--- /dev/null
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-06-07 Andreas Kupries <andreask@activestate.com>
+
+ * validate.tcl (snit::double, validate): Applied patch by Will
+ * pkgIndex.tcl: fixing the error message for max-limited
+ * snit.man: double types. Bumped versions to 2.3.2 and 1.4.2.
+ * snit.tcl: Extended testsuite.
+ * snit2.tcl:
+ * snit.test:
+
+2010-04-30 Andreas Kupries <andreask@activestate.com>
+
+ * snitfaq.man: Fixed typo in 'package require' commands, reported
+ by sigzero@gmail.com.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-11-16 Andreas Kupries <andreask@activestate.com>
+
+ * main2.tcl (::snit::RT.typemethod.destroy)
+ (::snit::RT.typemethod.info.instances):
+ * main1.tcl (::snit::RT.typemethod.info.instances)
+ (::snit::RT.typemethod.destroy): [Bug 2898640]. Fixed handling of
+ * snit.tcl: unrelated namespaces by restricting the set of
+ * snit2.tcl: children to look at. Bumped versions of v1 and v2 to
+ * pkgIndex.tcl: 1.4.1 and 2.3.1 respectively.
+ * snit.man:
+
+2009-11-02 Andreas Kupries <andreask@activestate.com>
+
+ * snit.tcl: Bumped versions of v1 and v2 to 1.4 and 2.3
+ * snit2.tcl: respectively, taking the backward compatible
+ * snit.man: API changes to validation types into account.
+ * pkgIndex.tcl:
+
+2009-10-31 Will Duquette <will@wjduquette.com>
+
+ * validate.tcl: Updated all Snit validation types to return the
+ * snit.tcl: validated value, and to throw -errorcode INVALID
+ on error.
+ * snit.man: Relevant changes.
+
+2009-09-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snit.test: Updated to handle changes in command error messages
+ done in Tcl 8.6+.
+
+2009-09-28 Andreas Kupries <andreask@activestate.com>
+
+ * snit.man: Committed a long-standing fix to a bug in the
+ * snit.tcl: last entry. Wrap the close commands into catch
+ * snit2.tcl: to handle the possibility of the std channels
+ * pkgIndex.tcl: not existing. Bumped versions to 1.3.4 and
+ * main1_83.tcl 2.2.4.
+ * main1.tcl:
+ * main2.tcl:
+
+2009-06-22 Andreas Kupries <andreask@activestate.com>
+
+ * main1.tcl: Fix handling of hierarchical typemethods for missing
+ * main1_83.tcl: subcommands. If a toplevel hmethod is not found
+ * main2.tcl: we can assume it to be an instance name and do an
+ * pkgIndex.tcl: implicit 'create' of it. If the toplevel hmethod
+ * snit.tcl: has already been accepted however a missing submethod
+ * snit2.tcl: has to error out, an implicit create is not possible
+ * snit.test: any longer. Extended the testsuite to cover this
+ case. Bumped the package versions to 2.2.3, and 1.3.3.
+
+2009-04-21 Andreas Kupries <andreask@activestate.com>
+
+ * main1.tcl (::snit::Comp.Init): Close unused standard channels
+ * main1_83.tcl (::snit::Comp.Init): to prevent the internal compile
+ * main2.tcl (::snit::Comp.Init): interp from blocking a close/open
+ * snit.tcl: dance to replace them in the main interp. Bumped the
+ * snit2.tcl: packages to versions 1.3.2 and 2.2.2 respectively.
+ * pkgIndex.tcl:
+
+2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11.1 ========================
+ *
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-08-20 Will Duquette <will@wjduquette.com>
+
+ * snitfaq.man: Finished up [SF Tcllib Bug 1658089].
+
+2008-05-16 Andreas Kupries <andreask@activestate.com>
+
+ * snitfaq.man: Fixed the sectref argument order issues.
+
+2008-05-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snitfaq.man: Updated to changes in doctools (sub)section
+ reference handling.
+
+2007-12-04 Andreas Kupries <andreask@activestate.com>
+
+ * snit.test: Updated some results to changes in the Tcl 8.5
+ head. This fixes [SF Tcllib Bug 1844106], reported by Larry
+ Virden <lvirden@users.sourceforg.net>. Thanks.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-20 Andreas Kupries <andreask@activestate.com>
+
+ * snit.test: Fixed bad indices in tests causing the generation of
+ bogus expected error messages.
+
+2007-07-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * main1_83.tcl (::snit::Comp.statement.oncget): Fixed double
+ * main1.tcl (::snit::Comp.statement.oncget): import of instance
+ * main2.tcl (::snit::Comp.statement.oncget): and type variables.
+ * snit.man: Bumped versions to 1.3.1 and 2.2.1 respectively.
+ * pkgIndex.tcl:
+ * snit.tcl:
+ * snit2.tcl:
+
+2007-07-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snit.test: Snit versions bumped to 1.3 and 2.2. Extended
+ * snit.man: 'info' method and typemethod with sub-methods
+ * snitfaq.man: 'args', 'body' and 'default' to query method
+ * main1.tcl: arguments, argument defaults, and bodies.
+ * main1_83.tcl:
+ * main2.tcl:
+ * pkgIndex.tcl:
+
+2007-06-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snitfaq.man: Replaced deprecated {expand} with {*}.
+
+2007-05-01 Andreas Kupries <andreask@activestate.com>
+
+ * main2.tcl: [Bug 1710640]. Replaced deprecated {expand} with {*}.
+
+ * snit.test: Updated to changes in 8.5a6.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snit.man: Fixed all warnings due to use of now deprecated
+ * snitfaq.man: commands. Added a section about how to give
+ feedback.
+
+2007-02-12 Andreas Kupries <andreask@activestate.com>
+
+ * snitfaq.man: Fixed typos, etc. reported in [Bug 1658089].
+
+2006-10-19 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * snit.man, main1.tcl, main1_83.tcl, main2.tcl: Allow -class to be
+ passed to snit::widget. [Patch 1580120]
+ * pkgIndex.tcl, snit.tcl, snit2.tcl: Bumped versions to 1.2.1 / 2.1.1.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-20 Will Duquette <will@wjduquette.com>
+ * pkgIndex.tcl, snit2.tcl, snit.man, snitfaq.man, README.txt:
+ Bumped the version number from 2.0 to 2.1, per Andreas' request.
+ Also, added details about the implications of 2.1's use of
+ [namespace path] to README.txt and the Snit FAQ.
+
+2006-09-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snit_tcl83_utils.tcl: Made the initialization of the
+ compatibility system a bit more robust against loading it
+ multiple times.
+
+2006-09-11 Will Duquette <will@wjduquette.com>
+ * main2.tcl: Comp.statement.typevariable now places the type name
+ directly in the "tvprocdec" rather than waiting to substitute it
+ in later.
+
+2006-08-19 Will Duquette <will@wjduquette.com>
+ * main2.tcl, snit.test: Fixed Bug 1483168: "Namespaced snit objs
+ are not commands in their ns". In particular, Snit 2.x types and
+ widgets now use [namespace path] to give themselves access to
+ their parent namespace.
+ * snit.man,snitfaq.man: Updated accordingly; also, fixed a couple
+ of typos in snitfaq.man.
+
+ * main2.tcl: Snit 2.x now uses [namespace upvar] where appropriate
+ throughout the Snit run-time and also for implicit declaration of
+ instance variables; I still need to use it for implicit
+ declaration of type variables. On my machine, dispatch of a
+ method with 10 instance variables is over twice as fast
+ when the variables are declared using [namespace upvar] rather
+ than [::variable ${selfns}::varname].
+
+ * main2.tcl: Snit 2.x now uses [namespace upvar] for implicit
+ declaration of type variables as well. It develops that
+ [namespace upvar] is a lot faster than [::variable] even when
+ using the default namespace (e.g., "::variable varname").
+
+2006-08-15 Will Duquette <will@wjduquette.com>
+ * main2.tcl, snit.test: Fixed Bug 1532791: "snit2,
+ snit::widget problem".
+
+2006-08-12 Will Duquette <will@wjduquette.com>
+ * main1.tcl, main1_83.tcl, main2.tcl: Replaced as many [string equal] calls
+ in main1_83.tcl with {"" ==/!= $a} expressions, so that the
+ differences between the two files are minimized. Also removed the
+ "-glob" from calls to "array names" in main1.tcl. There are now
+ only a few remaining differences between the two files.
+
+ Also, I added a "return" to the end of RT.DestroyObject in all
+ three "main" modules, to prevent a confusing return value from
+ "$object destroy" that Andreas noticed a while back.
+
+ * snit.test: Two tests, iinfo-6.4 and iinfo-6.5, failed on Tcl
+ 8.3. The -result in both cases was a list of Tk widget options
+ that included some new options defined in Tcl 8.4. I added two
+ new constraints, tcl83 and tcl84, and duplicated the two tests,
+ one for each.
+
+2006-08-10 Will Duquette <will@wjduquette.com>
+ * snit.man: Added documentation for how to define new
+ validation types.
+
+2006-08-09 Will Duquette <will@wjduquette.com>
+ * snit.man: Added documentation for the "-type" option-definition
+ option, and for the validation types. I still need to fill in a
+ section on defining new validation types.
+ * validate.tcl: Cleaned up the header comment.
+
+2006-08-08 Will Duquette <will@wjduquette.com>
+ * main1.tcl: Removed all "eq" and "ne" expressions, to reduce
+ the differences between main1.tcl and main1_83.tcl. Unlike
+ main1_83.tcl, though, I used the forms {"" == $a} and
+ {"" != $a} in preferences to [string equal], as they are
+ both shorter and more efficient. I used [string equal]
+ only when comparing two variables. The next step is
+ to update main1_83.tcl to use the {"" ==/!= $a} form
+ where possible, in preference to [string equal]; then,
+ most of the code can be shared between the two modules,
+ which will simplify maintenance.
+
+2006-08-07 Will Duquette <will@wjduquette.com>
+ * Implemented "-type" option-definition option in main2.tcl,
+ for Snit 2.x, and main1_83.tcl for Snit 1.2 on Tcl 8.3.
+
+2006-08-06 Will Duquette <will@wjduquette.com>
+ * Major reorganization of the code modules. snit.tcl and
+ snit2.tcl are now just short loader scripts. The Snit 1.x
+ compiler and run-time library are implemented in main1.tcl and
+ main1_83.tcl, respectively; the Snit 2.x compiler and run-time
+ are in main2.tcl. Both loaders load validate.tcl, which contains
+ the new validation types. This scheme is documented in
+ modules.txt.
+
+ * Bumped the Snit 1.x version number to Snit 1.2, since
+ Snit 1.1 has been a robust, stable release.
+
+ * snit83.tcl: Removed; obsolete
+ * snit84.tcl: Removed; obsolete
+
+ * snit.tcl, main1_83.tcl: snit_tcl83_utils.tcl is now sourced in
+ snit.tcl rather than main1_83.tcl. I don't believe this should
+ cause a problem....but it needs to be tested.
+
+ * snit.test: Added tests for Snit validation types. These tests
+ pass for Snit 2.x and for Snit 1.2 with Tcl 8.4. They *should*
+ pass for Snit 1.2 with Tcl 8.3, but I've been unable to test that.
+
+ * README.txt: Updated
+
+ * main1.tcl, snit.test: Implemented the "-type" option-definition
+ option for Snit 1.2 and Tcl 8.4, and added related tests.
+
+ * Still to do:
+ 1. Implement the "-type" option-definition option in
+ main1_83.tcl and main2.tcl.
+ 2. Write documentation for "-type" and for the Snit
+ validation types.
+ 3. Consider refactoring main1.tcl, main1_83.tcl for
+ maximum commonality, to simplify future changes of
+ this kind.
+
+2006-08-05 Will Duquette <will@wjduquette.com>
+ * validate.tcl: New module; defines a number of "validation
+ types". These will be used with the forthcoming "-type"
+ option-definition option to add robust validation for snit::type
+ and snit::widget options.
+
+2006-07-26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snitfaq.man: Finally fixed the two ambigous section titles.
+
+2006-01-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snit.tcl: Fixed [SF Tcllib Bug 1414589], prevent the package
+ activation code from stomping on the global variable 'dir'.
+
+2006-01-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snit.test: Fixed use of duplicate test names. Whitespace police
+ as well.
+
+2006-01-26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snit.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snit.test: Hooked into the new common test support
+ code. Reactivated the tests based on the commands wrongNumArgs
+ and tooManyArgs. Coming out of the new test support code.
+
+2006-01-14 Will Duquette <will@wjduquette.com>
+
+ * snit2.tcl (::snit::RT.UnknownMethod): When creating a new
+ submethod ensemble, creates it in the ${selfns} namespace
+ instead of in the ${type} namespace (fix courtesy of
+ Anton Kovalenko). Previously, multiple objects of a type that
+ defines a submethod ensemble would share a single ensemble,
+ with confusing results.
+ * snit.test: Added test hmethod-1.6, to test for the above error.
+ As expected, there was no error in snit 1.1, but the test failed
+ in snit 2.0 until the above change was made.
+ * snit.test: "if 0"'d out some tests that make use of
+ tcltest::tooManyArgs and tcltest::wrongNumArgs, two commands
+ that aren't available to me.
+
+ * snitfaq.man: Fixed a typo and added a suggestion from
+ Andreas Kupries on how to name component commands.
+
+ * snit.man: Added Kenneth Green and Anton Kovalenko to the list
+ of names in the "Credits".
+
+2005-12-05 Andreas Kupries <andreask@activestate.com>
+
+ * snit83.tcl: Replaced the direct use of / path separator with a
+ proper file join.
+
+2005-11-07 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Moved the selection of the implementation out of
+ the package declaration into the runtime.
+
+ * snit.tcl: Renamed to snit84.tcl. Also a new file containing
+ the selection of the implementation, basic dependency, and
+ common provide command.
+
+ * snit84.tcl: New file. Was originally named 'snit.tcl'. Contains
+ the Tcl 8.4 specific implementation of the package.
+
+ * snit.test: Updated to new entrypoint for snit 1.1.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-26 Andreas Kupries <andreask@activestate.com>
+
+ * snit.test: Adapted the testsuite to handle the 8.3 backport.
+
+ * snit83.tcl: Integrated Kenneth Green's backport of
+ * snit_tcl83_utils.tcl: Snit to Tcl 8.3 into the code base.
+
+ * snit.tcl: Checking the list result of [info commands ] now using
+ [llength] instead of string comparisons.
+
+ * snit2.tcl: Checking the list result of [info commands ] now using
+ [llength] instead of string comparisons.
+
+2005-09-05 Will Duquette <will@wjduquette.com>
+
+ * snitfaq.man: Updated for Snit 2.0/1.1.
+
+2005-08-27 Will Duquette <will@wjduquette.com>
+
+ * snit.man: Updated for Snit 2.0/1.1
+ * snit.tcl: Added the new hulltypes to snit.tcl (somehow they
+ didn't get in).
+ * snit.test: Added a test that verifies the list of valid
+ hulltypes.
+
+2005-08-22 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * snit.tcl, snit2.tcl: allow labelframe and ttk::labelframe as
+ hulltypes, and tk::(label)frame (planning ahead ...)
+
+2005-08-20 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl: It's now an error to call an object's "destroy" method
+ in the object's constructor.
+ * snit2.tcl: Snit 2.0, implemented with "namespace ensemble".
+ * snit.test: Now uses the "-body" style of Tcltests throughout.
+ Also, tests Snit 1.x (snit.tcl) when run with Tcl/Tk 8.4, and
+ tests Snit 2.x when run with Tcl/Tk 8.5.
+
+2005-08-10 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * snit.tcl (::snit::Comp.statement.hulltype): make hulltype one of
+ $::snit::hulltypes, allow ttk::frame
+
+2005-06-07 Will Duquette <will@wjduquette.com>
+
+ * snit.test (bug-2.1, bug-2.2): Added the "tk" constraint, so that
+ they'll be excluded when snit.test is run with tclsh.
+
+2005-06-04 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl, snit.man, snitfaq.man: Updated the copyright
+ information to 2005.
+ * snit.html, faq.html: Removed these files, as they are obsolete.
+ snit.man and snitfaq.man contain the up-to-date documentation.
+
+2005-06-04 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl: Bumped the version number to 1.0
+ * pkgIndex.tcl: Bumped the version number to 1.0.
+ * dictionary.txt: Bumped the version number to 1.0.
+ * snit.man: Bumped the version number to 1.0.
+ * snitfaq.man: Bumped the version number to 1.0.
+
+2005-06-04 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl (::snit::RT.DestroyObject)
+ * snit.test (test bug-2.1, bug-2.2):
+ Fixed [SF Tcllib Bug 1106375].
+
+2005-06-04 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl (::snit::Comp.statement.destructor):
+ * snit.test (test bug-1.1)
+ Fixed [SF Tcllib Bug 1161779].
+
+2005-06-04 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl: Checked a number of small optimizations Jeff Hobbs
+ sent me. Bumped the version number to 0.98.
+ * pkgIndex.tcl: Bumped the version number to 0.98.
+ * dictionary.txt: Bumped the version number to 0.98.
+ * snit.man: Bumped the version number to 0.98.
+ * snitfaq.man: Bumped the version number to 0.98.
+
+2005-04-11 Marty Backe <marty@lucidway.org>
+
+ * snit.man: Fixed typo in the -configuremethod example.
+
+2005-02-14 Andreas Kupries <andreask@activestate.com>
+
+ * snitfaq.man: Fixed a number of typos reported by Bob Techentin,
+ see [SF Tcllib Bug 1050674].
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-09-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snit.test: Fixed the tests which were dependent on the exact
+ order of results returned by [array names]. Which failed for Tcl
+ 8.5. Added lsort and updated expected results, for canonical
+ comparison.
+
+2004-09-18 Will Duquette <will@wjduquette.com>
+
+ * snit.man: Documented hierarchical methods and typemethods.
+
+ * Everything: Updated version to 0.97.
+
+2004-09-16 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl In "component foo -public name", the "-public
+ name" part is now implemented as "delegate method
+ {name *} to foo".
+ * snit.test Added tests for "$type info typemethods", "$self
+ info typemethods" and "$self info methods" for the
+ case of hierarchical methods/typemethods, and
+ fixed related bugs in snit.tcl.
+
+2004-09-14 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Modified the implementation of hierarchical methods;
+ * snit.test this involved extending the syntax of method
+ "using" patterns to better support the
+ hiearchical case.
+
+ * snit.tcl Extended the "delegate method *" and
+ * snit.test "delegate typemethod *" syntax to work better with
+ hierarchical methods.
+ E.g., "delegate method {tail *} to tail" now maps
+ "$self tail wag" to "$tail wag"
+
+2004-09-12 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Added support for hierarchical type methods,
+ * snit.test analogously to the support for regular methods.
+ * README.txt
+
+ * snit.tcl Refactored the compilation of hierarchical
+ * snit.test methods and typemethods to remove duplicated code.
+
+2004-09-10 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Added support for hierarchical methods: methods
+ * snit.test with submethods. The documentation has not yet
+ * README.txt been updated.
+
+ * snit.tcl Bug fix: "delegate method {a b} to comp" now produces
+ * snit.test the call "$comp a b" instead of "$comp a_b".
+
+2004-09-04 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Bug fix: read-only options were read-only only
+ * snit.test if they weren't set at creation time; the
+ * README.txt configure cache wasn't being cleared properly
+ after creation.
+
+2004-08-28 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl: Minor tweaks to instance creation to improve
+ * dictionary speed. No major gain. Also, -simpledispatch yes
+ * snit.man now supports instance renaming again.
+ * snitfaq.man
+
+
+2004-08-22 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Defined the -simpledispatch pragma. Updated
+ * snit.test the test suite and the relevant documentation.
+ * snit.man
+ * README.txt
+ * snitfaq.man
+ * dictionary
+
+2004-08-14 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Defined the -hastypemethods pragma, and added
+ * snit.test relevant tests and documentation.
+ * snit.man
+ * README.txt
+ * snitfaq.man
+
+2004-08-12 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Under appropriate conditions, calling a
+ * snit.test snit::type command with no arguments will create
+ * snit.man an instance with an automatically generated name.
+ * README.txt
+
+2004-08-11 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Added the -hasinfo pragma, along with the
+ * snit.test appropriate tests. Updated documentation.
+ * snit.man
+ * README.txt
+
+ * snit.tcl The "configure", "configurelist" and "cget"
+ * snit.test instance methods, along with the "options"
+ * snit.man instance variable, are defined only if the
+ * README.txt type defines at least one option (either
+ locally or by delegation).
+
+2004-08-07 Will Duquette <will@wjduquette.com>
+
+ * All files Updated to Snit V0.96 for post-0.95 development.
+ Fixed bug: methods called via [mymethod] can now
+ return exotic return codes, e.g.,
+ "return -code break"
+
+2004-08-04 Will Duquette <will@wjduquette.com>
+
+ * snitfaq.man Updated the Snit FAQ document.
+
+ * snit.man Finalized Snit V0.95, and updated the version number
+ * snit.tcl throughout.
+ * pkgIndex.tcl
+ * README.txt
+
+2004-07-27 Will Duquette <will@wjduquette.com>
+
+ * snit.man Updated the manpage to describe the new "pragma"
+ statement. Also, changed the SNIT acronym in the
+ title to "Simple Now In Tcl", i.e., objects are
+ now simple.
+
+ * snit.tcl Added another pragma, -canreplace. If false
+ * snit.test (the default) snit::types can no longer create
+ * README.txt instances which replace existing Tcl commands.
+ * snit.man Setting "pragma -canreplace yes" restores the
+ * dictionary previous behavior.
+
+ * snit.tcl The type definition statements "variable" and
+ * snit.test "typevariable" now take a "-array" option that
+ * README.txt allows them to initialize array variables with
+ * snit.man an "array set" list.
+
+ * snit.test Fixed Snit bug 899207 (snit test failures)
+
+ * snit.tcl Added new instance introspection methods
+ * snit.test "info typemethods" and "info methods", and a new
+ * README.txt type introspection typemethod "info typemethods".
+ * snit.man
+ * roadmap.txt
+
+ * snit.man Reviewed the entire man page, and made copious
+ changes and fixes.
+
+ * snit.tcl Revised many of the error messages to be more
+ * snit.test Tcl/Tk-like. Double-quotes are used instead of
+ single quotes, and terminal periods are omitted.
+
+ * snit.tcl Added some code to method and typemethod dispatch
+ * snit.test so that the return code (e.g., return -code break)
+ returned by the method/typemethod code is passed
+ along unchanged. This is mostly so that methods
+ and typemethods can conditionally break in event
+ bindings.
+
+2004-07-26 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Implemented -configuremethod and configure command
+ * snit.test caching; added tests to ensure that the cache is
+ * roadmap.txt cleared when necessary. Implemented -validatemethod
+ * dictionary and added tests. Implemented -readonly and added
+ * README.txt tests.
+
+ * snit.man Updated the man page with the new option
+ definition syntax.
+
+ * snit.tcl Added the "pragma" statement, and three pragma
+ * snit.test options, -hastypeinfo, -hastypedestroy, and
+ * roadmap.txt -hasinstances, plus related tests. It still
+ * dictionary needs to be documented.
+
+2004-07-25 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Renamed some procs for clarity, and repaired some
+ * roadmap.txt omissions in roadmap.txt. Added "cget" command
+ * snit.test caching for additional speed-up.
+ * dictionary.txt
+
+2004-07-24 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl (::snit::RT.MethodCacheLookup): The cached command
+ is now generated as a list, not a string; this
+ improves the speed of method invocation by quite a
+ bit.
+
+2004-07-24 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Consolidated the option typevariables into a
+ * dictionary single array, Snit_optionInfo. Implemented
+ * roadmap.txt parsing of the new option definition syntax;
+ * snit.test the -validatemethod, -configuremethod, and
+ -cgetmethod options as yet have no effect.
+ Added tests to ensure that the 'option' and
+ 'delegate option' statements populate
+ Snit_optionInfo properly.
+
+ Added "starcomp" to the Snit_optionInfo array.
+ When "delegate option *" is used, "*" no longer
+ has a "target-$opt" entry, nor does it appear
+ in "delegated-$comp". Instead, "starcomp" is the
+ name of the component to which option "*" is
+ delegated, or "".
+
+ Reimplemented user-defined "cget" handlers using
+ the "-cgetmethod" option definition option.
+ The "oncget" statement now defines a method, and
+ sets the option.
+
+2004-07-21 Will Duquette <will@wjduquette.com>
+
+ * README.txt Updated to reflect recent changes.
+ * snit.man
+
+2004-07-20 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Finished the refactoring job. All extraneous
+ * roadmap.txt code has been moved from the type templates to the
+ ::snit:: runtime.
+
+2004-07-19 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Refactored %TYPE%::Snit_optionget to
+ * roadmap.txt ::snit::RT.OptionDbGet. Refactored
+ %TYPE%::Snit_cleanup to ::snit::RT.DestroyObject,
+ %TYPE%::Snit_tracer to ::snit::RT.InstanceTrace,
+ and %TYPE%::Snit_removetrace to
+ ::snit::RT.RemoveInstanceTrace.
+
+2004-07-17 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Added "delegate typemethod ..." in all its glory,
+ * snit.test including "delegate typemethod *". Made it
+ * dictionary.txt Possible to delegate an instance method to a
+ * roadmap.txt typecomponent. Added tests to ensure that
+ variable/typevariable and component/typecomponent
+ names do not collide. Updated a number of
+ compilation error messages for consistency.
+ Moved the remaining typemethod definitions from the
+ template code and replaced them delegations to
+ the Snit runtime library. Added/modified
+ relevant tests, and updated the roadmap and
+ dictionary files.
+
+2004-07-15 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Replaced the old typemethod definition and
+ cacheLookup code with new pattern-based code, just
+ like the method definition and lookup. The
+ cache lookup routine doesn't yet understand
+ typemethod "*". The next step is to implement
+ typecomponents and "delegate typemethod".
+
+ * dictionary.txt Documented the changes related to the above
+ change.
+
+2004-07-14 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Replaced %TYPE%::Snit_comptrace with
+ snit::RT.ComponentTrace.
+
+ Replaced %TYPE%::Snit_cacheLookup with
+ snit::RT.MethodCacheLookup
+
+ Replaced %TYPE%::Snit_typeCacheLookup with
+ snit::RT.TypemethodCacheLookup
+
+ * snit.test Added a test to verify that a widget's hull
+ component cannot be altered once it is set.
+
+ * roadmap.txt Documents the internal structure of snit.tcl.
+
+2004-07-11 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Renamed a number of internal commands, for
+ clarity.
+
+ Refactored the standard method bodies
+ out of the type definition and into the Snit
+ runtime using delegation.
+
+ Defined snit::compile which compiles a
+ type definition into the Tcl script which
+ actually defines the type.
+
+ * snit.test Added and modified appropriate tests.
+
+ * README.txt Added a bullet about snit::compile.
+
+2004-07-05 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Replaced the old method cacheLookup code with new
+ code based on command patterns. All tests pass;
+ no test changes were needed. All is now ready to
+ add the new "delegate method" "using" keyword.
+ * dictionary.txt
+ This file documents Snit's private variables.
+ It's up-to-date, and checked in for the first
+ time.
+
+ * snit.tcl Implemented the new "using <pattern>" clause to
+ * snit.test "delegate method", and added relevant tests.
+
+ * snit.man Documented the new "delegate method" syntax.
+ * README.txt
+
+2004-07-04 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Re-implemented the option and method delegation
+ * snit.test syntax so that the order of clauses is no longer
+ important. Along the way, I made the relevant
+ error messages more specific.
+
+2004-06-26 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl Added the "component" statement, with two options,
+ * snit.test -public and -inherit. Added all relevant tests.
+ * snit.man Updated the man page to describe it.
+
+2004-05-30 Will Duquette <will@wjduquette.com>
+
+ * snit.man Updated per 0.94 changes to date; also I made a
+ sweep through the whole document and cleaned
+ things up here and there for readability.
+
+2004-05-29 Will Duquette <will@wjduqette.com>
+
+ * snit.tcl Moved Snit_component to snit::Component.
+
+ Removed the "type" argument from all of the
+ "Type.*" procs. Instead, the compilation type
+ is available as $compile(type). Consequently,
+ the Type.* procs can now be aliased into the
+ compiler just once, instead of with every type
+ definition. (Did that.)
+
+ Defined snit::macro.
+
+ * snit.test Added tests for snit::macro.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-15 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl: Updated version to 0.94
+ * pkgIndex.tcl:
+
+ * snit.tcl: Modified the Snit_dispatcher function to
+ use a method command cache. Method commands
+ are assembled in Snit_cacheLookup only if
+ they aren't found in the cache. The
+ new Snit_dispatcher was much shorter,
+ so its code was moved into the object's
+ instance command, and Snit_dispatcher
+ was deleted altogether. These changes
+ speed up method calls considerably.
+
+ Snit_tracer was then modified to clear the
+ method cache when the instance command is
+ renamed--the cached commands contained the
+ old instance command name.
+
+ * snit.test: Components can be changed dynamically; the
+ method cache breaks this, because the
+ previous component's command is still
+ cached. Added a test that checks whether
+ the method cache is cleared properly when
+ a component is changed.
+
+ * snit.tcl: Snit_comptrace now clears the method cache
+ when a component is redefined.
+
+ * snit.tcl: Added a type method cache. Type methods
+ (with the exception of implicit "create") are
+ now as fast as instance methods. This is a
+ naive implementation, though--for typemethods,
+ the cache could be populated at definition
+ time, since there's no delegation. Of course,
+ if I added typemethod delegation then what I'm
+ doing is appropriate.
+
+ * snit.tcl: Reorganized some things, in preparation to move
+ shared code from the type definition to the
+ snit:: namespace.
+
+ * snit.tcl: Made %TYPE%::mymethod an alias to snit::MyMethod.
+
+ * snit.tcl: Added %TYPE%::myproc, as an alias to
+ * snit.test: snit::MyProc. "codename" is now deprecated.
+ Added tests for myproc.
+
+ * snit.tcl: %TYPE%::codename is now an alias to
+ snit::CodeName.
+
+ * snit.tcl: Added %TYPE%::myvar and %TYPE%::mytypevar; these
+ replace %TYPE%::varname and %TYPE%::typevarname,
+ which are now deprecated. All are now implemented
+ as aliases to calls in snit::.
+
+ * snit.tcl: %TYPE%::variable is now an alias to
+ snit::variable.
+
+ * snit.tcl: %TYPE%::from is now an alias to snit::From.
+
+2004-02-26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snit.test: Codified the requirement of Tcl 8.4 into
+ * pkgIndex.tcl: package index and test suite.
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-07 Will Duquette <will@wjduquette.com>
+
+ * README.txt: Added 0.93 information to README.txt.
+
+ * snit.tcl: Fixed bug: "$obj info vars" used to leave out "options"
+ * snit.test: if no options were defined. It's clearer if the
+ behavior is always the same.
+
+ Fixed tcllib bugs item #852945: variable. The
+ statement "variable ::my::qualified::name" in an
+ instance method now makes "name" available, just
+ as the standard "variable" command does.
+
+ Fixed bug: in some cases the type command was
+ created even if there was an error defining the
+ type. The type command is now cleaned up in these
+ cases. (Credit Andy Goth)
+
+ * snit.tcl: Implemented RFE 844766: need ability to split class
+ * snit.test: defs across files. Added the snit::typemethod and
+ * snit.html: snit::method commands; these allow typemethods and
+ methods to be defined after the class already exists.
+
+2004-02-07 Will Duquette <will@wjduquette.com>
+
+ * All: Updated version to 0.93.
+ * snit.tcl: The %AUTO% name counter wraps around to 0 when it
+ reaches 2^31 - 1, to prevent integer overflow
+ errors.
+ * snit.html: Minor corrections and updates.
+ * faq.html
+
+2003-12-06 Will Duquette <will@wjduquette.com>
+
+ * All: Updated version to 0.92.
+
+ * snit.tcl Snit now propagates errorCode properly when
+ * snit.test propagating errors.
+
+2003-12-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * snit.man: Updated to changes in the .html files.
+ * snitfaq.man:
+
+2003-11-21 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl: Updated version to 0.91.
+ * pkgIndex.tcl:
+
+ * snit.tcl: Added the "expose" statement to type and widget
+ definitions.
+ * snit.test: Added appropriate tests.
+ * snit.html: Added documentation for "expose".
+ * faq.html: Updated the FAQ entries.
+
+ * snit.tcl: Added "string match" patterns to the Snit info
+ methods.
+ * snit.test: Added appropriate tests.
+ * snit.html: Updated documentation.
+
+
+2003-10-28 Andreas Kupries <andreask@activestate.com>
+
+ * snit.man: Fixed typos in documentation.
+ * snitfaq.man:
+
+2003-10-27 Will Duquette <will@wjduquette.com>
+
+ * snit.html: Fixed typos in documentation.
+ * faq.html:
+
+2003-10-27 Andreas Kupries <andreask@activestate.com>
+
+ * snit.man: Updated to changes in the .html files.
+ * snitfaq.man:
+
+2003-10-25 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl: Added the "except" clause for "delegate method *" and
+ * snit.test: "delegate option *". This allows the user to
+ explicitly exclude certain methods and options.
+ Added appropriate tests.
+
+ * snit.html: Gave the Snit FAQ a bit of an overhaul, and added
+ * faq.html: information corresponding to the recent code
+ changes, including a great deal of material on Snit
+ and the Tk option database. Updated the Snit man
+ page to be consistent with the recent code changes.
+
+2003-10-23 Andreas Kupries <andreask@activestate.com>
+
+ * snit.man: Updated from Will's html doc's.
+
+2003-10-23 Will Duquette <will@wjduquette.com>
+
+ * snit.html: Added documentation for the new "hulltype",
+ "widgetclass", and "install" commands. Updated the
+ documentation for "installhull" to show the new
+ "installhull using" syntax. Updated the
+ documentation for "option" and "delegate option" to
+ show how to specify the resource and class names for
+ options. Added a section on the interaction between
+ Snit and the Tk option database.
+
+2003-10-21 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl: Add the "hulltype" command. This allows the snit::widget
+ * snit.test: author to choose whether the hull should be a frame
+ or a toplevel. Tests have been updated as usual.
+
+2003-10-20 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl: The new "install" command can now be used to install
+ * snit.test: components for snit::types as well. It doesn't add
+ any value, since there's no option database, but at
+ least the syntax will be the same.
+
+ "install" now initializes the component properly
+ from the option database when "option *" has been
+ delegated to it.
+
+ Tests have been updated as usual.
+
+2003-10-19 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl: During normal widget creation, the default values
+ * snit.test: for a widget's local options are overridden by
+ values from the option database.
+
+ Array %TYPE%::Snit_compoptions now lists delegated
+ option names for each component.
+
+ Added a new command, "install", for use in widget
+ and widgetadaptor constructors. Install creates a
+ widget, assigning it to a component; it also queries
+ the option database for any option values that are
+ delegated to this component.
+
+ Modified installhull, adding a new form that queries
+ the option database as appropriate for options
+ delegated to the hull widget.
+
+ At this point, the only options whose default values
+ do not come from the option database in the proper
+ way are those implicitly delegated by "delegate
+ option *" to a non-hull widget. I need to think
+ about those.
+
+ Of course, new tests have been added for all of this.
+
+ The version number in snit.tcl has been updated to 0.84.
+
+2003-10-18 Will Duquette <will@wjduquette.com>
+
+ * snit.tcl: Added the "widgetclass" statement; this allows
+ * snit.test: snit::widgets (and nothing else) to explicitly set
+ the widget class name passed to the hull as "-class".
+ In addition, the hull's -class is set automatically,
+ to the explicit widgetclass, if any, or to the
+ widget type name with an initial capital letter.
+
+ Next, an object's options now have real resource
+ and class names, which are reported correctly by
+ "$obj configure". By default, the resource name
+ is just the option name minus the hyphen, and
+ the class name is just the resource name with an
+ initial capital.
+
+ In both the "option" and "delegate option"
+ statements, the option name may be specified as
+ a pair or a triple, e.g.,
+
+ option {-name name Name}
+
+ Thus, the resource name and class name can be
+ specified explicitly.
+
+ In previous versions, the resource name and
+ class name returned by configure for delegated
+ options was the resource name and class name
+ returned by the component. This is no longer
+ true; configure now returns the resource and
+ class name defined in the type definition.
+
+2003-10-17 Will Duquette <will@wjduquette.com>
+
+ * snit.html: Added typeconstructor documentation.
+ * faq.html:
+
+ * snit.tcl: Implemented typeconstructors. A typeconstructor's
+ body is executed as part of the compiled type
+ definition; it has access to all of the typevariables
+ and typemethods. Its job is to initialize arrays,
+ set option database values, and like that.
+
+ * snit.test: Added tests for typeconstructors.
+
+2003-10-16 Will Duquette <will@wjduquette.com>
+
+ * README.txt: Updated to reflect snit's presence in tcllib, and
+ to point to this ChangeLog file.
+
+2003-09-30 Andreas Kupries <andreask@activestate.com>
+
+ * snit.tcl: A number of changes to the code generation part.
+ - Usage of [subst]'s was superfluous, removed, simple string
+ interpolation now.
+
+ - Now 'namespace eval type' enclosing the generated code
+ anymore. Such an eval is now done only at the top of the
+ generated code to define the namespace, and to
+ define/initialize the typevariables. All procedure definitions
+ are now outside of 'namespace eval' and use fully qualified
+ command names instead.
+
+ - Moved the code in [snit::Define] which instantiated the class
+ using the generated code into it own helper command,
+ [snit::DefineDo]. Overiding this command allows users of the
+ snit package perform other actions on the newly defined
+ class. One example is that of a snit-compiler which goes
+ through a file containing tcl code and replaces all snit::*
+ definitions with the generated code.
+
+ Motivation for the change: When applying procomp to procedure
+ definitions inside of a 'namespace eval' they are not
+ byte-compiled, but kept as encoded literal. This is a direct
+ consequence of 'namespace eval' not having a compile
+ function. It also means that introspection, i.e. [info body]
+ does recover the actual procedure definition. By using procedure
+ definitions outside of namespace eval, but fully qualified names
+ this limitation of procomp is avoided. The aforementioned snit
+ compiler application is another part for this, ensuring that
+ instead of keeping the whole class definition as one literal for
+ the snit::* call we actually have tcl code to compile and hide.
+
+ * snit.tcl: Updated the version number to 0.83
+ * pkgIndex.tcl:
+ * snit.man:
+ * snitfaq.man:
+
+2003-07-18 Andreas Kupries <andreask@activestate.com>
+
+ * snit.test: Fixed SF tcllib bug #772535. Instead of using a
+ * snit.tcl: variable reference in the callback a regular command
+ is called, with the unchanging 'selfns' as argument.
+ From there things go through the regular dispatching
+ mechanism after the actual instance name was obtained.
+ Updated all affected tests.
+
+ Updated dmethod-1.5 also, 'string' delivers a
+ different error message.
+
+2003-07-16 Andreas Kupries <andreask@activestate.com>
+
+ * snit.man: Added references to bug trackers, as part of
+ * snitfaq.man: caveats. Also added note about bwidget/snit
+ interaction.
+
+ * snit.tcl: Integrated latest (small) change to original code base
+ (was not released yet). Removes bad trial to fix up error stack.
+ We are now at version 0.82. Added note to developers explaining
+ the catch in Snit_tracer.
+
+2003-07-15 Andreas Kupries <andreask@activestate.com>
+
+ * snit.tcl: Imported new module into tcllib.
+ * snit.test: snit = Snit Is Not IncrTcl
+ * snit.html: Author: William Duquette
+ * faq.html: OO package + megawidget framework.
+ * README.txt:
+ * license.txt:
+ * pkgIndex.tcl:
+ * snit.man:
+ * snitfaq.man:
--- /dev/null
+#--------------------------------------------------------------------------
+# README.tcl83.txt
+#--------------------------------------------------------------------------
+# Back-port of Snit to Tcl83
+#--------------------------------------------------------------------------
+# Copyright
+#
+# Copyright (c) 2005 Kenneth Green
+# All rights reserved
+#--------------------------------------------------------------------------
+# This code is freely distributable, but is provided as-is with
+# no warranty expressed or implied.
+#--------------------------------------------------------------------------
+# Acknowledgements
+# 1) The changes described in this file are made to awesome 'snit'
+# library as provided by William H. Duquette under the terms
+# defined in the associated 'license.txt'.
+#--------------------------------------------------------------------------
+
+Snit is pure-Tcl object and megawidget framework. See snit.html
+for full details.
+
+It was written for Tcl/Tk 8.4 but a back-port to Tcl/Tk 8.3 has been
+done by Kenneth Green (green.kenneth@gmail.com).
+
+-----------------------------------------------------------------
+
+The back-port to Tcl 83 passes 100% of the snit.test test cases.
+It adds two files to the package, this README file plus the back-port
+utility file: snit_tcl83_utils.tcl.
+
+Very few changes were required to either snit.tcl or snit.test to
+get them to run with Tcl/Tk 8.3. All changes in those files are
+tagged with a '#kmg' comment.
+
+-----------------------------------------------------------------
+07-Jun-2005 kmg (Release 1.0.1)
+ Port of first full snit release 1.0
+ Passes 452/452 test cases in snit.test
+ Known problems:
+ 1) In some cases that I have not been able to characterise, an instance
+ will be destroyed twice causing an error. If this happens, try wrapping
+ your deletion of the instance in a catch.
+ 2) As a consequence of (1), one test case generates an error in its
+ cleanup phase, even though the test itself passes OK
+
+
+10-Feb-2005 kmg (Beta Release 0.95.2)
+ Fixed bug in 'namespace' procedure in snit_tcl83_utils.tcl.
+ Made it execute the underlying __namespace__ in the context
+ of the caller's namespace.
+
+28-Aug-2004 kmg (Beta Release 0.95.1)
+ First trial release of the back-port to Tcl/Tk 8.3
+ Snit will work fine on Tcl/Tk 8.4 but a few of the tests
+ will have to have the changes commented out and the original
+ code uncommented in order to pass.
--- /dev/null
+Snit's Not Incr Tcl README.txt
+-----------------------------------------------------------------
+
+Snit is pure-Tcl object and megawidget framework. See snit.html
+for full details.
+
+Snit is part of "tcllib", the standard Tcl Library.
+
+Snit lives in "tcllib" now, but it is available separately at
+http://www.wjduquette.com/snit. If you have any questions, bug
+reports, suggestions, or comments, feel free to contact me, Will
+Duquette, at will@wjduquette.com; or, join the Snit mailing list (see
+http://www.wjduquette.com/snit for details).
+
+Differences Between Snit 2.1 and Snit 1.x
+--------------------------------------------------------------------
+
+V2.0 and V1.x are being developed in parallel.
+
+ Version 2.1 takes advantage of some new Tcl/Tk 8.5 commands
+ ([dict], [namespace ensemble], and [namespace upvar]) to improve
+ Snit's run-time efficiency. Otherwise, it's intended to be
+ feature-equivalent with V1.x. When running with Tcl/Tk 8.5, both
+ V2.0 and V1.x are available; when running with Tcl/Tk 8.3 or Tcl/Tk
+ 8.4, only V1.x is available.
+
+ Snit 1.x is implemented in snit.tcl; Snit 2.1 in snit2.tcl.
+
+V2.1 includes the following enhancements over V1.x:
+
+* A type's code (methods, type methods, etc.) can now call commands
+ from the type's parent namespace without qualifying or importing
+ them, i.e., type ::parentns::mytype's code can call
+ ::parentns::someproc as just "someproc".
+
+ This is extremely useful when a type is defined as part of a larger
+ package, and shares a parent namespace with the rest of the package;
+ it means that the type can call other commands defined by the
+ package without any extra work.
+
+ This feature depends on the new Tcl 8.5 [namespace path] command,
+ which is why it hasn't been implemented for V1.x. V1.x code can
+ achieve something similar by placing
+
+ namespace import [namespace parent]::*
+
+ in a type constructor. This is less useful, however, as it picks up
+ only those commands which have already been exported by the parent
+ namespace at the time the type is defined.
+
+There are four incompatibilities between V2.1 and V1.x:
+
+* Implicit naming of objects now only works if you set
+
+ pragma -hastypemethods 0
+
+ in the type definition. Otherwise,
+
+ set obj [mytype]
+
+ will fail; you must use
+
+ set obj [mytype %AUTO%]
+
+* In Snit 1.x and earlier, hierarchical methods and type methods
+ could be called in two ways:
+
+ snit::type mytype {
+ method {foo bar} {} { puts "Foobar!"}
+ }
+
+ set obj [mytype %AUTO%]
+ $obj foo bar ;# This is the first way
+ $obj {foo bar} ;# This is the second way
+
+ In Snit 2.1, the second way no longer works.
+
+* In Snit 1.x and earlier, [$obj info methods] and
+ [$obj info typemethods] returned a complete list of all known
+ hierarchical methods. In the example just above, for example,
+ the list returned by [$obj info methods] would include
+ "foo bar". In Snit 2.1, only the first word of a hierarchical
+ method name is returned, [$obj info methods] would include
+ "foo" but not "foo bar".
+
+* Because a type's code (methods, type methods, etc.) can now
+ call commands from the type's parent namespace without qualifying
+ or importing them, this means that all commands defined in the
+ parent namespace are visible--and can shadow commands defined
+ in the global namespace, including the standard Tcl commands.
+ There was a case in Tcllib where the Snit type ::tie::std::file
+ contained a bug with Snit 2.1 because the type's own name
+ shadowed the standard [file] command in the type's own code.
+
+
+Changes in V1.2
+--------------------------------------------------------------------
+
+* Defined a family of validation types. Validation types are used
+ to validate data values; for example, snit::integer and its
+ subtypes can validate a variety of classes of integer value, e.g.,
+ integers between 3 and 9 or integers greater than 0.
+
+Changes in V1.1
+--------------------------------------------------------------------
+
+* It's now explicitly an error to call an object's "destroy" method
+ in the object's constructor. (If you need to do it, just throw
+ an error; construction will fail and the object will be cleaned
+ up.
+
+* The Tile "ttk::frame" widget is now a valid hulltype for
+ snit::widgets. Any widget with a -class option can be used
+ as a hulltype; lappend the widget name to
+ snit::hulltypes to enable its use as a hulltype.
+
+* The TK labelframe widget and the Tile ttk::labelframe widget are
+ now valid hulltypes for snit::widgets.
+
+Changes in V1.0
+--------------------------------------------------------------------
+
+Functionally, V1.0 is identical to version V0.97.
+
+* Added a number of speed optimizations provided by Jeff Hobbs.
+ (Thanks, Jeff!)
+
+* Returned to the name "Snit's Not Incr Tcl".
+
+* Fixed SourceForge Tcllib Bug 1161779; it's no longer an error
+ if the destructor is defined before the constructor.
+
+* Fixed SourceForge Tcllib Bug 1106375; the hull widget is now
+ destroyed properly if there's an error in the constructor of
+ a widget or widgetadaptor.
+
+Changes in V0.97
+--------------------------------------------------------------------
+
+The changes listed here were actually made over time in Snit V0.96;
+now that they are complete, the result has been renumbered Snit V0.97.
+
+* Bug fix: methods called via [mymethod] can now return exotic
+ return codes (e.g., "return -code break").
+
+* Added the -hasinfo pragma, which controls whether there's an
+ "info" instance method or not. By default, there is.
+
+* POSSIBLE INCOMPATIBILITY: If no options are defined for a type, neither
+ locally nor delegated, then Snit will not define the "configure",
+ "configurelist", and "cget" instance methods or the "options"
+ instance variable.
+
+* If a snit::type's command is called without arguments, AND the type
+ can have instances, then an instance is created using %AUTO% to
+ create its name. E.g., the following commands are all equivalent:
+
+ snit::type dog { ... }
+
+ set mydog [dog create %AUTO%]
+ set mydog [dog %AUTO%]
+ set mydog [dog]
+
+ This doesn't work for widgets, for obvious reasons.
+
+* Added pragma -hastypemethods. If its value is "yes" (the
+ default), then the type has traditional Snit behavior with
+ respect to typemethods. If its value is "no", then the type
+ has no typemethods (even if typemethods were included
+ explicitly in the type definition). Instead, the first argument
+ of the type proc is the name of the object to create. As above,
+ the first argument defaults to "%AUTO%" for snit::types but not
+ for snit::widgets.
+
+* Added pragma -simpledispatch. This pragma is intended to make
+ simple, heavily used types (e.g. stacks or queues) more efficient.
+ If its value is "no" (the default), then the type has traditional
+ Snit behavior with respect to method dispatch. If its value is
+ "yes", then a simpler, faster scheme is used; however, there are
+ corresponding limitations. See the man page for details.
+
+* Bug fix: the "pragma" statement now throws an error if the specified
+ pragma isn't defined, e.g., "pragma -boguspragma yes" is now an
+ error.
+
+* Bug fix: -readonly options weren't. Now they are.
+
+* Added support for hierarchical methods, like the Tk text widget's
+ tag, mark, and image methods. You define the methods like so:
+
+ method {tag add} {args} {...}
+ method {tag configure} {args} {...}
+ method {tag cget} {args} {...}
+
+ and call them like so:
+
+ $widget tag add ....
+
+ The "delegate method" statement also supports hierarchical methods.
+ However, hierarchical methods cannot be used with -simpledispatch.
+
+* Similarly, added support for hierarchical typemethods.
+
+Changes in V0.96
+--------------------------------------------------------------------
+
+V0.96 was the development version in which most of the V0.97 changes
+were implemented. The name was changed to V0.97 when the changes
+were complete, so that the contents of V0.97 will be stable.
+
+Changes in V0.95
+--------------------------------------------------------------------
+
+The changes listed here were actually made over time in Snit V0.94;
+now that they are complete, the result has been renumbered Snit V0.95.
+
+* Snit method invocation (both local and delegated) has been
+ optimized by the addition of a "method cache". The primary
+ remaining cost in method invocation is the cost of declaring
+ instance variables.
+
+* Snit typemethod invocation now also uses a cache.
+
+* Added the "myproc" command, which parallels "mymethod". "codename"
+ is now deprecated.
+
+* Added the "mytypemethod" command, which parallels "mymethod".
+
+* Added the "myvar" and "mytypevar" commands. "varname" is now
+ deprecated.
+
+* Added ::snit::macro.
+
+* Added the "component" type definition statement. This replaces
+ "variable" for declaring components explicitly, and has two nifty
+ options, "-public" and "-inherit".
+
+* Reimplemented the "delegate method" and "delegate option"
+ statements; among other things, they now have more descriptive error
+ messages.
+
+* Added the "using" clause to the "delegate method" statement. The
+ "using" clause allows the programmer to specify an arbitrary command
+ prefix into which the component and method names (among other
+ things) can be automatically substituted. It's now possible to
+ delegate a method just about any way you'd like.
+
+* Added ::snit::compile.
+
+* Added the "delegate typemethod" statement. It's similar to
+ "delegate method" and has the same syntax, but delegates typemethods
+ to commands whose names are stored in typevariables.
+
+* Added the "typecomponent" type definition statement. Parallel to
+ "component", "typecomponent" is used to declare targets for the new
+ "delegate typemethod" statement.
+
+* "delegate method" can now delegate methods to components or
+ typecomponents.
+
+* The option definition syntax has been extended; see snit.man. You
+ can now define methods to handle cget or configure of any option; as
+ a result, The "oncget" and "onconfigure" statements are now deprecated.
+ Existing "oncget" and "onconfigure" handlers continue to function as
+ expected, with one difference: they get a new implicit argument,
+ "_option", which is the name of the option being set. If your
+ existing handlers use "_option" as a variable name, they will need
+ to be changed.
+
+* In addition, the "option" statement also allows you to define a
+ validation method. If defined, it will be called before the value
+ is saved; its job is to validate the option value and call "error"
+ if there's a problem.
+
+* In addition, options can be defined to be "-readonly". A readonly
+ option's value can be set at creation time (i.e., in the type's
+ constructor) but not afterwards.
+
+* There's a new type definition statement called "pragma" that
+ allows you to control how Snit generates the type from the
+ definition. For example, you can disable all standard typemethods
+ (including "create"); this allows you to use snit::type to define
+ an ensemble command (like "string" or "file") using typevariables
+ and typemethods.
+
+* In the past, you could create an instance of a snit::type with the
+ same name as an existing command; for example, you could create an
+ instance called "::info" or "::set". This is no longer allowed, as
+ it can lead to errors that are hard to debug. You can recover the
+ old behavior using the "-canreplace" pragma.
+
+* In type and widget definitions, the "variable" and "typevariable"
+ statements can now initialize arrays as well as scalars.
+
+* Added new introspection commands "$type info typemethods",
+ "$self info methods", and "$self info typemethods".
+
+* Sundry other internal changes.
+
+Changes in V0.94
+--------------------------------------------------------------------
+
+V0.94 was the development version in which most of the V0.95 changes
+were implemented. The name was changed to V0.95 when the changes
+were complete, so that the contents of V0.95 will be stable.
+
+Changes in V0.93
+--------------------------------------------------------------------
+
+* Enhancement: Added the snit::typemethod and snit::method commands;
+ these allow typemethods and methods to be defined (and redefined)
+ after the class already exists. See the Snit man page for
+ details.
+
+* Documentation fixes: a number of minor corrections were made to the
+ Snit man page and FAQ. Thanks to everyone who pointed them out,
+ especially David S. Cargo.
+
+* Bug fix: when using %AUTO% to create object names, the counter
+ will wrap around to 0 after it reaches (2^32 - 1), to prevent
+ integer overflow errors. (Credit Marty Backe)
+
+* Bug fix: in a normal Tcl proc, the command
+
+ variable ::my::namespace::var
+
+ makes variable "::my::namespace::var" available to the proc under the
+ local name "var". Snit redefines the "variable" command for use in
+ instance methods, and had lost this behavior. (Credit Jeff
+ Hobbs)
+
+* Bug fix: in some cases, the "info vars" instance method didn't
+ include the "options" instance variable in its output.
+
+* Fixed bug: in some cases the type command was created even if there
+ was an error defining the type. The type command is now cleaned
+ up in these cases. (Credit Andy Goth)
+
+
+Changes in V0.92
+--------------------------------------------------------------------
+
+* Bug fix: In type methods, constructors, and methods, the "errorCode"
+ of a thrown error was not propagated properly; no matter what it was
+ set to, it always emerged as "NONE".
+
+Changes in V0.91
+--------------------------------------------------------------------
+
+* Bug fix: On a system with both 0.9 and 0.81 installed,
+ "package require snit 0.9" would get snit 0.81. Here's why: to me
+ it was clear enough that 0.9 is later than 0.81, but to Tcl the
+ minor version number 9 is less than minor version number 81.
+ From now on, all pre-1.0 Snit version numbers will have two
+ digits.
+
+* Bug fix: If a method or typemethod had an argument list which was
+ broken onto multiple lines, the type definition would fail. It now
+ works as expected.
+
+* Added the "expose" statement; this allows you to expose an entire
+ component as part of your type's public interface. See the man page
+ and the Snit FAQ list for more information.
+
+* The "info" type and instance methods now take "string match"
+ patterns as appropriate.
+
+Changes in V0.9
+--------------------------------------------------------------------
+
+For specific changes, please see the file ChangeLog in this directory.
+Here are the highlights:
+
+* Snit widgets and widget adaptors now support the Tk option database.
+
+* It's possible set the hull type of a Snit widget to be either a
+ frame or a toplevel.
+
+* It's possible to explicitly set the widget class of a Snit widget.
+
+* It's possible to explicitly set the resource and class names for
+ all locally defined and explicitly delegated options.
+
+* Option and method names can be excluded from "delegate option *" by
+ using the "except" clause, e.g.,
+
+ delegate option * to hull except {-borderwidth -background}
+
+* Any Snit type or widget can define a "type constructor": a body of
+ code that's executed when the type is defined. The type constructor
+ is typically used to initialize array-valued type variables, and to
+ add values to the Tk option database.
+
+* Components should generally be created and installed using the new
+ "install" command.
+
+* snit::widgetadaptor hulls should generally be created and installed
+ using the new "installhull using" form of the "installhull" command.
+
+See the Snit man page and FAQ list for more information on these new
+features.
+
+
+Changes in V0.81
+--------------------------------------------------------------------
+
+* All documentation errors people e-mailed to me have been fixed.
+
+* Bug fix: weird type names. In Snit 0.8, type names like
+ "hyphenated-name" didn't work because the type name is used as a
+ namespace name, and Tcl won't parse "-" as part of a namespace name
+ unless you quote it somehow. Kudos to Michael Cleverly who both
+ noticed the problem and contributed the patch.
+
+* Bug fix: Tcl 8.4.2 incompatibility. There was a bug in Tcl 8.4.1
+ (and in earlier versions, likely) that if the Tcl command "catch"
+ evaluated a block that contained an explicit "return", "catch"
+ returned 0. The documentation evidently indicated that it should
+ return 2, and so this was fixed in Tcl 8.4.2. This broke a bit
+ of code in Snit.
+
+Changes in V0.8
+--------------------------------------------------------------------
+
+* Note that there are many incompatibilities between Snit V0.8 and
+ earlier versions; they are all included in this list.
+
+* Bug fix: In Snit 0.71 and Snit 0.72, if two instances of a
+ snit::type are created with the same name, the first instance's
+ private data is not destroyed. Hence, [$type info instances] will
+ report that the first instance still exists. This is now fixed.
+
+* Snit now requires Tcl 8.4, as it depends on the new command
+ tracing facility.
+
+* The snit::widgettype command, which was previously deprecated, has
+ now been deleted.
+
+* The snit::widget command has been renamed snit::widgetadaptor; its
+ usage is unchanged, except that the idiom "component hull is ..."
+ is no longer used to define the hull component. Instead, use the
+ "installhull" command:
+
+ constructor {args} {
+ installhull [label $win ...]
+ $self configurelist $args
+ }
+
+* The "component" command is now obsolete, and has been removed.
+ Instead, the "delegate" command implicitly defines an instance
+ variable for the named component; the constructor should assign an
+ object name to that instance variable. For example, whereas you
+ used to write this:
+
+ snit::type dog {
+ delegate method wag to tail
+
+ constructor {args} {
+ component tail is [tail $self.tail -partof self]
+ }
+
+ method gettail {} {
+ return [component tail]
+ }
+ }
+
+ you now write this:
+
+ snit::type dog {
+ delegate method wag to tail
+
+ constructor {args} {
+ set tail [tail $self.tail -partof self]
+ }
+
+ method gettail {} {
+ return $tail
+ }
+ }
+
+* There is a new snit::widget command; unlike snit::widgetadaptor,
+ snit::widget automatically creates a Tk frame widget as the hull
+ widget; the constructor doesn't need to create and set a hull component.
+
+* Snit objects may now be renamed without breaking; many of the
+ specific changes which follow are related to this. However,
+ there are some new practices for type authors to follow if they wish
+ to write renameable types and widgets. In particular,
+
+ * In an instance method, $self will always contain the object's
+ current name, so instance methods can go on calling other instance
+ methods using $self.
+
+ * If the object is renamed, then $self's value will change. Therefore,
+ don't use $self for anything that will break if $self changes.
+ For example, don't pass a callback as "[list $self methodname]".
+
+ * If the object passes "[list $self methodname arg1 arg2]" as a callback,
+ the callback will fail when the object is renamed. Instead, the
+ object should pass "[mymethod methodname arg1 arg2]". The [mymethod]
+ command returns the desired command as a list beginning with a
+ name for the object that never changes.
+
+ For example, in Snit V0.71 you might have used this code to call a
+ method when a Tk button is pushed:
+
+ .btn configure -command [list $self buttonpress]
+
+ This still works in V0.8--but the callback will break if your
+ instance is renamed. Here's the safe way to do it:
+
+ .btn configure -command [mymethod buttonpress]
+
+ * Every object has a private namespace; the name of this namespace
+ is now available in method bodies, etc., as "$selfns". This value is
+ constant for the life the object. Use "$selfns" instead of "$self" if
+ you need a unique token to identify the object.
+
+ * When a snit::widget's instance command is renamed, its Tk window
+ name remains the same--and is still extremely important.
+ Consequently, the Tk window name is now available in snit::widget
+ method bodies, etc., as "$win". This value is constant for the
+ life of the object. When creating child windows, it's best to
+ use "$win.child" rather than "$self.child" as the name of the
+ child window.
+
+* The names "selfns" and "win" may no longer be used as explicit argument
+ names for typemethods, methods, constructors, or onconfigure
+ handlers.
+
+* procs defined in a Snit type or widget definition used to be able to
+ reference instance variables if "$self" was passed to them
+ explicitly as the argument "self"; this is no longer the case.
+
+* procs defined in a Snit type or widget definition can now reference
+ instance variables if "$selfns" is passed to them explicitly as the
+ argument "selfns". However, this usage is deprecated.
+
+* All Snit type and widget instances can be destroyed by renaming the
+ instance command to "".
+
+Changes in V0.72
+--------------------------------------------------------------------
+
+* Updated the pkgIndex.tcl file to references snit 0.72 instead of
+ snit 0.7.
+
+* Fixed a bug in widget destruction that caused errors like
+ "can't rename "::hull1.f": command doesn't exist".
+
+Changes in V0.71
+--------------------------------------------------------------------
+
+* KNOWN BUG: The V0.7 documentation implies that a snit::widget can
+ serve as the hull of another snit::widget. Unfortunately, it
+ doesn't work. The fix for this turns out to be extremely
+ complicated, so I plan to fix it in Snit V0.8.
+
+ Note that a snit::widget can still be composed of other
+ snit::widgets; it's only a problem when the hull component in
+ particular is a snit::widget.
+
+* KNOWN BUG: If you rename a Snit type or instance command (i.e., using
+ Tcl's [rename] command) it will no longer work properly. This is
+ part of the reason for the previous bug, and should also be fixed in
+ Snit V0.8.
+
+* Enhancement: Snit now preserves the call stack (i.e., the
+ "errorInfo") when rethrowing errors thrown by Snit methods,
+ typemethods, and so forth. This should make debugging Snit types
+ and widgets much easier. In Snit V0.8, I hope to clean up the
+ call stack so that Snit internals are hidden.
+
+* Bug fix: Option default values were being processed incorrectly. In
+ particular, if the default value contained brackets, it was treated
+ as a command interpolation. For example,
+
+ option -regexp {[a-z]+}
+
+ yield the error that "a-z" isn't a known command. Credit to Keith
+ Waclena for finding this one.
+
+* Bug fix: the [$type info instances] command failed to find
+ instances that weren't defined in the global namespace, and found
+ some things that weren't instances. Credit to Keith Waclena for
+ finding this one as well.
+
+* Internal Change: the naming convention for instance namespaces
+ within the type namespace has changed. But then, your code
+ shouldn't have depended on that anyway.
+
+* Bug fix: snit::widget destruction was seriously broken if the hull
+ component was itself a megawidget (e.g., a BWidget).
+ Each layer of megawidget code needs its opportunity
+ to clean up properly, and that wasn't happening. In addition, the
+ snit::widget destruction code was bound as follows:
+
+ bind $widgetName <Destroy> {....}
+
+ which means that if the user of a Snit widget needs to bind to
+ <Destroy> on the widget name they've just wiped out Snit's
+ destructor. Consequently, Snit now creates a bindtag called
+
+ Snit<widgettype>
+
+ e.g.,
+
+ Snit::rotext
+
+ and binds its destroy handler to that. This bindtag is inserted in
+ the snit::widget's bindtags immediately after the widget name.
+
+ Destruction is always going to be somewhat tricky when multiple
+ levels of megawidgets are involved, as you need to make sure that
+ the destructors are called in inverse order of creation.
+
+Changes in V0.7
+----------------------------------------------------------------------
+
+* INCOMPATIBILITY: Snit constructor definitions can now have arbitrary
+ argument lists, as methods do. That is, the type's create method
+ expects the instance name followed by exactly the arguments defined
+ in the constructor's argument list:
+
+ snit::type dog {
+ variable data
+ constructor {breed color} {
+ set data(breed) $breed
+ set data(color) $color
+ }
+ }
+
+ dog spot labrador chocolate
+
+ To get the V0.6 behavior, use the argument "args". That is, the
+ default constructor would be defined in this way:
+
+ snit::type dog {
+ constructor {args} {
+ $self configurelist $args
+ }
+ }
+
+* Added a "$type destroy" type method. It destroys all instances of
+ the type properly (if possible) then deletes the type's namespace
+ and type command.
+
+Changes in V0.6
+-----------------------------------------------------------------
+
+* Minor corrections to the man page.
+
+* The command snit::widgettype is deprecated, in favor of
+ snit::widget.
+
+* The variable "type" is now automatically defined in all methods,
+ constructors, destructors, typemethods, onconfigure handlers, and
+ oncget handlers. Thus, a method can call type methods as "$type
+ methodname".
+
+* The new standard instance method "info" is used for introspection on
+ type and widget instances:
+
+ $object info type
+ Returns the object's type.
+
+ $object info vars
+ Returns a list of the object's instance variables (excluding Snit
+ internal variables). The names are fully qualified.
+
+ $object info typevars
+ Returns a list of the object's type's type variables (excluding
+ Snit internal variables). The names are fully qualified.
+
+ $object info options
+ Returns a list of the object's option names. This always
+ includes local options and explicitly delegated options. If
+ unknown options are delegated as well, and if the component to
+ which they are delegated responds to "$object configure" like Tk
+ widgets do, then the result will include all possible unknown
+ options which could be delegated to the component.
+
+ Note that the return value might be different for different
+ instances of the same type, if component object types can vary
+ from one instance to another.
+
+* The new standard typemethod "info" is used for introspection on
+ types:
+
+ $type info typevars
+ Returns a list of the type's type variables (excluding Snit
+ internal variables).
+
+ $type info instances
+ Returns a list of the instances of the type. For non-widget
+ types, each instance will be the fully-qualified instance command
+ name; for widget types, each instance will be a widget name.
+
+* Bug fixed: great confusion resulted if the hull component of a
+ snit::widgettype was another snit::widgettype. Snit takes over the
+ hull widget's Tk widget command by renaming it to a known name, and
+ putting its own command in its place. The code made no allowance
+ for the fact that this might happen more than once; the second time,
+ the original Tk widget command would be lost. Snit now ensures that
+ the renamed widget command is given a unique name.
+
+* Previously, instance methods could call typemethods by name, as
+ though they were normal procs. The downside to this was that
+ if a typemethod name was the same as a standard Tcl command, the
+ typemethod shadowed the standard command in all of the object's
+ code. This is extremely annoying should you wish to define a
+ typemethod called "set". Instance methods must now call typemethods
+ using the type's command, as in "$type methodname".
+
+* Typevariable declarations are no longer required in
+ typemethods, methods, or procs provided that the typevariables are defined
+ in the main type or widget definition.
+
+* Instance variable declarations are no longer required in methods provided
+ that the instance variables are defined in the main type or widget
+ declaration.
+
+* Instance variable declarations are no longer required in procs,
+ provided that the instance variables are defined in the main type or
+ widget declaration. Any proc that includes "self" in its argument
+ list will pick up all such instance variables automatically.
+
+* The "configure" method now returns output consistent with Tk's when
+ called with 0 or 1 arguments, i.e., it returns information about one
+ or all options. For options defined by Snit objects, the "dbname"
+ and "classname" returned in the output will be {}. "configure" does
+ its best to do the right thing in the face of delegation.
+
+* If the string "%AUTO%" appears in the "name" argument to "$type create"
+ or "$widgettype create", it will be replaced with a string that
+ looks like "$type$n", where "$type" is the type name and "$n" is
+ a counter that's incremented each time a
+ widget of this type is created. This allows the caller to create
+ effectively anonymous instances:
+
+ widget mylabel {...}
+
+ set w [mylabel .pane.toolbar.%AUTO% ...]
+ $w configure -text "Some text"
+
+* The "create" typemethod is now optional for ordinary types so long
+ as the desired instance name is different than any typemethod name
+ for that type. Thus, the following code creates two dogs, ::spot
+ and ::fido.
+
+ type dog {...}
+
+ dog create spot
+ dog fido
+
+ If there's a conflict between the instance name and a typemethod,
+ either use "create" explicitly, or fully qualify the instance name:
+
+ dog info -color black ;# Error; assumes "info" typemethod.
+ dog create info -color black ;# OK
+ dog ::info -color black ;# also OK
+
+* Bug fix: If any Snit method, typemethod, constructor, or onconfigure
+ handler defines an explicit argument called "type" or "self", the type
+ definition now throws an error, preventing confusing runtime
+ behavior.
+
+* Bug fix: If a Snit type or widget definition attempts to define a
+ method or option locally and also delegate it to a component, the
+ type definition now throws an error, preventing confusing runtime
+ behavior.
+
+* Bug(?) Fix: Previously, the "$self" command couldn't be used in
+ snit::widget constructors until after the hull component was
+ defined. It is now possible to use the "$self" command to call
+ instance methods at any point in the snit::widget's
+ constructor--always bearing in mind that it's an error to configure
+ delegated options or are call delegated methods before creating the
+ component to which they are delegated.
+
+Changes in V0.5
+------------------------------------------------------------------
+
+* Updated the test suite so that Tk-related tests are only run if
+ Tk is available. Credit Jose Nazario for pointing out the problem.
+
+* For snit::widgettypes, the "create" keyword is now optional when
+ creating a new instance. That is, either of the following will
+ work:
+
+ ::snit::widgettype mylabel { }
+
+ mylabel create .lab1 -text "Using create typemethod"
+ mylabel .lab2 -text "Implied create typemethod"
+
+ This means that snit::widgettypes can be used identically to normal
+ Tk widgets. Credit goes to Colin McCormack for suggesting this.
+
+* Destruction code is now defined using the "destructor" keyword
+ instead of by defining a "destroy" method. If you've been
+ defining the "destroy" method, you need to replace it with
+ "destructor" immediately. See the man page for the syntax.
+
+* widgettype destruction is now handled properly (it was buggy).
+ Use the Tk command "destroy" to destroy instances of a widgettype;
+ the "destroy" method isn't automatically defined for widgettypes as
+ it is for normal types, and has no special significance even if it
+ is defined.
+
+* Added the "from" command to aid in parsing out specific option
+ values in constructors.
+
+Changes in V0.4
+------------------------------------------------------------------
+
+* Added the "codename" command, to qualify type method and private
+ proc names.
+
+* Changed the internal implementation of Snit types and widget types
+ to prevent an obscure kind of error and to make it easier to pass
+ private procs as callback commands to other objects. Credit to Rolf
+ Ade for discovering the hole.
+
+Changes in V0.3
+------------------------------------------------------------------
+
+* First public release.
+
+
--- /dev/null
+Last updated: Snit V1.0
+
+TYPE VARIABLES
+
+Snit_info Introspection Array. Keys and values are as
+ follows:
+
+ hasinstances Boolean. Normally T, but F if pragma -hasinstances no
+ simpledispatch Uses a very simple method dispatcher.
+ canreplace Boolean. Normally F, but T if pragma -canreplace yes
+ counter Integer counter. Used to generate unique names.
+ widgetclass Tk widget class name for snit::widgets
+ hulltype Hull widget type (frame or toplevel) for
+ snit::widgets.
+ ns The type namespace, "$type::". UNUSED.
+ exceptmethods Method names excluded from delegate method *.
+ excepttypemethods Typemethod names excluded from delegate typemethod *.
+ tvardecs Type variable declarations--for dynamic
+ methods.
+ ivardecs Instance variable declarations--for dynamic
+ methods.
+ isWidget Boolean; true if object is a widget or
+ widgetadaptor.
+ isWidgetAdaptor Boolean; true if object is a widgetadaptor
+
+Snit_methods List of method names; defined only when
+ -simpledispatch yes.
+
+Snit_typemethodInfo Array(method name) = {<flag> ?<pattern> <compName>?}
+ where <flag> is 1 if the method has submethods
+ (in which case the other fields
+ are missing) and 0 if it doesn't.
+ <compName> is "" for normal typemethods
+ and "method name" can be "*". Used in
+ typemethod cache lookup to create the command
+ for the named typemethod.
+
+Snit_typecomponents Array(typecomponent name) = command_name
+ Used whenever we need to retrieve the
+ typecomponent's command.
+
+Snit_methodInfo Array(method name) = {<flag> ?<pattern> <compName>?}
+ where <flag> is 1 if the method has submethods
+ (in which case the other fields
+ are missing) and 0 if it doesn't.
+ <compName> is "" for normal methods and
+ "method name" can be "*". Used in
+ method cache lookup to create the command for
+ the named method.
+
+Snit_optionInfo An array of option data. The keys are as follows:
+
+ General fields:
+
+ local List of local option names.
+
+ delegated List of explicitly delegated option names.
+
+ starcomp Name of component for "delegate option *" or ""
+
+ except List of option names explicitly NOT delegated
+ by "delegate option *".
+
+ Fields defined for all locally defined and explicitly delegated options:
+
+ islocal-$opt 1 if local, 0 otherwise. Currently undefined
+ for "delegate option *" options.
+
+ resource-$opt The option's resource name.
+
+ class-$opt The option's class name.
+
+ Fields defined only for locally defined options
+
+ default-$localOpt Default value.
+
+ validate-$localOpt The name of the validate method, or "".
+
+ configure-$localOpt The name of the configure method, or "".
+
+ cget-$localOpt The name of the cget method, or "".
+
+ readonly-$localOpt true or false. (false is the default).
+
+ typespec-$localOpt Validation type specification (object name or
+ construction list)
+
+ typeobj-$localOpt Validation type object
+
+ Fields defined only for delegated options
+
+ delegated-$comp List of option names delegated to this component.
+
+ target-$opt [list component targetOptionName].
+
+
+INSTANCE VARIABLES
+
+Snit_iinfo Array, instance info. At some point,
+ Snit_instance and Snit_components should
+ probably be consolidated into it. The fields
+ are:
+
+ constructed 0 during instance construction, and 1 after.
+
+Snit_instance Current name of the instance command.
+
+Snit_components Array(component name) = command_name
+ Used whenever we need to retrieve the
+ component's command.
+
+Consider consolidating the following arrays into a single array, since
+they are all cleared at the same time.
+
+Snit_cgetCache Array(option name) = cached command.
+ Used by $self cget.
+
+Snit_configureCache Array(option name) = cached command.
+ Used by $self configurelist.
+
+Snit_validateCache Array(option name) = cached command.
+ Used by $self configurelist. The entry is ""
+ if there is no validate command.
+
+
--- /dev/null
+This software is copyrighted by William H. Duquette. The following
+terms apply to all files associated with the software unless
+explicitly disclaimed in individual files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+GOVERNMENT USE: If you are acquiring this software on behalf of the
+U.S. government, the Government shall have only "Restricted Rights"
+in the software and related documentation as defined in the Federal
+Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+are acquiring the software on behalf of the Department of Defense, the
+software shall be classified as "Commercial Computer Software" and the
+Government shall have only "Restricted Rights" as defined in Clause
+252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+authors grant the U.S. Government and others acting in its behalf
+permission to use and distribute the software in accordance with the
+terms specified in this license.
--- /dev/null
+#-----------------------------------------------------------------------
+# TITLE:
+# main1.tcl
+#
+# AUTHOR:
+# Will Duquette
+#
+# DESCRIPTION:
+# Snit's Not Incr Tcl, a simple object system in Pure Tcl.
+#
+# Snit 1.x Compiler and Run-Time Library, Tcl 8.4 and later
+#
+# Copyright (C) 2003-2006 by William H. Duquette
+# This code is licensed as described in license.txt.
+#
+#-----------------------------------------------------------------------
+
+#-----------------------------------------------------------------------
+# Namespace
+
+namespace eval ::snit:: {
+ namespace export \
+ compile type widget widgetadaptor typemethod method macro
+}
+
+#-----------------------------------------------------------------------
+# Some Snit variables
+
+namespace eval ::snit:: {
+ variable reservedArgs {type selfns win self}
+
+ # Widget classes which can be hulls (must have -class)
+ variable hulltypes {
+ toplevel tk::toplevel
+ frame tk::frame ttk::frame
+ labelframe tk::labelframe ttk::labelframe
+ }
+}
+
+#-----------------------------------------------------------------------
+# Snit Type Implementation template
+
+namespace eval ::snit:: {
+ # Template type definition: All internal and user-visible Snit
+ # implementation code.
+ #
+ # The following placeholders will automatically be replaced with
+ # the client's code, in two passes:
+ #
+ # First pass:
+ # %COMPILEDDEFS% The compiled type definition.
+ #
+ # Second pass:
+ # %TYPE% The fully qualified type name.
+ # %IVARDECS% Instance variable declarations
+ # %TVARDECS% Type variable declarations
+ # %TCONSTBODY% Type constructor body
+ # %INSTANCEVARS% The compiled instance variable initialization code.
+ # %TYPEVARS% The compiled type variable initialization code.
+
+ # This is the overall type template.
+ variable typeTemplate
+
+ # This is the normal type proc
+ variable nominalTypeProc
+
+ # This is the "-hastypemethods no" type proc
+ variable simpleTypeProc
+}
+
+set ::snit::typeTemplate {
+
+ #-------------------------------------------------------------------
+ # The type's namespace definition and the user's type variables
+
+ namespace eval %TYPE% {%TYPEVARS%
+ }
+
+ #----------------------------------------------------------------
+ # Commands for use in methods, typemethods, etc.
+ #
+ # These are implemented as aliases into the Snit runtime library.
+
+ interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE%
+ interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE%
+ interp alias {} %TYPE%::typevariable {} ::variable
+ interp alias {} %TYPE%::variable {} ::snit::RT.variable
+ interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE%
+ interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE%
+ interp alias {} %TYPE%::myvar {} ::snit::RT.myvar
+ interp alias {} %TYPE%::varname {} ::snit::RT.myvar
+ interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE%
+ interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE%
+ interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod
+ interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE%
+ interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE%
+
+ #-------------------------------------------------------------------
+ # Snit's internal variables
+
+ namespace eval %TYPE% {
+ # Array: General Snit Info
+ #
+ # ns: The type's namespace
+ # hasinstances: T or F, from pragma -hasinstances.
+ # simpledispatch: T or F, from pragma -hasinstances.
+ # canreplace: T or F, from pragma -canreplace.
+ # counter: Count of instances created so far.
+ # widgetclass: Set by widgetclass statement.
+ # hulltype: Hull type (frame or toplevel) for widgets only.
+ # exceptmethods: Methods explicitly not delegated to *
+ # excepttypemethods: Methods explicitly not delegated to *
+ # tvardecs: Type variable declarations--for dynamic methods
+ # ivardecs: Instance variable declarations--for dyn. methods
+ typevariable Snit_info
+ set Snit_info(ns) %TYPE%::
+ set Snit_info(hasinstances) 1
+ set Snit_info(simpledispatch) 0
+ set Snit_info(canreplace) 0
+ set Snit_info(counter) 0
+ set Snit_info(widgetclass) {}
+ set Snit_info(hulltype) frame
+ set Snit_info(exceptmethods) {}
+ set Snit_info(excepttypemethods) {}
+ set Snit_info(tvardecs) {%TVARDECS%}
+ set Snit_info(ivardecs) {%IVARDECS%}
+
+ # Array: Public methods of this type.
+ # The index is the method name, or "*".
+ # The value is [list $pattern $componentName], where
+ # $componentName is "" for normal methods.
+ typevariable Snit_typemethodInfo
+ array unset Snit_typemethodInfo
+
+ # Array: Public methods of instances of this type.
+ # The index is the method name, or "*".
+ # The value is [list $pattern $componentName], where
+ # $componentName is "" for normal methods.
+ typevariable Snit_methodInfo
+ array unset Snit_methodInfo
+
+ # Array: option information. See dictionary.txt.
+ typevariable Snit_optionInfo
+ array unset Snit_optionInfo
+ set Snit_optionInfo(local) {}
+ set Snit_optionInfo(delegated) {}
+ set Snit_optionInfo(starcomp) {}
+ set Snit_optionInfo(except) {}
+ }
+
+ #----------------------------------------------------------------
+ # Compiled Procs
+ #
+ # These commands are created or replaced during compilation:
+
+
+ # Snit_instanceVars selfns
+ #
+ # Initializes the instance variables, if any. Called during
+ # instance creation.
+
+ proc %TYPE%::Snit_instanceVars {selfns} {
+ %INSTANCEVARS%
+ }
+
+ # Type Constructor
+ proc %TYPE%::Snit_typeconstructor {type} {
+ %TVARDECS%
+ %TCONSTBODY%
+ }
+
+ #----------------------------------------------------------------
+ # Default Procs
+ #
+ # These commands might be replaced during compilation:
+
+ # Snit_destructor type selfns win self
+ #
+ # Default destructor for the type. By default, it does
+ # nothing. It's replaced by any user destructor.
+ # For types, it's called by method destroy; for widgettypes,
+ # it's called by a destroy event handler.
+
+ proc %TYPE%::Snit_destructor {type selfns win self} { }
+
+ #----------------------------------------------------------
+ # Compiled Definitions
+
+ %COMPILEDDEFS%
+
+ #----------------------------------------------------------
+ # Finally, call the Type Constructor
+
+ %TYPE%::Snit_typeconstructor %TYPE%
+}
+
+#-----------------------------------------------------------------------
+# Type procs
+#
+# These procs expect the fully-qualified type name to be
+# substituted in for %TYPE%.
+
+# This is the nominal type proc. It supports typemethods and
+# delegated typemethods.
+set ::snit::nominalTypeProc {
+ # Type dispatcher function. Note: This function lives
+ # in the parent of the %TYPE% namespace! All accesses to
+ # %TYPE% variables and methods must be qualified!
+ proc %TYPE% {{method ""} args} {
+ # First, if there's no method, and no args, and there's a create
+ # method, and this isn't a widget, then method is "create" and
+ # "args" is %AUTO%.
+ if {"" == $method && [llength $args] == 0} {
+ ::variable %TYPE%::Snit_info
+
+ if {$Snit_info(hasinstances) && !$Snit_info(isWidget)} {
+ set method create
+ lappend args %AUTO%
+ } else {
+ error "wrong \# args: should be \"%TYPE% method args\""
+ }
+ }
+
+ # Next, retrieve the command.
+ variable %TYPE%::Snit_typemethodCache
+ while 1 {
+ if {[catch {set Snit_typemethodCache($method)} commandRec]} {
+ set commandRec [::snit::RT.CacheTypemethodCommand %TYPE% $method]
+
+ if {[llength $commandRec] == 0} {
+ return -code error "\"%TYPE% $method\" is not defined"
+ }
+ }
+
+ # If we've got a real command, break.
+ if {[lindex $commandRec 0] == 0} {
+ break
+ }
+
+ # Otherwise, we need to look up again...if we can.
+ if {[llength $args] == 0} {
+ return -code error \
+ "wrong number args: should be \"%TYPE% $method method args\""
+ }
+
+ lappend method [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+
+ set command [lindex $commandRec 1]
+
+ # Pass along the return code unchanged.
+ set retval [catch {uplevel 1 $command $args} result]
+
+ if {$retval} {
+ if {$retval == 1} {
+ global errorInfo
+ global errorCode
+ return -code error -errorinfo $errorInfo \
+ -errorcode $errorCode $result
+ } else {
+ return -code $retval $result
+ }
+ }
+
+ return $result
+ }
+}
+
+# This is the simplified type proc for when there are no typemethods
+# except create. In this case, it doesn't take a method argument;
+# the method is always "create".
+set ::snit::simpleTypeProc {
+ # Type dispatcher function. Note: This function lives
+ # in the parent of the %TYPE% namespace! All accesses to
+ # %TYPE% variables and methods must be qualified!
+ proc %TYPE% {args} {
+ ::variable %TYPE%::Snit_info
+
+ # FIRST, if the are no args, the single arg is %AUTO%
+ if {[llength $args] == 0} {
+ if {$Snit_info(isWidget)} {
+ error "wrong \# args: should be \"%TYPE% name args\""
+ }
+
+ lappend args %AUTO%
+ }
+
+ # NEXT, we're going to call the create method.
+ # Pass along the return code unchanged.
+ if {$Snit_info(isWidget)} {
+ set command [list ::snit::RT.widget.typemethod.create %TYPE%]
+ } else {
+ set command [list ::snit::RT.type.typemethod.create %TYPE%]
+ }
+
+ set retval [catch {uplevel 1 $command $args} result]
+
+ if {$retval} {
+ if {$retval == 1} {
+ global errorInfo
+ global errorCode
+ return -code error -errorinfo $errorInfo \
+ -errorcode $errorCode $result
+ } else {
+ return -code $retval $result
+ }
+ }
+
+ return $result
+ }
+}
+
+#-----------------------------------------------------------------------
+# Instance procs
+#
+# The following must be substituted into these proc bodies:
+#
+# %SELFNS% The instance namespace
+# %WIN% The original instance name
+# %TYPE% The fully-qualified type name
+#
+
+# Nominal instance proc body: supports method caching and delegation.
+#
+# proc $instanceName {method args} ....
+set ::snit::nominalInstanceProc {
+ set self [set %SELFNS%::Snit_instance]
+
+ while {1} {
+ if {[catch {set %SELFNS%::Snit_methodCache($method)} commandRec]} {
+ set commandRec [snit::RT.CacheMethodCommand %TYPE% %SELFNS% %WIN% $self $method]
+
+ if {[llength $commandRec] == 0} {
+ return -code error \
+ "\"$self $method\" is not defined"
+ }
+ }
+
+ # If we've got a real command, break.
+ if {[lindex $commandRec 0] == 0} {
+ break
+ }
+
+ # Otherwise, we need to look up again...if we can.
+ if {[llength $args] == 0} {
+ return -code error \
+ "wrong number args: should be \"$self $method method args\""
+ }
+
+ lappend method [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+
+ set command [lindex $commandRec 1]
+
+ # Pass along the return code unchanged.
+ set retval [catch {uplevel 1 $command $args} result]
+
+ if {$retval} {
+ if {$retval == 1} {
+ global errorInfo
+ global errorCode
+ return -code error -errorinfo $errorInfo \
+ -errorcode $errorCode $result
+ } else {
+ return -code $retval $result
+ }
+ }
+
+ return $result
+}
+
+# Simplified method proc body: No delegation allowed; no support for
+# upvar or exotic return codes or hierarchical methods. Designed for
+# max speed for simple types.
+#
+# proc $instanceName {method args} ....
+
+set ::snit::simpleInstanceProc {
+ set self [set %SELFNS%::Snit_instance]
+
+ if {[lsearch -exact ${%TYPE%::Snit_methods} $method] == -1} {
+ set optlist [join ${%TYPE%::Snit_methods} ", "]
+ set optlist [linsert $optlist "end-1" "or"]
+ error "bad option \"$method\": must be $optlist"
+ }
+
+ eval [linsert $args 0 \
+ %TYPE%::Snit_method$method %TYPE% %SELFNS% %WIN% $self]
+}
+
+
+#=======================================================================
+# Snit Type Definition
+#
+# These are the procs used to define Snit types, widgets, and
+# widgetadaptors.
+
+
+#-----------------------------------------------------------------------
+# Snit Compilation Variables
+#
+# The following variables are used while Snit is compiling a type,
+# and are disposed afterwards.
+
+namespace eval ::snit:: {
+ # The compiler variable contains the name of the slave interpreter
+ # used to compile type definitions.
+ variable compiler ""
+
+ # The compile array accumulates information about the type or
+ # widgettype being compiled. It is cleared before and after each
+ # compilation. It has these indices:
+ #
+ # type: The name of the type being compiled, for use
+ # in compilation procs.
+ # defs: Compiled definitions, both standard and client.
+ # which: type, widget, widgetadaptor
+ # instancevars: Instance variable definitions and initializations.
+ # ivprocdec: Instance variable proc declarations.
+ # tvprocdec: Type variable proc declarations.
+ # typeconstructor: Type constructor body.
+ # widgetclass: The widgetclass, for snit::widgets, only
+ # hasoptions: False, initially; set to true when first
+ # option is defined.
+ # localoptions: Names of local options.
+ # delegatedoptions: Names of delegated options.
+ # localmethods: Names of locally defined methods.
+ # delegatesmethods: no if no delegated methods, yes otherwise.
+ # hashierarchic : no if no hierarchic methods, yes otherwise.
+ # components: Names of defined components.
+ # typecomponents: Names of defined typecomponents.
+ # typevars: Typevariable definitions and initializations.
+ # varnames: Names of instance variables
+ # typevarnames Names of type variables
+ # hasconstructor False, initially; true when constructor is
+ # defined.
+ # resource-$opt The option's resource name
+ # class-$opt The option's class
+ # -default-$opt The option's default value
+ # -validatemethod-$opt The option's validate method
+ # -configuremethod-$opt The option's configure method
+ # -cgetmethod-$opt The option's cget method.
+ # -hastypeinfo The -hastypeinfo pragma
+ # -hastypedestroy The -hastypedestroy pragma
+ # -hastypemethods The -hastypemethods pragma
+ # -hasinfo The -hasinfo pragma
+ # -hasinstances The -hasinstances pragma
+ # -simpledispatch The -simpledispatch pragma
+ # -canreplace The -canreplace pragma
+ variable compile
+
+ # This variable accumulates method dispatch information; it has
+ # the same structure as the %TYPE%::Snit_methodInfo array, and is
+ # used to initialize it.
+ variable methodInfo
+
+ # This variable accumulates typemethod dispatch information; it has
+ # the same structure as the %TYPE%::Snit_typemethodInfo array, and is
+ # used to initialize it.
+ variable typemethodInfo
+
+ # The following variable lists the reserved type definition statement
+ # names, e.g., the names you can't use as macros. It's built at
+ # compiler definition time using "info commands".
+ variable reservedwords {}
+}
+
+#-----------------------------------------------------------------------
+# type compilation commands
+#
+# The type and widgettype commands use a slave interpreter to compile
+# the type definition. These are the procs
+# that are aliased into it.
+
+# Initialize the compiler
+proc ::snit::Comp.Init {} {
+ variable compiler
+ variable reservedwords
+
+ if {"" == $compiler} {
+ # Create the compiler's interpreter
+ set compiler [interp create]
+
+ # Initialize the interpreter
+ $compiler eval {
+ catch {close stdout}
+ catch {close stderr}
+ catch {close stdin}
+
+ # Load package information
+ # TBD: see if this can be moved outside.
+ # @mdgen NODEP: ::snit::__does_not_exist__
+ catch {package require ::snit::__does_not_exist__}
+
+ # Protect some Tcl commands our type definitions
+ # will shadow.
+ rename proc _proc
+ rename variable _variable
+ }
+
+ # Define compilation aliases.
+ $compiler alias pragma ::snit::Comp.statement.pragma
+ $compiler alias widgetclass ::snit::Comp.statement.widgetclass
+ $compiler alias hulltype ::snit::Comp.statement.hulltype
+ $compiler alias constructor ::snit::Comp.statement.constructor
+ $compiler alias destructor ::snit::Comp.statement.destructor
+ $compiler alias option ::snit::Comp.statement.option
+ $compiler alias oncget ::snit::Comp.statement.oncget
+ $compiler alias onconfigure ::snit::Comp.statement.onconfigure
+ $compiler alias method ::snit::Comp.statement.method
+ $compiler alias typemethod ::snit::Comp.statement.typemethod
+ $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor
+ $compiler alias proc ::snit::Comp.statement.proc
+ $compiler alias typevariable ::snit::Comp.statement.typevariable
+ $compiler alias variable ::snit::Comp.statement.variable
+ $compiler alias typecomponent ::snit::Comp.statement.typecomponent
+ $compiler alias component ::snit::Comp.statement.component
+ $compiler alias delegate ::snit::Comp.statement.delegate
+ $compiler alias expose ::snit::Comp.statement.expose
+
+ # Get the list of reserved words
+ set reservedwords [$compiler eval {info commands}]
+ }
+}
+
+# Compile a type definition, and return the results as a list of two
+# items: the fully-qualified type name, and a script that will define
+# the type when executed.
+#
+# which type, widget, or widgetadaptor
+# type the type name
+# body the type definition
+proc ::snit::Comp.Compile {which type body} {
+ variable typeTemplate
+ variable nominalTypeProc
+ variable simpleTypeProc
+ variable compile
+ variable compiler
+ variable methodInfo
+ variable typemethodInfo
+
+ # FIRST, qualify the name.
+ if {![string match "::*" $type]} {
+ # Get caller's namespace;
+ # append :: if not global namespace.
+ set ns [uplevel 2 [list namespace current]]
+ if {"::" != $ns} {
+ append ns "::"
+ }
+
+ set type "$ns$type"
+ }
+
+ # NEXT, create and initialize the compiler, if needed.
+ Comp.Init
+
+ # NEXT, initialize the class data
+ array unset methodInfo
+ array unset typemethodInfo
+
+ array unset compile
+ set compile(type) $type
+ set compile(defs) {}
+ set compile(which) $which
+ set compile(hasoptions) no
+ set compile(localoptions) {}
+ set compile(instancevars) {}
+ set compile(typevars) {}
+ set compile(delegatedoptions) {}
+ set compile(ivprocdec) {}
+ set compile(tvprocdec) {}
+ set compile(typeconstructor) {}
+ set compile(widgetclass) {}
+ set compile(hulltype) {}
+ set compile(localmethods) {}
+ set compile(delegatesmethods) no
+ set compile(hashierarchic) no
+ set compile(components) {}
+ set compile(typecomponents) {}
+ set compile(varnames) {}
+ set compile(typevarnames) {}
+ set compile(hasconstructor) no
+ set compile(-hastypedestroy) yes
+ set compile(-hastypeinfo) yes
+ set compile(-hastypemethods) yes
+ set compile(-hasinfo) yes
+ set compile(-hasinstances) yes
+ set compile(-simpledispatch) no
+ set compile(-canreplace) no
+
+ set isWidget [string match widget* $which]
+ set isWidgetAdaptor [string match widgetadaptor $which]
+
+ # NEXT, Evaluate the type's definition in the class interpreter.
+ $compiler eval $body
+
+ # NEXT, Add the standard definitions
+ append compile(defs) \
+ "\nset %TYPE%::Snit_info(isWidget) $isWidget\n"
+
+ append compile(defs) \
+ "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n"
+
+ # Indicate whether the type can create instances that replace
+ # existing commands.
+ append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n"
+
+
+ # Check pragmas for conflict.
+
+ if {!$compile(-hastypemethods) && !$compile(-hasinstances)} {
+ error "$which $type has neither typemethods nor instances"
+ }
+
+ if {$compile(-simpledispatch) && $compile(delegatesmethods)} {
+ error "$which $type requests -simpledispatch but delegates methods."
+ }
+
+ if {$compile(-simpledispatch) && $compile(hashierarchic)} {
+ error "$which $type requests -simpledispatch but defines hierarchical methods."
+ }
+
+ # If there are typemethods, define the standard typemethods and
+ # the nominal type proc. Otherwise define the simple type proc.
+ if {$compile(-hastypemethods)} {
+ # Add the info typemethod unless the pragma forbids it.
+ if {$compile(-hastypeinfo)} {
+ Comp.statement.delegate typemethod info \
+ using {::snit::RT.typemethod.info %t}
+ }
+
+ # Add the destroy typemethod unless the pragma forbids it.
+ if {$compile(-hastypedestroy)} {
+ Comp.statement.delegate typemethod destroy \
+ using {::snit::RT.typemethod.destroy %t}
+ }
+
+ # Add the nominal type proc.
+ append compile(defs) $nominalTypeProc
+ } else {
+ # Add the simple type proc.
+ append compile(defs) $simpleTypeProc
+ }
+
+ # Add standard methods/typemethods that only make sense if the
+ # type has instances.
+ if {$compile(-hasinstances)} {
+ # If we're using simple dispatch, remember that.
+ if {$compile(-simpledispatch)} {
+ append compile(defs) "\nset %TYPE%::Snit_info(simpledispatch) 1\n"
+ }
+
+ # Add the info method unless the pragma forbids it.
+ if {$compile(-hasinfo)} {
+ if {!$compile(-simpledispatch)} {
+ Comp.statement.delegate method info \
+ using {::snit::RT.method.info %t %n %w %s}
+ } else {
+ Comp.statement.method info {args} {
+ eval [linsert $args 0 \
+ ::snit::RT.method.info $type $selfns $win $self]
+ }
+ }
+ }
+
+ # Add the option handling stuff if there are any options.
+ if {$compile(hasoptions)} {
+ Comp.statement.variable options
+
+ if {!$compile(-simpledispatch)} {
+ Comp.statement.delegate method cget \
+ using {::snit::RT.method.cget %t %n %w %s}
+ Comp.statement.delegate method configurelist \
+ using {::snit::RT.method.configurelist %t %n %w %s}
+ Comp.statement.delegate method configure \
+ using {::snit::RT.method.configure %t %n %w %s}
+ } else {
+ Comp.statement.method cget {args} {
+ eval [linsert $args 0 \
+ ::snit::RT.method.cget $type $selfns $win $self]
+ }
+ Comp.statement.method configurelist {args} {
+ eval [linsert $args 0 \
+ ::snit::RT.method.configurelist $type $selfns $win $self]
+ }
+ Comp.statement.method configure {args} {
+ eval [linsert $args 0 \
+ ::snit::RT.method.configure $type $selfns $win $self]
+ }
+ }
+ }
+
+ # Add a default constructor, if they haven't already defined one.
+ # If there are options, it will configure args; otherwise it
+ # will do nothing.
+ if {!$compile(hasconstructor)} {
+ if {$compile(hasoptions)} {
+ Comp.statement.constructor {args} {
+ $self configurelist $args
+ }
+ } else {
+ Comp.statement.constructor {} {}
+ }
+ }
+
+ if {!$isWidget} {
+ if {!$compile(-simpledispatch)} {
+ Comp.statement.delegate method destroy \
+ using {::snit::RT.method.destroy %t %n %w %s}
+ } else {
+ Comp.statement.method destroy {args} {
+ eval [linsert $args 0 \
+ ::snit::RT.method.destroy $type $selfns $win $self]
+ }
+ }
+
+ Comp.statement.delegate typemethod create \
+ using {::snit::RT.type.typemethod.create %t}
+ } else {
+ Comp.statement.delegate typemethod create \
+ using {::snit::RT.widget.typemethod.create %t}
+ }
+
+ # Save the list of method names, for -simpledispatch; otherwise,
+ # save the method info.
+ if {$compile(-simpledispatch)} {
+ append compile(defs) \
+ "\nset %TYPE%::Snit_methods [list $compile(localmethods)]\n"
+ } else {
+ append compile(defs) \
+ "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n"
+ }
+
+ } else {
+ append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n"
+ }
+
+ # NEXT, compiling the type definition built up a set of information
+ # about the type's locally defined options; add this information to
+ # the compiled definition.
+ Comp.SaveOptionInfo
+
+ # NEXT, compiling the type definition built up a set of information
+ # about the typemethods; save the typemethod info.
+ append compile(defs) \
+ "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n"
+
+ # NEXT, if this is a widget define the hull component if it isn't
+ # already defined.
+ if {$isWidget} {
+ Comp.DefineComponent hull
+ }
+
+ # NEXT, substitute the compiled definition into the type template
+ # to get the type definition script.
+ set defscript [Expand $typeTemplate \
+ %COMPILEDDEFS% $compile(defs)]
+
+ # NEXT, substitute the defined macros into the type definition script.
+ # This is done as a separate step so that the compile(defs) can
+ # contain the macros defined below.
+
+ set defscript [Expand $defscript \
+ %TYPE% $type \
+ %IVARDECS% $compile(ivprocdec) \
+ %TVARDECS% $compile(tvprocdec) \
+ %TCONSTBODY% $compile(typeconstructor) \
+ %INSTANCEVARS% $compile(instancevars) \
+ %TYPEVARS% $compile(typevars) \
+ ]
+
+ array unset compile
+
+ return [list $type $defscript]
+}
+
+# Information about locally-defined options is accumulated during
+# compilation, but not added to the compiled definition--the option
+# statement can appear multiple times, so it's easier this way.
+# This proc fills in Snit_optionInfo with the accumulated information.
+#
+# It also computes the option's resource and class names if needed.
+#
+# Note that the information for delegated options was put in
+# Snit_optionInfo during compilation.
+
+proc ::snit::Comp.SaveOptionInfo {} {
+ variable compile
+
+ foreach option $compile(localoptions) {
+ if {"" == $compile(resource-$option)} {
+ set compile(resource-$option) [string range $option 1 end]
+ }
+
+ if {"" == $compile(class-$option)} {
+ set compile(class-$option) [Capitalize $compile(resource-$option)]
+ }
+
+ # NOTE: Don't verify that the validate, configure, and cget
+ # values name real methods; the methods might be defined outside
+ # the typedefinition using snit::method.
+
+ Mappend compile(defs) {
+ # Option %OPTION%
+ lappend %TYPE%::Snit_optionInfo(local) %OPTION%
+
+ set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1
+ set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE%
+ set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
+ set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT%
+ set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE%
+ set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE%
+ set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET%
+ set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY%
+ set %TYPE%::Snit_optionInfo(typespec-%OPTION%) %TYPESPEC%
+ } %OPTION% $option \
+ %RESOURCE% $compile(resource-$option) \
+ %CLASS% $compile(class-$option) \
+ %DEFAULT% [list $compile(-default-$option)] \
+ %VALIDATE% [list $compile(-validatemethod-$option)] \
+ %CONFIGURE% [list $compile(-configuremethod-$option)] \
+ %CGET% [list $compile(-cgetmethod-$option)] \
+ %READONLY% $compile(-readonly-$option) \
+ %TYPESPEC% [list $compile(-type-$option)]
+ }
+}
+
+
+# Evaluates a compiled type definition, thus making the type available.
+proc ::snit::Comp.Define {compResult} {
+ # The compilation result is a list containing the fully qualified
+ # type name and a script to evaluate to define the type.
+ set type [lindex $compResult 0]
+ set defscript [lindex $compResult 1]
+
+ # Execute the type definition script.
+ # Consider using namespace eval %TYPE%. See if it's faster.
+ if {[catch {eval $defscript} result]} {
+ namespace delete $type
+ catch {rename $type ""}
+ error $result
+ }
+
+ return $type
+}
+
+# Sets pragma options which control how the type is defined.
+proc ::snit::Comp.statement.pragma {args} {
+ variable compile
+
+ set errRoot "Error in \"pragma...\""
+
+ foreach {opt val} $args {
+ switch -exact -- $opt {
+ -hastypeinfo -
+ -hastypedestroy -
+ -hastypemethods -
+ -hasinstances -
+ -simpledispatch -
+ -hasinfo -
+ -canreplace {
+ if {![string is boolean -strict $val]} {
+ error "$errRoot, \"$opt\" requires a boolean value"
+ }
+ set compile($opt) $val
+ }
+ default {
+ error "$errRoot, unknown pragma"
+ }
+ }
+ }
+}
+
+# Defines a widget's option class name.
+# This statement is only available for snit::widgets,
+# not for snit::types or snit::widgetadaptors.
+proc ::snit::Comp.statement.widgetclass {name} {
+ variable compile
+
+ # First, widgetclass can only be set for true widgets
+ if {"widget" != $compile(which)} {
+ error "widgetclass cannot be set for snit::$compile(which)s"
+ }
+
+ # Next, validate the option name. We'll require that it begin
+ # with an uppercase letter.
+ set initial [string index $name 0]
+ if {![string is upper $initial]} {
+ error "widgetclass \"$name\" does not begin with an uppercase letter"
+ }
+
+ if {"" != $compile(widgetclass)} {
+ error "too many widgetclass statements"
+ }
+
+ # Next, save it.
+ Mappend compile(defs) {
+ set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS%
+ } %WIDGETCLASS% [list $name]
+
+ set compile(widgetclass) $name
+}
+
+# Defines a widget's hull type.
+# This statement is only available for snit::widgets,
+# not for snit::types or snit::widgetadaptors.
+proc ::snit::Comp.statement.hulltype {name} {
+ variable compile
+ variable hulltypes
+
+ # First, hulltype can only be set for true widgets
+ if {"widget" != $compile(which)} {
+ error "hulltype cannot be set for snit::$compile(which)s"
+ }
+
+ # Next, it must be one of the valid hulltypes (frame, toplevel, ...)
+ if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} {
+ error "invalid hulltype \"$name\", should be one of\
+ [join $hulltypes {, }]"
+ }
+
+ if {"" != $compile(hulltype)} {
+ error "too many hulltype statements"
+ }
+
+ # Next, save it.
+ Mappend compile(defs) {
+ set %TYPE%::Snit_info(hulltype) %HULLTYPE%
+ } %HULLTYPE% $name
+
+ set compile(hulltype) $name
+}
+
+# Defines a constructor.
+proc ::snit::Comp.statement.constructor {arglist body} {
+ variable compile
+
+ CheckArgs "constructor" $arglist
+
+ # Next, add a magic reference to self.
+ set arglist [concat type selfns win self $arglist]
+
+ # Next, add variable declarations to body:
+ set body "%TVARDECS%%IVARDECS%\n$body"
+
+ set compile(hasconstructor) yes
+ append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n"
+}
+
+# Defines a destructor.
+proc ::snit::Comp.statement.destructor {body} {
+ variable compile
+
+ # Next, add variable declarations to body:
+ set body "%TVARDECS%%IVARDECS%\n$body"
+
+ append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n"
+}
+
+# Defines a type option. The option value can be a triple, specifying
+# the option's -name, resource name, and class name.
+proc ::snit::Comp.statement.option {optionDef args} {
+ variable compile
+
+ # First, get the three option names.
+ set option [lindex $optionDef 0]
+ set resourceName [lindex $optionDef 1]
+ set className [lindex $optionDef 2]
+
+ set errRoot "Error in \"option [list $optionDef]...\""
+
+ # Next, validate the option name.
+ if {![Comp.OptionNameIsValid $option]} {
+ error "$errRoot, badly named option \"$option\""
+ }
+
+ if {[Contains $option $compile(delegatedoptions)]} {
+ error "$errRoot, cannot define \"$option\" locally, it has been delegated"
+ }
+
+ if {![Contains $option $compile(localoptions)]} {
+ # Remember that we've seen this one.
+ set compile(hasoptions) yes
+ lappend compile(localoptions) $option
+
+ # Initialize compilation info for this option.
+ set compile(resource-$option) ""
+ set compile(class-$option) ""
+ set compile(-default-$option) ""
+ set compile(-validatemethod-$option) ""
+ set compile(-configuremethod-$option) ""
+ set compile(-cgetmethod-$option) ""
+ set compile(-readonly-$option) 0
+ set compile(-type-$option) ""
+ }
+
+ # NEXT, see if we have a resource name. If so, make sure it
+ # isn't being redefined differently.
+ if {"" != $resourceName} {
+ if {"" == $compile(resource-$option)} {
+ # If it's undefined, just save the value.
+ set compile(resource-$option) $resourceName
+ } elseif {![string equal $resourceName $compile(resource-$option)]} {
+ # It's been redefined differently.
+ error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\""
+ }
+ }
+
+ # NEXT, see if we have a class name. If so, make sure it
+ # isn't being redefined differently.
+ if {"" != $className} {
+ if {"" == $compile(class-$option)} {
+ # If it's undefined, just save the value.
+ set compile(class-$option) $className
+ } elseif {![string equal $className $compile(class-$option)]} {
+ # It's been redefined differently.
+ error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\""
+ }
+ }
+
+ # NEXT, handle the args; it's not an error to redefine these.
+ if {[llength $args] == 1} {
+ set compile(-default-$option) [lindex $args 0]
+ } else {
+ foreach {optopt val} $args {
+ switch -exact -- $optopt {
+ -default -
+ -validatemethod -
+ -configuremethod -
+ -cgetmethod {
+ set compile($optopt-$option) $val
+ }
+ -type {
+ set compile($optopt-$option) $val
+
+ if {[llength $val] == 1} {
+ # The type spec *is* the validation object
+ append compile(defs) \
+ "\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n"
+ } else {
+ # Compilation the creation of the validation object
+ set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%]
+ append compile(defs) \
+ "\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n"
+ }
+ }
+ -readonly {
+ if {![string is boolean -strict $val]} {
+ error "$errRoot, -readonly requires a boolean, got \"$val\""
+ }
+ set compile($optopt-$option) $val
+ }
+ default {
+ error "$errRoot, unknown option definition option \"$optopt\""
+ }
+ }
+ }
+ }
+}
+
+# 1 if the option name is valid, 0 otherwise.
+proc ::snit::Comp.OptionNameIsValid {option} {
+ if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} {
+ return 0
+ }
+
+ return 1
+}
+
+# Defines an option's cget handler
+proc ::snit::Comp.statement.oncget {option body} {
+ variable compile
+
+ set errRoot "Error in \"oncget $option...\""
+
+ if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
+ return -code error "$errRoot, option \"$option\" is delegated"
+ }
+
+ if {[lsearch -exact $compile(localoptions) $option] == -1} {
+ return -code error "$errRoot, option \"$option\" unknown"
+ }
+
+ Comp.statement.method _cget$option {_option} $body
+ Comp.statement.option $option -cgetmethod _cget$option
+}
+
+# Defines an option's configure handler.
+proc ::snit::Comp.statement.onconfigure {option arglist body} {
+ variable compile
+
+ if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
+ return -code error "onconfigure $option: option \"$option\" is delegated"
+ }
+
+ if {[lsearch -exact $compile(localoptions) $option] == -1} {
+ return -code error "onconfigure $option: option \"$option\" unknown"
+ }
+
+ if {[llength $arglist] != 1} {
+ error \
+ "onconfigure $option handler should have one argument, got \"$arglist\""
+ }
+
+ CheckArgs "onconfigure $option" $arglist
+
+ # Next, add a magic reference to the option name
+ set arglist [concat _option $arglist]
+
+ Comp.statement.method _configure$option $arglist $body
+ Comp.statement.option $option -configuremethod _configure$option
+}
+
+# Defines an instance method.
+proc ::snit::Comp.statement.method {method arglist body} {
+ variable compile
+ variable methodInfo
+
+ # FIRST, check the method name against previously defined
+ # methods.
+ Comp.CheckMethodName $method 0 ::snit::methodInfo \
+ "Error in \"method [list $method]...\""
+
+ if {[llength $method] > 1} {
+ set compile(hashierarchic) yes
+ }
+
+ # Remeber this method
+ lappend compile(localmethods) $method
+
+ CheckArgs "method [list $method]" $arglist
+
+ # Next, add magic references to type and self.
+ set arglist [concat type selfns win self $arglist]
+
+ # Next, add variable declarations to body:
+ set body "%TVARDECS%%IVARDECS%\n# END snit method prolog\n$body"
+
+ # Next, save the definition script.
+ if {[llength $method] == 1} {
+ set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
+ Mappend compile(defs) {
+ proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY%
+ } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
+ } else {
+ set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
+
+ Mappend compile(defs) {
+ proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY%
+ } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \
+ %BODY% [list $body]
+ }
+}
+
+# Check for name collisions; save prefix information.
+#
+# method The name of the method or typemethod.
+# delFlag 1 if delegated, 0 otherwise.
+# infoVar The fully qualified name of the array containing
+# information about the defined methods.
+# errRoot The root string for any error messages.
+
+proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} {
+ upvar $infoVar methodInfo
+
+ # FIRST, make sure the method name is a valid Tcl list.
+ if {[catch {lindex $method 0}]} {
+ error "$errRoot, the name \"$method\" must have list syntax."
+ }
+
+ # NEXT, check whether we can define it.
+ if {![catch {set methodInfo($method)} data]} {
+ # We can't redefine methods with submethods.
+ if {[lindex $data 0] == 1} {
+ error "$errRoot, \"$method\" has submethods."
+ }
+
+ # You can't delegate a method that's defined locally,
+ # and you can't define a method locally if it's been delegated.
+ if {$delFlag && "" == [lindex $data 2]} {
+ error "$errRoot, \"$method\" has been defined locally."
+ } elseif {!$delFlag && "" != [lindex $data 2]} {
+ error "$errRoot, \"$method\" has been delegated"
+ }
+ }
+
+ # Handle hierarchical case.
+ if {[llength $method] > 1} {
+ set prefix {}
+ set tokens $method
+ while {[llength $tokens] > 1} {
+ lappend prefix [lindex $tokens 0]
+ set tokens [lrange $tokens 1 end]
+
+ if {![catch {set methodInfo($prefix)} result]} {
+ # Prefix is known. If it's not a prefix, throw an
+ # error.
+ if {[lindex $result 0] == 0} {
+ error "$errRoot, \"$prefix\" has no submethods."
+ }
+ }
+
+ set methodInfo($prefix) [list 1]
+ }
+ }
+}
+
+# Defines a typemethod method.
+proc ::snit::Comp.statement.typemethod {method arglist body} {
+ variable compile
+ variable typemethodInfo
+
+ # FIRST, check the typemethod name against previously defined
+ # typemethods.
+ Comp.CheckMethodName $method 0 ::snit::typemethodInfo \
+ "Error in \"typemethod [list $method]...\""
+
+ CheckArgs "typemethod $method" $arglist
+
+ # First, add magic reference to type.
+ set arglist [concat type $arglist]
+
+ # Next, add typevariable declarations to body:
+ set body "%TVARDECS%\n# END snit method prolog\n$body"
+
+ # Next, save the definition script
+ if {[llength $method] == 1} {
+ set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
+
+ Mappend compile(defs) {
+ proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY%
+ } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
+ } else {
+ set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
+
+ Mappend compile(defs) {
+ proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY%
+ } %JMETHOD% [join $method _] \
+ %ARGLIST% [list $arglist] %BODY% [list $body]
+ }
+}
+
+
+# Defines a type constructor.
+proc ::snit::Comp.statement.typeconstructor {body} {
+ variable compile
+
+ if {"" != $compile(typeconstructor)} {
+ error "too many typeconstructors"
+ }
+
+ set compile(typeconstructor) $body
+}
+
+# Defines a static proc in the type's namespace.
+proc ::snit::Comp.statement.proc {proc arglist body} {
+ variable compile
+
+ # If "ns" is defined, the proc can see instance variables.
+ if {[lsearch -exact $arglist selfns] != -1} {
+ # Next, add instance variable declarations to body:
+ set body "%IVARDECS%\n$body"
+ }
+
+ # The proc can always see typevariables.
+ set body "%TVARDECS%\n$body"
+
+ append compile(defs) "
+
+ # Proc $proc
+ proc [list %TYPE%::$proc $arglist $body]
+ "
+}
+
+# Defines a static variable in the type's namespace.
+proc ::snit::Comp.statement.typevariable {name args} {
+ variable compile
+
+ set errRoot "Error in \"typevariable $name...\""
+
+ set len [llength $args]
+
+ if {$len > 2 ||
+ ($len == 2 && "-array" != [lindex $args 0])} {
+ error "$errRoot, too many initializers"
+ }
+
+ if {[lsearch -exact $compile(varnames) $name] != -1} {
+ error "$errRoot, \"$name\" is already an instance variable"
+ }
+
+ lappend compile(typevarnames) $name
+
+ if {$len == 1} {
+ append compile(typevars) \
+ "\n\t [list ::variable $name [lindex $args 0]]"
+ } elseif {$len == 2} {
+ append compile(typevars) \
+ "\n\t [list ::variable $name]"
+ append compile(typevars) \
+ "\n\t [list array set $name [lindex $args 1]]"
+ } else {
+ append compile(typevars) \
+ "\n\t [list ::variable $name]"
+ }
+
+ append compile(tvprocdec) "\n\t typevariable ${name}"
+}
+
+# Defines an instance variable; the definition will go in the
+# type's create typemethod.
+proc ::snit::Comp.statement.variable {name args} {
+ variable compile
+
+ set errRoot "Error in \"variable $name...\""
+
+ set len [llength $args]
+
+ if {$len > 2 ||
+ ($len == 2 && "-array" != [lindex $args 0])} {
+ error "$errRoot, too many initializers"
+ }
+
+ if {[lsearch -exact $compile(typevarnames) $name] != -1} {
+ error "$errRoot, \"$name\" is already a typevariable"
+ }
+
+ lappend compile(varnames) $name
+
+ if {$len == 1} {
+ append compile(instancevars) \
+ "\nset \${selfns}::$name [list [lindex $args 0]]\n"
+ } elseif {$len == 2} {
+ append compile(instancevars) \
+ "\narray set \${selfns}::$name [list [lindex $args 1]]\n"
+ }
+
+ append compile(ivprocdec) "\n\t "
+ Mappend compile(ivprocdec) {::variable ${selfns}::%N} %N $name
+}
+
+# Defines a typecomponent, and handles component options.
+#
+# component The logical name of the delegate
+# args options.
+
+proc ::snit::Comp.statement.typecomponent {component args} {
+ variable compile
+
+ set errRoot "Error in \"typecomponent $component...\""
+
+ # FIRST, define the component
+ Comp.DefineTypecomponent $component $errRoot
+
+ # NEXT, handle the options.
+ set publicMethod ""
+ set inheritFlag 0
+
+ foreach {opt val} $args {
+ switch -exact -- $opt {
+ -public {
+ set publicMethod $val
+ }
+ -inherit {
+ set inheritFlag $val
+ if {![string is boolean $inheritFlag]} {
+ error "typecomponent $component -inherit: expected boolean value, got \"$val\""
+ }
+ }
+ default {
+ error "typecomponent $component: Invalid option \"$opt\""
+ }
+ }
+ }
+
+ # NEXT, if -public specified, define the method.
+ if {"" != $publicMethod} {
+ Comp.statement.delegate typemethod [list $publicMethod *] to $component
+ }
+
+ # NEXT, if "-inherit 1" is specified, delegate typemethod * to
+ # this component.
+ if {$inheritFlag} {
+ Comp.statement.delegate typemethod "*" to $component
+ }
+
+}
+
+
+# Defines a name to be a typecomponent
+#
+# The name becomes a typevariable; in addition, it gets a
+# write trace so that when it is set, all of the component mechanisms
+# get updated.
+#
+# component The component name
+
+proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} {
+ variable compile
+
+ if {[lsearch -exact $compile(varnames) $component] != -1} {
+ error "$errRoot, \"$component\" is already an instance variable"
+ }
+
+ if {[lsearch -exact $compile(typecomponents) $component] == -1} {
+ # Remember we've done this.
+ lappend compile(typecomponents) $component
+
+ # Make it a type variable with no initial value
+ Comp.statement.typevariable $component ""
+
+ # Add a write trace to do the component thing.
+ Mappend compile(typevars) {
+ trace add variable %COMP% write \
+ [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%]
+ } %TYPE% $compile(type) %COMP% $component
+ }
+}
+
+# Defines a component, and handles component options.
+#
+# component The logical name of the delegate
+# args options.
+#
+# TBD: Ideally, it should be possible to call this statement multiple
+# times, possibly changing the option values. To do that, I'd need
+# to cache the option values and not act on them until *after* I'd
+# read the entire type definition.
+
+proc ::snit::Comp.statement.component {component args} {
+ variable compile
+
+ set errRoot "Error in \"component $component...\""
+
+ # FIRST, define the component
+ Comp.DefineComponent $component $errRoot
+
+ # NEXT, handle the options.
+ set publicMethod ""
+ set inheritFlag 0
+
+ foreach {opt val} $args {
+ switch -exact -- $opt {
+ -public {
+ set publicMethod $val
+ }
+ -inherit {
+ set inheritFlag $val
+ if {![string is boolean $inheritFlag]} {
+ error "component $component -inherit: expected boolean value, got \"$val\""
+ }
+ }
+ default {
+ error "component $component: Invalid option \"$opt\""
+ }
+ }
+ }
+
+ # NEXT, if -public specified, define the method.
+ if {"" != $publicMethod} {
+ Comp.statement.delegate method [list $publicMethod *] to $component
+ }
+
+ # NEXT, if -inherit is specified, delegate method/option * to
+ # this component.
+ if {$inheritFlag} {
+ Comp.statement.delegate method "*" to $component
+ Comp.statement.delegate option "*" to $component
+ }
+}
+
+
+# Defines a name to be a component
+#
+# The name becomes an instance variable; in addition, it gets a
+# write trace so that when it is set, all of the component mechanisms
+# get updated.
+#
+# component The component name
+
+proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} {
+ variable compile
+
+ if {[lsearch -exact $compile(typevarnames) $component] != -1} {
+ error "$errRoot, \"$component\" is already a typevariable"
+ }
+
+ if {[lsearch -exact $compile(components) $component] == -1} {
+ # Remember we've done this.
+ lappend compile(components) $component
+
+ # Make it an instance variable with no initial value
+ Comp.statement.variable $component ""
+
+ # Add a write trace to do the component thing.
+ Mappend compile(instancevars) {
+ trace add variable ${selfns}::%COMP% write \
+ [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%]
+ } %TYPE% $compile(type) %COMP% $component
+ }
+}
+
+# Creates a delegated method, typemethod, or option.
+proc ::snit::Comp.statement.delegate {what name args} {
+ # FIRST, dispatch to correct handler.
+ switch $what {
+ typemethod { Comp.DelegatedTypemethod $name $args }
+ method { Comp.DelegatedMethod $name $args }
+ option { Comp.DelegatedOption $name $args }
+ default {
+ error "Error in \"delegate $what $name...\", \"$what\"?"
+ }
+ }
+
+ if {([llength $args] % 2) != 0} {
+ error "Error in \"delegate $what $name...\", invalid syntax"
+ }
+}
+
+# Creates a delegated typemethod delegating it to a particular
+# typecomponent or an arbitrary command.
+#
+# method The name of the method
+# arglist Delegation options
+
+proc ::snit::Comp.DelegatedTypemethod {method arglist} {
+ variable compile
+ variable typemethodInfo
+
+ set errRoot "Error in \"delegate typemethod [list $method]...\""
+
+ # Next, parse the delegation options.
+ set component ""
+ set target ""
+ set exceptions {}
+ set pattern ""
+ set methodTail [lindex $method end]
+
+ foreach {opt value} $arglist {
+ switch -exact $opt {
+ to { set component $value }
+ as { set target $value }
+ except { set exceptions $value }
+ using { set pattern $value }
+ default {
+ error "$errRoot, unknown delegation option \"$opt\""
+ }
+ }
+ }
+
+ if {"" == $component && "" == $pattern} {
+ error "$errRoot, missing \"to\""
+ }
+
+ if {"*" == $methodTail && "" != $target} {
+ error "$errRoot, cannot specify \"as\" with \"*\""
+ }
+
+ if {"*" != $methodTail && "" != $exceptions} {
+ error "$errRoot, can only specify \"except\" with \"*\""
+ }
+
+ if {"" != $pattern && "" != $target} {
+ error "$errRoot, cannot specify both \"as\" and \"using\""
+ }
+
+ foreach token [lrange $method 1 end-1] {
+ if {"*" == $token} {
+ error "$errRoot, \"*\" must be the last token."
+ }
+ }
+
+ # NEXT, define the component
+ if {"" != $component} {
+ Comp.DefineTypecomponent $component $errRoot
+ }
+
+ # NEXT, define the pattern.
+ if {"" == $pattern} {
+ if {"*" == $methodTail} {
+ set pattern "%c %m"
+ } elseif {"" != $target} {
+ set pattern "%c $target"
+ } else {
+ set pattern "%c %m"
+ }
+ }
+
+ # Make sure the pattern is a valid list.
+ if {[catch {lindex $pattern 0} result]} {
+ error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
+ }
+
+ # NEXT, check the method name against previously defined
+ # methods.
+ Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot
+
+ set typemethodInfo($method) [list 0 $pattern $component]
+
+ if {[string equal $methodTail "*"]} {
+ Mappend compile(defs) {
+ set %TYPE%::Snit_info(excepttypemethods) %EXCEPT%
+ } %EXCEPT% [list $exceptions]
+ }
+}
+
+
+# Creates a delegated method delegating it to a particular
+# component or command.
+#
+# method The name of the method
+# arglist Delegation options.
+
+proc ::snit::Comp.DelegatedMethod {method arglist} {
+ variable compile
+ variable methodInfo
+
+ set errRoot "Error in \"delegate method [list $method]...\""
+
+ # Next, parse the delegation options.
+ set component ""
+ set target ""
+ set exceptions {}
+ set pattern ""
+ set methodTail [lindex $method end]
+
+ foreach {opt value} $arglist {
+ switch -exact $opt {
+ to { set component $value }
+ as { set target $value }
+ except { set exceptions $value }
+ using { set pattern $value }
+ default {
+ error "$errRoot, unknown delegation option \"$opt\""
+ }
+ }
+ }
+
+ if {"" == $component && "" == $pattern} {
+ error "$errRoot, missing \"to\""
+ }
+
+ if {"*" == $methodTail && "" != $target} {
+ error "$errRoot, cannot specify \"as\" with \"*\""
+ }
+
+ if {"*" != $methodTail && "" != $exceptions} {
+ error "$errRoot, can only specify \"except\" with \"*\""
+ }
+
+ if {"" != $pattern && "" != $target} {
+ error "$errRoot, cannot specify both \"as\" and \"using\""
+ }
+
+ foreach token [lrange $method 1 end-1] {
+ if {"*" == $token} {
+ error "$errRoot, \"*\" must be the last token."
+ }
+ }
+
+ # NEXT, we delegate some methods
+ set compile(delegatesmethods) yes
+
+ # NEXT, define the component. Allow typecomponents.
+ if {"" != $component} {
+ if {[lsearch -exact $compile(typecomponents) $component] == -1} {
+ Comp.DefineComponent $component $errRoot
+ }
+ }
+
+ # NEXT, define the pattern.
+ if {"" == $pattern} {
+ if {"*" == $methodTail} {
+ set pattern "%c %m"
+ } elseif {"" != $target} {
+ set pattern "%c $target"
+ } else {
+ set pattern "%c %m"
+ }
+ }
+
+ # Make sure the pattern is a valid list.
+ if {[catch {lindex $pattern 0} result]} {
+ error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
+ }
+
+ # NEXT, check the method name against previously defined
+ # methods.
+ Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot
+
+ # NEXT, save the method info.
+ set methodInfo($method) [list 0 $pattern $component]
+
+ if {[string equal $methodTail "*"]} {
+ Mappend compile(defs) {
+ set %TYPE%::Snit_info(exceptmethods) %EXCEPT%
+ } %EXCEPT% [list $exceptions]
+ }
+}
+
+# Creates a delegated option, delegating it to a particular
+# component and, optionally, to a particular option of that
+# component.
+#
+# optionDef The option definition
+# args definition arguments.
+
+proc ::snit::Comp.DelegatedOption {optionDef arglist} {
+ variable compile
+
+ # First, get the three option names.
+ set option [lindex $optionDef 0]
+ set resourceName [lindex $optionDef 1]
+ set className [lindex $optionDef 2]
+
+ set errRoot "Error in \"delegate option [list $optionDef]...\""
+
+ # Next, parse the delegation options.
+ set component ""
+ set target ""
+ set exceptions {}
+
+ foreach {opt value} $arglist {
+ switch -exact $opt {
+ to { set component $value }
+ as { set target $value }
+ except { set exceptions $value }
+ default {
+ error "$errRoot, unknown delegation option \"$opt\""
+ }
+ }
+ }
+
+ if {"" == $component} {
+ error "$errRoot, missing \"to\""
+ }
+
+ if {"*" == $option && "" != $target} {
+ error "$errRoot, cannot specify \"as\" with \"delegate option *\""
+ }
+
+ if {"*" != $option && "" != $exceptions} {
+ error "$errRoot, can only specify \"except\" with \"delegate option *\""
+ }
+
+ # Next, validate the option name
+
+ if {"*" != $option} {
+ if {![Comp.OptionNameIsValid $option]} {
+ error "$errRoot, badly named option \"$option\""
+ }
+ }
+
+ if {[Contains $option $compile(localoptions)]} {
+ error "$errRoot, \"$option\" has been defined locally"
+ }
+
+ if {[Contains $option $compile(delegatedoptions)]} {
+ error "$errRoot, \"$option\" is multiply delegated"
+ }
+
+ # NEXT, define the component
+ Comp.DefineComponent $component $errRoot
+
+ # Next, define the target option, if not specified.
+ if {![string equal $option "*"] &&
+ [string equal $target ""]} {
+ set target $option
+ }
+
+ # NEXT, save the delegation data.
+ set compile(hasoptions) yes
+
+ if {![string equal $option "*"]} {
+ lappend compile(delegatedoptions) $option
+
+ # Next, compute the resource and class names, if they aren't
+ # already defined.
+
+ if {"" == $resourceName} {
+ set resourceName [string range $option 1 end]
+ }
+
+ if {"" == $className} {
+ set className [Capitalize $resourceName]
+ }
+
+ Mappend compile(defs) {
+ set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0
+ set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES%
+ set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
+ lappend %TYPE%::Snit_optionInfo(delegated) %OPTION%
+ set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%]
+ lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION%
+ } %OPTION% $option \
+ %COMP% $component \
+ %TARGET% $target \
+ %RES% $resourceName \
+ %CLASS% $className
+ } else {
+ Mappend compile(defs) {
+ set %TYPE%::Snit_optionInfo(starcomp) %COMP%
+ set %TYPE%::Snit_optionInfo(except) %EXCEPT%
+ } %COMP% $component %EXCEPT% [list $exceptions]
+ }
+}
+
+# Exposes a component, effectively making the component's command an
+# instance method.
+#
+# component The logical name of the delegate
+# "as" sugar; if not "", must be "as"
+# methodname The desired method name for the component's command, or ""
+
+proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} {
+ variable compile
+
+
+ # FIRST, define the component
+ Comp.DefineComponent $component
+
+ # NEXT, define the method just as though it were in the type
+ # definition.
+ if {[string equal $methodname ""]} {
+ set methodname $component
+ }
+
+ Comp.statement.method $methodname args [Expand {
+ if {[llength $args] == 0} {
+ return $%COMPONENT%
+ }
+
+ if {[string equal $%COMPONENT% ""]} {
+ error "undefined component \"%COMPONENT%\""
+ }
+
+
+ set cmd [linsert $args 0 $%COMPONENT%]
+ return [uplevel 1 $cmd]
+ } %COMPONENT% $component]
+}
+
+
+
+#-----------------------------------------------------------------------
+# Public commands
+
+# Compile a type definition, and return the results as a list of two
+# items: the fully-qualified type name, and a script that will define
+# the type when executed.
+#
+# which type, widget, or widgetadaptor
+# type the type name
+# body the type definition
+proc ::snit::compile {which type body} {
+ return [Comp.Compile $which $type $body]
+}
+
+proc ::snit::type {type body} {
+ return [Comp.Define [Comp.Compile type $type $body]]
+}
+
+proc ::snit::widget {type body} {
+ return [Comp.Define [Comp.Compile widget $type $body]]
+}
+
+proc ::snit::widgetadaptor {type body} {
+ return [Comp.Define [Comp.Compile widgetadaptor $type $body]]
+}
+
+proc ::snit::typemethod {type method arglist body} {
+ # Make sure the type exists.
+ if {![info exists ${type}::Snit_info]} {
+ error "no such type: \"$type\""
+ }
+
+ upvar ${type}::Snit_info Snit_info
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+
+ # FIRST, check the typemethod name against previously defined
+ # typemethods.
+ Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \
+ "Cannot define \"$method\""
+
+ # NEXT, check the arguments
+ CheckArgs "snit::typemethod $type $method" $arglist
+
+ # Next, add magic reference to type.
+ set arglist [concat type $arglist]
+
+ # Next, add typevariable declarations to body:
+ set body "$Snit_info(tvardecs)\n$body"
+
+ # Next, define it.
+ if {[llength $method] == 1} {
+ set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
+ uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body]
+ } else {
+ set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
+ set suffix [join $method _]
+ uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body]
+ }
+}
+
+proc ::snit::method {type method arglist body} {
+ # Make sure the type exists.
+ if {![info exists ${type}::Snit_info]} {
+ error "no such type: \"$type\""
+ }
+
+ upvar ${type}::Snit_methodInfo Snit_methodInfo
+ upvar ${type}::Snit_info Snit_info
+
+ # FIRST, check the method name against previously defined
+ # methods.
+ Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \
+ "Cannot define \"$method\""
+
+ # NEXT, check the arguments
+ CheckArgs "snit::method $type $method" $arglist
+
+ # Next, add magic references to type and self.
+ set arglist [concat type selfns win self $arglist]
+
+ # Next, add variable declarations to body:
+ set body "$Snit_info(tvardecs)$Snit_info(ivardecs)\n$body"
+
+ # Next, define it.
+ if {[llength $method] == 1} {
+ set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
+ uplevel 1 [list proc ${type}::Snit_method$method $arglist $body]
+ } else {
+ set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
+
+ set suffix [join $method _]
+ uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body]
+ }
+}
+
+# Defines a proc within the compiler; this proc can call other
+# type definition statements, and thus can be used for meta-programming.
+proc ::snit::macro {name arglist body} {
+ variable compiler
+ variable reservedwords
+
+ # FIRST, make sure the compiler is defined.
+ Comp.Init
+
+ # NEXT, check the macro name against the reserved words
+ if {[lsearch -exact $reservedwords $name] != -1} {
+ error "invalid macro name \"$name\""
+ }
+
+ # NEXT, see if the name has a namespace; if it does, define the
+ # namespace.
+ set ns [namespace qualifiers $name]
+
+ if {"" != $ns} {
+ $compiler eval "namespace eval $ns {}"
+ }
+
+ # NEXT, define the macro
+ $compiler eval [list _proc $name $arglist $body]
+}
+
+#-----------------------------------------------------------------------
+# Utility Functions
+#
+# These are utility functions used while compiling Snit types.
+
+# Builds a template from a tagged list of text blocks, then substitutes
+# all symbols in the mapTable, returning the expanded template.
+proc ::snit::Expand {template args} {
+ return [string map $args $template]
+}
+
+# Expands a template and appends it to a variable.
+proc ::snit::Mappend {varname template args} {
+ upvar $varname myvar
+
+ append myvar [string map $args $template]
+}
+
+# Checks argument list against reserved args
+proc ::snit::CheckArgs {which arglist} {
+ variable reservedArgs
+
+ foreach name $reservedArgs {
+ if {[Contains $name $arglist]} {
+ error "$which's arglist may not contain \"$name\" explicitly"
+ }
+ }
+}
+
+# Returns 1 if a value is in a list, and 0 otherwise.
+proc ::snit::Contains {value list} {
+ if {[lsearch -exact $list $value] != -1} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# Capitalizes the first letter of a string.
+proc ::snit::Capitalize {text} {
+ return [string toupper $text 0]
+}
+
+# Converts an arbitrary white-space-delimited string into a list
+# by splitting on white-space and deleting empty tokens.
+
+proc ::snit::Listify {str} {
+ set result {}
+ foreach token [split [string trim $str]] {
+ if {[string length $token] > 0} {
+ lappend result $token
+ }
+ }
+
+ return $result
+}
+
+
+#=======================================================================
+# Snit Runtime Library
+#
+# These are procs used by Snit types and widgets at runtime.
+
+#-----------------------------------------------------------------------
+# Object Creation
+
+# Creates a new instance of the snit::type given its name and the args.
+#
+# type The snit::type
+# name The instance name
+# args Args to pass to the constructor
+
+proc ::snit::RT.type.typemethod.create {type name args} {
+ variable ${type}::Snit_info
+ variable ${type}::Snit_optionInfo
+
+ # FIRST, qualify the name.
+ if {![string match "::*" $name]} {
+ # Get caller's namespace;
+ # append :: if not global namespace.
+ set ns [uplevel 1 [list namespace current]]
+ if {"::" != $ns} {
+ append ns "::"
+ }
+
+ set name "$ns$name"
+ }
+
+ # NEXT, if %AUTO% appears in the name, generate a unique
+ # command name. Otherwise, ensure that the name isn't in use.
+ if {[string match "*%AUTO%*" $name]} {
+ set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
+ } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} {
+ error "command \"$name\" already exists"
+ }
+
+ # NEXT, create the instance's namespace.
+ set selfns \
+ [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
+ namespace eval $selfns {}
+
+ # NEXT, install the dispatcher
+ RT.MakeInstanceCommand $type $selfns $name
+
+ # Initialize the options to their defaults.
+ upvar ${selfns}::options options
+ foreach opt $Snit_optionInfo(local) {
+ set options($opt) $Snit_optionInfo(default-$opt)
+ }
+
+ # Initialize the instance vars to their defaults.
+ # selfns must be defined, as it is used implicitly.
+ ${type}::Snit_instanceVars $selfns
+
+ # Execute the type's constructor.
+ set errcode [catch {
+ RT.ConstructInstance $type $selfns $name $args
+ } result]
+
+ if {$errcode} {
+ global errorInfo
+ global errorCode
+
+ set theInfo $errorInfo
+ set theCode $errorCode
+ ::snit::RT.DestroyObject $type $selfns $name
+ error "Error in constructor: $result" $theInfo $theCode
+ }
+
+ # NEXT, return the object's name.
+ return $name
+}
+
+# Creates a new instance of the snit::widget or snit::widgetadaptor
+# given its name and the args.
+#
+# type The snit::widget or snit::widgetadaptor
+# name The instance name
+# args Args to pass to the constructor
+
+proc ::snit::RT.widget.typemethod.create {type name args} {
+ variable ${type}::Snit_info
+ variable ${type}::Snit_optionInfo
+
+ # FIRST, if %AUTO% appears in the name, generate a unique
+ # command name.
+ if {[string match "*%AUTO%*" $name]} {
+ set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
+ }
+
+ # NEXT, create the instance's namespace.
+ set selfns \
+ [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
+ namespace eval $selfns { }
+
+ # NEXT, Initialize the widget's own options to their defaults.
+ upvar ${selfns}::options options
+ foreach opt $Snit_optionInfo(local) {
+ set options($opt) $Snit_optionInfo(default-$opt)
+ }
+
+ # Initialize the instance vars to their defaults.
+ ${type}::Snit_instanceVars $selfns
+
+ # NEXT, if this is a normal widget (not a widget adaptor) then create a
+ # frame as its hull. We set the frame's -class to the user's widgetclass,
+ # or, if none, search for -class in the args list, otherwise default to
+ # the basename of the $type with an initial upper case letter.
+ if {!$Snit_info(isWidgetAdaptor)} {
+ # FIRST, determine the class name
+ set wclass $Snit_info(widgetclass)
+ if {$Snit_info(widgetclass) eq ""} {
+ set idx [lsearch -exact $args -class]
+ if {$idx >= 0 && ($idx%2 == 0)} {
+ # -class exists and is in the -option position
+ set wclass [lindex $args [expr {$idx+1}]]
+ set args [lreplace $args $idx [expr {$idx+1}]]
+ } else {
+ set wclass [::snit::Capitalize [namespace tail $type]]
+ }
+ }
+
+ # NEXT, create the widget
+ set self $name
+ package require Tk
+ ${type}::installhull using $Snit_info(hulltype) -class $wclass
+
+ # NEXT, let's query the option database for our
+ # widget, now that we know that it exists.
+ foreach opt $Snit_optionInfo(local) {
+ set dbval [RT.OptionDbGet $type $name $opt]
+
+ if {"" != $dbval} {
+ set options($opt) $dbval
+ }
+ }
+ }
+
+ # Execute the type's constructor, and verify that it
+ # has a hull.
+ set errcode [catch {
+ RT.ConstructInstance $type $selfns $name $args
+
+ ::snit::RT.Component $type $selfns hull
+
+ # Prepare to call the object's destructor when the
+ # <Destroy> event is received. Use a Snit-specific bindtag
+ # so that the widget name's tag is unencumbered.
+
+ bind Snit$type$name <Destroy> [::snit::Expand {
+ ::snit::RT.DestroyObject %TYPE% %NS% %W
+ } %TYPE% $type %NS% $selfns]
+
+ # Insert the bindtag into the list of bindtags right
+ # after the widget name.
+ set taglist [bindtags $name]
+ set ndx [lsearch -exact $taglist $name]
+ incr ndx
+ bindtags $name [linsert $taglist $ndx Snit$type$name]
+ } result]
+
+ if {$errcode} {
+ global errorInfo
+ global errorCode
+
+ set theInfo $errorInfo
+ set theCode $errorCode
+ ::snit::RT.DestroyObject $type $selfns $name
+ error "Error in constructor: $result" $theInfo $theCode
+ }
+
+ # NEXT, return the object's name.
+ return $name
+}
+
+
+# RT.MakeInstanceCommand type selfns instance
+#
+# type The object type
+# selfns The instance namespace
+# instance The instance name
+#
+# Creates the instance proc.
+
+proc ::snit::RT.MakeInstanceCommand {type selfns instance} {
+ variable ${type}::Snit_info
+
+ # FIRST, remember the instance name. The Snit_instance variable
+ # allows the instance to figure out its current name given the
+ # instance namespace.
+ upvar ${selfns}::Snit_instance Snit_instance
+ set Snit_instance $instance
+
+ # NEXT, qualify the proc name if it's a widget.
+ if {$Snit_info(isWidget)} {
+ set procname ::$instance
+ } else {
+ set procname $instance
+ }
+
+ # NEXT, install the new proc
+ if {!$Snit_info(simpledispatch)} {
+ set instanceProc $::snit::nominalInstanceProc
+ } else {
+ set instanceProc $::snit::simpleInstanceProc
+ }
+
+ proc $procname {method args} \
+ [string map \
+ [list %SELFNS% $selfns %WIN% $instance %TYPE% $type] \
+ $instanceProc]
+
+ # NEXT, add the trace.
+ trace add command $procname {rename delete} \
+ [list ::snit::RT.InstanceTrace $type $selfns $instance]
+}
+
+# This proc is called when the instance command is renamed.
+# If op is delete, then new will always be "", so op is redundant.
+#
+# type The fully-qualified type name
+# selfns The instance namespace
+# win The original instance/tk window name.
+# old old instance command name
+# new new instance command name
+# op rename or delete
+#
+# If the op is delete, we need to clean up the object; otherwise,
+# we need to track the change.
+#
+# NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete
+# traces aren't propagated correctly. Instead, they silently
+# vanish. Add a catch to output any error message.
+
+proc ::snit::RT.InstanceTrace {type selfns win old new op} {
+ variable ${type}::Snit_info
+
+ # Note to developers ...
+ # For Tcl 8.4.0, errors thrown in trace handlers vanish silently.
+ # Therefore we catch them here and create some output to help in
+ # debugging such problems.
+
+ if {[catch {
+ # FIRST, clean up if necessary
+ if {"" == $new} {
+ if {$Snit_info(isWidget)} {
+ destroy $win
+ } else {
+ ::snit::RT.DestroyObject $type $selfns $win
+ }
+ } else {
+ # Otherwise, track the change.
+ variable ${selfns}::Snit_instance
+ set Snit_instance [uplevel 1 [list namespace which -command $new]]
+
+ # Also, clear the instance caches, as many cached commands
+ # might be invalid.
+ RT.ClearInstanceCaches $selfns
+ }
+ } result]} {
+ global errorInfo
+ # Pop up the console on Windows wish, to enable stdout.
+ # This clobbers errorInfo on unix, so save it so we can print it.
+ set ei $errorInfo
+ catch {console show}
+ puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:"
+ puts $ei
+ }
+}
+
+# Calls the instance constructor and handles related housekeeping.
+proc ::snit::RT.ConstructInstance {type selfns instance arglist} {
+ variable ${type}::Snit_optionInfo
+ variable ${selfns}::Snit_iinfo
+
+ # Track whether we are constructed or not.
+ set Snit_iinfo(constructed) 0
+
+ # Call the user's constructor
+ eval [linsert $arglist 0 \
+ ${type}::Snit_constructor $type $selfns $instance $instance]
+
+ set Snit_iinfo(constructed) 1
+
+ # Validate the initial set of options (including defaults)
+ foreach option $Snit_optionInfo(local) {
+ set value [set ${selfns}::options($option)]
+
+ if {"" != $Snit_optionInfo(typespec-$option)} {
+ if {[catch {
+ $Snit_optionInfo(typeobj-$option) validate $value
+ } result]} {
+ return -code error "invalid $option default: $result"
+ }
+ }
+ }
+
+ # Unset the configure cache for all -readonly options.
+ # This ensures that the next time anyone tries to
+ # configure it, an error is thrown.
+ foreach opt $Snit_optionInfo(local) {
+ if {$Snit_optionInfo(readonly-$opt)} {
+ unset -nocomplain ${selfns}::Snit_configureCache($opt)
+ }
+ }
+
+ return
+}
+
+# Returns a unique command name.
+#
+# REQUIRE: type is a fully qualified name.
+# REQUIRE: name contains "%AUTO%"
+# PROMISE: the returned command name is unused.
+proc ::snit::RT.UniqueName {countervar type name} {
+ upvar $countervar counter
+ while 1 {
+ # FIRST, bump the counter and define the %AUTO% instance name;
+ # then substitute it into the specified name. Wrap around at
+ # 2^31 - 2 to prevent overflow problems.
+ incr counter
+ if {$counter > 2147483646} {
+ set counter 0
+ }
+ set auto "[namespace tail $type]$counter"
+ set candidate [Expand $name %AUTO% $auto]
+ if {![llength [info commands $candidate]]} {
+ return $candidate
+ }
+ }
+}
+
+# Returns a unique instance namespace, fully qualified.
+#
+# countervar The name of a counter variable
+# type The instance's type
+#
+# REQUIRE: type is fully qualified
+# PROMISE: The returned namespace name is unused.
+
+proc ::snit::RT.UniqueInstanceNamespace {countervar type} {
+ upvar $countervar counter
+ while 1 {
+ # FIRST, bump the counter and define the namespace name.
+ # Then see if it already exists. Wrap around at
+ # 2^31 - 2 to prevent overflow problems.
+ incr counter
+ if {$counter > 2147483646} {
+ set counter 0
+ }
+ set ins "${type}::Snit_inst${counter}"
+ if {![namespace exists $ins]} {
+ return $ins
+ }
+ }
+}
+
+# Retrieves an option's value from the option database.
+# Returns "" if no value is found.
+proc ::snit::RT.OptionDbGet {type self opt} {
+ variable ${type}::Snit_optionInfo
+
+ return [option get $self \
+ $Snit_optionInfo(resource-$opt) \
+ $Snit_optionInfo(class-$opt)]
+}
+
+#-----------------------------------------------------------------------
+# Object Destruction
+
+# Implements the standard "destroy" method
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+
+proc ::snit::RT.method.destroy {type selfns win self} {
+ variable ${selfns}::Snit_iinfo
+
+ # Can't destroy the object if it isn't complete constructed.
+ if {!$Snit_iinfo(constructed)} {
+ return -code error "Called 'destroy' method in constructor"
+ }
+
+ # Calls Snit_cleanup, which (among other things) calls the
+ # user's destructor.
+ ::snit::RT.DestroyObject $type $selfns $win
+}
+
+# This is the function that really cleans up; it's automatically
+# called when any instance is destroyed, e.g., by "$object destroy"
+# for types, and by the <Destroy> event for widgets.
+#
+# type The fully-qualified type name.
+# selfns The instance namespace
+# win The original instance command name.
+
+proc ::snit::RT.DestroyObject {type selfns win} {
+ variable ${type}::Snit_info
+
+ # If the variable Snit_instance doesn't exist then there's no
+ # instance command for this object -- it's most likely a
+ # widgetadaptor. Consequently, there are some things that
+ # we don't need to do.
+ if {[info exists ${selfns}::Snit_instance]} {
+ upvar ${selfns}::Snit_instance instance
+
+ # First, remove the trace on the instance name, so that we
+ # don't call RT.DestroyObject recursively.
+ RT.RemoveInstanceTrace $type $selfns $win $instance
+
+ # Next, call the user's destructor
+ ${type}::Snit_destructor $type $selfns $win $instance
+
+ # Next, if this isn't a widget, delete the instance command.
+ # If it is a widget, get the hull component's name, and rename
+ # it back to the widget name
+
+ # Next, delete the hull component's instance command,
+ # if there is one.
+ if {$Snit_info(isWidget)} {
+ set hullcmd [::snit::RT.Component $type $selfns hull]
+
+ catch {rename $instance ""}
+
+ # Clear the bind event
+ bind Snit$type$win <Destroy> ""
+
+ if {[llength [info commands $hullcmd]]} {
+ # FIRST, rename the hull back to its original name.
+ # If the hull is itself a megawidget, it will have its
+ # own cleanup to do, and it might not do it properly
+ # if it doesn't have the right name.
+ rename $hullcmd ::$instance
+
+ # NEXT, destroy it.
+ destroy $instance
+ }
+ } else {
+ catch {rename $instance ""}
+ }
+ }
+
+ # Next, delete the instance's namespace. This kills any
+ # instance variables.
+ namespace delete $selfns
+
+ return
+}
+
+# Remove instance trace
+#
+# type The fully qualified type name
+# selfns The instance namespace
+# win The original instance name/Tk window name
+# instance The current instance name
+
+proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} {
+ variable ${type}::Snit_info
+
+ if {$Snit_info(isWidget)} {
+ set procname ::$instance
+ } else {
+ set procname $instance
+ }
+
+ # NEXT, remove any trace on this name
+ catch {
+ trace remove command $procname {rename delete} \
+ [list ::snit::RT.InstanceTrace $type $selfns $win]
+ }
+}
+
+#-----------------------------------------------------------------------
+# Typecomponent Management and Method Caching
+
+# Typecomponent trace; used for write trace on typecomponent
+# variables. Saves the new component object name, provided
+# that certain conditions are met. Also clears the typemethod
+# cache.
+
+proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} {
+ upvar ${type}::Snit_info Snit_info
+ upvar ${type}::${component} cvar
+ upvar ${type}::Snit_typecomponents Snit_typecomponents
+
+ # Save the new component value.
+ set Snit_typecomponents($component) $cvar
+
+ # Clear the typemethod cache.
+ # TBD: can we unset just the elements related to
+ # this component?
+ unset -nocomplain -- ${type}::Snit_typemethodCache
+}
+
+# Generates and caches the command for a typemethod.
+#
+# type The type
+# method The name of the typemethod to call.
+#
+# The return value is one of the following lists:
+#
+# {} There's no such method.
+# {1} The method has submethods; look again.
+# {0 <command>} Here's the command to execute.
+
+proc snit::RT.CacheTypemethodCommand {type method} {
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+ upvar ${type}::Snit_typecomponents Snit_typecomponents
+ upvar ${type}::Snit_typemethodCache Snit_typemethodCache
+ upvar ${type}::Snit_info Snit_info
+
+ # FIRST, get the pattern data and the typecomponent name.
+ set implicitCreate 0
+ set instanceName ""
+
+ set starredMethod [lreplace $method end end *]
+ set methodTail [lindex $method end]
+
+ if {[info exists Snit_typemethodInfo($method)]} {
+ set key $method
+ } elseif {[info exists Snit_typemethodInfo($starredMethod)]} {
+ if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} {
+ set key $starredMethod
+ } else {
+ return [list ]
+ }
+ } elseif {[llength $method] > 1} {
+ return [list ]
+ } elseif {$Snit_info(hasinstances)} {
+ # Assume the unknown name is an instance name to create, unless
+ # this is a widget and the style of the name is wrong, or the
+ # name mimics a standard typemethod.
+
+ if {[set ${type}::Snit_info(isWidget)] &&
+ ![string match ".*" $method]} {
+ return [list ]
+ }
+
+ # Without this check, the call "$type info" will redefine the
+ # standard "::info" command, with disastrous results. Since it's
+ # a likely thing to do if !-typeinfo, put in an explicit check.
+ if {"info" == $method || "destroy" == $method} {
+ return [list ]
+ }
+
+ set implicitCreate 1
+ set instanceName $method
+ set key create
+ set method create
+ } else {
+ return [list ]
+ }
+
+ foreach {flag pattern compName} $Snit_typemethodInfo($key) {}
+
+ if {$flag == 1} {
+ return [list 1]
+ }
+
+ # NEXT, build the substitution list
+ set subList [list \
+ %% % \
+ %t $type \
+ %M $method \
+ %m [lindex $method end] \
+ %j [join $method _]]
+
+ if {"" != $compName} {
+ if {![info exists Snit_typecomponents($compName)]} {
+ error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\""
+ }
+
+ lappend subList %c [list $Snit_typecomponents($compName)]
+ }
+
+ set command {}
+
+ foreach subpattern $pattern {
+ lappend command [string map $subList $subpattern]
+ }
+
+ if {$implicitCreate} {
+ # In this case, $method is the name of the instance to
+ # create. Don't cache, as we usually won't do this one
+ # again.
+ lappend command $instanceName
+ } else {
+ set Snit_typemethodCache($method) [list 0 $command]
+ }
+
+ return [list 0 $command]
+}
+
+
+#-----------------------------------------------------------------------
+# Component Management and Method Caching
+
+# Retrieves the object name given the component name.
+proc ::snit::RT.Component {type selfns name} {
+ variable ${selfns}::Snit_components
+
+ if {[catch {set Snit_components($name)} result]} {
+ variable ${selfns}::Snit_instance
+
+ error "component \"$name\" is undefined in $type $Snit_instance"
+ }
+
+ return $result
+}
+
+# Component trace; used for write trace on component instance
+# variables. Saves the new component object name, provided
+# that certain conditions are met. Also clears the method
+# cache.
+
+proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} {
+ upvar ${type}::Snit_info Snit_info
+ upvar ${selfns}::${component} cvar
+ upvar ${selfns}::Snit_components Snit_components
+
+ # If they try to redefine the hull component after
+ # it's been defined, that's an error--but only if
+ # this is a widget or widget adaptor.
+ if {"hull" == $component &&
+ $Snit_info(isWidget) &&
+ [info exists Snit_components($component)]} {
+ set cvar $Snit_components($component)
+ error "The hull component cannot be redefined"
+ }
+
+ # Save the new component value.
+ set Snit_components($component) $cvar
+
+ # Clear the instance caches.
+ # TBD: can we unset just the elements related to
+ # this component?
+ RT.ClearInstanceCaches $selfns
+}
+
+# Generates and caches the command for a method.
+#
+# type: The instance's type
+# selfns: The instance's private namespace
+# win: The instance's original name (a Tk widget name, for
+# snit::widgets.
+# self: The instance's current name.
+# method: The name of the method to call.
+#
+# The return value is one of the following lists:
+#
+# {} There's no such method.
+# {1} The method has submethods; look again.
+# {0 <command>} Here's the command to execute.
+
+proc ::snit::RT.CacheMethodCommand {type selfns win self method} {
+ variable ${type}::Snit_info
+ variable ${type}::Snit_methodInfo
+ variable ${type}::Snit_typecomponents
+ variable ${selfns}::Snit_components
+ variable ${selfns}::Snit_methodCache
+
+ # FIRST, get the pattern data and the component name.
+ set starredMethod [lreplace $method end end *]
+ set methodTail [lindex $method end]
+
+ if {[info exists Snit_methodInfo($method)]} {
+ set key $method
+ } elseif {[info exists Snit_methodInfo($starredMethod)] &&
+ [lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} {
+ set key $starredMethod
+ } else {
+ return [list ]
+ }
+
+ foreach {flag pattern compName} $Snit_methodInfo($key) {}
+
+ if {$flag == 1} {
+ return [list 1]
+ }
+
+ # NEXT, build the substitution list
+ set subList [list \
+ %% % \
+ %t $type \
+ %M $method \
+ %m [lindex $method end] \
+ %j [join $method _] \
+ %n [list $selfns] \
+ %w [list $win] \
+ %s [list $self]]
+
+ if {"" != $compName} {
+ if {[info exists Snit_components($compName)]} {
+ set compCmd $Snit_components($compName)
+ } elseif {[info exists Snit_typecomponents($compName)]} {
+ set compCmd $Snit_typecomponents($compName)
+ } else {
+ error "$type $self delegates method \"$method\" to undefined component \"$compName\""
+ }
+
+ lappend subList %c [list $compCmd]
+ }
+
+ # Note: The cached command will executed faster if it's
+ # already a list.
+ set command {}
+
+ foreach subpattern $pattern {
+ lappend command [string map $subList $subpattern]
+ }
+
+ set commandRec [list 0 $command]
+
+ set Snit_methodCache($method) $commandRec
+
+ return $commandRec
+}
+
+
+# Looks up a method's command.
+#
+# type: The instance's type
+# selfns: The instance's private namespace
+# win: The instance's original name (a Tk widget name, for
+# snit::widgets.
+# self: The instance's current name.
+# method: The name of the method to call.
+# errPrefix: Prefix for any error method
+proc ::snit::RT.LookupMethodCommand {type selfns win self method errPrefix} {
+ set commandRec [snit::RT.CacheMethodCommand \
+ $type $selfns $win $self \
+ $method]
+
+
+ if {[llength $commandRec] == 0} {
+ return -code error \
+ "$errPrefix, \"$self $method\" is not defined"
+ } elseif {[lindex $commandRec 0] == 1} {
+ return -code error \
+ "$errPrefix, wrong number args: should be \"$self\" $method method args"
+ }
+
+ return [lindex $commandRec 1]
+}
+
+
+# Clears all instance command caches
+proc ::snit::RT.ClearInstanceCaches {selfns} {
+ unset -nocomplain -- ${selfns}::Snit_methodCache
+ unset -nocomplain -- ${selfns}::Snit_cgetCache
+ unset -nocomplain -- ${selfns}::Snit_configureCache
+ unset -nocomplain -- ${selfns}::Snit_validateCache
+}
+
+
+#-----------------------------------------------------------------------
+# Component Installation
+
+# Implements %TYPE%::installhull. The variables self and selfns
+# must be defined in the caller's context.
+#
+# Installs the named widget as the hull of a
+# widgetadaptor. Once the widget is hijacked, its new name
+# is assigned to the hull component.
+
+proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} {
+ variable ${type}::Snit_info
+ variable ${type}::Snit_optionInfo
+ upvar self self
+ upvar selfns selfns
+ upvar ${selfns}::hull hull
+ upvar ${selfns}::options options
+
+ # FIRST, make sure we can do it.
+ if {!$Snit_info(isWidget)} {
+ error "installhull is valid only for snit::widgetadaptors"
+ }
+
+ if {[info exists ${selfns}::Snit_instance]} {
+ error "hull already installed for $type $self"
+ }
+
+ # NEXT, has it been created yet? If not, create it using
+ # the specified arguments.
+ if {"using" == $using} {
+ # FIRST, create the widget
+ set cmd [linsert $args 0 $widgetType $self]
+ set obj [uplevel 1 $cmd]
+
+ # NEXT, for each option explicitly delegated to the hull
+ # that doesn't appear in the usedOpts list, get the
+ # option database value and apply it--provided that the
+ # real option name and the target option name are different.
+ # (If they are the same, then the option database was
+ # already queried as part of the normal widget creation.)
+ #
+ # Also, we don't need to worry about implicitly delegated
+ # options, as the option and target option names must be
+ # the same.
+ if {[info exists Snit_optionInfo(delegated-hull)]} {
+
+ # FIRST, extract all option names from args
+ set usedOpts {}
+ set ndx [lsearch -glob $args "-*"]
+ foreach {opt val} [lrange $args $ndx end] {
+ lappend usedOpts $opt
+ }
+
+ foreach opt $Snit_optionInfo(delegated-hull) {
+ set target [lindex $Snit_optionInfo(target-$opt) 1]
+
+ if {"$target" == $opt} {
+ continue
+ }
+
+ set result [lsearch -exact $usedOpts $target]
+
+ if {$result != -1} {
+ continue
+ }
+
+ set dbval [RT.OptionDbGet $type $self $opt]
+ $obj configure $target $dbval
+ }
+ }
+ } else {
+ set obj $using
+
+ if {![string equal $obj $self]} {
+ error \
+ "hull name mismatch: \"$obj\" != \"$self\""
+ }
+ }
+
+ # NEXT, get the local option defaults.
+ foreach opt $Snit_optionInfo(local) {
+ set dbval [RT.OptionDbGet $type $self $opt]
+
+ if {"" != $dbval} {
+ set options($opt) $dbval
+ }
+ }
+
+
+ # NEXT, do the magic
+ set i 0
+ while 1 {
+ incr i
+ set newName "::hull${i}$self"
+ if {![llength [info commands $newName]]} {
+ break
+ }
+ }
+
+ rename ::$self $newName
+ RT.MakeInstanceCommand $type $selfns $self
+
+ # Note: this relies on RT.ComponentTrace to do the dirty work.
+ set hull $newName
+
+ return
+}
+
+# Implements %TYPE%::install.
+#
+# Creates a widget and installs it as the named component.
+# It expects self and selfns to be defined in the caller's context.
+
+proc ::snit::RT.install {type compName "using" widgetType winPath args} {
+ variable ${type}::Snit_optionInfo
+ variable ${type}::Snit_info
+ upvar self self
+ upvar selfns selfns
+ upvar ${selfns}::$compName comp
+ upvar ${selfns}::hull hull
+
+ # We do the magic option database stuff only if $self is
+ # a widget.
+ if {$Snit_info(isWidget)} {
+ if {"" == $hull} {
+ error "tried to install \"$compName\" before the hull exists"
+ }
+
+ # FIRST, query the option database and save the results
+ # into args. Insert them before the first option in the
+ # list, in case there are any non-standard parameters.
+ #
+ # Note: there might not be any delegated options; if so,
+ # don't bother.
+
+ if {[info exists Snit_optionInfo(delegated-$compName)]} {
+ set ndx [lsearch -glob $args "-*"]
+
+ foreach opt $Snit_optionInfo(delegated-$compName) {
+ set dbval [RT.OptionDbGet $type $self $opt]
+
+ if {"" != $dbval} {
+ set target [lindex $Snit_optionInfo(target-$opt) 1]
+ set args [linsert $args $ndx $target $dbval]
+ }
+ }
+ }
+ }
+
+ # NEXT, create the component and save it.
+ set cmd [concat [list $widgetType $winPath] $args]
+ set comp [uplevel 1 $cmd]
+
+ # NEXT, handle the option database for "delegate option *",
+ # in widgets only.
+ if {$Snit_info(isWidget) && [string equal $Snit_optionInfo(starcomp) $compName]} {
+ # FIRST, get the list of option specs from the widget.
+ # If configure doesn't work, skip it.
+ if {[catch {$comp configure} specs]} {
+ return
+ }
+
+ # NEXT, get the set of explicitly used options from args
+ set usedOpts {}
+ set ndx [lsearch -glob $args "-*"]
+ foreach {opt val} [lrange $args $ndx end] {
+ lappend usedOpts $opt
+ }
+
+ # NEXT, "delegate option *" matches all options defined
+ # by this widget that aren't defined by the widget as a whole,
+ # and that aren't excepted. Plus, we skip usedOpts. So build
+ # a list of the options it can't match.
+ set skiplist [concat \
+ $usedOpts \
+ $Snit_optionInfo(except) \
+ $Snit_optionInfo(local) \
+ $Snit_optionInfo(delegated)]
+
+ # NEXT, loop over all of the component's options, and set
+ # any not in the skip list for which there is an option
+ # database value.
+ foreach spec $specs {
+ # Skip aliases
+ if {[llength $spec] != 5} {
+ continue
+ }
+
+ set opt [lindex $spec 0]
+
+ if {[lsearch -exact $skiplist $opt] != -1} {
+ continue
+ }
+
+ set res [lindex $spec 1]
+ set cls [lindex $spec 2]
+
+ set dbvalue [option get $self $res $cls]
+
+ if {"" != $dbvalue} {
+ $comp configure $opt $dbvalue
+ }
+ }
+ }
+
+ return
+}
+
+
+#-----------------------------------------------------------------------
+# Method/Variable Name Qualification
+
+# Implements %TYPE%::variable. Requires selfns.
+proc ::snit::RT.variable {varname} {
+ upvar selfns selfns
+
+ if {![string match "::*" $varname]} {
+ uplevel 1 [list upvar 1 ${selfns}::$varname $varname]
+ } else {
+ # varname is fully qualified; let the standard
+ # "variable" command handle it.
+ uplevel 1 [list ::variable $varname]
+ }
+}
+
+# Fully qualifies a typevariable name.
+#
+# This is used to implement the mytypevar command.
+
+proc ::snit::RT.mytypevar {type name} {
+ return ${type}::$name
+}
+
+# Fully qualifies an instance variable name.
+#
+# This is used to implement the myvar command.
+proc ::snit::RT.myvar {name} {
+ upvar selfns selfns
+ return ${selfns}::$name
+}
+
+# Use this like "list" to convert a proc call into a command
+# string to pass to another object (e.g., as a -command).
+# Qualifies the proc name properly.
+#
+# This is used to implement the "myproc" command.
+
+proc ::snit::RT.myproc {type procname args} {
+ set procname "${type}::$procname"
+ return [linsert $args 0 $procname]
+}
+
+# DEPRECATED
+proc ::snit::RT.codename {type name} {
+ return "${type}::$name"
+}
+
+# Use this like "list" to convert a typemethod call into a command
+# string to pass to another object (e.g., as a -command).
+# Inserts the type command at the beginning.
+#
+# This is used to implement the "mytypemethod" command.
+
+proc ::snit::RT.mytypemethod {type args} {
+ return [linsert $args 0 $type]
+}
+
+# Use this like "list" to convert a method call into a command
+# string to pass to another object (e.g., as a -command).
+# Inserts the code at the beginning to call the right object, even if
+# the object's name has changed. Requires that selfns be defined
+# in the calling context, eg. can only be called in instance
+# code.
+#
+# This is used to implement the "mymethod" command.
+
+proc ::snit::RT.mymethod {args} {
+ upvar selfns selfns
+ return [linsert $args 0 ::snit::RT.CallInstance ${selfns}]
+}
+
+# Calls an instance method for an object given its
+# instance namespace and remaining arguments (the first of which
+# will be the method name.
+#
+# selfns The instance namespace
+# args The arguments
+#
+# Uses the selfns to determine $self, and calls the method
+# in the normal way.
+#
+# This is used to implement the "mymethod" command.
+
+proc ::snit::RT.CallInstance {selfns args} {
+ upvar ${selfns}::Snit_instance self
+
+ set retval [catch {uplevel 1 [linsert $args 0 $self]} result]
+
+ if {$retval} {
+ if {$retval == 1} {
+ global errorInfo
+ global errorCode
+ return -code error -errorinfo $errorInfo \
+ -errorcode $errorCode $result
+ } else {
+ return -code $retval $result
+ }
+ }
+
+ return $result
+}
+
+# Looks for the named option in the named variable. If found,
+# it and its value are removed from the list, and the value
+# is returned. Otherwise, the default value is returned.
+# If the option is undelegated, it's own default value will be
+# used if none is specified.
+#
+# Implements the "from" command.
+
+proc ::snit::RT.from {type argvName option {defvalue ""}} {
+ variable ${type}::Snit_optionInfo
+ upvar $argvName argv
+
+ set ioption [lsearch -exact $argv $option]
+
+ if {$ioption == -1} {
+ if {"" == $defvalue &&
+ [info exists Snit_optionInfo(default-$option)]} {
+ return $Snit_optionInfo(default-$option)
+ } else {
+ return $defvalue
+ }
+ }
+
+ set ivalue [expr {$ioption + 1}]
+ set value [lindex $argv $ivalue]
+
+ set argv [lreplace $argv $ioption $ivalue]
+
+ return $value
+}
+
+#-----------------------------------------------------------------------
+# Type Destruction
+
+# Implements the standard "destroy" typemethod:
+# Destroys a type completely.
+#
+# type The snit type
+
+proc ::snit::RT.typemethod.destroy {type} {
+ variable ${type}::Snit_info
+
+ # FIRST, destroy all instances
+ foreach selfns [namespace children $type "${type}::Snit_inst*"] {
+ if {![namespace exists $selfns]} {
+ continue
+ }
+ upvar ${selfns}::Snit_instance obj
+
+ if {$Snit_info(isWidget)} {
+ destroy $obj
+ } else {
+ if {[llength [info commands $obj]]} {
+ $obj destroy
+ }
+ }
+ }
+
+ # NEXT, destroy the type's data.
+ namespace delete $type
+
+ # NEXT, get rid of the type command.
+ rename $type ""
+}
+
+
+
+#-----------------------------------------------------------------------
+# Option Handling
+
+# Implements the standard "cget" method
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# option The name of the option
+
+proc ::snit::RT.method.cget {type selfns win self option} {
+ if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} {
+ set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option]
+
+ if {[llength $command] == 0} {
+ return -code error "unknown option \"$option\""
+ }
+ }
+
+ uplevel 1 $command
+}
+
+# Retrieves and caches the command that implements "cget" for the
+# specified option.
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# option The name of the option
+
+proc ::snit::RT.CacheCgetCommand {type selfns win self option} {
+ variable ${type}::Snit_optionInfo
+ variable ${selfns}::Snit_cgetCache
+
+ if {[info exists Snit_optionInfo(islocal-$option)]} {
+ # We know the item; it's either local, or explicitly delegated.
+ if {$Snit_optionInfo(islocal-$option)} {
+ # It's a local option. If it has a cget method defined,
+ # use it; otherwise just return the value.
+
+ if {"" == $Snit_optionInfo(cget-$option)} {
+ set command [list set ${selfns}::options($option)]
+ } else {
+ set command [snit::RT.LookupMethodCommand \
+ $type $selfns $win $self \
+ $Snit_optionInfo(cget-$option) \
+ "can't cget $option"]
+
+ lappend command $option
+ }
+
+ set Snit_cgetCache($option) $command
+ return $command
+ }
+
+ # Explicitly delegated option; get target
+ set comp [lindex $Snit_optionInfo(target-$option) 0]
+ set target [lindex $Snit_optionInfo(target-$option) 1]
+ } elseif {"" != $Snit_optionInfo(starcomp) &&
+ [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
+ # Unknown option, but unknowns are delegated; get target.
+ set comp $Snit_optionInfo(starcomp)
+ set target $option
+ } else {
+ return ""
+ }
+
+ # Get the component's object.
+ set obj [RT.Component $type $selfns $comp]
+
+ set command [list $obj cget $target]
+ set Snit_cgetCache($option) $command
+
+ return $command
+}
+
+# Implements the standard "configurelist" method
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# optionlist A list of options and their values.
+
+proc ::snit::RT.method.configurelist {type selfns win self optionlist} {
+ variable ${type}::Snit_optionInfo
+
+ foreach {option value} $optionlist {
+ # FIRST, get the configure command, caching it if need be.
+ if {[catch {set ${selfns}::Snit_configureCache($option)} command]} {
+ set command [snit::RT.CacheConfigureCommand \
+ $type $selfns $win $self $option]
+
+ if {[llength $command] == 0} {
+ return -code error "unknown option \"$option\""
+ }
+ }
+
+ # NEXT, if we have a type-validation object, use it.
+ # TBD: Should test (islocal-$option) here, but islocal
+ # isn't defined for implicitly delegated options.
+ if {[info exists Snit_optionInfo(typeobj-$option)]
+ && "" != $Snit_optionInfo(typeobj-$option)} {
+ if {[catch {
+ $Snit_optionInfo(typeobj-$option) validate $value
+ } result]} {
+ return -code error "invalid $option value: $result"
+ }
+ }
+
+ # NEXT, the caching the configure command also cached the
+ # validate command, if any. If we have one, run it.
+ set valcommand [set ${selfns}::Snit_validateCache($option)]
+
+ if {[llength $valcommand]} {
+ lappend valcommand $value
+ uplevel 1 $valcommand
+ }
+
+ # NEXT, configure the option with the value.
+ lappend command $value
+ uplevel 1 $command
+ }
+
+ return
+}
+
+# Retrieves and caches the command that stores the named option.
+# Also stores the command that validates the name option if any;
+# If none, the validate command is "", so that the cache is always
+# populated.
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# option An option name
+
+proc ::snit::RT.CacheConfigureCommand {type selfns win self option} {
+ variable ${type}::Snit_optionInfo
+ variable ${selfns}::Snit_configureCache
+ variable ${selfns}::Snit_validateCache
+
+ if {[info exist Snit_optionInfo(islocal-$option)]} {
+ # We know the item; it's either local, or explicitly delegated.
+
+ if {$Snit_optionInfo(islocal-$option)} {
+ # It's a local option.
+
+ # If it's readonly, it throws an error if we're already
+ # constructed.
+ if {$Snit_optionInfo(readonly-$option)} {
+ if {[set ${selfns}::Snit_iinfo(constructed)]} {
+ error "option $option can only be set at instance creation"
+ }
+ }
+
+ # If it has a validate method, cache that for later.
+ if {"" != $Snit_optionInfo(validate-$option)} {
+ set command [snit::RT.LookupMethodCommand \
+ $type $selfns $win $self \
+ $Snit_optionInfo(validate-$option) \
+ "can't validate $option"]
+
+ lappend command $option
+ set Snit_validateCache($option) $command
+ } else {
+ set Snit_validateCache($option) ""
+ }
+
+ # If it has a configure method defined,
+ # cache it; otherwise, just set the value.
+
+ if {"" == $Snit_optionInfo(configure-$option)} {
+ set command [list set ${selfns}::options($option)]
+ } else {
+ set command [snit::RT.LookupMethodCommand \
+ $type $selfns $win $self \
+ $Snit_optionInfo(configure-$option) \
+ "can't configure $option"]
+
+ lappend command $option
+ }
+
+ set Snit_configureCache($option) $command
+ return $command
+ }
+
+ # Delegated option: get target.
+ set comp [lindex $Snit_optionInfo(target-$option) 0]
+ set target [lindex $Snit_optionInfo(target-$option) 1]
+ } elseif {$Snit_optionInfo(starcomp) != "" &&
+ [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
+ # Unknown option, but unknowns are delegated.
+ set comp $Snit_optionInfo(starcomp)
+ set target $option
+ } else {
+ return ""
+ }
+
+ # There is no validate command in this case; save an empty string.
+ set Snit_validateCache($option) ""
+
+ # Get the component's object
+ set obj [RT.Component $type $selfns $comp]
+
+ set command [list $obj configure $target]
+ set Snit_configureCache($option) $command
+
+ return $command
+}
+
+# Implements the standard "configure" method
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# args A list of options and their values, possibly empty.
+
+proc ::snit::RT.method.configure {type selfns win self args} {
+ # If two or more arguments, set values as usual.
+ if {[llength $args] >= 2} {
+ ::snit::RT.method.configurelist $type $selfns $win $self $args
+ return
+ }
+
+ # If zero arguments, acquire data for each known option
+ # and return the list
+ if {[llength $args] == 0} {
+ set result {}
+ foreach opt [RT.method.info.options $type $selfns $win $self] {
+ # Refactor this, so that we don't need to call via $self.
+ lappend result [RT.GetOptionDbSpec \
+ $type $selfns $win $self $opt]
+ }
+
+ return $result
+ }
+
+ # They want it for just one.
+ set opt [lindex $args 0]
+
+ return [RT.GetOptionDbSpec $type $selfns $win $self $opt]
+}
+
+
+# Retrieves the option database spec for a single option.
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# option The name of an option
+#
+# TBD: This is a bad name. What it's returning is the
+# result of the configure query.
+
+proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} {
+ variable ${type}::Snit_optionInfo
+
+ upvar ${selfns}::Snit_components Snit_components
+ upvar ${selfns}::options options
+
+ if {[info exists options($opt)]} {
+ # This is a locally-defined option. Just build the
+ # list and return it.
+ set res $Snit_optionInfo(resource-$opt)
+ set cls $Snit_optionInfo(class-$opt)
+ set def $Snit_optionInfo(default-$opt)
+
+ return [list $opt $res $cls $def \
+ [RT.method.cget $type $selfns $win $self $opt]]
+ } elseif {[info exists Snit_optionInfo(target-$opt)]} {
+ # This is an explicitly delegated option. The only
+ # thing we don't have is the default.
+ set res $Snit_optionInfo(resource-$opt)
+ set cls $Snit_optionInfo(class-$opt)
+
+ # Get the default
+ set logicalName [lindex $Snit_optionInfo(target-$opt) 0]
+ set comp $Snit_components($logicalName)
+ set target [lindex $Snit_optionInfo(target-$opt) 1]
+
+ if {[catch {$comp configure $target} result]} {
+ set defValue {}
+ } else {
+ set defValue [lindex $result 3]
+ }
+
+ return [list $opt $res $cls $defValue [$self cget $opt]]
+ } elseif {"" != $Snit_optionInfo(starcomp) &&
+ [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
+ set logicalName $Snit_optionInfo(starcomp)
+ set target $opt
+ set comp $Snit_components($logicalName)
+
+ if {[catch {set value [$comp cget $target]} result]} {
+ error "unknown option \"$opt\""
+ }
+
+ if {![catch {$comp configure $target} result]} {
+ # Replace the delegated option name with the local name.
+ return [::snit::Expand $result $target $opt]
+ }
+
+ # configure didn't work; return simple form.
+ return [list $opt "" "" "" $value]
+ } else {
+ error "unknown option \"$opt\""
+ }
+}
+
+#-----------------------------------------------------------------------
+# Type Introspection
+
+# Implements the standard "info" typemethod.
+#
+# type The snit type
+# command The info subcommand
+# args All other arguments.
+
+proc ::snit::RT.typemethod.info {type command args} {
+ global errorInfo
+ global errorCode
+
+ switch -exact $command {
+ args -
+ body -
+ default -
+ typevars -
+ typemethods -
+ instances {
+ # TBD: it should be possible to delete this error
+ # handling.
+ set errflag [catch {
+ uplevel 1 [linsert $args 0 \
+ ::snit::RT.typemethod.info.$command $type]
+ } result]
+
+ if {$errflag} {
+ return -code error -errorinfo $errorInfo \
+ -errorcode $errorCode $result
+ } else {
+ return $result
+ }
+ }
+ default {
+ error "\"$type info $command\" is not defined"
+ }
+ }
+}
+
+
+# Returns a list of the type's typevariables whose names match a
+# pattern, excluding Snit internal variables.
+#
+# type A Snit type
+# pattern Optional. The glob pattern to match. Defaults
+# to *.
+
+proc ::snit::RT.typemethod.info.typevars {type {pattern *}} {
+ set result {}
+ foreach name [info vars "${type}::$pattern"] {
+ set tail [namespace tail $name]
+ if {![string match "Snit_*" $tail]} {
+ lappend result $name
+ }
+ }
+
+ return $result
+}
+
+# Returns a list of the type's methods whose names match a
+# pattern. If "delegate typemethod *" is used, the list may
+# not be complete.
+#
+# type A Snit type
+# pattern Optional. The glob pattern to match. Defaults
+# to *.
+
+proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} {
+ variable ${type}::Snit_typemethodInfo
+ variable ${type}::Snit_typemethodCache
+
+ # FIRST, get the explicit names, skipping prefixes.
+ set result {}
+
+ foreach name [array names Snit_typemethodInfo $pattern] {
+ if {[lindex $Snit_typemethodInfo($name) 0] != 1} {
+ lappend result $name
+ }
+ }
+
+ # NEXT, add any from the cache that aren't explicit.
+ if {[info exists Snit_typemethodInfo(*)]} {
+ # First, remove "*" from the list.
+ set ndx [lsearch -exact $result "*"]
+ if {$ndx != -1} {
+ set result [lreplace $result $ndx $ndx]
+ }
+
+ foreach name [array names Snit_typemethodCache $pattern] {
+ if {[lsearch -exact $result $name] == -1} {
+ lappend result $name
+ }
+ }
+ }
+
+ return $result
+}
+
+# $type info args
+#
+# Returns a method's list of arguments. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.typemethod.info.args {type method} {
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_typemethodInfo
+
+ if {![info exists Snit_typemethodInfo($method)]} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ foreach {flag cmd component} $Snit_typemethodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated typemethod \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [lrange [::info args $theproc] 1 end]
+}
+
+# $type info body
+#
+# Returns a method's body. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.typemethod.info.body {type method} {
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_typemethodInfo
+
+ if {![info exists Snit_typemethodInfo($method)]} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ foreach {flag cmd component} $Snit_typemethodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated typemethod \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [RT.body [::info body $theproc]]
+}
+
+# $type info default
+#
+# Returns a method's list of arguments. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.typemethod.info.default {type method aname dvar} {
+ upvar 1 $dvar def
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_methodInfo
+
+ if {![info exists Snit_typemethodInfo($method)]} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ foreach {flag cmd component} $Snit_typemethodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated typemethod \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [::info default $theproc $aname def]
+}
+
+# Returns a list of the type's instances whose names match
+# a pattern.
+#
+# type A Snit type
+# pattern Optional. The glob pattern to match
+# Defaults to *
+#
+# REQUIRE: type is fully qualified.
+
+proc ::snit::RT.typemethod.info.instances {type {pattern *}} {
+ set result {}
+
+ foreach selfns [namespace children $type "${type}::Snit_inst*"] {
+ upvar ${selfns}::Snit_instance instance
+
+ if {[string match $pattern $instance]} {
+ lappend result $instance
+ }
+ }
+
+ return $result
+}
+
+#-----------------------------------------------------------------------
+# Instance Introspection
+
+# Implements the standard "info" method.
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# command The info subcommand
+# args All other arguments.
+
+proc ::snit::RT.method.info {type selfns win self command args} {
+ switch -exact $command {
+ args -
+ body -
+ default -
+ type -
+ vars -
+ options -
+ methods -
+ typevars -
+ typemethods {
+ set errflag [catch {
+ uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \
+ $type $selfns $win $self]
+ } result]
+
+ if {$errflag} {
+ global errorInfo
+ return -code error -errorinfo $errorInfo $result
+ } else {
+ return $result
+ }
+ }
+ default {
+ # error "\"$self info $command\" is not defined"
+ return -code error "\"$self info $command\" is not defined"
+ }
+ }
+}
+
+# $self info type
+#
+# Returns the instance's type
+proc ::snit::RT.method.info.type {type selfns win self} {
+ return $type
+}
+
+# $self info typevars
+#
+# Returns the instance's type's typevariables
+proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} {
+ return [RT.typemethod.info.typevars $type $pattern]
+}
+
+# $self info typemethods
+#
+# Returns the instance's type's typemethods
+proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} {
+ return [RT.typemethod.info.typemethods $type $pattern]
+}
+
+# Returns a list of the instance's methods whose names match a
+# pattern. If "delegate method *" is used, the list may
+# not be complete.
+#
+# type A Snit type
+# selfns The instance namespace
+# win The original instance name
+# self The current instance name
+# pattern Optional. The glob pattern to match. Defaults
+# to *.
+
+proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} {
+ variable ${type}::Snit_methodInfo
+ variable ${selfns}::Snit_methodCache
+
+ # FIRST, get the explicit names, skipping prefixes.
+ set result {}
+
+ foreach name [array names Snit_methodInfo $pattern] {
+ if {[lindex $Snit_methodInfo($name) 0] != 1} {
+ lappend result $name
+ }
+ }
+
+ # NEXT, add any from the cache that aren't explicit.
+ if {[info exists Snit_methodInfo(*)]} {
+ # First, remove "*" from the list.
+ set ndx [lsearch -exact $result "*"]
+ if {$ndx != -1} {
+ set result [lreplace $result $ndx $ndx]
+ }
+
+ foreach name [array names Snit_methodCache $pattern] {
+ if {[lsearch -exact $result $name] == -1} {
+ lappend result $name
+ }
+ }
+ }
+
+ return $result
+}
+
+# $self info args
+#
+# Returns a method's list of arguments. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.method.info.args {type selfns win self method} {
+
+ upvar ${type}::Snit_methodInfo Snit_methodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_methodInfo
+
+ if {![info exists Snit_methodInfo($method)]} {
+ return -code error "Unknown method \"$method\""
+ }
+ foreach {flag cmd component} $Snit_methodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown method \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated method \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [lrange [::info args $theproc] 4 end]
+}
+
+# $self info body
+#
+# Returns a method's body. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.method.info.body {type selfns win self method} {
+
+ upvar ${type}::Snit_methodInfo Snit_methodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_methodInfo
+
+ if {![info exists Snit_methodInfo($method)]} {
+ return -code error "Unknown method \"$method\""
+ }
+ foreach {flag cmd component} $Snit_methodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown method \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated method \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [RT.body [::info body $theproc]]
+}
+
+# $self info default
+#
+# Returns a method's list of arguments. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.method.info.default {type selfns win self method aname dvar} {
+ upvar 1 $dvar def
+ upvar ${type}::Snit_methodInfo Snit_methodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ if {![info exists Snit_methodInfo($method)]} {
+ return -code error "Unknown method \"$method\""
+ }
+ foreach {flag cmd component} $Snit_methodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown method \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated method \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [::info default $theproc $aname def]
+}
+
+# $self info vars
+#
+# Returns the instance's instance variables
+proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} {
+ set result {}
+ foreach name [info vars "${selfns}::$pattern"] {
+ set tail [namespace tail $name]
+ if {![string match "Snit_*" $tail]} {
+ lappend result $name
+ }
+ }
+
+ return $result
+}
+
+# $self info options
+#
+# Returns a list of the names of the instance's options
+proc ::snit::RT.method.info.options {type selfns win self {pattern *}} {
+ variable ${type}::Snit_optionInfo
+
+ # First, get the local and explicitly delegated options
+ set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)]
+
+ # If "configure" works as for Tk widgets, add the resulting
+ # options to the list. Skip excepted options
+ if {"" != $Snit_optionInfo(starcomp)} {
+ upvar ${selfns}::Snit_components Snit_components
+ set logicalName $Snit_optionInfo(starcomp)
+ set comp $Snit_components($logicalName)
+
+ if {![catch {$comp configure} records]} {
+ foreach record $records {
+ set opt [lindex $record 0]
+ if {[lsearch -exact $result $opt] == -1 &&
+ [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
+ lappend result $opt
+ }
+ }
+ }
+ }
+
+ # Next, apply the pattern
+ set names {}
+
+ foreach name $result {
+ if {[string match $pattern $name]} {
+ lappend names $name
+ }
+ }
+
+ return $names
+}
+
+proc ::snit::RT.body {body} {
+ regsub -all ".*# END snit method prolog\n" $body {} body
+ return $body
+}
--- /dev/null
+#-----------------------------------------------------------------------
+# TITLE:
+# main1_83.tcl
+#
+# AUTHOR:
+# Will Duquette
+#
+# DESCRIPTION:
+# Snit's Not Incr Tcl, a simple object system in Pure Tcl.
+#
+# Snit 1.x Compiler and Run-Time Library, Tcl 8.3 and later
+#
+# Copyright (C) 2003-2006 by William H. Duquette
+# This code is licensed as described in license.txt.
+#
+#-----------------------------------------------------------------------
+# Back-port to Tcl8.3 by Kenneth Green (kmg)
+# Modified by Andreas Kupries.
+# Further modified by Will Duquette 12 Aug 2006
+#
+# Local changes marked with "#kmg-tcl83"
+#
+# Global changes:
+# " trace add variable " -> "trace variable "
+# " write " -> "w" in all calls to 'trace variable'
+# " unset -nocomplain " -> "::snit83::unset -nocomplain"
+#-----------------------------------------------------------------------
+
+#-----------------------------------------------------------------------
+# Namespace
+
+namespace eval ::snit:: {
+ namespace export \
+ compile type widget widgetadaptor typemethod method macro
+}
+
+#-----------------------------------------------------------------------
+# Some Snit variables
+
+namespace eval ::snit:: {
+ variable reservedArgs {type selfns win self}
+
+ # Widget classes which can be hulls (must have -class)
+ variable hulltypes {
+ toplevel tk::toplevel
+ frame tk::frame ttk::frame
+ labelframe tk::labelframe ttk::labelframe
+ }
+}
+
+#-----------------------------------------------------------------------
+# Snit Type Implementation template
+
+namespace eval ::snit:: {
+ # Template type definition: All internal and user-visible Snit
+ # implementation code.
+ #
+ # The following placeholders will automatically be replaced with
+ # the client's code, in two passes:
+ #
+ # First pass:
+ # %COMPILEDDEFS% The compiled type definition.
+ #
+ # Second pass:
+ # %TYPE% The fully qualified type name.
+ # %IVARDECS% Instance variable declarations
+ # %TVARDECS% Type variable declarations
+ # %TCONSTBODY% Type constructor body
+ # %INSTANCEVARS% The compiled instance variable initialization code.
+ # %TYPEVARS% The compiled type variable initialization code.
+
+ # This is the overall type template.
+ variable typeTemplate
+
+ # This is the normal type proc
+ variable nominalTypeProc
+
+ # This is the "-hastypemethods no" type proc
+ variable simpleTypeProc
+}
+
+set ::snit::typeTemplate {
+
+ #-------------------------------------------------------------------
+ # The type's namespace definition and the user's type variables
+
+ namespace eval %TYPE% {%TYPEVARS%
+ }
+
+ #----------------------------------------------------------------
+ # Commands for use in methods, typemethods, etc.
+ #
+ # These are implemented as aliases into the Snit runtime library.
+
+ interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE%
+ interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE%
+ interp alias {} %TYPE%::typevariable {} ::variable
+ interp alias {} %TYPE%::variable {} ::snit::RT.variable
+ interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE%
+ interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE%
+ interp alias {} %TYPE%::myvar {} ::snit::RT.myvar
+ interp alias {} %TYPE%::varname {} ::snit::RT.myvar
+ interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE%
+ interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE%
+ interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod
+ interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE%
+ interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE%
+
+ #-------------------------------------------------------------------
+ # Snit's internal variables
+
+ namespace eval %TYPE% {
+ # Array: General Snit Info
+ #
+ # ns: The type's namespace
+ # hasinstances: T or F, from pragma -hasinstances.
+ # simpledispatch: T or F, from pragma -hasinstances.
+ # canreplace: T or F, from pragma -canreplace.
+ # counter: Count of instances created so far.
+ # widgetclass: Set by widgetclass statement.
+ # hulltype: Hull type (frame or toplevel) for widgets only.
+ # exceptmethods: Methods explicitly not delegated to *
+ # excepttypemethods: Methods explicitly not delegated to *
+ # tvardecs: Type variable declarations--for dynamic methods
+ # ivardecs: Instance variable declarations--for dyn. methods
+ typevariable Snit_info
+ set Snit_info(ns) %TYPE%::
+ set Snit_info(hasinstances) 1
+ set Snit_info(simpledispatch) 0
+ set Snit_info(canreplace) 0
+ set Snit_info(counter) 0
+ set Snit_info(widgetclass) {}
+ set Snit_info(hulltype) frame
+ set Snit_info(exceptmethods) {}
+ set Snit_info(excepttypemethods) {}
+ set Snit_info(tvardecs) {%TVARDECS%}
+ set Snit_info(ivardecs) {%IVARDECS%}
+
+ # Array: Public methods of this type.
+ # The index is the method name, or "*".
+ # The value is [list $pattern $componentName], where
+ # $componentName is "" for normal methods.
+ typevariable Snit_typemethodInfo
+ array unset Snit_typemethodInfo
+
+ # Array: Public methods of instances of this type.
+ # The index is the method name, or "*".
+ # The value is [list $pattern $componentName], where
+ # $componentName is "" for normal methods.
+ typevariable Snit_methodInfo
+ array unset Snit_methodInfo
+
+ # Array: option information. See dictionary.txt.
+ typevariable Snit_optionInfo
+ array unset Snit_optionInfo
+ set Snit_optionInfo(local) {}
+ set Snit_optionInfo(delegated) {}
+ set Snit_optionInfo(starcomp) {}
+ set Snit_optionInfo(except) {}
+ }
+
+ #----------------------------------------------------------------
+ # Compiled Procs
+ #
+ # These commands are created or replaced during compilation:
+
+
+ # Snit_instanceVars selfns
+ #
+ # Initializes the instance variables, if any. Called during
+ # instance creation.
+
+ proc %TYPE%::Snit_instanceVars {selfns} {
+ %INSTANCEVARS%
+ }
+
+ # Type Constructor
+ proc %TYPE%::Snit_typeconstructor {type} {
+ %TVARDECS%
+ %TCONSTBODY%
+ }
+
+ #----------------------------------------------------------------
+ # Default Procs
+ #
+ # These commands might be replaced during compilation:
+
+ # Snit_destructor type selfns win self
+ #
+ # Default destructor for the type. By default, it does
+ # nothing. It's replaced by any user destructor.
+ # For types, it's called by method destroy; for widgettypes,
+ # it's called by a destroy event handler.
+
+ proc %TYPE%::Snit_destructor {type selfns win self} { }
+
+ #----------------------------------------------------------
+ # Compiled Definitions
+
+ %COMPILEDDEFS%
+
+ #----------------------------------------------------------
+ # Finally, call the Type Constructor
+
+ %TYPE%::Snit_typeconstructor %TYPE%
+}
+
+#-----------------------------------------------------------------------
+# Type procs
+#
+# These procs expect the fully-qualified type name to be
+# substituted in for %TYPE%.
+
+# This is the nominal type proc. It supports typemethods and
+# delegated typemethods.
+set ::snit::nominalTypeProc {
+ # Type dispatcher function. Note: This function lives
+ # in the parent of the %TYPE% namespace! All accesses to
+ # %TYPE% variables and methods must be qualified!
+ proc %TYPE% {{method ""} args} {
+ # First, if there's no method, and no args, and there's a create
+ # method, and this isn't a widget, then method is "create" and
+ # "args" is %AUTO%.
+ if {"" == $method && [llength $args] == 0} {
+ ::variable %TYPE%::Snit_info
+
+ if {$Snit_info(hasinstances) && !$Snit_info(isWidget)} {
+ set method create
+ lappend args %AUTO%
+ } else {
+ error "wrong \# args: should be \"%TYPE% method args\""
+ }
+ }
+
+ # Next, retrieve the command.
+ variable %TYPE%::Snit_typemethodCache
+ while 1 {
+ if {[catch {set Snit_typemethodCache($method)} commandRec]} {
+ set commandRec [::snit::RT.CacheTypemethodCommand %TYPE% $method]
+
+ if {[llength $commandRec] == 0} {
+ return -code error "\"%TYPE% $method\" is not defined"
+ }
+ }
+
+ # If we've got a real command, break.
+ if {[lindex $commandRec 0] == 0} {
+ break
+ }
+
+ # Otherwise, we need to look up again...if we can.
+ if {[llength $args] == 0} {
+ return -code error \
+ "wrong number args: should be \"%TYPE% $method method args\""
+ }
+
+ lappend method [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+
+ set command [lindex $commandRec 1]
+
+ # Pass along the return code unchanged.
+ set retval [catch {uplevel 1 $command $args} result]
+
+ if {$retval} {
+ if {$retval == 1} {
+ global errorInfo
+ global errorCode
+ return -code error -errorinfo $errorInfo \
+ -errorcode $errorCode $result
+ } else {
+ return -code $retval $result
+ }
+ }
+
+ return $result
+ }
+}
+
+# This is the simplified type proc for when there are no typemethods
+# except create. In this case, it doesn't take a method argument;
+# the method is always "create".
+set ::snit::simpleTypeProc {
+ # Type dispatcher function. Note: This function lives
+ # in the parent of the %TYPE% namespace! All accesses to
+ # %TYPE% variables and methods must be qualified!
+ proc %TYPE% {args} {
+ ::variable %TYPE%::Snit_info
+
+ # FIRST, if the are no args, the single arg is %AUTO%
+ if {[llength $args] == 0} {
+ if {$Snit_info(isWidget)} {
+ error "wrong \# args: should be \"%TYPE% name args\""
+ }
+
+ lappend args %AUTO%
+ }
+
+ # NEXT, we're going to call the create method.
+ # Pass along the return code unchanged.
+ if {$Snit_info(isWidget)} {
+ set command [list ::snit::RT.widget.typemethod.create %TYPE%]
+ } else {
+ set command [list ::snit::RT.type.typemethod.create %TYPE%]
+ }
+
+ set retval [catch {uplevel 1 $command $args} result]
+
+ if {$retval} {
+ if {$retval == 1} {
+ global errorInfo
+ global errorCode
+ return -code error -errorinfo $errorInfo \
+ -errorcode $errorCode $result
+ } else {
+ return -code $retval $result
+ }
+ }
+
+ return $result
+ }
+}
+
+#-----------------------------------------------------------------------
+# Instance procs
+#
+# The following must be substituted into these proc bodies:
+#
+# %SELFNS% The instance namespace
+# %WIN% The original instance name
+# %TYPE% The fully-qualified type name
+#
+
+# Nominal instance proc body: supports method caching and delegation.
+#
+# proc $instanceName {method args} ....
+set ::snit::nominalInstanceProc {
+ set self [set %SELFNS%::Snit_instance]
+
+ while {1} {
+ if {[catch {set %SELFNS%::Snit_methodCache($method)} commandRec]} {
+ set commandRec [snit::RT.CacheMethodCommand %TYPE% %SELFNS% %WIN% $self $method]
+
+ if {[llength $commandRec] == 0} {
+ return -code error \
+ "\"$self $method\" is not defined"
+ }
+ }
+
+ # If we've got a real command, break.
+ if {[lindex $commandRec 0] == 0} {
+ break
+ }
+
+ # Otherwise, we need to look up again...if we can.
+ if {[llength $args] == 0} {
+ return -code error \
+ "wrong number args: should be \"$self $method method args\""
+ }
+
+ lappend method [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+
+ set command [lindex $commandRec 1]
+
+ # Pass along the return code unchanged.
+ set retval [catch {uplevel 1 $command $args} result]
+
+ if {$retval} {
+ if {$retval == 1} {
+ global errorInfo
+ global errorCode
+ return -code error -errorinfo $errorInfo \
+ -errorcode $errorCode $result
+ } else {
+ return -code $retval $result
+ }
+ }
+
+ return $result
+}
+
+# Simplified method proc body: No delegation allowed; no support for
+# upvar or exotic return codes or hierarchical methods. Designed for
+# max speed for simple types.
+#
+# proc $instanceName {method args} ....
+
+set ::snit::simpleInstanceProc {
+ set self [set %SELFNS%::Snit_instance]
+
+ if {[lsearch -exact ${%TYPE%::Snit_methods} $method] == -1} {
+ set optlist [join ${%TYPE%::Snit_methods} ", "]
+ set optlist [linsert $optlist "end-1" "or"]
+ error "bad option \"$method\": must be $optlist"
+ }
+
+ eval [linsert $args 0 \
+ %TYPE%::Snit_method$method %TYPE% %SELFNS% %WIN% $self]
+}
+
+
+#=======================================================================
+# Snit Type Definition
+#
+# These are the procs used to define Snit types, widgets, and
+# widgetadaptors.
+
+
+#-----------------------------------------------------------------------
+# Snit Compilation Variables
+#
+# The following variables are used while Snit is compiling a type,
+# and are disposed afterwards.
+
+namespace eval ::snit:: {
+ # The compiler variable contains the name of the slave interpreter
+ # used to compile type definitions.
+ variable compiler ""
+
+ # The compile array accumulates information about the type or
+ # widgettype being compiled. It is cleared before and after each
+ # compilation. It has these indices:
+ #
+ # type: The name of the type being compiled, for use
+ # in compilation procs.
+ # defs: Compiled definitions, both standard and client.
+ # which: type, widget, widgetadaptor
+ # instancevars: Instance variable definitions and initializations.
+ # ivprocdec: Instance variable proc declarations.
+ # tvprocdec: Type variable proc declarations.
+ # typeconstructor: Type constructor body.
+ # widgetclass: The widgetclass, for snit::widgets, only
+ # hasoptions: False, initially; set to true when first
+ # option is defined.
+ # localoptions: Names of local options.
+ # delegatedoptions: Names of delegated options.
+ # localmethods: Names of locally defined methods.
+ # delegatesmethods: no if no delegated methods, yes otherwise.
+ # hashierarchic : no if no hierarchic methods, yes otherwise.
+ # components: Names of defined components.
+ # typecomponents: Names of defined typecomponents.
+ # typevars: Typevariable definitions and initializations.
+ # varnames: Names of instance variables
+ # typevarnames Names of type variables
+ # hasconstructor False, initially; true when constructor is
+ # defined.
+ # resource-$opt The option's resource name
+ # class-$opt The option's class
+ # -default-$opt The option's default value
+ # -validatemethod-$opt The option's validate method
+ # -configuremethod-$opt The option's configure method
+ # -cgetmethod-$opt The option's cget method.
+ # -hastypeinfo The -hastypeinfo pragma
+ # -hastypedestroy The -hastypedestroy pragma
+ # -hastypemethods The -hastypemethods pragma
+ # -hasinfo The -hasinfo pragma
+ # -hasinstances The -hasinstances pragma
+ # -simpledispatch The -simpledispatch pragma
+ # -canreplace The -canreplace pragma
+ variable compile
+
+ # This variable accumulates method dispatch information; it has
+ # the same structure as the %TYPE%::Snit_methodInfo array, and is
+ # used to initialize it.
+ variable methodInfo
+
+ # This variable accumulates typemethod dispatch information; it has
+ # the same structure as the %TYPE%::Snit_typemethodInfo array, and is
+ # used to initialize it.
+ variable typemethodInfo
+
+ # The following variable lists the reserved type definition statement
+ # names, e.g., the names you can't use as macros. It's built at
+ # compiler definition time using "info commands".
+ variable reservedwords {}
+}
+
+#-----------------------------------------------------------------------
+# type compilation commands
+#
+# The type and widgettype commands use a slave interpreter to compile
+# the type definition. These are the procs
+# that are aliased into it.
+
+# Initialize the compiler
+proc ::snit::Comp.Init {} {
+ variable compiler
+ variable reservedwords
+
+ if {"" == $compiler} {
+ # Create the compiler's interpreter
+ set compiler [interp create]
+
+ # Initialize the interpreter
+ $compiler eval {
+ catch {close stdout}
+ catch {close stderr}
+ catch {close stdin}
+
+ # Load package information
+ # TBD: see if this can be moved outside.
+ # @mdgen NODEP: ::snit::__does_not_exist__
+ catch {package require ::snit::__does_not_exist__}
+
+ # Protect some Tcl commands our type definitions
+ # will shadow.
+ rename proc _proc
+ rename variable _variable
+ }
+
+ # Define compilation aliases.
+ $compiler alias pragma ::snit::Comp.statement.pragma
+ $compiler alias widgetclass ::snit::Comp.statement.widgetclass
+ $compiler alias hulltype ::snit::Comp.statement.hulltype
+ $compiler alias constructor ::snit::Comp.statement.constructor
+ $compiler alias destructor ::snit::Comp.statement.destructor
+ $compiler alias option ::snit::Comp.statement.option
+ $compiler alias oncget ::snit::Comp.statement.oncget
+ $compiler alias onconfigure ::snit::Comp.statement.onconfigure
+ $compiler alias method ::snit::Comp.statement.method
+ $compiler alias typemethod ::snit::Comp.statement.typemethod
+ $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor
+ $compiler alias proc ::snit::Comp.statement.proc
+ $compiler alias typevariable ::snit::Comp.statement.typevariable
+ $compiler alias variable ::snit::Comp.statement.variable
+ $compiler alias typecomponent ::snit::Comp.statement.typecomponent
+ $compiler alias component ::snit::Comp.statement.component
+ $compiler alias delegate ::snit::Comp.statement.delegate
+ $compiler alias expose ::snit::Comp.statement.expose
+
+ # Get the list of reserved words
+ set reservedwords [$compiler eval {info commands}]
+ }
+}
+
+# Compile a type definition, and return the results as a list of two
+# items: the fully-qualified type name, and a script that will define
+# the type when executed.
+#
+# which type, widget, or widgetadaptor
+# type the type name
+# body the type definition
+proc ::snit::Comp.Compile {which type body} {
+ variable typeTemplate
+ variable nominalTypeProc
+ variable simpleTypeProc
+ variable compile
+ variable compiler
+ variable methodInfo
+ variable typemethodInfo
+
+ # FIRST, qualify the name.
+ if {![string match "::*" $type]} {
+ # Get caller's namespace;
+ # append :: if not global namespace.
+ set ns [uplevel 2 [list namespace current]]
+ if {"::" != $ns} {
+ append ns "::"
+ }
+
+ set type "$ns$type"
+ }
+
+ # NEXT, create and initialize the compiler, if needed.
+ Comp.Init
+
+ # NEXT, initialize the class data
+ array unset methodInfo
+ array unset typemethodInfo
+
+ array unset compile
+ set compile(type) $type
+ set compile(defs) {}
+ set compile(which) $which
+ set compile(hasoptions) no
+ set compile(localoptions) {}
+ set compile(instancevars) {}
+ set compile(typevars) {}
+ set compile(delegatedoptions) {}
+ set compile(ivprocdec) {}
+ set compile(tvprocdec) {}
+ set compile(typeconstructor) {}
+ set compile(widgetclass) {}
+ set compile(hulltype) {}
+ set compile(localmethods) {}
+ set compile(delegatesmethods) no
+ set compile(hashierarchic) no
+ set compile(components) {}
+ set compile(typecomponents) {}
+ set compile(varnames) {}
+ set compile(typevarnames) {}
+ set compile(hasconstructor) no
+ set compile(-hastypedestroy) yes
+ set compile(-hastypeinfo) yes
+ set compile(-hastypemethods) yes
+ set compile(-hasinfo) yes
+ set compile(-hasinstances) yes
+ set compile(-simpledispatch) no
+ set compile(-canreplace) no
+
+ set isWidget [string match widget* $which]
+ set isWidgetAdaptor [string match widgetadaptor $which]
+
+ # NEXT, Evaluate the type's definition in the class interpreter.
+ $compiler eval $body
+
+ # NEXT, Add the standard definitions
+ append compile(defs) \
+ "\nset %TYPE%::Snit_info(isWidget) $isWidget\n"
+
+ append compile(defs) \
+ "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n"
+
+ # Indicate whether the type can create instances that replace
+ # existing commands.
+ append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n"
+
+
+ # Check pragmas for conflict.
+
+ if {!$compile(-hastypemethods) && !$compile(-hasinstances)} {
+ error "$which $type has neither typemethods nor instances"
+ }
+
+ if {$compile(-simpledispatch) && $compile(delegatesmethods)} {
+ error "$which $type requests -simpledispatch but delegates methods."
+ }
+
+ if {$compile(-simpledispatch) && $compile(hashierarchic)} {
+ error "$which $type requests -simpledispatch but defines hierarchical methods."
+ }
+
+ # If there are typemethods, define the standard typemethods and
+ # the nominal type proc. Otherwise define the simple type proc.
+ if {$compile(-hastypemethods)} {
+ # Add the info typemethod unless the pragma forbids it.
+ if {$compile(-hastypeinfo)} {
+ Comp.statement.delegate typemethod info \
+ using {::snit::RT.typemethod.info %t}
+ }
+
+ # Add the destroy typemethod unless the pragma forbids it.
+ if {$compile(-hastypedestroy)} {
+ Comp.statement.delegate typemethod destroy \
+ using {::snit::RT.typemethod.destroy %t}
+ }
+
+ # Add the nominal type proc.
+ append compile(defs) $nominalTypeProc
+ } else {
+ # Add the simple type proc.
+ append compile(defs) $simpleTypeProc
+ }
+
+ # Add standard methods/typemethods that only make sense if the
+ # type has instances.
+ if {$compile(-hasinstances)} {
+ # If we're using simple dispatch, remember that.
+ if {$compile(-simpledispatch)} {
+ append compile(defs) "\nset %TYPE%::Snit_info(simpledispatch) 1\n"
+ }
+
+ # Add the info method unless the pragma forbids it.
+ if {$compile(-hasinfo)} {
+ if {!$compile(-simpledispatch)} {
+ Comp.statement.delegate method info \
+ using {::snit::RT.method.info %t %n %w %s}
+ } else {
+ Comp.statement.method info {args} {
+ eval [linsert $args 0 \
+ ::snit::RT.method.info $type $selfns $win $self]
+ }
+ }
+ }
+
+ # Add the option handling stuff if there are any options.
+ if {$compile(hasoptions)} {
+ Comp.statement.variable options
+
+ if {!$compile(-simpledispatch)} {
+ Comp.statement.delegate method cget \
+ using {::snit::RT.method.cget %t %n %w %s}
+ Comp.statement.delegate method configurelist \
+ using {::snit::RT.method.configurelist %t %n %w %s}
+ Comp.statement.delegate method configure \
+ using {::snit::RT.method.configure %t %n %w %s}
+ } else {
+ Comp.statement.method cget {args} {
+ eval [linsert $args 0 \
+ ::snit::RT.method.cget $type $selfns $win $self]
+ }
+ Comp.statement.method configurelist {args} {
+ eval [linsert $args 0 \
+ ::snit::RT.method.configurelist $type $selfns $win $self]
+ }
+ Comp.statement.method configure {args} {
+ eval [linsert $args 0 \
+ ::snit::RT.method.configure $type $selfns $win $self]
+ }
+ }
+ }
+
+ # Add a default constructor, if they haven't already defined one.
+ # If there are options, it will configure args; otherwise it
+ # will do nothing.
+ if {!$compile(hasconstructor)} {
+ if {$compile(hasoptions)} {
+ Comp.statement.constructor {args} {
+ $self configurelist $args
+ }
+ } else {
+ Comp.statement.constructor {} {}
+ }
+ }
+
+ if {!$isWidget} {
+ if {!$compile(-simpledispatch)} {
+ Comp.statement.delegate method destroy \
+ using {::snit::RT.method.destroy %t %n %w %s}
+ } else {
+ Comp.statement.method destroy {args} {
+ eval [linsert $args 0 \
+ ::snit::RT.method.destroy $type $selfns $win $self]
+ }
+ }
+
+ Comp.statement.delegate typemethod create \
+ using {::snit::RT.type.typemethod.create %t}
+ } else {
+ Comp.statement.delegate typemethod create \
+ using {::snit::RT.widget.typemethod.create %t}
+ }
+
+ # Save the list of method names, for -simpledispatch; otherwise,
+ # save the method info.
+ if {$compile(-simpledispatch)} {
+ append compile(defs) \
+ "\nset %TYPE%::Snit_methods [list $compile(localmethods)]\n"
+ } else {
+ append compile(defs) \
+ "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n"
+ }
+
+ } else {
+ append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n"
+ }
+
+ # NEXT, compiling the type definition built up a set of information
+ # about the type's locally defined options; add this information to
+ # the compiled definition.
+ Comp.SaveOptionInfo
+
+ # NEXT, compiling the type definition built up a set of information
+ # about the typemethods; save the typemethod info.
+ append compile(defs) \
+ "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n"
+
+ # NEXT, if this is a widget define the hull component if it isn't
+ # already defined.
+ if {$isWidget} {
+ Comp.DefineComponent hull
+ }
+
+ # NEXT, substitute the compiled definition into the type template
+ # to get the type definition script.
+ set defscript [Expand $typeTemplate \
+ %COMPILEDDEFS% $compile(defs)]
+
+ # NEXT, substitute the defined macros into the type definition script.
+ # This is done as a separate step so that the compile(defs) can
+ # contain the macros defined below.
+
+ set defscript [Expand $defscript \
+ %TYPE% $type \
+ %IVARDECS% $compile(ivprocdec) \
+ %TVARDECS% $compile(tvprocdec) \
+ %TCONSTBODY% $compile(typeconstructor) \
+ %INSTANCEVARS% $compile(instancevars) \
+ %TYPEVARS% $compile(typevars) \
+ ]
+
+ array unset compile
+
+ return [list $type $defscript]
+}
+
+# Information about locally-defined options is accumulated during
+# compilation, but not added to the compiled definition--the option
+# statement can appear multiple times, so it's easier this way.
+# This proc fills in Snit_optionInfo with the accumulated information.
+#
+# It also computes the option's resource and class names if needed.
+#
+# Note that the information for delegated options was put in
+# Snit_optionInfo during compilation.
+
+proc ::snit::Comp.SaveOptionInfo {} {
+ variable compile
+
+ foreach option $compile(localoptions) {
+ if {"" == $compile(resource-$option)} {
+ set compile(resource-$option) [string range $option 1 end]
+ }
+
+ if {"" == $compile(class-$option)} {
+ set compile(class-$option) [Capitalize $compile(resource-$option)]
+ }
+
+ # NOTE: Don't verify that the validate, configure, and cget
+ # values name real methods; the methods might be defined outside
+ # the typedefinition using snit::method.
+
+ Mappend compile(defs) {
+ # Option %OPTION%
+ lappend %TYPE%::Snit_optionInfo(local) %OPTION%
+
+ set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1
+ set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE%
+ set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
+ set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT%
+ set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE%
+ set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE%
+ set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET%
+ set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY%
+ set %TYPE%::Snit_optionInfo(typespec-%OPTION%) %TYPESPEC%
+ } %OPTION% $option \
+ %RESOURCE% $compile(resource-$option) \
+ %CLASS% $compile(class-$option) \
+ %DEFAULT% [list $compile(-default-$option)] \
+ %VALIDATE% [list $compile(-validatemethod-$option)] \
+ %CONFIGURE% [list $compile(-configuremethod-$option)] \
+ %CGET% [list $compile(-cgetmethod-$option)] \
+ %READONLY% $compile(-readonly-$option) \
+ %TYPESPEC% [list $compile(-type-$option)]
+ }
+}
+
+
+# Evaluates a compiled type definition, thus making the type available.
+proc ::snit::Comp.Define {compResult} {
+ # The compilation result is a list containing the fully qualified
+ # type name and a script to evaluate to define the type.
+ set type [lindex $compResult 0]
+ set defscript [lindex $compResult 1]
+
+ # Execute the type definition script.
+ # Consider using namespace eval %TYPE%. See if it's faster.
+ if {[catch {eval $defscript} result]} {
+ namespace delete $type
+ catch {rename $type ""}
+ error $result
+ }
+
+ return $type
+}
+
+# Sets pragma options which control how the type is defined.
+proc ::snit::Comp.statement.pragma {args} {
+ variable compile
+
+ set errRoot "Error in \"pragma...\""
+
+ foreach {opt val} $args {
+ switch -exact -- $opt {
+ -hastypeinfo -
+ -hastypedestroy -
+ -hastypemethods -
+ -hasinstances -
+ -simpledispatch -
+ -hasinfo -
+ -canreplace {
+ if {![string is boolean -strict $val]} {
+ error "$errRoot, \"$opt\" requires a boolean value"
+ }
+ set compile($opt) $val
+ }
+ default {
+ error "$errRoot, unknown pragma"
+ }
+ }
+ }
+}
+
+# Defines a widget's option class name.
+# This statement is only available for snit::widgets,
+# not for snit::types or snit::widgetadaptors.
+proc ::snit::Comp.statement.widgetclass {name} {
+ variable compile
+
+ # First, widgetclass can only be set for true widgets
+ if {"widget" != $compile(which)} {
+ error "widgetclass cannot be set for snit::$compile(which)s"
+ }
+
+ # Next, validate the option name. We'll require that it begin
+ # with an uppercase letter.
+ set initial [string index $name 0]
+ if {![string is upper $initial]} {
+ error "widgetclass \"$name\" does not begin with an uppercase letter"
+ }
+
+ if {"" != $compile(widgetclass)} {
+ error "too many widgetclass statements"
+ }
+
+ # Next, save it.
+ Mappend compile(defs) {
+ set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS%
+ } %WIDGETCLASS% [list $name]
+
+ set compile(widgetclass) $name
+}
+
+# Defines a widget's hull type.
+# This statement is only available for snit::widgets,
+# not for snit::types or snit::widgetadaptors.
+proc ::snit::Comp.statement.hulltype {name} {
+ variable compile
+ variable hulltypes
+
+ # First, hulltype can only be set for true widgets
+ if {"widget" != $compile(which)} {
+ error "hulltype cannot be set for snit::$compile(which)s"
+ }
+
+ # Next, it must be one of the valid hulltypes (frame, toplevel, ...)
+ if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} {
+ error "invalid hulltype \"$name\", should be one of\
+ [join $hulltypes {, }]"
+ }
+
+ if {"" != $compile(hulltype)} {
+ error "too many hulltype statements"
+ }
+
+ # Next, save it.
+ Mappend compile(defs) {
+ set %TYPE%::Snit_info(hulltype) %HULLTYPE%
+ } %HULLTYPE% $name
+
+ set compile(hulltype) $name
+}
+
+# Defines a constructor.
+proc ::snit::Comp.statement.constructor {arglist body} {
+ variable compile
+
+ CheckArgs "constructor" $arglist
+
+ # Next, add a magic reference to self.
+ set arglist [concat type selfns win self $arglist]
+
+ # Next, add variable declarations to body:
+ set body "%TVARDECS%%IVARDECS%\n$body"
+
+ set compile(hasconstructor) yes
+ append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n"
+}
+
+# Defines a destructor.
+proc ::snit::Comp.statement.destructor {body} {
+ variable compile
+
+ # Next, add variable declarations to body:
+ set body "%TVARDECS%%IVARDECS%\n$body"
+
+ append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n"
+}
+
+# Defines a type option. The option value can be a triple, specifying
+# the option's -name, resource name, and class name.
+proc ::snit::Comp.statement.option {optionDef args} {
+ variable compile
+
+ # First, get the three option names.
+ set option [lindex $optionDef 0]
+ set resourceName [lindex $optionDef 1]
+ set className [lindex $optionDef 2]
+
+ set errRoot "Error in \"option [list $optionDef]...\""
+
+ # Next, validate the option name.
+ if {![Comp.OptionNameIsValid $option]} {
+ error "$errRoot, badly named option \"$option\""
+ }
+
+ if {[Contains $option $compile(delegatedoptions)]} {
+ error "$errRoot, cannot define \"$option\" locally, it has been delegated"
+ }
+
+ if {![Contains $option $compile(localoptions)]} {
+ # Remember that we've seen this one.
+ set compile(hasoptions) yes
+ lappend compile(localoptions) $option
+
+ # Initialize compilation info for this option.
+ set compile(resource-$option) ""
+ set compile(class-$option) ""
+ set compile(-default-$option) ""
+ set compile(-validatemethod-$option) ""
+ set compile(-configuremethod-$option) ""
+ set compile(-cgetmethod-$option) ""
+ set compile(-readonly-$option) 0
+ set compile(-type-$option) ""
+ }
+
+ # NEXT, see if we have a resource name. If so, make sure it
+ # isn't being redefined differently.
+ if {"" != $resourceName} {
+ if {"" == $compile(resource-$option)} {
+ # If it's undefined, just save the value.
+ set compile(resource-$option) $resourceName
+ } elseif {![string equal $resourceName $compile(resource-$option)]} {
+ # It's been redefined differently.
+ error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\""
+ }
+ }
+
+ # NEXT, see if we have a class name. If so, make sure it
+ # isn't being redefined differently.
+ if {"" != $className} {
+ if {"" == $compile(class-$option)} {
+ # If it's undefined, just save the value.
+ set compile(class-$option) $className
+ } elseif {![string equal $className $compile(class-$option)]} {
+ # It's been redefined differently.
+ error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\""
+ }
+ }
+
+ # NEXT, handle the args; it's not an error to redefine these.
+ if {[llength $args] == 1} {
+ set compile(-default-$option) [lindex $args 0]
+ } else {
+ foreach {optopt val} $args {
+ switch -exact -- $optopt {
+ -default -
+ -validatemethod -
+ -configuremethod -
+ -cgetmethod {
+ set compile($optopt-$option) $val
+ }
+ -type {
+ set compile($optopt-$option) $val
+
+ if {[llength $val] == 1} {
+ # The type spec *is* the validation object
+ append compile(defs) \
+ "\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n"
+ } else {
+ # Compilation the creation of the validation object
+ set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%]
+ append compile(defs) \
+ "\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n"
+ }
+ }
+ -readonly {
+ if {![string is boolean -strict $val]} {
+ error "$errRoot, -readonly requires a boolean, got \"$val\""
+ }
+ set compile($optopt-$option) $val
+ }
+ default {
+ error "$errRoot, unknown option definition option \"$optopt\""
+ }
+ }
+ }
+ }
+}
+
+# 1 if the option name is valid, 0 otherwise.
+proc ::snit::Comp.OptionNameIsValid {option} {
+ if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} {
+ return 0
+ }
+
+ return 1
+}
+
+# Defines an option's cget handler
+proc ::snit::Comp.statement.oncget {option body} {
+ variable compile
+
+ set errRoot "Error in \"oncget $option...\""
+
+ if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
+ return -code error "$errRoot, option \"$option\" is delegated"
+ }
+
+ if {[lsearch -exact $compile(localoptions) $option] == -1} {
+ return -code error "$errRoot, option \"$option\" unknown"
+ }
+
+ Comp.statement.method _cget$option {_option} $body
+ Comp.statement.option $option -cgetmethod _cget$option
+}
+
+# Defines an option's configure handler.
+proc ::snit::Comp.statement.onconfigure {option arglist body} {
+ variable compile
+
+ if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
+ return -code error "onconfigure $option: option \"$option\" is delegated"
+ }
+
+ if {[lsearch -exact $compile(localoptions) $option] == -1} {
+ return -code error "onconfigure $option: option \"$option\" unknown"
+ }
+
+ if {[llength $arglist] != 1} {
+ error \
+ "onconfigure $option handler should have one argument, got \"$arglist\""
+ }
+
+ CheckArgs "onconfigure $option" $arglist
+
+ # Next, add a magic reference to the option name
+ set arglist [concat _option $arglist]
+
+ Comp.statement.method _configure$option $arglist $body
+ Comp.statement.option $option -configuremethod _configure$option
+}
+
+# Defines an instance method.
+proc ::snit::Comp.statement.method {method arglist body} {
+ variable compile
+ variable methodInfo
+
+ # FIRST, check the method name against previously defined
+ # methods.
+ Comp.CheckMethodName $method 0 ::snit::methodInfo \
+ "Error in \"method [list $method]...\""
+
+ if {[llength $method] > 1} {
+ set compile(hashierarchic) yes
+ }
+
+ # Remeber this method
+ lappend compile(localmethods) $method
+
+ CheckArgs "method [list $method]" $arglist
+
+ # Next, add magic references to type and self.
+ set arglist [concat type selfns win self $arglist]
+
+ # Next, add variable declarations to body:
+ set body "%TVARDECS%%IVARDECS%\n# END snit method prolog\n$body"
+
+ # Next, save the definition script.
+ if {[llength $method] == 1} {
+ set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
+ Mappend compile(defs) {
+ proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY%
+ } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
+ } else {
+ set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
+
+ Mappend compile(defs) {
+ proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY%
+ } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \
+ %BODY% [list $body]
+ }
+}
+
+# Check for name collisions; save prefix information.
+#
+# method The name of the method or typemethod.
+# delFlag 1 if delegated, 0 otherwise.
+# infoVar The fully qualified name of the array containing
+# information about the defined methods.
+# errRoot The root string for any error messages.
+
+proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} {
+ upvar $infoVar methodInfo
+
+ # FIRST, make sure the method name is a valid Tcl list.
+ if {[catch {lindex $method 0}]} {
+ error "$errRoot, the name \"$method\" must have list syntax."
+ }
+
+ # NEXT, check whether we can define it.
+ if {![catch {set methodInfo($method)} data]} {
+ # We can't redefine methods with submethods.
+ if {[lindex $data 0] == 1} {
+ error "$errRoot, \"$method\" has submethods."
+ }
+
+ # You can't delegate a method that's defined locally,
+ # and you can't define a method locally if it's been delegated.
+ if {$delFlag && "" == [lindex $data 2]} {
+ error "$errRoot, \"$method\" has been defined locally."
+ } elseif {!$delFlag && "" != [lindex $data 2]} {
+ error "$errRoot, \"$method\" has been delegated"
+ }
+ }
+
+ # Handle hierarchical case.
+ if {[llength $method] > 1} {
+ set prefix {}
+ set tokens $method
+ while {[llength $tokens] > 1} {
+ lappend prefix [lindex $tokens 0]
+ set tokens [lrange $tokens 1 end]
+
+ if {![catch {set methodInfo($prefix)} result]} {
+ # Prefix is known. If it's not a prefix, throw an
+ # error.
+ if {[lindex $result 0] == 0} {
+ error "$errRoot, \"$prefix\" has no submethods."
+ }
+ }
+
+ set methodInfo($prefix) [list 1]
+ }
+ }
+}
+
+# Defines a typemethod method.
+proc ::snit::Comp.statement.typemethod {method arglist body} {
+ variable compile
+ variable typemethodInfo
+
+ # FIRST, check the typemethod name against previously defined
+ # typemethods.
+ Comp.CheckMethodName $method 0 ::snit::typemethodInfo \
+ "Error in \"typemethod [list $method]...\""
+
+ CheckArgs "typemethod $method" $arglist
+
+ # First, add magic reference to type.
+ set arglist [concat type $arglist]
+
+ # Next, add typevariable declarations to body:
+ set body "%TVARDECS%\n# END snit method prolog\n$body"
+
+ # Next, save the definition script
+ if {[llength $method] == 1} {
+ set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
+
+ Mappend compile(defs) {
+ proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY%
+ } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
+ } else {
+ set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
+
+ Mappend compile(defs) {
+ proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY%
+ } %JMETHOD% [join $method _] \
+ %ARGLIST% [list $arglist] %BODY% [list $body]
+ }
+}
+
+
+# Defines a type constructor.
+proc ::snit::Comp.statement.typeconstructor {body} {
+ variable compile
+
+ if {"" != $compile(typeconstructor)} {
+ error "too many typeconstructors"
+ }
+
+ set compile(typeconstructor) $body
+}
+
+# Defines a static proc in the type's namespace.
+proc ::snit::Comp.statement.proc {proc arglist body} {
+ variable compile
+
+ # If "ns" is defined, the proc can see instance variables.
+ if {[lsearch -exact $arglist selfns] != -1} {
+ # Next, add instance variable declarations to body:
+ set body "%IVARDECS%\n$body"
+ }
+
+ # The proc can always see typevariables.
+ set body "%TVARDECS%\n$body"
+
+ append compile(defs) "
+
+ # Proc $proc
+ proc [list %TYPE%::$proc $arglist $body]
+ "
+}
+
+# Defines a static variable in the type's namespace.
+proc ::snit::Comp.statement.typevariable {name args} {
+ variable compile
+
+ set errRoot "Error in \"typevariable $name...\""
+
+ set len [llength $args]
+
+ if {$len > 2 ||
+ ($len == 2 && "-array" != [lindex $args 0])} {
+ error "$errRoot, too many initializers"
+ }
+
+ if {[lsearch -exact $compile(varnames) $name] != -1} {
+ error "$errRoot, \"$name\" is already an instance variable"
+ }
+
+ lappend compile(typevarnames) $name
+
+ if {$len == 1} {
+ append compile(typevars) \
+ "\n\t [list ::variable $name [lindex $args 0]]"
+ } elseif {$len == 2} {
+ append compile(typevars) \
+ "\n\t [list ::variable $name]"
+ append compile(typevars) \
+ "\n\t [list array set $name [lindex $args 1]]"
+ } else {
+ append compile(typevars) \
+ "\n\t [list ::variable $name]"
+ }
+
+ append compile(tvprocdec) "\n\t typevariable ${name}"
+}
+
+# Defines an instance variable; the definition will go in the
+# type's create typemethod.
+proc ::snit::Comp.statement.variable {name args} {
+ variable compile
+
+ set errRoot "Error in \"variable $name...\""
+
+ set len [llength $args]
+
+ if {$len > 2 ||
+ ($len == 2 && "-array" != [lindex $args 0])} {
+ error "$errRoot, too many initializers"
+ }
+
+ if {[lsearch -exact $compile(typevarnames) $name] != -1} {
+ error "$errRoot, \"$name\" is already a typevariable"
+ }
+
+ lappend compile(varnames) $name
+
+ if {$len == 1} {
+ append compile(instancevars) \
+ "\nset \${selfns}::$name [list [lindex $args 0]]\n"
+ } elseif {$len == 2} {
+ append compile(instancevars) \
+ "\narray set \${selfns}::$name [list [lindex $args 1]]\n"
+ }
+
+ append compile(ivprocdec) "\n\t "
+ Mappend compile(ivprocdec) {::variable ${selfns}::%N} %N $name
+}
+
+# Defines a typecomponent, and handles component options.
+#
+# component The logical name of the delegate
+# args options.
+
+proc ::snit::Comp.statement.typecomponent {component args} {
+ variable compile
+
+ set errRoot "Error in \"typecomponent $component...\""
+
+ # FIRST, define the component
+ Comp.DefineTypecomponent $component $errRoot
+
+ # NEXT, handle the options.
+ set publicMethod ""
+ set inheritFlag 0
+
+ foreach {opt val} $args {
+ switch -exact -- $opt {
+ -public {
+ set publicMethod $val
+ }
+ -inherit {
+ set inheritFlag $val
+ if {![string is boolean $inheritFlag]} {
+ error "typecomponent $component -inherit: expected boolean value, got \"$val\""
+ }
+ }
+ default {
+ error "typecomponent $component: Invalid option \"$opt\""
+ }
+ }
+ }
+
+ # NEXT, if -public specified, define the method.
+ if {"" != $publicMethod} {
+ Comp.statement.delegate typemethod [list $publicMethod *] to $component
+ }
+
+ # NEXT, if "-inherit 1" is specified, delegate typemethod * to
+ # this component.
+ if {$inheritFlag} {
+ Comp.statement.delegate typemethod "*" to $component
+ }
+
+}
+
+
+# Defines a name to be a typecomponent
+#
+# The name becomes a typevariable; in addition, it gets a
+# write trace so that when it is set, all of the component mechanisms
+# get updated.
+#
+# component The component name
+
+proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} {
+ variable compile
+
+ if {[lsearch -exact $compile(varnames) $component] != -1} {
+ error "$errRoot, \"$component\" is already an instance variable"
+ }
+
+ if {[lsearch -exact $compile(typecomponents) $component] == -1} {
+ # Remember we've done this.
+ lappend compile(typecomponents) $component
+
+ # Make it a type variable with no initial value
+ Comp.statement.typevariable $component ""
+
+ # Add a write trace to do the component thing.
+ Mappend compile(typevars) {
+ trace variable %COMP% w \
+ [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%]
+ } %TYPE% $compile(type) %COMP% $component
+ }
+}
+
+# Defines a component, and handles component options.
+#
+# component The logical name of the delegate
+# args options.
+#
+# TBD: Ideally, it should be possible to call this statement multiple
+# times, possibly changing the option values. To do that, I'd need
+# to cache the option values and not act on them until *after* I'd
+# read the entire type definition.
+
+proc ::snit::Comp.statement.component {component args} {
+ variable compile
+
+ set errRoot "Error in \"component $component...\""
+
+ # FIRST, define the component
+ Comp.DefineComponent $component $errRoot
+
+ # NEXT, handle the options.
+ set publicMethod ""
+ set inheritFlag 0
+
+ foreach {opt val} $args {
+ switch -exact -- $opt {
+ -public {
+ set publicMethod $val
+ }
+ -inherit {
+ set inheritFlag $val
+ if {![string is boolean $inheritFlag]} {
+ error "component $component -inherit: expected boolean value, got \"$val\""
+ }
+ }
+ default {
+ error "component $component: Invalid option \"$opt\""
+ }
+ }
+ }
+
+ # NEXT, if -public specified, define the method.
+ if {"" != $publicMethod} {
+ Comp.statement.delegate method [list $publicMethod *] to $component
+ }
+
+ # NEXT, if -inherit is specified, delegate method/option * to
+ # this component.
+ if {$inheritFlag} {
+ Comp.statement.delegate method "*" to $component
+ Comp.statement.delegate option "*" to $component
+ }
+}
+
+
+# Defines a name to be a component
+#
+# The name becomes an instance variable; in addition, it gets a
+# write trace so that when it is set, all of the component mechanisms
+# get updated.
+#
+# component The component name
+
+proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} {
+ variable compile
+
+ if {[lsearch -exact $compile(typevarnames) $component] != -1} {
+ error "$errRoot, \"$component\" is already a typevariable"
+ }
+
+ if {[lsearch -exact $compile(components) $component] == -1} {
+ # Remember we've done this.
+ lappend compile(components) $component
+
+ # Make it an instance variable with no initial value
+ Comp.statement.variable $component ""
+
+ # Add a write trace to do the component thing.
+ Mappend compile(instancevars) {
+ trace variable ${selfns}::%COMP% w \
+ [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%]
+ } %TYPE% $compile(type) %COMP% $component
+ }
+}
+
+# Creates a delegated method, typemethod, or option.
+proc ::snit::Comp.statement.delegate {what name args} {
+ # FIRST, dispatch to correct handler.
+ switch $what {
+ typemethod { Comp.DelegatedTypemethod $name $args }
+ method { Comp.DelegatedMethod $name $args }
+ option { Comp.DelegatedOption $name $args }
+ default {
+ error "Error in \"delegate $what $name...\", \"$what\"?"
+ }
+ }
+
+ if {([llength $args] % 2) != 0} {
+ error "Error in \"delegate $what $name...\", invalid syntax"
+ }
+}
+
+# Creates a delegated typemethod delegating it to a particular
+# typecomponent or an arbitrary command.
+#
+# method The name of the method
+# arglist Delegation options
+
+proc ::snit::Comp.DelegatedTypemethod {method arglist} {
+ variable compile
+ variable typemethodInfo
+
+ set errRoot "Error in \"delegate typemethod [list $method]...\""
+
+ # Next, parse the delegation options.
+ set component ""
+ set target ""
+ set exceptions {}
+ set pattern ""
+ set methodTail [lindex $method end]
+
+ foreach {opt value} $arglist {
+ switch -exact $opt {
+ to { set component $value }
+ as { set target $value }
+ except { set exceptions $value }
+ using { set pattern $value }
+ default {
+ error "$errRoot, unknown delegation option \"$opt\""
+ }
+ }
+ }
+
+ if {"" == $component && "" == $pattern} {
+ error "$errRoot, missing \"to\""
+ }
+
+ if {"*" == $methodTail && "" != $target} {
+ error "$errRoot, cannot specify \"as\" with \"*\""
+ }
+
+ if {"*" != $methodTail && "" != $exceptions} {
+ error "$errRoot, can only specify \"except\" with \"*\""
+ }
+
+ if {"" != $pattern && "" != $target} {
+ error "$errRoot, cannot specify both \"as\" and \"using\""
+ }
+
+ foreach token [lrange $method 1 end-1] {
+ if {"*" == $token} {
+ error "$errRoot, \"*\" must be the last token."
+ }
+ }
+
+ # NEXT, define the component
+ if {"" != $component} {
+ Comp.DefineTypecomponent $component $errRoot
+ }
+
+ # NEXT, define the pattern.
+ if {"" == $pattern} {
+ if {"*" == $methodTail} {
+ set pattern "%c %m"
+ } elseif {"" != $target} {
+ set pattern "%c $target"
+ } else {
+ set pattern "%c %m"
+ }
+ }
+
+ # Make sure the pattern is a valid list.
+ if {[catch {lindex $pattern 0} result]} {
+ error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
+ }
+
+ # NEXT, check the method name against previously defined
+ # methods.
+ Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot
+
+ set typemethodInfo($method) [list 0 $pattern $component]
+
+ if {[string equal $methodTail "*"]} {
+ Mappend compile(defs) {
+ set %TYPE%::Snit_info(excepttypemethods) %EXCEPT%
+ } %EXCEPT% [list $exceptions]
+ }
+}
+
+
+# Creates a delegated method delegating it to a particular
+# component or command.
+#
+# method The name of the method
+# arglist Delegation options.
+
+proc ::snit::Comp.DelegatedMethod {method arglist} {
+ variable compile
+ variable methodInfo
+
+ set errRoot "Error in \"delegate method [list $method]...\""
+
+ # Next, parse the delegation options.
+ set component ""
+ set target ""
+ set exceptions {}
+ set pattern ""
+ set methodTail [lindex $method end]
+
+ foreach {opt value} $arglist {
+ switch -exact $opt {
+ to { set component $value }
+ as { set target $value }
+ except { set exceptions $value }
+ using { set pattern $value }
+ default {
+ error "$errRoot, unknown delegation option \"$opt\""
+ }
+ }
+ }
+
+ if {"" == $component && "" == $pattern} {
+ error "$errRoot, missing \"to\""
+ }
+
+ if {"*" == $methodTail && "" != $target} {
+ error "$errRoot, cannot specify \"as\" with \"*\""
+ }
+
+ if {"*" != $methodTail && "" != $exceptions} {
+ error "$errRoot, can only specify \"except\" with \"*\""
+ }
+
+ if {"" != $pattern && "" != $target} {
+ error "$errRoot, cannot specify both \"as\" and \"using\""
+ }
+
+ foreach token [lrange $method 1 end-1] {
+ if {"*" == $token} {
+ error "$errRoot, \"*\" must be the last token."
+ }
+ }
+
+ # NEXT, we delegate some methods
+ set compile(delegatesmethods) yes
+
+ # NEXT, define the component. Allow typecomponents.
+ if {"" != $component} {
+ if {[lsearch -exact $compile(typecomponents) $component] == -1} {
+ Comp.DefineComponent $component $errRoot
+ }
+ }
+
+ # NEXT, define the pattern.
+ if {"" == $pattern} {
+ if {"*" == $methodTail} {
+ set pattern "%c %m"
+ } elseif {"" != $target} {
+ set pattern "%c $target"
+ } else {
+ set pattern "%c %m"
+ }
+ }
+
+ # Make sure the pattern is a valid list.
+ if {[catch {lindex $pattern 0} result]} {
+ error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
+ }
+
+ # NEXT, check the method name against previously defined
+ # methods.
+ Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot
+
+ # NEXT, save the method info.
+ set methodInfo($method) [list 0 $pattern $component]
+
+ if {[string equal $methodTail "*"]} {
+ Mappend compile(defs) {
+ set %TYPE%::Snit_info(exceptmethods) %EXCEPT%
+ } %EXCEPT% [list $exceptions]
+ }
+}
+
+# Creates a delegated option, delegating it to a particular
+# component and, optionally, to a particular option of that
+# component.
+#
+# optionDef The option definition
+# args definition arguments.
+
+proc ::snit::Comp.DelegatedOption {optionDef arglist} {
+ variable compile
+
+ # First, get the three option names.
+ set option [lindex $optionDef 0]
+ set resourceName [lindex $optionDef 1]
+ set className [lindex $optionDef 2]
+
+ set errRoot "Error in \"delegate option [list $optionDef]...\""
+
+ # Next, parse the delegation options.
+ set component ""
+ set target ""
+ set exceptions {}
+
+ foreach {opt value} $arglist {
+ switch -exact $opt {
+ to { set component $value }
+ as { set target $value }
+ except { set exceptions $value }
+ default {
+ error "$errRoot, unknown delegation option \"$opt\""
+ }
+ }
+ }
+
+ if {"" == $component} {
+ error "$errRoot, missing \"to\""
+ }
+
+ if {"*" == $option && "" != $target} {
+ error "$errRoot, cannot specify \"as\" with \"delegate option *\""
+ }
+
+ if {"*" != $option && "" != $exceptions} {
+ error "$errRoot, can only specify \"except\" with \"delegate option *\""
+ }
+
+ # Next, validate the option name
+
+ if {"*" != $option} {
+ if {![Comp.OptionNameIsValid $option]} {
+ error "$errRoot, badly named option \"$option\""
+ }
+ }
+
+ if {[Contains $option $compile(localoptions)]} {
+ error "$errRoot, \"$option\" has been defined locally"
+ }
+
+ if {[Contains $option $compile(delegatedoptions)]} {
+ error "$errRoot, \"$option\" is multiply delegated"
+ }
+
+ # NEXT, define the component
+ Comp.DefineComponent $component $errRoot
+
+ # Next, define the target option, if not specified.
+ if {![string equal $option "*"] &&
+ [string equal $target ""]} {
+ set target $option
+ }
+
+ # NEXT, save the delegation data.
+ set compile(hasoptions) yes
+
+ if {![string equal $option "*"]} {
+ lappend compile(delegatedoptions) $option
+
+ # Next, compute the resource and class names, if they aren't
+ # already defined.
+
+ if {"" == $resourceName} {
+ set resourceName [string range $option 1 end]
+ }
+
+ if {"" == $className} {
+ set className [Capitalize $resourceName]
+ }
+
+ Mappend compile(defs) {
+ set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0
+ set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES%
+ set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
+ lappend %TYPE%::Snit_optionInfo(delegated) %OPTION%
+ set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%]
+ lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION%
+ } %OPTION% $option \
+ %COMP% $component \
+ %TARGET% $target \
+ %RES% $resourceName \
+ %CLASS% $className
+ } else {
+ Mappend compile(defs) {
+ set %TYPE%::Snit_optionInfo(starcomp) %COMP%
+ set %TYPE%::Snit_optionInfo(except) %EXCEPT%
+ } %COMP% $component %EXCEPT% [list $exceptions]
+ }
+}
+
+# Exposes a component, effectively making the component's command an
+# instance method.
+#
+# component The logical name of the delegate
+# "as" sugar; if not "", must be "as"
+# methodname The desired method name for the component's command, or ""
+
+proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} {
+ variable compile
+
+
+ # FIRST, define the component
+ Comp.DefineComponent $component
+
+ # NEXT, define the method just as though it were in the type
+ # definition.
+ if {[string equal $methodname ""]} {
+ set methodname $component
+ }
+
+ Comp.statement.method $methodname args [Expand {
+ if {[llength $args] == 0} {
+ return $%COMPONENT%
+ }
+
+ if {[string equal $%COMPONENT% ""]} {
+ error "undefined component \"%COMPONENT%\""
+ }
+
+
+ set cmd [linsert $args 0 $%COMPONENT%]
+ return [uplevel 1 $cmd]
+ } %COMPONENT% $component]
+}
+
+
+
+#-----------------------------------------------------------------------
+# Public commands
+
+# Compile a type definition, and return the results as a list of two
+# items: the fully-qualified type name, and a script that will define
+# the type when executed.
+#
+# which type, widget, or widgetadaptor
+# type the type name
+# body the type definition
+proc ::snit::compile {which type body} {
+ return [Comp.Compile $which $type $body]
+}
+
+proc ::snit::type {type body} {
+ return [Comp.Define [Comp.Compile type $type $body]]
+}
+
+proc ::snit::widget {type body} {
+ return [Comp.Define [Comp.Compile widget $type $body]]
+}
+
+proc ::snit::widgetadaptor {type body} {
+ return [Comp.Define [Comp.Compile widgetadaptor $type $body]]
+}
+
+proc ::snit::typemethod {type method arglist body} {
+ # Make sure the type exists.
+ if {![info exists ${type}::Snit_info]} {
+ error "no such type: \"$type\""
+ }
+
+ upvar ${type}::Snit_info Snit_info
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+
+ # FIRST, check the typemethod name against previously defined
+ # typemethods.
+ Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \
+ "Cannot define \"$method\""
+
+ # NEXT, check the arguments
+ CheckArgs "snit::typemethod $type $method" $arglist
+
+ # Next, add magic reference to type.
+ set arglist [concat type $arglist]
+
+ # Next, add typevariable declarations to body:
+ set body "$Snit_info(tvardecs)\n$body"
+
+ # Next, define it.
+ if {[llength $method] == 1} {
+ set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
+ uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body]
+ } else {
+ set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
+ set suffix [join $method _]
+ uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body]
+ }
+}
+
+proc ::snit::method {type method arglist body} {
+ # Make sure the type exists.
+ if {![info exists ${type}::Snit_info]} {
+ error "no such type: \"$type\""
+ }
+
+ upvar ${type}::Snit_methodInfo Snit_methodInfo
+ upvar ${type}::Snit_info Snit_info
+
+ # FIRST, check the method name against previously defined
+ # methods.
+ Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \
+ "Cannot define \"$method\""
+
+ # NEXT, check the arguments
+ CheckArgs "snit::method $type $method" $arglist
+
+ # Next, add magic references to type and self.
+ set arglist [concat type selfns win self $arglist]
+
+ # Next, add variable declarations to body:
+ set body "$Snit_info(tvardecs)$Snit_info(ivardecs)\n$body"
+
+ # Next, define it.
+ if {[llength $method] == 1} {
+ set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
+ uplevel 1 [list proc ${type}::Snit_method$method $arglist $body]
+ } else {
+ set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
+
+ set suffix [join $method _]
+ uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body]
+ }
+}
+
+# Defines a proc within the compiler; this proc can call other
+# type definition statements, and thus can be used for meta-programming.
+proc ::snit::macro {name arglist body} {
+ variable compiler
+ variable reservedwords
+
+ # FIRST, make sure the compiler is defined.
+ Comp.Init
+
+ # NEXT, check the macro name against the reserved words
+ if {[lsearch -exact $reservedwords $name] != -1} {
+ error "invalid macro name \"$name\""
+ }
+
+ # NEXT, see if the name has a namespace; if it does, define the
+ # namespace.
+ set ns [namespace qualifiers $name]
+
+ if {"" != $ns} {
+ $compiler eval "namespace eval $ns {}"
+ }
+
+ # NEXT, define the macro
+ $compiler eval [list _proc $name $arglist $body]
+}
+
+#-----------------------------------------------------------------------
+# Utility Functions
+#
+# These are utility functions used while compiling Snit types.
+
+# Builds a template from a tagged list of text blocks, then substitutes
+# all symbols in the mapTable, returning the expanded template.
+proc ::snit::Expand {template args} {
+ return [string map $args $template]
+}
+
+# Expands a template and appends it to a variable.
+proc ::snit::Mappend {varname template args} {
+ upvar $varname myvar
+
+ append myvar [string map $args $template]
+}
+
+# Checks argument list against reserved args
+proc ::snit::CheckArgs {which arglist} {
+ variable reservedArgs
+
+ foreach name $reservedArgs {
+ if {[Contains $name $arglist]} {
+ error "$which's arglist may not contain \"$name\" explicitly"
+ }
+ }
+}
+
+# Returns 1 if a value is in a list, and 0 otherwise.
+proc ::snit::Contains {value list} {
+ if {[lsearch -exact $list $value] != -1} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# Capitalizes the first letter of a string.
+proc ::snit::Capitalize {text} {
+ set first [string index $text 0]
+ set rest [string range $text 1 end]
+ return "[string toupper $first]$rest"
+}
+
+# Converts an arbitrary white-space-delimited string into a list
+# by splitting on white-space and deleting empty tokens.
+
+proc ::snit::Listify {str} {
+ set result {}
+ foreach token [split [string trim $str]] {
+ if {[string length $token] > 0} {
+ lappend result $token
+ }
+ }
+
+ return $result
+}
+
+
+#=======================================================================
+# Snit Runtime Library
+#
+# These are procs used by Snit types and widgets at runtime.
+
+#-----------------------------------------------------------------------
+# Object Creation
+
+# Creates a new instance of the snit::type given its name and the args.
+#
+# type The snit::type
+# name The instance name
+# args Args to pass to the constructor
+
+proc ::snit::RT.type.typemethod.create {type name args} {
+ variable ${type}::Snit_info
+ variable ${type}::Snit_optionInfo
+
+ # FIRST, qualify the name.
+ if {![string match "::*" $name]} {
+ # Get caller's namespace;
+ # append :: if not global namespace.
+ set ns [uplevel 1 [list namespace current]]
+ if {"::" != $ns} {
+ append ns "::"
+ }
+
+ set name "$ns$name"
+ }
+
+ # NEXT, if %AUTO% appears in the name, generate a unique
+ # command name. Otherwise, ensure that the name isn't in use.
+ if {[string match "*%AUTO%*" $name]} {
+ set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
+ } elseif {$Snit_info(canreplace) && [llength [info commands $name]]} {
+
+ #kmg-tcl83
+ #
+ # Had to add this elseif branch to pass test rename-1.5
+ #
+ # Allowed to replace so must first destroy the prior instance
+
+ $name destroy
+ } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} {
+ error "command \"$name\" already exists"
+ }
+
+ # NEXT, create the instance's namespace.
+ set selfns \
+ [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
+ namespace eval $selfns {}
+
+ # NEXT, install the dispatcher
+ RT.MakeInstanceCommand $type $selfns $name
+
+ # Initialize the options to their defaults.
+ upvar ${selfns}::options options
+ foreach opt $Snit_optionInfo(local) {
+ set options($opt) $Snit_optionInfo(default-$opt)
+ }
+
+ # Initialize the instance vars to their defaults.
+ # selfns must be defined, as it is used implicitly.
+ ${type}::Snit_instanceVars $selfns
+
+ # Execute the type's constructor.
+ set errcode [catch {
+ RT.ConstructInstance $type $selfns $name $args
+ } result]
+
+ if {$errcode} {
+ global errorInfo
+ global errorCode
+
+ set theInfo $errorInfo
+ set theCode $errorCode
+ ::snit::RT.DestroyObject $type $selfns $name
+ error "Error in constructor: $result" $theInfo $theCode
+ }
+
+ # NEXT, return the object's name.
+ return $name
+}
+
+# Creates a new instance of the snit::widget or snit::widgetadaptor
+# given its name and the args.
+#
+# type The snit::widget or snit::widgetadaptor
+# name The instance name
+# args Args to pass to the constructor
+
+proc ::snit::RT.widget.typemethod.create {type name args} {
+ variable ${type}::Snit_info
+ variable ${type}::Snit_optionInfo
+
+ # FIRST, if %AUTO% appears in the name, generate a unique
+ # command name.
+ if {[string match "*%AUTO%*" $name]} {
+ set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
+ }
+
+ # NEXT, create the instance's namespace.
+ set selfns \
+ [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
+ namespace eval $selfns { }
+
+ # NEXT, Initialize the widget's own options to their defaults.
+ upvar ${selfns}::options options
+ foreach opt $Snit_optionInfo(local) {
+ set options($opt) $Snit_optionInfo(default-$opt)
+ }
+
+ # Initialize the instance vars to their defaults.
+ ${type}::Snit_instanceVars $selfns
+
+ # NEXT, if this is a normal widget (not a widget adaptor) then create a
+ # frame as its hull. We set the frame's -class to the user's widgetclass,
+ # or, if none, search for -class in the args list, otherwise default to
+ # the basename of the $type with an initial upper case letter.
+ if {!$Snit_info(isWidgetAdaptor)} {
+ # FIRST, determine the class name
+ set wclass $Snit_info(widgetclass)
+ if {$Snit_info(widgetclass) == ""} {
+ set idx [lsearch -exact $args -class]
+ if {$idx >= 0 && ($idx%2 == 0)} {
+ # -class exists and is in the -option position
+ set wclass [lindex $args [expr {$idx+1}]]
+ set args [lreplace $args $idx [expr {$idx+1}]]
+ } else {
+ set wclass [::snit::Capitalize [namespace tail $type]]
+ }
+ }
+
+ # NEXT, create the widget
+ set self $name
+ package require Tk
+ ${type}::installhull using $Snit_info(hulltype) -class $wclass
+
+ # NEXT, let's query the option database for our
+ # widget, now that we know that it exists.
+ foreach opt $Snit_optionInfo(local) {
+ set dbval [RT.OptionDbGet $type $name $opt]
+
+ if {"" != $dbval} {
+ set options($opt) $dbval
+ }
+ }
+ }
+
+ # Execute the type's constructor, and verify that it
+ # has a hull.
+ set errcode [catch {
+ RT.ConstructInstance $type $selfns $name $args
+
+ ::snit::RT.Component $type $selfns hull
+
+ # Prepare to call the object's destructor when the
+ # <Destroy> event is received. Use a Snit-specific bindtag
+ # so that the widget name's tag is unencumbered.
+
+ bind Snit$type$name <Destroy> [::snit::Expand {
+ ::snit::RT.DestroyObject %TYPE% %NS% %W
+ } %TYPE% $type %NS% $selfns]
+
+ # Insert the bindtag into the list of bindtags right
+ # after the widget name.
+ set taglist [bindtags $name]
+ set ndx [lsearch -exact $taglist $name]
+ incr ndx
+ bindtags $name [linsert $taglist $ndx Snit$type$name]
+ } result]
+
+ if {$errcode} {
+ global errorInfo
+ global errorCode
+
+ set theInfo $errorInfo
+ set theCode $errorCode
+ ::snit::RT.DestroyObject $type $selfns $name
+ error "Error in constructor: $result" $theInfo $theCode
+ }
+
+ # NEXT, return the object's name.
+ return $name
+}
+
+
+# RT.MakeInstanceCommand type selfns instance
+#
+# type The object type
+# selfns The instance namespace
+# instance The instance name
+#
+# Creates the instance proc.
+
+proc ::snit::RT.MakeInstanceCommand {type selfns instance} {
+ variable ${type}::Snit_info
+
+ # FIRST, remember the instance name. The Snit_instance variable
+ # allows the instance to figure out its current name given the
+ # instance namespace.
+ upvar ${selfns}::Snit_instance Snit_instance
+ set Snit_instance $instance
+
+ # NEXT, qualify the proc name if it's a widget.
+ if {$Snit_info(isWidget)} {
+ set procname ::$instance
+ } else {
+ set procname $instance
+ }
+
+ # NEXT, install the new proc
+ if {!$Snit_info(simpledispatch)} {
+ set instanceProc $::snit::nominalInstanceProc
+ } else {
+ set instanceProc $::snit::simpleInstanceProc
+ }
+
+ proc $procname {method args} \
+ [string map \
+ [list %SELFNS% $selfns %WIN% $instance %TYPE% $type] \
+ $instanceProc]
+
+ #kmg-tcl83
+ # NEXT, add the trace.
+ ::snit83::traceAddCommand $procname {rename delete} \
+ [list ::snit::RT.InstanceTrace $type $selfns $instance]
+}
+
+# This proc is called when the instance command is renamed.
+# If op is delete, then new will always be "", so op is redundant.
+#
+# type The fully-qualified type name
+# selfns The instance namespace
+# win The original instance/tk window name.
+# old old instance command name
+# new new instance command name
+# op rename or delete
+#
+# If the op is delete, we need to clean up the object; otherwise,
+# we need to track the change.
+#
+# NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete
+# traces aren't propagated correctly. Instead, they silently
+# vanish. Add a catch to output any error message.
+
+proc ::snit::RT.InstanceTrace {type selfns win old new op} {
+ variable ${type}::Snit_info
+
+ # Note to developers ...
+ # For Tcl 8.4.0, errors thrown in trace handlers vanish silently.
+ # Therefore we catch them here and create some output to help in
+ # debugging such problems.
+
+ if {[catch {
+ # FIRST, clean up if necessary
+ if {"" == $new} {
+ if {$Snit_info(isWidget)} {
+ destroy $win
+ } else {
+ ::snit::RT.DestroyObject $type $selfns $win
+ }
+ } else {
+ # Otherwise, track the change.
+ variable ${selfns}::Snit_instance
+ set Snit_instance [uplevel 1 [list namespace which -command $new]]
+
+ # Also, clear the instance caches, as many cached commands
+ # might be invalid.
+ RT.ClearInstanceCaches $selfns
+ }
+ } result]} {
+ global errorInfo
+ # Pop up the console on Windows wish, to enable stdout.
+ # This clobbers errorInfo on unix, so save it so we can print it.
+ set ei $errorInfo
+ catch {console show}
+ puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:"
+ puts $ei
+ }
+}
+
+# Calls the instance constructor and handles related housekeeping.
+proc ::snit::RT.ConstructInstance {type selfns instance arglist} {
+ variable ${type}::Snit_optionInfo
+ variable ${selfns}::Snit_iinfo
+
+ # Track whether we are constructed or not.
+ set Snit_iinfo(constructed) 0
+
+ # Call the user's constructor
+ eval [linsert $arglist 0 \
+ ${type}::Snit_constructor $type $selfns $instance $instance]
+
+ set Snit_iinfo(constructed) 1
+
+ # Validate the initial set of options (including defaults)
+ foreach option $Snit_optionInfo(local) {
+ set value [set ${selfns}::options($option)]
+
+ if {"" != $Snit_optionInfo(typespec-$option)} {
+ if {[catch {
+ $Snit_optionInfo(typeobj-$option) validate $value
+ } result]} {
+ return -code error "invalid $option default: $result"
+ }
+ }
+ }
+
+ # Unset the configure cache for all -readonly options.
+ # This ensures that the next time anyone tries to
+ # configure it, an error is thrown.
+ foreach opt $Snit_optionInfo(local) {
+ if {$Snit_optionInfo(readonly-$opt)} {
+ ::snit83::unset -nocomplain ${selfns}::Snit_configureCache($opt)
+ }
+ }
+
+ return
+}
+
+# Returns a unique command name.
+#
+# REQUIRE: type is a fully qualified name.
+# REQUIRE: name contains "%AUTO%"
+# PROMISE: the returned command name is unused.
+proc ::snit::RT.UniqueName {countervar type name} {
+ upvar $countervar counter
+ while 1 {
+ # FIRST, bump the counter and define the %AUTO% instance name;
+ # then substitute it into the specified name. Wrap around at
+ # 2^31 - 2 to prevent overflow problems.
+ incr counter
+ if {$counter > 2147483646} {
+ set counter 0
+ }
+ set auto "[namespace tail $type]$counter"
+ set candidate [Expand $name %AUTO% $auto]
+ if {![llength [info commands $candidate]]} {
+ return $candidate
+ }
+ }
+}
+
+# Returns a unique instance namespace, fully qualified.
+#
+# countervar The name of a counter variable
+# type The instance's type
+#
+# REQUIRE: type is fully qualified
+# PROMISE: The returned namespace name is unused.
+
+proc ::snit::RT.UniqueInstanceNamespace {countervar type} {
+ upvar $countervar counter
+ while 1 {
+ # FIRST, bump the counter and define the namespace name.
+ # Then see if it already exists. Wrap around at
+ # 2^31 - 2 to prevent overflow problems.
+ incr counter
+ if {$counter > 2147483646} {
+ set counter 0
+ }
+ set ins "${type}::Snit_inst${counter}"
+ if {![namespace exists $ins]} {
+ return $ins
+ }
+ }
+}
+
+# Retrieves an option's value from the option database.
+# Returns "" if no value is found.
+proc ::snit::RT.OptionDbGet {type self opt} {
+ variable ${type}::Snit_optionInfo
+
+ return [option get $self \
+ $Snit_optionInfo(resource-$opt) \
+ $Snit_optionInfo(class-$opt)]
+}
+
+#-----------------------------------------------------------------------
+# Object Destruction
+
+# Implements the standard "destroy" method
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+
+proc ::snit::RT.method.destroy {type selfns win self} {
+ variable ${selfns}::Snit_iinfo
+
+ # Can't destroy the object if it isn't complete constructed.
+ if {!$Snit_iinfo(constructed)} {
+ return -code error "Called 'destroy' method in constructor"
+ }
+
+ # Calls Snit_cleanup, which (among other things) calls the
+ # user's destructor.
+ ::snit::RT.DestroyObject $type $selfns $win
+}
+
+# This is the function that really cleans up; it's automatically
+# called when any instance is destroyed, e.g., by "$object destroy"
+# for types, and by the <Destroy> event for widgets.
+#
+# type The fully-qualified type name.
+# selfns The instance namespace
+# win The original instance command name.
+
+proc ::snit::RT.DestroyObject {type selfns win} {
+ variable ${type}::Snit_info
+
+ # If the variable Snit_instance doesn't exist then there's no
+ # instance command for this object -- it's most likely a
+ # widgetadaptor. Consequently, there are some things that
+ # we don't need to do.
+ if {[info exists ${selfns}::Snit_instance]} {
+ upvar ${selfns}::Snit_instance instance
+
+ # First, remove the trace on the instance name, so that we
+ # don't call RT.DestroyObject recursively.
+ RT.RemoveInstanceTrace $type $selfns $win $instance
+
+ # Next, call the user's destructor
+ ${type}::Snit_destructor $type $selfns $win $instance
+
+ # Next, if this isn't a widget, delete the instance command.
+ # If it is a widget, get the hull component's name, and rename
+ # it back to the widget name
+
+ # Next, delete the hull component's instance command,
+ # if there is one.
+ if {$Snit_info(isWidget)} {
+ set hullcmd [::snit::RT.Component $type $selfns hull]
+
+ catch {rename $instance ""}
+
+ # Clear the bind event
+ bind Snit$type$win <Destroy> ""
+
+ if {[llength [info commands $hullcmd]]} {
+ # FIRST, rename the hull back to its original name.
+ # If the hull is itself a megawidget, it will have its
+ # own cleanup to do, and it might not do it properly
+ # if it doesn't have the right name.
+ rename $hullcmd ::$instance
+
+ # NEXT, destroy it.
+ destroy $instance
+ }
+ } else {
+ catch {rename $instance ""}
+ }
+ }
+
+ # Next, delete the instance's namespace. This kills any
+ # instance variables.
+ namespace delete $selfns
+
+ return
+}
+
+# Remove instance trace
+#
+# type The fully qualified type name
+# selfns The instance namespace
+# win The original instance name/Tk window name
+# instance The current instance name
+
+proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} {
+ variable ${type}::Snit_info
+
+ if {$Snit_info(isWidget)} {
+ set procname ::$instance
+ } else {
+ set procname $instance
+ }
+
+ # NEXT, remove any trace on this name
+ catch {
+ #kmg-tcl83
+ ::snit83::traceRemoveCommand $procname {rename delete} \
+ [list ::snit::RT.InstanceTrace $type $selfns $win]
+ }
+}
+
+#-----------------------------------------------------------------------
+# Typecomponent Management and Method Caching
+
+# Typecomponent trace; used for write trace on typecomponent
+# variables. Saves the new component object name, provided
+# that certain conditions are met. Also clears the typemethod
+# cache.
+
+proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} {
+ upvar ${type}::Snit_info Snit_info
+ upvar ${type}::${component} cvar
+ upvar ${type}::Snit_typecomponents Snit_typecomponents
+
+ # Save the new component value.
+ set Snit_typecomponents($component) $cvar
+
+ # Clear the typemethod cache.
+ # TBD: can we unset just the elements related to
+ # this component?
+ ::snit83::unset -nocomplain -- ${type}::Snit_typemethodCache
+}
+
+# Generates and caches the command for a typemethod.
+#
+# type The type
+# method The name of the typemethod to call.
+#
+# The return value is one of the following lists:
+#
+# {} There's no such method.
+# {1} The method has submethods; look again.
+# {0 <command>} Here's the command to execute.
+
+proc snit::RT.CacheTypemethodCommand {type method} {
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+ upvar ${type}::Snit_typecomponents Snit_typecomponents
+ upvar ${type}::Snit_typemethodCache Snit_typemethodCache
+ upvar ${type}::Snit_info Snit_info
+
+ # FIRST, get the pattern data and the typecomponent name.
+ set implicitCreate 0
+ set instanceName ""
+
+ set starredMethod [lreplace $method end end *]
+ set methodTail [lindex $method end]
+
+ if {[info exists Snit_typemethodInfo($method)]} {
+ set key $method
+ } elseif {[info exists Snit_typemethodInfo($starredMethod)]} {
+ if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} {
+ set key $starredMethod
+ } else {
+ return [list ]
+ }
+ } elseif {[llength $method] > 1} {
+ return [list ]
+ } elseif {$Snit_info(hasinstances)} {
+ # Assume the unknown name is an instance name to create, unless
+ # this is a widget and the style of the name is wrong, or the
+ # name mimics a standard typemethod.
+
+ if {[set ${type}::Snit_info(isWidget)] &&
+ ![string match ".*" $method]} {
+ return [list ]
+ }
+
+ # Without this check, the call "$type info" will redefine the
+ # standard "::info" command, with disastrous results. Since it's
+ # a likely thing to do if !-typeinfo, put in an explicit check.
+ if {"info" == $method || "destroy" == $method} {
+ return [list ]
+ }
+
+ set implicitCreate 1
+ set instanceName $method
+ set key create
+ set method create
+ } else {
+ return [list ]
+ }
+
+ foreach {flag pattern compName} $Snit_typemethodInfo($key) {}
+
+ if {$flag == 1} {
+ return [list 1]
+ }
+
+ # NEXT, build the substitution list
+ set subList [list \
+ %% % \
+ %t $type \
+ %M $method \
+ %m [lindex $method end] \
+ %j [join $method _]]
+
+ if {"" != $compName} {
+ if {![info exists Snit_typecomponents($compName)]} {
+ error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\""
+ }
+
+ lappend subList %c [list $Snit_typecomponents($compName)]
+ }
+
+ set command {}
+
+ foreach subpattern $pattern {
+ lappend command [string map $subList $subpattern]
+ }
+
+ if {$implicitCreate} {
+ # In this case, $method is the name of the instance to
+ # create. Don't cache, as we usually won't do this one
+ # again.
+ lappend command $instanceName
+ } else {
+ set Snit_typemethodCache($method) [list 0 $command]
+ }
+
+ return [list 0 $command]
+}
+
+
+#-----------------------------------------------------------------------
+# Component Management and Method Caching
+
+# Retrieves the object name given the component name.
+proc ::snit::RT.Component {type selfns name} {
+ variable ${selfns}::Snit_components
+
+ if {[catch {set Snit_components($name)} result]} {
+ variable ${selfns}::Snit_instance
+
+ error "component \"$name\" is undefined in $type $Snit_instance"
+ }
+
+ return $result
+}
+
+# Component trace; used for write trace on component instance
+# variables. Saves the new component object name, provided
+# that certain conditions are met. Also clears the method
+# cache.
+
+proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} {
+ upvar ${type}::Snit_info Snit_info
+ upvar ${selfns}::${component} cvar
+ upvar ${selfns}::Snit_components Snit_components
+
+ # If they try to redefine the hull component after
+ # it's been defined, that's an error--but only if
+ # this is a widget or widget adaptor.
+ if {"hull" == $component &&
+ $Snit_info(isWidget) &&
+ [info exists Snit_components($component)]} {
+ set cvar $Snit_components($component)
+ error "The hull component cannot be redefined"
+ }
+
+ # Save the new component value.
+ set Snit_components($component) $cvar
+
+ # Clear the instance caches.
+ # TBD: can we unset just the elements related to
+ # this component?
+ RT.ClearInstanceCaches $selfns
+}
+
+# Generates and caches the command for a method.
+#
+# type: The instance's type
+# selfns: The instance's private namespace
+# win: The instance's original name (a Tk widget name, for
+# snit::widgets.
+# self: The instance's current name.
+# method: The name of the method to call.
+#
+# The return value is one of the following lists:
+#
+# {} There's no such method.
+# {1} The method has submethods; look again.
+# {0 <command>} Here's the command to execute.
+
+proc ::snit::RT.CacheMethodCommand {type selfns win self method} {
+ variable ${type}::Snit_info
+ variable ${type}::Snit_methodInfo
+ variable ${type}::Snit_typecomponents
+ variable ${selfns}::Snit_components
+ variable ${selfns}::Snit_methodCache
+
+ # FIRST, get the pattern data and the component name.
+ set starredMethod [lreplace $method end end *]
+ set methodTail [lindex $method end]
+
+ if {[info exists Snit_methodInfo($method)]} {
+ set key $method
+ } elseif {[info exists Snit_methodInfo($starredMethod)] &&
+ [lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} {
+ set key $starredMethod
+ } else {
+ return [list ]
+ }
+
+ foreach {flag pattern compName} $Snit_methodInfo($key) {}
+
+ if {$flag == 1} {
+ return [list 1]
+ }
+
+ # NEXT, build the substitution list
+ set subList [list \
+ %% % \
+ %t $type \
+ %M $method \
+ %m [lindex $method end] \
+ %j [join $method _] \
+ %n [list $selfns] \
+ %w [list $win] \
+ %s [list $self]]
+
+ if {"" != $compName} {
+ if {[info exists Snit_components($compName)]} {
+ set compCmd $Snit_components($compName)
+ } elseif {[info exists Snit_typecomponents($compName)]} {
+ set compCmd $Snit_typecomponents($compName)
+ } else {
+ error "$type $self delegates method \"$method\" to undefined component \"$compName\""
+ }
+
+ lappend subList %c [list $compCmd]
+ }
+
+ # Note: The cached command will executed faster if it's
+ # already a list.
+ set command {}
+
+ foreach subpattern $pattern {
+ lappend command [string map $subList $subpattern]
+ }
+
+ set commandRec [list 0 $command]
+
+ set Snit_methodCache($method) $commandRec
+
+ return $commandRec
+}
+
+
+# Looks up a method's command.
+#
+# type: The instance's type
+# selfns: The instance's private namespace
+# win: The instance's original name (a Tk widget name, for
+# snit::widgets.
+# self: The instance's current name.
+# method: The name of the method to call.
+# errPrefix: Prefix for any error method
+proc ::snit::RT.LookupMethodCommand {type selfns win self method errPrefix} {
+ set commandRec [snit::RT.CacheMethodCommand \
+ $type $selfns $win $self \
+ $method]
+
+
+ if {[llength $commandRec] == 0} {
+ return -code error \
+ "$errPrefix, \"$self $method\" is not defined"
+ } elseif {[lindex $commandRec 0] == 1} {
+ return -code error \
+ "$errPrefix, wrong number args: should be \"$self\" $method method args"
+ }
+
+ return [lindex $commandRec 1]
+}
+
+
+# Clears all instance command caches
+proc ::snit::RT.ClearInstanceCaches {selfns} {
+ ::snit83::unset -nocomplain -- ${selfns}::Snit_methodCache
+ ::snit83::unset -nocomplain -- ${selfns}::Snit_cgetCache
+ ::snit83::unset -nocomplain -- ${selfns}::Snit_configureCache
+ ::snit83::unset -nocomplain -- ${selfns}::Snit_validateCache
+}
+
+
+#-----------------------------------------------------------------------
+# Component Installation
+
+# Implements %TYPE%::installhull. The variables self and selfns
+# must be defined in the caller's context.
+#
+# Installs the named widget as the hull of a
+# widgetadaptor. Once the widget is hijacked, its new name
+# is assigned to the hull component.
+
+proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} {
+ variable ${type}::Snit_info
+ variable ${type}::Snit_optionInfo
+ upvar self self
+ upvar selfns selfns
+ upvar ${selfns}::hull hull
+ upvar ${selfns}::options options
+
+ # FIRST, make sure we can do it.
+ if {!$Snit_info(isWidget)} {
+ error "installhull is valid only for snit::widgetadaptors"
+ }
+
+ if {[info exists ${selfns}::Snit_instance]} {
+ error "hull already installed for $type $self"
+ }
+
+ # NEXT, has it been created yet? If not, create it using
+ # the specified arguments.
+ if {"using" == $using} {
+ # FIRST, create the widget
+ set cmd [linsert $args 0 $widgetType $self]
+ set obj [uplevel 1 $cmd]
+
+ # NEXT, for each option explicitly delegated to the hull
+ # that doesn't appear in the usedOpts list, get the
+ # option database value and apply it--provided that the
+ # real option name and the target option name are different.
+ # (If they are the same, then the option database was
+ # already queried as part of the normal widget creation.)
+ #
+ # Also, we don't need to worry about implicitly delegated
+ # options, as the option and target option names must be
+ # the same.
+ if {[info exists Snit_optionInfo(delegated-hull)]} {
+
+ # FIRST, extract all option names from args
+ set usedOpts {}
+ set ndx [lsearch -glob $args "-*"]
+ foreach {opt val} [lrange $args $ndx end] {
+ lappend usedOpts $opt
+ }
+
+ foreach opt $Snit_optionInfo(delegated-hull) {
+ set target [lindex $Snit_optionInfo(target-$opt) 1]
+
+ if {"$target" == $opt} {
+ continue
+ }
+
+ set result [lsearch -exact $usedOpts $target]
+
+ if {$result != -1} {
+ continue
+ }
+
+ set dbval [RT.OptionDbGet $type $self $opt]
+ $obj configure $target $dbval
+ }
+ }
+ } else {
+ set obj $using
+
+ if {![string equal $obj $self]} {
+ error \
+ "hull name mismatch: \"$obj\" != \"$self\""
+ }
+ }
+
+ # NEXT, get the local option defaults.
+ foreach opt $Snit_optionInfo(local) {
+ set dbval [RT.OptionDbGet $type $self $opt]
+
+ if {"" != $dbval} {
+ set options($opt) $dbval
+ }
+ }
+
+
+ # NEXT, do the magic
+ set i 0
+ while 1 {
+ incr i
+ set newName "::hull${i}$self"
+ if {![llength [info commands $newName]]} {
+ break
+ }
+ }
+
+ rename ::$self $newName
+ RT.MakeInstanceCommand $type $selfns $self
+
+ # Note: this relies on RT.ComponentTrace to do the dirty work.
+ set hull $newName
+
+ return
+}
+
+# Implements %TYPE%::install.
+#
+# Creates a widget and installs it as the named component.
+# It expects self and selfns to be defined in the caller's context.
+
+proc ::snit::RT.install {type compName "using" widgetType winPath args} {
+ variable ${type}::Snit_optionInfo
+ variable ${type}::Snit_info
+ upvar self self
+ upvar selfns selfns
+ upvar ${selfns}::$compName comp
+ upvar ${selfns}::hull hull
+
+ # We do the magic option database stuff only if $self is
+ # a widget.
+ if {$Snit_info(isWidget)} {
+ if {"" == $hull} {
+ error "tried to install \"$compName\" before the hull exists"
+ }
+
+ # FIRST, query the option database and save the results
+ # into args. Insert them before the first option in the
+ # list, in case there are any non-standard parameters.
+ #
+ # Note: there might not be any delegated options; if so,
+ # don't bother.
+
+ if {[info exists Snit_optionInfo(delegated-$compName)]} {
+ set ndx [lsearch -glob $args "-*"]
+
+ foreach opt $Snit_optionInfo(delegated-$compName) {
+ set dbval [RT.OptionDbGet $type $self $opt]
+
+ if {"" != $dbval} {
+ set target [lindex $Snit_optionInfo(target-$opt) 1]
+ set args [linsert $args $ndx $target $dbval]
+ }
+ }
+ }
+ }
+
+ # NEXT, create the component and save it.
+ set cmd [concat [list $widgetType $winPath] $args]
+ set comp [uplevel 1 $cmd]
+
+ # NEXT, handle the option database for "delegate option *",
+ # in widgets only.
+ if {$Snit_info(isWidget) && [string equal $Snit_optionInfo(starcomp) $compName]} {
+ # FIRST, get the list of option specs from the widget.
+ # If configure doesn't work, skip it.
+ if {[catch {$comp configure} specs]} {
+ return
+ }
+
+ # NEXT, get the set of explicitly used options from args
+ set usedOpts {}
+ set ndx [lsearch -glob $args "-*"]
+ foreach {opt val} [lrange $args $ndx end] {
+ lappend usedOpts $opt
+ }
+
+ # NEXT, "delegate option *" matches all options defined
+ # by this widget that aren't defined by the widget as a whole,
+ # and that aren't excepted. Plus, we skip usedOpts. So build
+ # a list of the options it can't match.
+ set skiplist [concat \
+ $usedOpts \
+ $Snit_optionInfo(except) \
+ $Snit_optionInfo(local) \
+ $Snit_optionInfo(delegated)]
+
+ # NEXT, loop over all of the component's options, and set
+ # any not in the skip list for which there is an option
+ # database value.
+ foreach spec $specs {
+ # Skip aliases
+ if {[llength $spec] != 5} {
+ continue
+ }
+
+ set opt [lindex $spec 0]
+
+ if {[lsearch -exact $skiplist $opt] != -1} {
+ continue
+ }
+
+ set res [lindex $spec 1]
+ set cls [lindex $spec 2]
+
+ set dbvalue [option get $self $res $cls]
+
+ if {"" != $dbvalue} {
+ $comp configure $opt $dbvalue
+ }
+ }
+ }
+
+ return
+}
+
+
+#-----------------------------------------------------------------------
+# Method/Variable Name Qualification
+
+# Implements %TYPE%::variable. Requires selfns.
+proc ::snit::RT.variable {varname} {
+ upvar selfns selfns
+
+ if {![string match "::*" $varname]} {
+ uplevel 1 [list upvar 1 ${selfns}::$varname $varname]
+ } else {
+ # varname is fully qualified; let the standard
+ # "variable" command handle it.
+ uplevel 1 [list ::variable $varname]
+ }
+}
+
+# Fully qualifies a typevariable name.
+#
+# This is used to implement the mytypevar command.
+
+proc ::snit::RT.mytypevar {type name} {
+ return ${type}::$name
+}
+
+# Fully qualifies an instance variable name.
+#
+# This is used to implement the myvar command.
+proc ::snit::RT.myvar {name} {
+ upvar selfns selfns
+ return ${selfns}::$name
+}
+
+# Use this like "list" to convert a proc call into a command
+# string to pass to another object (e.g., as a -command).
+# Qualifies the proc name properly.
+#
+# This is used to implement the "myproc" command.
+
+proc ::snit::RT.myproc {type procname args} {
+ set procname "${type}::$procname"
+ return [linsert $args 0 $procname]
+}
+
+# DEPRECATED
+proc ::snit::RT.codename {type name} {
+ return "${type}::$name"
+}
+
+# Use this like "list" to convert a typemethod call into a command
+# string to pass to another object (e.g., as a -command).
+# Inserts the type command at the beginning.
+#
+# This is used to implement the "mytypemethod" command.
+
+proc ::snit::RT.mytypemethod {type args} {
+ return [linsert $args 0 $type]
+}
+
+# Use this like "list" to convert a method call into a command
+# string to pass to another object (e.g., as a -command).
+# Inserts the code at the beginning to call the right object, even if
+# the object's name has changed. Requires that selfns be defined
+# in the calling context, eg. can only be called in instance
+# code.
+#
+# This is used to implement the "mymethod" command.
+
+proc ::snit::RT.mymethod {args} {
+ upvar selfns selfns
+ return [linsert $args 0 ::snit::RT.CallInstance ${selfns}]
+}
+
+# Calls an instance method for an object given its
+# instance namespace and remaining arguments (the first of which
+# will be the method name.
+#
+# selfns The instance namespace
+# args The arguments
+#
+# Uses the selfns to determine $self, and calls the method
+# in the normal way.
+#
+# This is used to implement the "mymethod" command.
+
+proc ::snit::RT.CallInstance {selfns args} {
+ upvar ${selfns}::Snit_instance self
+
+ set retval [catch {uplevel 1 [linsert $args 0 $self]} result]
+
+ if {$retval} {
+ if {$retval == 1} {
+ global errorInfo
+ global errorCode
+ return -code error -errorinfo $errorInfo \
+ -errorcode $errorCode $result
+ } else {
+ return -code $retval $result
+ }
+ }
+
+ return $result
+}
+
+# Looks for the named option in the named variable. If found,
+# it and its value are removed from the list, and the value
+# is returned. Otherwise, the default value is returned.
+# If the option is undelegated, it's own default value will be
+# used if none is specified.
+#
+# Implements the "from" command.
+
+proc ::snit::RT.from {type argvName option {defvalue ""}} {
+ variable ${type}::Snit_optionInfo
+ upvar $argvName argv
+
+ set ioption [lsearch -exact $argv $option]
+
+ if {$ioption == -1} {
+ if {"" == $defvalue &&
+ [info exists Snit_optionInfo(default-$option)]} {
+ return $Snit_optionInfo(default-$option)
+ } else {
+ return $defvalue
+ }
+ }
+
+ set ivalue [expr {$ioption + 1}]
+ set value [lindex $argv $ivalue]
+
+ set argv [lreplace $argv $ioption $ivalue]
+
+ return $value
+}
+
+#-----------------------------------------------------------------------
+# Type Destruction
+
+# Implements the standard "destroy" typemethod:
+# Destroys a type completely.
+#
+# type The snit type
+
+proc ::snit::RT.typemethod.destroy {type} {
+ variable ${type}::Snit_info
+
+ # FIRST, destroy all instances
+ foreach selfns [namespace children $type] {
+ if {![namespace exists $selfns]} {
+ continue
+ }
+ upvar ${selfns}::Snit_instance obj
+
+ if {$Snit_info(isWidget)} {
+ destroy $obj
+ } else {
+ if {[llength [info commands $obj]]} {
+ $obj destroy
+ }
+ }
+ }
+
+ # NEXT, destroy the type's data.
+ namespace delete $type
+
+ # NEXT, get rid of the type command.
+ rename $type ""
+}
+
+
+
+#-----------------------------------------------------------------------
+# Option Handling
+
+# Implements the standard "cget" method
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# option The name of the option
+
+proc ::snit::RT.method.cget {type selfns win self option} {
+ if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} {
+ set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option]
+
+ if {[llength $command] == 0} {
+ return -code error "unknown option \"$option\""
+ }
+ }
+
+ uplevel 1 $command
+}
+
+# Retrieves and caches the command that implements "cget" for the
+# specified option.
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# option The name of the option
+
+proc ::snit::RT.CacheCgetCommand {type selfns win self option} {
+ variable ${type}::Snit_optionInfo
+ variable ${selfns}::Snit_cgetCache
+
+ if {[info exists Snit_optionInfo(islocal-$option)]} {
+ # We know the item; it's either local, or explicitly delegated.
+ if {$Snit_optionInfo(islocal-$option)} {
+ # It's a local option. If it has a cget method defined,
+ # use it; otherwise just return the value.
+
+ if {"" == $Snit_optionInfo(cget-$option)} {
+ set command [list set ${selfns}::options($option)]
+ } else {
+ set command [snit::RT.LookupMethodCommand \
+ $type $selfns $win $self \
+ $Snit_optionInfo(cget-$option) \
+ "can't cget $option"]
+
+ lappend command $option
+ }
+
+ set Snit_cgetCache($option) $command
+ return $command
+ }
+
+ # Explicitly delegated option; get target
+ set comp [lindex $Snit_optionInfo(target-$option) 0]
+ set target [lindex $Snit_optionInfo(target-$option) 1]
+ } elseif {"" != $Snit_optionInfo(starcomp) &&
+ [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
+ # Unknown option, but unknowns are delegated; get target.
+ set comp $Snit_optionInfo(starcomp)
+ set target $option
+ } else {
+ return ""
+ }
+
+ # Get the component's object.
+ set obj [RT.Component $type $selfns $comp]
+
+ set command [list $obj cget $target]
+ set Snit_cgetCache($option) $command
+
+ return $command
+}
+
+# Implements the standard "configurelist" method
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# optionlist A list of options and their values.
+
+proc ::snit::RT.method.configurelist {type selfns win self optionlist} {
+ variable ${type}::Snit_optionInfo
+
+ foreach {option value} $optionlist {
+ # FIRST, get the configure command, caching it if need be.
+ if {[catch {set ${selfns}::Snit_configureCache($option)} command]} {
+ set command [snit::RT.CacheConfigureCommand \
+ $type $selfns $win $self $option]
+
+ if {[llength $command] == 0} {
+ return -code error "unknown option \"$option\""
+ }
+ }
+
+ # NEXT, if we have a type-validation object, use it.
+ # TBD: Should test (islocal-$option) here, but islocal
+ # isn't defined for implicitly delegated options.
+ if {[info exists Snit_optionInfo(typeobj-$option)]
+ && "" != $Snit_optionInfo(typeobj-$option)} {
+ if {[catch {
+ $Snit_optionInfo(typeobj-$option) validate $value
+ } result]} {
+ return -code error "invalid $option value: $result"
+ }
+ }
+
+ # NEXT, the caching the configure command also cached the
+ # validate command, if any. If we have one, run it.
+ set valcommand [set ${selfns}::Snit_validateCache($option)]
+
+ if {[llength $valcommand]} {
+ lappend valcommand $value
+ uplevel 1 $valcommand
+ }
+
+ # NEXT, configure the option with the value.
+ lappend command $value
+ uplevel 1 $command
+ }
+
+ return
+}
+
+# Retrieves and caches the command that stores the named option.
+# Also stores the command that validates the name option if any;
+# If none, the validate command is "", so that the cache is always
+# populated.
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# option An option name
+
+proc ::snit::RT.CacheConfigureCommand {type selfns win self option} {
+ variable ${type}::Snit_optionInfo
+ variable ${selfns}::Snit_configureCache
+ variable ${selfns}::Snit_validateCache
+
+ if {[info exist Snit_optionInfo(islocal-$option)]} {
+ # We know the item; it's either local, or explicitly delegated.
+
+ if {$Snit_optionInfo(islocal-$option)} {
+ # It's a local option.
+
+ # If it's readonly, it throws an error if we're already
+ # constructed.
+ if {$Snit_optionInfo(readonly-$option)} {
+ if {[set ${selfns}::Snit_iinfo(constructed)]} {
+ error "option $option can only be set at instance creation"
+ }
+ }
+
+ # If it has a validate method, cache that for later.
+ if {"" != $Snit_optionInfo(validate-$option)} {
+ set command [snit::RT.LookupMethodCommand \
+ $type $selfns $win $self \
+ $Snit_optionInfo(validate-$option) \
+ "can't validate $option"]
+
+ lappend command $option
+ set Snit_validateCache($option) $command
+ } else {
+ set Snit_validateCache($option) ""
+ }
+
+ # If it has a configure method defined,
+ # cache it; otherwise, just set the value.
+
+ if {"" == $Snit_optionInfo(configure-$option)} {
+ set command [list set ${selfns}::options($option)]
+ } else {
+ set command [snit::RT.LookupMethodCommand \
+ $type $selfns $win $self \
+ $Snit_optionInfo(configure-$option) \
+ "can't configure $option"]
+
+ lappend command $option
+ }
+
+ set Snit_configureCache($option) $command
+ return $command
+ }
+
+ # Delegated option: get target.
+ set comp [lindex $Snit_optionInfo(target-$option) 0]
+ set target [lindex $Snit_optionInfo(target-$option) 1]
+ } elseif {$Snit_optionInfo(starcomp) != "" &&
+ [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
+ # Unknown option, but unknowns are delegated.
+ set comp $Snit_optionInfo(starcomp)
+ set target $option
+ } else {
+ return ""
+ }
+
+ # There is no validate command in this case; save an empty string.
+ set Snit_validateCache($option) ""
+
+ # Get the component's object
+ set obj [RT.Component $type $selfns $comp]
+
+ set command [list $obj configure $target]
+ set Snit_configureCache($option) $command
+
+ return $command
+}
+
+# Implements the standard "configure" method
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# args A list of options and their values, possibly empty.
+
+proc ::snit::RT.method.configure {type selfns win self args} {
+ # If two or more arguments, set values as usual.
+ if {[llength $args] >= 2} {
+ ::snit::RT.method.configurelist $type $selfns $win $self $args
+ return
+ }
+
+ # If zero arguments, acquire data for each known option
+ # and return the list
+ if {[llength $args] == 0} {
+ set result {}
+ foreach opt [RT.method.info.options $type $selfns $win $self] {
+ # Refactor this, so that we don't need to call via $self.
+ lappend result [RT.GetOptionDbSpec \
+ $type $selfns $win $self $opt]
+ }
+
+ return $result
+ }
+
+ # They want it for just one.
+ set opt [lindex $args 0]
+
+ return [RT.GetOptionDbSpec $type $selfns $win $self $opt]
+}
+
+
+# Retrieves the option database spec for a single option.
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# option The name of an option
+#
+# TBD: This is a bad name. What it's returning is the
+# result of the configure query.
+
+proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} {
+ variable ${type}::Snit_optionInfo
+
+ upvar ${selfns}::Snit_components Snit_components
+ upvar ${selfns}::options options
+
+ if {[info exists options($opt)]} {
+ # This is a locally-defined option. Just build the
+ # list and return it.
+ set res $Snit_optionInfo(resource-$opt)
+ set cls $Snit_optionInfo(class-$opt)
+ set def $Snit_optionInfo(default-$opt)
+
+ return [list $opt $res $cls $def \
+ [RT.method.cget $type $selfns $win $self $opt]]
+ } elseif {[info exists Snit_optionInfo(target-$opt)]} {
+ # This is an explicitly delegated option. The only
+ # thing we don't have is the default.
+ set res $Snit_optionInfo(resource-$opt)
+ set cls $Snit_optionInfo(class-$opt)
+
+ # Get the default
+ set logicalName [lindex $Snit_optionInfo(target-$opt) 0]
+ set comp $Snit_components($logicalName)
+ set target [lindex $Snit_optionInfo(target-$opt) 1]
+
+ if {[catch {$comp configure $target} result]} {
+ set defValue {}
+ } else {
+ set defValue [lindex $result 3]
+ }
+
+ return [list $opt $res $cls $defValue [$self cget $opt]]
+ } elseif {"" != $Snit_optionInfo(starcomp) &&
+ [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
+ set logicalName $Snit_optionInfo(starcomp)
+ set target $opt
+ set comp $Snit_components($logicalName)
+
+ if {[catch {set value [$comp cget $target]} result]} {
+ error "unknown option \"$opt\""
+ }
+
+ if {![catch {$comp configure $target} result]} {
+ # Replace the delegated option name with the local name.
+ return [::snit::Expand $result $target $opt]
+ }
+
+ # configure didn't work; return simple form.
+ return [list $opt "" "" "" $value]
+ } else {
+ error "unknown option \"$opt\""
+ }
+}
+
+#-----------------------------------------------------------------------
+# Type Introspection
+
+# Implements the standard "info" typemethod.
+#
+# type The snit type
+# command The info subcommand
+# args All other arguments.
+
+proc ::snit::RT.typemethod.info {type command args} {
+ global errorInfo
+ global errorCode
+
+ switch -exact $command {
+ args -
+ body -
+ default -
+ typevars -
+ typemethods -
+ instances {
+ # TBD: it should be possible to delete this error
+ # handling.
+ set errflag [catch {
+ uplevel 1 [linsert $args 0 \
+ ::snit::RT.typemethod.info.$command $type]
+ } result]
+
+ if {$errflag} {
+ return -code error -errorinfo $errorInfo \
+ -errorcode $errorCode $result
+ } else {
+ return $result
+ }
+ }
+ default {
+ error "\"$type info $command\" is not defined"
+ }
+ }
+}
+
+
+# Returns a list of the type's typevariables whose names match a
+# pattern, excluding Snit internal variables.
+#
+# type A Snit type
+# pattern Optional. The glob pattern to match. Defaults
+# to *.
+
+proc ::snit::RT.typemethod.info.typevars {type {pattern *}} {
+ set result {}
+ foreach name [info vars "${type}::$pattern"] {
+ set tail [namespace tail $name]
+ if {![string match "Snit_*" $tail]} {
+ lappend result $name
+ }
+ }
+
+ return $result
+}
+
+# Returns a list of the type's methods whose names match a
+# pattern. If "delegate typemethod *" is used, the list may
+# not be complete.
+#
+# type A Snit type
+# pattern Optional. The glob pattern to match. Defaults
+# to *.
+
+proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} {
+ variable ${type}::Snit_typemethodInfo
+ variable ${type}::Snit_typemethodCache
+
+ # FIRST, get the explicit names, skipping prefixes.
+ set result {}
+
+ foreach name [array names Snit_typemethodInfo $pattern] {
+ if {[lindex $Snit_typemethodInfo($name) 0] != 1} {
+ lappend result $name
+ }
+ }
+
+ # NEXT, add any from the cache that aren't explicit.
+ if {[info exists Snit_typemethodInfo(*)]} {
+ # First, remove "*" from the list.
+ set ndx [lsearch -exact $result "*"]
+ if {$ndx != -1} {
+ set result [lreplace $result $ndx $ndx]
+ }
+
+ foreach name [array names Snit_typemethodCache $pattern] {
+ if {[lsearch -exact $result $name] == -1} {
+ lappend result $name
+ }
+ }
+ }
+
+ return $result
+}
+
+# $type info args
+#
+# Returns a method's list of arguments. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.typemethod.info.args {type method} {
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_typemethodInfo
+
+ if {![info exists Snit_typemethodInfo($method)]} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ foreach {flag cmd component} $Snit_typemethodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated typemethod \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [lrange [::info args $theproc] 1 end]
+}
+
+# $type info body
+#
+# Returns a method's body. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.typemethod.info.body {type method} {
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_typemethodInfo
+
+ if {![info exists Snit_typemethodInfo($method)]} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ foreach {flag cmd component} $Snit_typemethodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated typemethod \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [RT.body [::info body $theproc]]
+}
+
+# $type info default
+#
+# Returns a method's list of arguments. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.typemethod.info.default {type method aname dvar} {
+ upvar 1 $dvar def
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_methodInfo
+
+ if {![info exists Snit_typemethodInfo($method)]} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ foreach {flag cmd component} $Snit_typemethodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated typemethod \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [::info default $theproc $aname def]
+}
+
+# Returns a list of the type's instances whose names match
+# a pattern.
+#
+# type A Snit type
+# pattern Optional. The glob pattern to match
+# Defaults to *
+#
+# REQUIRE: type is fully qualified.
+
+proc ::snit::RT.typemethod.info.instances {type {pattern *}} {
+ set result {}
+
+ foreach selfns [namespace children $type] {
+ upvar ${selfns}::Snit_instance instance
+
+ if {[string match $pattern $instance]} {
+ lappend result $instance
+ }
+ }
+
+ return $result
+}
+
+#-----------------------------------------------------------------------
+# Instance Introspection
+
+# Implements the standard "info" method.
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# command The info subcommand
+# args All other arguments.
+
+proc ::snit::RT.method.info {type selfns win self command args} {
+ switch -exact $command {
+ args -
+ body -
+ default -
+ type -
+ vars -
+ options -
+ methods -
+ typevars -
+ typemethods {
+ set errflag [catch {
+ uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \
+ $type $selfns $win $self]
+ } result]
+
+ if {$errflag} {
+ global errorInfo
+ return -code error -errorinfo $errorInfo $result
+ } else {
+ return $result
+ }
+ }
+ default {
+ # error "\"$self info $command\" is not defined"
+ return -code error "\"$self info $command\" is not defined"
+ }
+ }
+}
+
+# $self info type
+#
+# Returns the instance's type
+proc ::snit::RT.method.info.type {type selfns win self} {
+ return $type
+}
+
+# $self info typevars
+#
+# Returns the instance's type's typevariables
+proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} {
+ return [RT.typemethod.info.typevars $type $pattern]
+}
+
+# $self info typemethods
+#
+# Returns the instance's type's typemethods
+proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} {
+ return [RT.typemethod.info.typemethods $type $pattern]
+}
+
+# Returns a list of the instance's methods whose names match a
+# pattern. If "delegate method *" is used, the list may
+# not be complete.
+#
+# type A Snit type
+# selfns The instance namespace
+# win The original instance name
+# self The current instance name
+# pattern Optional. The glob pattern to match. Defaults
+# to *.
+
+proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} {
+ variable ${type}::Snit_methodInfo
+ variable ${selfns}::Snit_methodCache
+
+ # FIRST, get the explicit names, skipping prefixes.
+ set result {}
+
+ foreach name [array names Snit_methodInfo $pattern] {
+ if {[lindex $Snit_methodInfo($name) 0] != 1} {
+ lappend result $name
+ }
+ }
+
+ # NEXT, add any from the cache that aren't explicit.
+ if {[info exists Snit_methodInfo(*)]} {
+ # First, remove "*" from the list.
+ set ndx [lsearch -exact $result "*"]
+ if {$ndx != -1} {
+ set result [lreplace $result $ndx $ndx]
+ }
+
+ foreach name [array names Snit_methodCache $pattern] {
+ if {[lsearch -exact $result $name] == -1} {
+ lappend result $name
+ }
+ }
+ }
+
+ return $result
+}
+
+# $self info args
+#
+# Returns a method's list of arguments. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.method.info.args {type selfns win self method} {
+
+ upvar ${type}::Snit_methodInfo Snit_methodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_methodInfo
+
+ if {![info exists Snit_methodInfo($method)]} {
+ return -code error "Unknown method \"$method\""
+ }
+ foreach {flag cmd component} $Snit_methodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown method \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated method \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [lrange [::info args $theproc] 4 end]
+}
+
+# $self info body
+#
+# Returns a method's body. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.method.info.body {type selfns win self method} {
+
+ upvar ${type}::Snit_methodInfo Snit_methodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_methodInfo
+
+ if {![info exists Snit_methodInfo($method)]} {
+ return -code error "Unknown method \"$method\""
+ }
+ foreach {flag cmd component} $Snit_methodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown method \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated method \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [RT.body [::info body $theproc]]
+}
+
+# $self info default
+#
+# Returns a method's list of arguments. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.method.info.default {type selfns win self method aname dvar} {
+ upvar 1 $dvar def
+ upvar ${type}::Snit_methodInfo Snit_methodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ if {![info exists Snit_methodInfo($method)]} {
+ return -code error "Unknown method \"$method\""
+ }
+ foreach {flag cmd component} $Snit_methodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown method \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated method \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [::info default $theproc $aname def]
+}
+
+# $self info vars
+#
+# Returns the instance's instance variables
+proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} {
+ set result {}
+ foreach name [info vars "${selfns}::$pattern"] {
+ set tail [namespace tail $name]
+ if {![string match "Snit_*" $tail]} {
+ lappend result $name
+ }
+ }
+
+ return $result
+}
+
+# $self info options
+#
+# Returns a list of the names of the instance's options
+proc ::snit::RT.method.info.options {type selfns win self {pattern *}} {
+ variable ${type}::Snit_optionInfo
+
+ # First, get the local and explicitly delegated options
+ set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)]
+
+ # If "configure" works as for Tk widgets, add the resulting
+ # options to the list. Skip excepted options
+ if {"" != $Snit_optionInfo(starcomp)} {
+ upvar ${selfns}::Snit_components Snit_components
+ set logicalName $Snit_optionInfo(starcomp)
+ set comp $Snit_components($logicalName)
+
+ if {![catch {$comp configure} records]} {
+ foreach record $records {
+ set opt [lindex $record 0]
+ if {[lsearch -exact $result $opt] == -1 &&
+ [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
+ lappend result $opt
+ }
+ }
+ }
+ }
+
+ # Next, apply the pattern
+ set names {}
+
+ foreach name $result {
+ if {[string match $pattern $name]} {
+ lappend names $name
+ }
+ }
+
+ return $names
+}
+
+proc ::snit::RT.body {body} {
+ regsub -all ".*# END snit method prolog\n" $body {} body
+ return $body
+}
--- /dev/null
+#-----------------------------------------------------------------------
+# TITLE:
+# main2.tcl
+#
+# AUTHOR:
+# Will Duquette
+#
+# DESCRIPTION:
+# Snit's Not Incr Tcl, a simple object system in Pure Tcl.
+#
+# Snit 2.x Compiler and Run-Time Library
+#
+# Copyright (C) 2003-2006 by William H. Duquette
+# This code is licensed as described in license.txt.
+#
+#-----------------------------------------------------------------------
+
+#-----------------------------------------------------------------------
+# Namespace
+
+namespace eval ::snit:: {
+ namespace export \
+ compile type widget widgetadaptor typemethod method macro
+}
+
+#-----------------------------------------------------------------------
+# Some Snit variables
+
+namespace eval ::snit:: {
+ variable reservedArgs {type selfns win self}
+
+ # Widget classes which can be hulls (must have -class)
+ variable hulltypes {
+ toplevel tk::toplevel
+ frame tk::frame ttk::frame
+ labelframe tk::labelframe ttk::labelframe
+ }
+}
+
+#-----------------------------------------------------------------------
+# Snit Type Implementation template
+
+namespace eval ::snit:: {
+ # Template type definition: All internal and user-visible Snit
+ # implementation code.
+ #
+ # The following placeholders will automatically be replaced with
+ # the client's code, in two passes:
+ #
+ # First pass:
+ # %COMPILEDDEFS% The compiled type definition.
+ #
+ # Second pass:
+ # %TYPE% The fully qualified type name.
+ # %IVARDECS% Instance variable declarations
+ # %TVARDECS% Type variable declarations
+ # %TCONSTBODY% Type constructor body
+ # %INSTANCEVARS% The compiled instance variable initialization code.
+ # %TYPEVARS% The compiled type variable initialization code.
+
+ # This is the overall type template.
+ variable typeTemplate
+
+ # This is the normal type proc
+ variable nominalTypeProc
+
+ # This is the "-hastypemethods no" type proc
+ variable simpleTypeProc
+}
+
+set ::snit::typeTemplate {
+
+ #-------------------------------------------------------------------
+ # The type's namespace definition and the user's type variables
+
+ namespace eval %TYPE% {%TYPEVARS%
+ }
+
+ #----------------------------------------------------------------
+ # Commands for use in methods, typemethods, etc.
+ #
+ # These are implemented as aliases into the Snit runtime library.
+
+ interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE%
+ interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE%
+ interp alias {} %TYPE%::typevariable {} ::variable
+ interp alias {} %TYPE%::variable {} ::snit::RT.variable
+ interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE%
+ interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE%
+ interp alias {} %TYPE%::myvar {} ::snit::RT.myvar
+ interp alias {} %TYPE%::varname {} ::snit::RT.myvar
+ interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE%
+ interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE%
+ interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod
+ interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE%
+ interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE%
+
+ #-------------------------------------------------------------------
+ # Snit's internal variables
+
+ namespace eval %TYPE% {
+ # Array: General Snit Info
+ #
+ # ns: The type's namespace
+ # hasinstances: T or F, from pragma -hasinstances.
+ # simpledispatch: T or F, from pragma -hasinstances.
+ # canreplace: T or F, from pragma -canreplace.
+ # counter: Count of instances created so far.
+ # widgetclass: Set by widgetclass statement.
+ # hulltype: Hull type (frame or toplevel) for widgets only.
+ # exceptmethods: Methods explicitly not delegated to *
+ # excepttypemethods: Methods explicitly not delegated to *
+ # tvardecs: Type variable declarations--for dynamic methods
+ # ivardecs: Instance variable declarations--for dyn. methods
+ typevariable Snit_info
+ set Snit_info(ns) %TYPE%::
+ set Snit_info(hasinstances) 1
+ set Snit_info(simpledispatch) 0
+ set Snit_info(canreplace) 0
+ set Snit_info(counter) 0
+ set Snit_info(widgetclass) {}
+ set Snit_info(hulltype) frame
+ set Snit_info(exceptmethods) {}
+ set Snit_info(excepttypemethods) {}
+ set Snit_info(tvardecs) {%TVARDECS%}
+ set Snit_info(ivardecs) {%IVARDECS%}
+
+ # Array: Public methods of this type.
+ # The index is the method name, or "*".
+ # The value is [list $pattern $componentName], where
+ # $componentName is "" for normal methods.
+ typevariable Snit_typemethodInfo
+ array unset Snit_typemethodInfo
+
+ # Array: Public methods of instances of this type.
+ # The index is the method name, or "*".
+ # The value is [list $pattern $componentName], where
+ # $componentName is "" for normal methods.
+ typevariable Snit_methodInfo
+ array unset Snit_methodInfo
+
+ # Array: option information. See dictionary.txt.
+ typevariable Snit_optionInfo
+ array unset Snit_optionInfo
+ set Snit_optionInfo(local) {}
+ set Snit_optionInfo(delegated) {}
+ set Snit_optionInfo(starcomp) {}
+ set Snit_optionInfo(except) {}
+ }
+
+ #----------------------------------------------------------------
+ # Compiled Procs
+ #
+ # These commands are created or replaced during compilation:
+
+
+ # Snit_instanceVars selfns
+ #
+ # Initializes the instance variables, if any. Called during
+ # instance creation.
+
+ proc %TYPE%::Snit_instanceVars {selfns} {
+ %INSTANCEVARS%
+ }
+
+ # Type Constructor
+ proc %TYPE%::Snit_typeconstructor {type} {
+ %TVARDECS%
+ namespace path [namespace parent $type]
+ %TCONSTBODY%
+ }
+
+ #----------------------------------------------------------------
+ # Default Procs
+ #
+ # These commands might be replaced during compilation:
+
+ # Snit_destructor type selfns win self
+ #
+ # Default destructor for the type. By default, it does
+ # nothing. It's replaced by any user destructor.
+ # For types, it's called by method destroy; for widgettypes,
+ # it's called by a destroy event handler.
+
+ proc %TYPE%::Snit_destructor {type selfns win self} { }
+
+ #----------------------------------------------------------
+ # Compiled Definitions
+
+ %COMPILEDDEFS%
+
+ #----------------------------------------------------------
+ # Finally, call the Type Constructor
+
+ %TYPE%::Snit_typeconstructor %TYPE%
+}
+
+#-----------------------------------------------------------------------
+# Type procs
+#
+# These procs expect the fully-qualified type name to be
+# substituted in for %TYPE%.
+
+# This is the nominal type proc. It supports typemethods and
+# delegated typemethods.
+set ::snit::nominalTypeProc {
+ # WHD: Code for creating the type ensemble
+ namespace eval %TYPE% {
+ namespace ensemble create \
+ -unknown [list ::snit::RT.UnknownTypemethod %TYPE% ""] \
+ -prefixes 0
+ }
+}
+
+# This is the simplified type proc for when there are no typemethods
+# except create. In this case, it doesn't take a method argument;
+# the method is always "create".
+set ::snit::simpleTypeProc {
+ # Type dispatcher function. Note: This function lives
+ # in the parent of the %TYPE% namespace! All accesses to
+ # %TYPE% variables and methods must be qualified!
+ proc %TYPE% {args} {
+ ::variable %TYPE%::Snit_info
+
+ # FIRST, if the are no args, the single arg is %AUTO%
+ if {[llength $args] == 0} {
+ if {$Snit_info(isWidget)} {
+ error "wrong \# args: should be \"%TYPE% name args\""
+ }
+
+ lappend args %AUTO%
+ }
+
+ # NEXT, we're going to call the create method.
+ # Pass along the return code unchanged.
+ if {$Snit_info(isWidget)} {
+ set command [list ::snit::RT.widget.typemethod.create %TYPE%]
+ } else {
+ set command [list ::snit::RT.type.typemethod.create %TYPE%]
+ }
+
+ set retval [catch {uplevel 1 $command $args} result]
+
+ if {$retval} {
+ if {$retval == 1} {
+ global errorInfo
+ global errorCode
+ return -code error -errorinfo $errorInfo \
+ -errorcode $errorCode $result
+ } else {
+ return -code $retval $result
+ }
+ }
+
+ return $result
+ }
+}
+
+#=======================================================================
+# Snit Type Definition
+#
+# These are the procs used to define Snit types, widgets, and
+# widgetadaptors.
+
+
+#-----------------------------------------------------------------------
+# Snit Compilation Variables
+#
+# The following variables are used while Snit is compiling a type,
+# and are disposed afterwards.
+
+namespace eval ::snit:: {
+ # The compiler variable contains the name of the slave interpreter
+ # used to compile type definitions.
+ variable compiler ""
+
+ # The compile array accumulates information about the type or
+ # widgettype being compiled. It is cleared before and after each
+ # compilation. It has these indices:
+ #
+ # type: The name of the type being compiled, for use
+ # in compilation procs.
+ # defs: Compiled definitions, both standard and client.
+ # which: type, widget, widgetadaptor
+ # instancevars: Instance variable definitions and initializations.
+ # ivprocdec: Instance variable proc declarations.
+ # tvprocdec: Type variable proc declarations.
+ # typeconstructor: Type constructor body.
+ # widgetclass: The widgetclass, for snit::widgets, only
+ # hasoptions: False, initially; set to true when first
+ # option is defined.
+ # localoptions: Names of local options.
+ # delegatedoptions: Names of delegated options.
+ # localmethods: Names of locally defined methods.
+ # delegatesmethods: no if no delegated methods, yes otherwise.
+ # hashierarchic : no if no hierarchic methods, yes otherwise.
+ # components: Names of defined components.
+ # typecomponents: Names of defined typecomponents.
+ # typevars: Typevariable definitions and initializations.
+ # varnames: Names of instance variables
+ # typevarnames Names of type variables
+ # hasconstructor False, initially; true when constructor is
+ # defined.
+ # resource-$opt The option's resource name
+ # class-$opt The option's class
+ # -default-$opt The option's default value
+ # -validatemethod-$opt The option's validate method
+ # -configuremethod-$opt The option's configure method
+ # -cgetmethod-$opt The option's cget method.
+ # -hastypeinfo The -hastypeinfo pragma
+ # -hastypedestroy The -hastypedestroy pragma
+ # -hastypemethods The -hastypemethods pragma
+ # -hasinfo The -hasinfo pragma
+ # -hasinstances The -hasinstances pragma
+ # -simpledispatch The -simpledispatch pragma WHD: OBSOLETE
+ # -canreplace The -canreplace pragma
+ variable compile
+
+ # This variable accumulates method dispatch information; it has
+ # the same structure as the %TYPE%::Snit_methodInfo array, and is
+ # used to initialize it.
+ variable methodInfo
+
+ # This variable accumulates typemethod dispatch information; it has
+ # the same structure as the %TYPE%::Snit_typemethodInfo array, and is
+ # used to initialize it.
+ variable typemethodInfo
+
+ # The following variable lists the reserved type definition statement
+ # names, e.g., the names you can't use as macros. It's built at
+ # compiler definition time using "info commands".
+ variable reservedwords {}
+}
+
+#-----------------------------------------------------------------------
+# type compilation commands
+#
+# The type and widgettype commands use a slave interpreter to compile
+# the type definition. These are the procs
+# that are aliased into it.
+
+# Initialize the compiler
+proc ::snit::Comp.Init {} {
+ variable compiler
+ variable reservedwords
+
+ if {$compiler eq ""} {
+ # Create the compiler's interpreter
+ set compiler [interp create]
+
+ # Initialize the interpreter
+ $compiler eval {
+ catch {close stdout}
+ catch {close stderr}
+ catch {close stdin}
+
+ # Load package information
+ # TBD: see if this can be moved outside.
+ # @mdgen NODEP: ::snit::__does_not_exist__
+ catch {package require ::snit::__does_not_exist__}
+
+ # Protect some Tcl commands our type definitions
+ # will shadow.
+ rename proc _proc
+ rename variable _variable
+ }
+
+ # Define compilation aliases.
+ $compiler alias pragma ::snit::Comp.statement.pragma
+ $compiler alias widgetclass ::snit::Comp.statement.widgetclass
+ $compiler alias hulltype ::snit::Comp.statement.hulltype
+ $compiler alias constructor ::snit::Comp.statement.constructor
+ $compiler alias destructor ::snit::Comp.statement.destructor
+ $compiler alias option ::snit::Comp.statement.option
+ $compiler alias oncget ::snit::Comp.statement.oncget
+ $compiler alias onconfigure ::snit::Comp.statement.onconfigure
+ $compiler alias method ::snit::Comp.statement.method
+ $compiler alias typemethod ::snit::Comp.statement.typemethod
+ $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor
+ $compiler alias proc ::snit::Comp.statement.proc
+ $compiler alias typevariable ::snit::Comp.statement.typevariable
+ $compiler alias variable ::snit::Comp.statement.variable
+ $compiler alias typecomponent ::snit::Comp.statement.typecomponent
+ $compiler alias component ::snit::Comp.statement.component
+ $compiler alias delegate ::snit::Comp.statement.delegate
+ $compiler alias expose ::snit::Comp.statement.expose
+
+ # Get the list of reserved words
+ set reservedwords [$compiler eval {info commands}]
+ }
+}
+
+# Compile a type definition, and return the results as a list of two
+# items: the fully-qualified type name, and a script that will define
+# the type when executed.
+#
+# which type, widget, or widgetadaptor
+# type the type name
+# body the type definition
+proc ::snit::Comp.Compile {which type body} {
+ variable typeTemplate
+ variable nominalTypeProc
+ variable simpleTypeProc
+ variable compile
+ variable compiler
+ variable methodInfo
+ variable typemethodInfo
+
+ # FIRST, qualify the name.
+ if {![string match "::*" $type]} {
+ # Get caller's namespace;
+ # append :: if not global namespace.
+ set ns [uplevel 2 [list namespace current]]
+ if {"::" != $ns} {
+ append ns "::"
+ }
+
+ set type "$ns$type"
+ }
+
+ # NEXT, create and initialize the compiler, if needed.
+ Comp.Init
+
+ # NEXT, initialize the class data
+ array unset methodInfo
+ array unset typemethodInfo
+
+ array unset compile
+ set compile(type) $type
+ set compile(defs) {}
+ set compile(which) $which
+ set compile(hasoptions) no
+ set compile(localoptions) {}
+ set compile(instancevars) {}
+ set compile(typevars) {}
+ set compile(delegatedoptions) {}
+ set compile(ivprocdec) {}
+ set compile(tvprocdec) {}
+ set compile(typeconstructor) {}
+ set compile(widgetclass) {}
+ set compile(hulltype) {}
+ set compile(localmethods) {}
+ set compile(delegatesmethods) no
+ set compile(hashierarchic) no
+ set compile(components) {}
+ set compile(typecomponents) {}
+ set compile(varnames) {}
+ set compile(typevarnames) {}
+ set compile(hasconstructor) no
+ set compile(-hastypedestroy) yes
+ set compile(-hastypeinfo) yes
+ set compile(-hastypemethods) yes
+ set compile(-hasinfo) yes
+ set compile(-hasinstances) yes
+ set compile(-canreplace) no
+
+ set isWidget [string match widget* $which]
+ set isWidgetAdaptor [string match widgetadaptor $which]
+
+ # NEXT, Evaluate the type's definition in the class interpreter.
+ $compiler eval $body
+
+ # NEXT, Add the standard definitions
+ append compile(defs) \
+ "\nset %TYPE%::Snit_info(isWidget) $isWidget\n"
+
+ append compile(defs) \
+ "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n"
+
+ # Indicate whether the type can create instances that replace
+ # existing commands.
+ append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n"
+
+
+ # Check pragmas for conflict.
+
+ if {!$compile(-hastypemethods) && !$compile(-hasinstances)} {
+ error "$which $type has neither typemethods nor instances"
+ }
+
+ # If there are typemethods, define the standard typemethods and
+ # the nominal type proc. Otherwise define the simple type proc.
+ if {$compile(-hastypemethods)} {
+ # Add the info typemethod unless the pragma forbids it.
+ if {$compile(-hastypeinfo)} {
+ Comp.statement.delegate typemethod info \
+ using {::snit::RT.typemethod.info %t}
+ }
+
+ # Add the destroy typemethod unless the pragma forbids it.
+ if {$compile(-hastypedestroy)} {
+ Comp.statement.delegate typemethod destroy \
+ using {::snit::RT.typemethod.destroy %t}
+ }
+
+ # Add the nominal type proc.
+ append compile(defs) $nominalTypeProc
+ } else {
+ # Add the simple type proc.
+ append compile(defs) $simpleTypeProc
+ }
+
+ # Add standard methods/typemethods that only make sense if the
+ # type has instances.
+ if {$compile(-hasinstances)} {
+ # Add the info method unless the pragma forbids it.
+ if {$compile(-hasinfo)} {
+ Comp.statement.delegate method info \
+ using {::snit::RT.method.info %t %n %w %s}
+ }
+
+ # Add the option handling stuff if there are any options.
+ if {$compile(hasoptions)} {
+ Comp.statement.variable options
+
+ Comp.statement.delegate method cget \
+ using {::snit::RT.method.cget %t %n %w %s}
+ Comp.statement.delegate method configurelist \
+ using {::snit::RT.method.configurelist %t %n %w %s}
+ Comp.statement.delegate method configure \
+ using {::snit::RT.method.configure %t %n %w %s}
+ }
+
+ # Add a default constructor, if they haven't already defined one.
+ # If there are options, it will configure args; otherwise it
+ # will do nothing.
+ if {!$compile(hasconstructor)} {
+ if {$compile(hasoptions)} {
+ Comp.statement.constructor {args} {
+ $self configurelist $args
+ }
+ } else {
+ Comp.statement.constructor {} {}
+ }
+ }
+
+ if {!$isWidget} {
+ Comp.statement.delegate method destroy \
+ using {::snit::RT.method.destroy %t %n %w %s}
+
+ Comp.statement.delegate typemethod create \
+ using {::snit::RT.type.typemethod.create %t}
+ } else {
+ Comp.statement.delegate typemethod create \
+ using {::snit::RT.widget.typemethod.create %t}
+ }
+
+ # Save the method info.
+ append compile(defs) \
+ "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n"
+ } else {
+ append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n"
+ }
+
+ # NEXT, compiling the type definition built up a set of information
+ # about the type's locally defined options; add this information to
+ # the compiled definition.
+ Comp.SaveOptionInfo
+
+ # NEXT, compiling the type definition built up a set of information
+ # about the typemethods; save the typemethod info.
+ append compile(defs) \
+ "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n"
+
+ # NEXT, if this is a widget define the hull component if it isn't
+ # already defined.
+ if {$isWidget} {
+ Comp.DefineComponent hull
+ }
+
+ # NEXT, substitute the compiled definition into the type template
+ # to get the type definition script.
+ set defscript [Expand $typeTemplate \
+ %COMPILEDDEFS% $compile(defs)]
+
+ # NEXT, substitute the defined macros into the type definition script.
+ # This is done as a separate step so that the compile(defs) can
+ # contain the macros defined below.
+
+ set defscript [Expand $defscript \
+ %TYPE% $type \
+ %IVARDECS% $compile(ivprocdec) \
+ %TVARDECS% $compile(tvprocdec) \
+ %TCONSTBODY% $compile(typeconstructor) \
+ %INSTANCEVARS% $compile(instancevars) \
+ %TYPEVARS% $compile(typevars) \
+ ]
+
+ array unset compile
+
+ return [list $type $defscript]
+}
+
+# Information about locally-defined options is accumulated during
+# compilation, but not added to the compiled definition--the option
+# statement can appear multiple times, so it's easier this way.
+# This proc fills in Snit_optionInfo with the accumulated information.
+#
+# It also computes the option's resource and class names if needed.
+#
+# Note that the information for delegated options was put in
+# Snit_optionInfo during compilation.
+
+proc ::snit::Comp.SaveOptionInfo {} {
+ variable compile
+
+ foreach option $compile(localoptions) {
+ if {$compile(resource-$option) eq ""} {
+ set compile(resource-$option) [string range $option 1 end]
+ }
+
+ if {$compile(class-$option) eq ""} {
+ set compile(class-$option) [Capitalize $compile(resource-$option)]
+ }
+
+ # NOTE: Don't verify that the validate, configure, and cget
+ # values name real methods; the methods might be defined outside
+ # the typedefinition using snit::method.
+
+ Mappend compile(defs) {
+ # Option %OPTION%
+ lappend %TYPE%::Snit_optionInfo(local) %OPTION%
+
+ set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1
+ set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE%
+ set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
+ set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT%
+ set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE%
+ set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE%
+ set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET%
+ set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY%
+ set %TYPE%::Snit_optionInfo(typespec-%OPTION%) %TYPESPEC%
+ } %OPTION% $option \
+ %RESOURCE% $compile(resource-$option) \
+ %CLASS% $compile(class-$option) \
+ %DEFAULT% [list $compile(-default-$option)] \
+ %VALIDATE% [list $compile(-validatemethod-$option)] \
+ %CONFIGURE% [list $compile(-configuremethod-$option)] \
+ %CGET% [list $compile(-cgetmethod-$option)] \
+ %READONLY% $compile(-readonly-$option) \
+ %TYPESPEC% [list $compile(-type-$option)]
+ }
+}
+
+
+# Evaluates a compiled type definition, thus making the type available.
+proc ::snit::Comp.Define {compResult} {
+ # The compilation result is a list containing the fully qualified
+ # type name and a script to evaluate to define the type.
+ set type [lindex $compResult 0]
+ set defscript [lindex $compResult 1]
+
+ # Execute the type definition script.
+ # Consider using namespace eval %TYPE%. See if it's faster.
+ if {[catch {eval $defscript} result]} {
+ namespace delete $type
+ catch {rename $type ""}
+ error $result
+ }
+
+ return $type
+}
+
+# Sets pragma options which control how the type is defined.
+proc ::snit::Comp.statement.pragma {args} {
+ variable compile
+
+ set errRoot "Error in \"pragma...\""
+
+ foreach {opt val} $args {
+ switch -exact -- $opt {
+ -hastypeinfo -
+ -hastypedestroy -
+ -hastypemethods -
+ -hasinstances -
+ -simpledispatch -
+ -hasinfo -
+ -canreplace {
+ if {![string is boolean -strict $val]} {
+ error "$errRoot, \"$opt\" requires a boolean value"
+ }
+ set compile($opt) $val
+ }
+ default {
+ error "$errRoot, unknown pragma"
+ }
+ }
+ }
+}
+
+# Defines a widget's option class name.
+# This statement is only available for snit::widgets,
+# not for snit::types or snit::widgetadaptors.
+proc ::snit::Comp.statement.widgetclass {name} {
+ variable compile
+
+ # First, widgetclass can only be set for true widgets
+ if {"widget" != $compile(which)} {
+ error "widgetclass cannot be set for snit::$compile(which)s"
+ }
+
+ # Next, validate the option name. We'll require that it begin
+ # with an uppercase letter.
+ set initial [string index $name 0]
+ if {![string is upper $initial]} {
+ error "widgetclass \"$name\" does not begin with an uppercase letter"
+ }
+
+ if {"" != $compile(widgetclass)} {
+ error "too many widgetclass statements"
+ }
+
+ # Next, save it.
+ Mappend compile(defs) {
+ set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS%
+ } %WIDGETCLASS% [list $name]
+
+ set compile(widgetclass) $name
+}
+
+# Defines a widget's hull type.
+# This statement is only available for snit::widgets,
+# not for snit::types or snit::widgetadaptors.
+proc ::snit::Comp.statement.hulltype {name} {
+ variable compile
+ variable hulltypes
+
+ # First, hulltype can only be set for true widgets
+ if {"widget" != $compile(which)} {
+ error "hulltype cannot be set for snit::$compile(which)s"
+ }
+
+ # Next, it must be one of the valid hulltypes (frame, toplevel, ...)
+ if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} {
+ error "invalid hulltype \"$name\", should be one of\
+ [join $hulltypes {, }]"
+ }
+
+ if {"" != $compile(hulltype)} {
+ error "too many hulltype statements"
+ }
+
+ # Next, save it.
+ Mappend compile(defs) {
+ set %TYPE%::Snit_info(hulltype) %HULLTYPE%
+ } %HULLTYPE% $name
+
+ set compile(hulltype) $name
+}
+
+# Defines a constructor.
+proc ::snit::Comp.statement.constructor {arglist body} {
+ variable compile
+
+ CheckArgs "constructor" $arglist
+
+ # Next, add a magic reference to self.
+ set arglist [concat type selfns win self $arglist]
+
+ # Next, add variable declarations to body:
+ set body "%TVARDECS%\n%IVARDECS%\n$body"
+
+ set compile(hasconstructor) yes
+ append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n"
+}
+
+# Defines a destructor.
+proc ::snit::Comp.statement.destructor {body} {
+ variable compile
+
+ # Next, add variable declarations to body:
+ set body "%TVARDECS%\n%IVARDECS%\n$body"
+
+ append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n"
+}
+
+# Defines a type option. The option value can be a triple, specifying
+# the option's -name, resource name, and class name.
+proc ::snit::Comp.statement.option {optionDef args} {
+ variable compile
+
+ # First, get the three option names.
+ set option [lindex $optionDef 0]
+ set resourceName [lindex $optionDef 1]
+ set className [lindex $optionDef 2]
+
+ set errRoot "Error in \"option [list $optionDef]...\""
+
+ # Next, validate the option name.
+ if {![Comp.OptionNameIsValid $option]} {
+ error "$errRoot, badly named option \"$option\""
+ }
+
+ if {$option in $compile(delegatedoptions)} {
+ error "$errRoot, cannot define \"$option\" locally, it has been delegated"
+ }
+
+ if {!($option in $compile(localoptions))} {
+ # Remember that we've seen this one.
+ set compile(hasoptions) yes
+ lappend compile(localoptions) $option
+
+ # Initialize compilation info for this option.
+ set compile(resource-$option) ""
+ set compile(class-$option) ""
+ set compile(-default-$option) ""
+ set compile(-validatemethod-$option) ""
+ set compile(-configuremethod-$option) ""
+ set compile(-cgetmethod-$option) ""
+ set compile(-readonly-$option) 0
+ set compile(-type-$option) ""
+ }
+
+ # NEXT, see if we have a resource name. If so, make sure it
+ # isn't being redefined differently.
+ if {$resourceName ne ""} {
+ if {$compile(resource-$option) eq ""} {
+ # If it's undefined, just save the value.
+ set compile(resource-$option) $resourceName
+ } elseif {$resourceName ne $compile(resource-$option)} {
+ # It's been redefined differently.
+ error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\""
+ }
+ }
+
+ # NEXT, see if we have a class name. If so, make sure it
+ # isn't being redefined differently.
+ if {$className ne ""} {
+ if {$compile(class-$option) eq ""} {
+ # If it's undefined, just save the value.
+ set compile(class-$option) $className
+ } elseif {$className ne $compile(class-$option)} {
+ # It's been redefined differently.
+ error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\""
+ }
+ }
+
+ # NEXT, handle the args; it's not an error to redefine these.
+ if {[llength $args] == 1} {
+ set compile(-default-$option) [lindex $args 0]
+ } else {
+ foreach {optopt val} $args {
+ switch -exact -- $optopt {
+ -default -
+ -validatemethod -
+ -configuremethod -
+ -cgetmethod {
+ set compile($optopt-$option) $val
+ }
+ -type {
+ set compile($optopt-$option) $val
+
+ if {[llength $val] == 1} {
+ # The type spec *is* the validation object
+ append compile(defs) \
+ "\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n"
+ } else {
+ # Compilation the creation of the validation object
+ set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%]
+ append compile(defs) \
+ "\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n"
+ }
+ }
+ -readonly {
+ if {![string is boolean -strict $val]} {
+ error "$errRoot, -readonly requires a boolean, got \"$val\""
+ }
+ set compile($optopt-$option) $val
+ }
+ default {
+ error "$errRoot, unknown option definition option \"$optopt\""
+ }
+ }
+ }
+ }
+}
+
+# 1 if the option name is valid, 0 otherwise.
+proc ::snit::Comp.OptionNameIsValid {option} {
+ if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} {
+ return 0
+ }
+
+ return 1
+}
+
+# Defines an option's cget handler
+proc ::snit::Comp.statement.oncget {option body} {
+ variable compile
+
+ set errRoot "Error in \"oncget $option...\""
+
+ if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
+ return -code error "$errRoot, option \"$option\" is delegated"
+ }
+
+ if {[lsearch -exact $compile(localoptions) $option] == -1} {
+ return -code error "$errRoot, option \"$option\" unknown"
+ }
+
+ Comp.statement.method _cget$option {_option} $body
+ Comp.statement.option $option -cgetmethod _cget$option
+}
+
+# Defines an option's configure handler.
+proc ::snit::Comp.statement.onconfigure {option arglist body} {
+ variable compile
+
+ if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
+ return -code error "onconfigure $option: option \"$option\" is delegated"
+ }
+
+ if {[lsearch -exact $compile(localoptions) $option] == -1} {
+ return -code error "onconfigure $option: option \"$option\" unknown"
+ }
+
+ if {[llength $arglist] != 1} {
+ error \
+ "onconfigure $option handler should have one argument, got \"$arglist\""
+ }
+
+ CheckArgs "onconfigure $option" $arglist
+
+ # Next, add a magic reference to the option name
+ set arglist [concat _option $arglist]
+
+ Comp.statement.method _configure$option $arglist $body
+ Comp.statement.option $option -configuremethod _configure$option
+}
+
+# Defines an instance method.
+proc ::snit::Comp.statement.method {method arglist body} {
+ variable compile
+ variable methodInfo
+
+ # FIRST, check the method name against previously defined
+ # methods.
+ Comp.CheckMethodName $method 0 ::snit::methodInfo \
+ "Error in \"method [list $method]...\""
+
+ if {[llength $method] > 1} {
+ set compile(hashierarchic) yes
+ }
+
+ # Remeber this method
+ lappend compile(localmethods) $method
+
+ CheckArgs "method [list $method]" $arglist
+
+ # Next, add magic references to type and self.
+ set arglist [concat type selfns win self $arglist]
+
+ # Next, add variable declarations to body:
+ set body "%TVARDECS%\n%IVARDECS%\n# END snit method prolog\n$body"
+
+ # Next, save the definition script.
+ if {[llength $method] == 1} {
+ set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
+ Mappend compile(defs) {
+ proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY%
+ } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
+ } else {
+ set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
+
+ Mappend compile(defs) {
+ proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY%
+ } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \
+ %BODY% [list $body]
+ }
+}
+
+# Check for name collisions; save prefix information.
+#
+# method The name of the method or typemethod.
+# delFlag 1 if delegated, 0 otherwise.
+# infoVar The fully qualified name of the array containing
+# information about the defined methods.
+# errRoot The root string for any error messages.
+
+proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} {
+ upvar $infoVar methodInfo
+
+ # FIRST, make sure the method name is a valid Tcl list.
+ if {[catch {lindex $method 0}]} {
+ error "$errRoot, the name \"$method\" must have list syntax."
+ }
+
+ # NEXT, check whether we can define it.
+ if {![catch {set methodInfo($method)} data]} {
+ # We can't redefine methods with submethods.
+ if {[lindex $data 0] == 1} {
+ error "$errRoot, \"$method\" has submethods."
+ }
+
+ # You can't delegate a method that's defined locally,
+ # and you can't define a method locally if it's been delegated.
+ if {$delFlag && [lindex $data 2] eq ""} {
+ error "$errRoot, \"$method\" has been defined locally."
+ } elseif {!$delFlag && [lindex $data 2] ne ""} {
+ error "$errRoot, \"$method\" has been delegated"
+ }
+ }
+
+ # Handle hierarchical case.
+ if {[llength $method] > 1} {
+ set prefix {}
+ set tokens $method
+ while {[llength $tokens] > 1} {
+ lappend prefix [lindex $tokens 0]
+ set tokens [lrange $tokens 1 end]
+
+ if {![catch {set methodInfo($prefix)} result]} {
+ # Prefix is known. If it's not a prefix, throw an
+ # error.
+ if {[lindex $result 0] == 0} {
+ error "$errRoot, \"$prefix\" has no submethods."
+ }
+ }
+
+ set methodInfo($prefix) [list 1]
+ }
+ }
+}
+
+# Defines a typemethod method.
+proc ::snit::Comp.statement.typemethod {method arglist body} {
+ variable compile
+ variable typemethodInfo
+
+ # FIRST, check the typemethod name against previously defined
+ # typemethods.
+ Comp.CheckMethodName $method 0 ::snit::typemethodInfo \
+ "Error in \"typemethod [list $method]...\""
+
+ CheckArgs "typemethod $method" $arglist
+
+ # First, add magic reference to type.
+ set arglist [concat type $arglist]
+
+ # Next, add typevariable declarations to body:
+ set body "%TVARDECS%\n# END snit method prolog\n$body"
+
+ # Next, save the definition script
+ if {[llength $method] == 1} {
+ set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
+
+ Mappend compile(defs) {
+ proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY%
+ } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
+ } else {
+ set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
+
+ Mappend compile(defs) {
+ proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY%
+ } %JMETHOD% [join $method _] \
+ %ARGLIST% [list $arglist] %BODY% [list $body]
+ }
+}
+
+
+# Defines a type constructor.
+proc ::snit::Comp.statement.typeconstructor {body} {
+ variable compile
+
+ if {"" != $compile(typeconstructor)} {
+ error "too many typeconstructors"
+ }
+
+ set compile(typeconstructor) $body
+}
+
+# Defines a static proc in the type's namespace.
+proc ::snit::Comp.statement.proc {proc arglist body} {
+ variable compile
+
+ # If "ns" is defined, the proc can see instance variables.
+ if {[lsearch -exact $arglist selfns] != -1} {
+ # Next, add instance variable declarations to body:
+ set body "%IVARDECS%\n$body"
+ }
+
+ # The proc can always see typevariables.
+ set body "%TVARDECS%\n$body"
+
+ append compile(defs) "
+
+ # Proc $proc
+ proc [list %TYPE%::$proc $arglist $body]
+ "
+}
+
+# Defines a static variable in the type's namespace.
+proc ::snit::Comp.statement.typevariable {name args} {
+ variable compile
+
+ set errRoot "Error in \"typevariable $name...\""
+
+ set len [llength $args]
+
+ if {$len > 2 ||
+ ($len == 2 && [lindex $args 0] ne "-array")} {
+ error "$errRoot, too many initializers"
+ }
+
+ if {[lsearch -exact $compile(varnames) $name] != -1} {
+ error "$errRoot, \"$name\" is already an instance variable"
+ }
+
+ lappend compile(typevarnames) $name
+
+ if {$len == 1} {
+ append compile(typevars) \
+ "\n\t [list ::variable $name [lindex $args 0]]"
+ } elseif {$len == 2} {
+ append compile(typevars) \
+ "\n\t [list ::variable $name]"
+ append compile(typevars) \
+ "\n\t [list array set $name [lindex $args 1]]"
+ } else {
+ append compile(typevars) \
+ "\n\t [list ::variable $name]"
+ }
+
+ if {$compile(tvprocdec) eq ""} {
+ set compile(tvprocdec) "\n\t"
+ append compile(tvprocdec) "namespace upvar [list $compile(type)]"
+ }
+ append compile(tvprocdec) " [list $name $name]"
+}
+
+# Defines an instance variable; the definition will go in the
+# type's create typemethod.
+proc ::snit::Comp.statement.variable {name args} {
+ variable compile
+
+ set errRoot "Error in \"variable $name...\""
+
+ set len [llength $args]
+
+ if {$len > 2 ||
+ ($len == 2 && [lindex $args 0] ne "-array")} {
+ error "$errRoot, too many initializers"
+ }
+
+ if {[lsearch -exact $compile(typevarnames) $name] != -1} {
+ error "$errRoot, \"$name\" is already a typevariable"
+ }
+
+ lappend compile(varnames) $name
+
+ # Add a ::variable to instancevars, so that ::variable is used
+ # at least once; ::variable makes the variable visible to
+ # [info vars] even if no value is assigned.
+ append compile(instancevars) "\n"
+ Mappend compile(instancevars) {::variable ${selfns}::%N} %N $name
+
+ if {$len == 1} {
+ append compile(instancevars) \
+ "\nset $name [list [lindex $args 0]]\n"
+ } elseif {$len == 2} {
+ append compile(instancevars) \
+ "\narray set $name [list [lindex $args 1]]\n"
+ }
+
+ if {$compile(ivprocdec) eq ""} {
+ set compile(ivprocdec) "\n\t"
+ append compile(ivprocdec) {namespace upvar $selfns}
+ }
+ append compile(ivprocdec) " [list $name $name]"
+}
+
+# Defines a typecomponent, and handles component options.
+#
+# component The logical name of the delegate
+# args options.
+
+proc ::snit::Comp.statement.typecomponent {component args} {
+ variable compile
+
+ set errRoot "Error in \"typecomponent $component...\""
+
+ # FIRST, define the component
+ Comp.DefineTypecomponent $component $errRoot
+
+ # NEXT, handle the options.
+ set publicMethod ""
+ set inheritFlag 0
+
+ foreach {opt val} $args {
+ switch -exact -- $opt {
+ -public {
+ set publicMethod $val
+ }
+ -inherit {
+ set inheritFlag $val
+ if {![string is boolean $inheritFlag]} {
+ error "typecomponent $component -inherit: expected boolean value, got \"$val\""
+ }
+ }
+ default {
+ error "typecomponent $component: Invalid option \"$opt\""
+ }
+ }
+ }
+
+ # NEXT, if -public specified, define the method.
+ if {$publicMethod ne ""} {
+ Comp.statement.delegate typemethod [list $publicMethod *] to $component
+ }
+
+ # NEXT, if "-inherit 1" is specified, delegate typemethod * to
+ # this component.
+ if {$inheritFlag} {
+ Comp.statement.delegate typemethod "*" to $component
+ }
+
+}
+
+
+# Defines a name to be a typecomponent
+#
+# The name becomes a typevariable; in addition, it gets a
+# write trace so that when it is set, all of the component mechanisms
+# get updated.
+#
+# component The component name
+
+proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} {
+ variable compile
+
+ if {[lsearch -exact $compile(varnames) $component] != -1} {
+ error "$errRoot, \"$component\" is already an instance variable"
+ }
+
+ if {[lsearch -exact $compile(typecomponents) $component] == -1} {
+ # Remember we've done this.
+ lappend compile(typecomponents) $component
+
+ # Make it a type variable with no initial value
+ Comp.statement.typevariable $component ""
+
+ # Add a write trace to do the component thing.
+ Mappend compile(typevars) {
+ trace add variable %COMP% write \
+ [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%]
+ } %TYPE% $compile(type) %COMP% $component
+ }
+}
+
+# Defines a component, and handles component options.
+#
+# component The logical name of the delegate
+# args options.
+#
+# TBD: Ideally, it should be possible to call this statement multiple
+# times, possibly changing the option values. To do that, I'd need
+# to cache the option values and not act on them until *after* I'd
+# read the entire type definition.
+
+proc ::snit::Comp.statement.component {component args} {
+ variable compile
+
+ set errRoot "Error in \"component $component...\""
+
+ # FIRST, define the component
+ Comp.DefineComponent $component $errRoot
+
+ # NEXT, handle the options.
+ set publicMethod ""
+ set inheritFlag 0
+
+ foreach {opt val} $args {
+ switch -exact -- $opt {
+ -public {
+ set publicMethod $val
+ }
+ -inherit {
+ set inheritFlag $val
+ if {![string is boolean $inheritFlag]} {
+ error "component $component -inherit: expected boolean value, got \"$val\""
+ }
+ }
+ default {
+ error "component $component: Invalid option \"$opt\""
+ }
+ }
+ }
+
+ # NEXT, if -public specified, define the method.
+ if {$publicMethod ne ""} {
+ Comp.statement.delegate method [list $publicMethod *] to $component
+ }
+
+ # NEXT, if -inherit is specified, delegate method/option * to
+ # this component.
+ if {$inheritFlag} {
+ Comp.statement.delegate method "*" to $component
+ Comp.statement.delegate option "*" to $component
+ }
+}
+
+
+# Defines a name to be a component
+#
+# The name becomes an instance variable; in addition, it gets a
+# write trace so that when it is set, all of the component mechanisms
+# get updated.
+#
+# component The component name
+
+proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} {
+ variable compile
+
+ if {[lsearch -exact $compile(typevarnames) $component] != -1} {
+ error "$errRoot, \"$component\" is already a typevariable"
+ }
+
+ if {[lsearch -exact $compile(components) $component] == -1} {
+ # Remember we've done this.
+ lappend compile(components) $component
+
+ # Make it an instance variable with no initial value
+ Comp.statement.variable $component ""
+
+ # Add a write trace to do the component thing.
+ Mappend compile(instancevars) {
+ trace add variable ${selfns}::%COMP% write \
+ [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%]
+ } %TYPE% $compile(type) %COMP% $component
+ }
+}
+
+# Creates a delegated method, typemethod, or option.
+proc ::snit::Comp.statement.delegate {what name args} {
+ # FIRST, dispatch to correct handler.
+ switch $what {
+ typemethod { Comp.DelegatedTypemethod $name $args }
+ method { Comp.DelegatedMethod $name $args }
+ option { Comp.DelegatedOption $name $args }
+ default {
+ error "Error in \"delegate $what $name...\", \"$what\"?"
+ }
+ }
+
+ if {([llength $args] % 2) != 0} {
+ error "Error in \"delegate $what $name...\", invalid syntax"
+ }
+}
+
+# Creates a delegated typemethod delegating it to a particular
+# typecomponent or an arbitrary command.
+#
+# method The name of the method
+# arglist Delegation options
+
+proc ::snit::Comp.DelegatedTypemethod {method arglist} {
+ variable compile
+ variable typemethodInfo
+
+ set errRoot "Error in \"delegate typemethod [list $method]...\""
+
+ # Next, parse the delegation options.
+ set component ""
+ set target ""
+ set exceptions {}
+ set pattern ""
+ set methodTail [lindex $method end]
+
+ foreach {opt value} $arglist {
+ switch -exact $opt {
+ to { set component $value }
+ as { set target $value }
+ except { set exceptions $value }
+ using { set pattern $value }
+ default {
+ error "$errRoot, unknown delegation option \"$opt\""
+ }
+ }
+ }
+
+ if {$component eq "" && $pattern eq ""} {
+ error "$errRoot, missing \"to\""
+ }
+
+ if {$methodTail eq "*" && $target ne ""} {
+ error "$errRoot, cannot specify \"as\" with \"*\""
+ }
+
+ if {$methodTail ne "*" && $exceptions ne ""} {
+ error "$errRoot, can only specify \"except\" with \"*\""
+ }
+
+ if {$pattern ne "" && $target ne ""} {
+ error "$errRoot, cannot specify both \"as\" and \"using\""
+ }
+
+ foreach token [lrange $method 1 end-1] {
+ if {$token eq "*"} {
+ error "$errRoot, \"*\" must be the last token."
+ }
+ }
+
+ # NEXT, define the component
+ if {$component ne ""} {
+ Comp.DefineTypecomponent $component $errRoot
+ }
+
+ # NEXT, define the pattern.
+ if {$pattern eq ""} {
+ if {$methodTail eq "*"} {
+ set pattern "%c %m"
+ } elseif {$target ne ""} {
+ set pattern "%c $target"
+ } else {
+ set pattern "%c %m"
+ }
+ }
+
+ # Make sure the pattern is a valid list.
+ if {[catch {lindex $pattern 0} result]} {
+ error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
+ }
+
+ # NEXT, check the method name against previously defined
+ # methods.
+ Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot
+
+ set typemethodInfo($method) [list 0 $pattern $component]
+
+ if {[string equal $methodTail "*"]} {
+ Mappend compile(defs) {
+ set %TYPE%::Snit_info(excepttypemethods) %EXCEPT%
+ } %EXCEPT% [list $exceptions]
+ }
+}
+
+
+# Creates a delegated method delegating it to a particular
+# component or command.
+#
+# method The name of the method
+# arglist Delegation options.
+
+proc ::snit::Comp.DelegatedMethod {method arglist} {
+ variable compile
+ variable methodInfo
+
+ set errRoot "Error in \"delegate method [list $method]...\""
+
+ # Next, parse the delegation options.
+ set component ""
+ set target ""
+ set exceptions {}
+ set pattern ""
+ set methodTail [lindex $method end]
+
+ foreach {opt value} $arglist {
+ switch -exact $opt {
+ to { set component $value }
+ as { set target $value }
+ except { set exceptions $value }
+ using { set pattern $value }
+ default {
+ error "$errRoot, unknown delegation option \"$opt\""
+ }
+ }
+ }
+
+ if {$component eq "" && $pattern eq ""} {
+ error "$errRoot, missing \"to\""
+ }
+
+ if {$methodTail eq "*" && $target ne ""} {
+ error "$errRoot, cannot specify \"as\" with \"*\""
+ }
+
+ if {$methodTail ne "*" && $exceptions ne ""} {
+ error "$errRoot, can only specify \"except\" with \"*\""
+ }
+
+ if {$pattern ne "" && $target ne ""} {
+ error "$errRoot, cannot specify both \"as\" and \"using\""
+ }
+
+ foreach token [lrange $method 1 end-1] {
+ if {$token eq "*"} {
+ error "$errRoot, \"*\" must be the last token."
+ }
+ }
+
+ # NEXT, we delegate some methods
+ set compile(delegatesmethods) yes
+
+ # NEXT, define the component. Allow typecomponents.
+ if {$component ne ""} {
+ if {[lsearch -exact $compile(typecomponents) $component] == -1} {
+ Comp.DefineComponent $component $errRoot
+ }
+ }
+
+ # NEXT, define the pattern.
+ if {$pattern eq ""} {
+ if {$methodTail eq "*"} {
+ set pattern "%c %m"
+ } elseif {$target ne ""} {
+ set pattern "%c $target"
+ } else {
+ set pattern "%c %m"
+ }
+ }
+
+ # Make sure the pattern is a valid list.
+ if {[catch {lindex $pattern 0} result]} {
+ error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
+ }
+
+ # NEXT, check the method name against previously defined
+ # methods.
+ Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot
+
+ # NEXT, save the method info.
+ set methodInfo($method) [list 0 $pattern $component]
+
+ if {[string equal $methodTail "*"]} {
+ Mappend compile(defs) {
+ set %TYPE%::Snit_info(exceptmethods) %EXCEPT%
+ } %EXCEPT% [list $exceptions]
+ }
+}
+
+# Creates a delegated option, delegating it to a particular
+# component and, optionally, to a particular option of that
+# component.
+#
+# optionDef The option definition
+# args definition arguments.
+
+proc ::snit::Comp.DelegatedOption {optionDef arglist} {
+ variable compile
+
+ # First, get the three option names.
+ set option [lindex $optionDef 0]
+ set resourceName [lindex $optionDef 1]
+ set className [lindex $optionDef 2]
+
+ set errRoot "Error in \"delegate option [list $optionDef]...\""
+
+ # Next, parse the delegation options.
+ set component ""
+ set target ""
+ set exceptions {}
+
+ foreach {opt value} $arglist {
+ switch -exact $opt {
+ to { set component $value }
+ as { set target $value }
+ except { set exceptions $value }
+ default {
+ error "$errRoot, unknown delegation option \"$opt\""
+ }
+ }
+ }
+
+ if {$component eq ""} {
+ error "$errRoot, missing \"to\""
+ }
+
+ if {$option eq "*" && $target ne ""} {
+ error "$errRoot, cannot specify \"as\" with \"delegate option *\""
+ }
+
+ if {$option ne "*" && $exceptions ne ""} {
+ error "$errRoot, can only specify \"except\" with \"delegate option *\""
+ }
+
+ # Next, validate the option name
+
+ if {"*" != $option} {
+ if {![Comp.OptionNameIsValid $option]} {
+ error "$errRoot, badly named option \"$option\""
+ }
+ }
+
+ if {$option in $compile(localoptions)} {
+ error "$errRoot, \"$option\" has been defined locally"
+ }
+
+ if {$option in $compile(delegatedoptions)} {
+ error "$errRoot, \"$option\" is multiply delegated"
+ }
+
+ # NEXT, define the component
+ Comp.DefineComponent $component $errRoot
+
+ # Next, define the target option, if not specified.
+ if {![string equal $option "*"] &&
+ [string equal $target ""]} {
+ set target $option
+ }
+
+ # NEXT, save the delegation data.
+ set compile(hasoptions) yes
+
+ if {![string equal $option "*"]} {
+ lappend compile(delegatedoptions) $option
+
+ # Next, compute the resource and class names, if they aren't
+ # already defined.
+
+ if {"" == $resourceName} {
+ set resourceName [string range $option 1 end]
+ }
+
+ if {"" == $className} {
+ set className [Capitalize $resourceName]
+ }
+
+ Mappend compile(defs) {
+ set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0
+ set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES%
+ set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
+ lappend %TYPE%::Snit_optionInfo(delegated) %OPTION%
+ set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%]
+ lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION%
+ } %OPTION% $option \
+ %COMP% $component \
+ %TARGET% $target \
+ %RES% $resourceName \
+ %CLASS% $className
+ } else {
+ Mappend compile(defs) {
+ set %TYPE%::Snit_optionInfo(starcomp) %COMP%
+ set %TYPE%::Snit_optionInfo(except) %EXCEPT%
+ } %COMP% $component %EXCEPT% [list $exceptions]
+ }
+}
+
+# Exposes a component, effectively making the component's command an
+# instance method.
+#
+# component The logical name of the delegate
+# "as" sugar; if not "", must be "as"
+# methodname The desired method name for the component's command, or ""
+
+proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} {
+ variable compile
+
+
+ # FIRST, define the component
+ Comp.DefineComponent $component
+
+ # NEXT, define the method just as though it were in the type
+ # definition.
+ if {[string equal $methodname ""]} {
+ set methodname $component
+ }
+
+ Comp.statement.method $methodname args [Expand {
+ if {[llength $args] == 0} {
+ return $%COMPONENT%
+ }
+
+ if {[string equal $%COMPONENT% ""]} {
+ error "undefined component \"%COMPONENT%\""
+ }
+
+
+ set cmd [linsert $args 0 $%COMPONENT%]
+ return [uplevel 1 $cmd]
+ } %COMPONENT% $component]
+}
+
+
+
+#-----------------------------------------------------------------------
+# Public commands
+
+# Compile a type definition, and return the results as a list of two
+# items: the fully-qualified type name, and a script that will define
+# the type when executed.
+#
+# which type, widget, or widgetadaptor
+# type the type name
+# body the type definition
+proc ::snit::compile {which type body} {
+ return [Comp.Compile $which $type $body]
+}
+
+proc ::snit::type {type body} {
+ return [Comp.Define [Comp.Compile type $type $body]]
+}
+
+proc ::snit::widget {type body} {
+ return [Comp.Define [Comp.Compile widget $type $body]]
+}
+
+proc ::snit::widgetadaptor {type body} {
+ return [Comp.Define [Comp.Compile widgetadaptor $type $body]]
+}
+
+proc ::snit::typemethod {type method arglist body} {
+ # Make sure the type exists.
+ if {![info exists ${type}::Snit_info]} {
+ error "no such type: \"$type\""
+ }
+
+ upvar ${type}::Snit_info Snit_info
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+
+ # FIRST, check the typemethod name against previously defined
+ # typemethods.
+ Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \
+ "Cannot define \"$method\""
+
+ # NEXT, check the arguments
+ CheckArgs "snit::typemethod $type $method" $arglist
+
+ # Next, add magic reference to type.
+ set arglist [concat type $arglist]
+
+ # Next, add typevariable declarations to body:
+ set body "$Snit_info(tvardecs)\n$body"
+
+ # Next, define it.
+ if {[llength $method] == 1} {
+ set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
+ uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body]
+ } else {
+ set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
+ set suffix [join $method _]
+ uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body]
+ }
+}
+
+proc ::snit::method {type method arglist body} {
+ # Make sure the type exists.
+ if {![info exists ${type}::Snit_info]} {
+ error "no such type: \"$type\""
+ }
+
+ upvar ${type}::Snit_methodInfo Snit_methodInfo
+ upvar ${type}::Snit_info Snit_info
+
+ # FIRST, check the method name against previously defined
+ # methods.
+ Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \
+ "Cannot define \"$method\""
+
+ # NEXT, check the arguments
+ CheckArgs "snit::method $type $method" $arglist
+
+ # Next, add magic references to type and self.
+ set arglist [concat type selfns win self $arglist]
+
+ # Next, add variable declarations to body:
+ set body "$Snit_info(tvardecs)\n$Snit_info(ivardecs)\n$body"
+
+ # Next, define it.
+ if {[llength $method] == 1} {
+ set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
+ uplevel 1 [list proc ${type}::Snit_method$method $arglist $body]
+ } else {
+ set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
+
+ set suffix [join $method _]
+ uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body]
+ }
+}
+
+# Defines a proc within the compiler; this proc can call other
+# type definition statements, and thus can be used for meta-programming.
+proc ::snit::macro {name arglist body} {
+ variable compiler
+ variable reservedwords
+
+ # FIRST, make sure the compiler is defined.
+ Comp.Init
+
+ # NEXT, check the macro name against the reserved words
+ if {[lsearch -exact $reservedwords $name] != -1} {
+ error "invalid macro name \"$name\""
+ }
+
+ # NEXT, see if the name has a namespace; if it does, define the
+ # namespace.
+ set ns [namespace qualifiers $name]
+
+ if {$ns ne ""} {
+ $compiler eval "namespace eval $ns {}"
+ }
+
+ # NEXT, define the macro
+ $compiler eval [list _proc $name $arglist $body]
+}
+
+#-----------------------------------------------------------------------
+# Utility Functions
+#
+# These are utility functions used while compiling Snit types.
+
+# Builds a template from a tagged list of text blocks, then substitutes
+# all symbols in the mapTable, returning the expanded template.
+proc ::snit::Expand {template args} {
+ return [string map $args $template]
+}
+
+# Expands a template and appends it to a variable.
+proc ::snit::Mappend {varname template args} {
+ upvar $varname myvar
+
+ append myvar [string map $args $template]
+}
+
+# Checks argument list against reserved args
+proc ::snit::CheckArgs {which arglist} {
+ variable reservedArgs
+
+ foreach name $reservedArgs {
+ if {$name in $arglist} {
+ error "$which's arglist may not contain \"$name\" explicitly"
+ }
+ }
+}
+
+# Capitalizes the first letter of a string.
+proc ::snit::Capitalize {text} {
+ return [string toupper $text 0]
+}
+
+
+#=======================================================================
+# Snit Runtime Library
+#
+# These are procs used by Snit types and widgets at runtime.
+
+#-----------------------------------------------------------------------
+# Object Creation
+
+# Creates a new instance of the snit::type given its name and the args.
+#
+# type The snit::type
+# name The instance name
+# args Args to pass to the constructor
+
+proc ::snit::RT.type.typemethod.create {type name args} {
+ variable ${type}::Snit_info
+ variable ${type}::Snit_optionInfo
+
+ # FIRST, qualify the name.
+ if {![string match "::*" $name]} {
+ # Get caller's namespace;
+ # append :: if not global namespace.
+ set ns [uplevel 1 [list namespace current]]
+ if {"::" != $ns} {
+ append ns "::"
+ }
+
+ set name "$ns$name"
+ }
+
+ # NEXT, if %AUTO% appears in the name, generate a unique
+ # command name. Otherwise, ensure that the name isn't in use.
+ if {[string match "*%AUTO%*" $name]} {
+ set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
+ } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} {
+ error "command \"$name\" already exists"
+ }
+
+ # NEXT, create the instance's namespace.
+ set selfns \
+ [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
+ namespace eval $selfns {}
+
+ # NEXT, install the dispatcher
+ RT.MakeInstanceCommand $type $selfns $name
+
+ # Initialize the options to their defaults.
+ namespace upvar ${selfns} options options
+
+ foreach opt $Snit_optionInfo(local) {
+ set options($opt) $Snit_optionInfo(default-$opt)
+ }
+
+ # Initialize the instance vars to their defaults.
+ # selfns must be defined, as it is used implicitly.
+ ${type}::Snit_instanceVars $selfns
+
+ # Execute the type's constructor.
+ set errcode [catch {
+ RT.ConstructInstance $type $selfns $name $args
+ } result]
+
+ if {$errcode} {
+ global errorInfo
+ global errorCode
+
+ set theInfo $errorInfo
+ set theCode $errorCode
+
+ ::snit::RT.DestroyObject $type $selfns $name
+ error "Error in constructor: $result" $theInfo $theCode
+ }
+
+ # NEXT, return the object's name.
+ return $name
+}
+
+# Creates a new instance of the snit::widget or snit::widgetadaptor
+# given its name and the args.
+#
+# type The snit::widget or snit::widgetadaptor
+# name The instance name
+# args Args to pass to the constructor
+
+proc ::snit::RT.widget.typemethod.create {type name args} {
+ variable ${type}::Snit_info
+ variable ${type}::Snit_optionInfo
+
+ # FIRST, if %AUTO% appears in the name, generate a unique
+ # command name.
+ if {[string match "*%AUTO%*" $name]} {
+ set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
+ }
+
+ # NEXT, create the instance's namespace.
+ set selfns \
+ [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
+ namespace eval $selfns { }
+
+ # NEXT, Initialize the widget's own options to their defaults.
+ namespace upvar $selfns options options
+
+ foreach opt $Snit_optionInfo(local) {
+ set options($opt) $Snit_optionInfo(default-$opt)
+ }
+
+ # Initialize the instance vars to their defaults.
+ ${type}::Snit_instanceVars $selfns
+
+ # NEXT, if this is a normal widget (not a widget adaptor) then create a
+ # frame as its hull. We set the frame's -class to the user's widgetclass,
+ # or, if none, search for -class in the args list, otherwise default to
+ # the basename of the $type with an initial upper case letter.
+ if {!$Snit_info(isWidgetAdaptor)} {
+ # FIRST, determine the class name
+ set wclass $Snit_info(widgetclass)
+ if {$Snit_info(widgetclass) eq ""} {
+ set idx [lsearch -exact $args -class]
+ if {$idx >= 0 && ($idx%2 == 0)} {
+ # -class exists and is in the -option position
+ set wclass [lindex $args [expr {$idx+1}]]
+ set args [lreplace $args $idx [expr {$idx+1}]]
+ } else {
+ set wclass [::snit::Capitalize [namespace tail $type]]
+ }
+ }
+
+ # NEXT, create the widget
+ set self $name
+ package require Tk
+ ${type}::installhull using $Snit_info(hulltype) -class $wclass
+
+ # NEXT, let's query the option database for our
+ # widget, now that we know that it exists.
+ foreach opt $Snit_optionInfo(local) {
+ set dbval [RT.OptionDbGet $type $name $opt]
+
+ if {"" != $dbval} {
+ set options($opt) $dbval
+ }
+ }
+ }
+
+ # Execute the type's constructor, and verify that it
+ # has a hull.
+ set errcode [catch {
+ RT.ConstructInstance $type $selfns $name $args
+
+ ::snit::RT.Component $type $selfns hull
+
+ # Prepare to call the object's destructor when the
+ # <Destroy> event is received. Use a Snit-specific bindtag
+ # so that the widget name's tag is unencumbered.
+
+ bind Snit$type$name <Destroy> [::snit::Expand {
+ ::snit::RT.DestroyObject %TYPE% %NS% %W
+ } %TYPE% $type %NS% $selfns]
+
+ # Insert the bindtag into the list of bindtags right
+ # after the widget name.
+ set taglist [bindtags $name]
+ set ndx [lsearch -exact $taglist $name]
+ incr ndx
+ bindtags $name [linsert $taglist $ndx Snit$type$name]
+ } result]
+
+ if {$errcode} {
+ global errorInfo
+ global errorCode
+
+ set theInfo $errorInfo
+ set theCode $errorCode
+ ::snit::RT.DestroyObject $type $selfns $name
+ error "Error in constructor: $result" $theInfo $theCode
+ }
+
+ # NEXT, return the object's name.
+ return $name
+}
+
+
+# RT.MakeInstanceCommand type selfns instance
+#
+# type The object type
+# selfns The instance namespace
+# instance The instance name
+#
+# Creates the instance proc.
+
+proc ::snit::RT.MakeInstanceCommand {type selfns instance} {
+ variable ${type}::Snit_info
+
+ # FIRST, remember the instance name. The Snit_instance variable
+ # allows the instance to figure out its current name given the
+ # instance namespace.
+
+ namespace upvar $selfns Snit_instance Snit_instance
+
+ set Snit_instance $instance
+
+ # NEXT, qualify the proc name if it's a widget.
+ if {$Snit_info(isWidget)} {
+ set procname ::$instance
+ } else {
+ set procname $instance
+ }
+
+ # NEXT, install the new proc
+ # WHD: Snit 2.0 code
+
+ set unknownCmd [list ::snit::RT.UnknownMethod $type $selfns $instance ""]
+ set createCmd [list namespace ensemble create \
+ -command $procname \
+ -unknown $unknownCmd \
+ -prefixes 0]
+
+ namespace eval $selfns $createCmd
+
+ # NEXT, add the trace.
+ trace add command $procname {rename delete} \
+ [list ::snit::RT.InstanceTrace $type $selfns $instance]
+}
+
+# This proc is called when the instance command is renamed.
+# If op is delete, then new will always be "", so op is redundant.
+#
+# type The fully-qualified type name
+# selfns The instance namespace
+# win The original instance/tk window name.
+# old old instance command name
+# new new instance command name
+# op rename or delete
+#
+# If the op is delete, we need to clean up the object; otherwise,
+# we need to track the change.
+#
+# NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete
+# traces aren't propagated correctly. Instead, they silently
+# vanish. Add a catch to output any error message.
+
+proc ::snit::RT.InstanceTrace {type selfns win old new op} {
+ variable ${type}::Snit_info
+
+ # Note to developers ...
+ # For Tcl 8.4.0, errors thrown in trace handlers vanish silently.
+ # Therefore we catch them here and create some output to help in
+ # debugging such problems.
+
+ if {[catch {
+ # FIRST, clean up if necessary
+ if {"" == $new} {
+ if {$Snit_info(isWidget)} {
+ destroy $win
+ } else {
+ ::snit::RT.DestroyObject $type $selfns $win
+ }
+ } else {
+ # Otherwise, track the change.
+ variable ${selfns}::Snit_instance
+ set Snit_instance [uplevel 1 [list namespace which -command $new]]
+
+ # Also, clear the instance caches, as many cached commands
+ # might be invalid.
+ RT.ClearInstanceCaches $selfns
+ }
+ } result]} {
+ global errorInfo
+ # Pop up the console on Windows wish, to enable stdout.
+ # This clobbers errorInfo on unix, so save it so we can print it.
+ set ei $errorInfo
+ catch {console show}
+ puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:"
+ puts $ei
+ }
+}
+
+# Calls the instance constructor and handles related housekeeping.
+proc ::snit::RT.ConstructInstance {type selfns instance arglist} {
+ variable ${type}::Snit_optionInfo
+ variable ${selfns}::Snit_iinfo
+
+ # Track whether we are constructed or not.
+ set Snit_iinfo(constructed) 0
+
+ # Call the user's constructor
+ eval [linsert $arglist 0 \
+ ${type}::Snit_constructor $type $selfns $instance $instance]
+
+ set Snit_iinfo(constructed) 1
+
+ # Validate the initial set of options (including defaults)
+ foreach option $Snit_optionInfo(local) {
+ set value [set ${selfns}::options($option)]
+
+ if {$Snit_optionInfo(typespec-$option) ne ""} {
+ if {[catch {
+ $Snit_optionInfo(typeobj-$option) validate $value
+ } result]} {
+ return -code error "invalid $option default: $result"
+ }
+ }
+ }
+
+ # Unset the configure cache for all -readonly options.
+ # This ensures that the next time anyone tries to
+ # configure it, an error is thrown.
+ foreach opt $Snit_optionInfo(local) {
+ if {$Snit_optionInfo(readonly-$opt)} {
+ unset -nocomplain ${selfns}::Snit_configureCache($opt)
+ }
+ }
+
+ return
+}
+
+# Returns a unique command name.
+#
+# REQUIRE: type is a fully qualified name.
+# REQUIRE: name contains "%AUTO%"
+# PROMISE: the returned command name is unused.
+proc ::snit::RT.UniqueName {countervar type name} {
+ upvar $countervar counter
+ while 1 {
+ # FIRST, bump the counter and define the %AUTO% instance name;
+ # then substitute it into the specified name. Wrap around at
+ # 2^31 - 2 to prevent overflow problems.
+ incr counter
+ if {$counter > 2147483646} {
+ set counter 0
+ }
+ set auto "[namespace tail $type]$counter"
+ set candidate [Expand $name %AUTO% $auto]
+ if {![llength [info commands $candidate]]} {
+ return $candidate
+ }
+ }
+}
+
+# Returns a unique instance namespace, fully qualified.
+#
+# countervar The name of a counter variable
+# type The instance's type
+#
+# REQUIRE: type is fully qualified
+# PROMISE: The returned namespace name is unused.
+
+proc ::snit::RT.UniqueInstanceNamespace {countervar type} {
+ upvar $countervar counter
+ while 1 {
+ # FIRST, bump the counter and define the namespace name.
+ # Then see if it already exists. Wrap around at
+ # 2^31 - 2 to prevent overflow problems.
+ incr counter
+ if {$counter > 2147483646} {
+ set counter 0
+ }
+ set ins "${type}::Snit_inst${counter}"
+ if {![namespace exists $ins]} {
+ return $ins
+ }
+ }
+}
+
+# Retrieves an option's value from the option database.
+# Returns "" if no value is found.
+proc ::snit::RT.OptionDbGet {type self opt} {
+ variable ${type}::Snit_optionInfo
+
+ return [option get $self \
+ $Snit_optionInfo(resource-$opt) \
+ $Snit_optionInfo(class-$opt)]
+}
+
+#-----------------------------------------------------------------------
+# Object Destruction
+
+# Implements the standard "destroy" method
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+
+proc ::snit::RT.method.destroy {type selfns win self} {
+ variable ${selfns}::Snit_iinfo
+
+ # Can't destroy the object if it isn't complete constructed.
+ if {!$Snit_iinfo(constructed)} {
+ return -code error "Called 'destroy' method in constructor"
+ }
+
+ # Calls Snit_cleanup, which (among other things) calls the
+ # user's destructor.
+ ::snit::RT.DestroyObject $type $selfns $win
+}
+
+# This is the function that really cleans up; it's automatically
+# called when any instance is destroyed, e.g., by "$object destroy"
+# for types, and by the <Destroy> event for widgets.
+#
+# type The fully-qualified type name.
+# selfns The instance namespace
+# win The original instance command name.
+
+proc ::snit::RT.DestroyObject {type selfns win} {
+ variable ${type}::Snit_info
+
+ # If the variable Snit_instance doesn't exist then there's no
+ # instance command for this object -- it's most likely a
+ # widgetadaptor. Consequently, there are some things that
+ # we don't need to do.
+ if {[info exists ${selfns}::Snit_instance]} {
+ namespace upvar $selfns Snit_instance instance
+
+ # First, remove the trace on the instance name, so that we
+ # don't call RT.DestroyObject recursively.
+ RT.RemoveInstanceTrace $type $selfns $win $instance
+
+ # Next, call the user's destructor
+ ${type}::Snit_destructor $type $selfns $win $instance
+
+ # Next, if this isn't a widget, delete the instance command.
+ # If it is a widget, get the hull component's name, and rename
+ # it back to the widget name
+
+ # Next, delete the hull component's instance command,
+ # if there is one.
+ if {$Snit_info(isWidget)} {
+ set hullcmd [::snit::RT.Component $type $selfns hull]
+
+ catch {rename $instance ""}
+
+ # Clear the bind event
+ bind Snit$type$win <Destroy> ""
+
+ if {[llength [info commands $hullcmd]]} {
+ # FIRST, rename the hull back to its original name.
+ # If the hull is itself a megawidget, it will have its
+ # own cleanup to do, and it might not do it properly
+ # if it doesn't have the right name.
+ rename $hullcmd ::$instance
+
+ # NEXT, destroy it.
+ destroy $instance
+ }
+ } else {
+ catch {rename $instance ""}
+ }
+ }
+
+ # Next, delete the instance's namespace. This kills any
+ # instance variables.
+ namespace delete $selfns
+
+ return
+}
+
+# Remove instance trace
+#
+# type The fully qualified type name
+# selfns The instance namespace
+# win The original instance name/Tk window name
+# instance The current instance name
+
+proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} {
+ variable ${type}::Snit_info
+
+ if {$Snit_info(isWidget)} {
+ set procname ::$instance
+ } else {
+ set procname $instance
+ }
+
+ # NEXT, remove any trace on this name
+ catch {
+ trace remove command $procname {rename delete} \
+ [list ::snit::RT.InstanceTrace $type $selfns $win]
+ }
+}
+
+#-----------------------------------------------------------------------
+# Typecomponent Management and Method Caching
+
+# Typecomponent trace; used for write trace on typecomponent
+# variables. Saves the new component object name, provided
+# that certain conditions are met. Also clears the typemethod
+# cache.
+
+proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} {
+ namespace upvar $type \
+ Snit_info Snit_info \
+ $component cvar \
+ Snit_typecomponents Snit_typecomponents
+
+
+ # Save the new component value.
+ set Snit_typecomponents($component) $cvar
+
+ # Clear the typemethod cache.
+ # TBD: can we unset just the elements related to
+ # this component?
+
+ # WHD: Namespace 2.0 code
+ namespace ensemble configure $type -map {}
+}
+
+# WHD: Snit 2.0 code
+#
+# RT.UnknownTypemethod type eId eCmd method args
+#
+# type The type
+# eId The ensemble command ID; "" for the instance itself.
+# eCmd The ensemble command name.
+# method The unknown method name.
+# args The additional arguments, if any.
+#
+# This proc looks up the method relative to the specified ensemble.
+# If no method is found, it assumes that the "create" method is
+# desired, and that the "method" is the instance name. In this case,
+# it returns the "create" typemethod command with the instance name
+# appended; this will cause the instance to be created without updating
+# the -map. If the method is found, the method's command is created and
+# added to the -map; the function returns the empty list.
+
+proc snit::RT.UnknownTypemethod {type eId eCmd method args} {
+ namespace upvar $type \
+ Snit_typemethodInfo Snit_typemethodInfo \
+ Snit_typecomponents Snit_typecomponents \
+ Snit_info Snit_info
+
+ # FIRST, get the pattern data and the typecomponent name.
+ set implicitCreate 0
+ set instanceName ""
+
+ set fullMethod $eId
+ lappend fullMethod $method
+ set starredMethod [concat $eId *]
+ set methodTail $method
+
+ if {[info exists Snit_typemethodInfo($fullMethod)]} {
+ set key $fullMethod
+ } elseif {[info exists Snit_typemethodInfo($starredMethod)]} {
+ if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} {
+ set key $starredMethod
+ } else {
+ # WHD: The method is explicitly not delegated, so this is an error.
+ # Or should we treat it as an instance name?
+ return [list ]
+ }
+ } elseif {[llength $fullMethod] > 1} {
+ return [list ]
+ } elseif {$Snit_info(hasinstances)} {
+ # Assume the unknown name is an instance name to create, unless
+ # this is a widget and the style of the name is wrong, or the
+ # name mimics a standard typemethod.
+
+ if {[set ${type}::Snit_info(isWidget)] &&
+ ![string match ".*" $method]} {
+ return [list ]
+ }
+
+ # Without this check, the call "$type info" will redefine the
+ # standard "::info" command, with disastrous results. Since it's
+ # a likely thing to do if !-typeinfo, put in an explicit check.
+ if {$method eq "info" || $method eq "destroy"} {
+ return [list ]
+ }
+
+ set implicitCreate 1
+ set instanceName $method
+ set key create
+ set method create
+ } else {
+ return [list ]
+ }
+
+ foreach {flag pattern compName} $Snit_typemethodInfo($key) {}
+
+ if {$flag == 1} {
+ # FIRST, define the ensemble command.
+ lappend eId $method
+
+ set newCmd ${type}::Snit_ten[llength $eId]_[join $eId _]
+
+ set unknownCmd [list ::snit::RT.UnknownTypemethod \
+ $type $eId]
+
+ set createCmd [list namespace ensemble create \
+ -command $newCmd \
+ -unknown $unknownCmd \
+ -prefixes 0]
+
+ namespace eval $type $createCmd
+
+ # NEXT, add the method to the current ensemble
+ set map [namespace ensemble configure $eCmd -map]
+
+ dict append map $method $newCmd
+
+ namespace ensemble configure $eCmd -map $map
+
+ return [list ]
+ }
+
+ # NEXT, build the substitution list
+ set subList [list \
+ %% % \
+ %t $type \
+ %M $fullMethod \
+ %m [lindex $fullMethod end] \
+ %j [join $fullMethod _]]
+
+ if {$compName ne ""} {
+ if {![info exists Snit_typecomponents($compName)]} {
+ error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\""
+ }
+
+ lappend subList %c [list $Snit_typecomponents($compName)]
+ }
+
+ set command {}
+
+ foreach subpattern $pattern {
+ lappend command [string map $subList $subpattern]
+ }
+
+ if {$implicitCreate} {
+ # In this case, $method is the name of the instance to
+ # create. Don't cache, as we usually won't do this one
+ # again.
+ lappend command $instanceName
+ return $command
+ }
+
+
+ # NEXT, if the actual command name isn't fully qualified,
+ # assume it's global.
+ set cmd [lindex $command 0]
+
+ if {[string index $cmd 0] ne ":"} {
+ set command [lreplace $command 0 0 "::$cmd"]
+ }
+
+ # NEXT, update the ensemble map.
+ set map [namespace ensemble configure $eCmd -map]
+
+ dict append map $method $command
+
+ namespace ensemble configure $eCmd -map $map
+
+ return [list ]
+}
+
+#-----------------------------------------------------------------------
+# Component Management and Method Caching
+
+# Retrieves the object name given the component name.
+proc ::snit::RT.Component {type selfns name} {
+ variable ${selfns}::Snit_components
+
+ if {[catch {set Snit_components($name)} result]} {
+ variable ${selfns}::Snit_instance
+
+ error "component \"$name\" is undefined in $type $Snit_instance"
+ }
+
+ return $result
+}
+
+# Component trace; used for write trace on component instance
+# variables. Saves the new component object name, provided
+# that certain conditions are met. Also clears the method
+# cache.
+
+proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} {
+ namespace upvar $type Snit_info Snit_info
+ namespace upvar $selfns \
+ $component cvar \
+ Snit_components Snit_components
+
+ # If they try to redefine the hull component after
+ # it's been defined, that's an error--but only if
+ # this is a widget or widget adaptor.
+ if {"hull" == $component &&
+ $Snit_info(isWidget) &&
+ [info exists Snit_components($component)]} {
+ set cvar $Snit_components($component)
+ error "The hull component cannot be redefined"
+ }
+
+ # Save the new component value.
+ set Snit_components($component) $cvar
+
+ # Clear the instance caches.
+ # TBD: can we unset just the elements related to
+ # this component?
+ RT.ClearInstanceCaches $selfns
+}
+
+# WHD: Snit 2.0 code
+#
+# RT.UnknownMethod type selfns win eId eCmd method args
+#
+# type The type or widget command.
+# selfns The instance namespace.
+# win The original instance name.
+# eId The ensemble command ID; "" for the instance itself.
+# eCmd The real ensemble command name
+# method The unknown method name
+# args The additional arguments, if any.
+#
+# This proc looks up the method relative to the specific ensemble.
+# If no method is found, it returns an empty list; this will result in
+# the parent ensemble throwing an error.
+# If the method is found, the ensemble's -map is extended with the
+# correct command, and the empty list is returned; this caches the
+# method's command. If the method is found, and it is also an
+# ensemble, the ensemble command is created with an empty map.
+
+proc ::snit::RT.UnknownMethod {type selfns win eId eCmd method args} {
+ variable ${type}::Snit_info
+ variable ${type}::Snit_methodInfo
+ variable ${type}::Snit_typecomponents
+ variable ${selfns}::Snit_components
+
+ # FIRST, get the "self" value
+ set self [set ${selfns}::Snit_instance]
+
+ # FIRST, get the pattern data and the component name.
+ set fullMethod $eId
+ lappend fullMethod $method
+ set starredMethod [concat $eId *]
+ set methodTail $method
+
+ if {[info exists Snit_methodInfo($fullMethod)]} {
+ set key $fullMethod
+ } elseif {[info exists Snit_methodInfo($starredMethod)] &&
+ [lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} {
+ set key $starredMethod
+ } else {
+ return [list ]
+ }
+
+ foreach {flag pattern compName} $Snit_methodInfo($key) {}
+
+ if {$flag == 1} {
+ # FIRST, define the ensemble command.
+ lappend eId $method
+
+ # Fix provided by Anton Kovalenko; previously this call erroneously
+ # used ${type} rather than ${selfns}.
+ set newCmd ${selfns}::Snit_en[llength $eId]_[join $eId _]
+
+ set unknownCmd [list ::snit::RT.UnknownMethod \
+ $type $selfns $win $eId]
+
+ set createCmd [list namespace ensemble create \
+ -command $newCmd \
+ -unknown $unknownCmd \
+ -prefixes 0]
+
+ namespace eval $selfns $createCmd
+
+ # NEXT, add the method to the current ensemble
+ set map [namespace ensemble configure $eCmd -map]
+
+ dict append map $method $newCmd
+
+ namespace ensemble configure $eCmd -map $map
+
+ return [list ]
+ }
+
+ # NEXT, build the substitution list
+ set subList [list \
+ %% % \
+ %t $type \
+ %M $fullMethod \
+ %m [lindex $fullMethod end] \
+ %j [join $fullMethod _] \
+ %n [list $selfns] \
+ %w [list $win] \
+ %s [list $self]]
+
+ if {$compName ne ""} {
+ if {[info exists Snit_components($compName)]} {
+ set compCmd $Snit_components($compName)
+ } elseif {[info exists Snit_typecomponents($compName)]} {
+ set compCmd $Snit_typecomponents($compName)
+ } else {
+ error "$type $self delegates method \"$fullMethod\" to undefined component \"$compName\""
+ }
+
+ lappend subList %c [list $compCmd]
+ }
+
+ # Note: The cached command will execute faster if it's
+ # already a list.
+ set command {}
+
+ foreach subpattern $pattern {
+ lappend command [string map $subList $subpattern]
+ }
+
+ # NEXT, if the actual command name isn't fully qualified,
+ # assume it's global.
+
+ set cmd [lindex $command 0]
+
+ if {[string index $cmd 0] ne ":"} {
+ set command [lreplace $command 0 0 "::$cmd"]
+ }
+
+ # NEXT, update the ensemble map.
+ set map [namespace ensemble configure $eCmd -map]
+
+ dict append map $method $command
+
+ namespace ensemble configure $eCmd -map $map
+
+ return [list ]
+}
+
+# Clears all instance command caches
+proc ::snit::RT.ClearInstanceCaches {selfns} {
+ # WHD: clear ensemble -map
+ if {![info exists ${selfns}::Snit_instance]} {
+ # Component variable set prior to constructor
+ # via the "variable" type definition statement.
+ return
+ }
+ set self [set ${selfns}::Snit_instance]
+ namespace ensemble configure $self -map {}
+
+ unset -nocomplain -- ${selfns}::Snit_cgetCache
+ unset -nocomplain -- ${selfns}::Snit_configureCache
+ unset -nocomplain -- ${selfns}::Snit_validateCache
+}
+
+
+#-----------------------------------------------------------------------
+# Component Installation
+
+# Implements %TYPE%::installhull. The variables self and selfns
+# must be defined in the caller's context.
+#
+# Installs the named widget as the hull of a
+# widgetadaptor. Once the widget is hijacked, its new name
+# is assigned to the hull component.
+
+proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} {
+ variable ${type}::Snit_info
+ variable ${type}::Snit_optionInfo
+ upvar 1 self self
+ upvar 1 selfns selfns
+ namespace upvar $selfns \
+ hull hull \
+ options options
+
+ # FIRST, make sure we can do it.
+ if {!$Snit_info(isWidget)} {
+ error "installhull is valid only for snit::widgetadaptors"
+ }
+
+ if {[info exists ${selfns}::Snit_instance]} {
+ error "hull already installed for $type $self"
+ }
+
+ # NEXT, has it been created yet? If not, create it using
+ # the specified arguments.
+ if {"using" == $using} {
+ # FIRST, create the widget
+ set cmd [linsert $args 0 $widgetType $self]
+ set obj [uplevel 1 $cmd]
+
+ # NEXT, for each option explicitly delegated to the hull
+ # that doesn't appear in the usedOpts list, get the
+ # option database value and apply it--provided that the
+ # real option name and the target option name are different.
+ # (If they are the same, then the option database was
+ # already queried as part of the normal widget creation.)
+ #
+ # Also, we don't need to worry about implicitly delegated
+ # options, as the option and target option names must be
+ # the same.
+ if {[info exists Snit_optionInfo(delegated-hull)]} {
+
+ # FIRST, extract all option names from args
+ set usedOpts {}
+ set ndx [lsearch -glob $args "-*"]
+ foreach {opt val} [lrange $args $ndx end] {
+ lappend usedOpts $opt
+ }
+
+ foreach opt $Snit_optionInfo(delegated-hull) {
+ set target [lindex $Snit_optionInfo(target-$opt) 1]
+
+ if {"$target" == $opt} {
+ continue
+ }
+
+ set result [lsearch -exact $usedOpts $target]
+
+ if {$result != -1} {
+ continue
+ }
+
+ set dbval [RT.OptionDbGet $type $self $opt]
+ $obj configure $target $dbval
+ }
+ }
+ } else {
+ set obj $using
+
+ if {$obj ne $self} {
+ error \
+ "hull name mismatch: \"$obj\" != \"$self\""
+ }
+ }
+
+ # NEXT, get the local option defaults.
+ foreach opt $Snit_optionInfo(local) {
+ set dbval [RT.OptionDbGet $type $self $opt]
+
+ if {"" != $dbval} {
+ set options($opt) $dbval
+ }
+ }
+
+
+ # NEXT, do the magic
+ set i 0
+ while 1 {
+ incr i
+ set newName "::hull${i}$self"
+ if {![llength [info commands $newName]]} {
+ break
+ }
+ }
+
+ rename ::$self $newName
+ RT.MakeInstanceCommand $type $selfns $self
+
+ # Note: this relies on RT.ComponentTrace to do the dirty work.
+ set hull $newName
+
+ return
+}
+
+# Implements %TYPE%::install.
+#
+# Creates a widget and installs it as the named component.
+# It expects self and selfns to be defined in the caller's context.
+
+proc ::snit::RT.install {type compName "using" widgetType winPath args} {
+ variable ${type}::Snit_optionInfo
+ variable ${type}::Snit_info
+ upvar 1 self self
+ upvar 1 selfns selfns
+
+ namespace upvar ${selfns} \
+ $compName comp \
+ hull hull
+
+ # We do the magic option database stuff only if $self is
+ # a widget.
+ if {$Snit_info(isWidget)} {
+ if {"" == $hull} {
+ error "tried to install \"$compName\" before the hull exists"
+ }
+
+ # FIRST, query the option database and save the results
+ # into args. Insert them before the first option in the
+ # list, in case there are any non-standard parameters.
+ #
+ # Note: there might not be any delegated options; if so,
+ # don't bother.
+
+ if {[info exists Snit_optionInfo(delegated-$compName)]} {
+ set ndx [lsearch -glob $args "-*"]
+
+ foreach opt $Snit_optionInfo(delegated-$compName) {
+ set dbval [RT.OptionDbGet $type $self $opt]
+
+ if {"" != $dbval} {
+ set target [lindex $Snit_optionInfo(target-$opt) 1]
+ set args [linsert $args $ndx $target $dbval]
+ }
+ }
+ }
+ }
+
+ # NEXT, create the component and save it.
+ set cmd [concat [list $widgetType $winPath] $args]
+ set comp [uplevel 1 $cmd]
+
+ # NEXT, handle the option database for "delegate option *",
+ # in widgets only.
+ if {$Snit_info(isWidget) && $Snit_optionInfo(starcomp) eq $compName} {
+ # FIRST, get the list of option specs from the widget.
+ # If configure doesn't work, skip it.
+ if {[catch {$comp configure} specs]} {
+ return
+ }
+
+ # NEXT, get the set of explicitly used options from args
+ set usedOpts {}
+ set ndx [lsearch -glob $args "-*"]
+ foreach {opt val} [lrange $args $ndx end] {
+ lappend usedOpts $opt
+ }
+
+ # NEXT, "delegate option *" matches all options defined
+ # by this widget that aren't defined by the widget as a whole,
+ # and that aren't excepted. Plus, we skip usedOpts. So build
+ # a list of the options it can't match.
+ set skiplist [concat \
+ $usedOpts \
+ $Snit_optionInfo(except) \
+ $Snit_optionInfo(local) \
+ $Snit_optionInfo(delegated)]
+
+ # NEXT, loop over all of the component's options, and set
+ # any not in the skip list for which there is an option
+ # database value.
+ foreach spec $specs {
+ # Skip aliases
+ if {[llength $spec] != 5} {
+ continue
+ }
+
+ set opt [lindex $spec 0]
+
+ if {[lsearch -exact $skiplist $opt] != -1} {
+ continue
+ }
+
+ set res [lindex $spec 1]
+ set cls [lindex $spec 2]
+
+ set dbvalue [option get $self $res $cls]
+
+ if {"" != $dbvalue} {
+ $comp configure $opt $dbvalue
+ }
+ }
+ }
+
+ return
+}
+
+
+#-----------------------------------------------------------------------
+# Method/Variable Name Qualification
+
+# Implements %TYPE%::variable. Requires selfns.
+proc ::snit::RT.variable {varname} {
+ upvar 1 selfns selfns
+
+ if {![string match "::*" $varname]} {
+ uplevel 1 [list upvar 1 ${selfns}::$varname $varname]
+ } else {
+ # varname is fully qualified; let the standard
+ # "variable" command handle it.
+ uplevel 1 [list ::variable $varname]
+ }
+}
+
+# Fully qualifies a typevariable name.
+#
+# This is used to implement the mytypevar command.
+
+proc ::snit::RT.mytypevar {type name} {
+ return ${type}::$name
+}
+
+# Fully qualifies an instance variable name.
+#
+# This is used to implement the myvar command.
+proc ::snit::RT.myvar {name} {
+ upvar 1 selfns selfns
+ return ${selfns}::$name
+}
+
+# Use this like "list" to convert a proc call into a command
+# string to pass to another object (e.g., as a -command).
+# Qualifies the proc name properly.
+#
+# This is used to implement the "myproc" command.
+
+proc ::snit::RT.myproc {type procname args} {
+ set procname "${type}::$procname"
+ return [linsert $args 0 $procname]
+}
+
+# DEPRECATED
+proc ::snit::RT.codename {type name} {
+ return "${type}::$name"
+}
+
+# Use this like "list" to convert a typemethod call into a command
+# string to pass to another object (e.g., as a -command).
+# Inserts the type command at the beginning.
+#
+# This is used to implement the "mytypemethod" command.
+
+proc ::snit::RT.mytypemethod {type args} {
+ return [linsert $args 0 $type]
+}
+
+# Use this like "list" to convert a method call into a command
+# string to pass to another object (e.g., as a -command).
+# Inserts the code at the beginning to call the right object, even if
+# the object's name has changed. Requires that selfns be defined
+# in the calling context, eg. can only be called in instance
+# code.
+#
+# This is used to implement the "mymethod" command.
+
+proc ::snit::RT.mymethod {args} {
+ upvar 1 selfns selfns
+ return [linsert $args 0 ::snit::RT.CallInstance ${selfns}]
+}
+
+# Calls an instance method for an object given its
+# instance namespace and remaining arguments (the first of which
+# will be the method name.
+#
+# selfns The instance namespace
+# args The arguments
+#
+# Uses the selfns to determine $self, and calls the method
+# in the normal way.
+#
+# This is used to implement the "mymethod" command.
+
+proc ::snit::RT.CallInstance {selfns args} {
+ namespace upvar $selfns Snit_instance self
+
+ set retval [catch {uplevel 1 [linsert $args 0 $self]} result]
+
+ if {$retval} {
+ if {$retval == 1} {
+ global errorInfo
+ global errorCode
+ return -code error -errorinfo $errorInfo \
+ -errorcode $errorCode $result
+ } else {
+ return -code $retval $result
+ }
+ }
+
+ return $result
+}
+
+# Looks for the named option in the named variable. If found,
+# it and its value are removed from the list, and the value
+# is returned. Otherwise, the default value is returned.
+# If the option is undelegated, it's own default value will be
+# used if none is specified.
+#
+# Implements the "from" command.
+
+proc ::snit::RT.from {type argvName option {defvalue ""}} {
+ namespace upvar $type Snit_optionInfo Snit_optionInfo
+ upvar $argvName argv
+
+ set ioption [lsearch -exact $argv $option]
+
+ if {$ioption == -1} {
+ if {"" == $defvalue &&
+ [info exists Snit_optionInfo(default-$option)]} {
+ return $Snit_optionInfo(default-$option)
+ } else {
+ return $defvalue
+ }
+ }
+
+ set ivalue [expr {$ioption + 1}]
+ set value [lindex $argv $ivalue]
+
+ set argv [lreplace $argv $ioption $ivalue]
+
+ return $value
+}
+
+#-----------------------------------------------------------------------
+# Type Destruction
+
+# Implements the standard "destroy" typemethod:
+# Destroys a type completely.
+#
+# type The snit type
+
+proc ::snit::RT.typemethod.destroy {type} {
+ variable ${type}::Snit_info
+
+ # FIRST, destroy all instances
+ foreach selfns [namespace children $type "${type}::Snit_inst*"] {
+ if {![namespace exists $selfns]} {
+ continue
+ }
+
+ namespace upvar $selfns Snit_instance obj
+
+ if {$Snit_info(isWidget)} {
+ destroy $obj
+ } else {
+ if {[llength [info commands $obj]]} {
+ $obj destroy
+ }
+ }
+ }
+
+ # NEXT, get rid of the type command.
+ rename $type ""
+
+ # NEXT, destroy the type's data.
+ namespace delete $type
+}
+
+
+
+#-----------------------------------------------------------------------
+# Option Handling
+
+# Implements the standard "cget" method
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# option The name of the option
+
+proc ::snit::RT.method.cget {type selfns win self option} {
+ if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} {
+ set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option]
+
+ if {[llength $command] == 0} {
+ return -code error "unknown option \"$option\""
+ }
+ }
+
+ uplevel 1 $command
+}
+
+# Retrieves and caches the command that implements "cget" for the
+# specified option.
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# option The name of the option
+
+proc ::snit::RT.CacheCgetCommand {type selfns win self option} {
+ variable ${type}::Snit_optionInfo
+ variable ${selfns}::Snit_cgetCache
+
+ if {[info exists Snit_optionInfo(islocal-$option)]} {
+ # We know the item; it's either local, or explicitly delegated.
+ if {$Snit_optionInfo(islocal-$option)} {
+ # It's a local option. If it has a cget method defined,
+ # use it; otherwise just return the value.
+
+ if {$Snit_optionInfo(cget-$option) eq ""} {
+ set command [list set ${selfns}::options($option)]
+ } else {
+ # WHD: Snit 2.0 code -- simpler, no slower.
+ set command [list \
+ $self \
+ {*}$Snit_optionInfo(cget-$option) \
+ $option]
+ }
+
+ set Snit_cgetCache($option) $command
+ return $command
+ }
+
+ # Explicitly delegated option; get target
+ set comp [lindex $Snit_optionInfo(target-$option) 0]
+ set target [lindex $Snit_optionInfo(target-$option) 1]
+ } elseif {$Snit_optionInfo(starcomp) ne "" &&
+ [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
+ # Unknown option, but unknowns are delegated; get target.
+ set comp $Snit_optionInfo(starcomp)
+ set target $option
+ } else {
+ return ""
+ }
+
+ # Get the component's object.
+ set obj [RT.Component $type $selfns $comp]
+
+ set command [list $obj cget $target]
+ set Snit_cgetCache($option) $command
+
+ return $command
+}
+
+# Implements the standard "configurelist" method
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# optionlist A list of options and their values.
+
+proc ::snit::RT.method.configurelist {type selfns win self optionlist} {
+ variable ${type}::Snit_optionInfo
+
+ foreach {option value} $optionlist {
+ # FIRST, get the configure command, caching it if need be.
+ if {[catch {set ${selfns}::Snit_configureCache($option)} command]} {
+ set command [snit::RT.CacheConfigureCommand \
+ $type $selfns $win $self $option]
+
+ if {[llength $command] == 0} {
+ return -code error "unknown option \"$option\""
+ }
+ }
+
+ # NEXT, if we have a type-validation object, use it.
+ # TBD: Should test (islocal-$option) here, but islocal
+ # isn't defined for implicitly delegated options.
+ if {[info exists Snit_optionInfo(typeobj-$option)]
+ && $Snit_optionInfo(typeobj-$option) ne ""} {
+ if {[catch {
+ $Snit_optionInfo(typeobj-$option) validate $value
+ } result]} {
+ return -code error "invalid $option value: $result"
+ }
+ }
+
+ # NEXT, the caching the configure command also cached the
+ # validate command, if any. If we have one, run it.
+ set valcommand [set ${selfns}::Snit_validateCache($option)]
+
+ if {[llength $valcommand]} {
+ lappend valcommand $value
+ uplevel 1 $valcommand
+ }
+
+ # NEXT, configure the option with the value.
+ lappend command $value
+ uplevel 1 $command
+ }
+
+ return
+}
+
+# Retrieves and caches the command that stores the named option.
+# Also stores the command that validates the name option if any;
+# If none, the validate command is "", so that the cache is always
+# populated.
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# option An option name
+
+proc ::snit::RT.CacheConfigureCommand {type selfns win self option} {
+ variable ${type}::Snit_optionInfo
+ variable ${selfns}::Snit_configureCache
+ variable ${selfns}::Snit_validateCache
+
+ if {[info exist Snit_optionInfo(islocal-$option)]} {
+ # We know the item; it's either local, or explicitly delegated.
+
+ if {$Snit_optionInfo(islocal-$option)} {
+ # It's a local option.
+
+ # If it's readonly, it throws an error if we're already
+ # constructed.
+ if {$Snit_optionInfo(readonly-$option)} {
+ if {[set ${selfns}::Snit_iinfo(constructed)]} {
+ error "option $option can only be set at instance creation"
+ }
+ }
+
+ # If it has a validate method, cache that for later.
+ if {$Snit_optionInfo(validate-$option) ne ""} {
+ # WHD: Snit 2.0 code -- simpler, no slower.
+ set command [list \
+ $self \
+ {*}$Snit_optionInfo(validate-$option) \
+ $option]
+
+ set Snit_validateCache($option) $command
+ } else {
+ set Snit_validateCache($option) ""
+ }
+
+ # If it has a configure method defined,
+ # cache it; otherwise, just set the value.
+ if {$Snit_optionInfo(configure-$option) eq ""} {
+ set command [list set ${selfns}::options($option)]
+ } else {
+ # WHD: Snit 2.0 code -- simpler, no slower.
+ set command [list \
+ $self \
+ {*}$Snit_optionInfo(configure-$option) \
+ $option]
+ }
+
+ set Snit_configureCache($option) $command
+ return $command
+ }
+
+ # Delegated option: get target.
+ set comp [lindex $Snit_optionInfo(target-$option) 0]
+ set target [lindex $Snit_optionInfo(target-$option) 1]
+ } elseif {$Snit_optionInfo(starcomp) != "" &&
+ [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
+ # Unknown option, but unknowns are delegated.
+ set comp $Snit_optionInfo(starcomp)
+ set target $option
+ } else {
+ return ""
+ }
+
+ # There is no validate command in this case; save an empty string.
+ set Snit_validateCache($option) ""
+
+ # Get the component's object
+ set obj [RT.Component $type $selfns $comp]
+
+ set command [list $obj configure $target]
+ set Snit_configureCache($option) $command
+
+ return $command
+}
+
+# Implements the standard "configure" method
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# args A list of options and their values, possibly empty.
+
+proc ::snit::RT.method.configure {type selfns win self args} {
+ # If two or more arguments, set values as usual.
+ if {[llength $args] >= 2} {
+ ::snit::RT.method.configurelist $type $selfns $win $self $args
+ return
+ }
+
+ # If zero arguments, acquire data for each known option
+ # and return the list
+ if {[llength $args] == 0} {
+ set result {}
+ foreach opt [RT.method.info.options $type $selfns $win $self] {
+ # Refactor this, so that we don't need to call via $self.
+ lappend result [RT.GetOptionDbSpec \
+ $type $selfns $win $self $opt]
+ }
+
+ return $result
+ }
+
+ # They want it for just one.
+ set opt [lindex $args 0]
+
+ return [RT.GetOptionDbSpec $type $selfns $win $self $opt]
+}
+
+
+# Retrieves the option database spec for a single option.
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# option The name of an option
+#
+# TBD: This is a bad name. What it's returning is the
+# result of the configure query.
+
+proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} {
+ variable ${type}::Snit_optionInfo
+
+ namespace upvar $selfns \
+ Snit_components Snit_components \
+ options options
+
+ if {[info exists options($opt)]} {
+ # This is a locally-defined option. Just build the
+ # list and return it.
+ set res $Snit_optionInfo(resource-$opt)
+ set cls $Snit_optionInfo(class-$opt)
+ set def $Snit_optionInfo(default-$opt)
+
+ return [list $opt $res $cls $def \
+ [RT.method.cget $type $selfns $win $self $opt]]
+ } elseif {[info exists Snit_optionInfo(target-$opt)]} {
+ # This is an explicitly delegated option. The only
+ # thing we don't have is the default.
+ set res $Snit_optionInfo(resource-$opt)
+ set cls $Snit_optionInfo(class-$opt)
+
+ # Get the default
+ set logicalName [lindex $Snit_optionInfo(target-$opt) 0]
+ set comp $Snit_components($logicalName)
+ set target [lindex $Snit_optionInfo(target-$opt) 1]
+
+ if {[catch {$comp configure $target} result]} {
+ set defValue {}
+ } else {
+ set defValue [lindex $result 3]
+ }
+
+ return [list $opt $res $cls $defValue [$self cget $opt]]
+ } elseif {$Snit_optionInfo(starcomp) ne "" &&
+ [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
+ set logicalName $Snit_optionInfo(starcomp)
+ set target $opt
+ set comp $Snit_components($logicalName)
+
+ if {[catch {set value [$comp cget $target]} result]} {
+ error "unknown option \"$opt\""
+ }
+
+ if {![catch {$comp configure $target} result]} {
+ # Replace the delegated option name with the local name.
+ return [::snit::Expand $result $target $opt]
+ }
+
+ # configure didn't work; return simple form.
+ return [list $opt "" "" "" $value]
+ } else {
+ error "unknown option \"$opt\""
+ }
+}
+
+#-----------------------------------------------------------------------
+# Type Introspection
+
+# Implements the standard "info" typemethod.
+#
+# type The snit type
+# command The info subcommand
+# args All other arguments.
+
+proc ::snit::RT.typemethod.info {type command args} {
+ global errorInfo
+ global errorCode
+
+ switch -exact $command {
+ args -
+ body -
+ default -
+ typevars -
+ typemethods -
+ instances {
+ # TBD: it should be possible to delete this error
+ # handling.
+ set errflag [catch {
+ uplevel 1 [linsert $args 0 \
+ ::snit::RT.typemethod.info.$command $type]
+ } result]
+
+ if {$errflag} {
+ return -code error -errorinfo $errorInfo \
+ -errorcode $errorCode $result
+ } else {
+ return $result
+ }
+ }
+ default {
+ error "\"$type info $command\" is not defined"
+ }
+ }
+}
+
+
+# Returns a list of the type's typevariables whose names match a
+# pattern, excluding Snit internal variables.
+#
+# type A Snit type
+# pattern Optional. The glob pattern to match. Defaults
+# to *.
+
+proc ::snit::RT.typemethod.info.typevars {type {pattern *}} {
+ set result {}
+ foreach name [info vars "${type}::$pattern"] {
+ set tail [namespace tail $name]
+ if {![string match "Snit_*" $tail]} {
+ lappend result $name
+ }
+ }
+
+ return $result
+}
+
+# Returns a list of the type's methods whose names match a
+# pattern. If "delegate typemethod *" is used, the list may
+# not be complete.
+#
+# type A Snit type
+# pattern Optional. The glob pattern to match. Defaults
+# to *.
+
+proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} {
+ variable ${type}::Snit_typemethodInfo
+
+ # FIRST, get the explicit names, skipping prefixes.
+ set result {}
+
+ foreach name [array names Snit_typemethodInfo -glob $pattern] {
+ if {[lindex $Snit_typemethodInfo($name) 0] != 1} {
+ lappend result $name
+ }
+ }
+
+ # NEXT, add any from the cache that aren't explicit.
+ # WHD: fixed up to use newstyle method cache/list of subcommands.
+ if {[info exists Snit_typemethodInfo(*)]} {
+ # First, remove "*" from the list.
+ set ndx [lsearch -exact $result "*"]
+ if {$ndx != -1} {
+ set result [lreplace $result $ndx $ndx]
+ }
+
+ # Next, get the type's -map
+ array set typemethodCache [namespace ensemble configure $type -map]
+
+ # Next, get matching names from the cache that we don't already
+ # know about.
+ foreach name [array names typemethodCache -glob $pattern] {
+ if {[lsearch -exact $result $name] == -1} {
+ lappend result $name
+ }
+ }
+ }
+
+ return $result
+}
+
+# $type info args
+#
+# Returns a method's list of arguments. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.typemethod.info.args {type method} {
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_typemethodInfo
+
+ if {![info exists Snit_typemethodInfo($method)]} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ foreach {flag cmd component} $Snit_typemethodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated typemethod \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [lrange [::info args $theproc] 1 end]
+}
+
+# $type info body
+#
+# Returns a method's body. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.typemethod.info.body {type method} {
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_typemethodInfo
+
+ if {![info exists Snit_typemethodInfo($method)]} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ foreach {flag cmd component} $Snit_typemethodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated typemethod \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [RT.body [::info body $theproc]]
+}
+
+# $type info default
+#
+# Returns a method's list of arguments. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.typemethod.info.default {type method aname dvar} {
+ upvar 1 $dvar def
+ upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_methodInfo
+
+ if {![info exists Snit_typemethodInfo($method)]} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ foreach {flag cmd component} $Snit_typemethodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown typemethod \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated typemethod \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [::info default $theproc $aname def]
+}
+
+# Returns a list of the type's instances whose names match
+# a pattern.
+#
+# type A Snit type
+# pattern Optional. The glob pattern to match
+# Defaults to *
+#
+# REQUIRE: type is fully qualified.
+
+proc ::snit::RT.typemethod.info.instances {type {pattern *}} {
+ set result {}
+
+ foreach selfns [namespace children $type "${type}::Snit_inst*"] {
+ namespace upvar $selfns Snit_instance instance
+
+ if {[string match $pattern $instance]} {
+ lappend result $instance
+ }
+ }
+
+ return $result
+}
+
+#-----------------------------------------------------------------------
+# Instance Introspection
+
+# Implements the standard "info" method.
+#
+# type The snit type
+# selfns The instance's instance namespace
+# win The instance's original name
+# self The instance's current name
+# command The info subcommand
+# args All other arguments.
+
+proc ::snit::RT.method.info {type selfns win self command args} {
+ switch -exact $command {
+ args -
+ body -
+ default -
+ type -
+ vars -
+ options -
+ methods -
+ typevars -
+ typemethods {
+ set errflag [catch {
+ uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \
+ $type $selfns $win $self]
+ } result]
+
+ if {$errflag} {
+ global errorInfo
+ return -code error -errorinfo $errorInfo $result
+ } else {
+ return $result
+ }
+ }
+ default {
+ # error "\"$self info $command\" is not defined"
+ return -code error "\"$self info $command\" is not defined"
+ }
+ }
+}
+
+# $self info type
+#
+# Returns the instance's type
+proc ::snit::RT.method.info.type {type selfns win self} {
+ return $type
+}
+
+# $self info typevars
+#
+# Returns the instance's type's typevariables
+proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} {
+ return [RT.typemethod.info.typevars $type $pattern]
+}
+
+# $self info typemethods
+#
+# Returns the instance's type's typemethods
+proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} {
+ return [RT.typemethod.info.typemethods $type $pattern]
+}
+
+# Returns a list of the instance's methods whose names match a
+# pattern. If "delegate method *" is used, the list may
+# not be complete.
+#
+# type A Snit type
+# selfns The instance namespace
+# win The original instance name
+# self The current instance name
+# pattern Optional. The glob pattern to match. Defaults
+# to *.
+
+proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} {
+ variable ${type}::Snit_methodInfo
+
+ # FIRST, get the explicit names, skipping prefixes.
+ set result {}
+
+ foreach name [array names Snit_methodInfo -glob $pattern] {
+ if {[lindex $Snit_methodInfo($name) 0] != 1} {
+ lappend result $name
+ }
+ }
+
+ # NEXT, add any from the cache that aren't explicit.
+ # WHD: Fixed up to use newstyle method cache/list of subcommands.
+ if {[info exists Snit_methodInfo(*)]} {
+ # First, remove "*" from the list.
+ set ndx [lsearch -exact $result "*"]
+ if {$ndx != -1} {
+ set result [lreplace $result $ndx $ndx]
+ }
+
+ # Next, get the instance's -map
+ set self [set ${selfns}::Snit_instance]
+
+ array set methodCache [namespace ensemble configure $self -map]
+
+ # Next, get matching names from the cache that we don't already
+ # know about.
+ foreach name [array names methodCache -glob $pattern] {
+ if {[lsearch -exact $result $name] == -1} {
+ lappend result $name
+ }
+ }
+ }
+
+ return $result
+}
+
+# $self info args
+#
+# Returns a method's list of arguments. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.method.info.args {type selfns win self method} {
+
+ upvar ${type}::Snit_methodInfo Snit_methodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_methodInfo
+
+ if {![info exists Snit_methodInfo($method)]} {
+ return -code error "Unknown method \"$method\""
+ }
+ foreach {flag cmd component} $Snit_methodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown method \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated method \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [lrange [::info args $theproc] 4 end]
+}
+
+# $self info body
+#
+# Returns a method's body. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.method.info.body {type selfns win self method} {
+
+ upvar ${type}::Snit_methodInfo Snit_methodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ #parray Snit_methodInfo
+
+ if {![info exists Snit_methodInfo($method)]} {
+ return -code error "Unknown method \"$method\""
+ }
+ foreach {flag cmd component} $Snit_methodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown method \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated method \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [RT.body [::info body $theproc]]
+}
+
+# $self info default
+#
+# Returns a method's list of arguments. does not work for delegated
+# methods, nor for the internal dispatch methods of multi-word
+# methods.
+
+proc ::snit::RT.method.info.default {type selfns win self method aname dvar} {
+ upvar 1 $dvar def
+ upvar ${type}::Snit_methodInfo Snit_methodInfo
+
+ # Snit_methodInfo: method -> list (flag cmd component)
+
+ # flag : 1 -> internal dispatcher for multi-word method.
+ # 0 -> regular method
+ #
+ # cmd : template mapping from method to command prefix, may
+ # contain placeholders for various pieces of information.
+ #
+ # component : is empty for normal methods.
+
+ if {![info exists Snit_methodInfo($method)]} {
+ return -code error "Unknown method \"$method\""
+ }
+ foreach {flag cmd component} $Snit_methodInfo($method) break
+ if {$flag} {
+ return -code error "Unknown method \"$method\""
+ }
+ if {$component != ""} {
+ return -code error "Delegated method \"$method\""
+ }
+
+ set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
+ set theproc [lindex [string map $map $cmd] 0]
+ return [::info default $theproc $aname def]
+}
+
+# $self info vars
+#
+# Returns the instance's instance variables
+proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} {
+ set result {}
+ foreach name [info vars "${selfns}::$pattern"] {
+ set tail [namespace tail $name]
+ if {![string match "Snit_*" $tail]} {
+ lappend result $name
+ }
+ }
+
+ return $result
+}
+
+# $self info options
+#
+# Returns a list of the names of the instance's options
+proc ::snit::RT.method.info.options {type selfns win self {pattern *}} {
+ variable ${type}::Snit_optionInfo
+
+ # First, get the local and explicitly delegated options
+ set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)]
+
+ # If "configure" works as for Tk widgets, add the resulting
+ # options to the list. Skip excepted options
+ if {$Snit_optionInfo(starcomp) ne ""} {
+ namespace upvar $selfns Snit_components Snit_components
+
+ set logicalName $Snit_optionInfo(starcomp)
+ set comp $Snit_components($logicalName)
+
+ if {![catch {$comp configure} records]} {
+ foreach record $records {
+ set opt [lindex $record 0]
+ if {[lsearch -exact $result $opt] == -1 &&
+ [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
+ lappend result $opt
+ }
+ }
+ }
+ }
+
+ # Next, apply the pattern
+ set names {}
+
+ foreach name $result {
+ if {[string match $pattern $name]} {
+ lappend names $name
+ }
+ }
+
+ return $names
+}
+
+proc ::snit::RT.body {body} {
+ regsub -all ".*# END snit method prolog\n" $body {} body
+ return $body
+}
--- /dev/null
+Snit Modules
+----------------------------------------------------------------------
+
+snit.tcl Loader for Snit 1.x
+ main1.tcl Compiler, runtime for Snit 1.x, Tcl 8.4 and later
+ main1_83.tcl Compiler, runtime for Snit 1.x, Tcl 8.3
+
+snit2.tcl Loader for Snit 2.x
+ main2.tcl Compiler, runtime for Snit 2.x, Tcl 8.5 and later
+
+validate.tcl Snit validation types, Snit 1.x *and* Snit 2.x
--- /dev/null
+if {[package vsatisfies [package provide Tcl] 8.5]} {
+ package ifneeded snit 2.3.2 \
+ [list source [file join $dir snit2.tcl]]
+}
+
+package ifneeded snit 1.4.2 [list source [file join $dir snit.tcl]]
--- /dev/null
+This is a roadmap to the code layout in snit.tcl.
+
+Package Definition
+* package provide
+* ::snit:: namespace definition; exports Snit commands.
+
+Major Variable Definitions (this includes a whole lot of code)
+* ::snit:: variable definitions:
+ * reservedArgs
+ * prettyStackTrace Not used currently
+
+* ::snit::typeTemplate Template code shared by all Snit types.
+ As the type definition is parsed, it
+ produced text that gets inserted into
+ this template; then the template is
+ evaluated as though it were sourced
+ from a normal .tcl file.
+ * Type namespace definition
+ * User's typevariable definitions
+ * Commands for use in type code
+ * alias installhull
+ * alias install
+ * alias typevariable
+ * alias variable
+ * alias mytypevar
+ * alias typevarname Deprecated
+ * alias myvar
+ * alias varname Deprecated
+ * alias myproc
+ * alias codename Deprecated
+ * alias mymethod
+ * alias mytypemethod
+ * alias from
+ * Snit's internal variables
+ * See dictionary.txt
+ * Template Code -- Stuff that gets filled in.
+ * proc Snit_instanceVars Initializes instance variables
+ * proc Snit_typeconstructor
+ * Default Procs -- Stuff that's sometimes replaced.
+ * proc Snit_constructor The default constructor
+ * proc Snit_destructor The default destructor (empty)
+ * %COMPILEDDEFS%
+ * Call the Type Constructor
+
+* ::snit::nominalTypeProc Template for the normal type proc.
+* ::snit::simpleTypeProc Template for the simple type proc.
+ This is used when "-hastypemethods no";
+ all it does is create instances.
+
+* ::snit::nominalInstanceProc Template for the body of the normal
+ instance proc. Supports method
+ caching, delegation, etc.
+* ::snit::simpleInstanceProc Template for the body of the simple
+ instance proc, used when
+ "-simpledispatch yes". Doesn't
+ support delegation, upvar,
+ hierarchical methods, or exotic return
+ types.
+
+* Snit compilation variables
+ * compiler The name of the slave interpreter used
+ to "compile" type definitions
+ * compile Array, accumulates results of
+ "compiling" type definitions
+ * reservedwords List of names that can't be used as
+ macros. Basically, any command
+ defined before the first macro.
+
+Compilation Commands
+* proc ::snit::Comp.Init
+* proc ::snit::Comp.Compile
+* proc ::snit::Comp.SaveOptionInfo
+* proc ::snit::Comp.Define
+* proc ::snit::Comp.statement.pragma
+* proc ::snit::Comp.statement.widgetclass
+* proc ::snit::Comp.statement.hulltype
+* proc ::snit::Comp.statement.constructor
+* proc ::snit::Comp.statement.destructor
+* proc ::snit::Comp.statement.option
+* proc ::snit::Comp.OptionNameIsValid
+* proc ::snit::Comp.statement.oncget
+* proc ::snit::Comp.statement.onconfigure
+* proc ::snit::Comp.statement.method
+* proc ::snit::Comp.CheckMethodName
+* proc ::snit::Comp.statement.typemethod
+* proc ::snit::Comp.statement.typeconstructor
+* proc ::snit::Comp.statement.proc
+* proc ::snit::Comp.statement.typevariable
+* proc ::snit::Comp.statement.variable
+* proc ::snit::Comp.statement.typecomponent
+* proc ::snit::Comp.DefineTypeComponent
+* proc ::snit::Comp.statement.component
+* proc ::snit::Comp.DefineComponent
+* proc ::snit::Comp.statement.delegate
+* proc ::snit::Comp.DelegatedTypemethod
+* proc ::snit::Comp.DelegatedMethod
+* proc ::snit::Comp.DelegatedOption
+* proc ::snit::Comp.statement.expose
+
+Public Commands
+* proc ::snit::compile
+* proc ::snit::type
+* proc ::snit::widgetadaptor
+* proc ::snit::widget
+* proc ::snit::typemethod
+* proc ::snit::method
+* proc ::snit::macro
+
+Utility Commands
+* proc ::snit::Expand
+* proc ::snit::Mappend
+* proc ::snit::CheckArgs
+* proc ::snit::Contains
+* proc ::snit::Capitalize
+* proc ::snit::Listify
+
+Snit Runtime Library
+
+The commands defined here are used by Snit-generated code at run-time
+rather than compile time.
+
+* Object Creation
+** ::snit::RT.type.typemethod.create
+** ::snit::RT.widget.typemethod.create
+** ::snit::RT.MakeInstanceCommand
+** ::snit::RT.InstanceTrace
+** ::snit::RT.ConstructInstance
+** ::snit::RT.UniqueName
+** ::snit::RT.UniqueInstanceNamespace
+** ::snit::RT.OptionDbGet
+* Object Destruction
+** ::snit::RT.method.destroy
+** ::snit::RT.DestroyObject
+** ::snit::RT.RemoveInstanceTrace
+* Typecomponent Management and Typemethod Caching
+** ::snit::RT.TypecomponentTrace
+** ::snit::RT.CacheTypemethodCommand
+* Component Management and Method Caching
+** ::snit::RT.Component
+** ::snit::RT.ComponentTrace
+** ::snit::RT.CacheMethodCommand
+** ::snit::RT.LookupMethodCommand
+** ::snit::RT.ClearInstanceCaches
+* Component Installation
+** ::snit::RT.installhull
+** ::snit::RT.install
+* Method/Variable Name Qualification
+** ::snit::RT.variable
+** ::snit::RT.mytypevar
+** ::snit::RT.myvar
+** ::snit::RT.myproc
+** ::snit::RT.codename
+** ::snit::RT.mytypemethod
+** ::snit::RT.mymethod
+** ::snit::RT.CallInstance
+* Utilities
+** ::snit::RT.from
+* Type Destruction
+** ::snit::RT.typemethod.destroy
+* Option Handling
+** ::snit::RT.method.cget
+** ::snit::RT.CacheCgetCommand
+** ::snit::RT.method.configurelist
+** ::snit::RT.CacheConfigureCommand
+** ::snit::RT.method.configure
+** ::snit::RT.GetOptionDbSpec
+* Type Introspection
+** ::snit::RT.typemethod.info
+** ::snit::RT.typemethod.info.typevars
+** ::snit::RT.typemethod.info.typemethods
+** ::snit::RT.typemethod.info.instances
+* Instance Introspection
+** ::snit::RT.method.info
+** ::snit::RT.method.info.type
+** ::snit::RT.method.info.typevars
+** ::snit::RT.method.info.typemethods
+** ::snit::RT.method.info.methods
+** ::snit::RT.method.info.vars
+** ::snit::RT.method.info.options
+
--- /dev/null
+This is a roadmap to the code layout in snit.tcl.
+
+Package Definition
+* package provide
+* ::snit:: namespace definition; exports Snit commands.
+
+Major Variable Definitions (this includes a whole lot of code)
+* ::snit:: variable definitions:
+ * reservedArgs
+ * prettyStackTrace Not used currently
+
+* ::snit::typeTemplate Template code shared by all Snit types.
+ As the type definition is parsed, it
+ produced text that gets inserted into
+ this template; then the template is
+ evaluated as though it were sourced
+ from a normal .tcl file.
+ * Type namespace definition
+ * User's typevariable definitions
+ * Commands for use in type code
+ * alias installhull
+ * alias install
+ * alias typevariable
+ * alias variable
+ * alias mytypevar
+ * alias typevarname Deprecated
+ * alias myvar
+ * alias varname Deprecated
+ * alias myproc
+ * alias codename Deprecated
+ * alias mymethod
+ * alias mytypemethod
+ * alias from
+ * Snit's internal variables
+ * See dictionary.txt
+ * Template Code -- Stuff that gets filled in.
+ * proc Snit_instanceVars Initializes instance variables
+ * proc Snit_typeconstructor
+ * Default Procs -- Stuff that's sometimes replaced.
+ * proc Snit_constructor The default constructor
+ * proc Snit_destructor The default destructor (empty)
+ * %COMPILEDDEFS%
+ * Call the Type Constructor
+
+* ::snit::nominalTypeProc Template for the normal type proc.
+* ::snit::simpleTypeProc Template for the simple type proc.
+ This is used when "-hastypemethods no";
+ all it does is create instances.
+
+* ::snit::nominalInstanceProc Template for the body of the normal
+ instance proc. Supports method
+ caching, delegation, etc.
+* ::snit::simpleInstanceProc Template for the body of the simple
+ instance proc, used when
+ "-simpledispatch yes". Doesn't
+ support delegation, upvar,
+ hierarchical methods, or exotic return
+ types.
+
+* Snit compilation variables
+ * compiler The name of the slave interpreter used
+ to "compile" type definitions
+ * compile Array, accumulates results of
+ "compiling" type definitions
+ * reservedwords List of names that can't be used as
+ macros. Basically, any command
+ defined before the first macro.
+
+Compilation Commands
+* proc ::snit::Comp.Init
+* proc ::snit::Comp.Compile
+* proc ::snit::Comp.SaveOptionInfo
+* proc ::snit::Comp.Define
+* proc ::snit::Comp.statement.pragma
+* proc ::snit::Comp.statement.widgetclass
+* proc ::snit::Comp.statement.hulltype
+* proc ::snit::Comp.statement.constructor
+* proc ::snit::Comp.statement.destructor
+* proc ::snit::Comp.statement.option
+* proc ::snit::Comp.OptionNameIsValid
+* proc ::snit::Comp.statement.oncget
+* proc ::snit::Comp.statement.onconfigure
+* proc ::snit::Comp.statement.method
+* proc ::snit::Comp.CheckMethodName
+* proc ::snit::Comp.statement.typemethod
+* proc ::snit::Comp.statement.typeconstructor
+* proc ::snit::Comp.statement.proc
+* proc ::snit::Comp.statement.typevariable
+* proc ::snit::Comp.statement.variable
+* proc ::snit::Comp.statement.typecomponent
+* proc ::snit::Comp.DefineTypeComponent
+* proc ::snit::Comp.statement.component
+* proc ::snit::Comp.DefineComponent
+* proc ::snit::Comp.statement.delegate
+* proc ::snit::Comp.DelegatedTypemethod
+* proc ::snit::Comp.DelegatedMethod
+* proc ::snit::Comp.DelegatedOption
+* proc ::snit::Comp.statement.expose
+
+Public Commands
+* proc ::snit::compile
+* proc ::snit::type
+* proc ::snit::widgetadaptor
+* proc ::snit::widget
+* proc ::snit::typemethod
+* proc ::snit::method
+* proc ::snit::macro
+
+Utility Commands
+* proc ::snit::Expand
+* proc ::snit::Mappend
+* proc ::snit::CheckArgs
+* proc ::snit::Capitalize
+
+Snit Runtime Library
+
+The commands defined here are used by Snit-generated code at run-time
+rather than compile time.
+
+* Object Creation
+** ::snit::RT.type.typemethod.create
+** ::snit::RT.widget.typemethod.create
+** ::snit::RT.MakeInstanceCommand
+** ::snit::RT.InstanceTrace
+** ::snit::RT.ConstructInstance
+** ::snit::RT.UniqueName
+** ::snit::RT.UniqueInstanceNamespace
+** ::snit::RT.OptionDbGet
+* Object Destruction
+** ::snit::RT.method.destroy
+** ::snit::RT.DestroyObject
+** ::snit::RT.RemoveInstanceTrace
+* Typecomponent Management and Typemethod Caching
+** ::snit::RT.TypecomponentTrace
+** ::snit::RT.UnknownTypemethod
+* Component Management and Method Caching
+** ::snit::RT.Component
+** ::snit::RT.ComponentTrace
+** ::snit::RT.UnknownMethod
+** ::snit::RT.ClearInstanceCaches
+* Component Installation
+** ::snit::RT.installhull
+** ::snit::RT.install
+* Method/Variable Name Qualification
+** ::snit::RT.variable
+** ::snit::RT.mytypevar
+** ::snit::RT.myvar
+** ::snit::RT.myproc
+** ::snit::RT.codename
+** ::snit::RT.mytypemethod
+** ::snit::RT.mymethod
+** ::snit::RT.CallInstance
+* Utilities
+** ::snit::RT.from
+* Type Destruction
+** ::snit::RT.typemethod.destroy
+* Option Handling
+** ::snit::RT.method.cget
+** ::snit::RT.CacheCgetCommand
+** ::snit::RT.method.configurelist
+** ::snit::RT.CacheConfigureCommand
+** ::snit::RT.method.configure
+** ::snit::RT.GetOptionDbSpec
+* Type Introspection
+** ::snit::RT.typemethod.info
+** ::snit::RT.typemethod.info.typevars
+** ::snit::RT.typemethod.info.typemethods
+** ::snit::RT.typemethod.info.instances
+* Instance Introspection
+** ::snit::RT.method.info
+** ::snit::RT.method.info.type
+** ::snit::RT.method.info.typevars
+** ::snit::RT.method.info.typemethods
+** ::snit::RT.method.info.methods
+** ::snit::RT.method.info.vars
+** ::snit::RT.method.info.options
+
--- /dev/null
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin snit n 2.3.2]
+[copyright {2003-2009, by William H. Duquette}]
+[moddesc {Snit's Not Incr Tcl, OO system}]
+[titledesc {Snit's Not Incr Tcl}]
+[category {Programming tools}]
+[require Tcl 8.5]
+[require snit [opt 2.3.2]]
+[description]
+[para]
+
+Snit is a pure Tcl object and megawidget system. It's
+unique among Tcl object systems in that it's based not on inheritance
+but on delegation. Object systems based on inheritance only allow you
+to inherit from classes defined using the same system, which is
+limiting. In Tcl, an object is
+anything that acts like an object; it shouldn't matter how the object
+was implemented. Snit is intended to help you build applications out of
+the materials at hand; thus, Snit is designed to be able to
+incorporate and build on any object, whether it's a hand-coded object,
+a [package Tk] widget, an [package {Incr Tcl}] object,
+a [package BWidget] or almost anything else.
+
+[para]
+
+This man page is intended to be a reference only; see the accompanying
+[cmd snitfaq] for a gentler, more tutorial introduction to Snit
+concepts.
+
+[section {SNIT VERSIONS}]
+
+This man page covers both Snit 2.2 and Snit 1.3. The primary
+difference between the two versions is simply that Snit 2.2 contains
+speed optimizations based on new features of Tcl 8.5; Snit 1.3
+supports all of Tcl 8.3, 8.4 and Tcl 8.5. There are a few minor
+inconsistencies; they are flagged in the body of the man page with the
+label "Snit 1.x Incompatibility"; they are also discussed in the [cmd snitfaq].
+
+[para]
+
+[section REFERENCE]
+
+[subsection {Type and Widget Definitions}]
+
+Snit provides the following commands for defining new types:
+
+[list_begin definitions]
+
+[call [cmd snit::type] [arg name] [arg definition]]
+
+Defines a new abstract data type called [arg name]. If [arg name] is
+not a fully qualified command name, it is assumed to be a name in the
+namespace in which the [cmd snit::type] command was called (usually the
+global namespace). It returns the fully qualified name of the new type.
+
+[para]
+
+The type name is then a command that is used to create objects of the
+new type, along with other activities.
+
+[para]
+
+The [cmd snit::type] [arg definition] block is a script that may
+contain the following definitions:
+
+[list_begin definitions]
+[call [cmd typevariable] [arg name] [opt [const -array]] [opt [arg value]]]
+
+Defines a type variable with the specified [arg name], and optionally
+the specified [arg value]. Type variables are shared by all instances
+of the type. If the [const -array] option is included, then
+[arg value] should be a dictionary; it will be
+assigned to the variable using [cmd "array set"].
+
+[call [cmd typemethod] [arg name] [arg arglist] [arg body]]
+
+Defines a type method, a subcommand of the new type command,
+with the specified name, argument list, and
+body. The [arg arglist] is a normal Tcl argument list and may contain
+default arguments and the [var args] argument; however, it may not
+contain the argument names [var type], [var self], [var selfns], or
+[var win].
+
+[para]
+
+The variable [var type] is automatically defined in the [arg body] to
+the type's fully-qualified name. In addition,
+type variables are automatically visible in the [arg body]
+of every type method.
+
+[para]
+
+If the [arg name] consists of two or more tokens, Snit handles it specially:
+
+[example { typemethod {a b} {arg} { puts "Got $arg" }
+}]
+
+This statement implicitly defines a type method called [const a] which
+has a subcommand [const b]. [const b] is called like this:
+
+[example { $type a b "Hello, world!"
+}]
+
+[const a] may have any number of subcommands. This makes it possible
+to define a hierarchical command structure; see [cmd method], below,
+for more examples.
+
+[para]
+
+Type methods can call commands from the namespace in which the type is
+defined without importing them, e.g., if the type name is
+[cmd ::parentns::typename], then the type's type methods can call
+[cmd ::parentns::someproc] just as [cmd someproc].
+[emph {Snit 1.x Incompatibility:}] This does not work in Snit 1.x, as
+it depends on [cmd "namespace path"], a new command in Tcl 8.5.
+
+[para]
+
+[emph {Snit 1.x Incompatibility:}] In Snit 1.x, the following
+following two calls to this type method are equivalent:
+
+[example { $type a b "Hello, world!"
+ $type {a b} "Hello, world!"
+}]
+
+In Snit 2.2, the second form is invalid.
+
+[call [cmd typeconstructor] [arg body]]
+
+The type constructor's [arg body] is executed once when the
+type is first defined; it is typically used to
+initialize array-valued type variables and to add
+entries to [sectref {The Tk Option Database}].
+
+[para]
+
+The variable [var type] is automatically defined in the [arg body],
+and contains the type's fully-qualified name. In addition,
+type variables are automatically visible in the [arg body] of the type
+constructor.
+
+[para]
+
+A type may define at most one type constructor.
+
+[para]
+
+The type constructor can call commands from the namespace in which the type is
+defined without importing them, e.g., if the type name is
+[cmd ::parentns::typename], then the type constructor can call
+[cmd ::parentns::someproc] just as [cmd someproc].
+[emph {Snit 1.x Incompatibility:}] This does not work in Snit 1.x, as
+it depends on [cmd "namespace path"], a new command in Tcl 8.5.
+
+[call [cmd variable] [arg name] [opt [const -array]] [opt [arg value]]]
+
+Defines an instance variable, a private variable associated with each
+instance of this type, and optionally its initial value.
+If the [const -array] option is included, then
+[arg value] should be a dictionary; it will be
+assigned to the variable using [cmd "array set"].
+
+[call [cmd method] [arg name] [arg arglist] [arg body]]
+
+Defines an instance method, a subcommand of each instance of this
+type, with the specified name, argument list and body.
+The [arg arglist] is a normal Tcl argument list and may contain
+default arguments and the [var args] argument.
+
+[para]
+
+The method is implicitly passed the following arguments as well:
+
+[var type], which contains the fully-qualified type name; [var self],
+which contains the current instance command name; [var selfns], which
+contains the name of the instance's private namespace; and [var win],
+which contains the original instance name.
+
+Consequently, the [arg arglist] may not contain the argument names
+[const type], [const self], [const selfns], or [const win].
+
+[para]
+
+An instance method defined in this way is said to be
+[term {locally defined}].
+
+[para]
+
+Type and instance variables are
+automatically visible in all instance methods. If the type has
+locally defined options, the [var options] array is also visible.
+
+[para]
+
+If the [arg name] consists of two or more tokens, Snit handles it specially:
+
+[example { method {a b} {} { ... }
+}]
+
+This statement implicitly defines a method called [const a] which
+has a subcommand [const b]. [const b] is called like this:
+
+[example { $self a b "Hello, world!"
+}]
+
+[const a] may have any number of subcommands. This makes it possible
+to define a hierarchical command structure:
+
+[example {% snit::type dog {
+ method {tail wag} {} {return "Wag, wag"}
+ method {tail droop} {} {return "Droop, droop"}
+}
+::dog
+% dog spot
+::spot
+% spot tail wag
+Wag, wag
+% spot tail droop
+Droop, droop
+%
+}]
+
+What we've done is implicitly defined a "tail" method with subcommands
+"wag" and "droop". Consequently, it's an error to define "tail"
+explicitly.
+
+[para]
+
+Methods can call commands from the namespace in which the type is
+defined without importing them, e.g., if the type name is
+[cmd ::parentns::typename], then the type's methods can call
+[cmd ::parentns::someproc] just as [cmd someproc].
+[emph {Snit 1.x Incompatibility:}] This does not work in Snit 1.x, as
+it depends on [cmd "namespace path"], a new command in Tcl 8.5.
+
+[para]
+
+[emph {Snit 1.x Incompatibility:}] In Snit 1.x, the following
+following two calls to this method are equivalent:
+
+[example { $self a b "Hello, world!"
+ $self {a b} "Hello, world!"
+}]
+
+In Snit 2.2, the second form is invalid.
+
+[call [cmd option] [arg namespec] [opt [arg defaultValue]]]
+[call [cmd option] [arg namespec] [opt [arg options...]]]
+
+Defines an option for instances of this type, and optionally gives it
+an initial value. The initial value defaults to the empty string if
+no [arg defaultValue] is specified.
+
+[para]
+
+An option defined in this way is said to be [term {locally defined}].
+
+[para]
+
+The [arg namespec] is a list defining the option's
+name, resource name, and class name, e.g.:
+
+[example { option {-font font Font} {Courier 12}
+}]
+
+The option name must begin with a hyphen, and must not contain any
+upper case letters. The resource name and class name are optional; if
+not specified, the resource name defaults to the option name, minus
+the hyphen, and the class name defaults to the resource name with the
+first letter capitalized. Thus, the following statement is equivalent
+to the previous example:
+
+[example { option -font {Courier 12}
+}]
+
+See [sectref {The Tk Option Database}] for more information about
+resource and class names.
+
+[para]
+
+Options are normally set and retrieved using the standard
+instance methods [method configure] and [method cget]; within instance code
+(method bodies, etc.), option values are available through the
+[var options] array:
+
+[example { set myfont $options(-font)
+}]
+
+If the type defines any option handlers (e.g., [const -configuremethod]),
+then it should probably use [method configure] and [method cget] to
+access its options to avoid subtle errors.
+
+[para]
+
+The [cmd option] statement may include the following options:
+
+[list_begin definitions]
+[def "[const -default] [arg defvalue]"]
+
+Defines the option's default value; the option's default value
+will be "" otherwise.
+
+[def "[const -readonly] [arg flag]"]
+
+The [arg flag] can be any Boolean value recognized by Tcl.
+If [arg flag] is true, then the option is read-only--it can only
+be set using [method configure] or [method configurelist]
+at creation time, i.e., in the type's constructor.
+
+[def "[const -type] [arg type]"]
+
+Every locally-defined option may define its validation type, which may
+be either the name of a validation type or a specification for a
+validation subtype
+
+[para]
+
+For example, an option may declare that its value must be an integer
+by specifying [cmd snit::integer] as its validation type:
+
+[example { option -number -type snit::integer
+}]
+
+It may also declare that its value is an integer between 1 and 10
+by specifying a validation subtype:
+
+[example { option -number -type {snit::integer -min 1 -max 10}
+}]
+
+If a validation type or subtype is defined for an option, then
+it will be used to validate the option's value whenever it is
+changed by the object's [method configure] or
+[method configurelist] methods. In addition, all such options
+will have their values validated automatically immediately
+after the constructor executes.
+
+[para]
+
+Snit defines a family of validation types and subtypes, and it's
+quite simple to define new ones. See
+[sectref "Validation Types"] for the complete list, and
+[sectref "Defining Validation Types"] for an explanation of how
+to define your own.
+
+[def "[const -cgetmethod] [arg methodName]"]
+
+Every locally-defined option may define a [const -cgetmethod];
+it is called when the option's value is retrieved using the
+[method cget] method. Whatever the method's [arg body] returns will
+be the return value of the call to [method cget].
+
+[para]
+
+The named method must take one argument, the option name.
+For example, this code is equivalent to (though slower than)
+Snit's default handling of [cmd cget]:
+
+[example { option -font -cgetmethod GetOption
+ method GetOption {option} {
+ return $options($option)
+ }
+}]
+
+Note that it's possible for any number of options to share a
+[const -cgetmethod].
+
+[def "[const -configuremethod] [arg methodName]"]
+
+Every locally-defined option may define a [const -configuremethod];
+it is called when the option's value is set using the
+[method configure] or [method configurelist] methods. It is the
+named method's responsibility to save the option's value; in other
+words, the value will not be saved to the [var options()] array unless
+the method saves it there.
+
+[para]
+
+The named method must take two arguments, the option name and
+its new value. For example, this code is equivalent to
+(though slower than) Snit's default handling of [cmd configure]:
+
+[example { option -font -configuremethod SetOption
+ method SetOption {option value} {
+ set options($option) $value
+ }
+}]
+
+Note that it's possible for any number of options to share a
+single [const -configuremethod].
+
+[def "[const -validatemethod] [arg methodName]"]
+
+Every locally-defined option may define a [const -validatemethod];
+it is called when the option's value is set using the
+[method configure] or [method configurelist] methods, just before
+the [const -configuremethod] (if any). It is the
+named method's responsibility to validate the option's new value,
+and to throw an error if the value is invalid.
+
+[para]
+
+The named method must take two arguments, the option name and
+its new value. For example, this code verifies that
+[const -flag]'s value is a valid Boolean value:
+
+[example { option -font -validatemethod CheckBoolean
+ method CheckBoolean {option value} {
+ if {![string is boolean -strict $value]} {
+ error "option $option must have a boolean value."
+ }
+ }
+}]
+
+Note that it's possible for any number of options to share a
+single [const -validatemethod].
+
+[list_end]
+
+[call [cmd constructor] [arg arglist] [arg body]]
+
+The constructor definition specifies a [arg body] of code to be
+executed when a new instance is created. The [arg arglist] is a
+normal Tcl argument list and may contain default arguments and
+the [var args] argument.
+
+[para]
+
+As with methods, the arguments [var type], [var self], [var selfns],
+and [var win] are defined implicitly, and all type and instance
+variables are automatically visible in its [arg body].
+
+[para]
+
+If the [arg definition] doesn't explicitly define the constructor,
+Snit defines one implicitly. If the type declares at least one option
+(whether locally or by delegation), the default constructor will
+be defined as follows:
+
+[example { constructor {args} {
+ $self configurelist $args
+ }
+}]
+
+For standard Tk widget behavior, the argument list should be
+the single name [const args], as shown.
+
+[para]
+
+If the [arg definition] defines neither a constructor nor
+any options, the default constructor is defined as follows:
+
+[example { constructor {} {}
+}]
+
+As with methods, the constructor can call commands from the namespace
+in which the type is
+defined without importing them, e.g., if the type name is
+[cmd ::parentns::typename], then the constructor can call
+[cmd ::parentns::someproc] just as [cmd someproc].
+[emph {Snit 1.x Incompatibility:}] This does not work in Snit 1.x, as
+it depends on [cmd "namespace path"], a new command in Tcl 8.5.
+
+[call [cmd destructor] [arg body]]
+
+The destructor is used to code any actions that must take place when
+an instance of the type is destroyed: typically, the destruction of
+anything created in the constructor.
+
+[para]
+
+The destructor takes no explicit arguments; as with methods, the
+arguments [var type], [var self], [var selfns], and [var win], are
+defined implicitly, and all type and instance
+variables are automatically visible in its [arg body].
+
+As with methods, the destructor can call commands from the namespace
+in which the type is
+defined without importing them, e.g., if the type name is
+[cmd ::parentns::typename], then the destructor can call
+[cmd ::parentns::someproc] just as [cmd someproc].
+[emph {Snit 1.x Incompatibility:}] This does not work in Snit 1.x, as
+it depends on [cmd "namespace path"], a new command in Tcl 8.5.
+
+[call [cmd proc] [arg name] [arg args] [arg body]]
+
+Defines a new Tcl procedure in the type's namespace.
+
+[para]
+
+The defined proc differs from a normal Tcl proc in that all type
+variables are automatically visible. The proc can access
+instance variables as well, provided that it is passed
+[var selfns] (with precisely that name) as one of its arguments.
+
+[para]
+
+Although they are not implicitly defined for procs, the argument names
+[const type], [const self], and [const win] should be avoided.
+
+[para]
+
+As with methods and typemethods, procs can call commands from the namespace
+in which the type is
+defined without importing them, e.g., if the type name is
+[cmd ::parentns::typename], then the proc can call
+[cmd ::parentns::someproc] just as [cmd someproc].
+[emph {Snit 1.x Incompatibility:}] This does not work in Snit 1.x, as
+it depends on [cmd "namespace path"], a new command in Tcl 8.5.
+
+[call [cmd delegate] [const method] [arg name] [const to] [arg comp] [opt "[const as] [arg target]"]]
+
+Delegates method [arg name] to component [arg comp]. That is, when
+method [arg name] is called on an instance of this type, the method
+and its arguments will be passed to the named component's command
+instead. That is, the following statement
+
+[example { delegate method wag to tail
+}]
+
+is roughly equivalent to this explicitly defined method:
+
+[example { method wag {args} {
+ uplevel $tail wag $args
+ }
+}]
+
+As with methods, the [arg name] may have multiple tokens; in this
+case, the last token of the name is assumed to be the name of the
+component's method.
+
+[para]
+
+The optional [const as] clause allows you to specify the delegated
+method name and possibly add some arguments:
+
+[example { delegate method wagtail to tail as "wag briskly"
+}]
+
+[para]
+
+A method cannot be both locally defined and delegated.
+
+[para]
+
+[const Note:] All forms of [cmd "delegate method"] can delegate to
+both instance components and type components.
+
+[call [cmd delegate] [const method] [arg name] [opt "[const to] [arg comp]"] [const using] [arg pattern]]
+
+In this form of the [cmd delegate] statement, the [const using] clause
+is used to specify the precise form of the command to which method
+[arg name] name is delegated. In this form, the [const "to"] clause is
+optional, since the chosen command might not involve any particular
+component.
+
+[para]
+
+The value of the [const using] clause is a list that may contain
+any or all of the following substitution codes; these codes are
+substituted with the described value to build the delegated command
+prefix. Note that the following two statements are equivalent:
+
+[example { delegate method wag to tail
+ delegate method wag to tail using "%c %m"
+}]
+
+Each element of the list becomes a single element of the delegated
+command--it is never reparsed as a string.
+
+[para]
+
+Substitutions:
+[list_begin definitions]
+[def [const %%]]
+
+This is replaced with a single "%". Thus, to pass the string "%c"
+to the command as an argument, you'd write "%%c".
+
+[def [const %c]]
+
+This is replaced with the named component's command.
+
+[def [const %m]]
+
+This is replaced with the final token of the method [arg name]; if
+the method [arg name] has one token, this is identical to [const %M].
+
+[def [const %M]]
+
+This is replaced by the method [arg name]; if the [arg name] consists
+of multiple tokens, they are joined by space characters.
+
+[def [const %j]]
+
+This is replaced by the method [arg name]; if the [arg name] consists
+of multiple tokens, they are joined by underscores ("_").
+
+[def [const %t]]
+
+This is replaced with the fully qualified type name.
+
+[def [const %n]]
+
+This is replaced with the name of the instance's private namespace.
+
+[def [const %s]]
+
+This is replaced with the name of the instance command.
+
+[def [const %w]]
+
+This is replaced with the original name of the instance command; for
+Snit widgets and widget adaptors, it will be the Tk window name.
+It remains constant, even if the instance command is renamed.
+
+[list_end]
+
+[call [cmd delegate] [const method] [const *] [opt "[const to] [arg comp]"] [opt "[const using] [arg pattern]"] [opt "[const except] [arg exceptions]"]]
+
+The form [cmd "delegate method *"] delegates all unknown method names to the
+specified [arg comp]onent. The [const except] clause can be used to
+specify a list of [arg exceptions], i.e., method names that will not
+be so delegated. The [const using] clause is defined as given above.
+In this form, the statement must contain the [const to] clause, the
+[const using] clause, or both.
+
+[para]
+
+In fact, the "*" can be a list of two or more tokens whose last
+element is "*", as in the following example:
+
+[example { delegate method {tail *} to tail
+}]
+
+This implicitly defines the method [cmd tail] whose subcommands will
+be delegated to the [var tail] component.
+
+[call [cmd delegate] [const option] [arg namespec] [const to] [arg comp]]
+[call [cmd delegate] [const option] [arg namespec] [const to] [arg comp] [const as] [arg target]]
+
+[call [cmd delegate] [const option] [const *] [const to] [arg comp]]
+[call [cmd delegate] [const option] [const *] [const to] [arg comp] [const except] [arg exceptions]]
+
+Defines a delegated option; the [arg namespec] is defined as for the
+[cmd option] statement.
+
+When the [method configure], [method configurelist], or [method cget]
+instance method is used to set or retrieve the option's value, the
+equivalent [method configure] or [method cget] command will be applied
+to the component as though the option was defined with the following
+[const -configuremethod] and [const -cgetmethod]:
+
+[example { method ConfigureMethod {option value} {
+ $comp configure $option $value
+ }
+
+ method CgetMethod {option} {
+ return [$comp cget $option]
+ }
+}]
+
+Note that delegated options never appear in the [var options] array.
+
+[para]
+
+If the [const as] clause is specified, then the [arg target] option
+name is used in place of [arg name].
+
+[para]
+
+The form [cmd "delegate option *"] delegates all unknown options to the
+specified [arg comp]onent. The [const except] clause can be used to
+specify a list of [arg exceptions], i.e., option names that will not
+be so delegated.
+
+[para]
+
+Warning: options can only be delegated to a component if it supports
+the [method configure] and [method cget] instance methods.
+
+[para]
+
+An option cannot be both locally defined and delegated.
+
+TBD: Continue from here.
+
+[call [cmd component] [arg comp] \
+ [opt "[const -public] [arg method]"] \
+ [opt "[const -inherit] [arg flag]"]]
+
+Explicitly declares a component called [arg comp], and automatically
+defines the component's instance variable.
+
+[para]
+
+If the [const -public] option is specified, then the option is made
+public by defining a [arg method] whose subcommands are delegated
+to the component e.g., specifying [const "-public mycomp"] is
+equivalent to the following:
+
+[example { component mycomp
+ delegate method {mymethod *} to mycomp
+}]
+
+If the [const -inherit] option is specified, then [arg flag] must be a
+Boolean value; if [arg flag] is true then all unknown methods and
+options will be delegated to this component. The name [const -inherit]
+implies that instances of this new type inherit, in a sense, the
+methods and options of the component. That is, [const "-inherit yes"] is
+equivalent to:
+
+[example { component mycomp
+ delegate option * to mycomp
+ delegate method * to mycomp
+}]
+
+[call [cmd delegate] [const typemethod] [arg name] [const to] [arg comp] [opt "[const as] [arg target]"]]
+
+Delegates type method [arg name] to type component [arg comp]. That is, when
+type method [arg name] is called on this type, the type method
+and its arguments will be passed to the named type component's command
+instead. That is, the following statement
+
+[example { delegate typemethod lostdogs to pound
+}]
+
+is roughly equivalent to this explicitly defined method:
+
+[example { typemethod lostdogs {args} {
+ uplevel $pound lostdogs $args
+ }
+}]
+
+As with type methods, the [arg name] may have multiple tokens; in this
+case, the last token of the name is assumed to be the name of the
+component's method.
+
+[para]
+
+The optional [const as] clause allows you to specify the delegated
+method name and possibly add some arguments:
+
+[example { delegate typemethod lostdogs to pound as "get lostdogs"
+}]
+
+[para]
+
+A type method cannot be both locally defined and delegated.
+
+[call [cmd delegate] [const typemethod] [arg name] [opt "[const to] [arg comp]"] [const using] [arg pattern]]
+
+In this form of the [cmd delegate] statement, the [const using] clause
+is used to specify the precise form of the command to which type method
+[arg name] name is delegated. In this form, the [const "to"] clause is
+optional, since the chosen command might not involve any particular
+type component.
+
+[para]
+
+The value of the [const using] clause is a list that may contain
+any or all of the following substitution codes; these codes are
+substituted with the described value to build the delegated command
+prefix. Note that the following two statements are equivalent:
+
+[example { delegate typemethod lostdogs to pound
+ delegate typemethod lostdogs to pound using "%c %m"
+}]
+
+Each element of the list becomes a single element of the delegated
+command--it is never reparsed as a string.
+
+[para]
+
+Substitutions:
+[list_begin definitions]
+[def [const %%]]
+
+This is replaced with a single "%". Thus, to pass the string "%c"
+to the command as an argument, you'd write "%%c".
+
+[def [const %c]]
+
+This is replaced with the named type component's command.
+
+[def [const %m]]
+
+This is replaced with the final token of the type method [arg name]; if
+the type method [arg name] has one token, this is identical to [const %M].
+
+[def [const %M]]
+
+This is replaced by the type method [arg name]; if the [arg name] consists
+of multiple tokens, they are joined by space characters.
+
+[def [const %j]]
+
+This is replaced by the type method [arg name]; if the [arg name] consists
+of multiple tokens, they are joined by underscores ("_").
+
+[def [const %t]]
+
+This is replaced with the fully qualified type name.
+
+[list_end]
+
+[call [cmd delegate] [const typemethod] [const *] [opt "[const to] [arg comp]"] \
+ [opt "[const using] [arg pattern]"] [opt "[const except] [arg exceptions]"]]
+
+The form [cmd "delegate typemethod *"] delegates all unknown type
+method names to the
+specified type component. The [const except] clause can be used to
+specify a list of [arg exceptions], i.e., type method names that will not
+be so delegated. The [const using] clause is defined as given above.
+In this form, the statement must contain the [const to] clause, the
+[const using] clause, or both.
+
+[para]
+
+[const Note:] By default, Snit interprets [cmd "\$type foo"], where
+[const "foo"] is
+not a defined type method, as equivalent to [cmd "\$type create foo"], where
+[const "foo"] is the name of a new instance of the type. If you
+use [const "delegate typemethod *"], then the [method "create"] type
+method must always be used explicitly.
+
+[para]
+
+The "*" can be a list of two or more tokens whose last
+element is "*", as in the following example:
+
+[example { delegate typemethod {tail *} to tail
+}]
+
+This implicitly defines the type method [cmd tail] whose subcommands will
+be delegated to the [var tail] type component.
+
+[call [cmd typecomponent] [arg comp] \
+ [opt "[const -public] [arg typemethod]"] \
+ [opt "[const -inherit] [arg flag]"]]
+
+Explicitly declares a type component called [arg comp], and automatically
+defines the component's type variable. A type component is an arbitrary
+command to which type methods and instance methods can be delegated;
+the command's name is stored in a type variable.
+
+[para]
+
+If the [const -public] option is specified, then the type component is made
+public by defining a [arg typemethod] whose subcommands are delegated to
+the type component, e.g., specifying [const "-public mytypemethod"]
+is equivalent to the following:
+
+[example { typecomponent mycomp
+ delegate typemethod {mytypemethod *} to mycomp
+}]
+
+If the [const -inherit] option is specified, then [arg flag] must be a
+Boolean value; if [arg flag] is true then all unknown type methods
+will be delegated to this type component. (See the note on "delegate
+typemethod *", above.) The name [const -inherit]
+implies that this type inherits, in a sense, the behavior of
+the type component. That is, [const "-inherit yes"] is equivalent to:
+
+[example { typecomponent mycomp
+ delegate typemethod * to mycomp
+}]
+
+[call [cmd pragma] [opt [arg options...]]]
+
+The [cmd pragma] statement provides control over how Snit generates a
+type. It takes the following options; in each case, [arg flag] must
+be a Boolean value recognized by Tcl, e.g., [const 0], [const 1],
+[const "yes"], [const "no"], and so
+on.
+
+[para]
+
+By setting the [const -hastypeinfo], [const -hastypedestroy], and
+[const -hasinstances] pragmas to false and defining appropriate
+type methods, you can create an ensemble command without any extraneous
+behavior.
+
+[list_begin definitions]
+[def "[const -canreplace] [arg flag]"]
+
+If false (the default) Snit will not create an instance of a
+[cmd snit::type] that has the same name as an existing command; this
+prevents subtle errors. Setting this pragma to true restores the
+behavior of Snit V0.93 and earlier versions.
+
+[def "[const -hastypeinfo] [arg flag]"]
+
+If true (the default), the generated type will have a type method
+called [cmd info] that is used for type introspection; the [cmd info]
+type method is documented below. If false, it will not.
+
+[def "[const -hastypedestroy] [arg flag]"]
+
+If true (the default), the generated type will have a type method
+called [cmd destroy] that is used to destroy the type and all of its
+instances. The [cmd destroy] type method is documented below. If
+false, it will not.
+
+[def "[const -hastypemethods] [arg flag]"]
+
+If true (the default), the generated type's type command will have
+subcommands (type methods) as usual. If false, the type command
+will serve only to create instances of the type; the first argument
+is the instance name.
+
+[para]
+
+This pragma and [const -hasinstances] cannot both be set false.
+
+[def "[const -hasinstances] [arg flag]"]
+
+If true (the default), the generated type will have a type method
+called [cmd create] that is used to create instances of the type,
+along with a variety of instance-related features. If false, it will
+not.
+
+[para]
+
+This pragma and [const -hastypemethods] cannot both be set false.
+
+[def "[const -hasinfo] [arg flag]"]
+
+If true (the default), instances of the generated type will have
+an instance method called [method info] that is used for
+instance introspection; the [method info]
+method is documented below. If false, it will not.
+
+[def "[const -simpledispatch] [arg flag]"]
+
+This pragma is intended to make simple, heavily-used abstract
+data types (e.g., stacks and queues) more efficient.
+
+[para]
+
+If false (the default), instance methods are dispatched normally. If
+true, a faster dispatching scheme is used instead.
+The speed comes at a price; with [const "-simpledispatch yes"] you
+get the following limitations:
+
+[list_begin itemized]
+
+[item] Methods cannot be delegated.
+[item] [cmd uplevel] and [cmd upvar] do not work as expected: the
+caller's scope is two levels up rather than one.
+[item] The option-handling methods
+([cmd cget], [cmd configure], and [cmd configurelist]) are very
+slightly slower.
+[list_end]
+
+[list_end]
+
+[call [cmd expose] [arg comp]]
+[call [cmd expose] [arg comp] [const as] [arg method]]
+
+[comment {
+ The word "Deprecated" really needs to be boldface, and
+ there's no good way to do it, so I'm using "const".
+}]
+
+[const Deprecated.] To expose component [arg comp] publicly, use
+[cmd component]'s [const -public] option.
+
+[call [cmd onconfigure] [arg name] [arg arglist] [arg body]]
+
+[const Deprecated.] Define [cmd option]'s [const -configuremethod]
+option instead.
+
+[para]
+
+As of version 0.95, the following definitions,
+
+[example { option -myoption
+ onconfigure -myoption {value} {
+ # Code to save the option's value
+ }
+}]
+
+are implemented as follows:
+
+[example { option -myoption -configuremethod _configure-myoption
+ method _configure-myoption {_option value} {
+ # Code to save the option's value
+ }
+}]
+
+[call [cmd oncget] [arg name] [arg body]]
+
+[const Deprecated.] Define [cmd option]'s [const -cgetmethod]
+option instead.
+
+[para]
+
+As of version 0.95, the following definitions,
+
+[example { option -myoption
+ oncget -myoption {
+ # Code to return the option's value
+ }
+}]
+
+are implemented as follows:
+
+[example { option -myoption -cgetmethod _cget-myoption
+ method _cget-myoption {_option} {
+ # Code to return the option's value
+ }
+}]
+
+[list_end]
+
+
+[call [cmd snit::widget] [arg name] [arg definition]]
+
+This command defines a Snit megawidget type with the specified
+[arg name]. The [arg definition] is defined as for [cmd snit::type].
+ A [cmd snit::widget] differs from a [cmd snit::type]
+in these ways:
+
+[list_begin itemized]
+[item]
+
+Every instance of a [cmd snit::widget] has an automatically-created
+component called [var hull], which is normally a Tk frame widget.
+Other widgets created as part of the megawidget will be created within
+this widget.
+
+[para]
+
+The hull component is initially created with the requested widget
+name; then Snit does some magic, renaming the hull component and
+installing its own instance command in its place.
+
+The hull component's new name is saved in an instance variable called
+[var hull].
+
+[item]
+
+The name of an instance must be valid Tk window name, and the parent
+window must exist.
+
+[list_end]
+
+A [cmd snit::widget] definition can include any of statements allowed
+in a [cmd snit::type] definition, and may also include the following:
+
+[list_begin definitions]
+
+[call [cmd widgetclass] [arg name]]
+
+Sets the [cmd snit::widget]'s widget class to [arg name], overriding
+the default. See [sectref {The Tk Option Database}] for more
+information.
+
+[call [cmd hulltype] [arg type]]
+
+Determines the kind of widget used as the [cmd snit::widget]'s hull.
+The [arg type] may be [const frame] (the default), [const toplevel],
+[const labelframe]; the qualified equivalents of these,
+[const tk::frame], [const tk::toplevel], and [const tk::labelframe];
+or, if available, the equivalent Tile widgets:
+[const ttk::frame], [const ttk::toplevel], and
+[const ttk::labelframe]. In practice, any widget that supports the
+[const -class] option can be used as a hull widget by
+[cmd lappend]'ing its name to the variable [var snit::hulltypes].
+
+[list_end]
+
+[call [cmd snit::widgetadaptor] [arg name] [arg definition]]
+
+This command defines a Snit megawidget type with the specified name.
+It differs from [cmd snit::widget] in that the instance's [var hull]
+component is not created automatically, but is created in the
+constructor and installed using the [cmd installhull] command. Once
+the hull is installed, its instance command is renamed and replaced as
+with normal [cmd snit::widget]s. The original command is again
+accessible in the instance variable [var hull].
+
+[para]
+
+Note that in general it is not possible to change the
+[emph {widget class}] of a [cmd snit::widgetadaptor]'s hull widget.
+
+[para]
+
+See [sectref {The Tk Option Database}] for information on how
+[cmd snit::widgetadaptor]s interact with the option database.
+
+[call [cmd snit::typemethod] [arg type] [arg name] [arg arglist] [arg body]]
+
+Defines a new type method (or redefines an existing type method)
+for a previously existing [arg type].
+
+[call [cmd snit::method] [arg type] [arg name] [arg arglist] [arg body]]
+
+Defines a new instance method (or redefines an existing instance
+method) for a previously existing [arg type]. Note that delegated
+instance methods can't be redefined.
+
+[call [cmd snit::macro] [arg name] [arg arglist] [arg body]]
+
+Defines a Snit macro with the specified [arg name], [arg arglist], and
+[arg body]. Macros are used to define new type and widget
+definition statements in terms of the statements defined in this man
+page.
+
+[para]
+
+A macro is simply a Tcl proc that is defined in the slave interpreter
+used to compile type and widget definitions. Thus, macros have
+access to all of the type and widget definition statements. See
+[sectref "Macros and Meta-programming"] for more details.
+
+[para]
+
+The macro [arg name] cannot be the same as any standard Tcl command,
+or any Snit type or widget definition statement, e.g., you can't
+redefine the [cmd method] or [cmd delegate] statements, or the
+standard [cmd set], [cmd list], or [cmd string] commands.
+
+[call [cmd snit::compile] [arg which] [arg type] [arg body]]
+
+Snit defines a type, widget, or widgetadaptor by "compiling" the
+definition into a Tcl script; this script is then evaluated in the
+Tcl interpreter, which actually defines the new type.
+
+[para]
+
+This command exposes the "compiler". Given a definition [arg body]
+for the named [arg type], where [arg which] is [const type],
+[const widget], or [const widgetadaptor], [cmd snit::compile] returns a list
+of two elements. The first element is the fully qualified type name;
+the second element is the definition script.
+
+[para]
+
+[cmd snit::compile] is useful when additional processing
+must be done on the Snit-generated code--if it must be instrumented,
+for example, or run through the TclDevKit compiler. In addition, the
+returned script could be saved in a ".tcl" file and used to define the
+type as part of an application or library, thus saving the compilation
+overhead at application start-up. Note that the
+same version of Snit must be used at run-time as at compile-time.
+
+[list_end]
+
+[subsection {The Type Command}]
+
+A type or widget definition creates a type command, which is used to
+create instances of the type. The type command has this form:
+
+[para]
+[list_begin definitions]
+[call [cmd {$type}] [arg typemethod] [arg args]...]
+
+The [arg typemethod] can be any of the
+[sectref "Standard Type Methods"] (e.g., [method create]),
+or any type method defined in the type
+definition.
+
+The subsequent [arg args] depend on the specific [arg typemethod]
+chosen.
+
+[para]
+
+The type command is most often used to create new instances of the
+type; hence, the [method create] method is assumed if the first
+argument to the type command doesn't name a valid type method, unless
+the type definition includes [cmd "delegate typemethod *"] or the
+[const -hasinstances] pragma is set to false.
+
+[para]
+
+Furthermore, if the [const -hastypemethods] pragma is false, then
+Snit type commands can be called with no arguments at
+all; in this case, the type command creates an instance with an
+automatically generated name. In other words, provided that the
+[const -hastypemethods] pragma is false and the type
+has instances, the following commands are equivalent:
+
+[example {snit::type dog { ... }
+
+set mydog [dog create %AUTO%]
+set mydog [dog %AUTO%]
+set mydog [dog]
+}]
+
+This doesn't work for Snit widgets, for obvious reasons.
+
+[para]
+
+[emph "Snit 1.x Incompatibility:"] In Snit 1.x, the above behavior is
+available whether [const -hastypemethods] is true (the default) or false.
+
+[list_end]
+
+[subsection {Standard Type Methods}]
+
+In addition to any type methods in the type's definition, all type and
+widget commands will usually have at least the following subcommands:
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd {$type}] [method create] [arg name] [opt "[arg option] [arg value] ..."]]
+
+Creates a new instance of the type, giving it the specified [arg name]
+and calling the type's constructor.
+
+[para]
+
+For [cmd snit::type]s, if [arg name] is not a fully-qualified command
+name, it is assumed to be a name in the namespace in which the call to
+[cmd snit::type] appears. The method returns the fully-qualified
+instance name.
+
+[para]
+
+For [cmd snit::widget]s and [cmd snit::widgetadaptor]s, [arg name]
+must be a valid widget name; the method returns the widget name.
+
+[para]
+
+So long as [arg name] does not conflict with any defined type method
+name the [method create] keyword may be omitted, unless
+the type definition includes [cmd "delegate typemethod *"] or the
+[const -hasinstances] pragma is set to false.
+
+[para]
+
+If the [arg name] includes the string [const %AUTO%], it will be
+replaced with the string [const {$type$counter}] where [const {$type}] is
+the type name and [const {$counter}] is a counter that increments each
+time [const %AUTO%] is used for this type.
+
+[para]
+
+By default, any arguments following the [arg name] will be a list of
+[arg option] names and their [arg value]s; however, a type's
+constructor can specify a different argument list.
+
+[para]
+
+As of Snit V0.95, [method create] will throw an error if the [arg name]
+is the same as any existing command--note that this was always true
+for [cmd snit::widget]s and [cmd snit::widgetadaptor]s. You can
+restore the previous behavior using the [const -canreplace] pragma.
+
+
+[call [cmd {$type}] [method {info typevars}] [opt [arg pattern]]]
+
+Returns a list of the type's type variables (excluding Snit internal
+variables); all variable names are fully-qualified.
+
+[para]
+
+If [arg pattern] is given, it's used as a [cmd {string match}]
+pattern; only names that match the pattern are returned.
+
+
+[call [cmd {$type}] [method {info typemethods}] [opt [arg pattern]]]
+
+Returns a list of the names of the type's type methods.
+If the type has hierarchical
+type methods, whether locally-defined or delegated, only the first
+word of each will be included in the list.
+
+[para]
+
+If the type
+definition includes [cmd "delegate typemethod *"], the list will
+include only the names of those implicitly delegated type methods
+that have been called at least once and are still in the type method cache.
+
+[para]
+
+If [arg pattern] is given, it's used as a [cmd {string match}]
+pattern; only names that match the pattern are returned.
+
+
+[call [cmd {$type}] [method {info args}] [arg method]]
+
+Returns a list containing the names of the arguments to the type's
+[arg method], in order. This method cannot be applied to delegated
+type methods.
+
+
+[call [cmd {$type}] [method {info body}] [arg method]]
+
+Returns the body of typemethod [arg method]. This method cannot be
+applied to delegated type methods.
+
+
+[call [cmd {$type}] [method {info default}] [arg method] [arg aname] [arg varname]]
+
+Returns a boolean value indicating whether the argument [arg aname] of
+the type's [arg method] has a default value ([const true]) or not
+([const false]). If the argument has a default its value is placed into
+the variable [arg varname].
+
+
+[call [cmd {$type}] [method {info instances}] [opt [arg pattern]]]
+
+Returns a list of the type's instances. For [cmd snit::type]s, it
+will be a list of fully-qualified instance names;
+for [cmd snit::widget]s, it will be a list of Tk widget names.
+
+[para]
+
+If [arg pattern] is given, it's used as a [cmd {string match}]
+pattern; only names that match the pattern are returned.
+
+[para]
+
+[emph "Snit 1.x Incompatibility:"] In Snit 1.x, the full multi-word
+names of hierarchical type methods are included in the return value.
+
+[call [cmd {$type}] [method destroy]]
+
+Destroys the type's instances, the type's namespace, and the type
+command itself.
+
+[list_end]
+
+[subsection {The Instance Command}]
+
+A Snit type or widget's [method create] type method creates objects of
+the type; each object has a unique name that is also a Tcl command.
+This command is used to access the object's methods and data, and has
+this form:
+
+[para]
+
+[list_begin definitions]
+[call [cmd {$object}] [arg method] [arg args...]]
+
+The [arg method] can be any of the
+[sectref "Standard Instance Methods"], or any instance method
+defined in the type definition.
+
+The subsequent [arg args] depend on the specific [arg method] chosen.
+
+[list_end]
+
+[subsection {Standard Instance Methods}]
+
+In addition to any delegated or locally-defined instance methods in
+the type's definition, all Snit objects will have at least the
+following subcommands:
+
+[para]
+
+[list_begin definitions]
+[call [cmd {$object}] [method configure] [opt [arg option]] [opt [arg value]] ...]
+
+Assigns new values to one or more options. If called with one
+argument, an [arg option] name, returns a list describing the option,
+as Tk widgets do; if called with no arguments, returns a list of lists
+describing all options, as Tk widgets do.
+
+[para]
+
+Warning: This information will be available for delegated options only
+if the component to which they are delegated has a [method configure]
+method that returns this same kind of information.
+
+[para]
+
+Note: Snit defines this method only if the type has at least one
+option.
+
+[call [cmd {$object}] [method configurelist] [arg optionlist]]
+
+Like [method configure], but takes one argument, a list of options and
+their values. It's mostly useful in the type constructor, but can be
+used anywhere.
+
+[para]
+
+Note: Snit defines this method only if the type has at least one
+option.
+
+[call [cmd {$object}] [method cget] [arg option]]
+
+Returns the option's value.
+
+[para]
+
+Note: Snit defines this method only if the type has at least one
+option.
+
+[call [cmd {$object}] [method destroy]]
+
+Destroys the object, calling the [cmd destructor] and freeing all
+related memory.
+
+[para]
+
+[emph Note:]
+
+The [method destroy] method isn't defined for [cmd snit::widget] or
+[cmd snit::widgetadaptor] objects; instances of these are destroyed by
+calling [package Tk]'s [cmd destroy] command, just as normal
+widgets are.
+
+
+[call [cmd {$object}] [method {info type}]]
+
+Returns the instance's type.
+
+
+[call [cmd {$object}] [method {info vars}] [opt [arg pattern]]]
+
+Returns a list of the object's instance variables (excluding Snit
+internal variables). The names are fully qualified.
+
+[para]
+
+If [arg pattern] is given, it's used as a [cmd {string match}]
+pattern; only names that match the pattern are returned.
+
+
+[call [cmd {$object}] [method {info typevars}] [opt [arg pattern]]]
+
+Returns a list of the object's type's type variables (excluding Snit
+internal variables). The names are fully qualified.
+
+[para]
+
+If [arg pattern] is given, it's used as a [cmd {string match}]
+pattern; only names that match the pattern are returned.
+
+
+[call [cmd {$object}] [method {info typemethods}] [opt [arg pattern]]]
+
+Returns a list of the names of the type's type methods.
+If the type has hierarchical
+type methods, whether locally-defined or delegated, only the first
+word of each will be included in the list.
+
+[para]
+
+If the type
+definition includes [cmd "delegate typemethod *"], the list will
+include only the names of those implicitly delegated type methods
+that have been called at least once and are still in the type method cache.
+
+[para]
+
+If [arg pattern] is given, it's used as a [cmd {string match}]
+pattern; only names that match the pattern are returned.
+
+[para]
+
+[emph "Snit 1.x Incompatibility:"] In Snit 1.x, the full multi-word
+names of hierarchical type methods are included in the return value.
+
+[call [cmd {$object}] [method {info options}] [opt [arg pattern]]]
+
+Returns a list of the object's option names. This always includes
+local options and explicitly delegated options. If unknown options
+are delegated as well, and if the component to which they are
+delegated responds to [cmd {$object configure}] like Tk widgets do,
+then the result will include all possible unknown options that can
+be delegated to the component.
+
+[para]
+
+If [arg pattern] is given, it's used as a [cmd {string match}]
+pattern; only names that match the pattern are returned.
+
+[para]
+
+Note that the return value might be different for different instances
+of the same type, if component object types can vary from one instance
+to another.
+
+[call [cmd {$object}] [method {info methods}] [opt [arg pattern]]]
+
+Returns a list of the names of the instance's methods.
+If the type has hierarchical methods, whether locally-defined or
+delegated, only the first word of each will be included in the list.
+
+[para]
+
+If the type
+definition includes [cmd "delegate method *"], the list will
+include only the names of those implicitly delegated methods that have
+been called at least once and are still in the method cache.
+
+[para]
+
+If [arg pattern] is given, it's used as a [cmd {string match}]
+pattern; only names that match the pattern are returned.
+
+[para]
+
+[emph "Snit 1.x Incompatibility:"] In Snit 1.x, the full multi-word
+names of hierarchical type methods are included in the return value.
+
+
+[call [cmd {$object}] [method {info args}] [arg method]]
+
+Returns a list containing the names of the arguments to the instance's
+[arg method], in order. This method cannot be applied to delegated methods.
+
+
+[call [cmd {$object}] [method {info body}] [arg method]]
+
+Returns the body of the instance's method [arg method]. This method
+cannot be applied to delegated methods.
+
+
+[call [cmd {$object}] [method {info default}] [arg method] [arg aname] [arg varname]]
+
+Returns a boolean value indicating whether the argument [arg aname] of
+the instance's [arg method] has a default value ([const true]) or not
+([const false]). If the argument has a default its value is placed into
+the variable [arg varname].
+
+
+[list_end]
+
+[subsection {Commands for use in Object Code}]
+
+Snit defines the following commands for use in your object code:
+that is, for use in type methods, instance methods, constructors,
+destructors, onconfigure handlers, oncget handlers, and procs.
+They do not reside in the ::snit:: namespace; instead, they are
+created with the type, and can be used without qualification.
+
+
+[list_begin definitions]
+
+[call [cmd mymethod] [arg name] [opt [arg args...]]]
+
+The [cmd mymethod] command is used for formatting callback commands to
+be passed to other objects. It returns a command that when called
+will invoke method [arg name] with the specified arguments, plus of
+course any arguments added by the caller. In other words, both of the
+following commands will cause the object's
+[method dosomething] method to be called when the [cmd {$button}] is pressed:
+
+[example { $button configure -command [list $self dosomething myargument]
+
+ $button configure -command [mymethod dosomething myargument]
+}]
+
+The chief distinction between the two is that the latter form will not
+break if the object's command is renamed.
+
+[call [cmd mytypemethod] [arg name] [opt [arg args...]]]
+
+The [cmd mytypemethod] command is used for formatting callback commands to
+be passed to other objects. It returns a command that when called
+will invoke type method [arg name] with the specified arguments, plus of
+course any arguments added by the caller. In other words, both of the
+following commands will cause the object's [method dosomething] type method
+to be called when [cmd {$button}] is pressed:
+
+[example { $button configure -command [list $type dosomething myargument]
+
+ $button configure -command [mytypemethod dosomething myargument]
+}]
+
+Type commands cannot be renamed, so in practice there's little
+difference between the two forms. [cmd mytypemethod] is provided for
+parallelism with [cmd mymethod].
+
+[call [cmd myproc] [arg name] [opt [arg args...]]]
+
+The [cmd myproc] command is used for formatting callback commands to
+be passed to other objects. It returns a command that when called
+will invoke the type proc [arg name] with the specified arguments, plus of
+course any arguments added by the caller. In other words, both of the
+following commands will cause the object's [method dosomething] proc
+to be called when [cmd {$button}] is pressed:
+
+[example { $button configure -command [list ${type}::dosomething myargument]
+
+ $button configure -command [myproc dosomething myargument]
+}]
+
+[call [cmd myvar] [arg name]]
+
+Given an instance variable name, returns the fully qualified name.
+Use this if you're passing the variable to some other object, e.g., as
+a [option -textvariable] to a Tk label widget.
+
+[call [cmd mytypevar] [arg name]]
+
+Given an type variable name, returns the fully qualified name. Use
+this if you're passing the variable to some other object, e.g., as a
+[option -textvariable] to a Tk label widget.
+
+[call [cmd from] [arg argvName] [arg option] [opt [arg defvalue]]]
+
+The [cmd from] command plucks an option value from a list of options
+and their values, such as is passed into a type's [cmd constructor].
+[arg argvName] must be the name of a variable containing such a list;
+[arg option] is the name of the specific option.
+
+[para]
+
+[cmd from] looks for [arg option] in the option list. If it is found,
+it and its value are removed from the list, and the value is returned.
+If [arg option] doesn't appear in the list, then the [arg defvalue] is
+returned.
+
+If the option is locally-defined option, and [arg defvalue] is
+not specified, then the option's default value as specified in the
+type definition will be returned instead.
+
+[call [cmd install] [arg compName] [const using] [arg objType] [arg objName] [arg args...]]
+
+Creates a new object of type [arg objType] called [arg objName]
+and installs it as component [arg compName],
+as described in [sectref {Components and Delegation}]. Any additional
+[arg args...] are passed along with the name to the [arg objType]
+command.
+
+If this is a [cmd snit::type], then the following two commands are
+equivalent:
+
+[example { install myComp using myObjType $self.myComp args...
+
+ set myComp [myObjType $self.myComp args...]
+}]
+
+Note that whichever method is used, [arg compName] must still be
+declared in the type definition using [cmd component], or must be
+referenced in at least one [cmd delegate] statement.
+
+[para]
+
+If this is a [cmd snit::widget] or [cmd snit::widgetadaptor], and if
+options have been delegated to component [arg compName], then those
+options will receive default values from the Tk option database. Note
+that it doesn't matter whether the component to be installed is a
+widget or not. See [sectref {The Tk Option Database}] for more
+information.
+
+[para]
+
+[cmd install] cannot be used to install type components; just assign
+the type component's command name to the type component's variable
+instead.
+
+[call [cmd installhull] [const using] [arg widgetType] [arg args...]]
+[call [cmd installhull] [arg name]]
+
+The constructor of a [cmd snit::widgetadaptor] must create a widget to
+be the object's hull component; the widget is installed as the hull
+component using this command. Note that the installed widget's name
+must be [const {$win}].
+
+This command has two forms.
+
+[para]
+
+The first form specifies the [arg widgetType] and the [arg args...]
+(that is, the hardcoded option list) to use in creating the hull.
+Given this form, [cmd installhull] creates the hull widget, and
+initializes any options delegated to the hull from the Tk option
+database.
+
+[para]
+
+In the second form, the hull widget has already been created; note
+that its name must be "$win". In this case, the Tk option database is
+[emph not] queried for any options delegated to the hull.
+
+The longer form is preferred; however, the shorter form allows the
+programmer to adapt a widget created elsewhere, which is sometimes
+useful. For example, it can be used to adapt a "page" widget created
+by a [package BWidgets] tabbed notebook or pages manager widget.
+
+[para]
+
+See [sectref {The Tk Option Database}] for more information
+about [cmd snit::widgetadaptor]s and the option database.
+
+[call [cmd variable] [arg name]]
+
+Normally, instance variables are defined in the type definition along
+with the options, methods, and so forth; such instance variables are
+automatically visible in all instance code (e.g., method bodies). However,
+instance code can use the [cmd variable] command to declare instance variables
+that don't appear in the type definition, and also to bring variables
+from other namespaces into scope in the usual way.
+
+[para]
+
+It's generally clearest to define all instance variables in the type
+definition, and omit declaring them in methods and so forth.
+
+[para]
+
+Note that this is an instance-specific version of the standard Tcl
+[cmd ::variable] command.
+
+[call [cmd typevariable] [arg name]]
+
+Normally, type variables are defined in the type definition, along
+with the instance variables; such type variables are automatically
+visible in all of the type's code. However, type methods, instance
+methods and so forth can use [cmd typevariable] to declare type
+variables that don't appear in the type definition.
+
+[para]
+
+It's generally clearest to declare all type variables in the type
+definition, and omit declaring them in methods, type methods, etc.
+
+[call [cmd varname] [arg name]]
+
+[const Deprecated.] Use [cmd myvar] instead.
+
+[para]
+
+Given an instance variable name, returns the fully qualified name.
+Use this if you're passing the variable to some other object, e.g., as
+a [option -textvariable] to a Tk label widget.
+
+
+[call [cmd typevarname] [arg name]]
+
+[const Deprecated.] Use [cmd mytypevar] instead.
+
+[para]
+
+Given a type variable name, returns the fully qualified name. Use
+this if you're passing the type variable to some other object, e.g., as a
+[option -textvariable] to a Tk label widget.
+
+[call [cmd codename] [arg name]]
+
+[const Deprecated.] Use [cmd myproc] instead.
+
+Given the name of a proc (but not a type or instance method), returns
+the fully-qualified command name, suitable for passing as a callback.
+
+[list_end]
+[para]
+
+[subsection {Components and Delegation}]
+
+When an object includes other objects, as when a toolbar contains
+buttons or a GUI object contains an object that references a database,
+the included object is called a component. The standard way to handle
+component objects owned by a Snit object is to declare them using
+[cmd component], which creates a component instance variable.
+In the following example, a [cmd dog] object has a
+[cmd tail] object:
+
+[para]
+[example { snit::type dog {
+ component mytail
+
+ constructor {args} {
+ set mytail [tail %AUTO% -partof $self]
+ $self configurelist $args
+ }
+
+ method wag {} {
+ $mytail wag
+ }
+ }
+
+ snit::type tail {
+ option -length 5
+ option -partof
+ method wag {} { return "Wag, wag, wag."}
+ }
+}]
+[para]
+
+Because the [cmd tail] object's name is stored in an instance
+variable, it's easily accessible in any method.
+
+[para]
+
+The [cmd install] command provides an alternate way
+to create and install the component:
+
+[para]
+[example { snit::type dog {
+ component mytail
+
+ constructor {args} {
+ install mytail using tail %AUTO% -partof $self
+ $self configurelist $args
+ }
+
+ method wag {} {
+ $mytail wag
+ }
+ }
+}]
+[para]
+
+For [cmd snit::type]s, the two methods are equivalent; for
+[cmd snit::widget]s and [cmd snit::widgetadaptor]s, the [cmd install]
+command properly initializes the widget's options by querying
+[sectref {The Tk Option Database}].
+
+[para]
+
+In the above examples, the [cmd dog] object's [method wag] method
+simply calls the [cmd tail] component's [method wag] method. In OO
+jargon, this is called delegation. Snit provides an easier way to do
+this:
+
+[para]
+[example { snit::type dog {
+ delegate method wag to mytail
+
+ constructor {args} {
+ install mytail using tail %AUTO% -partof $self
+ $self configurelist $args
+ }
+ }
+}]
+[para]
+
+The [cmd delegate] statement in the type definition implicitly defines
+the instance variable [var mytail] to hold the component's name
+(though it's good form to use [cmd component] to declare it explicitly); it
+also defines the [cmd dog] object's [method wag] method, delegating it
+to the [var mytail] component.
+
+[para]
+
+If desired, all otherwise unknown methods can be delegated to a
+specific component:
+
+[para]
+[example {
+ snit::type dog {
+ delegate method * to mytail
+
+ constructor {args} {
+ set mytail [tail %AUTO% -partof $self]
+ $self configurelist $args
+ }
+
+ method bark { return "Bark, bark, bark!" }
+ }
+}]
+[para]
+
+In this case, a [cmd dog] object will handle its own [method bark]
+method; but [method wag] will be passed along to [cmd mytail]. Any
+other method, being recognized by neither [cmd dog] nor [cmd tail],
+will simply raise an error.
+
+[para]
+
+Option delegation is similar to method delegation, except for the
+interactions with the Tk option database; this is described in
+[sectref "The Tk Option Database"].
+
+[subsection {Type Components and Delegation}]
+
+The relationship between type components and instance components is
+identical to that between type variables and instance variables, and
+that between type methods and instance methods. Just as an instance
+component is an instance variable that holds the name of a command, so
+a type component is a type variable that holds the name of a command.
+In essence, a type component is a component that's shared by every
+instance of the type.
+
+[para]
+
+Just as [cmd "delegate method"] can be used to delegate methods to
+instance components, as described in
+[sectref "Components and Delegation"], so [cmd "delegate typemethod"]
+can be used to delegate type methods to type components.
+
+[para]
+
+Note also that as of Snit 0.95 [cmd "delegate method"] can delegate
+methods to both instance components and type components.
+
+[subsection {The Tk Option Database}]
+
+This section describes how Snit interacts with the Tk option database,
+and assumes the reader has a working knowledge of the option database
+and its uses. The book [emph {Practical Programming in Tcl and Tk}]
+by Welch et al has a good introduction to the option database, as does
+[emph {Effective Tcl/Tk Programming}].
+
+[para]
+
+Snit is implemented so that most of the time it will simply do the
+right thing with respect to the option database, provided that the
+widget developer does the right thing by Snit. The body of this
+section goes into great deal about what Snit requires. The following
+is a brief statement of the requirements, for reference.
+
+[para]
+
+[list_begin itemized]
+[item]
+
+If the [cmd snit::widget]'s default widget class is not what is desired, set it
+explicitly using [cmd widgetclass] in the widget definition.
+
+[item]
+
+When defining or delegating options, specify the resource and class
+names explicitly when if the defaults aren't what you want.
+
+[item]
+
+Use [cmd {installhull using}] to install the hull for
+[cmd snit::widgetadaptor]s.
+
+[item]
+
+Use [cmd install] to install all other components.
+
+[list_end]
+[para]
+
+The interaction of Tk widgets with the option database is a complex
+thing; the interaction of Snit with the option database is even more
+so, and repays attention to detail.
+
+[para]
+
+[const {Setting the widget class:}] Every Tk widget has a widget class.
+For Tk widgets, the widget class name is the just the widget type name
+with an initial capital letter, e.g., the widget class for
+[cmd button] widgets is "Button".
+
+[para]
+
+Similarly, the widget class of a [cmd snit::widget] defaults to the
+unqualified type name with the first letter capitalized. For example,
+the widget class of
+
+[para]
+[example { snit::widget ::mylibrary::scrolledText { ... }}]
+[para]
+
+is "ScrolledText". The widget class can also be set explicitly using
+the [cmd widgetclass] statement within the [cmd snit::widget]
+definition.
+
+[para]
+
+Any widget can be used as the [cmd hulltype] provided that it supports
+the [const -class] option for changing its widget class name. See
+the discussion of the [cmd hulltype] command, above. The user may pass
+[const -class] to the widget at instantion.
+
+[para]
+
+The widget class of a [cmd snit::widgetadaptor] is just the widget
+class of its hull widget; this cannot be changed unless the hull
+widget supports [const -class], in which case it will
+usually make more sense to use [cmd snit::widget] rather than
+[cmd snit::widgetadaptor].
+
+[para]
+
+[const {Setting option resource names and classes:}] In Tk, every
+option has three names: the option name, the resource name, and the
+class name. The option name begins with a hyphen and is all lowercase;
+it's used when creating widgets, and with the [cmd configure] and
+[cmd cget] commands.
+
+[para]
+
+The resource and class names are used to initialize option default
+values by querying the Tk option database. The resource name is
+usually just the option name minus the hyphen, but may contain
+uppercase letters at word boundaries; the class name is usually just
+the resource name with an initial capital, but not always. For
+example, here are the option, resource, and class names for several
+[cmd text] widget options:
+
+[para]
+[example { -background background Background
+ -borderwidth borderWidth BorderWidth
+ -insertborderwidth insertBorderWidth BorderWidth
+ -padx padX Pad
+}]
+[para]
+
+As is easily seen, sometimes the resource and class names can be
+inferred from the option name, but not always.
+
+[para]
+
+Snit options also have a resource name and a class name. By default,
+these names follow the rule given above: the resource name is the
+option name without the hyphen, and the class name is the resource
+name with an initial capital. This is true for both locally-defined
+options and explicitly delegated options:
+
+[para]
+[example { snit::widget mywidget {
+ option -background
+ delegate option -borderwidth to hull
+ delegate option * to text
+ # ...
+ }
+}]
+[para]
+
+In this case, the widget class name is "Mywidget". The widget has the
+following options: [option -background], which is locally defined, and
+[option -borderwidth], which is explicitly delegated; all other widgets are
+delegated to a component called "text", which is probably a Tk
+
+[cmd text] widget. If so, [cmd mywidget] has all the same options as
+a [cmd text] widget. The option, resource, and class names are as
+follows:
+
+[para]
+[example { -background background Background
+ -borderwidth borderwidth Borderwidth
+ -padx padX Pad
+}]
+[para]
+
+Note that the locally defined option, [option -background], happens to have
+the same three names as the standard Tk [option -background] option; and
+[option -pad], which is delegated implicitly to the [var text]
+component, has the
+same three names for [cmd mywidget] as it does for the [cmd text]
+widget. [option -borderwidth], on the other hand, has different resource and
+class names than usual, because the internal word "width" isn't
+capitalized. For consistency, it should be; this is done as follows:
+
+[para]
+[example { snit::widget mywidget {
+ option -background
+ delegate option {-borderwidth borderWidth} to hull
+ delegate option * to text
+ # ...
+ }
+}]
+[para]
+
+The class name will default to "BorderWidth", as expected.
+
+[para]
+
+Suppose, however, that [cmd mywidget] also delegated
+[option -padx] and
+[option -pady] to the hull. In this case, both the resource name and the
+class name must be specified explicitly:
+
+[para]
+[example { snit::widget mywidget {
+ option -background
+ delegate option {-borderwidth borderWidth} to hull
+ delegate option {-padx padX Pad} to hull
+ delegate option {-pady padY Pad} to hull
+ delegate option * to text
+ # ...
+ }
+}]
+[para]
+
+[const {Querying the option database:}] If you set your widgetclass and
+option names as described above, Snit will query the option database
+when each instance is created, and will generally do the right thing
+when it comes to querying the option database. The remainder of this
+section goes into the gory details.
+
+[para]
+[const {Initializing locally defined options:}]
+
+When an instance of a snit::widget is created, its locally defined
+options are initialized as follows: each option's resource and class
+names are used to query the Tk option database. If the result is
+non-empty, it is used as the option's default; otherwise, the default
+hardcoded in the type definition is used. In either case, the default
+can be overridden by the caller. For example,
+
+[para]
+[example { option add *Mywidget.texture pebbled
+
+ snit::widget mywidget {
+ option -texture smooth
+ # ...
+ }
+
+ mywidget .mywidget -texture greasy
+}]
+[para]
+
+Here, [option -texture] would normally default to "smooth", but because of
+the entry added to the option database it defaults to "pebbled".
+However, the caller has explicitly overridden the default, and so the
+new widget will be "greasy".
+
+[para]
+[const {Initializing options delegated to the hull:}]
+
+A [cmd snit::widget]'s hull is a widget, and given that its class has
+been set it is expected to query the option database for itself. The
+only exception concerns options that are delegated to it with a
+different name. Consider the following code:
+
+[para]
+[example { option add *Mywidget.borderWidth 5
+ option add *Mywidget.relief sunken
+ option add *Mywidget.hullbackground red
+ option add *Mywidget.background green
+
+ snit::widget mywidget {
+ delegate option -borderwidth to hull
+ delegate option -hullbackground to hull as -background
+ delegate option * to hull
+ # ...
+ }
+
+ mywidget .mywidget
+
+ set A [.mywidget cget -relief]
+ set B [.mywidget cget -hullbackground]
+ set C [.mywidget cget -background]
+ set D [.mywidget cget -borderwidth]
+}]
+[para]
+
+The question is, what are the values of variables A, B, C and D?
+
+[para]
+
+The value of A is "sunken". The hull is a Tk frame that has been
+given the widget class "Mywidget"; it will automatically query the
+option database and pick up this value. Since the [option -relief]
+option is implicitly delegated to the hull, Snit takes no action.
+
+[para]
+
+The value of B is "red". The hull will automatically pick up the
+value "green" for its [option -background] option, just as it picked up the
+[option -relief] value. However, Snit knows that
+[option -hullbackground] is mapped to
+the hull's [option -background] option; hence, it queries the option database
+for [option -hullbackground] and gets "red" and updates the hull
+accordingly.
+
+[para]
+
+The value of C is also "red", because [option -background] is implicitly
+delegated to the hull; thus, retrieving it is the same as retrieving
+[option -hullbackground]. Note that this case is unusual; in practice,
+[option -background] would probably be explicitly delegated to some other
+component.
+
+[para]
+
+The value of D is "5", but not for the reason you think. Note that as
+it is defined above, the resource name for [option -borderwidth]
+defaults to "borderwidth", whereas the option database entry is
+"borderWidth". As with [option -relief], the hull picks up its
+own [option -borderwidth] option before Snit does anything. Because the
+option is delegated under its own name, Snit assumes that the correct
+thing has happened, and doesn't worry about it any further.
+
+[para]
+
+For [cmd snit::widgetadaptor]s, the case is somewhat altered. Widget
+adaptors retain the widget class of their hull, and the hull is not
+created automatically by Snit. Instead, the [cmd snit::widgetadaptor]
+must call [cmd installhull] in its constructor. The normal way to do
+this is as follows:
+
+[para]
+[example { snit::widgetadaptor mywidget {
+ # ...
+ constructor {args} {
+ # ...
+ installhull using text -foreground white
+ #
+ }
+ #...
+ }
+}]
+[para]
+
+In this case, the [cmd installhull] command will create the hull using
+a command like this:
+
+[para]
+[example { set hull [text $win -foreground white]
+}]
+[para]
+
+The hull is a [cmd text] widget, so its widget class is "Text". Just
+as with [cmd snit::widget] hulls, Snit assumes that it will pick up
+all of its normal option values automatically; options delegated from
+a different name are initialized from the option database in the same
+way.
+
+[para]
+[const {Initializing options delegated to other components:}]
+
+Non-hull components are matched against the option database in two
+ways. First, a component widget remains a widget still, and therefore
+is initialized from the option database in the usual way.
+
+Second, the option database is queried for all options delegated to
+the component, and the component is initialized accordingly--provided
+that the [cmd install] command is used to create it.
+
+[para]
+
+Before option database support was added to Snit, the usual way to
+create a component was to simply create it in the constructor and
+assign its command name to the component variable:
+
+[para]
+[example { snit::widget mywidget {
+ delegate option -background to myComp
+
+ constructor {args} {
+ set myComp [text $win.text -foreground black]
+ }
+ }
+}]
+[para]
+
+The drawback of this method is that Snit has no opportunity to
+initialize the component properly. Hence, the following approach is
+now used:
+
+[para]
+[example { snit::widget mywidget {
+ delegate option -background to myComp
+
+ constructor {args} {
+ install myComp using text $win.text -foreground black
+ }
+ }
+}]
+[para]
+
+The [cmd install] command does the following:
+
+[para]
+[list_begin itemized]
+[item]
+
+Builds a list of the options explicitly included in the [cmd install]
+command -- in this case, [option -foreground].
+
+[item]
+
+Queries the option database for all options delegated explicitly to
+the named component.
+
+[item]
+
+Creates the component using the specified command, after inserting
+into it a list of options and values read from the option database.
+Thus, the explicitly included options ([option -foreground]) will override
+anything read from the option database.
+
+[item]
+
+If the widget definition implicitly delegated options to the component
+using [cmd "delegate option *"], then Snit calls the newly created
+component's [cmd configure] method to receive a list of all of the
+component's options. From this Snit builds a list of options
+implicitly delegated to the component that were not explicitly
+included in the [cmd install] command. For all such options, Snit
+queries the option database and configures the component accordingly.
+
+[list_end]
+
+[para]
+[const {Non-widget components:}] The option database is never queried
+for [cmd snit::type]s, since it can only be queried given a Tk widget
+name.
+
+However, [cmd snit::widget]s can have non-widget components. And if
+options are delegated to those components, and if the [cmd install]
+command is used to install those components, then they will be
+initialized from the option database just as widget components are.
+
+[para]
+
+[subsection {Macros and Meta-programming}]
+
+The [cmd snit::macro] command enables a certain amount of
+meta-programming with Snit classes. For example, suppose you like to
+define properties: instance variables that have set/get methods. Your
+code might look like this:
+
+[example { snit::type dog {
+ variable mood happy
+
+ method getmood {} {
+ return $mood
+ }
+
+ method setmood {newmood} {
+ set mood $newmood
+ }
+ }
+}]
+
+That's nine lines of text per property. Or, you could define the
+following [cmd snit::macro]:
+
+[example { snit::macro property {name initValue} {
+ variable $name $initValue
+
+ method get$name {} "return $name"
+
+ method set$name {value} "set $name \$value"
+ }
+}]
+
+Note that a [cmd snit::macro] is just a normal Tcl proc defined in
+the slave interpreter used to compile type and widget definitions; as
+a result, it has access to all the commands used to define types and
+widgets.
+
+[para]
+
+Given this new macro, you can define a property in one line of code:
+
+[example { snit::type dog {
+ property mood happy
+ }
+}]
+
+Within a macro, the commands [cmd variable] and [cmd proc] refer to
+the Snit type-definition commands, not the standard Tcl commands. To
+get the standard Tcl commands, use [cmd _variable] and [cmd _proc].
+
+[para]
+
+Because a single slave interpreter is used for compiling all Snit
+types and widgets in the application, there's the possibility of macro
+name collisions. If you're writing a reuseable package using Snit,
+and you use some [cmd snit::macro]s, define them in your package
+namespace:
+
+[example { snit::macro mypkg::property {name initValue} { ... }
+
+ snit::type dog {
+ mypkg::property mood happy
+ }
+}]
+
+This leaves the global namespace open for application authors.
+
+[para]
+
+[subsection "Validation Types"]
+
+A validation type is an object that can be used to validate
+Tcl values of a particular kind. For example,
+[cmd snit::integer] is used to validate that a Tcl value is
+an integer.
+
+[para]
+
+Every validation type has a [method validate] method which is used to
+do the validation. This method must take a single argument, the value
+to be validated; further, it must do nothing if the value is valid,
+but throw an error if the value is invalid:
+
+[example { snit::integer validate 5 ;# Does nothing
+ snit::integer validate 5.0 ;# Throws an error (not an integer!)
+}]
+
+[para]
+
+The [method validate] method will always return the validated value on success,
+and throw the [cmd -errorcode] INVALID on error.
+
+[para]
+
+Snit defines a family of validation types, all of which are
+implemented as [cmd snit::type]'s. They can be used as is;
+in addition, their instances serve as parameterized
+subtypes. For example, a probability is a number between 0.0 and 1.0
+inclusive:
+
+[example { snit::double probability -min 0.0 -max 1.0
+}]
+
+The example above creates an instance of [cmd snit::double]--a
+validation subtype--called
+[cmd probability], which can be used to validate probability values:
+
+[example { probability validate 0.5 ;# Does nothing
+ probability validate 7.9 ;# Throws an error
+}]
+
+Validation subtypes can be defined explicitly, as in the above
+example; when a locally-defined option's [const -type] is specified,
+they may also be created on the fly:
+
+[example { snit::enum ::dog::breed -values {mutt retriever sheepdog}
+
+ snit::type dog {
+ # Define subtypes on the fly...
+ option -breed -type {
+ snit::enum -values {mutt retriever sheepdog}
+ }
+
+ # Or use predefined subtypes...
+ option -breed -type ::dog::breed
+ }
+}]
+
+[para]
+
+Any object that has a [method validate] method with the semantics
+described above can be used as a validation type; see
+[sectref "Defining Validation Types"] for information on how to define
+new ones.
+
+[para]
+
+Snit defines the following validation types:
+
+[list_begin definitions]
+
+[call [cmd snit::boolean] [const validate] [opt [arg value]]]
+[call [cmd snit::boolean] [arg name]]
+
+Validates Tcl boolean values: 1, 0, [const on], [const off],
+[const yes], [const no], [const true], [const false].
+It's possible to define subtypes--that is, instances--of
+[cmd snit::boolean], but as it has no options there's no reason to do
+so.
+
+[call [cmd snit::double] [const validate] [opt [arg value]]]
+[call [cmd snit::double] [arg name] [opt "[arg option] [arg value]..."]]
+
+Validates floating-point values. Subtypes may be created with the
+following options:
+
+[list_begin definitions]
+
+[def "[const -min] [arg min]"]
+
+Specifies a floating-point minimum bound; a value is invalid if it is strictly
+less than [arg min].
+
+[def "[const -max] [arg max]"]
+
+Specifies a floating-point maximum bound; a value is invalid if it is strictly
+greater than [arg max].
+
+[list_end]
+
+[call [cmd snit::enum] [const validate] [opt [arg value]]]
+[call [cmd snit::enum] [arg name] [opt "[arg option] [arg value]..."]]
+
+Validates that a value comes from an enumerated list. The base
+type is of little use by itself, as only subtypes actually have
+an enumerated list to validate against. Subtypes may be created
+with the following options:
+
+[list_begin definitions]
+
+[def "[const -values] [arg list]"]
+
+Specifies a list of valid values. A value is valid if and only if
+it's included in the list.
+
+[list_end]
+
+[call [cmd snit::fpixels] [const validate] [opt [arg value]]]
+[call [cmd snit::fpixels] [arg name] [opt "[arg option] [arg value]..."]]
+
+[emph "Tk programs only."] Validates screen distances, in any of the
+forms accepted by [cmd "winfo fpixels"]. Subtypes may be created with the
+following options:
+
+[list_begin definitions]
+
+[def "[const -min] [arg min]"]
+
+Specifies a minimum bound; a value is invalid if it is strictly
+less than [arg min]. The bound may be expressed in any of the
+forms accepted by [cmd "winfo fpixels"].
+
+[def "[const -max] [arg max]"]
+
+Specifies a maximum bound; a value is invalid if it is strictly
+greater than [arg max]. The bound may be expressed in any of the
+forms accepted by [cmd "winfo fpixels"].
+
+[list_end]
+
+[call [cmd snit::integer] [const validate] [opt [arg value]]]
+[call [cmd snit::integer] [arg name] [opt "[arg option] [arg value]..."]]
+
+Validates integer values. Subtypes may be created with the
+following options:
+
+[list_begin definitions]
+
+[def "[const -min] [arg min]"]
+
+Specifies an integer minimum bound; a value is invalid if it is strictly
+less than [arg min].
+
+[def "[const -max] [arg max]"]
+
+Specifies an integer maximum bound; a value is invalid if it is strictly
+greater than [arg max].
+
+[list_end]
+
+[call [cmd snit::listtype] [const validate] [opt [arg value]]]
+[call [cmd snit::listtype] [arg name] [opt "[arg option] [arg value]..."]]
+
+Validates Tcl lists. Subtypes may be created with the
+following options:
+
+[list_begin definitions]
+
+[def "[const -minlen] [arg min]"]
+
+Specifies a minimum list length; the value is invalid if it has
+fewer than [arg min] elements. Defaults to 0.
+
+[def "[const -maxlen] [arg max]"]
+
+Specifies a maximum list length; the value is invalid if it
+more than [arg max] elements.
+
+[def "[const -type] [arg type]"]
+
+Specifies the type of the list elements; [arg type] must be
+the name of a validation type or subtype. In the
+following example, the value of [const -numbers] must be a list
+of integers.
+
+[example { option -numbers -type {snit::listtype -type snit::integer}
+}]
+
+Note that this option doesn't support defining new validation subtypes
+on the fly; that is, the following code will not work (yet, anyway):
+
+[example { option -numbers -type {
+ snit::listtype -type {snit::integer -min 5}
+ }
+}]
+
+Instead, define the subtype explicitly:
+
+[example { snit::integer gt4 -min 5
+
+ snit::type mytype {
+ option -numbers -type {snit::listtype -type gt4}
+ }
+}]
+
+
+[list_end]
+
+[call [cmd snit::pixels] [const validate] [opt [arg value]]]
+[call [cmd snit::pixels] [arg name] [opt "[arg option] [arg value]..."]]
+
+[emph "Tk programs only."] Validates screen distances, in any of the
+forms accepted by [cmd "winfo pixels"]. Subtypes may be created with the
+following options:
+
+[list_begin definitions]
+
+[def "[const -min] [arg min]"]
+
+Specifies a minimum bound; a value is invalid if it is strictly
+less than [arg min]. The bound may be expressed in any of the
+forms accepted by [cmd "winfo pixels"].
+
+[def "[const -max] [arg max]"]
+
+Specifies a maximum bound; a value is invalid if it is strictly
+greater than [arg max]. The bound may be expressed in any of the
+forms accepted by [cmd "winfo pixels"].
+
+[list_end]
+
+
+[call [cmd snit::stringtype] [const validate] [opt [arg value]]]
+[call [cmd snit::stringtype] [arg name] [opt "[arg option] [arg value]..."]]
+
+Validates Tcl strings. The base type is of little use by itself,
+since very Tcl value is also a valid string. Subtypes may be created with the
+following options:
+
+[list_begin definitions]
+
+[def "[const -minlen] [arg min]"]
+
+Specifies a minimum string length; the value is invalid if it has
+fewer than [arg min] characters. Defaults to 0.
+
+[def "[const -maxlen] [arg max]"]
+
+Specifies a maximum string length; the value is invalid if it has
+more than [arg max] characters.
+
+[def "[const -glob] [arg pattern]"]
+
+Specifies a [cmd "string match"] pattern; the value is invalid
+if it doesn't match the pattern.
+
+[def "[const -regexp] [arg regexp]"]
+
+Specifies a regular expression; the value is invalid if it doesn't
+match the regular expression.
+
+[def "[const -nocase] [arg flag]"]
+
+By default, both [const -glob] and [const -regexp] matches are
+case-sensitive. If [const -nocase] is set to true, then both
+[const -glob] and [const -regexp] matches are case-insensitive.
+
+[list_end]
+
+[call [cmd snit::window] [const validate] [opt [arg value]]]
+[call [cmd snit::window] [arg name]]
+
+[emph "Tk programs only."] Validates Tk window names. The value must
+cause [cmd "winfo exists"] to return true; otherwise, the value is
+invalid. It's possible to define subtypes--that is, instances--of
+[cmd snit::window], but as it has no options at present there's no
+reason to do so.
+
+[list_end]
+
+[para]
+
+[subsection "Defining Validation Types"]
+
+There are three ways to define a new validation type: as a subtype of
+one of Snit's validation types, as a validation type command, and as
+a full-fledged validation type similar to those provided by Snit.
+Defining subtypes of Snit's validation types is described above,
+under [sectref "Validation Types"].
+
+[para]
+
+The next simplest way to create a new validation type is as a
+validation type command. A validation type is simply an
+object that has a [method validate] method; the [method validate]
+method must take one argument, a value, return the value if it is
+valid, and throw an error with [cmd -errorcode] INVALID if the
+value is invalid. This can be done with a simple [cmd proc]. For
+example, the [cmd snit::boolean] validate type could have been
+implemented like this:
+
+[example { proc ::snit::boolean {"validate" value} {
+ if {![string is boolean -strict $value]} {
+ return -code error -errorcode INVALID \
+ "invalid boolean \"$value\", should be one of: 1, 0, ..."
+ }
+
+ return $value
+ }
+}]
+
+A validation type defined in this way cannot be subtyped, of course;
+but for many applications this will be sufficient.
+
+[para]
+
+Finally, one can define a full-fledged, subtype-able validation type
+as a [cmd snit::type]. Here's a skeleton to get you started:
+
+[example { snit::type myinteger {
+ # First, define any options you'd like to use to define
+ # subtypes. Give them defaults such that they won't take
+ # effect if they aren't used, and marked them "read-only".
+ # After all, you shouldn't be changing their values after
+ # a subtype is defined.
+ #
+ # For example:
+
+ option -min -default "" -readonly 1
+ option -max -default "" -readonly 1
+
+ # Next, define a "validate" type method which should do the
+ # validation in the basic case. This will allow the
+ # type command to be used as a validation type.
+
+ typemethod validate {value} {
+ if {![string is integer -strict $value]} {
+ return -code error -errorcode INVALID \
+ "invalid value \"$value\", expected integer"
+ }
+
+ return $value
+ }
+
+ # Next, the constructor should validate the subtype options,
+ # if any. Since they are all readonly, we don't need to worry
+ # about validating the options on change.
+
+ constructor {args} {
+ # FIRST, get the options
+ $self configurelist $args
+
+ # NEXT, validate them.
+
+ # I'll leave this to your imagination.
+ }
+
+ # Next, define a "validate" instance method; its job is to
+ # validate values for subtypes.
+
+ method validate {value} {
+ # First, call the type method to do the basic validation.
+ $type validate $value
+
+ # Now we know it's a valid integer.
+
+ if {("" != $options(-min) && $value < $options(-min)) ||
+ ("" != $options(-max) && $value > $options(-max))} {
+ # It's out of range; format a detailed message about
+ # the error, and throw it.
+
+ set msg "...."
+
+ return -code error -errorcode INVALID $msg
+ }
+
+ # Otherwise, if it's valid just return it.
+ return $valid
+ }
+ }
+}]
+
+And now you have a type that can be subtyped.
+
+[para]
+
+The file "validate.tcl" in the Snit distribution defines all of Snit's
+validation types; you can find the complete implementation for
+[cmd snit::integer] and the other types there, to use as examples for
+your own types.
+
+[para]
+
+[section CAVEATS]
+
+If you have problems, find bugs, or new ideas you are hereby cordially
+invited to submit a report of your problem, bug, or idea at the
+SourceForge trackers for tcllib, which can be found at
+
+[uri http://sourceforge.net/projects/tcllib/].
+
+The relevant category is [emph snit].
+
+[para]
+
+Additionally, you might wish to join the Snit mailing list;
+see [uri http://www.wjduquette.com/snit] for details.
+
+[para]
+
+One particular area to watch is using [cmd snit::widgetadaptor] to
+adapt megawidgets created by other megawidget packages; correct
+widget destruction depends on the order of the <Destroy> bindings.
+The wisest course is simply not to do this.
+
+[section {KNOWN BUGS}]
+
+[list_begin itemized]
+[item]
+
+Error stack traces returned by Snit 1.x are extremely ugly and typically
+contain far too much information about Snit internals. The error
+messages are much improved in Snit 2.2.
+
+[item]
+
+Also see the SourceForge Trackers at
+[uri http://sourceforge.net/projects/tcllib/], category [emph snit].
+
+[list_end]
+
+
+[section HISTORY]
+
+During the course of developing Notebook
+(See [uri http://www.wjduquette.com/notebook]), my Tcl-based personal
+notebook application, I found I was writing it as a collection of
+objects. I wasn't using any particular object-oriented framework; I
+was just writing objects in pure Tcl following the guidelines in my
+Guide to Object Commands
+(see [uri http://www.wjduquette.com/tcl/objects.html]), along with a
+few other tricks I'd picked up since. And though it was working well,
+it quickly became tiresome because of the amount of boilerplate
+code associated with each new object type.
+
+[para]
+
+So that was one thing--tedium is a powerful motivator. But the other
+thing I noticed is that I wasn't using inheritance at all, and I
+wasn't missing it. Instead, I was using delegation: objects that
+created other objects and delegated methods to them.
+
+[para]
+
+And I said to myself, "This is getting tedious...there has got to be a
+better way." And one afternoon, on a whim, I started working on Snit,
+an object system that works the way Tcl works. Snit doesn't support
+inheritance, but it's great at delegation, and it makes creating
+megawidgets easy.
+
+[para]
+
+If you have any comments or suggestions (or bug reports!) don't
+hesitate to send me e-mail at [uri will@wjduquette.com]. In addition,
+there's a Snit mailing list; you can find out more about it at the
+Snit home page (see [uri http://www.wjduquette.com/snit]).
+
+[para]
+
+
+[section CREDITS]
+
+Snit has been designed and implemented from the very beginning by
+William H. Duquette. However, much credit belongs to the following
+people for using Snit and providing me with valuable feedback: Rolf
+Ade, Colin McCormack, Jose Nazario, Jeff Godfrey, Maurice Diamanti,
+Egon Pasztor, David S. Cargo, Tom Krehbiel, Michael Cleverly,
+Andreas Kupries, Marty Backe, Andy Goth, Jeff Hobbs, Brian
+Griffin, Donal Fellows, Miguel Sofer, Kenneth Green,
+and Anton Kovalenko.
+If I've forgotten anyone, my apologies; let me know and I'll add
+your name to the list.
+
+[section {BUGS, IDEAS, FEEDBACK}]
+
+This document, and the package it describes, will undoubtedly contain
+bugs and other problems.
+
+Please report such in the category [emph snit] of the
+[uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}].
+
+Please also report any ideas for enhancements you may have for either
+package and/or documentation.
+
+
+[keywords class {object oriented} object C++]
+[keywords Snit type {Incr Tcl} BWidget]
+[keywords widget adaptors {widget adaptors} {mega widget}]
+[manpage_end]
--- /dev/null
+#-----------------------------------------------------------------------
+# TITLE:
+# snit.tcl
+#
+# AUTHOR:
+# Will Duquette
+#
+# DESCRIPTION:
+# Snit's Not Incr Tcl, a simple object system in Pure Tcl.
+#
+# Snit 1.x Loader
+#
+# Copyright (C) 2003-2006 by William H. Duquette
+# This code is licensed as described in license.txt.
+#
+#-----------------------------------------------------------------------
+
+package require Tcl 8.3
+
+# Define the snit namespace and save the library directory
+
+namespace eval ::snit:: {
+ set library [file dirname [info script]]
+}
+
+# Select the implementation based on the version of the Tcl core
+# executing this code. For 8.3 we use a backport emulating various
+# 8.4 features
+
+if {[package vsatisfies [package provide Tcl] 8.4]} {
+ source [file join $::snit::library main1.tcl]
+} else {
+ source [file join $::snit::library main1_83.tcl]
+ source [file join $::snit::library snit_tcl83_utils.tcl]
+}
+
+# Load the library of Snit validation types.
+
+source [file join $::snit::library validate.tcl]
+
+package provide snit 1.4.2
--- /dev/null
+# -*- tcl -*-
+#---------------------------------------------------------------------
+# TITLE:
+# snit.test
+#
+# AUTHOR:
+# Will Duquette
+#
+# DESCRIPTION:
+# Test cases for snit.tcl. Uses the ::tcltest:: harness.
+#
+# If Tcl is 8.5, Snit 2.0 is loaded.
+# If Tcl is 8.4, Snit 1.2 is loaded.
+# If Tcl is 8.3, Snit 1.2 is loaded. (Kenneth Green's backport).
+#
+# Tests back-ported to Tcl 8.3 for snit 1.2 backport by kmg
+# Backport of test made general by Andreas Kupries.
+#
+# The tests assume tcltest 2.2
+
+#-----------------------------------------------------------------------
+# Back-port to Tcl8.3 by Kenneth Green (kmg)
+#
+# Global changes:
+# " eq " => "string equal"
+# " ne " -> "!string equal"
+#-----------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.3
+testsNeedTcltest 2.2
+
+#---------------------------------------------------------------------
+# Set up a number of constraints. This also determines which
+# implementation of snit is loaded and tested.
+
+# WHD: Work around bugs in 8.5a3
+tcltest::testConstraint bug8.5a3 [expr {![string equal [info patchlevel] "8.5a3"]}]
+
+# Marks tests which are only for Tk.
+tcltest::testConstraint tk [info exists tk_version]
+
+# If Tk is available, require BWidget
+tcltest::testConstraint bwidget [expr {
+ [tcltest::testConstraint tk] &&
+ ![catch {package require BWidget}]
+}]
+
+# Determine which Snit version to load. If Tcl 8.5, use 2.x.
+# Otherwise, use 1.x. (Different variants depending on 8.3 vs 8.4)
+if {[package vsatisfies [package present Tcl] 8.5]} {
+ set snitVersion 2
+ set snitFile snit2.tcl
+} else {
+ set snitVersion 1
+ set snitFile snit.tcl
+}
+
+# Marks tests which are only for Snit 1
+tcltest::testConstraint snit1 [expr {$snitVersion == 1}]
+
+# Marks tests which are only for Snit 2
+tcltest::testConstraint snit2 [expr {$snitVersion == 2}]
+
+# Marks tests which are only for Snit 1 with Tcl 8.3
+tcltest::testConstraint tcl83 [string equal [info tclversion] "8.3"]
+tcltest::testConstraint tcl84 [package vsatisfies [package present Tcl] 8.4]
+
+if {[package vsatisfies [package provide Tcl] 8.6]} {
+ # 8.6+
+ proc expect {six default} { return $six }
+} else {
+ # 8.4/8.5
+ proc expect {six default} { return $default }
+}
+
+#---------------------------------------------------------------------
+# Load the snit package.
+
+testing {
+ useLocal $snitFile snit
+}
+
+#---------------------------------------------------------------------
+
+namespace import ::snit::*
+
+# Set up for Tk tests: Repeat background errors
+proc bgerror {msg} {
+ global errorInfo
+ set ::bideError $msg
+ set ::bideErrorInfo $errorInfo
+}
+
+# Set up for Tk tests: enter the event loop long enough to catch
+# any bgerrors.
+proc tkbide {{msg "tkbide"} {msec 500}} {
+ set ::bideVar 0
+ set ::bideError ""
+ set ::bideErrorInfo ""
+ # It looks like update idletasks does the job.
+ if {0} {
+ after $msec {set ::bideVar 1}
+ tkwait variable ::bideVar
+ }
+ update idletasks
+ if {"" != $::bideError} {
+ error "$msg: $::bideError" $::bideErrorInfo
+ }
+}
+
+# cleanup type
+proc cleanupType {name} {
+ if {[namespace exists $name]} {
+ if {[catch {$name destroy} result]} {
+ global errorInfo
+ puts $errorInfo
+ error "Could not cleanup $name!"
+ }
+ }
+ tkbide "cleanupType $name"
+}
+
+# cleanup before each test
+proc cleanup {} {
+ global errorInfo
+
+ cleanupType ::dog
+ cleanupType ::cat
+ cleanupType ::mylabel
+ cleanupType ::myframe
+ cleanupType ::foo
+ cleanupType ::bar
+ cleanupType ::tail
+ cleanupType ::papers
+ cleanupType ::animal
+ cleanupType ::confused-dog
+ catch {option clear}
+
+ if {![string equal [info commands "spot"] ""]} {
+ puts "spot not erased!"
+ error "spot not erased!"
+ }
+
+ if {![string equal [info commands "fido"] ""]} {
+ puts "fido not erased!"
+ error "fido not erased!"
+ }
+}
+
+# catch error code and error
+
+proc codecatch {command} {
+ if {![catch {uplevel 1 $command} result]} {
+ error "expected error, got OK"
+ }
+
+ return "$::errorCode $result"
+}
+
+
+#-----------------------------------------------------------------------
+# Internals: tests for Snit utility functions
+
+test Expand-1.1 {template, no arguments} -body {
+ snit::Expand "My %TEMPLATE%"
+} -result {My %TEMPLATE%}
+
+test Expand-1.2 {template, no matching arguments} -body {
+ snit::Expand "My %TEMPLATE%" %FOO% foo
+} -result {My %TEMPLATE%}
+
+test Expand-1.3 {template with matching arguments} -body {
+ snit::Expand "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo
+} -result {bar foo bar}
+
+test Expand-1.4 {template with odd number of arguments} -body {
+ snit::Expand "%FOO% %BAR% %FOO%" %FOO%
+} -result {char map list unbalanced} -returnCodes error
+
+test Mappend-1.1 {template, no arguments} -body {
+ set text "Prefix: "
+ snit::Mappend text "My %TEMPLATE%"
+} -cleanup {
+ unset text
+} -result {Prefix: My %TEMPLATE%}
+
+test Mappend-1.2 {template, no matching arguments} -body {
+ set text "Prefix: "
+ snit::Mappend text "My %TEMPLATE%" %FOO% foo
+} -cleanup {
+ unset text
+} -result {Prefix: My %TEMPLATE%}
+
+test Mappend-1.3 {template with matching arguments} -body {
+ set text "Prefix: "
+ snit::Mappend text "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo
+} -cleanup {
+ unset text
+} -result {Prefix: bar foo bar}
+
+test Mappend-1.4 {template with odd number of arguments} -body {
+ set text "Prefix: "
+ snit::Mappend text "%FOO% %BAR% %FOO%" %FOO%
+} -cleanup {
+ unset text
+} -returnCodes error -result {char map list unbalanced}
+
+test RT.UniqueName-1.1 {no name collision} -body {
+ set counter 0
+
+ # Standard qualified type name.
+ set n1 [snit::RT.UniqueName counter ::mytype ::my::%AUTO%]
+
+ # Standard qualified widget name.
+ set n2 [snit::RT.UniqueName counter ::mytype .my.%AUTO%]
+
+ list $n1 $n2
+} -result {::my::mytype1 .my.mytype2} -cleanup {
+ unset counter n1 n2
+}
+
+test RT.UniqueName-1.2 {name collision} -body {
+ set counter 0
+
+ # Create the first two equivalent procs.
+ proc ::mytype1 {} {}
+ proc ::mytype2 {} {}
+
+ # Create a new name; it should skip to 3.
+ snit::RT.UniqueName counter ::mytype ::%AUTO%
+} -cleanup {
+ unset counter
+ rename ::mytype1 ""
+ rename ::mytype2 ""
+} -result {::mytype3}
+
+test RT.UniqueName-1.3 {nested type name} -body {
+ set counter 0
+
+ snit::RT.UniqueName counter ::thisis::yourtype ::your::%AUTO%
+} -cleanup {
+ unset counter
+} -result {::your::yourtype1}
+
+test RT.UniqueInstanceNamespace-1.1 {no name collision} -setup {
+ namespace eval ::mytype:: {}
+} -body {
+ set counter 0
+ snit::RT.UniqueInstanceNamespace counter ::mytype
+} -cleanup {
+ unset counter
+ namespace delete ::mytype::
+} -result {::mytype::Snit_inst1}
+
+test RT.UniqueInstanceNamespace-1.2 {name collision} -setup {
+ namespace eval ::mytype:: {}
+ namespace eval ::mytype::Snit_inst1:: {}
+ namespace eval ::mytype::Snit_inst2:: {}
+} -body {
+ set counter 0
+
+ # Should skip to 3.
+ snit::RT.UniqueInstanceNamespace counter ::mytype
+} -cleanup {
+ unset counter
+ namespace delete ::mytype::
+} -result {::mytype::Snit_inst3}
+
+test Contains-1.1 {contains element} -constraints {
+ snit1
+} -setup {
+ set mylist {foo bar baz}
+} -body {
+ snit::Contains baz $mylist
+} -cleanup {
+ unset mylist
+} -result {1}
+
+test Contains-1.2 {does not contain element} -constraints {
+ snit1
+} -setup {
+ set mylist {foo bar baz}
+} -body {
+ snit::Contains quux $mylist
+} -cleanup {
+ unset mylist
+} -result {0}
+
+#-----------------------------------------------------------------------
+# type compilation
+
+# snit::compile returns two values, the qualified type name
+# and the script to execute to define the type. This section
+# only checks the length of the list and the type name;
+# the content of the script is validated by the remainder
+# of this test suite.
+
+test compile-1.1 {compile returns qualified type} -body {
+ set compResult [compile type dog { }]
+
+ list [llength $compResult] [lindex $compResult 0]
+} -result {2 ::dog}
+
+#-----------------------------------------------------------------------
+# type destruction
+
+test typedestruction-1.1 {type command is deleted} -body {
+ type dog { }
+ dog destroy
+ info command ::dog
+} -result {}
+
+test typedestruction-1.2 {instance commands are deleted} -body {
+ type dog { }
+
+ dog create spot
+ dog destroy
+ info command ::spot
+} -result {}
+
+test typedestruction-1.3 {type namespace is deleted} -body {
+ type dog { }
+ dog destroy
+ namespace exists ::dog
+} -result {0}
+
+test typedestruction-1.4 {type proc is destroyed on error} -body {
+ catch {type dog {
+ error "Error creating dog"
+ }} result
+
+ list [namespace exists ::dog] [info command ::dog]
+} -result {0 {}}
+
+test typedestruction-1.5 {unrelated namespaces are deleted, bug 2898640} -body {
+ type dog {}
+ namespace eval dog::unrelated {}
+ dog destroy
+} -result {}
+
+#-----------------------------------------------------------------------
+# type and typemethods
+
+test type-1.1 {type names get qualified} -body {
+ type dog {}
+} -cleanup {
+ dog destroy
+} -result {::dog}
+
+test type-1.2 {typemethods can be defined} -body {
+ type dog {
+ typemethod foo {a b} {
+ return [list $a $b]
+ }
+ }
+
+ dog foo 1 2
+} -cleanup {
+ dog destroy
+} -result {1 2}
+
+test type-1.3 {upvar works in typemethods} -body {
+ type dog {
+ typemethod goodname {varname} {
+ upvar $varname myvar
+ set myvar spot
+ }
+ }
+
+ set thename fido
+ dog goodname thename
+ set thename
+} -cleanup {
+ dog destroy
+ unset thename
+} -result {spot}
+
+test type-1.4 {typemethod args can't include type} -body {
+ type dog {
+ typemethod foo {a type b} { }
+ }
+} -returnCodes error -result {typemethod foo's arglist may not contain "type" explicitly}
+
+test type-1.5 {typemethod args can't include self} -body {
+ type dog {
+ typemethod foo {a self b} { }
+ }
+} -returnCodes error -result {typemethod foo's arglist may not contain "self" explicitly}
+
+test type-1.6 {typemethod args can span multiple lines} -body {
+ # This case caused an error at definition time in 0.9 because the
+ # arguments were included in a comment in the compile script, and
+ # the subsequent lines weren't commented.
+ type dog {
+ typemethod foo {
+ a
+ b
+ } { }
+ }
+} -cleanup {
+ dog destroy
+} -result {::dog}
+
+
+#-----------------------------------------------------------------------
+# typeconstructor
+
+test typeconstructor-1.1 {a typeconstructor can be defined} -body {
+ type dog {
+ typevariable a
+
+ typeconstructor {
+ set a 1
+ }
+
+ typemethod aget {} {
+ return $a
+ }
+ }
+
+ dog aget
+} -cleanup {
+ dog destroy
+} -result {1}
+
+test typeconstructor-1.2 {only one typeconstructor can be defined} -body {
+ type dog {
+ typevariable a
+
+ typeconstructor {
+ set a 1
+ }
+
+ typeconstructor {
+ set a 2
+ }
+ }
+} -returnCodes error -result {too many typeconstructors}
+
+test typeconstructor-1.3 {type proc is destroyed on error} -body {
+ catch {
+ type dog {
+ typeconstructor {
+ error "Error creating dog"
+ }
+ }
+ } result
+
+ list [namespace exists ::dog] [info command ::dog]
+} -result {0 {}}
+
+#-----------------------------------------------------------------------
+# Type components
+
+test typecomponent-1.1 {typecomponent defines typevariable} -body {
+ type dog {
+ typecomponent mycomp
+
+ typemethod test {} {
+ return $mycomp
+ }
+ }
+
+ dog test
+} -cleanup {
+ dog destroy
+} -result {}
+
+test typecomponent-1.2 {typecomponent trace executes} -body {
+ type dog {
+ typecomponent mycomp
+
+ typemethod test {} {
+ typevariable Snit_typecomponents
+ set mycomp foo
+ return $Snit_typecomponents(mycomp)
+ }
+ }
+
+ dog test
+} -cleanup {
+ dog destroy
+} -result {foo}
+
+test typecomponent-1.3 {typecomponent -public works} -body {
+ type dog {
+ typecomponent mycomp -public string
+
+ typeconstructor {
+ set mycomp string
+ }
+ }
+
+ dog string length foo
+} -cleanup {
+ dog destroy
+} -result {3}
+
+test typecomponent-1.4 {typecomponent -inherit yes} -body {
+ type dog {
+ typecomponent mycomp -inherit yes
+
+ typeconstructor {
+ set mycomp string
+ }
+ }
+
+ dog length foo
+} -cleanup {
+ dog destroy
+} -result {3}
+
+
+#-----------------------------------------------------------------------
+# hierarchical type methods
+
+test htypemethod-1.1 {hierarchical method, two tokens} -body {
+ type dog {
+ typemethod {wag tail} {} {
+ return "wags tail"
+ }
+ }
+
+ dog wag tail
+} -cleanup {
+ dog destroy
+} -result {wags tail}
+
+test htypemethod-1.2 {hierarchical method, three tokens} -body {
+ type dog {
+ typemethod {wag tail proudly} {} {
+ return "wags tail proudly"
+ }
+ }
+
+ dog wag tail proudly
+} -cleanup {
+ dog destroy
+} -result {wags tail proudly}
+
+test htypemethod-1.3 {hierarchical method, four tokens} -body {
+ type dog {
+ typemethod {wag tail really high} {} {
+ return "wags tail really high"
+ }
+ }
+
+ dog wag tail really high
+} -cleanup {
+ dog destroy
+} -result {wags tail really high}
+
+test htypemethod-1.4 {redefinition is OK} -body {
+ type dog {
+ typemethod {wag tail} {} {
+ return "wags tail"
+ }
+ typemethod {wag tail} {} {
+ return "wags tail briskly"
+ }
+ }
+
+ dog wag tail
+} -cleanup {
+ dog destroy
+} -result {wags tail briskly}
+
+# Case 1
+test htypemethod-1.5 {proper error on missing submethod} -constraints {
+ snit1
+} -body {
+ cleanup
+
+ type dog {
+ typemethod {wag tail} {} { }
+ }
+
+ dog wag
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {wrong number args: should be "::dog wag method args"}
+
+# Case 2
+test htypemethod-1.6 {proper error on missing submethod} -constraints {
+ snit2
+} -body {
+ cleanup
+
+ type dog {
+ typemethod {wag tail} {} { }
+ }
+
+ dog wag
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [expect \
+ {wrong # args: should be "dog wag subcommand ?arg ...?"} \
+ {wrong # args: should be "dog wag subcommand ?argument ...?"}]
+
+# Case 1
+test htypemethod-1.7 {proper error on bogus submethod} -constraints {
+ snit1
+} -body {
+ cleanup
+
+ type dog {
+ typemethod {wag tail} {} { }
+ }
+
+ dog wag ears
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {"::dog wag ears" is not defined}
+
+# Case 2
+test htypemethod-1.8 {proper error on bogus submethod} -constraints {
+ snit2
+} -body {
+ cleanup
+
+ type dog {
+ typemethod {wag tail} {} { }
+ }
+
+ dog wag ears
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "ears": namespace ::dog does not export any commands}
+
+test htypemethod-2.1 {prefix/method collision, level 1, order 1} -body {
+ type dog {
+ typemethod wag {} {}
+ typemethod {wag tail} {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "typemethod {wag tail}...", "wag" has no submethods.}
+
+test htypemethod-2.2 {prefix/method collision, level 1, order 2} -body {
+ type dog {
+ typemethod {wag tail} {} {}
+ typemethod wag {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "typemethod wag...", "wag" has submethods.}
+
+test htypemethod-2.3 {prefix/method collision, level 2, order 1} -body {
+ type dog {
+ typemethod {wag tail} {} {}
+ typemethod {wag tail proudly} {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "typemethod {wag tail proudly}...", "wag tail" has no submethods.}
+
+test htypemethod-2.4 {prefix/method collision, level 2, order 2} -body {
+ type dog {
+ typemethod {wag tail proudly} {} {}
+ typemethod {wag tail} {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "typemethod {wag tail}...", "wag tail" has submethods.}
+
+#-----------------------------------------------------------------------
+# Typemethod delegation
+
+test dtypemethod-1.1 {delegate typemethod to non-existent component} -body {
+ set result ""
+
+ type dog {
+ delegate typemethod foo to bar
+ }
+
+ dog foo
+} -returnCodes {
+ error
+} -result {::dog delegates typemethod "foo" to undefined typecomponent "bar"}
+
+test dtypemethod-1.2 {delegating to existing typecomponent} -body {
+ type dog {
+ delegate typemethod length to string
+
+ typeconstructor {
+ set string string
+ }
+ }
+
+ dog length foo
+} -cleanup {
+ dog destroy
+} -result {3}
+
+# Case 1
+test dtypemethod-1.3 {delegating to existing typecomponent with error} -constraints {
+ snit1
+} -body {
+ type dog {
+ delegate typemethod length to string
+
+ typeconstructor {
+ set string string
+ }
+ }
+
+ dog length foo bar
+} -returnCodes {
+ error
+} -result {wrong # args: should be "string length string"}
+
+# Case 2
+test dtypemethod-1.4 {delegating to existing typecomponent with error} -constraints {
+ snit2
+} -body {
+ type dog {
+ delegate typemethod length to string
+
+ typeconstructor {
+ set string string
+ }
+ }
+
+ dog length foo bar
+} -returnCodes {
+ error
+} -result {wrong # args: should be "dog length string"}
+
+test dtypemethod-1.5 {delegating unknown typemethods to existing typecomponent} -body {
+ type dog {
+ delegate typemethod * to string
+
+ typeconstructor {
+ set string string
+ }
+ }
+
+ dog length foo
+} -cleanup {
+ dog destroy
+} -result {3}
+
+# Case 1
+test dtypemethod-1.6 {delegating unknown typemethod to existing typecomponent with error} -body {
+ type dog {
+ delegate typemethod * to stringhandler
+
+ typeconstructor {
+ set stringhandler string
+ }
+ }
+
+ dog foo bar
+} -constraints {
+ snit1
+} -returnCodes {
+ error
+} -result {bad option "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}
+
+test dtypemethod-1.6a {delegating unknown typemethod to existing typecomponent with error} -body {
+ type dog {
+ delegate typemethod * to stringhandler
+
+ typeconstructor {
+ set stringhandler string
+ }
+ }
+
+ dog foo bar
+} -constraints {
+ snit2
+} -returnCodes {
+ error
+} -result {unknown or ambiguous subcommand "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}
+
+test dtypemethod-1.7 {can't delegate local typemethod: order 1} -body {
+ type dog {
+ typemethod foo {} {}
+ delegate typemethod foo to bar
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate typemethod foo...", "foo" has been defined locally.}
+
+test dtypemethod-1.8 {can't delegate local typemethod: order 2} -body {
+ type dog {
+ delegate typemethod foo to bar
+ typemethod foo {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "typemethod foo...", "foo" has been delegated}
+
+# Case 1
+test dtypemethod-1.9 {excepted methods are caught properly} -constraints {
+ snit1
+} -body {
+ type dog {
+ delegate typemethod * to string except {match index}
+
+ typeconstructor {
+ set string string
+ }
+ }
+
+ catch {dog length foo} a
+ catch {dog match foo} b
+ catch {dog index foo} c
+
+ list $a $b $c
+} -cleanup {
+ dog destroy
+} -result {3 {"::dog match" is not defined} {"::dog index" is not defined}}
+
+# Case 2
+test dtypemethod-1.10 {excepted methods are caught properly} -constraints {
+ snit2
+} -body {
+ type dog {
+ delegate typemethod * to string except {match index}
+
+ typeconstructor {
+ set string string
+ }
+ }
+
+ catch {dog length foo} a
+ catch {dog match foo} b
+ catch {dog index foo} c
+
+ list $a $b $c
+} -cleanup {
+ dog destroy
+} -result {3 {unknown subcommand "match": must be length} {unknown subcommand "index": must be length}}
+
+test dtypemethod-1.11 {as clause can include arguments} -body {
+ proc tail {a b} {
+ return "<$a $b>"
+ }
+
+ type dog {
+ delegate typemethod wag to tail as {wag briskly}
+
+ typeconstructor {
+ set tail tail
+ }
+ }
+
+ dog wag
+} -cleanup {
+ dog destroy
+ rename tail ""
+} -result {<wag briskly>}
+
+test dtypemethod-2.1 {'using "%c %m"' gets normal behavior} -body {
+ type dog {
+ delegate typemethod length to string using {%c %m}
+
+ typeconstructor {
+ set string string
+ }
+ }
+
+ dog length foo
+} -cleanup {
+ dog destroy
+} -result {3}
+
+test dtypemethod-2.2 {All relevant 'using' conversions are converted} -body {
+ proc echo {args} {
+ return $args
+ }
+
+ type dog {
+ delegate typemethod {tail wag} using {echo %% %t %M %m %j %n %w %s %c}
+ }
+
+ dog tail wag
+} -cleanup {
+ dog destroy
+ rename echo ""
+} -result {% ::dog {tail wag} wag tail_wag %n %w %s %c}
+
+test dtypemethod-2.3 {"%%" is handled properly} -body {
+ proc echo {args} { join $args "|" }
+
+ type dog {
+ delegate typemethod wag using {echo %%m %%%m}
+ }
+
+ dog wag
+} -cleanup {
+ dog destroy
+ rename echo ""
+} -result {%m|%wag}
+
+test dtypemethod-2.4 {Method "*" and "using"} -body {
+ proc echo {args} { join $args "|" }
+
+ type dog {
+ delegate typemethod * using {echo %m}
+ }
+
+ list [dog wag] [dog bark loudly]
+} -cleanup {
+ dog destroy
+ rename echo ""
+} -result {wag bark|loudly}
+
+test dtypemethod-3.1 {typecomponent names can be changed dynamically} -body {
+ proc echo {args} { join $args "|" }
+
+ type dog {
+ delegate typemethod length to mycomp
+
+ typeconstructor {
+ set mycomp string
+ }
+
+ typemethod switchit {} {
+ set mycomp echo
+ }
+ }
+
+ set a [dog length foo]
+ dog switchit
+ set b [dog length foo]
+
+ list $a $b
+} -cleanup {
+ dog destroy
+ rename echo ""
+} -result {3 length|foo}
+
+test dtypemethod-4.1 {hierarchical typemethod, two tokens} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {wag tail} to tail as wag
+ }
+
+ dog wag tail
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dtypemethod-4.2 {hierarchical typemethod, three tokens} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {wag tail proudly} to tail as wag
+ }
+
+ dog wag tail proudly
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dtypemethod-4.3 {hierarchical typemethod, four tokens} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {wag tail really high} to tail as wag
+ }
+
+ dog wag tail really high
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dtypemethod-4.4 {redefinition is OK} -body {
+ type tail {
+ method {wag tail} {} {return "wags tail"}
+ method {wag briskly} {} {return "wags tail briskly"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {wag tail} to tail as {wag tail}
+ delegate typemethod {wag tail} to tail as {wag briskly}
+ }
+
+ dog wag tail
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail briskly}
+
+test dtypemethod-4.5 {last token is used by default} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {tail wag} to tail
+ }
+
+ dog tail wag
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dtypemethod-4.6 {last token can be *} -body {
+ type tail {
+ method wag {} {return "wags"}
+ method droop {} {return "droops"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {tail *} to tail
+ }
+
+ list [dog tail wag] [dog tail droop]
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags droops}
+
+# Case 2
+test dtypemethod-4.7 {except with multiple tokens} -constraints {
+ snit1
+} -body {
+ type tail {
+ method wag {} {return "wags"}
+ method droop {} {return "droops"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {tail *} to tail except droop
+ }
+
+ catch {dog tail droop} result
+
+ list [dog tail wag] $result
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags {"::dog tail droop" is not defined}}
+
+# Case 2
+test dtypemethod-4.8 {except with multiple tokens} -constraints {
+ snit2
+} -body {
+ type tail {
+ method wag {} {return "wags"}
+ method droop {} {return "droops"}
+ }
+
+ type dog {
+ typeconstructor {
+ set tail [tail %AUTO%]
+ }
+ delegate typemethod {tail *} to tail except droop
+ }
+
+ catch {dog tail droop} result
+
+ list [dog tail wag] $result
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags {unknown subcommand "droop": namespace ::dog does not export any commands}}
+
+test dtypemethod-4.9 {"*" in the wrong spot} -body {
+ type dog {
+ delegate typemethod {tail * wag} to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate typemethod {tail * wag}...", "*" must be the last token.}
+
+test dtypemethod-5.1 {prefix/typemethod collision} -body {
+ type dog {
+ delegate typemethod wag to tail
+ delegate typemethod {wag tail} to tail as wag
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate typemethod {wag tail}...", "wag" has no submethods.}
+
+test dtypemethod-5.2 {prefix/typemethod collision} -body {
+ type dog {
+ delegate typemethod {wag tail} to tail as wag
+ delegate typemethod wag to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate typemethod wag...", "wag" has submethods.}
+
+test dtypemethod-5.3 {prefix/typemethod collision} -body {
+ type dog {
+ delegate typemethod {wag tail} to tail
+ delegate typemethod {wag tail proudly} to tail as wag
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate typemethod {wag tail proudly}...", "wag tail" has no submethods.}
+
+test dtypemethod-5.4 {prefix/typemethod collision} -body {
+ type dog {
+ delegate typemethod {wag tail proudly} to tail as wag
+ delegate typemethod {wag tail} to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate typemethod {wag tail}...", "wag tail" has submethods.}
+
+#-----------------------------------------------------------------------
+# type creation
+
+test creation-1.1 {type instance names get qualified} -body {
+ type dog { }
+
+ dog create spot
+} -cleanup {
+ dog destroy
+} -result {::spot}
+
+test creation-1.2 {type instance names can be generated} -body {
+ type dog { }
+
+ dog create my%AUTO%
+} -cleanup {
+ dog destroy
+} -result {::mydog1}
+
+test creation-1.3 {"create" method is optional} -body {
+ type dog { }
+
+ dog fido
+} -cleanup {
+ dog destroy
+} -result {::fido}
+
+test creation-1.4 {constructor arg can't be type} -body {
+ type dog {
+ constructor {type} { }
+ }
+} -returnCodes {
+ error
+} -result {constructor's arglist may not contain "type" explicitly}
+
+test creation-1.5 {constructor arg can't be self} -body {
+ type dog {
+ constructor {self} { }
+ }
+} -returnCodes {
+ error
+} -result {constructor's arglist may not contain "self" explicitly}
+
+test creation-1.6 {weird names are OK} -body {
+ # I.e., names with non-identifier characters
+ type confused-dog {
+ method meow {} {
+ return "$self meows."
+ }
+ }
+
+ confused-dog spot
+ spot meow
+} -cleanup {
+ confused-dog destroy
+} -result {::spot meows.}
+
+# Case 1
+test creation-1.7 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints {
+ snit1
+} -body {
+ type dog {
+ variable dummy
+ }
+
+ set mydog [dog]
+} -cleanup {
+ $mydog destroy
+ dog destroy
+} -result {::dog1}
+
+# Case 2
+test creation-1.8 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints {
+ snit2
+} -body {
+ type dog {
+ # WHD: In Snit 1.0, this pragma was not needed.
+ pragma -hastypemethods no
+ variable dummy
+ }
+
+ set mydog [dog]
+} -cleanup {
+ # [dog destroy] doesn't exist
+ $mydog destroy
+ namespace delete ::dog
+} -result {::dog1}
+
+# Case 1
+test creation-1.9 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -hasinstances no
+ }
+
+ set mydog [dog]
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {wrong # args: should be "::dog method args"}
+
+# Case 2
+test creation-1.10 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints {
+ snit2
+} -body {
+ type dog {
+ pragma -hasinstances no
+ }
+
+ set mydog [dog]
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result [expect \
+ {wrong # args: should be "dog subcommand ?arg ...?"} \
+ {wrong # args: should be "dog subcommand ?argument ...?"}]
+
+# Case 1
+test creation-1.11 {If widget, [$type] != [$type create %AUTO%]} -constraints {
+ snit1 tk
+} -body {
+ widget dog {
+ variable dummy
+ }
+
+ set mydog [dog]
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {wrong # args: should be "::dog method args"}
+
+# Case 2
+test creation-1.12 {If widget, [$type] != [$type create %AUTO%]} -constraints {
+ snit2 tk
+} -body {
+ widget dog {
+ variable dummy
+ }
+
+ set mydog [dog]
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result [expect \
+ {wrong # args: should be "dog subcommand ?arg ...?"} \
+ {wrong # args: should be "dog subcommand ?argument ...?"}]
+
+test creation-1.13 {If -hastypemethods yes, [$type] == [$type create %AUTO%]} -constraints {
+ snit1
+} -body {
+ type dog {
+ variable dummy
+ }
+
+ set mydog [dog]
+} -cleanup {
+ dog destroy
+} -result {::dog1}
+
+test creation-1.14 {If -hastypemethods yes, [$type] != [$type create %AUTO%]} -constraints {
+ snit2
+} -body {
+ type dog {
+ variable dummy
+ }
+
+ set mydog [dog]
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result [expect \
+ {wrong # args: should be "dog subcommand ?arg ...?"} \
+ {wrong # args: should be "dog subcommand ?argument ...?"}]
+
+test creation-2.1 {Can't call "destroy" in constructor} -body {
+ type dog {
+ constructor {} {
+ $self destroy
+ }
+ }
+
+ dog spot
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {Error in constructor: Called 'destroy' method in constructor}
+
+#-----------------------------------------------------------------------
+# procs
+
+test proc-1.1 {proc args can span multiple lines} -body {
+ # This case caused an error at definition time in 0.9 because the
+ # arguments were included in a comment in the compile script, and
+ # the subsequent lines weren't commented.
+ type dog {
+ proc foo {
+ a
+ b
+ } { }
+ }
+} -cleanup {
+ dog destroy
+} -result {::dog}
+
+
+#-----------------------------------------------------------------------
+# methods
+
+test method-1.1 {methods get called} -body {
+ type dog {
+ method bark {} {
+ return "$self barks"
+ }
+ }
+
+ dog create spot
+ spot bark
+} -cleanup {
+ dog destroy
+} -result {::spot barks}
+
+test method-1.2 {methods can call other methods} -body {
+ type dog {
+ method bark {} {
+ return "$self barks."
+ }
+
+ method chase {quarry} {
+ return "$self chases $quarry; [$self bark]"
+ }
+ }
+
+ dog create spot
+ spot chase cat
+} -cleanup {
+ dog destroy
+} -result {::spot chases cat; ::spot barks.}
+
+test method-1.3 {instances can call one another} -body {
+ type dog {
+ method bark {} {
+ return "$self barks."
+ }
+
+ method chase {quarry} {
+ return "$self chases $quarry; [$quarry bark] [$self bark]"
+ }
+ }
+
+ dog create spot
+ dog create fido
+ spot chase ::fido
+} -cleanup {
+ dog destroy
+} -result {::spot chases ::fido; ::fido barks. ::spot barks.}
+
+test method-1.4 {upvar works in methods} -body {
+ type dog {
+ method goodname {varname} {
+ upvar $varname myvar
+ set myvar spot
+ }
+ }
+
+ dog create fido
+ set thename fido
+ fido goodname thename
+ set thename
+} -cleanup {
+ dog destroy
+} -result {spot}
+
+# Case 1
+test method-1.5 {unknown methods get an error} -constraints {
+ snit1
+} -body {
+ type dog { }
+
+ dog create spot
+ set result ""
+ spot chase
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {"::spot chase" is not defined}
+
+# Case 2
+test method-1.6 {unknown methods get an error} -constraints {
+ snit2
+} -body {
+ type dog { }
+
+ dog create spot
+ set result ""
+ spot chase
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {unknown subcommand "chase": namespace ::dog::Snit_inst1 does not export any commands}
+
+test method-1.7 {info type method returns the object's type} -body {
+ type dog { }
+
+ dog create spot
+ spot info type
+} -cleanup {
+ dog destroy
+} -result {::dog}
+
+test method-1.8 {instance method can call type method} -body {
+ type dog {
+ typemethod hello {} {
+ return "Hello"
+ }
+ method helloworld {} {
+ return "[$type hello], World!"
+ }
+ }
+
+ dog create spot
+ spot helloworld
+} -cleanup {
+ dog destroy
+} -result {Hello, World!}
+
+test method-1.9 {type methods must be qualified} -body {
+ type dog {
+ typemethod hello {} {
+ return "Hello"
+ }
+ method helloworld {} {
+ return "[hello], World!"
+ }
+ }
+
+ dog create spot
+ spot helloworld
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {invalid command name "hello"}
+
+# Case 1
+test method-1.10 {too few arguments} -constraints {
+ snit1
+} -body {
+ type dog {
+ method bark {volume} { }
+ }
+
+ dog create spot
+ spot bark
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result [tcltest::wrongNumArgs ::dog::Snit_methodbark {type selfns win self volume} 4]
+
+# Case 2
+test method-1.11 {too few arguments} -constraints {
+ snit2
+} -body {
+ type dog {
+ method bark {volume} { }
+ }
+
+ dog create spot
+ spot bark
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {wrong # args: should be "spot bark volume"}
+
+# Case 1
+test method-1.12 {too many arguments} -constraints {
+ snit1
+} -body {
+ type dog {
+ method bark {volume} { }
+ }
+
+ dog create spot
+
+ spot bark really loud
+} -returnCodes {
+ error
+} -result [tcltest::tooManyArgs ::dog::Snit_methodbark {type selfns win self volume}]
+
+# Case 2
+test method-1.13 {too many arguments} -constraints {
+ snit2
+} -body {
+ type dog {
+ method bark {volume} { }
+ }
+
+ dog create spot
+
+ spot bark really loud
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {wrong # args: should be "spot bark volume"}
+
+test method-1.14 {method args can't include type} -body {
+ type dog {
+ method foo {a type b} { }
+ }
+} -returnCodes {
+ error
+} -result {method foo's arglist may not contain "type" explicitly}
+
+test method-1.15 {method args can't include self} -body {
+ type dog {
+ method foo {a self b} { }
+ }
+} -returnCodes {
+ error
+} -result {method foo's arglist may not contain "self" explicitly}
+
+test method-1.16 {method args can span multiple lines} -body {
+ # This case caused an error at definition time in 0.9 because the
+ # arguments were included in a comment in the compile script, and
+ # the subsequent lines weren't commented.
+ type dog {
+ method foo {
+ a
+ b
+ } { }
+ }
+} -cleanup {
+ dog destroy
+} -result {::dog}
+
+#-----------------------------------------------------------------------
+# hierarchical methods
+
+test hmethod-1.1 {hierarchical method, two tokens} -body {
+ type dog {
+ method {wag tail} {} {
+ return "$self wags tail."
+ }
+ }
+
+ dog spot
+ spot wag tail
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail.}
+
+test hmethod-1.2 {hierarchical method, three tokens} -body {
+ type dog {
+ method {wag tail proudly} {} {
+ return "$self wags tail proudly."
+ }
+ }
+
+ dog spot
+ spot wag tail proudly
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail proudly.}
+
+test hmethod-1.3 {hierarchical method, three tokens} -body {
+ type dog {
+ method {wag tail really high} {} {
+ return "$self wags tail really high."
+ }
+ }
+
+ dog spot
+ spot wag tail really high
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail really high.}
+
+test hmethod-1.4 {redefinition is OK} -body {
+ type dog {
+ method {wag tail} {} {
+ return "$self wags tail."
+ }
+ method {wag tail} {} {
+ return "$self wags tail briskly."
+ }
+ }
+
+ dog spot
+ spot wag tail
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail briskly.}
+
+# Case 1
+test hmethod-1.5 {proper error on missing submethod} -constraints {
+ snit1
+} -body {
+ type dog {
+ method {wag tail} {} { }
+ }
+
+ dog spot
+ spot wag
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {wrong number args: should be "::spot wag method args"}
+
+# Case 2
+test hmethod-1.6 {proper error on missing submethod} -constraints {
+ snit2
+} -body {
+ type dog {
+ method {wag tail} {} { }
+ }
+
+ dog spot
+ spot wag
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result [expect \
+ {wrong # args: should be "spot wag subcommand ?arg ...?"} \
+ {wrong # args: should be "spot wag subcommand ?argument ...?"}]
+
+test hmethod-1.7 {submethods called in proper objects} -body {
+ # NOTE: This test was added in response to a bug report by
+ # Anton Kovalenko. In Snit 2.0, submethod ensembles were
+ # created in the type namespace. If a type defines a submethod
+ # ensemble, then all objects of that type would end up sharing
+ # a single ensemble. Ensembles are created lazily, so in this
+ # test, the first call to "fido this tail wag" and "spot this tail wag"
+ # will yield the correct result, but the second call to
+ # "fido this tail wag" will yield the same as the call to
+ # "spot this tail wag", because spot's submethod ensemble has
+ # displaced fido's. Until the bug is fixed, that is.
+ #
+ # Fortunately, Anton provided the fix as well.
+ type tail {
+ option -manner
+
+ method wag {} {
+ return "wags tail $options(-manner)"
+ }
+ }
+
+ type dog {
+ delegate option -manner to tail
+ delegate method {this tail wag} to tail
+
+ constructor {args} {
+ set tail [tail %AUTO%]
+ $self configurelist $args
+ }
+ }
+
+ dog fido -manner briskly
+ dog spot -manner slowly
+
+ list [fido this tail wag] [spot this tail wag] [fido this tail wag]
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {{wags tail briskly} {wags tail slowly} {wags tail briskly}}
+
+test hmethod-2.1 {prefix/method collision} -body {
+ type dog {
+ method wag {} {}
+ method {wag tail} {} {
+ return "$self wags tail."
+ }
+ }
+} -returnCodes {
+ error
+} -result {Error in "method {wag tail}...", "wag" has no submethods.}
+
+test hmethod-2.2 {prefix/method collision} -body {
+ type dog {
+ method {wag tail} {} {
+ return "$self wags tail."
+ }
+ method wag {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "method wag...", "wag" has submethods.}
+
+test hmethod-2.3 {prefix/method collision} -body {
+ type dog {
+ method {wag tail} {} {}
+ method {wag tail proudly} {} {
+ return "$self wags tail."
+ }
+ }
+} -returnCodes {
+ error
+} -result {Error in "method {wag tail proudly}...", "wag tail" has no submethods.}
+
+test hmethod-2.4 {prefix/method collision} -body {
+ type dog {
+ method {wag tail proudly} {} {
+ return "$self wags tail."
+ }
+ method {wag tail} {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "method {wag tail}...", "wag tail" has submethods.}
+
+#-----------------------------------------------------------------------
+# mymethod and renaming
+
+test rename-1.1 {mymethod uses name of instance name variable} -body {
+ type dog {
+ method mymethod {} {
+ list [mymethod] [mymethod "A B"] [mymethod A B]
+ }
+ }
+
+ dog fido
+ fido mymethod
+} -cleanup {
+ dog destroy
+} -result {{::snit::RT.CallInstance ::dog::Snit_inst1} {::snit::RT.CallInstance ::dog::Snit_inst1 {A B}} {::snit::RT.CallInstance ::dog::Snit_inst1 A B}}
+
+test rename-1.2 {instances can be renamed} -body {
+ type dog {
+ method names {} {
+ list [mymethod] $selfns $win $self
+ }
+ }
+
+ dog fido
+ set a [fido names]
+ rename fido spot
+ set b [spot names]
+
+ concat $a $b
+} -cleanup {
+ dog destroy
+} -result {{::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::fido {::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::spot}
+
+test rename-1.3 {rename to "" deletes an instance} -constraints {
+ bug8.5a3
+} -body {
+ type dog { }
+
+ dog fido
+ rename fido ""
+ namespace children ::dog
+} -cleanup {
+ dog destroy
+} -result {}
+
+test rename-1.4 {rename to "" deletes an instance even after a rename} -constraints {
+ bug8.5a3
+} -body {
+ type dog { }
+
+ dog fido
+ rename fido spot
+ rename spot ""
+ namespace children ::dog
+} -cleanup {
+ dog destroy
+} -result {}
+
+test rename-1.5 {creating an object twice destroys the first instance} -constraints {
+ bug8.5a3
+} -body {
+ type dog {
+ # Can't even test this normally.
+ pragma -canreplace yes
+ }
+
+ dog fido
+ set a [namespace children ::dog]
+ dog fido
+ set b [namespace children ::dog]
+ fido destroy
+ set c [namespace children ::dog]
+
+ list $a $b $c
+} -cleanup {
+ dog destroy
+} -result {::dog::Snit_inst1 ::dog::Snit_inst2 {}}
+
+#-----------------------------------------------------------------------
+# mymethod actually works
+
+test mymethod-1.1 {run mymethod handler} -body {
+ type foo {
+ option -command {}
+ method runcmd {} {
+ eval [linsert $options(-command) end $self snarf]
+ return
+ }
+ }
+ type bar {
+ variable sub
+ constructor {args} {
+ set sub [foo fubar -command [mymethod Handler]]
+ return
+ }
+
+ method Handler {args} {
+ set ::RES $args
+ }
+
+ method test {} {
+ $sub runcmd
+ return
+ }
+ }
+
+ set ::RES {}
+ bar boogle
+ boogle test
+ set ::RES
+} -cleanup {
+ bar destroy
+ foo destroy
+} -result {::bar::fubar snarf}
+
+#-----------------------------------------------------------------------
+# myproc
+
+test myproc-1.1 {myproc qualifies proc names} -body {
+ type dog {
+ proc foo {} {}
+
+ typemethod getit {} {
+ return [myproc foo]
+ }
+ }
+
+ dog getit
+} -cleanup {
+ dog destroy
+} -result {::dog::foo}
+
+test myproc-1.2 {myproc adds arguments} -body {
+ type dog {
+ proc foo {} {}
+
+ typemethod getit {} {
+ return [myproc foo "a b"]
+ }
+ }
+
+ dog getit
+} -cleanup {
+ dog destroy
+} -result {::dog::foo {a b}}
+
+test myproc-1.3 {myproc adds arguments} -body {
+ type dog {
+ proc foo {} {}
+
+ typemethod getit {} {
+ return [myproc foo "a b" c d]
+ }
+ }
+
+ dog getit
+} -cleanup {
+ dog destroy
+} -result {::dog::foo {a b} c d}
+
+test myproc-1.4 {procs with selfns work} -body {
+ type dog {
+ variable datum foo
+
+ method qualify {} {
+ return [myproc getdatum $selfns]
+ }
+ proc getdatum {selfns} {
+ return $datum
+ }
+ }
+ dog create spot
+ eval [spot qualify]
+} -cleanup {
+ dog destroy
+} -result {foo}
+
+
+#-----------------------------------------------------------------------
+# mytypemethod
+
+test mytypemethod-1.1 {mytypemethod qualifies typemethods} -body {
+ type dog {
+ typemethod this {} {}
+
+ typemethod a {} {
+ return [mytypemethod this]
+ }
+ typemethod b {} {
+ return [mytypemethod this x]
+ }
+ typemethod c {} {
+ return [mytypemethod this "x y"]
+ }
+ typemethod d {} {
+ return [mytypemethod this x y]
+ }
+ }
+
+ list [dog a] [dog b] [dog c] [dog d]
+} -cleanup {
+ dog destroy
+} -result {{::dog this} {::dog this x} {::dog this {x y}} {::dog this x y}}
+
+#-----------------------------------------------------------------------
+# typevariable
+
+test typevariable-1.1 {typevarname qualifies typevariables} -body {
+ # Note: typevarname is DEPRECATED. Real code should use
+ # mytypevar instead.
+ type dog {
+ method tvname {name} {
+ typevarname $name
+ }
+ }
+
+ dog create spot
+ spot tvname myvar
+} -cleanup {
+ dog destroy
+} -result {::dog::myvar}
+
+test typevariable-1.2 {undefined typevariables are OK} -body {
+ type dog {
+ method tset {value} {
+ typevariable theValue
+
+ set theValue $value
+ }
+
+ method tget {} {
+ typevariable theValue
+
+ return $theValue
+ }
+ }
+
+ dog create spot
+ dog create fido
+ spot tset Howdy
+
+ list [spot tget] [fido tget] [set ::dog::theValue]
+} -cleanup {
+ dog destroy
+} -result {Howdy Howdy Howdy}
+
+test typevariable-1.3 {predefined typevariables are OK} -body {
+ type dog {
+ typevariable greeting Hello
+
+ method tget {} {
+ return $greeting
+ }
+ }
+
+ dog create spot
+ dog create fido
+
+ list [spot tget] [fido tget] [set ::dog::greeting]
+} -cleanup {
+ dog destroy
+} -result {Hello Hello Hello}
+
+test typevariable-1.4 {typevariables can be arrays} -body {
+ type dog {
+ typevariable greetings
+
+ method fill {} {
+ set greetings(a) Hi
+ set greetings(b) Howdy
+ }
+ }
+
+ dog create spot
+ spot fill
+ list $::dog::greetings(a) $::dog::greetings(b)
+} -cleanup {
+ dog destroy
+} -result {Hi Howdy}
+
+test typevariable-1.5 {typevariables can used in typemethods} -body {
+ type dog {
+ typevariable greetings Howdy
+
+ typemethod greet {} {
+ return $greetings
+ }
+ }
+
+ dog greet
+} -cleanup {
+ dog destroy
+} -result {Howdy}
+
+test typevariable-1.6 {typevariables can used in procs} -body {
+ type dog {
+ typevariable greetings Howdy
+
+ method greet {} {
+ return [realGreet]
+ }
+
+ proc realGreet {} {
+ return $greetings
+ }
+ }
+
+ dog create spot
+ spot greet
+} -cleanup {
+ dog destroy
+} -result {Howdy}
+
+test typevariable-1.7 {mytypevar qualifies typevariables} -body {
+ type dog {
+ method tvname {name} {
+ mytypevar $name
+ }
+ }
+
+ dog create spot
+ spot tvname myvar
+} -cleanup {
+ dog destroy
+} -result {::dog::myvar}
+
+test typevariable-1.8 {typevariable with too many initializers throws an error} -body {
+ type dog {
+ typevariable color dark brown
+ }
+} -returnCodes {
+ error
+} -result {Error in "typevariable color...", too many initializers}
+
+test typevariable-1.9 {typevariable with too many initializers throws an error} -body {
+ type dog {
+ typevariable color -array dark brown
+ }
+
+ set result
+} -returnCodes {
+ error
+} -result {Error in "typevariable color...", too many initializers}
+
+test typevariable-1.10 {typevariable can initialize array variables} -body {
+ type dog {
+ typevariable data -array {
+ family jones
+ color brown
+ }
+
+ typemethod getdata {item} {
+ return $data($item)
+ }
+ }
+
+ list [dog getdata family] [dog getdata color]
+} -cleanup {
+ dog destroy
+} -result {jones brown}
+
+#-----------------------------------------------------------------------
+# instance variable
+
+test ivariable-1.1 {myvar qualifies instance variables} -body {
+ type dog {
+ method vname {name} {
+ myvar $name
+ }
+ }
+
+ dog create spot
+ spot vname somevar
+} -cleanup {
+ dog destroy
+} -result {::dog::Snit_inst1::somevar}
+
+test ivariable-1.2 {undefined instance variables are OK} -body {
+ type dog {
+ method setgreeting {value} {
+ variable greeting
+
+ set greeting $value
+ }
+
+ method getgreeting {} {
+ variable greeting
+
+ return $greeting
+ }
+ }
+
+ set spot [dog create spot]
+ spot setgreeting Hey
+
+ dog create fido
+ fido setgreeting Howdy
+
+ list [spot getgreeting] [fido getgreeting] [set ::dog::Snit_inst1::greeting]
+} -cleanup {
+ dog destroy
+} -result {Hey Howdy Hey}
+
+test ivariable-1.3 {instance variables are destroyed automatically} -body {
+ type dog {
+ constructor {args} {
+ variable greeting
+
+ set greeting Hi
+ }
+ }
+
+ dog create spot
+ set g1 $::dog::Snit_inst1::greeting
+
+ spot destroy
+ list $g1 [info exists ::dog::Snit_inst1::greeting]
+} -cleanup {
+ dog destroy
+} -result {Hi 0}
+
+test ivariable-1.4 {defined instance variables need not be declared} -body {
+ type dog {
+ variable greetings
+
+ method put {} {
+ set greetings Howdy
+ }
+
+ method get {} {
+ return $greetings
+ }
+ }
+
+ dog create spot
+ spot put
+ spot get
+} -cleanup {
+ dog destroy
+} -result {Howdy}
+
+test ivariable-1.5 {instance variables can be arrays} -body {
+ type dog {
+ variable greetings
+
+ method fill {} {
+ set greetings(a) Hi
+ set greetings(b) Howdy
+ }
+
+ method vname {} {
+ return [myvar greetings]
+ }
+ }
+
+ dog create spot
+ spot fill
+ list [set [spot vname](a)] [set [spot vname](b)]
+} -cleanup {
+ dog destroy
+} -result {Hi Howdy}
+
+test ivariable-1.6 {instance variables can be initialized in the definition} -body {
+ type dog {
+ variable greetings {Hi Howdy}
+ variable empty {}
+
+ method list {} {
+ list $greetings $empty
+ }
+ }
+
+ dog create spot
+ spot list
+} -cleanup {
+ dog destroy
+} -result {{Hi Howdy} {}}
+
+test ivariable-1.7 {variable is illegal when selfns is undefined} -body {
+ type dog {
+ method caller {} {
+ callee
+ }
+ proc callee {} {
+ variable foo
+ }
+ }
+
+ dog create spot
+
+ spot caller
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {can't read "selfns": no such variable}
+
+test ivariable-1.8 {myvar is illegal when selfns is undefined} -body {
+ type dog {
+ method caller {} {
+ callee
+ }
+ proc callee {} {
+ myvar foo
+ }
+ }
+
+ dog create spot
+
+ spot caller
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {can't read "selfns": no such variable}
+
+test ivariable-1.9 {procs which define selfns see instance variables} -body {
+ type dog {
+ variable greeting Howdy
+
+ method caller {} {
+ return [callee $selfns]
+ }
+
+ proc callee {selfns} {
+ return $greeting
+ }
+ }
+
+ dog create spot
+
+ spot caller
+} -cleanup {
+ dog destroy
+} -result {Howdy}
+
+test ivariable-1.10 {in methods, variable works with fully qualified names} -body {
+ namespace eval ::somenamespace:: {
+ set somevar somevalue
+ }
+
+ type dog {
+ method get {} {
+ variable ::somenamespace::somevar
+ return $somevar
+ }
+ }
+
+ dog create spot
+
+ spot get
+} -cleanup {
+ dog destroy
+} -result {somevalue}
+
+test ivariable-1.11 {variable with too many initializers throws an error} -body {
+ type dog {
+ variable color dark brown
+ }
+} -returnCodes {
+ error
+} -result {Error in "variable color...", too many initializers}
+
+test ivariable-1.12 {variable with too many initializers throws an error} -body {
+ type dog {
+ variable color -array dark brown
+ }
+} -returnCodes {
+ error
+} -result {Error in "variable color...", too many initializers}
+
+test ivariable-1.13 {variable can initialize array variables} -body {
+ type dog {
+ variable data -array {
+ family jones
+ color brown
+ }
+
+ method getdata {item} {
+ return $data($item)
+ }
+ }
+
+ dog spot
+ list [spot getdata family] [spot getdata color]
+} -cleanup {
+ dog destroy
+} -result {jones brown}
+
+#-----------------------------------------------------------------------
+# codename
+#
+# NOTE: codename is deprecated; myproc should be used instead.
+
+test codename-1.1 {codename qualifies procs} -body {
+ type dog {
+ method qualify {} {
+ return [codename myproc]
+ }
+ proc myproc {} { }
+ }
+ dog create spot
+ spot qualify
+} -cleanup {
+ dog destroy
+} -result {::dog::myproc}
+
+test codename-1.2 {procs with selfns work} -body {
+ type dog {
+ variable datum foo
+
+ method qualify {} {
+ return [list [codename getdatum] $selfns]
+ }
+ proc getdatum {selfns} {
+ return $datum
+ }
+ }
+ dog create spot
+ eval [spot qualify]
+} -cleanup {
+ dog destroy
+} -result {foo}
+
+#-----------------------------------------------------------------------
+# Options
+
+test option-1.1 {options get default values} -body {
+ type dog {
+ option -color golden
+ }
+
+ dog create spot
+ spot cget -color
+} -cleanup {
+ dog destroy
+} -result {golden}
+
+test option-1.2 {options can be set} -body {
+ type dog {
+ option -color golden
+ }
+
+ dog create spot
+ spot configure -color black
+ spot cget -color
+} -cleanup {
+ dog destroy
+} -result {black}
+
+test option-1.3 {multiple options can be set} -body {
+ type dog {
+ option -color golden
+ option -akc 0
+ }
+
+ dog create spot
+ spot configure -color brown -akc 1
+ list [spot cget -color] [spot cget -akc]
+} -cleanup {
+ dog destroy
+} -result {brown 1}
+
+test option-1.4 {options can be retrieved as instance variable} -body {
+ type dog {
+ option -color golden
+ option -akc 0
+
+ method listopts {} {
+ list $options(-color) $options(-akc)
+ }
+ }
+
+ dog create spot
+ spot configure -color black -akc 1
+ spot listopts
+} -cleanup {
+ dog destroy
+} -result {black 1}
+
+test option-1.5 {options can be set as an instance variable} -body {
+ type dog {
+ option -color golden
+ option -akc 0
+
+ method setopts {} {
+ set options(-color) black
+ set options(-akc) 1
+ }
+ }
+
+ dog create spot
+ spot setopts
+ list [spot cget -color] [spot cget -akc]
+} -cleanup {
+ dog destroy
+} -result {black 1}
+
+test option-1.6 {options can be set at creation time} -body {
+ type dog {
+ option -color golden
+ option -akc 0
+ }
+
+ dog create spot -color white -akc 1
+ list [spot cget -color] [spot cget -akc]
+} -cleanup {
+ dog destroy
+} -result {white 1}
+
+test option-1.7 {undefined option: cget} -body {
+ type dog {
+ option -color golden
+ option -akc 0
+ }
+
+ dog create spot
+ spot cget -colour
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown option "-colour"}
+
+test option-1.8 {undefined option: configure} -body {
+ type dog {
+ option -color golden
+ option -akc 0
+ }
+
+ dog create spot
+ spot configure -colour blue
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown option "-colour"}
+
+test option-1.9 {options default to ""} -body {
+ type dog {
+ option -color
+ }
+
+ dog create spot
+ spot cget -color
+} -cleanup {
+ dog destroy
+} -result {}
+
+test option-1.10 {spaces allowed in option defaults} -body {
+ type dog {
+ option -breed "golden retriever"
+ }
+ dog fido
+ fido cget -breed
+} -cleanup {
+ dog destroy
+} -result {golden retriever}
+
+test option-1.11 {brackets allowed in option defaults} -body {
+ type dog {
+ option -regexp {[a-z]+}
+ }
+
+ dog fido
+ fido cget -regexp
+} -cleanup {
+ dog destroy
+} -result {[a-z]+}
+
+test option-2.1 {configure returns info, local options only} -body {
+ type dog {
+ option -color black
+ option -akc 1
+ }
+
+ dog create spot
+ spot configure -color red
+ spot configure -akc 0
+ spot configure
+} -cleanup {
+ dog destroy
+} -result {{-color color Color black red} {-akc akc Akc 1 0}}
+
+test option-2.2 {configure -opt returns info, local options only} -body {
+ type dog {
+ option -color black
+ option -akc 1
+ }
+
+ dog create spot
+ spot configure -color red
+ spot configure -color
+} -cleanup {
+ dog destroy
+} -result {-color color Color black red}
+
+test option-2.3 {configure -opt returns info, explicit options} -body {
+ type papers {
+ option -akcflag 1
+ }
+
+ type dog {
+ option -color black
+ delegate option -akc to papers as -akcflag
+ constructor {args} {
+ set papers [papers create $self.papers]
+ }
+
+ destructor {
+ catch {$self.papers destroy}
+ }
+ }
+
+ dog create spot
+ spot configure -akc 0
+ spot configure -akc
+} -cleanup {
+ dog destroy
+} -result {-akc akc Akc 1 0}
+
+test option-2.4 {configure -unknownopt} -body {
+ type papers {
+ option -akcflag 1
+ }
+
+ type dog {
+ option -color black
+ delegate option -akc to papers as -akcflag
+ constructor {args} {
+ set papers [papers create $self.papers]
+ }
+
+ destructor {
+ catch {$self.papers destroy}
+ }
+ }
+
+ dog create spot
+ spot configure -foo
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+ papers destroy
+} -result {unknown option "-foo"}
+
+test option-2.5 {configure returns info, unknown options} -constraints {
+ tk
+} -body {
+ widgetadaptor myframe {
+ option -foo a
+ delegate option -width to hull
+ delegate option * to hull
+ constructor {args} {
+ installhull [frame $self]
+ }
+ }
+
+ myframe .frm
+ set a [.frm configure -foo]
+ set b [.frm configure -width]
+ set c [.frm configure -height]
+ destroy .frm
+ tkbide
+
+ list $a $b $c
+
+} -cleanup {
+ myframe destroy
+} -result {{-foo foo Foo a a} {-width width Width 0 0} {-height height Height 0 0}}
+
+test option-2.6 {configure -opt unknown to implicit component} -constraints {
+ tk
+} -body {
+ widgetadaptor myframe {
+ delegate option * to hull
+ constructor {args} {
+ installhull [frame $self]
+ }
+ }
+ myframe .frm
+ catch {.frm configure -quux} result
+ destroy .frm
+ tkbide
+ set result
+} -cleanup {
+ myframe destroy
+} -result {unknown option "-quux"}
+
+test option-3.1 {set option resource name explicitly} -body {
+ type dog {
+ option {-tailcolor tailColor} black
+ }
+
+ dog fido
+
+ fido configure -tailcolor
+} -cleanup {
+ dog destroy
+} -result {-tailcolor tailColor TailColor black black}
+
+test option-3.2 {set option class name explicitly} -body {
+ type dog {
+ option {-tailcolor tailcolor TailColor} black
+ }
+
+ dog fido
+
+ fido configure -tailcolor
+} -cleanup {
+ dog destroy
+} -result {-tailcolor tailcolor TailColor black black}
+
+test option-3.3 {delegated option's names come from owner} -body {
+ type tail {
+ option -color black
+ }
+
+ type dog {
+ delegate option -tailcolor to tail as -color
+
+ constructor {args} {
+ set tail [tail fidotail]
+ }
+ }
+
+ dog fido
+
+ fido configure -tailcolor
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {-tailcolor tailcolor Tailcolor black black}
+
+test option-3.4 {delegated option's resource name set explicitly} -body {
+ type tail {
+ option -color black
+ }
+
+ type dog {
+ delegate option {-tailcolor tailColor} to tail as -color
+
+ constructor {args} {
+ set tail [tail fidotail]
+ }
+ }
+
+ dog fido
+
+ fido configure -tailcolor
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {-tailcolor tailColor TailColor black black}
+
+test option-3.5 {delegated option's class name set explicitly} -body {
+ type tail {
+ option -color black
+ }
+
+ type dog {
+ delegate option {-tailcolor tailcolor TailColor} to tail as -color
+
+ constructor {args} {
+ set tail [tail fidotail]
+ }
+ }
+
+ dog fido
+
+ fido configure -tailcolor
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {-tailcolor tailcolor TailColor black black}
+
+test option-3.6 {delegated option's default comes from component} -body {
+ type tail {
+ option -color black
+ }
+
+ type dog {
+ delegate option -tailcolor to tail as -color
+
+ constructor {args} {
+ set tail [tail fidotail -color red]
+ }
+ }
+
+ dog fido
+
+ fido configure -tailcolor
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {-tailcolor tailcolor Tailcolor black red}
+
+test option-4.1 {local option name must begin with hyphen} -body {
+ type dog {
+ option nohyphen
+ }
+} -returnCodes {
+ error
+} -result {Error in "option nohyphen...", badly named option "nohyphen"}
+
+test option-4.2 {local option name must be lower case} -body {
+ type dog {
+ option -Upper
+ }
+} -returnCodes {
+ error
+} -result {Error in "option -Upper...", badly named option "-Upper"}
+
+test option-4.3 {local option name may not contain spaces} -body {
+ type dog {
+ option {"-with space"}
+ }
+} -returnCodes {
+ error
+} -result {Error in "option {"-with space"}...", badly named option "-with space"}
+
+test option-4.4 {delegated option name must begin with hyphen} -body {
+ type dog {
+ delegate option nohyphen to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate option nohyphen...", badly named option "nohyphen"}
+
+test option-4.5 {delegated option name must be lower case} -body {
+ type dog {
+ delegate option -Upper to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate option -Upper...", badly named option "-Upper"}
+
+test option-4.6 {delegated option name may not contain spaces} -body {
+ type dog {
+ delegate option {"-with space"} to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate option {"-with space"}...", badly named option "-with space"}
+
+test option-5.1 {local widget options read from option database} -constraints {
+ tk
+} -body {
+ widget dog {
+ option -foo a
+ option -bar b
+
+ typeconstructor {
+ option add *Dog.bar bb
+ }
+ }
+
+ dog .fido
+ set a [.fido cget -foo]
+ set b [.fido cget -bar]
+ destroy .fido
+ tkbide
+
+ list $a $b
+
+} -cleanup {
+ dog destroy
+} -result {a bb}
+
+test option-5.2 {local option database values available in constructor} -constraints {
+ tk
+} -body {
+ widget dog {
+ option -bar b
+ variable saveit
+
+ typeconstructor {
+ option add *Dog.bar bb
+ }
+
+ constructor {args} {
+ set saveit $options(-bar)
+ }
+
+ method getit {} {
+ return $saveit
+ }
+ }
+
+ dog .fido
+ set result [.fido getit]
+ destroy .fido
+ tkbide
+
+ set result
+} -cleanup {
+ dog destroy
+} -result {bb}
+
+test option-6.1 {if no options, no options variable} -body {
+ type dog {
+ variable dummy
+ }
+
+ dog spot
+ spot info vars options
+} -cleanup {
+ dog destroy
+} -result {}
+
+test option-6.2 {if no options, no options methods} -body {
+ type dog {
+ variable dummy
+ }
+
+ dog spot
+ spot info methods c*
+} -cleanup {
+ dog destroy
+} -result {}
+
+#-----------------------------------------------------------------------
+# onconfigure
+
+test onconfigure-1.1 {invalid onconfigure methods are caught} -body {
+ type dog {
+ onconfigure -color {value} { }
+ }
+} -returnCodes {
+ error
+} -result {onconfigure -color: option "-color" unknown}
+
+test onconfigure-1.2 {onconfigure methods take one argument} -body {
+ type dog {
+ option -color golden
+
+ onconfigure -color {value badarg} { }
+ }
+} -returnCodes {
+ error
+} -result {onconfigure -color handler should have one argument, got "value badarg"}
+
+test onconfigure-1.3 {onconfigure methods work} -body {
+ type dog {
+ option -color golden
+
+ onconfigure -color {value} {
+ set options(-color) "*$value*"
+ }
+ }
+
+ dog create spot
+ spot configure -color brown
+ spot cget -color
+} -cleanup {
+ dog destroy
+} -result {*brown*}
+
+test onconfigure-1.4 {onconfigure arg can't be type} -body {
+ type dog {
+ option -color
+ onconfigure -color {type} { }
+ }
+} -returnCodes {
+ error
+} -result {onconfigure -color's arglist may not contain "type" explicitly}
+
+test onconfigure-1.5 {onconfigure arg can't be self} -body {
+ type dog {
+ option -color
+ onconfigure -color {self} { }
+ }
+} -returnCodes {
+ error
+} -result {onconfigure -color's arglist may not contain "self" explicitly}
+
+#-----------------------------------------------------------------------
+# oncget
+
+test oncget-1.1 {invalid oncget methods are caught} -body {
+ type dog {
+ oncget -color { }
+ }
+} -returnCodes {
+ error
+} -result {Error in "oncget -color...", option "-color" unknown}
+
+test oncget-1.2 {oncget methods work} -body {
+ cleanup
+
+ type dog {
+ option -color golden
+
+ oncget -color {
+ return "*$options(-color)*"
+ }
+ }
+
+ dog create spot
+ spot configure -color brown
+ spot cget -color
+} -cleanup {
+ dog destroy
+} -result {*brown*}
+
+#-----------------------------------------------------------------------
+# constructor
+
+
+test constructor-1.1 {constructor can do things} -body {
+ type dog {
+ variable a
+ variable b
+ constructor {args} {
+ set a 1
+ set b 2
+ }
+ method foo {} {
+ list $a $b
+ }
+ }
+
+ dog create spot
+ spot foo
+} -cleanup {
+ dog destroy
+} -result {1 2}
+
+test constructor-1.2 {constructor with no configurelist ignores args} -body {
+ type dog {
+ constructor {args} { }
+ option -color golden
+ option -akc 0
+ }
+
+ dog create spot -color white -akc 1
+ list [spot cget -color] [spot cget -akc]
+} -cleanup {
+ dog destroy
+} -result {golden 0}
+
+test constructor-1.3 {constructor with configurelist gets args} -body {
+ type dog {
+ constructor {args} {
+ $self configurelist $args
+ }
+ option -color golden
+ option -akc 0
+ }
+
+ dog create spot -color white -akc 1
+ list [spot cget -color] [spot cget -akc]
+} -cleanup {
+ dog destroy
+} -result {white 1}
+
+test constructor-1.4 {constructor with specific args} -body {
+ type dog {
+ option -value ""
+ constructor {a b args} {
+ set options(-value) [list $a $b $args]
+ }
+ }
+
+ dog spot retriever golden -akc 1
+ spot cget -value
+} -cleanup {
+ dog destroy
+} -result {retriever golden {-akc 1}}
+
+test constructor-1.5 {constructor with list as one list arg} -body {
+ type dog {
+ option -value ""
+ constructor {args} {
+ set options(-value) $args
+ }
+ }
+
+ dog spot {retriever golden}
+ spot cget -value
+} -cleanup {
+ dog destroy
+} -result {{retriever golden}}
+
+test constructor-1.6 {default constructor configures options} -body {
+ type dog {
+ option -color brown
+ option -breed mutt
+ }
+
+ dog spot -color golden -breed retriever
+ list [spot cget -color] [spot cget -breed]
+} -cleanup {
+ dog destroy
+} -result {golden retriever}
+
+test constructor-1.7 {default constructor takes no args if no options} -body {
+ type dog {
+ variable color
+ }
+
+ dog spot -color golden
+} -returnCodes {
+ error
+} -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]"
+
+#-----------------------------------------------------------------------
+# destroy
+
+test destroy-1.1 {destroy cleans up the instance} -body {
+ type dog {
+ option -color golden
+ }
+
+ set a [namespace children ::dog::]
+ dog create spot
+ set b [namespace children ::dog::]
+ spot destroy
+ set c [namespace children ::dog::]
+ list $a $b $c [info commands ::dog::spot]
+} -cleanup {
+ dog destroy
+} -result {{} ::dog::Snit_inst1 {} {}}
+
+test destroy-1.2 {incomplete objects are destroyed} -body {
+ array unset ::dog::snit_ivars
+
+ type dog {
+ option -color golden
+
+ constructor {args} {
+ $self configurelist $args
+
+ if {"red" == [$self cget -color]} {
+ error "No Red Dogs!"
+ }
+ }
+ }
+
+ catch {dog create spot -color red} result
+ set names [array names ::dog::snit_ivars]
+ list $result $names [info commands ::dog::spot]
+} -cleanup {
+ dog destroy
+} -result {{Error in constructor: No Red Dogs!} {} {}}
+
+test destroy-1.3 {user-defined destructors are called} -body {
+ type dog {
+ typevariable flag ""
+
+ constructor {args} {
+ set flag "created $self"
+ }
+
+ destructor {
+ set flag "destroyed $self"
+ }
+
+ typemethod getflag {} {
+ return $flag
+ }
+ }
+
+ dog create spot
+ set a [dog getflag]
+ spot destroy
+ list $a [dog getflag]
+} -cleanup {
+ dog destroy
+} -result {{created ::spot} {destroyed ::spot}}
+
+#-----------------------------------------------------------------------
+# delegate: general syntax tests
+
+test delegate-1.1 {can only delegate methods or options} -body {
+ type dog {
+ delegate foo bar to baz
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate foo bar...", "foo"?}
+
+test delegate-1.2 {"to" must appear in the right place} -body {
+ type dog {
+ delegate method foo from bar
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method foo...", unknown delegation option "from"}
+
+test delegate-1.3 {"as" must have a target} -body {
+ type dog {
+ delegate method foo to bar as
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method foo...", invalid syntax}
+
+test delegate-1.4 {"as" must have a single target} -body {
+ type dog {
+ delegate method foo to bar as baz quux
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method foo...", unknown delegation option "quux"}
+
+test delegate-1.5 {"as" doesn't work with "*"} -body {
+ type dog {
+ delegate method * to hull as foo
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method *...", cannot specify "as" with "*"}
+
+test delegate-1.6 {"except" must have a target} -body {
+ type dog {
+ delegate method * to bar except
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method *...", invalid syntax}
+
+test delegate-1.7 {"except" must have a single target} -body {
+ type dog {
+ delegate method * to bar except baz quux
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method *...", unknown delegation option "quux"}
+
+test delegate-1.8 {"except" works only with "*"} -body {
+ type dog {
+ delegate method foo to hull except bar
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method foo...", can only specify "except" with "*"}
+
+test delegate-1.9 {only "as" or "except"} -body {
+ type dog {
+ delegate method foo to bar with quux
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method foo...", unknown delegation option "with"}
+
+
+#-----------------------------------------------------------------------
+# delegated methods
+
+test dmethod-1.1 {delegate method to non-existent component} -body {
+ type dog {
+ delegate method foo to bar
+ }
+
+ dog create spot
+ spot foo
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {::dog ::spot delegates method "foo" to undefined component "bar"}
+
+test dmethod-1.2 {delegating to existing component} -body {
+ type dog {
+ constructor {args} {
+ set string string
+ }
+
+ delegate method length to string
+ }
+
+ dog create spot
+ spot length foo
+} -cleanup {
+ dog destroy
+} -result {3}
+
+# Case 1
+test dmethod-1.3 {delegating to existing component with error} -constraints {
+ snit1
+} -body {
+ type dog {
+ constructor {args} {
+ set string string
+ }
+
+ delegate method length to string
+ }
+
+ dog create spot
+ spot length foo bar
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {wrong # args: should be "string length string"}
+
+# Case 2
+test dmethod-1.4 {delegating to existing component with error} -constraints {
+ snit2
+} -body {
+ type dog {
+ constructor {args} {
+ set string string
+ }
+
+ delegate method length to string
+ }
+
+ dog create spot
+ spot length foo bar
+} -cleanup {
+ dog destroy
+} -returnCodes {
+ error
+} -result {wrong # args: should be "spot length string"}
+
+test dmethod-1.5 {delegating unknown methods to existing component} -body {
+ type dog {
+ constructor {args} {
+ set string string
+ }
+
+ delegate method * to string
+ }
+
+ dog create spot
+ spot length foo
+} -cleanup {
+ dog destroy
+} -result {3}
+
+test dmethod-1.6 {delegating unknown method to existing component with error} -body {
+ type dog {
+ constructor {args} {
+ set stringhandler string
+ }
+
+ delegate method * to stringhandler
+ }
+
+ dog create spot
+ spot foo bar
+} -constraints {
+ snit1
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {bad option "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}
+
+test dmethod-1.6a {delegating unknown method to existing component with error} -body {
+ type dog {
+ constructor {args} {
+ set stringhandler string
+ }
+
+ delegate method * to stringhandler
+ }
+
+ dog create spot
+ spot foo bar
+} -constraints {
+ snit2
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown or ambiguous subcommand "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}
+
+test dmethod-1.7 {can't delegate local method: order 1} -body {
+ type cat {
+ method foo {} {}
+ delegate method foo to hull
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method foo...", "foo" has been defined locally.}
+
+test dmethod-1.8 {can't delegate local method: order 2} -body {
+ type cat {
+ delegate method foo to hull
+ method foo {} {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "method foo...", "foo" has been delegated}
+
+# Case 1
+test dmethod-1.9 {excepted methods are caught properly} -constraints {
+ snit1
+} -body {
+ type tail {
+ method wag {} {return "wagged"}
+ method flaunt {} {return "flaunted"}
+ method tuck {} {return "tuck"}
+ }
+
+ type cat {
+ method meow {} {}
+ delegate method * to tail except {wag tuck}
+
+ constructor {args} {
+ set tail [tail %AUTO%]
+ }
+ }
+
+ cat fifi
+
+ catch {fifi flaunt} a
+ catch {fifi wag} b
+ catch {fifi tuck} c
+
+ list $a $b $c
+} -cleanup {
+ cat destroy
+ tail destroy
+} -result {flaunted {"::fifi wag" is not defined} {"::fifi tuck" is not defined}}
+
+# Case 2
+test dmethod-1.10 {excepted methods are caught properly} -constraints {
+ snit2
+} -body {
+ type tail {
+ method wag {} {return "wagged"}
+ method flaunt {} {return "flaunted"}
+ method tuck {} {return "tuck"}
+ }
+
+ type cat {
+ method meow {} {}
+ delegate method * to tail except {wag tuck}
+
+ constructor {args} {
+ set tail [tail %AUTO%]
+ }
+ }
+
+ cat fifi
+
+ catch {fifi flaunt} a
+ catch {fifi wag} b
+ catch {fifi tuck} c
+
+ list $a $b $c
+} -cleanup {
+ cat destroy
+ tail destroy
+} -result {flaunted {unknown subcommand "wag": must be flaunt} {unknown subcommand "tuck": must be flaunt}}
+
+test dmethod-1.11 {as clause can include arguments} -body {
+ type tail {
+ method wag {adverb} {return "wagged $adverb"}
+ }
+
+ type dog {
+ delegate method wag to tail as {wag briskly}
+
+ constructor {args} {
+ set tail [tail %AUTO%]
+ }
+ }
+
+ dog spot
+
+ spot wag
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wagged briskly}
+
+test dmethod-2.1 {'using "%c %m"' gets normal behavior} -body {
+ type tail {
+ method wag {adverb} {return "wagged $adverb"}
+ }
+
+ type dog {
+ delegate method wag to tail using {%c %m}
+
+ constructor {args} {
+ set tail [tail %AUTO%]
+ }
+ }
+
+ dog spot
+
+ spot wag briskly
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wagged briskly}
+
+test dmethod-2.2 {All 'using' conversions are converted} -body {
+ proc echo {args} { return $args }
+
+ type dog {
+ delegate method {tail wag} using {echo %% %t %M %m %j %n %w %s %c}
+ }
+
+ dog spot
+
+ spot tail wag
+} -cleanup {
+ dog destroy
+ rename echo ""
+} -result {% ::dog {tail wag} wag tail_wag ::dog::Snit_inst1 ::spot ::spot %c}
+
+test dmethod-2.3 {"%%" is handled properly} -body {
+ proc echo {args} { join $args "|" }
+
+ type dog {
+ delegate method wag using {echo %%m %%%m}
+ }
+
+ dog spot
+
+ spot wag
+} -cleanup {
+ dog destroy
+ rename echo ""
+} -result {%m|%wag}
+
+test dmethod-2.4 {Method "*" and "using"} -body {
+ proc echo {args} { join $args "|" }
+
+ type dog {
+ delegate method * using {echo %m}
+ }
+
+ dog spot
+
+ list [spot wag] [spot bark loudly]
+} -cleanup {
+ dog destroy
+ rename echo ""
+} -result {wag bark|loudly}
+
+
+test dmethod-3.1 {component names can be changed dynamically} -body {
+ type tail1 {
+ method wag {} {return "wagged"}
+ }
+
+ type tail2 {
+ method wag {} {return "drooped"}
+ }
+
+ type dog {
+ delegate method wag to tail
+
+ constructor {args} {
+ set tail [tail1 %AUTO%]
+ }
+
+ method switchit {} {
+ set tail [tail2 %AUTO%]
+ }
+ }
+
+ dog fido
+
+ set a [fido wag]
+ fido switchit
+ set b [fido wag]
+
+ list $a $b
+} -cleanup {
+ dog destroy
+ tail1 destroy
+ tail2 destroy
+} -result {wagged drooped}
+
+test dmethod-4.1 {hierarchical method, two tokens} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {wag tail} to tail as wag
+ }
+
+ dog spot
+ spot wag tail
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dmethod-4.2 {hierarchical method, three tokens} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {wag tail proudly} to tail as wag
+ }
+
+ dog spot
+ spot wag tail proudly
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dmethod-4.3 {hierarchical method, three tokens} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {wag tail really high} to tail as wag
+ }
+
+ dog spot
+ spot wag tail really high
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dmethod-4.4 {redefinition is OK} -body {
+ type tail {
+ method {wag tail} {} {return "wags tail"}
+ method {wag briskly} {} {return "wags tail briskly"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {wag tail} to tail as {wag tail}
+ delegate method {wag tail} to tail as {wag briskly}
+ }
+
+ dog spot
+ spot wag tail
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail briskly}
+
+test dmethod-4.5 {all tokens are used by default} -body {
+ type tail {
+ method wag {} {return "wags tail"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {tail wag} to tail
+ }
+
+ dog spot
+ spot tail wag
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags tail}
+
+test dmethod-4.6 {last token can be *} -body {
+ type tail {
+ method wag {} {return "wags"}
+ method droop {} {return "droops"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {tail *} to tail
+ }
+
+ dog spot
+
+ list [spot tail wag] [spot tail droop]
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags droops}
+
+# Case 1
+test dmethod-4.7 {except with multiple tokens} -constraints {
+ snit1
+} -body {
+ type tail {
+ method wag {} {return "wags"}
+ method droop {} {return "droops"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {tail *} to tail except droop
+ }
+
+ dog spot
+
+ catch {spot tail droop} result
+
+ list [spot tail wag] $result
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags {"::spot tail droop" is not defined}}
+
+# Case 2
+test dmethod-4.8 {except with multiple tokens} -constraints {
+ snit2
+} -body {
+ type tail {
+ method wag {} {return "wags"}
+ method droop {} {return "droops"}
+ }
+
+ type dog {
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ delegate method {tail *} to tail except droop
+ }
+
+ dog spot
+
+ catch {spot tail droop} result
+
+ list [spot tail wag] $result
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wags {unknown subcommand "droop": namespace ::dog::Snit_inst1 does not export any commands}}
+
+test dmethod-4.9 {"*" in the wrong spot} -body {
+ type dog {
+ delegate method {tail * wag} to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method {tail * wag}...", "*" must be the last token.}
+
+test dmethod-5.1 {prefix/method collision} -body {
+ type dog {
+ delegate method wag to tail
+ delegate method {wag tail} to tail as wag
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method {wag tail}...", "wag" has no submethods.}
+
+test dmethod-5.2 {prefix/method collision} -body {
+ type dog {
+ delegate method {wag tail} to tail as wag
+ delegate method wag to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method wag...", "wag" has submethods.}
+
+test dmethod-5.3 {prefix/method collision} -body {
+ type dog {
+ delegate method {wag tail} to tail
+ delegate method {wag tail proudly} to tail as wag
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method {wag tail proudly}...", "wag tail" has no submethods.}
+
+test dmethod-5.4 {prefix/method collision} -body {
+ type dog {
+ delegate method {wag tail proudly} to tail as wag
+ delegate method {wag tail} to tail
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate method {wag tail}...", "wag tail" has submethods.}
+
+#-----------------------------------------------------------------------
+# delegated options
+
+test doption-1.1 {delegate option to non-existent component} -body {
+ type dog {
+ delegate option -foo to bar
+ }
+
+ dog create spot
+ spot cget -foo
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {component "bar" is undefined in ::dog ::spot}
+
+test doption-1.2 {delegating option to existing component: cget} -body {
+ type cat {
+ option -color "black"
+ }
+
+ cat create hershey
+
+ type dog {
+ constructor {args} {
+ set catthing ::hershey
+ }
+
+ delegate option -color to catthing
+ }
+
+ dog create spot
+ spot cget -color
+} -cleanup {
+ dog destroy
+ cat destroy
+} -result {black}
+
+test doption-1.3 {delegating option to existing component: configure} -body {
+ type cat {
+ option -color "black"
+ }
+
+ cat create hershey
+
+ type dog {
+ constructor {args} {
+ set catthing ::hershey
+ $self configurelist $args
+ }
+
+ delegate option -color to catthing
+ }
+
+ dog create spot -color blue
+ list [spot cget -color] [hershey cget -color]
+} -cleanup {
+ dog destroy
+ cat destroy
+} -result {blue blue}
+
+test doption-1.4 {delegating unknown options to existing component} -body {
+ type cat {
+ option -color "black"
+ }
+
+ cat create hershey
+
+ type dog {
+ constructor {args} {
+ set catthing ::hershey
+
+ # Note: must do this after components are defined; this
+ # may be a problem.
+ $self configurelist $args
+ }
+
+ delegate option * to catthing
+ }
+
+ dog create spot -color blue
+ list [spot cget -color] [hershey cget -color]
+} -cleanup {
+ dog destroy
+ cat destroy
+} -result {blue blue}
+
+test doption-1.5 {can't oncget for delegated option} -body {
+ type dog {
+ delegate option -color to catthing
+
+ oncget -color { }
+ }
+} -returnCodes {
+ error
+} -result {Error in "oncget -color...", option "-color" is delegated}
+
+test doption-1.6 {can't onconfigure for delegated option} -body {
+ type dog {
+ delegate option -color to catthing
+
+ onconfigure -color {value} { }
+ }
+} -returnCodes {
+ error
+} -result {onconfigure -color: option "-color" is delegated}
+
+test doption-1.7 {delegating unknown options to existing component: error} -body {
+ type cat {
+ option -color "black"
+ }
+
+ cat create hershey
+
+ type dog {
+ constructor {args} {
+ set catthing ::hershey
+ $self configurelist $args
+ }
+
+ delegate option * to catthing
+ }
+
+ dog create spot -colour blue
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+ cat destroy
+} -result {Error in constructor: unknown option "-colour"}
+
+test doption-1.8 {can't delegate local option: order 1} -body {
+ type cat {
+ option -color "black"
+ delegate option -color to hull
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate option -color...", "-color" has been defined locally}
+
+test doption-1.9 {can't delegate local option: order 2} -body {
+ type cat {
+ delegate option -color to hull
+ option -color "black"
+ }
+} -returnCodes {
+ error
+} -result {Error in "option -color...", cannot define "-color" locally, it has been delegated}
+
+test doption-1.10 {excepted options are caught properly on cget} -body {
+ type tail {
+ option -a a
+ option -b b
+ option -c c
+ }
+
+ type cat {
+ delegate option * to tail except {-b -c}
+
+ constructor {args} {
+ set tail [tail %AUTO%]
+ }
+ }
+
+ cat fifi
+
+ catch {fifi cget -a} a
+ catch {fifi cget -b} b
+ catch {fifi cget -c} c
+
+ list $a $b $c
+} -cleanup {
+ cat destroy
+ tail destroy
+} -result {a {unknown option "-b"} {unknown option "-c"}}
+
+test doption-1.11 {excepted options are caught properly on configurelist} -body {
+ type tail {
+ option -a a
+ option -b b
+ option -c c
+ }
+
+ type cat {
+ delegate option * to tail except {-b -c}
+
+ constructor {args} {
+ set tail [tail %AUTO%]
+ }
+ }
+
+ cat fifi
+
+ catch {fifi configurelist {-a 1}} a
+ catch {fifi configurelist {-b 1}} b
+ catch {fifi configurelist {-c 1}} c
+
+ list $a $b $c
+} -cleanup {
+ cat destroy
+ tail destroy
+} -result {{} {unknown option "-b"} {unknown option "-c"}}
+
+test doption-1.12 {excepted options are caught properly on configure, 1} -body {
+ type tail {
+ option -a a
+ option -b b
+ option -c c
+ }
+
+ type cat {
+ delegate option * to tail except {-b -c}
+
+ constructor {args} {
+ set tail [tail %AUTO%]
+ }
+ }
+
+ cat fifi
+
+ catch {fifi configure -a 1} a
+ catch {fifi configure -b 1} b
+ catch {fifi configure -c 1} c
+
+ list $a $b $c
+} -cleanup {
+ cat destroy
+ tail destroy
+} -result {{} {unknown option "-b"} {unknown option "-c"}}
+
+test doption-1.13 {excepted options are caught properly on configure, 2} -body {
+ type tail {
+ option -a a
+ option -b b
+ option -c c
+ }
+
+ type cat {
+ delegate option * to tail except {-b -c}
+
+ constructor {args} {
+ set tail [tail %AUTO%]
+ }
+ }
+
+ cat fifi
+
+ catch {fifi configure -a} a
+ catch {fifi configure -b} b
+ catch {fifi configure -c} c
+
+ list $a $b $c
+} -cleanup {
+ cat destroy
+ tail destroy
+} -result {{-a a A a a} {unknown option "-b"} {unknown option "-c"}}
+
+test doption-1.14 {configure query skips excepted options} -body {
+ type tail {
+ option -a a
+ option -b b
+ option -c c
+ }
+
+ type cat {
+ option -d d
+ delegate option * to tail except {-b -c}
+
+ constructor {args} {
+ set tail [tail %AUTO%]
+ }
+ }
+
+ cat fifi
+
+ fifi configure
+} -cleanup {
+ cat destroy
+ tail destroy
+} -result {{-d d D d d} {-a a A a a}}
+
+
+#-----------------------------------------------------------------------
+# from
+
+test from-1.1 {getting default values} -body {
+ type dog {
+ option -foo FOO
+ option -bar BAR
+
+ constructor {args} {
+ $self configure -foo [from args -foo AAA]
+ $self configure -bar [from args -bar]
+ }
+ }
+
+ dog create spot
+ list [spot cget -foo] [spot cget -bar]
+} -cleanup {
+ dog destroy
+} -result {AAA BAR}
+
+test from-1.2 {getting non-default values} -body {
+ type dog {
+ option -foo FOO
+ option -bar BAR
+ option -args
+
+ constructor {args} {
+ $self configure -foo [from args -foo]
+ $self configure -bar [from args -bar]
+ $self configure -args $args
+ }
+ }
+
+ dog create spot -foo quux -baz frobnitz -bar frobozz
+ list [spot cget -foo] [spot cget -bar] [spot cget -args]
+} -cleanup {
+ dog destroy
+} -result {quux frobozz {-baz frobnitz}}
+
+#-----------------------------------------------------------------------
+# Widgetadaptors
+
+test widgetadaptor-1.1 {creating a widget: hull hijacking} -constraints {
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ $self configurelist $args
+ }
+
+ delegate method * to hull
+ delegate option * to hull
+ }
+
+ mylabel create .label -text "My Label"
+
+ set a [.label cget -text]
+ set b [hull1.label cget -text]
+
+ destroy .label
+ tkbide
+ list $a $b
+} -cleanup {
+ mylabel destroy
+} -result {{My Label} {My Label}}
+
+test widgetadaptor-1.2 {destroying a widget with destroy} -constraints {
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel create .label
+ set a [namespace children ::mylabel]
+ destroy .label
+ set b [namespace children ::mylabel]
+ tkbide
+ list $a $b
+} -cleanup {
+ mylabel destroy
+} -result {::mylabel::Snit_inst1 {}}
+
+test widgetadaptor-1.3 {destroying two widgets of the same type with destroy} -constraints {
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel create .lab1
+ mylabel create .lab2
+ set a [namespace children ::mylabel]
+ destroy .lab1
+ destroy .lab2
+ set b [namespace children ::mylabel]
+ tkbide
+ list $a $b
+} -cleanup {
+ mylabel destroy
+} -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}}
+
+test widgetadaptor-1.4 {destroying a widget with rename, then destroy type} -constraints {
+ tk bug8.5a3
+} -body {
+ widgetadaptor mylabel {
+ constructor {} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel create .label
+ set a [namespace children ::mylabel]
+ rename .label ""
+ set b [namespace children ::mylabel]
+
+ mylabel destroy
+ tkbide
+ list $a $b
+} -result {::mylabel::Snit_inst1 {}}
+
+test widgetadaptor-1.5 {destroying two widgets of the same type with rename} -constraints {
+ tk bug8.5a3
+} -body {
+ widgetadaptor mylabel {
+ constructor {} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel create .lab1
+ mylabel create .lab2
+ set a [namespace children ::mylabel]
+ rename .lab1 ""
+ rename .lab2 ""
+ set b [namespace children ::mylabel]
+ mylabel destroy
+ tkbide
+ list $a $b
+} -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}}
+
+test widgetadaptor-1.6 {create/destroy twice, with destroy} -constraints {
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel create .lab1
+ set a [namespace children ::mylabel]
+ destroy .lab1
+
+ mylabel create .lab1
+ set b [namespace children ::mylabel]
+ destroy .lab1
+
+ set c [namespace children ::mylabel]
+ mylabel destroy
+ tkbide
+ list $a $b $c
+} -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}}
+
+test widgetadaptor-1.7 {create/destroy twice, with rename} -constraints {
+ tk bug8.5a3
+} -body {
+ widgetadaptor mylabel {
+ constructor {} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel create .lab1
+ set a [namespace children ::mylabel]
+ rename .lab1 ""
+
+ mylabel create .lab1
+ set b [namespace children ::mylabel]
+ rename .lab1 ""
+
+ set c [namespace children ::mylabel]
+ mylabel destroy
+ tkbide
+ list $a $b $c
+} -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}}
+
+test widgetadaptor-1.8 {"create" is optional} -constraints {
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ }
+ method howdy {} {return "Howdy!"}
+ }
+
+ mylabel .label
+ set a [.label howdy]
+
+ destroy .label
+ tkbide
+ set a
+} -cleanup {
+ mylabel destroy
+} -result {Howdy!}
+
+# Case 1
+test widgetadaptor-1.9 {"create" is optional, but must be a valid name} -constraints {
+ snit1
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ }
+ method howdy {} {return "Howdy!"}
+ }
+
+ catch {mylabel foo} result
+ tkbide
+ set result
+} -cleanup {
+ mylabel destroy
+} -result {"::mylabel foo" is not defined}
+
+# Case 2
+test widgetadaptor-1.10 {"create" is optional, but must be a valid name} -constraints {
+ snit2
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ }
+ method howdy {} {return "Howdy!"}
+ }
+
+ catch {mylabel foo} result
+ tkbide
+ set result
+} -cleanup {
+ mylabel destroy
+} -result {unknown subcommand "foo": namespace ::mylabel does not export any commands}
+
+test widgetadaptor-1.11 {user-defined destructors are called} -constraints {
+ tk
+} -body {
+ widgetadaptor mylabel {
+ typevariable flag ""
+
+ constructor {args} {
+ installhull [label $self]
+ set flag "created $self"
+ }
+
+ destructor {
+ set flag "destroyed $self"
+ }
+
+ typemethod getflag {} {
+ return $flag
+ }
+ }
+
+ mylabel .label
+ set a [mylabel getflag]
+ destroy .label
+ tkbide
+ list $a [mylabel getflag]
+} -cleanup {
+ mylabel destroy
+} -result {{created .label} {destroyed .label}}
+
+# Case 1
+test widgetadaptor-1.12 {destroy method not defined for widget types} -constraints {
+ snit1
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel .label
+ catch {.label destroy} result
+ destroy .label
+ tkbide
+ set result
+} -cleanup {
+ mylabel destroy
+} -result {".label destroy" is not defined}
+
+# Case 2
+test widgetadaptor-1.13 {destroy method not defined for widget types} -constraints {
+ snit2
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel .label
+ catch {.label destroy} result
+ destroy .label
+ tkbide
+ set result
+} -cleanup {
+ mylabel destroy
+} -result {unknown subcommand "destroy": namespace ::mylabel::Snit_inst1 does not export any commands}
+
+test widgetadaptor-1.14 {hull can be repeatedly renamed} -constraints {
+ tk
+} -body {
+ widgetadaptor basetype {
+ constructor {args} {
+ installhull [label $self]
+ }
+
+ method basemethod {} { return "basemethod" }
+ }
+
+ widgetadaptor w1 {
+ constructor {args} {
+ installhull [basetype create $self]
+ }
+ }
+
+ widgetadaptor w2 {
+ constructor {args} {
+ installhull [w1 $self]
+ }
+ }
+
+ set a [w2 .foo]
+ destroy .foo
+ tkbide
+ set a
+} -cleanup {
+ w2 destroy
+ w1 destroy
+ basetype destroy
+} -result {.foo}
+
+test widgetadaptor-1.15 {widget names can be generated} -constraints {
+ tk
+} -body {
+ widgetadaptor unique {
+ constructor {args} {
+ installhull [label $self]
+ }
+ }
+
+ set w [unique .%AUTO%]
+ destroy $w
+ tkbide
+ set w
+} -cleanup {
+ unique destroy
+} -result {.unique1}
+
+test widgetadaptor-1.16 {snit::widgetadaptor as hull} -constraints {
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ $self configurelist $args
+ }
+ method method1 {} {
+ return "method1"
+ }
+ delegate option * to hull
+ }
+
+ widgetadaptor mylabel2 {
+ constructor {args} {
+ installhull [mylabel $self]
+ $self configurelist $args
+ }
+ method method2 {} {
+ return "method2: [$hull method1]"
+ }
+ delegate option * to hull
+ }
+
+ mylabel2 .label -text "Some Text"
+ set a [.label method2]
+ set b [.label cget -text]
+ .label configure -text "More Text"
+ set c [.label cget -text]
+ set d [namespace children ::mylabel2]
+ set e [namespace children ::mylabel]
+
+ destroy .label
+
+ set f [namespace children ::mylabel2]
+ set g [namespace children ::mylabel]
+
+ mylabel2 destroy
+ mylabel destroy
+
+ tkbide
+ list $a $b $c $d $e $f $g
+} -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}}
+
+test widgetadaptor-1.17 {snit::widgetadaptor as hull; use rename} -constraints {
+ tk bug8.5a3
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ $self configurelist $args
+ }
+ method method1 {} {
+ return "method1"
+ }
+ delegate option * to hull
+ }
+
+ widgetadaptor mylabel2 {
+ constructor {args} {
+ installhull [mylabel $self]
+ $self configurelist $args
+ }
+ method method2 {} {
+ return "method2: [$hull method1]"
+ }
+ delegate option * to hull
+ }
+
+ mylabel2 .label -text "Some Text"
+ set a [.label method2]
+ set b [.label cget -text]
+ .label configure -text "More Text"
+ set c [.label cget -text]
+ set d [namespace children ::mylabel2]
+ set e [namespace children ::mylabel]
+
+ rename .label ""
+
+ set f [namespace children ::mylabel2]
+ set g [namespace children ::mylabel]
+
+ mylabel2 destroy
+ mylabel destroy
+
+ tkbide
+ list $a $b $c $d $e $f $g
+} -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}}
+
+test widgetadaptor-1.18 {BWidget Label as hull} -constraints {
+ bwidget
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [Label $win]
+ $self configurelist $args
+ }
+ delegate option * to hull
+ }
+
+ mylabel .label -text "Some Text"
+ set a [.label cget -text]
+
+ .label configure -text "More Text"
+ set b [.label cget -text]
+
+ set c [namespace children ::mylabel]
+
+ destroy .label
+
+ set d [namespace children ::mylabel]
+
+ mylabel destroy
+
+ tkbide
+ list $a $b $c $d
+} -result {{Some Text} {More Text} ::mylabel::Snit_inst1 {}}
+
+test widgetadaptor-1.19 {error in widgetadaptor constructor} -constraints {
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ error "Simulated Error"
+ }
+ }
+
+ mylabel .lab
+} -returnCodes {
+ error
+} -cleanup {
+ mylabel destroy
+} -result {Error in constructor: Simulated Error}
+
+
+#-----------------------------------------------------------------------
+# Widgets
+
+# A widget is just a widgetadaptor with an automatically created hull
+# component (a Tk frame). So the widgetadaptor tests apply; all we
+# need to test here is the frame creation.
+
+test widget-1.1 {creating a widget} -constraints {
+ tk
+} -body {
+ widget myframe {
+ method hull {} { return $hull }
+
+ delegate method * to hull
+ delegate option * to hull
+ }
+
+ myframe create .frm -background green
+
+ set a [.frm cget -background]
+ set b [.frm hull]
+
+ destroy .frm
+ tkbide
+ list $a $b
+} -cleanup {
+ myframe destroy
+} -result {green ::hull1.frm}
+
+test widget-2.1 {can't redefine hull} -constraints {
+ tk
+} -body {
+ widget myframe {
+ method resethull {} { set hull "" }
+ }
+
+ myframe .frm
+
+ .frm resethull
+} -returnCodes {
+ error
+} -cleanup {
+ myframe destroy
+} -result {can't set "hull": The hull component cannot be redefined}
+
+#-----------------------------------------------------------------------
+# install
+#
+# The install command is used to install widget components, while getting
+# options for the option database.
+
+test install-1.1 {installed components are created properly} -constraints {
+ tk
+} -body {
+ widget myframe {
+ # Delegate an option just to make sure the component variable
+ # exists.
+ delegate option -font to text
+
+ constructor {args} {
+ install text using text $win.text -background green
+ }
+
+ method getit {} {
+ $win.text cget -background
+ }
+ }
+
+ myframe .frm
+ set a [.frm getit]
+ destroy .frm
+ tkbide
+ set a
+} -cleanup {
+ myframe destroy
+} -result {green}
+
+test install-1.2 {installed components are saved properly} -constraints {
+ tk
+} -body {
+ widget myframe {
+ # Delegate an option just to make sure the component variable
+ # exists.
+ delegate option -font to text
+
+ constructor {args} {
+ install text using text $win.text -background green
+ }
+
+ method getit {} {
+ $text cget -background
+ }
+ }
+
+ myframe .frm
+ set a [.frm getit]
+ destroy .frm
+ tkbide
+ set a
+} -cleanup {
+ myframe destroy
+} -result {green}
+
+test install-1.3 {can't install until hull exists} -constraints {
+ tk
+} -body {
+ widgetadaptor myframe {
+ # Delegate an option just to make sure the component variable
+ # exists.
+ delegate option -font to text
+
+ constructor {args} {
+ install text using text $win.text -background green
+ }
+ }
+
+ myframe .frm
+} -returnCodes {
+ error
+} -cleanup {
+ myframe destroy
+} -result {Error in constructor: tried to install "text" before the hull exists}
+
+test install-1.4 {install queries option database} -constraints {
+ tk
+} -body {
+ widget myframe {
+ delegate option -font to text
+
+ typeconstructor {
+ option add *Myframe.font Courier
+ }
+
+ constructor {args} {
+ install text using text $win.text
+ }
+ }
+
+ myframe .frm
+ set a [.frm cget -font]
+ destroy .frm
+ tkbide
+ set a
+} -cleanup {
+ myframe destroy
+} -result {Courier}
+
+test install-1.5 {explicit options override option database} -constraints {
+ tk
+} -body {
+ widget myframe {
+ delegate option -font to text
+
+ typeconstructor {
+ option add *Myframe.font Courier
+ }
+
+ constructor {args} {
+ install text using text $win.text -font Times
+ }
+ }
+
+ myframe .frm
+ set a [.frm cget -font]
+ destroy .frm
+ tkbide
+ set a
+} -cleanup {
+ myframe destroy
+} -result {Times}
+
+test install-1.6 {option db works with targetted options} -constraints {
+ tk
+} -body {
+ widget myframe {
+ delegate option -textfont to text as -font
+
+ typeconstructor {
+ option add *Myframe.textfont Courier
+ }
+
+ constructor {args} {
+ install text using text $win.text
+ }
+ }
+
+ myframe .frm
+ set a [.frm cget -textfont]
+ destroy .frm
+ tkbide
+ set a
+} -cleanup {
+ myframe destroy
+} -result {Courier}
+
+test install-1.7 {install works for snit::types} -body {
+ type tail {
+ option -tailcolor black
+ }
+
+ type dog {
+ delegate option -tailcolor to tail
+
+ constructor {args} {
+ install tail using tail $self.tail
+ }
+ }
+
+ dog fido
+ fido cget -tailcolor
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {black}
+
+test install-1.8 {install can install non-widget components} -constraints {
+ tk
+} -body {
+ type dog {
+ option -tailcolor black
+ }
+
+ widget myframe {
+ delegate option -tailcolor to thedog
+
+ typeconstructor {
+ option add *Myframe.tailcolor green
+ }
+
+ constructor {args} {
+ install thedog using dog $win.dog
+ }
+ }
+
+ myframe .frm
+ set a [.frm cget -tailcolor]
+ destroy .frm
+ tkbide
+ set a
+
+} -cleanup {
+ dog destroy
+ myframe destroy
+} -result {green}
+
+test install-1.9 {ok if no options are delegated to component} -constraints {
+ tk
+} -body {
+ type dog {
+ option -tailcolor black
+ }
+
+ widget myframe {
+ constructor {args} {
+ install thedog using dog $win.dog
+ }
+ }
+
+ myframe .frm
+ destroy .frm
+ tkbide
+
+ # Test passes if no error is raised.
+ list ok
+} -cleanup {
+ myframe destroy
+ dog destroy
+} -result {ok}
+
+test install-2.1 {
+ delegate option * for a non-shadowed option. The text widget's
+ -foreground and -font options should be set according to what's
+ in the option database on the widgetclass.
+} -constraints {
+ tk
+} -body {
+ widget myframe {
+ delegate option * to text
+
+ typeconstructor {
+ option add *Myframe.foreground red
+ option add *Myframe.font {Times 14}
+ }
+
+ constructor {args} {
+ install text using text $win.text
+ }
+ }
+
+ myframe .frm
+ set a [.frm cget -foreground]
+ set b [.frm cget -font]
+ destroy .frm
+ tkbide
+
+ list $a $b
+} -cleanup {
+ myframe destroy
+} -result {red {Times 14}}
+
+test install-2.2 {
+ Delegate option * for a shadowed option. Foreground is declared
+ as a non-delegated option, hence it will pick up the option database
+ default. -foreground is not included in the "delegate option *", so
+ the text widget's -foreground option will not be set from the
+ option database.
+} -constraints {
+ tk
+} -body {
+ widget myframe {
+ option -foreground white
+ delegate option * to text
+
+ typeconstructor {
+ option add *Myframe.foreground red
+ }
+
+ constructor {args} {
+ install text using text $win.text
+ }
+
+ method getit {} {
+ $text cget -foreground
+ }
+ }
+
+ myframe .frm
+ set a [.frm cget -foreground]
+ set b [.frm getit]
+ destroy .frm
+ tkbide
+
+ expr {![string equal $a $b]}
+} -cleanup {
+ myframe destroy
+} -result {1}
+
+test install-2.3 {
+ Delegate option * for a creation option. Because the text widget's
+ -foreground is set explicitly by the constructor, that always
+ overrides the option database.
+} -constraints {
+ tk
+} -body {
+ widget myframe {
+ delegate option * to text
+
+ typeconstructor {
+ option add *Myframe.foreground red
+ }
+
+ constructor {args} {
+ install text using text $win.text -foreground blue
+ }
+ }
+
+ myframe .frm
+ set a [.frm cget -foreground]
+ destroy .frm
+ tkbide
+
+ set a
+} -cleanup {
+ myframe destroy
+} -result {blue}
+
+test install-2.4 {
+ Delegate option * with an excepted option. Because the text widget's
+ -state is excepted, it won't be set from the option database.
+} -constraints {
+ tk
+} -body {
+ widget myframe {
+ delegate option * to text except -state
+
+ typeconstructor {
+ option add *Myframe.foreground red
+ option add *Myframe.state disabled
+ }
+
+ constructor {args} {
+ install text using text $win.text
+ }
+
+ method getstate {} {
+ $text cget -state
+ }
+ }
+
+ myframe .frm
+ set a [.frm getstate]
+ destroy .frm
+ tkbide
+
+ set a
+} -cleanup {
+ myframe destroy
+} -result {normal}
+
+#-----------------------------------------------------------------------
+# Advanced installhull tests
+#
+# installhull is used to install the hull widget for both widgets and
+# widget adaptors. It has two forms. In one form it installs a widget
+# created by some third party; in this form no querying of the option
+# database is needed, because we haven't taken responsibility for creating
+# it. But in the other form (installhull using) installhull actually
+# creates the widget, and takes responsibility for querying the
+# option database as needed.
+#
+# NOTE: "installhull using" is always used to create a widget's hull frame.
+#
+# That options passed into installhull override those from the
+# option database.
+
+test installhull-1.1 {
+ options delegated to a widget's hull frame with the same name are
+ initialized from the option database. Note that there's no
+ explicit code in Snit to do this; it happens because we set the
+ -class when the widget was created. In fact, it happens whether
+ we delegate the option name or not.
+} -constraints {
+ tk
+} -body {
+ widget myframe {
+ delegate option -background to hull
+
+ typeconstructor {
+ option add *Myframe.background red
+ option add *Myframe.width 123
+ }
+
+ method getwid {} {
+ $hull cget -width
+ }
+ }
+
+ myframe .frm
+ set a [.frm cget -background]
+ set b [.frm getwid]
+ destroy .frm
+ tkbide
+ list $a $b
+} -cleanup {
+ myframe destroy
+} -result {red 123}
+
+test installhull-1.2 {
+ Options delegated to a widget's hull frame with a different name are
+ initialized from the option database.
+} -constraints {
+ tk
+} -body {
+ widget myframe {
+ delegate option -mainbackground to hull as -background
+
+ typeconstructor {
+ option add *Myframe.mainbackground red
+ }
+ }
+
+ myframe .frm
+ set a [.frm cget -mainbackground]
+ destroy .frm
+ tkbide
+ set a
+} -cleanup {
+ myframe destroy
+} -result {red}
+
+test installhull-1.3 {
+ options delegated to a widgetadaptor's hull frame with the same name are
+ initialized from the option database. Note that there's no
+ explicit code in Snit to do this; there's no way to change the
+ adapted hull widget's -class, so the widget is simply being
+ initialized normally.
+} -constraints {
+ tk
+} -body {
+ widgetadaptor myframe {
+ delegate option -background to hull
+
+ typeconstructor {
+ option add *Frame.background red
+ option add *Frame.width 123
+ }
+
+ constructor {args} {
+ installhull using frame
+ }
+
+ method getwid {} {
+ $hull cget -width
+ }
+ }
+
+ myframe .frm
+ set a [.frm cget -background]
+ set b [.frm getwid]
+ destroy .frm
+ tkbide
+ list $a $b
+} -cleanup {
+ myframe destroy
+} -result {red 123}
+
+test installhull-1.4 {
+ Options delegated to a widget's hull frame with a different name are
+ initialized from the option database.
+} -constraints {
+ tk
+} -body {
+ widgetadaptor myframe {
+ delegate option -mainbackground to hull as -background
+
+ typeconstructor {
+ option add *Frame.mainbackground red
+ }
+
+ constructor {args} {
+ installhull using frame
+ }
+ }
+
+ myframe .frm
+ set a [.frm cget -mainbackground]
+ destroy .frm
+ tkbide
+ set a
+} -cleanup {
+ myframe destroy
+} -result {red}
+
+test installhull-1.5 {
+ Option values read from the option database are overridden by options
+ explicitly passed, even if delegated under a different name.
+} -constraints {
+ tk
+} -body {
+ widgetadaptor myframe {
+ delegate option -mainbackground to hull as -background
+
+ typeconstructor {
+ option add *Frame.mainbackground red
+ option add *Frame.width 123
+ }
+
+ constructor {args} {
+ installhull using frame -background green -width 321
+ }
+
+ method getwid {} {
+ $hull cget -width
+ }
+ }
+
+ myframe .frm
+ set a [.frm cget -mainbackground]
+ set b [.frm getwid]
+ destroy .frm
+ tkbide
+ list $a $b
+} -cleanup {
+ myframe destroy
+} -result {green 321}
+
+
+#-----------------------------------------------------------------------
+# Instance Introspection
+
+# Case 1
+test iinfo-1.1 {object info too few args} -constraints {
+ snit1
+} -body {
+ type dog { }
+
+ dog create spot
+
+ spot info
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.method.info {type selfns win self command args} 4]
+
+# Case 2
+test iinfo-1.2 {object info too few args} -constraints {
+ snit2
+} -body {
+ type dog { }
+
+ dog create spot
+
+ spot info
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [expect \
+ {wrong # args: should be "spot info command ?arg ...?"} \
+ {wrong # args: should be "spot info command ..."}]
+
+test iinfo-1.3 {object info too many args} -body {
+ type dog { }
+
+ dog create spot
+
+ spot info type foo
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.method.info.type {type selfns win self}]
+
+test iinfo-2.1 {object info type} -body {
+ type dog { }
+
+ dog create spot
+ spot info type
+} -cleanup {
+ dog destroy
+} -result {::dog}
+
+test iinfo-3.1 {object info typevars} -body {
+ type dog {
+ typevariable thisvar 1
+
+ constructor {args} {
+ typevariable thatvar 2
+ }
+ }
+
+ dog create spot
+ lsort [spot info typevars]
+} -cleanup {
+ dog destroy
+} -result {::dog::thatvar ::dog::thisvar}
+
+test iinfo-3.2 {object info typevars with pattern} -body {
+ type dog {
+ typevariable thisvar 1
+
+ constructor {args} {
+ typevariable thatvar 2
+ }
+ }
+
+ dog create spot
+ spot info typevars *this*
+} -cleanup {
+ dog destroy
+} -result {::dog::thisvar}
+
+test iinfo-4.1 {object info vars} -body {
+ type dog {
+ variable hisvar 1
+
+ constructor {args} {
+ variable hervar
+ set hervar 2
+ }
+ }
+
+ dog create spot
+ lsort [spot info vars]
+} -cleanup {
+ dog destroy
+} -result {::dog::Snit_inst1::hervar ::dog::Snit_inst1::hisvar}
+
+test iinfo-4.2 {object info vars with pattern} -body {
+ type dog {
+ variable hisvar 1
+
+ constructor {args} {
+ variable hervar
+ set hervar 2
+ }
+ }
+
+ dog create spot
+ spot info vars "*his*"
+} -cleanup {
+ dog destroy
+} -result {::dog::Snit_inst1::hisvar}
+
+test iinfo-5.1 {object info no vars defined} -body {
+ type dog { }
+
+ dog create spot
+ list [spot info vars] [spot info typevars]
+} -cleanup {
+ dog destroy
+} -result {{} {}}
+
+test iinfo-6.1 {info options with no options} -body {
+ type dog { }
+ dog create spot
+
+ llength [spot info options]
+} -cleanup {
+ dog destroy
+} -result {0}
+
+test iinfo-6.2 {info options with only local options} -body {
+ type dog {
+ option -foo a
+ option -bar b
+ }
+ dog create spot
+
+ lsort [spot info options]
+} -cleanup {
+ dog destroy
+} -result {-bar -foo}
+
+test iinfo-6.3 {info options with local and delegated options} -body {
+ type dog {
+ option -foo a
+ option -bar b
+ delegate option -quux to sibling
+ }
+ dog create spot
+
+ lsort [spot info options]
+} -cleanup {
+ dog destroy
+} -result {-bar -foo -quux}
+
+test iinfo-6.4 {info options with unknown delegated options} -constraints {
+ tk tcl83
+} -body {
+ widgetadaptor myframe {
+ option -foo a
+ delegate option * to hull
+ constructor {args} {
+ installhull [frame $self]
+ }
+ }
+ myframe .frm
+
+ set a [lsort [.frm info options]]
+ destroy .frm
+ tkbide
+ set a
+} -cleanup {
+ myframe destroy
+} -result {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -relief -takefocus -visual -width}
+
+test iinfo-6.5 {info options with unknown delegated options} -constraints {
+ tk tcl84
+} -body {
+ widgetadaptor myframe {
+ option -foo a
+ delegate option * to hull
+ constructor {args} {
+ installhull [frame $self]
+ }
+ }
+ myframe .frm
+
+ set a [lsort [.frm info options]]
+ destroy .frm
+ tkbide
+ set a
+} -cleanup {
+ myframe destroy
+} -result {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width}
+
+test iinfo-6.6 {info options with exceptions} -constraints {
+ tk tcl83
+} -body {
+ widgetadaptor myframe {
+ option -foo a
+ delegate option * to hull except -background
+ constructor {args} {
+ installhull [frame $self]
+ }
+ }
+ myframe .frm
+
+ set a [lsort [.frm info options]]
+ destroy .frm
+ tkbide
+ set a
+} -cleanup {
+ myframe destroy
+} -result {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -relief -takefocus -visual -width}
+
+test iinfo-6.7 {info options with exceptions} -constraints {
+ tk tcl84
+} -body {
+ widgetadaptor myframe {
+ option -foo a
+ delegate option * to hull except -background
+ constructor {args} {
+ installhull [frame $self]
+ }
+ }
+ myframe .frm
+
+ set a [lsort [.frm info options]]
+ destroy .frm
+ tkbide
+ set a
+} -cleanup {
+ myframe destroy
+} -result {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width}
+
+test iinfo-6.8 {info options with pattern} -constraints {
+ tk
+} -body {
+ widgetadaptor myframe {
+ option -foo a
+ delegate option * to hull
+ constructor {args} {
+ installhull [frame $self]
+ }
+ }
+ myframe .frm
+
+ set a [lsort [.frm info options -c*]]
+ destroy .frm
+ tkbide
+ set a
+} -cleanup {
+ myframe destroy
+} -result {-class -colormap -container -cursor}
+
+test iinfo-7.1 {info typemethods, simple case} -body {
+ type dog { }
+
+ dog spot
+
+ lsort [spot info typemethods]
+} -cleanup {
+ dog destroy
+} -result {create destroy info}
+
+test iinfo-7.2 {info typemethods, with pattern} -body {
+ type dog { }
+
+ dog spot
+
+ spot info typemethods i*
+} -cleanup {
+ dog destroy
+} -result {info}
+
+test iinfo-7.3 {info typemethods, with explicit typemethods} -body {
+ type dog {
+ typemethod foo {} {}
+ delegate typemethod bar to comp
+ }
+
+ dog spot
+
+ lsort [spot info typemethods]
+} -cleanup {
+ dog destroy
+} -result {bar create destroy foo info}
+
+test iinfo-7.4 {info typemethods, with implicit typemethods} -body {
+ type dog {
+ delegate typemethod * to comp
+
+ typeconstructor {
+ set comp string
+ }
+ }
+
+ dog create spot
+
+ set a [lsort [spot info typemethods]]
+
+ dog length foo
+ dog is boolean yes
+
+ set b [lsort [spot info typemethods]]
+
+ set c [spot info typemethods len*]
+
+ list $a $b $c
+} -cleanup {
+ dog destroy
+} -result {{create destroy info} {create destroy info is length} length}
+
+test iinfo-7.5 {info typemethods, with hierarchical typemethods} -body {
+ type dog {
+ delegate typemethod {comp foo} to comp
+
+ typemethod {comp bar} {} {}
+ }
+
+ dog create spot
+
+ lsort [spot info typemethods]
+} -cleanup {
+ dog destroy
+} -result {{comp bar} {comp foo} create destroy info}
+
+
+test iinfo-8.1 {info methods, simple case} -body {
+ type dog { }
+
+ dog spot
+
+ lsort [spot info methods]
+} -cleanup {
+ dog destroy
+} -result {destroy info}
+
+test iinfo-8.2 {info methods, with pattern} -body {
+ type dog { }
+
+ dog spot
+
+ spot info methods i*
+} -cleanup {
+ dog destroy
+} -result {info}
+
+test iinfo-8.3 {info methods, with explicit methods} -body {
+ type dog {
+ method foo {} {}
+ delegate method bar to comp
+ }
+
+ dog spot
+
+ lsort [spot info methods]
+} -cleanup {
+ dog destroy
+} -result {bar destroy foo info}
+
+test iinfo-8.4 {info methods, with implicit methods} -body {
+ type dog {
+ delegate method * to comp
+
+ constructor {args} {
+ set comp string
+ }
+ }
+
+ dog create spot
+
+ set a [lsort [spot info methods]]
+
+ spot length foo
+ spot is boolean yes
+
+ set b [lsort [spot info methods]]
+
+ set c [spot info methods len*]
+
+ list $a $b $c
+} -cleanup {
+ dog destroy
+} -result {{destroy info} {destroy info is length} length}
+
+test iinfo-8.5 {info methods, with hierarchical methods} -body {
+ type dog {
+ delegate method {comp foo} to comp
+
+ method {comp bar} {} {}
+ }
+
+ dog create spot
+
+ lsort [spot info methods]
+} -cleanup {
+ dog destroy
+} -result {{comp bar} {comp foo} destroy info}
+
+test iinfo-9.1 {info args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info args bark
+} -cleanup {
+ dog destroy
+} -result {volume}
+
+test iinfo-9.2 {info args, too few args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info args
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.method.info.args {type selfns win self method} 4]
+
+test iinfo-9.3 {info args, too many args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info args bark wag
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.method.info.args {type selfns win self method}]
+
+test iinfo-9.4 {info args, unknown method} -body {
+ type dog {
+ }
+
+ dog spot
+
+ spot info args bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Unknown method "bark"}
+
+test iinfo-9.5 {info args, delegated method} -body {
+ type dog {
+ component x
+ delegate method bark to x
+ }
+
+ dog spot
+
+ spot info args bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Delegated method "bark"}
+
+test iinfo-10.1 {info default} -body {
+ type dog {
+ method bark {{volume 50}} {}
+ }
+
+ dog spot
+
+ list [spot info default bark volume def] $def
+} -cleanup {
+ dog destroy
+} -result {1 50}
+
+test iinfo-10.2 {info default, too few args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info default
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.method.info.default {type selfns win self method aname dvar} 4]
+
+test iinfo-10.3 {info default, too many args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info default bark wag def foo
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.method.info.default {type selfns win self method aname dvar}]
+
+test iinfo-10.4 {info default, unknown method} -body {
+ type dog {
+ }
+
+ dog spot
+
+ spot info default bark x var
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Unknown method "bark"}
+
+test iinfo-10.5 {info default, delegated method} -body {
+ type dog {
+ component x
+ delegate method bark to x
+ }
+
+ dog spot
+
+ spot info default bark x var
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Delegated method "bark"}
+
+test iinfo-11.1 {info body} -body {
+ type dog {
+ typevariable x
+ variable y
+ method bark {volume} {
+ speaker on
+ speaker play bark.snd
+ speaker off
+ }
+ }
+
+ dog spot
+
+ spot info body bark
+} -cleanup {
+ dog destroy
+} -result {
+ speaker on
+ speaker play bark.snd
+ speaker off
+ }
+
+test iinfo-11.2 {info body, too few args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info body
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.method.info.body {type selfns win self method} 4]
+
+test iinfo-11.3 {info body, too many args} -body {
+ type dog {
+ method bark {volume} {}
+ }
+
+ dog spot
+
+ spot info body bark wag
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.method.info.body {type selfns win self method}]
+
+test iinfo-11.4 {info body, unknown method} -body {
+ type dog {
+ }
+
+ dog spot
+
+ spot info body bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Unknown method "bark"}
+
+test iinfo-11.5 {info body, delegated method} -body {
+ type dog {
+ component x
+ delegate method bark to x
+ }
+
+ dog spot
+
+ spot info body bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Delegated method "bark"}
+
+#-----------------------------------------------------------------------
+# Type Introspection
+
+# Case 1
+test tinfo-1.1 {type info too few args} -constraints {
+ snit1
+} -body {
+ type dog { }
+
+ dog info
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info {type command args} 1]
+
+# Case 2
+test tinfo-1.2 {type info too few args} -constraints {
+ snit2
+} -body {
+ type dog { }
+
+ dog info
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [expect \
+ {wrong # args: should be "dog info command ?arg ...?"} \
+ {wrong # args: should be "dog info command ..."}]
+
+test tinfo-1.3 {type info too many args} -body {
+ type dog { }
+
+ dog info instances foo bar
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.instances {type ?pattern?}]
+
+test tinfo-2.1 {type info typevars} -body {
+ type dog {
+ typevariable thisvar 1
+
+ constructor {args} {
+ typevariable thatvar 2
+ }
+ }
+
+ dog create spot
+ lsort [dog info typevars]
+} -cleanup {
+ dog destroy
+} -result {::dog::thatvar ::dog::thisvar}
+
+test tinfo-3.1 {type info instances} -body {
+ type dog { }
+
+ dog create spot
+ dog create fido
+
+ lsort [dog info instances]
+} -cleanup {
+ dog destroy
+} -result {::fido ::spot}
+
+test tinfo-3.2 {widget info instances} -constraints {
+ tk
+} -body {
+ widgetadaptor mylabel {
+ constructor {args} {
+ installhull [label $self]
+ }
+ }
+
+ mylabel .lab1
+ mylabel .lab2
+
+ set result [mylabel info instances]
+
+ destroy .lab1
+ destroy .lab2
+ tkbide
+
+ lsort $result
+} -cleanup {
+ mylabel destroy
+} -result {.lab1 .lab2}
+
+test tinfo-3.3 {type info instances with non-global namespaces} -body {
+ type dog { }
+
+ dog create ::spot
+
+ namespace eval ::dogs:: {
+ set ::qname [dog create fido]
+ }
+
+ list $qname [lsort [dog info instances]]
+} -cleanup {
+ dog destroy
+} -result {::dogs::fido {::dogs::fido ::spot}}
+
+test tinfo-3.4 {type info instances with pattern} -body {
+ type dog { }
+
+ dog create spot
+ dog create fido
+
+ dog info instances "*f*"
+} -cleanup {
+ dog destroy
+} -result {::fido}
+
+test tinfo-3.5 {type info instances with unrelated child namespace, bug 2898640} -body {
+ type dog { }
+ namespace eval dog::unrelated {}
+ dog create fido
+
+ dog info instances
+} -cleanup {
+ dog destroy
+} -result {::fido}
+
+test tinfo-4.1 {type info typevars with pattern} -body {
+ type dog {
+ typevariable thisvar 1
+
+ constructor {args} {
+ typevariable thatvar 2
+ }
+ }
+
+ dog create spot
+ dog info typevars *this*
+} -cleanup {
+ dog destroy
+} -result {::dog::thisvar}
+
+test tinfo-5.1 {type info typemethods, simple case} -body {
+ type dog { }
+
+ lsort [dog info typemethods]
+} -cleanup {
+ dog destroy
+} -result {create destroy info}
+
+test tinfo-5.2 {type info typemethods, with pattern} -body {
+ type dog { }
+
+ dog info typemethods i*
+} -cleanup {
+ dog destroy
+} -result {info}
+
+test tinfo-5.3 {type info typemethods, with explicit typemethods} -body {
+ type dog {
+ typemethod foo {} {}
+ delegate typemethod bar to comp
+ }
+
+ lsort [dog info typemethods]
+} -cleanup {
+ dog destroy
+} -result {bar create destroy foo info}
+
+test tinfo-5.4 {type info typemethods, with implicit typemethods} -body {
+ type dog {
+ delegate typemethod * to comp
+
+ typeconstructor {
+ set comp string
+ }
+ }
+
+ set a [lsort [dog info typemethods]]
+
+ dog length foo
+ dog is boolean yes
+
+ set b [lsort [dog info typemethods]]
+
+ set c [dog info typemethods len*]
+
+ list $a $b $c
+} -cleanup {
+ dog destroy
+} -result {{create destroy info} {create destroy info is length} length}
+
+test tinfo-5.5 {info typemethods, with hierarchical typemethods} -body {
+ type dog {
+ delegate typemethod {comp foo} to comp
+
+ typemethod {comp bar} {} {}
+ }
+
+ lsort [dog info typemethods]
+} -cleanup {
+ dog destroy
+} -result {{comp bar} {comp foo} create destroy info}
+
+test tinfo-6.1 {type info args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info args bark
+} -cleanup {
+ dog destroy
+} -result {volume}
+
+test tinfo-6.2 {type info args, too few args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info args
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.args {type method} 1]
+
+test tinfo-6.3 {type info args, too many args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info args bark wag
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.args {type method}]
+
+test tinfo-6.4 {type info args, unknown method} -body {
+ type dog {
+ }
+
+ dog info args bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Unknown typemethod "bark"}
+
+test tinfo-6.5 {type info args, delegated method} -body {
+ type dog {
+ delegate typemethod bark to x
+ }
+
+ dog info args bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Delegated typemethod "bark"}
+
+test tinfo-7.1 {type info default} -body {
+ type dog {
+ typemethod bark {{volume 50}} {}
+ }
+
+ list [dog info default bark volume def] $def
+} -cleanup {
+ dog destroy
+} -result {1 50}
+
+test tinfo-7.2 {type info default, too few args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info default
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.default {type method aname dvar} 1]
+
+test tinfo-7.3 {type info default, too many args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info default bark wag def foo
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.default {type method aname dvar}]
+
+test tinfo-7.4 {type info default, unknown method} -body {
+ type dog {
+ }
+
+ dog info default bark x var
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Unknown typemethod "bark"}
+
+test tinfo-7.5 {type info default, delegated method} -body {
+ type dog {
+ delegate typemethod bark to x
+ }
+
+ dog info default bark x var
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Delegated typemethod "bark"}
+
+test tinfo-8.1 {type info body} -body {
+ type dog {
+ typevariable x
+ variable y
+ typemethod bark {volume} {
+ speaker on
+ speaker play bark.snd
+ speaker off
+ }
+ }
+
+ dog info body bark
+} -cleanup {
+ dog destroy
+} -result {
+ speaker on
+ speaker play bark.snd
+ speaker off
+ }
+
+test tinfo-8.2 {type info body, too few args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info body
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.body {type method} 1]
+
+test tinfo-8.3 {type info body, too many args} -body {
+ type dog {
+ typemethod bark {volume} {}
+ }
+
+ dog info body bark wag
+} -returnCodes error -cleanup {
+ dog destroy
+} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.body {type method}]
+
+test tinfo-8.4 {type info body, unknown method} -body {
+ type dog {
+ }
+
+ dog info body bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Unknown typemethod "bark"}
+
+test tinfo-8.5 {type info body, delegated method} -body {
+ type dog {
+ delegate typemethod bark to x
+ }
+
+ dog info body bark
+} -returnCodes error -cleanup {
+ dog destroy
+} -result {Delegated typemethod "bark"}
+
+#-----------------------------------------------------------------------
+# Setting the widget class explicitly
+
+test widgetclass-1.1 {can't set widgetclass for snit::types} -body {
+ type dog {
+ widgetclass Dog
+ }
+} -returnCodes {
+ error
+} -result {widgetclass cannot be set for snit::types}
+
+test widgetclass-1.2 {can't set widgetclass for snit::widgetadaptors} -constraints {
+ tk
+} -body {
+ widgetadaptor dog {
+ widgetclass Dog
+ }
+} -returnCodes {
+ error
+} -result {widgetclass cannot be set for snit::widgetadaptors}
+
+test widgetclass-1.3 {widgetclass must begin with uppercase letter} -constraints {
+ tk
+} -body {
+ widget dog {
+ widgetclass dog
+ }
+} -returnCodes {
+ error
+} -result {widgetclass "dog" does not begin with an uppercase letter}
+
+test widgetclass-1.4 {widgetclass can only be defined once} -constraints {
+ tk
+} -body {
+ widget dog {
+ widgetclass Dog
+ widgetclass Dog
+ }
+} -returnCodes {
+ error
+} -result {too many widgetclass statements}
+
+test widgetclass-1.5 {widgetclass set successfully} -constraints {
+ tk
+} -body {
+ widget dog {
+ widgetclass DogWidget
+ }
+
+ # The test passes if no error is thrown.
+ list ok
+} -cleanup {
+ dog destroy
+} -result {ok}
+
+test widgetclass-1.6 {implicit widgetclass applied to hull} -constraints {
+ tk
+} -body {
+ widget dog {
+ typeconstructor {
+ option add *Dog.background green
+ }
+
+ method background {} {
+ $hull cget -background
+ }
+ }
+
+ dog .dog
+
+ set bg [.dog background]
+
+ destroy .dog
+
+ set bg
+} -cleanup {
+ dog destroy
+} -result {green}
+
+test widgetclass-1.7 {explicit widgetclass applied to hull} -constraints {
+ tk
+} -body {
+ widget dog {
+ widgetclass DogWidget
+
+ typeconstructor {
+ option add *DogWidget.background green
+ }
+
+ method background {} {
+ $hull cget -background
+ }
+ }
+
+ dog .dog
+
+ set bg [.dog background]
+
+ destroy .dog
+
+ set bg
+} -cleanup {
+ dog destroy
+} -result {green}
+
+#-----------------------------------------------------------------------
+# hulltype statement
+
+test hulltype-1.1 {can't set hulltype for snit::types} -body {
+ type dog {
+ hulltype Dog
+ }
+} -returnCodes {
+ error
+} -result {hulltype cannot be set for snit::types}
+
+test hulltype-1.2 {can't set hulltype for snit::widgetadaptors} -constraints {
+ tk
+} -body {
+ widgetadaptor dog {
+ hulltype Dog
+ }
+} -returnCodes {
+ error
+} -result {hulltype cannot be set for snit::widgetadaptors}
+
+test hulltype-1.3 {hulltype can be frame} -constraints {
+ tk
+} -body {
+ widget dog {
+ delegate option * to hull
+ hulltype frame
+ }
+
+ dog .fido
+ catch {.fido configure -use} result
+ destroy .fido
+ tkbide
+
+ set result
+} -cleanup {
+ dog destroy
+} -result {unknown option "-use"}
+
+test hulltype-1.4 {hulltype can be toplevel} -constraints {
+ tk
+} -body {
+ widget dog {
+ delegate option * to hull
+ hulltype toplevel
+ }
+
+ dog .fido
+ catch {.fido configure -use} result
+ destroy .fido
+ tkbide
+
+ set result
+} -cleanup {
+ dog destroy
+} -result {-use use Use {} {}}
+
+test hulltype-1.5 {hulltype can only be defined once} -constraints {
+ tk
+} -body {
+ widget dog {
+ hulltype frame
+ hulltype toplevel
+ }
+} -returnCodes {
+ error
+} -result {too many hulltype statements}
+
+test hulltype-2.1 {list of valid hulltypes} -constraints {
+ tk
+} -body {
+ lsort $::snit::hulltypes
+} -result {frame labelframe tk::frame tk::labelframe tk::toplevel toplevel ttk::frame ttk::labelframe}
+
+
+#-----------------------------------------------------------------------
+# expose statement
+
+test expose-1.1 {can't expose nothing} -body {
+ type dog {
+ expose
+ }
+} -constraints {
+ snit1
+} -returnCodes {
+ error
+} -result [tcltest::wrongNumArgs ::snit::Comp.statement.expose {component ?as? ?methodname?} 0]
+
+test expose-1.1a {can't expose nothing} -body {
+ type dog {
+ expose
+ }
+} -constraints {
+ snit2
+} -returnCodes {
+ error
+} -result [tcltest::wrongNumArgs expose {component ?as? ?methodname?} 0]
+
+test expose-1.2 {expose a component that's never installed} -body {
+ type dog {
+ expose tail
+ }
+
+ dog fido
+
+ fido tail wag
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {undefined component "tail"}
+
+test expose-1.3 {exposed method returns component command} -body {
+ type tail { }
+
+ type dog {
+ expose tail
+
+ constructor {} {
+ install tail using tail $self.tail
+ }
+
+ destructor {
+ $tail destroy
+ }
+ }
+
+ dog fido
+
+ fido tail
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {::fido.tail}
+
+test expose-1.4 {exposed method calls component methods} -body {
+ type tail {
+ method wag {args} {return "wag<$args>"}
+ method droop {} {return "droop"}
+ }
+
+ type dog {
+ expose tail
+
+ constructor {} {
+ install tail using tail $self.tail
+ }
+
+ destructor {
+ $tail destroy
+ }
+ }
+
+ dog fido
+
+ list [fido tail wag] [fido tail wag abc] [fido tail wag abc def] \
+ [fido tail droop]
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {wag<> wag<abc> {wag<abc def>} droop}
+
+#-----------------------------------------------------------------------
+# Error handling
+#
+# This section verifies that errorInfo and errorCode are propagated
+# appropriately on error.
+
+test error-1.1 {typemethod errors propagate properly} -body {
+ type dog {
+ typemethod generr {} {
+ error bogusError bogusInfo bogusCode
+ }
+ }
+
+ catch {dog generr} result
+
+ global errorInfo errorCode
+
+ list $result [string match "*bogusInfo*" $errorInfo] $errorCode
+} -cleanup {
+ dog destroy
+} -result {bogusError 1 bogusCode}
+
+test error-1.2 {snit::type constructor errors propagate properly} -body {
+ type dog {
+ constructor {} {
+ error bogusError bogusInfo bogusCode
+ }
+ }
+
+ catch {dog fido} result
+
+ global errorInfo errorCode
+
+ list $result [string match "*bogusInfo*" $errorInfo] $errorCode
+} -cleanup {
+ dog destroy
+} -result {{Error in constructor: bogusError} 1 bogusCode}
+
+test error-1.3 {snit::widget constructor errors propagate properly} -constraints {
+ tk
+} -body {
+ widget dog {
+ constructor {args} {
+ error bogusError bogusInfo bogusCode
+ }
+ }
+
+ catch {dog .fido} result
+
+ global errorInfo errorCode
+
+ list $result [string match "*bogusInfo*" $errorInfo] $errorCode
+} -cleanup {
+ dog destroy
+} -result {{Error in constructor: bogusError} 1 bogusCode}
+
+test error-1.4 {method errors propagate properly} -body {
+ type dog {
+ method generr {} {
+ error bogusError bogusInfo bogusCode
+ }
+ }
+
+ dog fido
+ catch {fido generr} result
+
+ global errorInfo errorCode
+
+ list $result [string match "*bogusInfo*" $errorInfo] $errorCode
+} -cleanup {
+ dog destroy
+} -result {bogusError 1 bogusCode}
+
+test error-1.5 {onconfigure errors propagate properly} -body {
+ type dog {
+ option -generr
+
+ onconfigure -generr {value} {
+ error bogusError bogusInfo bogusCode
+ }
+ }
+
+ dog fido
+ catch {fido configure -generr 0} result
+
+ global errorInfo errorCode
+
+ list $result [string match "*bogusInfo*" $errorInfo] $errorCode
+} -cleanup {
+ dog destroy
+} -result {bogusError 1 bogusCode}
+
+test error-1.6 {oncget errors propagate properly} -body {
+ type dog {
+ option -generr
+
+ oncget -generr {
+ error bogusError bogusInfo bogusCode
+ }
+ }
+
+ dog fido
+ catch {fido cget -generr} result
+
+ global errorInfo errorCode
+
+ list $result [string match "*bogusInfo*" $errorInfo] $errorCode
+} -cleanup {
+ dog destroy
+} -result {bogusError 1 bogusCode}
+
+#-----------------------------------------------------------------------
+# Externally defined typemethods
+
+test etypemethod-1.1 {external typemethods can be called as expected} -body {
+ type dog { }
+ typemethod dog foo {a} {return "+$a+"}
+
+ dog foo bar
+} -cleanup {
+ dog destroy
+} -result {+bar+}
+
+test etypemethod-1.2 {external typemethods can use typevariables} -body {
+ type dog {
+ typevariable somevar "Howdy"
+ }
+ typemethod dog getvar {} {return $somevar}
+
+ dog getvar
+} -cleanup {
+ dog destroy
+} -result {Howdy}
+
+test etypemethod-1.3 {typemethods can be redefined dynamically} -body {
+ type dog {
+ typemethod foo {} { return "foo" }
+ }
+ set a [dog foo]
+
+ typemethod dog foo {} { return "bar"}
+
+ set b [dog foo]
+
+ list $a $b
+} -cleanup {
+ dog destroy
+} -result {foo bar}
+
+test etypemethod-1.4 {can't define external typemethod if no type} -body {
+ typemethod extremelyraredog foo {} { return "bar"}
+} -returnCodes {
+ error
+} -result {no such type: "extremelyraredog"}
+
+test etypemethod-2.1 {external hierarchical method, two tokens} -body {
+ type dog { }
+ typemethod dog {wag tail} {} {
+ return "wags tail"
+ }
+
+ dog wag tail
+} -cleanup {
+ dog destroy
+} -result {wags tail}
+
+test etypemethod-2.2 {external hierarchical method, three tokens} -body {
+ type dog { }
+ typemethod dog {wag tail proudly} {} {
+ return "wags tail proudly"
+ }
+
+ dog wag tail proudly
+} -cleanup {
+ dog destroy
+} -result {wags tail proudly}
+
+test etypemethod-2.3 {external hierarchical method, three tokens} -body {
+ type dog { }
+ typemethod dog {wag tail really high} {} {
+ return "wags tail really high"
+ }
+
+ dog wag tail really high
+} -cleanup {
+ dog destroy
+} -result {wags tail really high}
+
+test etypemethod-2.4 {redefinition is OK} -body {
+ type dog { }
+ typemethod dog {wag tail} {} {
+ return "wags tail"
+ }
+ typemethod dog {wag tail} {} {
+ return "wags tail briskly"
+ }
+
+ dog wag tail
+} -cleanup {
+ dog destroy
+} -result {wags tail briskly}
+
+test etypemethod-3.1 {prefix/method collision} -body {
+ type dog {
+ typemethod wag {} {}
+ }
+
+ typemethod dog {wag tail} {} {}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag tail", "wag" has no submethods.}
+
+test etypemethod-3.2 {prefix/method collision} -body {
+ type dog {
+ typemethod {wag tail} {} {}
+ }
+
+ typemethod dog wag {} {}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag", "wag" has submethods.}
+
+test etypemethod-3.3 {prefix/method collision} -body {
+ type dog {
+ typemethod {wag tail} {} {}
+ }
+
+ typemethod dog {wag tail proudly} {} {}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag tail proudly", "wag tail" has no submethods.}
+
+test etypemethod-3.4 {prefix/method collision} -body {
+ type dog {
+ typemethod {wag tail proudly} {} {}
+ }
+
+ typemethod dog {wag tail} {} {}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag tail", "wag tail" has submethods.}
+
+#-----------------------------------------------------------------------
+# Externally defined methods
+
+test emethod-1.1 {external methods can be called as expected} -body {
+ type dog { }
+ method dog bark {a} {return "+$a+"}
+
+ dog spot
+ spot bark woof
+} -cleanup {
+ dog destroy
+} -result {+woof+}
+
+test emethod-1.2 {external methods can use typevariables} -body {
+ type dog {
+ typevariable somevar "Hello"
+ }
+ method dog getvar {} {return $somevar}
+
+ dog spot
+ spot getvar
+} -cleanup {
+ dog destroy
+} -result {Hello}
+
+test emethod-1.3 {external methods can use variables} -body {
+ type dog {
+ variable somevar "Greetings"
+ }
+ method dog getvar {} {return $somevar}
+
+ dog spot
+ spot getvar
+} -cleanup {
+ dog destroy
+} -result {Greetings}
+
+test emethod-1.4 {methods can be redefined dynamically} -body {
+ type dog {
+ method bark {} { return "woof" }
+ }
+
+ dog spot
+
+ set a [spot bark]
+
+ method dog bark {} { return "arf"}
+
+ set b [spot bark]
+
+ list $a $b
+} -cleanup {
+ dog destroy
+} -result {woof arf}
+
+test emethod-1.5 {delegated methods can't be redefined} -body {
+ type dog {
+ delegate method bark to someotherdog
+ }
+
+ method dog bark {} { return "arf"}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "bark", "bark" has been delegated}
+
+test emethod-1.6 {can't define external method if no type} -body {
+ method extremelyraredog foo {} { return "bar"}
+} -returnCodes {
+ error
+} -result {no such type: "extremelyraredog"}
+
+test emethod-2.1 {external hierarchical method, two tokens} -body {
+ type dog { }
+ method dog {wag tail} {} {
+ return "$self wags tail."
+ }
+
+ dog spot
+ spot wag tail
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail.}
+
+test emethod-2.2 {external hierarchical method, three tokens} -body {
+ type dog { }
+ method dog {wag tail proudly} {} {
+ return "$self wags tail proudly."
+ }
+
+ dog spot
+ spot wag tail proudly
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail proudly.}
+
+test emethod-2.3 {external hierarchical method, three tokens} -body {
+ type dog { }
+ method dog {wag tail really high} {} {
+ return "$self wags tail really high."
+ }
+
+ dog spot
+ spot wag tail really high
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail really high.}
+
+test emethod-2.4 {redefinition is OK} -body {
+ type dog { }
+ method dog {wag tail} {} {
+ return "$self wags tail."
+ }
+ method dog {wag tail} {} {
+ return "$self wags tail briskly."
+ }
+
+ dog spot
+ spot wag tail
+} -cleanup {
+ dog destroy
+} -result {::spot wags tail briskly.}
+
+test emethod-3.1 {prefix/method collision} -body {
+ type dog {
+ method wag {} {}
+ }
+
+ method dog {wag tail} {} {
+ return "$self wags tail."
+ }
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag tail", "wag" has no submethods.}
+
+test emethod-3.2 {prefix/method collision} -body {
+ type dog {
+ method {wag tail} {} {
+ return "$self wags tail."
+ }
+ }
+
+ method dog wag {} {}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag", "wag" has submethods.}
+
+test emethod-3.3 {prefix/method collision} -body {
+ type dog {
+ method {wag tail} {} {}
+ }
+
+ method dog {wag tail proudly} {} {
+ return "$self wags tail."
+ }
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag tail proudly", "wag tail" has no submethods.}
+
+test emethod-3.4 {prefix/method collision} -body {
+ type dog {
+ method {wag tail proudly} {} {
+ return "$self wags tail."
+ }
+ }
+
+ method dog {wag tail} {} {}
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Cannot define "wag tail", "wag tail" has submethods.}
+
+
+#-----------------------------------------------------------------------
+# Macros
+
+test macro-1.1 {can't redefine non-macros} -body {
+ snit::macro method {} {}
+} -returnCodes {
+ error
+} -result {invalid macro name "method"}
+
+test macro-1.2 {can define and use a macro} -body {
+ snit::macro hello {name} {
+ method hello {} "return {Hello, $name!}"
+ }
+
+ type dog {
+ hello World
+ }
+
+ dog spot
+
+ spot hello
+
+} -cleanup {
+ dog destroy
+} -result {Hello, World!}
+
+test macro-1.3 {can redefine macro} -body {
+ snit::macro dup {} {}
+ snit::macro dup {} {}
+
+ set dummy "No error"
+} -result {No error}
+
+test macro-1.4 {can define macro in namespace} -body {
+ snit::macro ::test::goodbye {name} {
+ method goodbye {} "return {Goodbye, $name!}"
+ }
+
+ type dog {
+ ::test::goodbye World
+ }
+
+ dog spot
+
+ spot goodbye
+} -cleanup {
+ dog destroy
+} -result {Goodbye, World!}
+
+test macro-1.5 {_proc and _variable are defined} -body {
+ snit::macro testit {} {
+ set a [info commands _variable]
+ set b [info commands _proc]
+ method testit {} "list $a $b"
+ }
+
+ type dog {
+ testit
+ }
+
+ dog spot
+
+ spot testit
+} -cleanup {
+ dog destroy
+} -result {_variable _proc}
+
+test macro-1.6 {_variable works} -body {
+ snit::macro test1 {} {
+ _variable myvar "_variable works"
+ }
+
+ snit::macro test2 {} {
+ _variable myvar
+
+ method testit {} "return {$myvar}"
+ }
+
+ type dog {
+ test1
+ test2
+ }
+
+ dog spot
+
+ spot testit
+} -cleanup {
+ dog destroy
+} -result {_variable works}
+
+#-----------------------------------------------------------------------
+# Component Statement
+
+test component-1.1 {component defines an instance variable} -body {
+ type dog {
+ component tail
+ }
+
+ dog spot
+
+ namespace tail [spot info vars tail]
+} -cleanup {
+ dog destroy
+} -result {tail}
+
+test component-1.2 {-public exposes the component} -body {
+ type tail {
+ method wag {} {
+ return "Wag, wag"
+ }
+ }
+
+ type dog {
+ component tail -public mytail
+
+ constructor {} {
+ set tail [tail %AUTO%]
+ }
+ }
+
+ dog spot
+
+ spot mytail wag
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {Wag, wag}
+
+test component-1.3 {-inherit requires a boolean value} -body {
+ type dog {
+ component animal -inherit foo
+ }
+} -returnCodes {
+ error
+} -result {component animal -inherit: expected boolean value, got "foo"}
+
+test component-1.4 {-inherit delegates unknown methods to the component} -body {
+ type animal {
+ method eat {} {
+ return "Eat, eat."
+ }
+ }
+
+ type dog {
+ component animal -inherit yes
+
+ constructor {} {
+ set animal [animal %AUTO%]
+ }
+ }
+
+ dog spot
+
+ spot eat
+} -cleanup {
+ dog destroy
+ animal destroy
+} -result {Eat, eat.}
+
+test component-1.5 {-inherit delegates unknown options to the component} -body {
+ type animal {
+ option -size medium
+ }
+
+ type dog {
+ component animal -inherit yes
+
+ constructor {} {
+ set animal [animal %AUTO%]
+ }
+ }
+
+ dog spot
+
+ spot cget -size
+} -cleanup {
+ dog destroy
+ animal destroy
+} -result {medium}
+
+#-----------------------------------------------------------------------
+# Typevariables, Variables, Typecomponents, Components
+
+test typevar_var-1.1 {variable/typevariable collisions not allowed: order 1} -body {
+ type dog {
+ typevariable var
+ variable var
+ }
+} -returnCodes {
+ error
+} -result {Error in "variable var...", "var" is already a typevariable}
+
+test typevar_var-1.2 {variable/typevariable collisions not allowed: order 2} -body {
+ type dog {
+ variable var
+ typevariable var
+ }
+} -returnCodes {
+ error
+} -result {Error in "typevariable var...", "var" is already an instance variable}
+
+test typevar_var-1.3 {component/typecomponent collisions not allowed: order 1} -body {
+ type dog {
+ typecomponent comp
+ component comp
+ }
+} -returnCodes {
+ error
+} -result {Error in "component comp...", "comp" is already a typevariable}
+
+test typevar_var-1.4 {component/typecomponent collisions not allowed: order 2} -body {
+ type dog {
+ component comp
+ typecomponent comp
+ }
+} -returnCodes {
+ error
+} -result {Error in "typecomponent comp...", "comp" is already an instance variable}
+
+test typevar_var-1.5 {can't delegate options to typecomponents} -body {
+ type dog {
+ typecomponent comp
+
+ delegate option -opt to comp
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate option -opt...", "comp" is already a typevariable}
+
+test typevar_var-1.6 {can't delegate typemethods to instance components} -body {
+ type dog {
+ component comp
+
+ delegate typemethod foo to comp
+ }
+} -returnCodes {
+ error
+} -result {Error in "delegate typemethod foo...", "comp" is already an instance variable}
+
+test typevar_var-1.7 {can delegate methods to typecomponents} -body {
+ proc echo {args} {return [join $args "|"]}
+
+ type dog {
+ typecomponent tail
+
+ typeconstructor {
+ set tail echo
+ }
+
+ delegate method wag to tail
+ }
+
+ dog spot
+ spot wag briskly
+} -cleanup {
+ dog destroy
+ rename echo ""
+} -result {wag|briskly}
+
+#-----------------------------------------------------------------------
+# Option syntax tests.
+#
+# This set of tests verifies that the option statement is interpreted
+# properly, that errors are caught, and that the type's optionInfo
+# array is initialized properly.
+#
+# TBD: At some point, this needs to be folded into the regular
+# option tests.
+
+test optionsyntax-1.1 {local option names are saved} -body {
+ type dog {
+ option -foo
+ option -bar
+ }
+
+ set ::dog::Snit_optionInfo(local)
+} -cleanup {
+ dog destroy
+} -result {-foo -bar}
+
+test optionsyntax-1.2 {islocal flag is set} -body {
+ type dog {
+ option -foo
+ }
+
+ set ::dog::Snit_optionInfo(islocal--foo)
+} -cleanup {
+ dog destroy
+} -result {1}
+
+test optionsyntax-2.1 {implicit resource and class} -body {
+ type dog {
+ option -foo
+ }
+
+ list \
+ $::dog::Snit_optionInfo(resource--foo) \
+ $::dog::Snit_optionInfo(class--foo)
+} -cleanup {
+ dog destroy
+} -result {foo Foo}
+
+test optionsyntax-2.2 {explicit resource, default class} -body {
+ type dog {
+ option {-foo ffoo}
+ }
+
+ list \
+ $::dog::Snit_optionInfo(resource--foo) \
+ $::dog::Snit_optionInfo(class--foo)
+} -cleanup {
+ dog destroy
+} -result {ffoo Ffoo}
+
+test optionsyntax-2.3 {explicit resource and class} -body {
+ type dog {
+ option {-foo ffoo FFoo}
+ }
+
+ list \
+ $::dog::Snit_optionInfo(resource--foo) \
+ $::dog::Snit_optionInfo(class--foo)
+} -cleanup {
+ dog destroy
+} -result {ffoo FFoo}
+
+test optionsyntax-2.4 {can't redefine explicit resource} -body {
+ type dog {
+ option {-foo ffoo}
+ option {-foo foo}
+ }
+} -returnCodes {
+ error
+} -result {Error in "option {-foo foo}...", resource name redefined from "ffoo" to "foo"}
+
+test optionsyntax-2.5 {can't redefine explicit class} -body {
+ type dog {
+ option {-foo ffoo Ffoo}
+ option {-foo ffoo FFoo}
+ }
+} -returnCodes {
+ error
+} -result {Error in "option {-foo ffoo FFoo}...", class name redefined from "Ffoo" to "FFoo"}
+
+test optionsyntax-2.6 {can redefine implicit resource and class} -body {
+ type dog {
+ option -foo
+ option {-foo ffoo}
+ option {-foo ffoo FFoo}
+ option -foo
+ }
+} -cleanup {
+ dog destroy
+} -result {::dog}
+
+test optionsyntax-3.1 {no default value} -body {
+ type dog {
+ option -foo
+ }
+
+ set ::dog::Snit_optionInfo(default--foo)
+} -cleanup {
+ dog destroy
+} -result {}
+
+test optionsyntax-3.2 {default value, old syntax} -body {
+ type dog {
+ option -foo bar
+ }
+
+ set ::dog::Snit_optionInfo(default--foo)
+} -cleanup {
+ dog destroy
+} -result {bar}
+
+test optionsyntax-3.3 {option definition options can be set} -body {
+ type dog {
+ option -foo \
+ -default Bar \
+ -validatemethod Validate \
+ -configuremethod Configure \
+ -cgetmethod Cget \
+ -readonly 1
+ }
+
+ list \
+ $::dog::Snit_optionInfo(default--foo) \
+ $::dog::Snit_optionInfo(validate--foo) \
+ $::dog::Snit_optionInfo(configure--foo) \
+ $::dog::Snit_optionInfo(cget--foo) \
+ $::dog::Snit_optionInfo(readonly--foo)
+} -cleanup {
+ dog destroy
+} -result {Bar Validate Configure Cget 1}
+
+test optionsyntax-3.4 {option definition option values accumulate} -body {
+ type dog {
+ option -foo -default Bar
+ option -foo -validatemethod Validate
+ option -foo -configuremethod Configure
+ option -foo -cgetmethod Cget
+ option -foo -readonly 1
+ }
+
+ list \
+ $::dog::Snit_optionInfo(default--foo) \
+ $::dog::Snit_optionInfo(validate--foo) \
+ $::dog::Snit_optionInfo(configure--foo) \
+ $::dog::Snit_optionInfo(cget--foo) \
+ $::dog::Snit_optionInfo(readonly--foo)
+} -cleanup {
+ dog destroy
+} -result {Bar Validate Configure Cget 1}
+
+test optionsyntax-3.5 {option definition option values can be redefined} -body {
+ type dog {
+ option -foo -default Bar
+ option -foo -validatemethod Validate
+ option -foo -configuremethod Configure
+ option -foo -cgetmethod Cget
+ option -foo -readonly 1
+ option -foo -default Bar2
+ option -foo -validatemethod Validate2
+ option -foo -configuremethod Configure2
+ option -foo -cgetmethod Cget2
+ option -foo -readonly 0
+ }
+
+ list \
+ $::dog::Snit_optionInfo(default--foo) \
+ $::dog::Snit_optionInfo(validate--foo) \
+ $::dog::Snit_optionInfo(configure--foo) \
+ $::dog::Snit_optionInfo(cget--foo) \
+ $::dog::Snit_optionInfo(readonly--foo)
+} -cleanup {
+ dog destroy
+} -result {Bar2 Validate2 Configure2 Cget2 0}
+
+test optionsyntax-3.6 {option -readonly defaults to 0} -body {
+ type dog {
+ option -foo
+ }
+
+ set ::dog::Snit_optionInfo(readonly--foo)
+} -cleanup {
+ dog destroy
+} -result {0}
+
+test optionsyntax-3.7 {option -readonly can be any boolean} -body {
+ type dog {
+ option -foo -readonly 0
+ option -foo -readonly 1
+ option -foo -readonly y
+ option -foo -readonly n
+ }
+} -cleanup {
+ dog destroy
+} -result {::dog}
+
+test optionsyntax-3.8 {option -readonly must be a boolean} -body {
+ type dog {
+ option -foo -readonly foo
+ }
+} -returnCodes {
+ error
+} -result {Error in "option -foo...", -readonly requires a boolean, got "foo"}
+
+test optionsyntax-3.9 {option -readonly can't be empty} -body {
+ type dog {
+ option -foo -readonly {}
+ }
+} -returnCodes {
+ error
+} -result {Error in "option -foo...", -readonly requires a boolean, got ""}
+
+#-----------------------------------------------------------------------
+# 'delegate option' Syntax tests.
+#
+# This set of tests verifies that the 'delegation option' statement is
+# interpreted properly, and that the type's optionInfo
+# array is initialized properly.
+#
+# TBD: At some point, this needs to be folded into the regular
+# option tests.
+
+test delegateoptionsyntax-1.1 {'delegated' lists delegated option names} -body {
+ type dog {
+ delegate option -foo to comp
+ delegate option -bar to comp
+ }
+
+ set ::dog::Snit_optionInfo(delegated)
+} -cleanup {
+ dog destroy
+} -result {-foo -bar}
+
+test delegateoptionsyntax-1.2 {'delegated' does not include '*'} -body {
+ type dog {
+ delegate option * to comp
+ }
+
+ set ::dog::Snit_optionInfo(delegated)
+} -cleanup {
+ dog destroy
+} -result {}
+
+test delegateoptionsyntax-1.3 {'islocal' is set to 0} -body {
+ type dog {
+ delegate option -foo to comp
+ }
+
+ set ::dog::Snit_optionInfo(islocal--foo)
+} -cleanup {
+ dog destroy
+} -result {0}
+
+test delegateoptionsyntax-1.4 {'islocal' is not set for '*'} -body {
+ type dog {
+ delegate option * to comp
+ }
+
+ info exists ::dog::Snit_optionInfo(islocal-*)
+} -cleanup {
+ dog destroy
+} -result {0}
+
+test delegateoptionsyntax-1.5 {'delegated-$comp' lists options for the component} -body {
+ type dog {
+ delegate option -foo to comp1
+ delegate option -bar to comp1
+ delegate option -baz to comp2
+
+ # The * won't show up.
+ delegate option * to comp2
+ }
+
+ list \
+ $::dog::Snit_optionInfo(delegated-comp1) \
+ $::dog::Snit_optionInfo(delegated-comp2)
+} -cleanup {
+ dog destroy
+} -result {{-foo -bar} -baz}
+
+test delegateoptionsyntax-1.6 {'except' is empty by default} -body {
+ type dog {
+ delegate option -foo to comp
+ }
+
+ set ::dog::Snit_optionInfo(except)
+} -cleanup {
+ dog destroy
+} -result {}
+
+test delegateoptionsyntax-1.7 {'except' lists exceptions} -body {
+ type dog {
+ delegate option * to comp except {-foo -bar -baz}
+ }
+
+ set ::dog::Snit_optionInfo(except)
+} -cleanup {
+ dog destroy
+} -result {-foo -bar -baz}
+
+test delegateoptionsyntax-1.8 {'target-$opt' set with default} -body {
+ type dog {
+ delegate option -foo to comp
+ }
+
+ set ::dog::Snit_optionInfo(target--foo)
+} -cleanup {
+ dog destroy
+} -result {comp -foo}
+
+test delegateoptionsyntax-1.9 {'target-$opt' set explicitly} -body {
+ type dog {
+ delegate option -foo to comp as -bar
+ }
+
+ set ::dog::Snit_optionInfo(target--foo)
+} -cleanup {
+ dog destroy
+} -result {comp -bar}
+
+test delegateoptionsyntax-1.10 {'starcomp' is {} by default} -body {
+ type dog {
+ delegate option -foo to comp
+ }
+
+ set ::dog::Snit_optionInfo(starcomp)
+} -cleanup {
+ dog destroy
+} -result {}
+
+test delegateoptionsyntax-1.11 {'starcomp' set for *} -body {
+ type dog {
+ delegate option * to comp
+ }
+
+ set ::dog::Snit_optionInfo(starcomp)
+} -cleanup {
+ dog destroy
+} -result {comp}
+
+test delegatedoptionsyntax-2.1 {implicit resource and class} -body {
+ type dog {
+ delegate option -foo to comp
+ }
+
+ list \
+ $::dog::Snit_optionInfo(resource--foo) \
+ $::dog::Snit_optionInfo(class--foo)
+} -cleanup {
+ dog destroy
+} -result {foo Foo}
+
+test delegatedoptionsyntax-2.2 {explicit resource, default class} -body {
+ type dog {
+ delegate option {-foo ffoo} to comp
+ }
+
+ list \
+ $::dog::Snit_optionInfo(resource--foo) \
+ $::dog::Snit_optionInfo(class--foo)
+} -cleanup {
+ dog destroy
+} -result {ffoo Ffoo}
+
+test delegatedoptionsyntax-2.3 {explicit resource and class} -body {
+ type dog {
+ delegate option {-foo ffoo FFoo} to comp
+ }
+
+ list \
+ $::dog::Snit_optionInfo(resource--foo) \
+ $::dog::Snit_optionInfo(class--foo)
+} -cleanup {
+ dog destroy
+} -result {ffoo FFoo}
+
+test delegatedoptionsyntax-2.4 {* doesn't get resource and class} -body {
+ type dog {
+ delegate option * to comp
+ }
+
+ list \
+ [info exist ::dog::Snit_optionInfo(resource-*)] \
+ [info exist ::dog::Snit_optionInfo(class-*)]
+} -cleanup {
+ dog destroy
+} -result {0 0}
+
+#-----------------------------------------------------------------------
+# Cget cache
+
+test cgetcache-1.1 {Instance rename invalidates cache} -body {
+ type dog {
+ option -foo -default bar -cgetmethod getfoo
+
+ method getfoo {option} {
+ return $options($option)
+ }
+ }
+
+ dog fido -foo quux
+
+ # Cache the cget command.
+ fido cget -foo
+
+ rename fido spot
+
+ spot cget -foo
+} -cleanup {
+ dog destroy
+} -result {quux}
+
+test cgetcache-1.2 {Component rename invalidates cache} -body {
+ type tail {
+ option -foo bar
+ }
+
+ type dog {
+ delegate option -foo to tail
+
+ constructor {args} {
+ set tail [tail %AUTO%]
+ $tail configure -foo quux
+ }
+
+ method retail {} {
+ set tail [tail %AUTO%]
+ }
+ }
+
+ dog fido
+
+ # Cache the cget command.
+ fido cget -foo
+
+ # Invalidate the cache
+ fido retail
+
+ fido cget -foo
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {bar}
+
+# case 1
+test cgetcache-1.3 {Invalid -cgetmethod causes error} -constraints {
+ snit1
+} -body {
+ type dog {
+ option -foo -default bar -cgetmethod bogus
+ }
+
+ dog fido -foo quux
+
+ fido cget -foo
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {can't cget -foo, "::fido bogus" is not defined}
+
+# case 2
+test cgetcache-1.4 {Invalid -cgetmethod causes error} -constraints {
+ snit2
+} -body {
+ type dog {
+ option -foo -default bar -cgetmethod bogus
+ }
+
+ dog fido -foo quux
+
+ fido cget -foo
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "bogus": must be cget, or configurelist}
+
+test cgetcache-1.5 {hierarchical -cgetmethod} -body {
+ type dog {
+ option -foo -default bar -cgetmethod {Get Opt}
+
+ method {Get Opt} {option} {
+ return Dummy
+ }
+ }
+
+ dog fido
+
+ fido cget -foo
+} -cleanup {
+ dog destroy
+} -result {Dummy}
+
+#-----------------------------------------------------------------------
+# Configure cache
+
+test configurecache-1.1 {Instance rename invalidates cache} -body {
+ type dog {
+ option -foo -default bar -configuremethod setfoo
+
+ method setfoo {option value} {
+ $self setoption $option $value
+ }
+
+ method setoption {option value} {
+ set options($option) $value
+ }
+ }
+
+ # Set the option on creation; this will cache the
+ # configure command.
+ dog fido -foo quux
+
+ rename fido spot
+
+ spot configure -foo baz
+ spot cget -foo
+} -cleanup {
+ dog destroy
+} -result {baz}
+
+test configurecache-1.2 {Component rename invalidates cache} -body {
+ type tail {
+ option -foo bar
+ }
+
+ type dog {
+ delegate option -foo to tail
+
+ constructor {args} {
+ set tail [tail thistail]
+ $self configurelist $args
+ }
+
+ method retail {} {
+ # Give it a new component
+ set tail [tail thattail]
+ }
+ }
+
+ # Set the tail's -foo, and cache the command.
+ dog fido -foo quux
+
+ # Invalidate the cache
+ fido retail
+
+ # Should recache, and set the new tail's option.
+ fido configure -foo baz
+
+ fido cget -foo
+} -cleanup {
+ dog destroy
+ tail destroy
+} -result {baz}
+
+# Case 1
+test configurecache-1.3 {Invalid -configuremethod causes error} -constraints {
+ snit1
+} -body {
+ type dog {
+ option -foo -default bar -configuremethod bogus
+ }
+
+ dog fido
+ fido configure -foo quux
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {can't configure -foo, "::fido bogus" is not defined}
+
+# Case 2
+test configurecache-1.4 {Invalid -configuremethod causes error} -constraints {
+ snit2
+} -body {
+ type dog {
+ option -foo -default bar -configuremethod bogus
+ }
+
+ dog fido
+ fido configure -foo quux
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "bogus": must be configure, or configurelist}
+
+test configurecache-1.5 {hierarchical -configuremethod} -body {
+ type dog {
+ option -foo -default bar -configuremethod {Set Opt}
+
+ method {Set Opt} {option value} {
+ set options($option) Dummy
+ }
+ }
+
+ dog fido -foo NotDummy
+ fido cget -foo
+} -cleanup {
+ dog destroy
+} -result {Dummy}
+
+
+
+#-----------------------------------------------------------------------
+# option -validatemethod
+
+test validatemethod-1.1 {Validate method is called} -body {
+ type dog {
+ variable flag 0
+
+ option -color \
+ -default black \
+ -validatemethod ValidateColor
+
+ method ValidateColor {option value} {
+ set flag 1
+ }
+
+ method getflag {} {
+ return $flag
+ }
+ }
+
+ dog fido -color brown
+ fido getflag
+} -cleanup {
+ dog destroy
+} -result {1}
+
+test validatemethod-1.2 {Validate method gets correct arguments} -body {
+ type dog {
+ option -color \
+ -default black \
+ -validatemethod ValidateColor
+
+ method ValidateColor {option value} {
+ if {![string equal $option "-color"] ||
+ ![string equal $value "brown"]} {
+ error "Expected '-color brown'"
+ }
+ }
+ }
+
+ dog fido -color brown
+} -cleanup {
+ dog destroy
+} -result {::fido}
+
+# Case 1
+test validatemethod-1.3 {Invalid -validatemethod causes error} -constraints {
+ snit1
+} -body {
+ type dog {
+ option -foo -default bar -validatemethod bogus
+ }
+
+ dog fido
+ fido configure -foo quux
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {can't validate -foo, "::fido bogus" is not defined}
+
+# Case 2
+test validatemethod-1.4 {Invalid -validatemethod causes error} -constraints {
+ snit2
+} -body {
+ type dog {
+ option -foo -default bar -validatemethod bogus
+ }
+
+ dog fido
+ fido configure -foo quux
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "bogus": must be configure, or configurelist}
+
+test validatemethod-1.5 {hierarchical -validatemethod} -body {
+ type dog {
+ option -foo -default bar -validatemethod {Val Opt}
+
+ method {Val Opt} {option value} {
+ error "Dummy"
+ }
+ }
+
+ dog fido -foo value
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Error in constructor: Dummy}
+
+
+
+#-----------------------------------------------------------------------
+# option -readonly semantics
+
+test optionreadonly-1.1 {Readonly options can be set at creation time} -body {
+ type dog {
+ option -color \
+ -default black \
+ -readonly true
+ }
+
+ dog fido -color brown
+
+ fido cget -color
+} -cleanup {
+ dog destroy
+} -result {brown}
+
+test optionreadonly-1.2 {Readonly options can't be set after creation} -body {
+ type dog {
+ option -color \
+ -default black \
+ -readonly true
+ }
+
+ dog fido
+
+ fido configure -color brown
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {option -color can only be set at instance creation}
+
+test optionreadonly-1.3 {Readonly options can't be set after creation} -body {
+ type dog {
+ option -color \
+ -default black \
+ -readonly true
+ }
+
+ dog fido -color yellow
+
+ fido configure -color brown
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {option -color can only be set at instance creation}
+
+#-----------------------------------------------------------------------
+# Pragma -hastypeinfo
+
+test hastypeinfo-1.1 {$type info is defined by default} -body {
+ type dog {
+ typevariable foo
+ }
+
+ dog info typevars
+} -cleanup {
+ dog destroy
+} -result {::dog::foo}
+
+# Case 1
+test hastypeinfo-1.2 {$type info can be disabled} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -hastypeinfo no
+ typevariable foo
+ }
+
+ dog info typevars
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {"::dog info" is not defined}
+
+# Case 2
+test hastypeinfo-1.3 {$type info can be disabled} -constraints {
+ snit2
+} -body {
+ type dog {
+ pragma -hastypeinfo no
+ typevariable foo
+ }
+
+ dog info typevars
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "info": namespace ::dog does not export any commands}
+
+
+#-----------------------------------------------------------------------
+# Pragma -hastypedestroy
+
+test hastypedestroy-1.1 {$type destroy is defined by default} -body {
+ type dog {
+ typevariable foo
+ }
+
+ dog destroy
+
+ ::dog info typevars
+} -returnCodes {
+ error
+} -result {invalid command name "::dog"}
+
+# Case 1
+test hastypedestroy-1.2 {$type destroy can be disabled} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -hastypedestroy no
+ typevariable foo
+ }
+
+ dog destroy
+} -returnCodes {
+ error
+} -cleanup {
+ rename ::dog ""
+ namespace delete ::dog
+} -result {"::dog destroy" is not defined}
+
+# Case 2
+test hastypedestroy-1.3 {$type destroy can be disabled} -constraints {
+ snit2
+} -body {
+ type dog {
+ pragma -hastypedestroy no
+ typevariable foo
+ }
+
+ dog destroy
+} -returnCodes {
+ error
+} -cleanup {
+ rename ::dog ""
+ namespace delete ::dog
+} -result {unknown subcommand "destroy": namespace ::dog does not export any commands}
+
+#-----------------------------------------------------------------------
+# Pragma -hasinstances
+
+test hasinstances-1.1 {-hasinstances is true by default} -body {
+ type dog {
+ method bark {} {
+ return "Woof"
+ }
+ }
+
+ dog fido
+ fido bark
+} -cleanup {
+ dog destroy
+} -result {Woof}
+
+# Case 1
+test hasinstances-1.2 {'-hasinstances no' disables explicit object creation} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -hasinstances no
+ }
+
+ dog create fido
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {"::dog create" is not defined}
+
+# Case 2
+test hasinstances-1.3 {'-hasinstances no' disables explicit object creation} -constraints {
+ snit2
+} -body {
+ type dog {
+ pragma -hasinstances no
+ }
+
+ dog create fido
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "create": namespace ::dog does not export any commands}
+
+# Case 1
+test hasinstances-1.4 {'-hasinstances no' disables implicit object creation} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -hasinstances no
+ }
+
+ dog fido
+} -returnCodes {
+ error
+} -result {"::dog fido" is not defined}
+
+# Case 2
+test hasinstances-1.5 {'-hasinstances no' disables implicit object creation} -constraints {
+ snit2
+} -body {
+ type dog {
+ pragma -hasinstances no
+ }
+
+ dog fido
+} -returnCodes {
+ error
+} -result {unknown subcommand "fido": namespace ::dog does not export any commands}
+
+#-----------------------------------------------------------------------
+# pragma -canreplace
+
+test canreplace-1.1 {By default, "-canreplace no"} -body {
+ type dog {
+ # ...
+ }
+
+ dog fido
+ dog fido
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {command "::fido" already exists}
+
+test canreplace-1.2 {Can replace commands when "-canreplace yes"} -constraints {
+ bug8.5a3
+} -body {
+ type dog {
+ pragma -canreplace yes
+ }
+
+ dog fido
+ dog fido
+} -cleanup {
+ dog destroy
+} -result {::fido}
+
+#-----------------------------------------------------------------------
+# pragma -hasinfo
+
+test hasinfo-1.1 {$obj info is defined by default} -body {
+ type dog {
+ variable foo ""
+ }
+
+ dog spot
+ spot info vars
+} -cleanup {
+ dog destroy
+} -result {::dog::Snit_inst1::foo}
+
+# Case 1
+test hasinfo-1.2 {$obj info can be disabled} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -hasinfo no
+ variable foo
+ }
+
+ dog spot
+ spot info vars
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {"::spot info" is not defined}
+
+# Case 2
+test hasinfo-1.3 {$obj info can be disabled} -constraints {
+ snit2
+} -body {
+ type dog {
+ pragma -hasinfo no
+ variable foo
+ }
+
+ dog spot
+ spot info vars
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {unknown subcommand "info": namespace ::dog::Snit_inst1 does not export any commands}
+
+#-----------------------------------------------------------------------
+# pragma -hastypemethods
+#
+# The "-hastypemethods yes" case is tested by the bulk of this file.
+# We'll test the "-hastypemethods no" case here.
+
+test hastypemethods-1.1 {-hastypemethods no, $type foo creates instance.} -body {
+ type dog {
+ pragma -hastypemethods no
+ variable foo
+ }
+
+ dog spot
+} -cleanup {
+ spot destroy
+ rename ::dog ""
+ namespace delete ::dog
+} -result {::spot}
+
+test hastypemethods-1.2 {-hastypemethods no, $type create foo fails.} -body {
+ type dog {
+ pragma -hastypemethods no
+ variable foo
+ }
+
+ dog create spot
+} -returnCodes {
+ error
+} -cleanup {
+ rename ::dog ""
+ namespace delete ::dog
+} -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]"
+
+test hastypemethods-1.3 {-hastypemethods no, $type info fails.} -body {
+ type dog {
+ pragma -hastypemethods no
+ variable foo
+ }
+
+ dog info
+} -returnCodes {
+ error
+} -cleanup {
+ rename ::dog ""
+ namespace delete ::dog
+} -result {command "::info" already exists}
+
+test hastypemethods-1.4 {-hastypemethods no, [$widget] fails.} -constraints {
+ tk
+} -body {
+ widget dog {
+ pragma -hastypemethods no
+ variable foo
+ }
+
+ dog
+} -returnCodes {
+ error
+} -cleanup {
+ rename ::dog ""
+ namespace delete ::dog
+} -result {wrong # args: should be "::dog name args"}
+
+test hastypemethods-1.5 {-hastypemethods no, -hasinstances no fails.} -body {
+ type dog {
+ pragma -hastypemethods no
+ pragma -hasinstances no
+ variable foo
+ }
+} -returnCodes {
+ error
+} -result {type ::dog has neither typemethods nor instances}
+
+#-----------------------------------------------------------------------
+# -simpledispatch yes
+
+test simpledispatch-1.1 {not allowed with method delegation.} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -simpledispatch yes
+
+ delegate method foo to bar
+ }
+} -returnCodes {
+ error
+} -result {type ::dog requests -simpledispatch but delegates methods.}
+
+test simpledispatch-1.2 {normal methods work with simpledispatch.} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -simpledispatch yes
+
+ method barks {how} {
+ return "$self barks $how."
+ }
+ }
+
+ dog spot
+ spot barks loudly
+} -cleanup {
+ dog destroy
+} -result {::spot barks loudly.}
+
+test simpledispatch-1.3 {option methods work with simpledispatch.} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -simpledispatch yes
+
+ option -breed mutt
+ }
+
+ dog spot
+ set a [spot cget -breed]
+ spot configure -breed collie
+ set b [spot cget -breed]
+ spot configurelist [list -breed sheltie]
+ set c [spot cget -breed]
+
+ list $a $b $c
+} -cleanup {
+ dog destroy
+} -result {mutt collie sheltie}
+
+test simpledispatch-1.4 {info method works with simpledispatch.} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -simpledispatch yes
+
+ option -breed mutt
+ }
+
+ dog spot
+
+ spot info options
+} -cleanup {
+ dog destroy
+} -result {-breed}
+
+test simpledispatch-1.5 {destroy method works with simpledispatch.} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -simpledispatch yes
+
+ option -breed mutt
+ }
+
+ dog spot
+ set a [info commands ::spot]
+ spot destroy
+ set b [info commands ::spot]
+ list $a $b
+} -cleanup {
+ dog destroy
+} -result {::spot {}}
+
+test simpledispatch-1.6 {no hierarchical methods with simpledispatch.} -constraints {
+ snit1
+} -body {
+ type dog {
+ pragma -simpledispatch yes
+
+ method {wag tail} {} {}
+ }
+} -returnCodes {
+ error
+} -result {type ::dog requests -simpledispatch but defines hierarchical methods.}
+
+#-----------------------------------------------------------------------
+# Exotic return codes
+
+test break-1.1 {Methods can "return -code break"} -body {
+ snit::type dog {
+ method bark {} {return -code break "Breaking"}
+ }
+
+ dog spot
+
+ catch {spot bark} result
+} -cleanup {
+ dog destroy
+} -result {3}
+
+test break-1.2 {Typemethods can "return -code break"} -body {
+ snit::type dog {
+ typemethod bark {} {return -code break "Breaking"}
+ }
+
+ catch {dog bark} result
+} -cleanup {
+ dog destroy
+} -result {3}
+
+test break-1.3 {Methods called via mymethod "return -code break"} -body {
+ snit::type dog {
+ method bark {} {return -code break "Breaking"}
+
+ method getbark {} {
+ return [mymethod bark]
+ }
+ }
+
+ dog spot
+
+ catch {uplevel \#0 [spot getbark]} result
+} -cleanup {
+ dog destroy
+} -result {3}
+
+#-----------------------------------------------------------------------
+# Namespace path
+
+test nspath-1.1 {Typemethods call commands from parent namespace} -constraints {
+ snit2
+} -body {
+ namespace eval ::snit_test:: {
+ proc bark {} {return "[namespace current]: Woof"}
+ }
+
+ snit::type ::snit_test::dog {
+ typemethod bark {} {
+ bark
+ }
+ }
+
+ ::snit_test::dog bark
+} -cleanup {
+ ::snit_test::dog destroy
+ namespace forget ::snit_test
+} -result {::snit_test: Woof}
+
+test nspath-1.2 {Methods can call commands from parent namespace} -constraints {
+ snit2
+} -body {
+ namespace eval ::snit_test:: {
+ proc bark {} {return "[namespace current]: Woof"}
+ }
+
+ snit::type ::snit_test::dog {
+ method bark {} {
+ bark
+ }
+ }
+
+ ::snit_test::dog spot
+ spot bark
+} -cleanup {
+ ::snit_test::dog destroy
+ namespace forget ::snit_test
+} -result {::snit_test: Woof}
+
+#-----------------------------------------------------------------------
+# snit::boolean
+
+test boolean-1.1 {boolean: valid} -body {
+ snit::boolean validate 1
+ snit::boolean validate 0
+ snit::boolean validate true
+ snit::boolean validate false
+ snit::boolean validate yes
+ snit::boolean validate no
+ snit::boolean validate on
+ snit::boolean validate off
+} -result {off}
+
+test boolean-1.2 {boolean: invalid} -body {
+ codecatch {snit::boolean validate quux}
+} -result {INVALID invalid boolean "quux", should be one of: 1, 0, true, false, yes, no, on, off}
+
+test boolean-2.1 {boolean subtype: valid} -body {
+ snit::boolean subtype
+ subtype validate 1
+ subtype validate 0
+ subtype validate true
+ subtype validate false
+ subtype validate yes
+ subtype validate no
+ subtype validate on
+ subtype validate off
+} -cleanup {
+ subtype destroy
+} -result {off}
+
+test boolean-2.2 {boolean subtype: invalid} -body {
+ snit::boolean subtype
+ codecatch {subtype validate quux}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid boolean "quux", should be one of: 1, 0, true, false, yes, no, on, off}
+
+#-----------------------------------------------------------------------
+# snit::double
+
+test double-1.1 {double: invalid -min} -body {
+ snit::double obj -min abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -min: "abc"}
+
+test double-1.2 {double: invalid -max} -body {
+ snit::double obj -max abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -max: "abc"}
+
+test double-1.3 {double: invalid, max < min} -body {
+ snit::double obj -min 5 -max 0
+} -returnCodes {
+ error
+} -result {Error in constructor: -max < -min}
+
+test double-2.1 {double type: valid} -body {
+ snit::double validate 1.5
+} -result {1.5}
+
+test double-2.2 {double type: invalid} -body {
+ codecatch {snit::double validate abc}
+} -result {INVALID invalid value "abc", expected double}
+
+test double-3.1 {double subtype: valid, no range} -body {
+ snit::double subtype
+ subtype validate 1.5
+} -cleanup {
+ subtype destroy
+} -result {1.5}
+
+test double-3.2 {double subtype: valid, min but no max} -body {
+ snit::double subtype -min 0.5
+ subtype validate 1
+} -cleanup {
+ subtype destroy
+} -result {1}
+
+test double-3.3 {double subtype: valid, min and max} -body {
+ snit::double subtype -min 0.5 -max 10.5
+ subtype validate 1.5
+} -cleanup {
+ subtype destroy
+} -result {1.5}
+
+test double-4.1 {double subtype: not a number} -body {
+ snit::double subtype
+ codecatch {subtype validate quux}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "quux", expected double}
+
+test double-4.2 {double subtype: less than min, no max} -body {
+ snit::double subtype -min 0.5
+ codecatch {subtype validate -1}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "-1", expected double no less than 0.5}
+
+test double-4.3 {double subtype: less than min, with max} -body {
+ snit::double subtype -min 0.5 -max 5.5
+ codecatch {subtype validate -1}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "-1", expected double in range 0.5, 5.5}
+
+test double-4.4 {double subtype: greater than max, no min} -body {
+ snit::double subtype -max 0.5
+ codecatch {subtype validate 1}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "1", expected double no greater than 0.5}
+
+#-----------------------------------------------------------------------
+# snit::enum
+
+test enum-1.1 {enum: valid} -body {
+ snit::enum validate foo
+} -result {foo}
+
+test enum-2.1 {enum subtype: missing -values} -body {
+ snit::enum subtype
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -values: ""}
+
+test enum-3.1 {enum subtype: valid} -body {
+ snit::enum subtype -values {foo bar baz}
+ subtype validate foo
+ subtype validate bar
+ subtype validate baz
+} -cleanup {
+ subtype destroy
+} -result {baz}
+
+test enum-3.2 {enum subtype: invalid} -body {
+ snit::enum subtype -values {foo bar baz}
+ codecatch {subtype validate quux}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "quux", should be one of: foo, bar, baz}
+
+
+#-----------------------------------------------------------------------
+# snit::fpixels
+
+test fpixels-1.1 {no suffix} -constraints tk -body {
+ snit::fpixels validate 5
+} -result {5}
+
+test fpixels-1.2 {suffix} -constraints tk -body {
+ snit::fpixels validate 5i
+} -result {5i}
+
+test fpixels-1.3 {decimal} -constraints tk -body {
+ snit::fpixels validate 5.5
+} -result {5.5}
+
+test fpixels-1.4 {invalid} -constraints tk -body {
+ codecatch {snit::fpixels validate 5.5abc}
+} -result {INVALID invalid value "5.5abc", expected fpixels}
+
+test fpixels-2.1 {bad -min} -constraints tk -body {
+ snit::fpixels subtype -min abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -min: "abc"}
+
+test fpixels-2.2 {bad -max} -constraints tk -body {
+ snit::fpixels subtype -max abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -max: "abc"}
+
+test fpixels-2.3 {-min > -max} -constraints tk -body {
+ snit::fpixels subtype -min 10 -max 5
+} -returnCodes {
+ error
+} -result {Error in constructor: -max < -min}
+
+test fpixels-3.1 {subtype, no suffix} -constraints tk -body {
+ snit::fpixels subtype
+ subtype validate 5
+} -cleanup {
+ subtype destroy
+} -result {5}
+
+test fpixels-3.2 {suffix} -constraints tk -body {
+ snit::fpixels subtype
+ subtype validate 5i
+} -cleanup {
+ subtype destroy
+} -result {5i}
+
+test fpixels-3.3 {decimal} -constraints tk -body {
+ snit::fpixels subtype
+ subtype validate 5.5
+} -cleanup {
+ subtype destroy
+} -result {5.5}
+
+test fpixels-3.4 {invalid} -constraints tk -body {
+ snit::fpixels subtype
+ codecatch {subtype validate 5.5abc}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "5.5abc", expected fpixels}
+
+
+test fpixels-3.5 {subtype -min} -constraints tk -body {
+ snit::fpixels subtype -min 5
+ subtype validate 10
+} -cleanup {
+ subtype destroy
+} -result {10}
+
+test fpixels-3.6 {min of min, max} -constraints tk -body {
+ snit::fpixels subtype -min 5 -max 20
+ subtype validate 5
+} -cleanup {
+ subtype destroy
+} -result {5}
+
+test fpixels-3.7 {max of min, max} -constraints tk -body {
+ snit::fpixels subtype -min 5 -max 20
+ subtype validate 20
+} -cleanup {
+ subtype destroy
+} -result {20}
+
+test fpixels-3.8 {middle of min, max} -constraints tk -body {
+ snit::fpixels subtype -min 5 -max 20
+ subtype validate 15
+} -cleanup {
+ subtype destroy
+} -result {15}
+
+test fpixels-3.9 {invalid, < min} -constraints tk -body {
+ snit::fpixels subtype -min 5
+ codecatch {subtype validate 4}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "4", expected fpixels no less than 5}
+
+test fpixels-3.10 {invalid, > max} -constraints tk -body {
+ snit::fpixels subtype -min 5 -max 20
+ codecatch {subtype validate 21}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "21", expected fpixels in range 5, 20}
+
+test fpixels-3.11 {invalid, > max, range with suffix} -constraints tk -body {
+ snit::fpixels subtype -min 5i -max 10i
+ codecatch {subtype validate 11i}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "11i", expected fpixels in range 5i, 10i}
+
+#-----------------------------------------------------------------------
+# snit::integer
+
+test integer-1.1 {integer: invalid -min} -body {
+ snit::integer obj -min abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -min: "abc"}
+
+test integer-1.2 {integer: invalid -max} -body {
+ snit::integer obj -max abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -max: "abc"}
+
+test integer-1.3 {integer: invalid, max < min} -body {
+ snit::integer obj -min 5 -max 0
+} -returnCodes {
+ error
+} -result {Error in constructor: -max < -min}
+
+test integer-2.1 {integer type: valid} -body {
+ snit::integer validate 1
+} -result {1}
+
+test integer-2.2 {integer type: invalid} -body {
+ codecatch {snit::integer validate abc}
+} -result {INVALID invalid value "abc", expected integer}
+
+test integer-3.1 {integer subtype: valid, no range} -body {
+ snit::integer subtype
+ subtype validate 1
+} -cleanup {
+ subtype destroy
+} -result {1}
+
+test integer-3.2 {integer subtype: valid, min but no max} -body {
+ snit::integer subtype -min 0
+ subtype validate 1
+} -cleanup {
+ subtype destroy
+} -result {1}
+
+test integer-3.3 {integer subtype: valid, min and max} -body {
+ snit::integer subtype -min 0 -max 10
+ subtype validate 1
+} -cleanup {
+ subtype destroy
+} -result {1}
+
+test integer-4.1 {integer subtype: not a number} -body {
+ snit::integer subtype
+ codecatch {subtype validate quux}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "quux", expected integer}
+
+test integer-4.2 {integer subtype: less than min, no max} -body {
+ snit::integer subtype -min 0
+ codecatch {subtype validate -1}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "-1", expected integer no less than 0}
+
+test integer-4.3 {integer subtype: less than min, with max} -body {
+ snit::integer subtype -min 0 -max 5
+ codecatch {subtype validate -1}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "-1", expected integer in range 0, 5}
+
+#-----------------------------------------------------------------------
+# snit::listtype
+
+test listtype-1.1 {listtype, length 0; valid} -body {
+ snit::listtype validate ""
+} -result {}
+
+test listtype-1.2 {listtype, length 1; valid} -body {
+ snit::listtype validate a
+} -result {a}
+
+test listtype-1.3 {listtype, length 2; valid} -body {
+ snit::listtype validate {a b}
+} -result {a b}
+
+test listtype-2.1 {listtype subtype, length 0; valid} -body {
+ snit::listtype subtype
+ subtype validate ""
+} -cleanup {
+ subtype destroy
+} -result {}
+
+test listtype-2.2 {listtype, length 1; valid} -body {
+ snit::listtype subtype
+ subtype validate a
+} -cleanup {
+ subtype destroy
+} -result {a}
+
+test listtype-2.3 {listtype, length 2; valid} -body {
+ snit::listtype subtype
+ subtype validate {a b}
+} -cleanup {
+ subtype destroy
+} -result {a b}
+
+test listtype-2.4 {listtype, invalid -minlen} -body {
+ snit::listtype subtype -minlen abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -minlen: "abc"}
+
+test listtype-2.5 {listtype, negative -minlen} -body {
+ snit::listtype subtype -minlen -1
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -minlen: "-1"}
+
+test listtype-2.6 {listtype, invalid -maxlen} -body {
+ snit::listtype subtype -maxlen abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -maxlen: "abc"}
+
+test listtype-2.7 {listtype, -maxlen < -minlen} -body {
+ snit::listtype subtype -minlen 10 -maxlen 9
+} -returnCodes {
+ error
+} -result {Error in constructor: -maxlen < -minlen}
+
+test listtype-3.1 {-minlen 2, length 2; valid} -body {
+ snit::listtype subtype -minlen 2
+ subtype validate {a b}
+} -cleanup {
+ subtype destroy
+} -result {a b}
+
+test listtype-3.2 {-minlen 2, length 3; valid} -body {
+ snit::listtype subtype -minlen 2
+ subtype validate {a b c}
+} -cleanup {
+ subtype destroy
+} -result {a b c}
+
+test listtype-3.3 {-minlen 2, length 1; invalid} -body {
+ snit::listtype subtype -minlen 2
+ codecatch {subtype validate a}
+} -cleanup {
+ subtype destroy
+} -result {INVALID value has too few elements; at least 2 expected}
+
+test listtype-3.4 {range 1 to 3, length 1; valid} -body {
+ snit::listtype subtype -minlen 1 -maxlen 3
+ subtype validate a
+} -cleanup {
+ subtype destroy
+} -result {a}
+
+test listtype-3.5 {range 1 to 3, length 3; valid} -body {
+ snit::listtype subtype -minlen 1 -maxlen 3
+ subtype validate {a b c}
+} -cleanup {
+ subtype destroy
+} -result {a b c}
+
+test listtype-3.6 {range 1 to 3, length 0; invalid} -body {
+ snit::listtype subtype -minlen 1 -maxlen 3
+ codecatch {subtype validate {}}
+} -cleanup {
+ subtype destroy
+} -result {INVALID value has too few elements; at least 1 expected}
+
+test listtype-3.7 {range 1 to 3, length 4; invalid} -body {
+ snit::listtype subtype -minlen 1 -maxlen 3
+ codecatch {subtype validate {a b c d}}
+} -cleanup {
+ subtype destroy
+} -result {INVALID value has too many elements; no more than 3 expected}
+
+test listtype-4.1 {boolean list, valid} -body {
+ snit::listtype subtype -type snit::boolean
+ subtype validate {yes 1 true}
+} -cleanup {
+ subtype destroy
+} -result {yes 1 true}
+
+test listtype-4.2 {boolean list, invalid} -body {
+ snit::listtype subtype -type snit::boolean
+ codecatch {subtype validate {yes 1 abc no}}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid boolean "abc", should be one of: 1, 0, true, false, yes, no, on, off}
+
+#-----------------------------------------------------------------------
+# snit::pixels
+
+test pixels-1.1 {no suffix} -constraints tk -body {
+ snit::pixels validate 5
+} -result {5}
+
+test pixels-1.2 {suffix} -constraints tk -body {
+ snit::pixels validate 5i
+} -result {5i}
+
+test pixels-1.3 {decimal} -constraints tk -body {
+ snit::pixels validate 5.5
+} -result {5.5}
+
+test pixels-1.4 {invalid} -constraints tk -body {
+ codecatch {snit::pixels validate 5.5abc}
+} -result {INVALID invalid value "5.5abc", expected pixels}
+
+test pixels-2.1 {bad -min} -constraints tk -body {
+ snit::pixels subtype -min abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -min: "abc"}
+
+test pixels-2.2 {bad -max} -constraints tk -body {
+ snit::pixels subtype -max abc
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -max: "abc"}
+
+test pixels-2.3 {-min > -max} -constraints tk -body {
+ snit::pixels subtype -min 10 -max 5
+} -returnCodes {
+ error
+} -result {Error in constructor: -max < -min}
+
+test pixels-3.1 {subtype, no suffix} -constraints tk -body {
+ snit::pixels subtype
+ subtype validate 5
+} -cleanup {
+ subtype destroy
+} -result {5}
+
+test pixels-3.2 {suffix} -constraints tk -body {
+ snit::pixels subtype
+ subtype validate 5i
+} -cleanup {
+ subtype destroy
+} -result {5i}
+
+test pixels-3.3 {decimal} -constraints tk -body {
+ snit::pixels subtype
+ subtype validate 5.5
+} -cleanup {
+ subtype destroy
+} -result {5.5}
+
+test pixels-3.4 {invalid} -constraints tk -body {
+ snit::pixels subtype
+ codecatch {subtype validate 5.5abc}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "5.5abc", expected pixels}
+
+
+test pixels-3.5 {subtype -min} -constraints tk -body {
+ snit::pixels subtype -min 5
+ subtype validate 10
+} -cleanup {
+ subtype destroy
+} -result {10}
+
+test pixels-3.6 {min of min, max} -constraints tk -body {
+ snit::pixels subtype -min 5 -max 20
+ subtype validate 5
+} -cleanup {
+ subtype destroy
+} -result {5}
+
+test pixels-3.7 {max of min, max} -constraints tk -body {
+ snit::pixels subtype -min 5 -max 20
+ subtype validate 20
+} -cleanup {
+ subtype destroy
+} -result {20}
+
+test pixels-3.8 {middle of min, max} -constraints tk -body {
+ snit::pixels subtype -min 5 -max 20
+ subtype validate 15
+} -cleanup {
+ subtype destroy
+} -result {15}
+
+test pixels-3.9 {invalid, < min} -constraints tk -body {
+ snit::pixels subtype -min 5
+ codecatch {subtype validate 4}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "4", expected pixels no less than 5}
+
+test pixels-3.10 {invalid, > max} -constraints tk -body {
+ snit::pixels subtype -min 5 -max 20
+ codecatch {subtype validate 21}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "21", expected pixels in range 5, 20}
+
+test pixels-3.11 {invalid, > max, range with suffix} -constraints tk -body {
+ snit::pixels subtype -min 5i -max 10i
+ codecatch {subtype validate 11i}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "11i", expected pixels in range 5i, 10i}
+
+#-----------------------------------------------------------------------
+# snit::stringtype
+
+test stringtype-1.1 {stringtype, valid string} -body {
+ snit::stringtype validate ""
+} -result {}
+
+test stringtype-2.1 {stringtype subtype: invalid -regexp} -body {
+ snit::stringtype subtype -regexp "\[A-Z"
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -regexp: "[A-Z"}
+
+test stringtype-2.2 {stringtype subtype: invalid -minlen} -body {
+ snit::stringtype subtype -minlen foo
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -minlen: "foo"}
+
+test stringtype-2.3 {stringtype subtype: invalid -maxlen} -body {
+ snit::stringtype subtype -maxlen foo
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -maxlen: "foo"}
+
+test stringtype-2.4 {stringtype subtype: -maxlen < -minlen} -body {
+ snit::stringtype subtype -maxlen 1 -minlen 5
+} -returnCodes {
+ error
+} -result {Error in constructor: -maxlen < -minlen}
+
+test stringtype-2.5 {stringtype subtype: -minlen < 0} -body {
+ snit::stringtype subtype -minlen -1
+} -returnCodes {
+ error
+} -result {Error in constructor: invalid -minlen: "-1"}
+
+test stringtype-2.6 {stringtype subtype: -maxlen < 0} -body {
+ snit::stringtype subtype -maxlen -1
+} -returnCodes {
+ error
+} -result {Error in constructor: -maxlen < -minlen}
+
+test stringtype-3.1 {stringtype subtype: -glob, valid} -body {
+ snit::stringtype subtype -glob "*FOO*"
+ subtype validate 1FOO2
+} -cleanup {
+ subtype destroy
+} -result {1FOO2}
+
+test stringtype-3.2 {stringtype subtype: -glob, case-insensitive} -body {
+ snit::stringtype subtype -nocase yes -glob "*FOO*"
+ subtype validate 1foo2
+} -cleanup {
+ subtype destroy
+} -result {1foo2}
+
+test stringtype-3.3 {stringtype subtype: -glob invalid, case-sensitive} -body {
+ snit::stringtype subtype -glob "*FOO*"
+ codecatch {subtype validate 1foo2}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "1foo2"}
+
+test stringtype-5.4 {stringtype subtype: -glob invalid, case-insensitive} -body {
+ snit::stringtype subtype -nocase yes -glob "*FOO*"
+ codecatch {subtype validate bar}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "bar"}
+
+test stringtype-5.5 {stringtype subtype: -regexp valid, case-sensitive} -body {
+ snit::stringtype subtype -regexp {^[A-Z]+$}
+ subtype validate FOO
+} -cleanup {
+ subtype destroy
+} -result {FOO}
+
+test stringtype-5.6 {stringtype subtype: -regexp valid, case-insensitive} -body {
+ snit::stringtype subtype -nocase yes -regexp {^[A-Z]+$}
+ subtype validate foo
+} -cleanup {
+ subtype destroy
+} -result {foo}
+
+test stringtype-5.7 {stringtype subtype: -regexp invalid, case-sensitive} -body {
+ snit::stringtype subtype -regexp {^[A-Z]+$}
+ codecatch {subtype validate foo}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "foo"}
+
+test stringtype-5.8 {stringtype subtype: -regexp invalid, case-insensitive} -body {
+ snit::stringtype subtype -nocase yes -regexp {^[A-Z]+$}
+ codecatch {subtype validate foo1}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value "foo1"}
+
+#-----------------------------------------------------------------------
+# snit::window
+
+test window-1.1 {window: valid} -constraints tk -body {
+ snit::window validate .
+} -result {.}
+
+test window-1.2 {window: invalid} -constraints tk -body {
+ codecatch {snit::window validate .nonesuch}
+} -result {INVALID invalid value ".nonesuch", value is not a window}
+
+test window-2.1 {window subtype: valid} -constraints tk -body {
+ snit::window subtype
+ subtype validate .
+} -cleanup {
+ subtype destroy
+} -result {.}
+
+test window-2.2 {window subtype: invalid} -constraints tk -body {
+ snit::window subtype
+ codecatch {subtype validate .nonesuch}
+} -cleanup {
+ subtype destroy
+} -result {INVALID invalid value ".nonesuch", value is not a window}
+
+#-----------------------------------------------------------------------
+# option -type specifications
+
+test optiontype-1.1 {-type is type object name} -body {
+ type dog {
+ option -akcflag -default no -type snit::boolean
+ }
+
+ dog create spot
+
+ # Set -akcflag to a boolean value
+ spot configure -akcflag yes
+ spot configure -akcflag 1
+ spot configure -akcflag on
+ spot configure -akcflag off
+
+ # Set -akcflag to an invalid value
+ spot configure -akcflag offf
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {invalid -akcflag value: invalid boolean "offf", should be one of: 1, 0, true, false, yes, no, on, off}
+
+test optiontype-1.2 {-type is type specification} -body {
+ type dog {
+ option -color -default brown \
+ -type {snit::enum -values {brown black white golden}}
+ }
+
+ dog create spot
+
+ # Set -color to a valid value
+ spot configure -color brown
+ spot configure -color black
+ spot configure -color white
+ spot configure -color golden
+
+ # Set -color to an invalid value
+ spot configure -color green
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {invalid -color value: invalid value "green", should be one of: brown, black, white, golden}
+
+test optiontype-1.3 {-type catches invalid defaults} -body {
+ type dog {
+ option -color -default green \
+ -type {snit::enum -values {brown black white golden}}
+ }
+
+ dog spot
+} -returnCodes {
+ error
+} -cleanup {
+ dog destroy
+} -result {Error in constructor: invalid -color default: invalid value "green", should be one of: brown, black, white, golden}
+
+
+#-----------------------------------------------------------------------
+# Bug Fixes
+
+test bug-1.1 {Bug 1161779: destructor can't precede constructor} -body {
+ type dummy {
+ destructor {
+ # No content
+ }
+
+ constructor {args} {
+ $self configurelist $args
+ }
+
+ }
+} -cleanup {
+ rename ::dummy ""
+} -result ::dummy
+
+test bug-2.1 {Bug 1106375: Widget Error on failed object's construction} -constraints {
+ tk
+} -body {
+ ::snit::widgetadaptor mylabel {
+ delegate method * to hull
+ delegate option * to hull
+
+ constructor {args} {
+ installhull using label
+ error "simulated error"
+ }
+ }
+
+ catch {mylabel .lab} result
+ list [info commands .lab] $result
+
+} -cleanup {
+ ::mylabel destroy
+} -result {{} {Error in constructor: simulated error}}
+
+test bug-2.2 {Bug 1106375: Widget Error on failed object's construction} -constraints {
+ tk
+} -body {
+ ::snit::widget myframe {
+ delegate method * to hull
+ delegate option * to hull
+
+ constructor {args} {
+ error "simulated error"
+ }
+ }
+
+ catch {myframe .frm} result
+ list [info commands .frm] $result
+ } -cleanup {
+ ::myframe destroy
+} -result {{} {Error in constructor: simulated error}}
+
+test bug-3.1 {Bug 1532791: snit2, snit::widget problem} -constraints {
+ tk
+} -body {
+ snit::widget mywidget {
+ delegate method * to mylabel
+ delegate option * to mylabel
+
+ variable mylabel {}
+ }
+
+ mywidget .mylabel
+} -cleanup {
+ destroy .mylabel
+} -result {.mylabel}
+
+
+#---------------------------------------------------------------------
+# Clean up
+
+rename expect {}
+testsuiteCleanup
--- /dev/null
+#-----------------------------------------------------------------------
+# TITLE:
+# snit2.tcl
+#
+# AUTHOR:
+# Will Duquette
+#
+# DESCRIPTION:
+# Snit's Not Incr Tcl, a simple object system in Pure Tcl.
+#
+# Snit 2.x Loader
+#
+# Copyright (C) 2003-2006 by William H. Duquette
+# This code is licensed as described in license.txt.
+#
+#-----------------------------------------------------------------------
+
+package require Tcl 8.5
+
+# Define the snit namespace and save the library directory
+
+namespace eval ::snit:: {
+ set library [file dirname [info script]]
+}
+
+# Load the kernel.
+source [file join $::snit::library main2.tcl]
+
+# Load the library of Snit validation types.
+source [file join $::snit::library validate.tcl]
+
+package provide snit 2.3.2
--- /dev/null
+#--------------------------------------------------------------------------
+# TITLE:
+# snit_tcl83_utils.tcl
+#
+# AUTHOR:
+# Kenneth Green, 28 Aug 2004
+#
+# DESCRIPTION:
+# Utilities to support the back-port of snit from Tcl 8.4 to 8.3
+#
+#--------------------------------------------------------------------------
+# Copyright
+#
+# Copyright (c) 2005 Kenneth Green
+# Modified by Andreas Kupries.
+# All rights reserved. This code is licensed as described in license.txt.
+#--------------------------------------------------------------------------
+# This code is freely distributable, but is provided as-is with
+# no warranty expressed or implied.
+#--------------------------------------------------------------------------
+# Acknowledgements
+# The changes described in this file are made to the awesome 'snit'
+# library as provided by William H. Duquette under the terms
+# defined in the associated 'license.txt'.
+#-----------------------------------------------------------------------
+
+#-----------------------------------------------------------------------
+# Namespace
+
+namespace eval ::snit83 {}
+
+#-----------------------------------------------------------------------
+# Some Snit83 variables
+
+namespace eval ::snit83 {
+ variable cmdTraceTable
+ array set cmdTraceTable {}
+
+ namespace eval private {}
+}
+
+
+#-----------------------------------------------------------------------
+# Initialisation
+
+#
+# Override Tcl functions so we can mimic some behaviours. This is
+# conditional on not having been done already. Otherwise loading snit
+# twice will fail the second time.
+#
+
+if [info exists tk_version] {
+ if {
+ ![llength [info procs destroy]] ||
+ ![regexp snit83 [info body destroy]]
+ } {
+ rename destroy __destroy__
+ }
+}
+if {
+ ![llength [info procs namespace]] ||
+ ![regexp snit83 [info body namespace]]
+} {
+ rename namespace __namespace__
+ rename rename __rename__ ;# must be last one renamed!
+}
+
+#-----------------------------------------------------------------------
+# Global namespace functions
+
+
+# destroy -
+#
+# Perform delete tracing and then invoke the actual Tk destroy command
+
+if [info exists tk_version] {
+ proc destroy { w } {
+ variable ::snit83::cmdTraceTable
+
+ set index "delete,$w"
+ if [info exists cmdTraceTable($index)] {
+ set cmd $cmdTraceTable($index)
+ ::unset cmdTraceTable($index) ;# prevent recursive tracing
+ if [catch {eval $cmd $oldName \"$newName\" delete} err] { ; # "
+ error $err
+ }
+ }
+
+ return [__destroy__ $w]
+ }
+}
+
+# namespace -
+#
+# Add limited support for 'namespace exists'. Must be a fully
+# qualified namespace name (pattern match support not provided).
+
+proc namespace { cmd args } {
+ if {[string equal $cmd "exists"]} {
+ set ptn [lindex $args 0]
+ return [::snit83::private::NamespaceIsDescendantOf :: $ptn]
+ } elseif {[string equal $cmd "delete"]} {
+ if [namespace exists [lindex $args 0]] {
+ return [uplevel 1 [subst {__namespace__ $cmd $args}]]
+ }
+ } else {
+ return [uplevel 1 [subst {__namespace__ $cmd $args}]]
+ }
+}
+
+# rename -
+#
+# Perform rename tracing and then invoke the actual Tcl rename command
+
+proc rename { oldName newName } {
+ variable ::snit83::cmdTraceTable
+
+ # Get caller's namespace since rename must be performed
+ # in the context of the caller's namespace
+ set callerNs "::"
+ set callerLevel [expr {[info level] - 1}]
+ if { $callerLevel > 0 } {
+ set callerInfo [info level $callerLevel]
+ set procName [lindex $callerInfo 0]
+ set callerNs [namespace qualifiers $procName]
+ }
+
+ #puts "rename: callerNs: $callerNs"
+ #puts "rename: '$oldName' -> '$newName'"
+ #puts "rename: rcds - [join [array names cmdTraceTable] "\nrename: rcds - "]"
+
+ set result [namespace eval $callerNs [concat __rename__ [list $oldName $newName]]]
+
+ set index1 "rename,$oldName"
+ set index2 "rename,::$oldName"
+
+ foreach index [list $index1 $index2] {
+ if [info exists cmdTraceTable($index)] {
+ set cmd $cmdTraceTable($index)
+
+ #puts "rename: '$cmd' { $oldName -> $newName }"
+
+ ::unset cmdTraceTable($index) ;# prevent recursive tracing
+ if {![string equal $newName ""]} {
+ # Create a new trace record under the new name
+ set cmdTraceTable(rename,$newName) $cmd
+ }
+ if [catch {eval $cmd $oldName \"$newName\" rename} err] {
+ error $err
+ }
+ break
+ }
+ }
+
+ return $result
+}
+
+
+#-----------------------------------------------------------------------
+# Private functions
+
+proc ::snit83::private::NamespaceIsDescendantOf { parent child } {
+ set result 0
+
+ foreach ns [__namespace__ children $parent] {
+ if [string match $ns $child] {
+ set result 1
+ break;
+ } else {
+ if [set result [NamespaceIsDescendantOf $ns $child]] {
+ break
+ }
+ }
+ }
+ return $result
+}
+
+
+#-----------------------------------------------------------------------
+# Utility functions
+
+proc ::snit83::traceAddCommand {name ops command} {
+ variable cmdTraceTable
+
+ #puts "::snit83::traceAddCommand n/$name/ o/$ops/ c/$command/"
+ #puts "XX [join [array names cmdTraceTable] "\nXX "]"
+
+ foreach op $ops {
+ set index "$op,$name"
+ #puts "::snit83::traceAddCommand: index = $index cmd = $command"
+
+ set cmdTraceTable($index) $command
+ }
+}
+
+proc ::snit83::traceRemoveCommand {name ops command} {
+ variable cmdTraceTable
+
+ #puts "::snit83::traceRemoveCommand n/$name/ o/$ops/ c/$command/"
+ #puts "YY [join [array names cmdTraceTable] "\nYY "]"
+
+ foreach op $ops {
+ set index "$op,$name"
+ #puts "::snit83::traceRemoveCommand: index = $index cmd = $command"
+
+ catch { ::unset cmdTraceTable($index) }
+ }
+}
+
+# Add support for 'unset -nocomplain'
+proc ::snit83::unset { args } {
+
+ #puts "::snit83::unset - args: '$args'"
+
+ set noComplain 0
+ if {[string equal [lindex $args 0] "-nocomplain"]} {
+ set noComplain 1
+ set args [lrange $args 1 end]
+ }
+ if {[string equal [lindex $args 0] "--"]} {
+ set args [lrange $args 1 end]
+ }
+
+ if [catch {
+ uplevel 1 [linsert $args 0 ::unset]
+ } err] {
+ if { !$noComplain } {
+ error $err
+ }
+ }
+}
--- /dev/null
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin snitfaq n 2.2]
+[copyright {2003-2006, by William H. Duquette}]
+[moddesc {Snit's Not Incr Tcl, OO system}]
+[titledesc {Snit Frequently Asked Questions}]
+[category {Programming tools}]
+[description]
+[para]
+
+[section OVERVIEW]
+
+[subsection {What is this document?}]
+
+This is an atypical FAQ list, in that few of the questions are
+frequently asked. Rather, these are the questions I think a newcomer
+to Snit should be asking. This file is not a complete reference to
+Snit, however; that information is in the [cmd snit] man page.
+
+[subsection {What is Snit?}]
+
+Snit is a framework for defining abstract data types and megawidgets
+in pure Tcl. The name "Snit" stands for "Snit's Not Incr Tcl",
+signifying that Snit takes a different approach to defining objects
+than does Incr Tcl, the best known object framework for Tcl. Had
+I realized that Snit would become at all popular, I'd probably have
+chosen something else.
+
+[para]
+
+The primary purpose of Snit is to be [term "object glue"]--to help you
+compose diverse objects from diverse sources into types and
+megawidgets with clean, convenient interfaces so that you can more
+easily build your application.
+
+[para]
+
+Snit isn't about theoretical purity or minimalist design; it's about
+being able to do powerful things easily and consistently without
+having to think about them--so that you can concentrate on building
+your application.
+
+[para]
+
+Snit isn't about implementing thousands of nearly identical
+carefully-specified lightweight thingamajigs--not as individual Snit
+objects. Traditional Tcl methods will be much faster, and not much
+more complicated. But Snit [emph is] about implementing a clean interface
+to manage a collection of thousands of nearly identical
+carefully-specified lightweight thingamajigs (e.g., think of the text
+widget and text tags, or the canvas widget and canvas objects). Snit
+lets you hide the details of just how those thingamajigs are
+stored--so that you can ignore it, and concentrate on building your
+application.
+
+[para]
+
+Snit isn't a way of life, a silver bullet, or the Fountain of
+Youth. It's just a way of managing complexity--and of managing some of
+the complexity of managing complexity--so that you can concentrate on
+building your application.
+
+[subsection {What version of Tcl does Snit require?}]
+
+Snit 1.3 requires Tcl 8.3 or later; Snit 2.2 requires Tcl 8.5 or
+later. See [sectref {SNIT VERSIONS}] for the differences between Snit
+1.3 and Snit 2.2.
+
+[subsection {Where can I download Snit?}]
+
+Snit is part of Tcllib, the standard Tcl library, so you might already
+have it. It's also available at the Snit Home Page,
+[uri http://www.wjduquette.com/snit].
+
+[subsection {What are Snit's goals?}]
+
+[para]
+
+[list_begin itemized]
+[item]
+
+A Snit object should be at least as efficient as a hand-coded Tcl
+object (see [uri http://www.wjduquette.com/tcl/objects.html]).
+
+[item]
+
+The fact that Snit was used in an object's implementation should be
+transparent (and irrelevant) to clients of that object.
+
+[item]
+
+Snit should be able to encapsulate objects from other sources,
+particularly Tk widgets.
+
+[item]
+
+Snit megawidgets should be (to the extent possible) indistinguishable
+in interface from Tk widgets.
+
+[item]
+
+Snit should be Tclish--that is, rather than trying to emulate C++,
+Smalltalk, or anything else, it should try to emulate Tcl itself.
+
+[item]
+
+It should have a simple, easy-to-use, easy-to-remember syntax.
+
+[list_end]
+
+[subsection {How is Snit different from other OO frameworks?}]
+
+Snit is unique among Tcl object systems in that
+it is based not on inheritance but on delegation. Object
+systems based on inheritance only allow you to inherit from classes
+defined using the same system, and that's a shame. In Tcl, an object
+is anything that acts like an object; it shouldn't matter how the
+object was implemented. I designed Snit to help me build applications
+out of the materials at hand; thus, Snit is designed to be able to
+incorporate and build on any object, whether it's a hand-coded object,
+a Tk widget, an Incr Tcl object, a BWidget or almost anything else.
+
+[para]
+
+Note that you can achieve the effect of inheritance using
+[sectref COMPONENTS] and [sectref "DELEGATION"]--and you can inherit
+from anything that looks like a Tcl object.
+
+[subsection {What can I do with Snit?}]
+
+Using Snit, a programmer can:
+
+[list_begin itemized]
+[item]
+
+Create abstract data types and Tk megawidgets.
+
+[item]
+
+Define instance variables, type variables, and Tk-style options.
+
+[item]
+
+Define constructors, destructors, instance methods, type methods, procs.
+
+[item]
+
+Assemble a type out of component types. Instance methods and options
+can be delegated to the component types automatically.
+
+[list_end]
+
+[section {SNIT VERSIONS}]
+
+[subsection {Which version of Snit should I use?}]
+
+The current Snit distribution includes two versions, Snit 1.3 and Snit
+2.2. The reason that both are included is that Snit 2.2 takes
+advantage of a number of new features of Tcl 8.5 to improve run-time
+efficiency; as a side-effect, the ugliness of Snit's error messages
+and stack traces has been reduced considerably. The cost of using
+Snit 2.2, of course, is that you must target Tcl 8.5.
+
+[para]
+
+Snit 1.3, on the other hand, lacks Snit 2.2's optimizations, but
+requires only Tcl 8.3 and later.
+
+[para]
+
+In short, if you're targetting Tcl 8.3 or 8.4 you should use Snit 1.3. If
+you can afford to target Tcl 8.5, you should definitely use Snit 2.2.
+If you will be targetting both, you can use Snit 1.3 exclusively, or
+(if your code is unaffected by the minor incompatibilities between the
+two versions) you can use Snit 1.3 for Tcl 8.4 and Snit 2.2 for Tcl
+8.5.
+
+[subsection {How do I select the version of Snit I want to use?}]
+
+To always use Snit 1.3 (or a later version of Snit 1.x), invoke Snit
+as follows:
+
+[example {package require snit 1.3
+}]
+
+To always use Snit 2.2 (or a later version of Snit 2.x), say this
+instead:
+
+[example {package require snit 2.2
+}]
+
+Note that if you request Snit 2.2 explicitly, your application will
+halt with Tcl 8.4, since Snit 2.2 is unavailable for Tcl 8.4.
+
+[para]
+
+If you wish your application to always use the latest available
+version of Snit, don't specify a version number:
+
+[example {package require snit
+}]
+
+Tcl will find and load the latest version that's available relative to
+the version of Tcl being used. In this case, be careful to avoid
+using any incompatible features.
+
+[subsection {How are Snit 1.3 and Snit 2.2 incompatible?}]
+
+To the extent possible, Snit 2.2 is intended to be a drop-in
+replacement for Snit 1.3. Unfortunately, some incompatibilities were
+inevitable because Snit 2.2 uses Tcl 8.5's new
+[cmd "namespace ensemble"] mechanism to implement subcommand dispatch.
+This approach is much faster than the mechanism used in Snit 1.3, and
+also results in much better error messages; however, it also places
+new constraints on the implementation.
+
+[para]
+
+There are four specific incompatibilities between Snit 1.3 and Snit 2.2.
+
+[para]
+
+[list_begin itemized]
+[item]
+
+Snit 1.3 supports implicit naming of objects. Suppose you define a
+new [cmd snit::type] called [cmd dog]. You can create instances of
+[cmd dog] in three ways:
+
+[example {dog spot ;# Explicit naming
+set obj1 [dog %AUTO%] ;# Automatic naming
+set obj2 [dog] ;# Implicit naming
+}]
+
+In Snit 2.2, type commands are defined using the [cmd "namespace ensemble"]
+mechanism; and [cmd "namespace ensemble"] doesn't allow an ensemble command
+to be called without a subcommand. In short, using
+[cmd "namespace ensemble"] there's no way to support implicit naming.
+
+[para]
+
+All is not lost, however. If the type has no type methods, then the
+type command is a simple command rather than an ensemble, and
+[cmd "namespace ensemble"] is not used. In this case, implicit naming
+is still possible.
+
+[para]
+
+In short, you can have implicit naming if you're willing to do without
+type methods (including the standard type methods, like
+[cmd "\$type info"]). To do so, use the [const -hastypemethods] pragma:
+
+[example {pragma -hastypemethods 0}]
+
+[item]
+Hierarchical methods and type methods are implemented differently in
+Snit 2.2.
+
+[para]
+
+A hierarchical method is an instance method which has
+subcommands; these subcommands are themselves methods. The Tk text
+widget's [cmd tag] command and its subcommands are examples of
+hierarchical methods. You can implement such subcommands in Snit
+simply by including multiple words in the method names:
+
+[example {method {tag configure} {tag args} { ... }
+
+method {tag cget} {tag option} {...}
+}]
+
+Here we've implicitly defined a [cmd tag] method which has two
+subcommands, [cmd configure] and [cmd cget].
+
+[para]
+
+In Snit 1.3, hierarchical methods could be called in two ways:
+
+[example {$obj tag cget -myoption ;# The good way
+$obj {tag cget} -myoption ;# The weird way
+}]
+
+In the second call, we see that a hierarchical method or type method
+is simply one whose name contains multiple words.
+
+[para]
+
+In Snit 2.2 this is no longer the case, and the "weird" way of calling
+hierarchical methods and type methods no longer works.
+
+[item]
+The third incompatibility derives from the second. In Snit 1.3,
+hierarchical methods were also simply methods whose name contains
+multiple words. As a result, [cmd "\$obj info methods"] returned the
+full names of all hierarchical methods. In the example above,
+the list returned by [cmd "\$obj info methods"] would include
+[cmd "tag configure"] and [cmd "tag cget"] but not [cmd "tag"], since
+[cmd "tag"] is defined only implicitly.
+
+[para]
+
+In Snit 2.2, hierarchical methods and type methods are no longer
+simply ones whose
+name contains multiple words; in the above example, the list returned
+by [cmd "\$obj info methods"] would include [cmd "tag"] but not
+[cmd "tag configure"] or [cmd "tag cget"].
+
+
+[item]
+The fourth incompatibility is due to a new feature. Snit 2.2 uses
+the new [cmd "namespace path"] command so that a type's code can
+call any command defined in the type's parent namespace without
+qualification or importation. For example, suppose you have a
+package called [cmd "mypackage"] which defines a number of commands
+including a type, [cmd "::mypackage::mytype"]. Thanks to
+[cmd "namespace path"], the type's code can call any of the other
+commands defined in [cmd "::mypackage::"].
+
+[para]
+
+This is extremely convenient. However, it also means that commands
+defined in the parent namespace, [cmd "::mypackage::"] can block the
+type's access to identically named commands in the global namespace.
+This can lead to bugs. For example, Tcllib includes a type called
+[cmd "::tie::std::file"]. This type's code calls the standard
+[cmd "file"] command. When run with Snit 2.2, the code broke--
+the type's command, [cmd "::tie::std::file"], is itself a command
+in the type's parent namespace, and so instead of calling
+the standard [cmd "file"] command, the type found itself calling
+itself.
+
+[list_end]
+
+[subsection {Are there other differences between Snit 1.x and Snit 2.2?}]
+
+Yes.
+
+[list_begin itemized]
+[item]
+Method dispatch is considerably faster.
+
+[item]
+Many error messages and stack traces are cleaner.
+
+[item]
+The [const -simpledispatch] pragma is obsolete, and ignored if
+present. In Snit 1.x, [const -simpledispatch] substitutes a faster
+mechanism for method dispatch, at the cost of losing certain features.
+Snit 2.2 method dispatch is faster still in all cases, so
+[const -simpledispatch] is no longer needed.
+
+[item]
+
+In Snit 2.2, a type's code (methods, type methods, etc.) can call commands
+from the type's parent namespace without qualifying or importing
+them, i.e., type [cmd ::parentns::mytype]'s code can call
+[cmd ::parentns::someproc] as just [cmd someproc].
+
+[para]
+
+This is extremely useful when a type is defined as part of a larger
+package, and shares a parent namespace with the rest of the package;
+it means that the type can call other commands defined by the
+package without any extra work.
+
+[para]
+
+This feature depends on the new Tcl 8.5 [cmd "namespace path"] command,
+which is why it hasn't been implemented for V1.x. V1.x code can
+achieve something similar by placing
+
+[example {namespace import [namespace parent]::*}]
+
+in a type constructor. This is less useful, however, as it picks up
+only those commands which have already been exported by the parent
+namespace at the time the type is defined.
+
+[list_end]
+
+
+[section OBJECTS]
+
+[subsection {What is an object?}]
+
+A full description of object-oriented programming is beyond
+the scope of this FAQ, obviously. In simple terms, an object is an instance of
+an abstract data type--a coherent bundle of code and data.
+There are many ways to represent objects in Tcl/Tk; the best known
+examples are the Tk widgets.
+
+[para]
+
+A Tk widget is an object; it is represented by a Tcl command.
+The object's methods are subcommands of the Tcl command. The object's
+properties are options accessed using the [method configure] and
+[method cget] methods. Snit uses the same conventions as Tk widgets do.
+
+[subsection {What is an abstract data type?}]
+
+In computer science terms, an abstract data type is a complex data
+structure along with a set of operations--a stack, a queue, a
+binary tree, etc--that is to say, in modern terms, an object. In systems
+that include some form of inheritance the word [term class] is
+usually used instead of [term {abstract data type}], but as Snit
+doesn't implement inheritance as it's ordinarily understood
+the older term seems more appropriate. Sometimes this is called
+[term {object-based}] programming as opposed to object-oriented
+programming. Note that you can easily create the effect of
+inheritance using [sectref COMPONENTS] and [sectref "DELEGATION"].
+
+[para]
+
+In Snit, as in Tk, a [term type] is a command that creates instances
+-- objects -- which belong to the type. Most types define some number
+of [term options] which can be set at creation time, and usually can be
+changed later.
+
+[para]
+
+Further, an [term instance] is also a Tcl command--a command that
+gives access to the operations which are defined for that abstract
+data type. Conventionally, the operations are defined as subcommands
+of the instance command. For example, to insert
+text into a Tk text widget, you use the text widget's [method insert]
+subcommand:
+
+[para]
+[example { # Create a text widget and insert some text in it.
+ text .mytext -width 80 -height 24
+ .mytext insert end "Howdy!"
+}]
+[para]
+
+In this example, [cmd text] is the [term type] command and
+[cmd .mytext] is the [term instance] command.
+
+[para]
+
+In Snit, object subcommands are generally called
+[sectref "INSTANCE METHODS"].
+
+[subsection {What kinds of abstract data types does Snit provide?}]
+
+Snit allows you to define three kinds of abstract data type:
+
+[para]
+
+[list_begin itemized]
+[item]
+
+[cmd snit::type]
+[item]
+
+[cmd snit::widget]
+[item]
+
+[cmd snit::widgetadaptor]
+[list_end]
+
+
+[subsection {What is a snit::type?}]
+
+A [cmd snit::type] is a non-GUI abstract data type, e.g., a stack or a
+queue. [cmd snit::type]s are defined using the [cmd snit::type]
+command. For example, if you were designing a kennel management
+system for a dog breeder, you'd need a dog type.
+
+[para]
+[example {% snit::type dog {
+ # ...
+}
+::dog
+%
+}]
+[para]
+
+This definition defines a new command ([cmd ::dog], in this case)
+that can be used to define dog objects.
+
+[para]
+
+An instance of a [cmd snit::type] can have [sectref {INSTANCE METHODS}],
+[sectref {INSTANCE VARIABLES}], [sectref OPTIONS], and [sectref COMPONENTS].
+The type itself can have [sectref {TYPE METHODS}],
+[sectref {TYPE VARIABLES}], [sectref {TYPE COMPONENTS}], and
+[sectref PROCS].
+
+
+[subsection {What is a snit::widget?, the short story}]
+
+A [cmd snit::widget] is a Tk megawidget built using Snit; it is very
+similar to a [cmd snit::type]. See [sectref WIDGETS].
+
+
+[subsection {What is a snit::widgetadaptor?, the short story}]
+
+A [cmd snit::widgetadaptor] uses Snit to wrap an existing widget type
+(e.g., a Tk label), modifying its interface to a lesser or greater
+extent. It is very similar to a [cmd snit::widget].
+See [sectref {WIDGET ADAPTORS}].
+
+
+[subsection {How do I create an instance of a snit::type?}]
+
+You create an instance of a [cmd snit::type] by passing the new
+instance's name to the type's create method. In the following
+example, we create a [cmd dog] object called [cmd spot].
+
+[para]
+[example {% snit::type dog {
+ # ....
+}
+::dog
+% dog create spot
+::spot
+%
+}]
+[para]
+
+In general, the [method create] method name can be omitted so long as
+the instance name doesn't conflict with any defined
+[sectref {TYPE METHODS}]. (See [sectref {TYPE COMPONENTS}] for the
+special case in which this doesn't work.)
+So the following example is identical to the
+previous example:
+
+[para]
+[example {% snit::type dog {
+ # ....
+}
+::dog
+% dog spot
+::spot
+%
+}]
+[para]
+
+This document generally uses the shorter form.
+
+[para]
+
+If the [cmd dog] type defines [sectref OPTIONS], these can usually be
+given defaults at creation time:
+
+[para]
+[example {% snit::type dog {
+ option -breed mongrel
+ option -color brown
+
+ method bark {} { return "$self barks." }
+}
+::dog
+% dog create spot -breed dalmation -color spotted
+::spot
+% spot cget -breed
+dalmation
+% spot cget -color
+spotted
+%
+}]
+[para]
+
+Once created, the instance name now names a new Tcl command that is used
+to manipulate the object. For example, the following code makes the
+dog bark:
+
+[para]
+[example {% spot bark
+::spot barks.
+%
+}]
+[para]
+
+[subsection {How do I refer to an object indirectly?}]
+
+Some programmers prefer to save the object name in a variable, and
+reference it that way. For example,
+
+[para]
+[example {% snit::type dog { ... }
+::dog
+% set d [dog spot -breed dalmation -color spotted]
+::spot
+% $d cget -breed
+dalmation
+% $d bark
+::spot barks.
+%
+}]
+[para]
+
+If you prefer this style, you might prefer to have Snit
+generate the instance's name automatically.
+
+[subsection {How can I generate the object name automatically?}]
+
+If you'd like Snit to generate an object name for you,
+use the [const %AUTO%] keyword as the requested name:
+
+[para]
+[example {% snit::type dog { ... }
+::dog
+% set d [dog %AUTO%]
+::dog2
+% $d bark
+::dog2 barks.
+%
+}]
+[para]
+
+The [const %AUTO%] keyword can be embedded in a longer string:
+
+[para]
+[example {% set d [dog obj_%AUTO%]
+::obj_dog4
+% $d bark
+::obj_dog4 barks.
+%
+}]
+[para]
+
+
+[subsection {Can types be renamed?}]
+
+Tcl's [cmd rename] command renames other commands. It's a common
+technique in Tcl to modify an existing command by renaming it and
+defining a new command with the original name; the new command usually
+calls the renamed command.
+
+[para]
+
+[cmd snit::type] commands, however, should never be renamed; to do so breaks
+the connection between the type and its objects.
+
+[subsection {Can objects be renamed?}]
+
+Tcl's [cmd rename] command renames other commands. It's a common
+technique in Tcl to modify an existing command by renaming it and
+defining a new command with the original name; the new command usually
+calls the renamed command.
+
+[para]
+
+All Snit objects (including [term widgets] and [term widgetadaptors])
+can be renamed, though this flexibility has some consequences:
+
+[para]
+
+[list_begin itemized]
+[item]
+
+In an instance method, the implicit argument [var self] will always
+contain the object's current name, so instance methods can always call
+other instance methods using [var \$self].
+
+[item]
+
+If the object is renamed, however, then [var \$self]'s value will change.
+Therefore, don't use [var \$self] for anything that will break if
+[var \$self] changes. For example, don't pass a callback command to
+another object like this:
+
+[example {
+ .btn configure -command [list $self ButtonPress]
+}]
+
+You'll get an error if [cmd .btn] calls your command after your object is
+renamed.
+
+[item]
+
+Instead, your object should define its callback command like this:
+
+[example {
+ .btn configure -command [mymethod ButtonPress]
+}]
+
+The [cmd mymethod] command returns code that will call the desired
+method safely; the caller of the callback can add additional
+arguments to the end of the command as usual.
+
+[item]
+
+Every object has a private namespace; the name of this namespace is
+available in method bodies, etc., as the value of the implicit
+argument [var selfns]. This value is constant for the life of the
+object. Use [var \$selfns] instead of [var \$self] if you need a
+unique token to identify the object.
+
+[item]
+
+When a [cmd snit::widget]'s instance command is renamed, its Tk window
+name remains the same -- and is still extremely
+important. Consequently, the Tk window name is available in
+method bodies as the value of the implicit argument [var win].
+This value is constant for the
+life of the object. When creating child windows, it's best to use
+[var {$win.child}] rather than [var {$self.child}] as the name of the
+child window.
+
+[list_end]
+
+[subsection {How do I destroy a Snit object?}]
+
+Any Snit object of any type can be destroyed by renaming
+it to the empty string using the Tcl [cmd rename] command.
+
+[para]
+
+Snit megawidgets (i.e., instances of [cmd snit::widget] and
+[cmd snit::widgetadaptor]) can be destroyed like any other widget: by
+using the Tk [cmd destroy] command on the widget or on one of its
+ancestors in the window hierarchy.
+
+[para]
+
+Every instance of a [cmd snit::type] has a [method destroy] method:
+
+[para]
+[example {% snit::type dog { ... }
+::dog
+% dog spot
+::spot
+% spot bark
+::spot barks.
+% spot destroy
+% spot barks
+invalid command name "spot"
+%
+}]
+[para]
+
+Finally, every Snit type has a type method called [method destroy]; calling it
+destroys the type and all of its instances:
+
+[example {% snit::type dog { ... }
+::dog
+% dog spot
+::spot
+% spot bark
+::spot barks.
+% dog destroy
+% spot bark
+invalid command name "spot"
+% dog fido
+invalid command name "dog"
+%
+}]
+
+[section {INSTANCE METHODS}]
+
+[subsection {What is an instance method?}]
+
+An instance method is a procedure associated with a specific object
+and called as a subcommand of the object's command. It is given free
+access to all of the object's type variables, instance variables, and
+so forth.
+
+[subsection {How do I define an instance method?}]
+
+Instance methods are defined in the type definition using
+the [cmd method] statement. Consider the following code that might be
+used to add dogs to a computer simulation:
+
+[para]
+[example {% snit::type dog {
+ method bark {} {
+ return "$self barks."
+ }
+
+ method chase {thing} {
+ return "$self chases $thing."
+ }
+}
+::dog
+%
+}]
+[para]
+
+A dog can bark, and it can chase things.
+
+[para]
+
+The [cmd method] statement looks just like a normal Tcl [cmd proc],
+except that it appears in a [cmd snit::type] definition. Notice that
+every instance method gets an implicit argument called [var self];
+this argument contains the object's name. (There's more on
+implicit method arguments below.)
+
+[subsection {How does a client call an instance method?}]
+
+The method name becomes a subcommand of the object. For example,
+let's put a simulated dog through its paces:
+
+[para]
+[example {% dog spot
+::spot
+% spot bark
+::spot barks.
+% spot chase cat
+::spot chases cat.
+%
+}]
+[para]
+
+[subsection {How does an instance method call another instance method?}]
+
+If method A needs to call method B on the same object, it does so just
+as a client does: it calls method B as a subcommand of the object
+itself, using the object name stored in the implicit argument [var self].
+
+[para]
+
+Suppose, for example, that our dogs never chase anything without
+barking at them:
+
+[para]
+[example {% snit::type dog {
+ method bark {} {
+ return "$self barks."
+ }
+
+ method chase {thing} {
+ return "$self chases $thing. [$self bark]"
+ }
+}
+::dog
+% dog spot
+::spot
+% spot bark
+::spot barks.
+% spot chase cat
+::spot chases cat. ::spot barks.
+%
+}]
+[para]
+
+[subsection {Are there any limitations on instance method names?}]
+
+Not really, so long as you avoid the standard instance method names:
+[method configure], [method configurelist], [method cget],
+[method destroy], and [method info]. Also, method names consisting of
+multiple words define hierarchical methods.
+
+[subsection {What is a hierarchical method?}]
+
+An object's methods are subcommands of the object's instance command.
+Hierarchical methods allow an object's methods to have subcommands of
+their own; and these can in turn have subcommands, and so on. This
+allows the programmer to define a tree-shaped command structure, such
+as is used by many of the Tk widgets--the subcommands of the
+Tk [cmd text] widget's [cmd tag] method are hierarchical methods.
+
+[subsection {How do I define a hierarchical method?}]
+
+Define methods whose names consist of multiple words. These words
+define the hierarchy implicitly. For example, the following code
+defines a [cmd tag] method with subcommands [cmd cget] and
+[cmd configure]:
+
+[example {snit::widget mytext {
+ method {tag configure} {tag args} { ... }
+
+ method {tag cget} {tag option} {...}
+}
+}]
+
+Note that there is no explicit definition for the [cmd tag] method;
+it is implicit in the definition of [cmd "tag configure"] and
+[cmd "tag cget"]. If you tried to define [cmd tag] explicitly in this
+example, you'd get an error.
+
+[subsection {How do I call hierarchical methods?}]
+
+As subcommands of subcommands.
+
+[example {% mytext .text
+.text
+% .text tag configure redtext -foreground red -background black
+% .text tag cget redtext -foreground
+red
+%
+}]
+
+[subsection {How do I make an instance method private?}]
+
+It's often useful to define private methods, that is, instance methods
+intended to be called only by other methods of the same object.
+
+[para]
+
+Snit doesn't implement any access control on instance methods, so all
+methods are [emph {de facto}] public. Conventionally, though, the
+names of public methods begin with a lower-case letter, and the names
+of private methods begin with an upper-case letter.
+
+[para]
+
+For example, suppose our simulated dogs only bark in response to other
+stimuli; they never bark just for fun. So the [method bark] method
+becomes [method Bark] to indicate that it is private:
+
+[para]
+[example {% snit::type dog {
+ # Private by convention: begins with uppercase letter.
+ method Bark {} {
+ return "$self barks."
+ }
+
+ method chase {thing} {
+ return "$self chases $thing. [$self Bark]"
+ }
+}
+::dog
+% dog fido
+::fido
+% fido chase cat
+::fido chases cat. ::fido barks.
+%
+}]
+[para]
+
+[subsection {Are there any limitations on instance method arguments?}]
+
+Method argument lists are defined just like normal Tcl [cmd proc] argument
+lists; in particular, they can include arguments with default values
+ and the [var args] argument.
+
+[para]
+
+However, every method also has a number of implicit arguments
+provided by Snit in addition to those explicitly defined. The names
+of these implicit arguments may not used to name explicit arguments.
+
+[subsection {What implicit arguments are passed to each instance method?}]
+
+The arguments implicitly passed to every method are [var type],
+[var selfns], [var win], and [var self].
+
+[subsection {What is $type?}]
+
+The implicit argument [var type] contains the fully qualified name of
+the object's type:
+
+[para]
+[example {% snit::type thing {
+ method mytype {} {
+ return $type
+ }
+}
+::thing
+% thing something
+::something
+% something mytype
+::thing
+%
+}]
+[para]
+
+[subsection {What is $self?}]
+
+The implicit argument [var self] contains the object's fully
+qualified name.
+
+[para]
+
+If the object's command is renamed, then [var \$self] will change to
+match in subsequent calls. Thus, your code should not assume that
+[var \$self] is constant unless you know for sure that the object
+will never be renamed.
+
+[para]
+[example {% snit::type thing {
+ method myself {} {
+ return $self
+ }
+}
+::thing
+% thing mutt
+::mutt
+% mutt myself
+::mutt
+% rename mutt jeff
+% jeff myself
+::jeff
+%
+}]
+[para]
+
+[subsection {What is $selfns?}]
+
+Each Snit object has a private namespace in which to store its
+[sectref {INSTANCE VARIABLES}] and [sectref OPTIONS]. The implicit argument
+[var selfns] contains the name of this namespace; its value never changes, and
+is constant for the life of the object, even if the object's name
+changes:
+
+[para]
+[example {% snit::type thing {
+ method myNameSpace {} {
+ return $selfns
+ }
+}
+::thing
+% thing jeff
+::jeff
+% jeff myNameSpace
+::thing::Snit_inst3
+% rename jeff mutt
+% mutt myNameSpace
+::thing::Snit_inst3
+%
+}]
+[para]
+
+The above example reveals how Snit names an instance's private
+namespace; however, you should not write code that depends on the
+specific naming convention, as it might change in future releases.
+
+[subsection {What is $win?}]
+
+The implicit argument [var win] is defined for all Snit methods,
+though it really makes sense only for those of
+[sectref WIDGETS] and [sectref {WIDGET ADAPTORS}]. [var \$win] is simply
+the original name of the object, whether it's been renamed or not.
+For widgets and widgetadaptors, it is also therefore the name of a Tk
+window.
+
+[para]
+
+When a [cmd snit::widgetadaptor] is used to modify the interface of a
+widget or megawidget, it must rename the widget's original command and
+replace it with its own.
+
+[para]
+
+Thus, using [var win] whenever the Tk window name is called for
+means that a [cmd snit::widget] or [cmd snit::widgetadaptor] can be
+adapted by a [cmd snit::widgetadaptor]. See [sectref WIDGETS] for
+more information.
+
+[subsection {How do I pass an instance method as a callback?}]
+
+It depends on the context.
+
+[para]
+
+Suppose in my application I have a [cmd dog] object named [cmd fido],
+and I want [cmd fido] to bark when a Tk button called [cmd .bark] is
+pressed. In this case, I create the callback command in the usual
+way, using [cmd list]:
+
+[para]
+[example { button .bark -text "Bark!" -command [list fido bark]
+}]
+[para]
+
+In typical Tcl style, we use a callback to hook two independent
+components together. But suppose that the [cmd dog] object has
+a graphical interface and owns the button itself? In this case,
+the [cmd dog] must pass one of its own instance methods to the
+button it owns. The obvious thing to do is this:
+
+[para]
+[example {% snit::widget dog {
+ constructor {args} {
+ #...
+ button $win.barkbtn -text "Bark!" -command [list $self bark]
+ #...
+ }
+}
+::dog
+%
+}]
+[para]
+
+(Note that in this example, our [cmd dog]
+becomes a [cmd snit::widget], because it has GUI behavior. See
+[sectref WIDGETS] for more.) Thus, if we create a [cmd dog] called
+[cmd .spot], it will create a Tk button called [cmd .spot.barkbtn];
+when pressed, the button will call [cmd {$self bark}].
+
+[para]
+
+Now, this will work--provided that [cmd .spot] is never renamed to
+something else. But surely renaming widgets is
+abnormal? And so it is--unless [cmd .spot] is the hull component of a
+[cmd snit::widgetadaptor]. If it is, then it will be renamed, and
+[cmd .spot] will become the name of the [cmd snit::widgetadaptor]
+object. When the button is pressed, the command [cmd {$self bark}]
+will be handled by the [cmd snit::widgetadaptor], which might or might
+not do the right thing.
+
+[para]
+
+There's a safer way to do it, and it looks like this:
+
+[para]
+[example {% snit::widget dog {
+ constructor {args} {
+ #...
+ button $win.barkbtn -text "Bark!" -command [mymethod bark]
+ #...
+ }
+}
+::dog
+%
+}]
+[para]
+
+The command [cmd mymethod] takes any number of arguments, and can be
+used like [cmd list] to build up a callback command; the only
+difference is that [cmd mymethod] returns a
+form of the command that won't change even if the instance's name
+changes.
+
+[para]
+
+On the other hand, you might prefer to allow a widgetadaptor to
+override a method such that your renamed widget will call the
+widgetadaptor's method instead of its own. In this case,
+using [cmd "\[list \$self bark\]"] will do what you want...but
+this is a technique which should be used only in carefully controlled
+circumstances.
+
+[subsection {How do I delegate instance methods to a component?}]
+
+See [sectref DELEGATION].
+
+[section {INSTANCE VARIABLES}]
+
+
+[subsection {What is an instance variable?}]
+
+An instance variable is a private variable associated with some
+particular Snit object. Instance variables can be scalars or arrays.
+
+
+[subsection {How is a scalar instance variable defined?}]
+
+Scalar instance variables are defined in the type definition using the
+[cmd variable] statement. You can simply name it, or you can
+initialize it with a value:
+
+[para]
+[example {snit::type mytype {
+ # Define variable "greeting" and initialize it with "Howdy!"
+ variable greeting "Howdy!"
+}
+}]
+[para]
+
+[subsection {How is an array instance variable defined?}]
+
+Array instance variables are also defined in the type definition
+using the [cmd variable] command. You can initialize them at the same
+time by specifying the [const -array] option:
+
+[para]
+[example {snit::type mytype {
+ # Define array variable "greetings"
+ variable greetings -array {
+ formal "Good Evening"
+ casual "Howdy!"
+ }
+}
+}]
+[para]
+
+[subsection {What happens if I don't initialize an instance variable?}]
+
+Variables do not really exist until they are given values. If you
+do not initialize a variable when you define it, then you must be
+sure to assign a value to it (in the constructor, say, or in some
+method) before you reference it.
+
+[subsection {Are there any limitations on instance variable names?}]
+
+Just a few.
+
+[para]
+
+First, every Snit object has a built-in instance variable called
+[var options], which should never be redefined.
+
+[para]
+
+Second, all names beginning with "Snit_" are reserved for
+use by Snit internal code.
+
+[para]
+
+Third, instance variable names containing the namespace delimiter
+([const ::]) are likely to cause great confusion.
+
+
+[subsection {Do I need to declare my instance variables in my methods?}]
+
+No. Once you've defined an instance variable in the type definition,
+it can be used in any instance code (instance methods, the
+constructor, and the destructor) without declaration. This differs
+from normal Tcl practice, in which all non-local variables in a proc
+need to be declared.
+
+[para]
+
+There is a speed penalty to having all instance variables implicitly
+available in all instance code. Even though your code need not
+declare the variables explicitly, Snit must still declare them,
+and that takes time. If you have ten instance variables, a method
+that uses none of them must still pay the declaration penalty for
+all ten. In most cases, the additional runtime cost is negligible.
+If extreme cases, you might wish to avoid it; there are two methods
+for doing so.
+
+[para]
+
+The first is to define a single instance variable, an array, and store
+all of your instance data in the array. This way, you're only paying
+the declaration penalty for one variable--and you probably need the
+variable most of the time anyway. This method breaks down if your
+instance variables include multiple arrays; in Tcl 8.5, however,
+the [cmd dict] command might come to your rescue.
+
+[para]
+
+The second method is to declare your instance variables explicitly
+in your instance code, while [emph not] including them in the type
+definition:
+
+[example {snit::type dog {
+ constructor {} {
+ variable mood
+
+ set mood happy
+ }
+
+ method setmood {newMood} {
+ variable mood
+
+ set mood $newMood
+ }
+
+ method getmood {} {
+ variable mood
+
+ return $mood
+ }
+}
+}]
+
+This allows you to ensure that only the required variables are
+included in each method, at the cost of longer code and run-time
+errors when you forget to declare a variable you need.
+
+[subsection {How do I pass an instance variable's name to another object?}]
+
+In Tk, it's common to pass a widget a variable name; for example, Tk
+label widgets have a [option -textvariable] option which names the
+variable which will contain the widget's text. This allows the
+program to update the label's value just by assigning a new value to
+the variable.
+
+[para]
+
+If you naively pass the instance variable name to the label widget,
+you'll be confused by the result; Tk will assume that the name names a
+global variable. Instead, you need to provide a fully-qualified
+variable name. From within an instance method or a constructor, you
+can fully qualify the variable's name using the [cmd myvar] command:
+
+[para]
+[example {snit::widget mywidget {
+ variable labeltext ""
+
+ constructor {args} {
+ # ...
+
+ label $win.label -textvariable [myvar labeltext]
+
+ # ...
+ }
+}
+}]
+[para]
+
+[subsection {How do I make an instance variable public?}]
+
+Practically speaking, you don't. Instead, you'll implement public
+variables as [sectref OPTIONS].
+
+Alternatively, you can write [sectref {INSTANCE METHODS}] to set and get
+the variable's value.
+
+[section OPTIONS]
+
+[subsection {What is an option?}]
+
+A type's options are the equivalent of what other object-oriented
+languages would call public member variables or properties: they are
+data values which can be retrieved and (usually) set by the clients of
+an object.
+
+[para]
+
+Snit's implementation of options follows the Tk model fairly exactly,
+except that [cmd snit::type] objects usually don't interact with
+[sectref "THE TK OPTION DATABASE"]; [cmd snit::widget] and
+[cmd snit::widgetadaptor] objects, on the other hand, always do.
+
+[subsection {How do I define an option?}]
+
+Options are defined in the type definition using the [cmd option]
+statement. Consider the following type, to be used in an application
+that manages a list of dogs for a pet store:
+
+[para]
+[example {snit::type dog {
+ option -breed -default mongrel
+ option -color -default brown
+ option -akc -default 0
+ option -shots -default 0
+}
+}]
+[para]
+
+
+According to this, a dog has four notable properties: a
+breed, a color, a flag that says whether it's pedigreed with the
+American Kennel Club, and another flag that says whether it has had
+its shots. The default dog, evidently, is a brown mutt.
+
+[para]
+
+There are a number of options you can specify when defining an option;
+if [const -default] is the only one, you can omit the word
+[const -default] as follows:
+
+[para]
+[example {snit::type dog {
+ option -breed mongrel
+ option -color brown
+ option -akc 0
+ option -shots 0
+}
+}]
+
+[para]
+
+If no [const -default] value is specified, the option's default value
+will be the empty string (but see [sectref {THE TK OPTION DATABASE}]).
+
+[para]
+
+The Snit man page refers to options like these as "locally defined" options.
+
+[subsection {How can a client set options at object creation?}]
+
+The normal convention is that the client may pass any number of
+options and their values after the object's name at object creation.
+For example, the [cmd ::dog] command defined in the previous answer can now
+be used to create individual dogs. Any or all of the options may be
+set at creation time.
+
+[para]
+[example {% dog spot -breed beagle -color "mottled" -akc 1 -shots 1
+::spot
+% dog fido -shots 1
+::fido
+%
+}]
+[para]
+
+So [cmd ::spot] is a pedigreed beagle; [cmd ::fido] is a typical mutt,
+but his owners evidently take care of him, because he's had his shots.
+
+[para]
+
+[emph Note:] If the type defines a constructor, it can specify a
+different object-creation syntax. See [sectref CONSTRUCTORS] for more
+information.
+
+[subsection {How can a client retrieve an option's value?}]
+
+Retrieve option values using the [method cget] method:
+
+[para]
+[example {% spot cget -color
+mottled
+% fido cget -breed
+mongrel
+%
+}]
+[para]
+
+[subsection {How can a client set options after object creation?}]
+
+Any number of options may be set at one time using the
+[method configure] instance method. Suppose that closer inspection
+shows that ::fido is not a brown mongrel, but rather a rare Arctic Boar
+Hound of a lovely dun color:
+
+[para]
+[example {% fido configure -color dun -breed "Arctic Boar Hound"
+% fido cget -color
+dun
+% fido cget -breed
+Arctic Boar Hound
+}]
+[para]
+
+Alternatively, the [method configurelist] method takes a list of
+options and values; occasionally this is more convenient:
+
+[para]
+[example {% set features [list -color dun -breed "Arctic Boar Hound"]
+-color dun -breed {Arctic Boar Hound}
+% fido configurelist $features
+% fido cget -color
+dun
+% fido cget -breed
+Arctic Boar Hound
+%
+}]
+[para]
+
+In Tcl 8.5, the [cmd {*}] keyword can be used with
+[method configure] in this case:
+
+[para]
+[example {% set features [list -color dun -breed "Arctic Boar Hound"]
+-color dun -breed {Arctic Boar Hound}
+% fido configure {*}$features
+% fido cget -color
+dun
+% fido cget -breed
+Arctic Boar Hound
+%
+}]
+[para]
+
+The results are the same.
+
+[subsection {How should an instance method access an option value?}]
+
+There are two ways an instance method can set and retrieve an option's
+value. One is to use the [method configure] and [method cget]
+methods, as shown below.
+
+[para]
+[example {% snit::type dog {
+ option -weight 10
+
+ method gainWeight {} {
+ set wt [$self cget -weight]
+ incr wt
+ $self configure -weight $wt
+ }
+}
+::dog
+% dog fido
+::fido
+% fido cget -weight
+10
+% fido gainWeight
+% fido cget -weight
+11
+%
+}]
+[para]
+
+Alternatively, Snit provides a built-in array instance variable called
+[var options]. The indices are the option names; the values are the
+option values. The method [method gainWeight] can thus be rewritten as
+follows:
+
+[para]
+[example {
+ method gainWeight {} {
+ incr options(-weight)
+ }
+}]
+[para]
+
+As you can see, using the [var options] variable involves considerably
+less typing and is the usual way to do it. But if you use
+[const -configuremethod] or [const -cgetmethod] (described in the following
+answers), you might wish to use the [method configure] and
+[method cget] methods anyway, just so that any special processing you've
+implemented is sure to get done. Also, if the option is delegated to
+a component then [method configure] and [method cget] are the only way
+to access it without accessing the component directly. See
+[sectref "DELEGATION"] for more information.
+
+[subsection {How can I make an option read-only?}]
+
+Define the option with [const "-readonly yes"].
+
+[para]
+
+Suppose you've got an option that determines how
+instances of your type are constructed; it must be set at creation
+time, after which it's constant. For example, a dog never changes its
+breed; it might or might not have had its shots, and if not can have
+them at a later time. [const -breed] should be read-only, but
+[const -shots] should not be.
+
+[para]
+[example {% snit::type dog {
+ option -breed -default mongrel -readonly yes
+ option -shots -default no
+}
+::dog
+% dog fido -breed retriever
+::fido
+% fido configure -shots yes
+% fido configure -breed terrier
+option -breed can only be set at instance creation
+%
+}]
+[para]
+
+[subsection {How can I catch accesses to an option's value?}]
+
+Define a [const -cgetmethod] for the option.
+
+[subsection {What is a -cgetmethod?}]
+
+A [const -cgetmethod] is a method that's called whenever the related
+option's value is queried via the
+[method cget] instance method. The handler can compute the option's
+value, retrieve it from a database, or do anything else you'd like it to do.
+
+[para]
+
+Here's what the default behavior would look like if
+written using a [const -cgetmethod]:
+
+[para]
+[example {snit::type dog {
+ option -color -default brown -cgetmethod GetOption
+
+ method GetOption {option} {
+ return $options($option)
+ }
+}
+}]
+[para]
+
+Any instance method can be used, provided that it takes one argument,
+the name of the option whose value is to be retrieved.
+
+[subsection {How can I catch changes to an option's value?}]
+
+Define a [const -configuremethod] for the option.
+
+[subsection {What is a -configuremethod?}]
+
+A [const -configuremethod] is a method that's called whenever the
+related option is given a new value via the [method configure] or
+[method configurelist] instance methods. The method can
+pass the value on to some other object, store it in a database, or do
+anything else you'd like it to do.
+
+[para]
+
+Here's what the default configuration behavior would look like if
+written using a [const -configuremethod]:
+
+[para]
+[example {snit::type dog {
+ option -color -default brown -configuremethod SetOption
+
+ method SetOption {option value} {
+ set options($option) $value
+ }
+}
+}]
+[para]
+
+Any instance method can be used, provided that it takes two arguments,
+the name of the option and the new value.
+
+[para]
+
+Note that if your method doesn't store the value in the [var options]
+array, the [var options] array won't get updated.
+
+[subsection {How can I validate an option's value?}]
+
+Define a [const -validatemethod].
+
+[subsection {What is a -validatemethod?}]
+
+A [const -validatemethod] is a method that's called whenever the
+related option is given a new value via the [method configure] or
+[method configurelist] instance methods. It's the method's
+responsibility to determine whether the new value is valid, and throw
+an error if it isn't. The [const -validatemethod], if any, is called
+before the value is stored in the [var options] array; in particular,
+it's called before the [const -configuremethod], if any.
+
+[para]
+
+For example, suppose an option always takes a Boolean value. You can
+ensure that the value is in fact a valid Boolean like this:
+
+[example {% snit::type dog {
+ option -shots -default no -validatemethod BooleanOption
+
+ method BooleanOption {option value} {
+ if {![string is boolean -strict $value]} {
+ error "expected a boolean value, got \"$value\""
+ }
+ }
+}
+::dog
+% dog fido
+% fido configure -shots yes
+% fido configure -shots NotABooleanValue
+expected a boolean value, got "NotABooleanValue"
+%
+}]
+
+Note that the same [const -validatemethod] can be used to validate any number
+of boolean options.
+
+[para]
+
+Any method can be a [const -validatemethod] provided that it takes
+two arguments, the option name and the new option value.
+
+
+[section {TYPE VARIABLES}]
+
+[subsection {What is a type variable?}]
+
+A type variable is a private variable associated with a Snit type
+rather than with a particular instance of the type. In C++ and Java,
+the term [term "static member variable"] is used for the same notion.
+Type variables can be scalars or arrays.
+
+
+[subsection {How is a scalar type variable defined?}]
+
+Scalar type variables are defined in the type definition using the
+[cmd typevariable] statement. You can simply name it, or you can
+initialize it with a value:
+
+[para]
+[example {
+snit::type mytype {
+ # Define variable "greeting" and initialize it with "Howdy!"
+ typevariable greeting "Howdy!"
+}
+}]
+[para]
+
+Every object of type [cmd mytype] now has access to a single variable
+called [var greeting].
+
+[subsection {How is an array-valued type variable defined?}]
+
+Array-valued type variables are also defined using the
+[cmd typevariable] command; to initialize them, include the
+[const -array] option:
+
+[para]
+[example {snit::type mytype {
+ # Define typearray variable "greetings"
+ typevariable greetings -array {
+ formal "Good Evening"
+ casual "Howdy!"
+ }
+}
+}]
+[para]
+
+[subsection {What happens if I don't initialize a type variable?}]
+
+Variables do not really exist until they are given values. If you
+do not initialize a variable when you define it, then you must be
+sure to assign a value to it (in the type constructor, say)
+before you reference it.
+
+[subsection {Are there any limitations on type variable names?}]
+
+Type variable names have the same restrictions as
+the names of [sectref {INSTANCE VARIABLES}] do.
+
+[subsection {Do I need to declare my type variables in my methods?}]
+
+No. Once you've defined a type variable in the type definition, it can
+be used in [sectref {INSTANCE METHODS}] or [sectref {TYPE METHODS}] without
+declaration. This differs from normal Tcl practice, in which all
+non-local variables in a proc need to be declared.
+
+[para]
+
+Type variables are subject to the same speed/readability tradeoffs
+as instance variables; see
+[sectref {Do I need to declare my instance variables in my methods?}]
+
+[subsection {How do I pass a type variable's name to another object?}]
+
+In Tk, it's common to pass a widget a variable name; for example, Tk
+label widgets have a [option -textvariable] option which names the
+variable which will contain the widget's text. This allows the
+program to update the label's value just by assigning a new value to
+the variable.
+
+[para]
+
+If you naively pass a type variable name to the label widget, you'll
+be confused by the result; Tk will assume that the name names a global
+variable. Instead, you need to provide a fully-qualified variable
+name. From within an instance method or a constructor, you can fully
+qualify the type variable's name using the [cmd mytypevar] command:
+
+[para]
+[example {snit::widget mywidget {
+ typevariable labeltext ""
+
+ constructor {args} {
+ # ...
+
+ label $win.label -textvariable [mytypevar labeltext]
+
+ # ...
+ }
+}
+}]
+[para]
+
+[subsection {How do I make a type variable public?}]
+
+There are two ways to do this. The preferred way is to write a pair
+of [sectref {TYPE METHODS}] to set and query the type variable's value.
+
+[para]
+
+Type variables are stored in the type's namespace, which has
+the same name as the type itself. Thus, you can also
+publicize the type variable's name in your
+documentation so that clients can access it directly. For example,
+
+[para]
+[example {snit::type mytype {
+ typevariable myvariable
+}
+
+set ::mytype::myvariable "New Value"
+}]
+[para]
+
+[section {TYPE METHODS}]
+
+[subsection {What is a type method?}]
+
+A type method is a procedure associated with the type itself rather
+than with any specific instance of the type, and called as a
+subcommand of the type command.
+
+[subsection {How do I define a type method?}]
+
+Type methods are defined in the type definition using the
+
+[cmd typemethod] statement:
+
+[para]
+[example {snit::type dog {
+ # List of pedigreed dogs
+ typevariable pedigreed
+
+ typemethod pedigreedDogs {} {
+ return $pedigreed
+ }
+}
+}]
+[para]
+
+Suppose the [cmd dog] type maintains a list of the names of the dogs
+that have pedigrees. The [cmd pedigreedDogs] type method returns this
+list.
+
+[para]
+
+The [cmd typemethod] statement looks just like a normal Tcl
+[cmd proc], except that it appears in a [cmd snit::type] definition.
+Notice that every type method gets an implicit argument called
+[var type], which contains the fully-qualified type name.
+
+[subsection {How does a client call a type method?}]
+
+The type method name becomes a subcommand of the type's command. For
+example, assuming that the constructor adds each pedigreed dog to the
+list of [var pedigreedDogs],
+
+[para]
+[example {snit::type dog {
+ option -pedigreed 0
+
+ # List of pedigreed dogs
+ typevariable pedigreed
+
+ typemethod pedigreedDogs {} {
+ return $pedigreed
+ }
+
+ # ...
+}
+
+dog spot -pedigreed 1
+dog fido
+
+foreach dog [dog pedigreedDogs] { ... }
+}]
+[para]
+
+[subsection {Are there any limitations on type method names?}]
+
+Not really, so long as you avoid the standard type method names:
+[method create], [method destroy], and [method info].
+
+
+[subsection {How do I make a type method private?}]
+
+It's sometimes useful to define private type methods, that is, type
+methods intended to be called only by other type or instance methods
+of the same object.
+
+[para]
+
+Snit doesn't implement any access control on type methods; by
+convention, the names of public methods begin with a lower-case
+letter, and the names of private methods begin with an upper-case
+letter.
+
+[para]
+
+Alternatively, a Snit [cmd proc] can be used as a private type method; see
+[sectref PROCS].
+
+
+[subsection {Are there any limitations on type method arguments?}]
+
+Method argument lists are defined just like normal Tcl proc argument
+lists; in particular, they can include arguments with default values
+and the [var args] argument.
+
+[para]
+
+However, every type method is called with an implicit argument called
+[var type] that contains the name of the type command. In addition,
+type methods should by convention avoid using the names of the
+arguments implicitly defined for [sectref {INSTANCE METHODS}].
+
+[subsection {How does an instance or type method call a type method?}]
+
+If an instance or type method needs to call a type method, it should
+use [var \$type] to do so:
+
+[para]
+[example {snit::type dog {
+
+ typemethod pedigreedDogs {} { ... }
+
+ typemethod printPedigrees {} {
+ foreach obj [$type pedigreedDogs] { ... }
+ }
+}
+}]
+[para]
+
+[subsection {How do I pass a type method as a callback?}]
+
+It's common in Tcl to pass a snippet of code to another object, for it
+to call later. Because types cannot be renamed, you can just
+use the type name, or, if the callback is registered from within
+a type method, [var type]. For example, suppose we want to print a
+list of pedigreed dogs when a Tk button is pushed:
+
+[para]
+[example {
+button .btn -text "Pedigrees" -command [list dog printPedigrees]
+pack .btn
+}]
+
+Alternatively, from a method or type method you can use the
+[cmd mytypemethod] command, just as you would use [cmd mymethod]
+to define a callback command for [sectref {INSTANCE METHODS}].
+
+[subsection {Can type methods be hierarchical?}]
+
+Yes, you can define hierarchical type methods in just the same way as
+you can define hierarchical instance methods. See
+[sectref {INSTANCE METHODS}] for more.
+
+[section PROCS]
+
+[subsection {What is a proc?}]
+
+A Snit [cmd proc] is really just a Tcl proc defined within the type's
+namespace. You can use procs for private code that isn't related to
+any particular instance.
+
+[subsection {How do I define a proc?}]
+
+Procs are defined by including a [cmd proc] statement in the type
+definition:
+
+[para]
+[example {snit::type mytype {
+ # Pops and returns the first item from the list stored in the
+ # listvar, updating the listvar
+ proc pop {listvar} { ... }
+
+ # ...
+}
+}]
+[para]
+
+[subsection {Are there any limitations on proc names?}]
+
+Any name can be used, so long as it does not begin with [const Snit_];
+names beginning with [const Snit_] are reserved for Snit's own use.
+However, the wise programmer will avoid [cmd proc] names ([cmd set],
+[cmd list], [cmd if], etc.) that would shadow standard Tcl
+command names.
+
+[para]
+
+[cmd proc] names, being private, should begin with a capital letter according
+to convention; however, as there are typically no public [cmd proc]s
+in the type's namespace it doesn't matter much either way.
+
+[subsection {How does a method call a proc?}]
+
+Just like it calls any Tcl command. For example,
+
+[para]
+
+[example {snit::type mytype {
+ # Pops and returns the first item from the list stored in the
+ # listvar, updating the listvar
+ proc pop {listvar} { ... }
+
+ variable requestQueue {}
+
+ # Get one request from the queue and process it.
+ method processRequest {} {
+ set req [pop requestQueue]
+ }
+}
+}]
+[para]
+
+[subsection {How can I pass a proc to another object as a callback?}]
+
+The [cmd myproc] command returns a callback command for the
+[cmd proc], just as [cmd mymethod] does for a method.
+
+[section {TYPE CONSTRUCTORS}]
+
+[subsection {What is a type constructor?}]
+
+A type constructor is a body of code that initializes the type as a
+whole, rather like a C++ static initializer. The body of a type
+constructor is executed once when the type is defined, and never
+again.
+
+[para]
+
+A type can have at most one type constructor.
+
+
+[subsection {How do I define a type constructor?}]
+
+A type constructor is defined by using the [cmd typeconstructor]
+statement in the type definition. For example, suppose the type uses
+an array-valued type variable as a look-up table, and the values in
+the array have to be computed at start-up.
+
+[para]
+[example {% snit::type mytype {
+ typevariable lookupTable
+
+ typeconstructor {
+ array set lookupTable {key value...}
+ }
+}
+}]
+[para]
+
+
+
+[section CONSTRUCTORS]
+
+[subsection {What is a constructor?}]
+
+In object-oriented programming, an object's constructor is responsible
+for initializing the object completely at creation time. The constructor
+receives the list of options passed to the [cmd snit::type] command's
+[method create] method and can then do whatever it likes. That might include
+computing instance variable values, reading data from files, creating
+other objects, updating type and instance variables, and so forth.
+
+[para]
+
+The constructor's return value is ignored (unless it's an
+error, of course).
+
+
+[subsection {How do I define a constructor?}]
+
+A constructor is defined by using the [cmd constructor] statement in
+the type definition. Suppose that it's desired to keep a list of all
+pedigreed dogs. The list can be maintained in a
+type variable and retrieved by a type method. Whenever a dog is
+created, it can add itself to the list--provided that it's registered
+with the American Kennel Club.
+
+[para]
+[example {% snit::type dog {
+ option -akc 0
+
+ typevariable akcList {}
+
+ constructor {args} {
+ $self configurelist $args
+
+ if {$options(-akc)} {
+ lappend akcList $self
+ }
+ }
+
+ typemethod akclist {} {
+ return $akcList
+ }
+}
+::dog
+% dog spot -akc 1
+::spot
+% dog fido
+::fido
+% dog akclist
+::spot
+%
+}]
+[para]
+
+[subsection {What does the default constructor do?}]
+
+If you don't provide a constructor explicitly, you get the default
+constructor, which is identical to the explicitly-defined
+constructor shown here:
+
+[para]
+[example {snit::type dog {
+ constructor {args} {
+ $self configurelist $args
+ }
+}
+}]
+[para]
+
+When the constructor is called, [var args] will be set to the list of
+arguments that follow the object's name. The constructor is allowed
+to interpret this list any way it chooses; the normal convention is
+to assume that it's a list of option names and values, as shown in the
+example above. If you simply want to save the option values, you
+should use the [method configurelist] method, as shown.
+
+[subsection {Can I choose a different set of arguments for the constructor?}]
+
+Yes, you can. For example, suppose we wanted to be sure that the
+breed was explicitly stated for every dog at creation time, and
+couldn't be changed thereafter. One way to do that is as follows:
+
+[para]
+[example {% snit::type dog {
+ variable breed
+
+ option -color brown
+ option -akc 0
+
+ constructor {theBreed args} {
+ set breed $theBreed
+ $self configurelist $args
+ }
+
+ method breed {} { return $breed }
+}
+::dog
+% dog spot dalmatian -color spotted -akc 1
+::spot
+% spot breed
+dalmatian
+}]
+[para]
+
+The drawback is that this syntax is non-standard, and may
+limit the compatibility of your new type with other people's code.
+For example, Snit assumes that it can create
+[sectref COMPONENTS] using the standard creation syntax.
+
+[subsection {Are there any limitations on constructor arguments?}]
+
+Constructor argument lists are subject to the same limitations
+as those on instance method argument lists. It has the
+same implicit arguments, and can contain default values and the
+[var args] argument.
+
+[subsection "Is there anything special about writing the constructor?"]
+
+Yes. Writing the constructor can be tricky if you're delegating
+options to components, and there are specific issues relating to
+[cmd snit::widget]s and [cmd snit::widgetadaptor]s. See
+[sectref {DELEGATION}], [sectref {WIDGETS}],
+[sectref {WIDGET ADAPTORS}], and [sectref {THE TK OPTION DATABASE}].
+
+[section DESTRUCTORS]
+
+[subsection {What is a destructor?}]
+
+A destructor is a special kind of method that's called when an object
+is destroyed. It's responsible for doing any necessary clean-up when
+the object goes away: destroying [sectref COMPONENTS], closing files,
+and so forth.
+
+[subsection {How do I define a destructor?}]
+
+Destructors are defined by using the [cmd destructor] statement in the
+type definition.
+
+[para]
+Suppose we're maintaining a list of pedigreed dogs;
+then we'll want to remove dogs from it when they are destroyed.
+
+[para]
+[example {snit::type dog {
+ option -akc 0
+
+ typevariable akcList {}
+
+ constructor {args} {
+ $self configurelist $args
+
+ if {$options(-akc)} {
+ lappend akcList $self
+ }
+ }
+
+ destructor {
+ set ndx [lsearch $akcList $self]
+
+ if {$ndx != -1} {
+ set akcList [lreplace $akcList $ndx $ndx]
+ }
+ }
+
+ typemethod akclist {} {
+ return $akcList
+ }
+}
+}]
+[para]
+
+[subsection {Are there any limitations on destructor arguments?}]
+
+Yes; a destructor has no explicit arguments.
+
+[subsection {What implicit arguments are passed to the destructor?}]
+
+The destructor gets the same implicit arguments that are passed to
+[sectref {INSTANCE METHODS}]: [var type], [var selfns], [var win], and
+[var self].
+
+[subsection {Must components be destroyed explicitly?}]
+
+Yes and no.
+
+[para]
+
+Any Tk widgets created by a [cmd snit::widget] or
+[cmd snit::widgetadaptor] will be destroyed automatically by Tk
+when the megawidget is destroyed, in keeping with normal Tk behavior
+(destroying a parent widget destroys the whole tree).
+
+[para]
+
+Components of normal [cmd snit::types], on the other hand,
+are never destroyed automatically, nor are non-widget components
+of Snit megawidgets. If your object creates them in its
+constructor, then it should generally destroy them in its destructor.
+
+[subsection {Is there any special about writing a destructor?}]
+
+Yes. If an object's constructor throws an error, the object's
+destructor will be called to clean up; this means that the object
+might not be completely constructed when the destructor is called.
+This can cause the destructor to throw its own error; the result
+is usually misleading, confusing, and unhelpful. Consequently, it's
+important to write your destructor so that it's fail-safe.
+
+[para]
+
+For example, a [cmd dog] might create a [cmd tail] component; the
+component will need to be destroyed. But suppose there's an error
+while processing the creation options--the destructor will be called,
+and there will be no [cmd tail] to destroy. The simplest solution is
+generally to catch and ignore any errors while destroying components.
+
+[example {snit::type dog {
+ component tail
+
+ constructor {args} {
+ $self configurelist $args
+
+ set tail [tail %AUTO%]
+ }
+
+ destructor {
+ catch {$tail destroy}
+ }
+}
+}]
+
+
+[section COMPONENTS]
+
+[subsection {What is a component?}]
+
+Often an object will create and manage a number of other objects. A
+Snit megawidget, for example, will often create a number of Tk
+widgets. These objects are part of the main object; it is composed
+of them, so they are called components of the object.
+
+[para]
+
+But Snit also has a more precise meaning for
+[sectref COMPONENTS COMPONENT]. The components of a Snit object are those
+objects to which methods or options can be delegated.
+(See [sectref DELEGATION] for more information about delegation.)
+
+[subsection {How do I declare a component?}]
+
+First, you must decide what role a component plays within your object,
+and give the role a name. Then, you declare the component using its
+role name and the [cmd component] statement. The [cmd component]
+statement declares an [term {instance variable}] which is used to
+store the component's command name when the component is created.
+
+[para]
+
+For example, suppose your [cmd dog] object
+creates a [cmd tail] object (the better to wag with, no doubt):
+
+[para]
+[example {snit::type dog {
+ component mytail
+
+ constructor {args} {
+ # Create and save the component's command
+ set mytail [tail %AUTO% -partof $self]
+ $self configurelist $args
+ }
+
+ method wag {} {
+ $mytail wag
+ }
+}
+}]
+[para]
+
+As shown here, it doesn't matter what the [cmd tail] object's real
+name is; the [cmd dog] object refers to it by its component name.
+
+[para]
+
+The above example shows one way to delegate the [method wag] method to
+the [var mytail] component; see [sectref DELEGATION] for an easier way.
+
+[subsection {How is a component named?}]
+
+A component has two names. The first name is that of the component
+variable; this represents the role the component object plays within
+the Snit object. This is the component name proper, and is the name
+used to refer to the component within Snit code. The second name is
+the name of the actual component object created by the Snit object's
+constructor. This second name is always a Tcl command name, and is
+referred to as the component's object name.
+
+[para]
+
+In the example in the previous question, the component name is
+[const mytail]; the [const mytail] component's object name is chosen
+automatically by Snit since [const %AUTO%] was used when the component
+object was created.
+
+[subsection {Are there any limitations on component names?}]
+
+Yes. [cmd snit::widget] and [cmd snit::widgetadaptor] objects have a special
+component called the [var hull] component; thus, the name [var hull]
+should be used for no other purpose.
+
+[para]
+
+Otherwise, since component names are in fact instance variable names
+they must follow the rules for [sectref {INSTANCE VARIABLES}].
+
+[subsection {What is an owned component?}]
+
+An [term owned] component is a component whose object command's
+lifetime is controlled by the [cmd snit::type] or [cmd snit::widget].
+
+[para]
+
+As stated above, a component is an object to
+which our object can delegate methods or options. Under this
+definition, our object will usually create its component objects,
+but not necessarily. Consider the following: a dog object has a tail
+component; but tail knows that it's part of the dog:
+
+[example {snit::type dog {
+ component mytail
+
+ constructor {args} {
+ set mytail [tail %AUTO% -partof $self]
+ $self configurelist $args
+ }
+
+ destructor {
+ catch {$mytail destroy}
+ }
+
+ delegate method wagtail to mytail as wag
+
+ method bark {} {
+ return "$self barked."
+ }
+}
+
+ snit::type tail {
+ component mydog
+ option -partof -readonly yes
+
+ constructor {args} {
+ $self configurelist $args
+ set mydog $options(-partof)
+ }
+
+ method wag {} {
+ return "Wag, wag."
+ }
+
+ method pull {} {
+ $mydog bark
+ }
+ }
+}]
+
+Thus, if you ask a dog to wag its tail, it tells its tail to wag;
+and if you pull the dog's tail, the tail tells the dog to bark. In
+this scenario, the tail is a component of the dog, and the dog is a
+component of the tail, but the dog owns the tail and not the other way
+around.
+
+[subsection {What does the install command do?}]
+
+The [cmd install] command creates an owned component using a specified
+command, and assigns the result to the component's instance variable.
+For example:
+
+[example {snit::type dog {
+ component mytail
+
+ constructor {args} {
+ # set mytail [tail %AUTO% -partof $self]
+ install mytail using tail %AUTO% -partof $self
+ $self configurelist $args
+ }
+}
+}]
+
+In a [cmd snit::type]'s code, the [cmd install]
+command shown above is equivalent to the [const {set mytail}] command
+that's commented out. In a [cmd snit::widget]'s or
+[cmd snit::widgetadaptor]'s, code, however, the
+[cmd install] command also queries [sectref {THE TK OPTION DATABASE}]
+and initializes the new component's options accordingly. For consistency,
+it's a good idea to get in the habit of using [cmd install] for all
+owned components.
+
+[subsection {Must owned components be created in the constructor?}]
+
+No, not necessarily. In fact, there's no reason why an
+object can't destroy and recreate a component multiple times over
+its own lifetime.
+
+[subsection {Are there any limitations on component object names?}]
+
+Yes.
+
+[para]
+
+Component objects which are Tk widgets or megawidgets must have valid
+Tk window names.
+
+[para]
+
+Component objects which are not widgets or megawidgets must have
+fully-qualified command names, i.e., names which include the full
+namespace of the command. Note that Snit always creates objects with
+fully qualified names.
+
+[para]
+
+Next, the object names of components and owned by your object
+must be unique. This is no problem for widget components, since
+widget names are always unique; but consider the following code:
+
+[para]
+[example {snit::type tail { ... }
+
+snit::type dog {
+ delegate method wag to mytail
+
+ constructor {} {
+ install mytail using tail mytail
+ }
+}
+}]
+[para]
+
+This code uses the component name, [const "mytail"], as the component object
+name. This is not good, and here's why: Snit instance code executes
+in the Snit type's namespace. In this case, the [const mytail] component is
+created in the [const ::dog::] namespace, and will thus have the name
+[cmd ::dog::mytail].
+
+[para]
+
+Now, suppose you create two dogs. Both dogs will attempt to
+create a tail called [cmd ::dog::mytail]. The first will succeed,
+and the second will fail, since Snit won't let you create an object if
+its name is already a command. Here are two ways to avoid this situation:
+
+[para]
+
+First, if the component type is a [cmd snit::type] you can
+specify [const %AUTO%] as its name, and be guaranteed to get a unique name.
+This is the safest thing to do:
+
+[para]
+[example {
+ install mytail using tail %AUTO%
+}]
+[para]
+
+If the component type isn't a [cmd snit::type] you can create
+the component in the object's instance namespace:
+
+[para]
+[example {
+ install mytail using tail ${selfns}::mytail
+}]
+[para]
+
+Make sure you pick a unique name within the instance namespace.
+
+[subsection {Must I destroy the components I own?}]
+
+That depends. When a parent widget is destroyed, all child widgets
+are destroyed automatically. Thus, if your object is a [cmd snit::widget]
+or [cmd snit::widgetadaptor] you don't need to destroy any components
+that are widgets, because they will generally be children or
+descendants of your megawidget.
+
+[para]
+
+If your object is an instance of [cmd snit::type], though, none of its
+owned components will be destroyed automatically, nor will be
+non-widget components of a [cmd snit::widget] be destroyed
+automatically. All such owned components must be destroyed
+explicitly, or they won't be destroyed at all.
+
+[subsection {Can I expose a component's object command as part of my interface?}]
+
+Yes, and there are two ways to do it. The most appropriate way is
+usually to use [sectref DELEGATION]. Delegation allows you to pass
+the options and methods you specify along to particular components.
+This effectively hides the components from the users of your type, and
+ensures good encapsulation.
+
+[para]
+
+However, there are times when it's appropriate, not to mention
+simpler, just to make the entire component part of your type's public
+interface.
+
+
+[subsection {How do I expose a component's object command?}]
+
+When you declare the component, specify the [cmd component]
+statement's [const -public] option. The value of this option is the
+name of a method which will be delegated to your component's object
+command.
+
+[para]
+
+For example, supposed you've written a combobox megawidget which owns
+a listbox widget, and you want to make the listbox's entire interface
+public. You can do it like this:
+
+[para]
+[example {snit::widget combobox {
+ component listbox -public listbox
+
+ constructor {args} {
+ install listbox using listbox $win.listbox ....
+ }
+}
+
+combobox .mycombo
+.mycombo listbox configure -width 30
+}]
+[para]
+
+Your comobox widget, [cmd .mycombo], now has a [method listbox] method
+which has all of the same subcommands as the listbox widget itself.
+Thus, the above code sets the listbox component's width to 30.
+
+[para]
+
+Usually you'll let the method name be the same as the component name;
+however, you can name it anything you like.
+
+[section {TYPE COMPONENTS}]
+
+[subsection {What is a type component?}]
+
+A type component is a component that belongs to the type itself
+instead of to a particular instance of the type. The relationship
+between components and type components is the same as the
+relationship between [sectref {INSTANCE VARIABLES}] and
+[sectref {TYPE VARIABLES}]. Both [sectref {INSTANCE METHODS}] and
+[sectref {TYPE METHODS}] can be delegated to type components.
+
+[para]
+
+Once you understand [sectref COMPONENTS] and
+[sectref {DELEGATION}], type components are just more of the same.
+
+[subsection {How do I declare a type component?}]
+
+Declare a type component using the [cmd typecomponent] statement. It
+takes the same options ([const -inherit] and [const -public]) as the
+[cmd component] statement does, and defines a type variable to hold
+the type component's object command.
+
+[para]
+
+Suppose in your model you've got many dogs, but only one
+veterinarian. You might make the veterinarian a type component.
+
+[example {snit::type veterinarian { ... }
+
+snit::type dog {
+ typecomponent vet
+
+ # ...
+}
+}]
+
+[subsection {How do I install a type component?}]
+
+Just use the [cmd set] command to assign the component's object
+command to the type component. Because types
+(even [cmd snit::widget] types) are not widgets, and do not have
+options anyway, the extra features of the [cmd install] command are
+not needed.
+
+[para]
+
+You'll usually install type components in the type constructor, as
+shown here:
+
+[example {snit::type veterinarian { ... }
+
+snit::type dog {
+ typecomponent vet
+
+ typeconstructor {
+ set vet [veterinarian %AUTO%]
+ }
+}
+}]
+
+[subsection {Are there any limitations on type component names?}]
+
+Yes, the same as on [sectref {INSTANCE VARIABLES}],
+[sectref {TYPE VARIABLES}], and normal [sectref COMPONENTS].
+
+
+[section DELEGATION]
+
+[subsection {What is delegation?}]
+
+Delegation, simply put, is when you pass a task you've been given to
+one of your assistants. (You do have assistants, don't you?) Snit
+objects can do the same thing. The following example shows one way in
+which the [cmd dog] object can delegate its [cmd wag] method and its
+[option -taillength] option to its [cmd tail] component.
+
+[para]
+[example {snit::type dog {
+ variable mytail
+
+ option -taillength -configuremethod SetTailOption -cgetmethod GetTailOption
+
+
+ method SetTailOption {option value} {
+ $mytail configure $option $value
+ }
+
+ method GetTailOption {option} {
+ $mytail cget $option
+ }
+
+ method wag {} {
+ $mytail wag
+ }
+
+ constructor {args} {
+ install mytail using tail %AUTO% -partof $self
+ $self configurelist $args
+ }
+
+}
+}]
+[para]
+
+This is the hard way to do it, by it demonstrates what delegation is
+all about. See the following answers for the easy way to do it.
+
+[para]
+
+Note that the constructor calls the [method configurelist] method
+[cmd after] it creates its [cmd tail]; otherwise,
+if [option -taillength] appeared in the list of [var args] we'd get an
+error.
+
+[subsection {How can I delegate a method to a component object?}]
+
+Delegation occurs frequently enough that Snit makes it easy. Any
+method can be delegated to any component or type component
+by placing a single [cmd delegate] statement in the type definition.
+
+(See [sectref COMPONENTS] and [sectref {TYPE COMPONENTS}]
+for more information about component names.)
+
+[para]
+
+For example, here's a much better way to delegate the [cmd dog]
+object's [cmd wag] method:
+
+[para]
+[example {% snit::type dog {
+ delegate method wag to mytail
+
+ constructor {} {
+ install mytail using tail %AUTO%
+ }
+}
+::dog
+% snit::type tail {
+ method wag {} { return "Wag, wag, wag."}
+}
+::tail
+% dog spot
+::spot
+% spot wag
+Wag, wag, wag.
+}]
+[para]
+
+This code has the same effect as the code shown under the previous
+question: when a [cmd dog]'s [cmd wag] method is called, the call and
+its arguments are passed along automatically to the [cmd tail] object.
+
+[para]
+
+Note that when a component is mentioned in a [cmd delegate] statement,
+the component's instance variable is defined implicitly. However,
+it's still good practice to declare it explicitly using the
+[cmd component] statement.
+
+[para]
+
+Note also that you can define a method name using the [cmd method]
+statement, or you can define it using [cmd delegate]; you can't do
+both.
+
+[subsection {Can I delegate to a method with a different name?}]
+
+Suppose you wanted to delegate the [cmd dog]'s [method wagtail] method to
+the [cmd tail]'s [method wag] method. After all you wag the tail, not
+the dog. It's easily done:
+
+[para]
+[example {snit::type dog {
+ delegate method wagtail to mytail as wag
+
+ constructor {args} {
+ install mytail using tail %AUTO% -partof $self
+ $self configurelist $args
+ }
+}
+}]
+[para]
+
+
+[subsection {Can I delegate to a method with additional arguments?}]
+
+Suppose the [cmd tail]'s [method wag] method takes as an argument the
+number of times the tail should be wagged. You want to delegate the
+[cmd dog]'s [method wagtail] method to the [cmd tail]'s [method wag]
+method, specifying that the tail should be wagged exactly three times.
+This is easily done, too:
+
+[para]
+[example {snit::type dog {
+ delegate method wagtail to mytail as {wag 3}
+ # ...
+}
+
+snit::type tail {
+ method wag {count} {
+ return [string repeat "Wag " $count]
+ }
+ # ...
+}
+}]
+[para]
+
+[subsection {Can I delegate a method to something other than an object?}]
+
+Normal method delegation assumes that you're delegating a method (a
+subcommand of an object command) to a method of another object (a
+subcommand of a different object command). But not all Tcl objects
+follow Tk conventions, and not everything you'd to which you'd like
+to delegate a method is necessary an object. Consequently, Snit makes
+it easy to delegate a method to pretty much anything you like using
+the [cmd delegate] statement's [const using] clause.
+
+[para]
+
+Suppose your dog simulation stores dogs in a database, each dog as a
+single record. The database API you're using provides a number of
+commands to manage records; each takes the record ID (a string you
+choose) as its first argument. For example, [cmd saverec]
+saves a record. If you let the record ID be the name of the dog
+object, you can delegate the dog's [method save] method to the
+[cmd saverec] command as follows:
+
+[example {snit::type dog {
+ delegate method save using {saverec %s}
+}
+}]
+
+The [const %s] is replaced with the instance name when the
+[method save] method is called; any additional arguments are the
+appended to the resulting command.
+
+[para]
+
+The [const using] clause understands a number of other %-conversions;
+in addition to the instance name, you can substitute in the method
+name ([const %m]), the type name ([const %t]), the instance
+namespace ([const %n]), the Tk window name ([const %w]), and,
+if a component or typecomponent name was given in the
+[cmd delegate] statement, the component's object command
+([const %c]).
+
+[subsection {How can I delegate a method to a type component object?}]
+
+Just exactly as you would to a component object. The
+[cmd {delegate method}] statement accepts both component and type
+component names in its [const to] clause.
+
+[subsection {How can I delegate a type method to a type component object?}]
+
+Use the [cmd {delegate typemethod}] statement. It works like
+[cmd {delegate method}], with these differences: first, it defines
+a type method instead of an instance method; second, the
+[const using] clause ignores the [const {%s}], [const {%n}],
+and [const {%w}] %-conversions.
+
+[para]
+
+Naturally, you can't delegate a type method to an instance
+component...Snit wouldn't know which instance should receive it.
+
+[subsection {How can I delegate an option to a component object?}]
+
+The first question in this section (see [sectref DELEGATION]) shows
+one way to delegate an option to a component; but this pattern occurs
+often enough that Snit makes it easy. For example, every [cmd tail]
+object has a [option -length] option; we want to allow the creator of
+a [cmd dog] object to set the tail's length. We can do this:
+
+[para]
+[example {% snit::type dog {
+ delegate option -length to mytail
+
+ constructor {args} {
+ install mytail using tail %AUTO% -partof $self
+ $self configurelist $args
+ }
+}
+::dog
+% snit::type tail {
+ option -partof
+ option -length 5
+}
+::tail
+% dog spot -length 7
+::spot
+% spot cget -length
+7
+}]
+[para]
+
+This produces nearly the same result as the [const -configuremethod] and
+[const -cgetmethod] shown under the first question in this
+section: whenever a [cmd dog] object's [option -length] option is set
+or retrieved, the underlying [cmd tail] object's option is set or
+retrieved in turn.
+
+[para]
+
+Note that you can define an option name using the [cmd option]
+statement, or you can define it using [cmd delegate]; you can't do
+both.
+
+[subsection {Can I delegate to an option with a different name?}]
+
+In the previous answer we delegated the [cmd dog]'s [option -length]
+option down to its [cmd tail]. This is, of course, wrong. The dog
+has a length, and the tail has a length, and they are different. What
+we'd really like to do is give the [cmd dog] a [option -taillength]
+option, but delegate it to the [cmd tail]'s [option -length] option:
+
+[para]
+[example {snit::type dog {
+ delegate option -taillength to mytail as -length
+
+ constructor {args} {
+ set mytail [tail %AUTO% -partof $self]
+ $self configurelist $args
+ }
+}
+}]
+[para]
+
+[subsection {How can I delegate any unrecognized method or option to a component object?}]
+
+It may happen that a Snit object gets most of its behavior from one of
+its components. This often happens with [cmd snit::widgetadaptors],
+for example, where we wish to slightly the modify the behavior of an
+existing widget. To carry on with our [cmd dog] example, however, suppose
+that we have a [cmd snit::type] called [cmd animal] that implements a
+variety of animal behaviors--moving, eating, sleeping, and so forth.
+
+We want our [cmd dog] objects to inherit these same behaviors, while
+adding dog-like behaviors of its own.
+
+Here's how we can give a [cmd dog] methods and options of its own
+while delegating all other methods and options to its [cmd animal]
+component:
+
+[para]
+[example {snit::type dog {
+ delegate option * to animal
+ delegate method * to animal
+
+ option -akc 0
+
+ constructor {args} {
+ install animal using animal %AUTO% -name $self
+ $self configurelist $args
+ }
+
+ method wag {} {
+ return "$self wags its tail"
+ }
+}
+}]
+[para]
+
+That's it. A [cmd dog] is now an [cmd animal] that has a
+[option -akc] option and can [cmd wag] its tail.
+
+[para]
+
+Note that we don't need to specify the full list of method names or
+option names that [cmd animal] will receive.
+It gets anything [cmd dog] doesn't recognize--and if it doesn't
+recognize it either, it will simply throw an error, just as it should.
+
+[para]
+
+You can also delegate all unknown type methods to a type component
+using [cmd {delegate typemethod *}].
+
+[subsection {How can I delegate all but certain methods or options to a component?}]
+
+In the previous answer, we said that every [cmd dog] is
+an [cmd animal] by delegating all unknown methods and options to the
+[var animal] component. But what if the [cmd animal] type has some
+methods or options that we'd like to suppress?
+
+[para]
+
+One solution is to explicitly delegate all the options and methods,
+and forgo the convenience of [cmd {delegate method *}] and
+[cmd {delegate option *}]. But if we wish to suppress only a few
+options or methods, there's an easier way:
+
+[para]
+[example {snit::type dog {
+ delegate option * to animal except -numlegs
+ delegate method * to animal except {fly climb}
+
+ # ...
+
+ constructor {args} {
+ install animal using animal %AUTO% -name $self -numlegs 4
+ $self configurelist $args
+ }
+
+ # ...
+}
+}]
+[para]
+
+Dogs have four legs, so we specify that explicitly when we create the
+[var animal] component, and explicitly exclude [option -numlegs] from the
+set of delegated options. Similarly, dogs can neither
+[method fly] nor [method climb],
+so we exclude those [cmd animal] methods as shown.
+
+[subsection {Can a hierarchical method be delegated?}]
+
+Yes; just specify multiple words in the delegated method's name:
+
+[para]
+[example {snit::type tail {
+ method wag {} {return "Wag, wag"}
+ method droop {} {return "Droop, droop"}
+}
+
+
+snit::type dog {
+ delegate method {tail wag} to mytail
+ delegate method {tail droop} to mytail
+
+ # ...
+
+ constructor {args} {
+ install mytail using tail %AUTO%
+ $self configurelist $args
+ }
+
+ # ...
+}
+}]
+[para]
+
+Unrecognized hierarchical methods can also be delegated; the following
+code delegates all subcommands of the "tail" method to the "mytail"
+component:
+
+[para]
+[example {snit::type dog {
+ delegate method {tail *} to mytail
+
+ # ...
+}
+}]
+[para]
+
+
+
+
+[section WIDGETS]
+
+[subsection {What is a snit::widget?}]
+
+A [cmd snit::widget] is the Snit version of what Tcl programmers
+usually call a [term megawidget]: a widget-like object usually
+consisting of one or more Tk widgets all contained within a Tk frame.
+
+[para]
+
+A [cmd snit::widget] is also a special kind of [cmd snit::type]. Just
+about everything in this FAQ list that relates to [cmd snit::types]
+also applies to [cmd snit::widgets].
+
+
+[subsection {How do I define a snit::widget?}]
+
+[cmd snit::widgets] are defined using the [cmd snit::widget] command,
+just as [cmd snit::types] are defined by the [cmd snit::type] command.
+
+[para]
+
+The body of the definition can contain all of the same kinds of
+statements, plus a couple of others which will be mentioned below.
+
+
+[subsection {How do snit::widgets differ from snit::types?}]
+
+[list_begin itemized]
+[item]
+
+The name of an instance of a [cmd snit::type] can be any valid Tcl
+command name, in any namespace.
+
+The name of an instance of a [cmd snit::widget] must be a valid Tk
+widget name, and its parent widget must already exist.
+
+
+[item]
+
+An instance of a [cmd snit::type] can be destroyed by calling
+
+its [cmd destroy] method. Instances of a [cmd snit::widget] have no
+destroy method; use the Tk [cmd destroy] command instead.
+
+
+[item]
+
+Every instance of a [cmd snit::widget] has one predefined component
+called its [var hull] component.
+
+The hull is usually a Tk [cmd frame] or [cmd toplevel] widget; any other
+widgets created as part of the [cmd snit::widget] will usually be
+contained within the hull.
+
+[item]
+
+[cmd snit::widget]s can have their options receive default values from
+[sectref {THE TK OPTION DATABASE}].
+
+[list_end]
+
+[subsection {What is a hull component?}]
+
+Snit can't create a Tk widget object; only Tk can do that.
+
+Thus, every instance of a [cmd snit::widget] must be wrapped around a
+genuine Tk widget; this Tk widget is called the [term {hull component}].
+
+Snit effectively piggybacks the behavior you define (methods, options,
+and so forth) on top of the hull component so that the whole thing
+behaves like a standard Tk widget.
+
+[para]
+
+For [cmd snit::widget]s the hull component must be a Tk widget that
+defines the [const -class] option.
+
+[para]
+
+[cmd snit::widgetadaptor]s differ from [cmd snit::widget]s chiefly in
+that any kind of widget can be used as the hull component; see
+[sectref {WIDGET ADAPTORS}].
+
+[subsection {How can I set the hull type for a snit::widget?}]
+
+A [cmd snit::widget]'s hull component will usually be a Tk [cmd frame]
+widget; however, it may be any Tk widget that defines the
+[const -class] option. You can
+explicitly choose the hull type you prefer by including the [cmd hulltype]
+command in the widget definition:
+
+[para]
+[example {snit::widget mytoplevel {
+ hulltype toplevel
+
+ # ...
+}
+}]
+[para]
+
+If no [cmd hulltype] command appears, the hull will be a [cmd frame].
+
+[para]
+
+By default, Snit recognizes the following hull types: the Tk widgets
+[cmd frame], [cmd labelframe], [cmd toplevel], and the Tile widgets
+[cmd ttk::frame], [cmd ttk::labelframe], and [cmd ttk::toplevel]. To
+enable the use of some other kind of widget as the hull type, you can
+[cmd lappend] the widget command to the variable [var snit::hulltypes] (always
+provided the widget defines the [const -class] option. For example,
+suppose Tk gets a new widget type called a [cmd prettyframe]:
+
+[para]
+[example {lappend snit::hulltypes prettyframe
+
+snit::widget mywidget {
+ hulltype prettyframe
+
+ # ...
+}
+}]
+[para]
+
+
+
+[subsection {How should I name widgets which are components of a snit::widget?}]
+
+Every widget, whether a genuine Tk widget or a Snit megawidget, has to
+have a valid Tk window name. When a [cmd snit::widget] is first
+created, its instance name, [var self], is a Tk window name;
+
+however, if the [cmd snit::widget] is used as the hull component by a
+[cmd snit::widgetadaptor] its instance name will be changed to
+something else. For this reason, every [cmd snit::widget] method,
+constructor, destructor, and so forth is passed another implicit
+argument, [var win], which is the window name of the megawidget. Any
+children should be named using [var win] as the root.
+
+[para]
+
+Thus, suppose you're writing a toolbar widget, a frame consisting of a
+number of buttons placed side-by-side. It might look something like
+this:
+
+[para]
+[example {snit::widget toolbar {
+ delegate option * to hull
+
+ constructor {args} {
+ button $win.open -text Open -command [mymethod open]
+ button $win.save -text Save -command [mymethod save]
+
+ # ....
+
+ $self configurelist $args
+
+ }
+}
+}]
+[para]
+
+See also the question on renaming objects, toward the top of this
+file.
+
+[section {WIDGET ADAPTORS}]
+
+[subsection {What is a snit::widgetadaptor?}]
+
+A [cmd snit::widgetadaptor] is a kind of [cmd snit::widget]. Whereas
+a [cmd snit::widget]'s hull is automatically created and is always a
+Tk frame, a [cmd snit::widgetadaptor] can be based on any Tk
+widget--or on any Snit megawidget, or even (with luck) on megawidgets
+defined using some other package.
+
+[para]
+
+It's called a [term {widget adaptor}] because it allows you to take an
+existing widget and customize its behavior.
+
+
+[subsection {How do I define a snit::widgetadaptor?}]
+
+Use the [cmd snit::widgetadaptor] command. The definition for a
+[cmd snit::widgetadaptor] looks just like that for a [cmd snit::type]
+or [cmd snit::widget], except that the constructor must create and
+install the hull component.
+
+[para]
+
+For example, the following code creates a read-only text widget by the
+simple device of turning its [method insert] and [method delete]
+methods into no-ops. Then, we define new methods, [method ins] and
+[method del],
+
+which get delegated to the hull component as [method insert] and
+[method delete]. Thus, we've adapted the text widget and given it new
+behavior while still leaving it fundamentally a text widget.
+
+[para]
+[example {::snit::widgetadaptor rotext {
+
+ constructor {args} {
+ # Create the text widget; turn off its insert cursor
+ installhull using text -insertwidth 0
+
+ # Apply any options passed at creation time.
+ $self configurelist $args
+ }
+
+ # Disable the text widget's insert and delete methods, to
+ # make this readonly.
+ method insert {args} {}
+ method delete {args} {}
+
+ # Enable ins and del as synonyms, so the program can insert and
+ # delete.
+ delegate method ins to hull as insert
+ delegate method del to hull as delete
+
+ # Pass all other methods and options to the real text widget, so
+ # that the remaining behavior is as expected.
+ delegate method * to hull
+ delegate option * to hull
+}
+}]
+[para]
+
+The most important part is in the constructor.
+Whereas [cmd snit::widget] creates the hull for you,
+[cmd snit::widgetadaptor] cannot -- it doesn't know what kind of
+widget you want. So the first thing the constructor does is create
+the hull component (a Tk text widget in this case), and then installs
+it using the [cmd installhull] command.
+
+[para]
+
+[emph Note:] There is no instance command until you create one by
+installing a hull component. Any attempt to pass methods to [var \$self]
+prior to calling [cmd installhull] will fail.
+
+[subsection {Can I adapt a widget created elsewhere in the program?}]
+
+Yes.
+
+[para]
+
+At times, it can be convenient to adapt a pre-existing widget instead
+of creating your own.
+For example, the Bwidget [cmd PagesManager] widget manages a
+set of [cmd frame] widgets, only one of which is visible at a time.
+The application chooses which [cmd frame] is visible. All of the
+These [cmd frame]s are created by the [cmd PagesManager] itself, using
+its [method add] method. It's convenient to adapt these frames to
+do what we'd like them to do.
+
+[para]
+
+In a case like this, the Tk widget will already exist when the
+[cmd snit::widgetadaptor] is created. Snit provides an alternate form
+of the [cmd installhull] command for this purpose:
+
+[para]
+[example {snit::widgetadaptor pageadaptor {
+ constructor {args} {
+ # The widget already exists; just install it.
+ installhull $win
+
+ # ...
+ }
+}
+}]
+
+[subsection {Can I adapt another megawidget?}]
+
+Maybe. If the other megawidget is a [cmd snit::widget] or
+[cmd snit::widgetadaptor], then yes. If it isn't then, again, maybe.
+You'll have to try it and see. You're most likely to have trouble
+with widget destruction--you have to make sure that your
+megawidget code receives the [const <Destroy>] event before the
+megawidget you're adapting does.
+
+[section {THE TK OPTION DATABASE}]
+
+[subsection {What is the Tk option database?}]
+
+The Tk option database is a database of default option values
+maintained by Tk itself; every Tk application has one. The concept of
+the option database derives from something called the X Windows
+resource database; however, the option database is available in every
+Tk implementation, including those which do not use the X Windows
+system (e.g., Microsoft Windows).
+
+[para]
+
+Full details about the Tk option database are beyond the scope of this
+document; both [emph {Practical Programming in Tcl and Tk}] by Welch,
+Jones, and Hobbs, and [emph {Effective Tcl/Tk Programming}] by
+Harrison and McClennan., have good introductions to it.
+
+[para]
+
+Snit is implemented so that most of the time it will simply do the
+right thing with respect to the option database, provided that the
+widget developer does the right thing by Snit. The body of this
+section goes into great deal about what Snit requires. The following
+is a brief statement of the requirements, for reference.
+
+[para]
+
+[list_begin itemized]
+
+[item]
+
+If the widget's default widget class is not what is desired, set it
+explicitly using the [cmd widgetclass] statement in the widget
+definition.
+
+[item]
+
+When defining or delegating options, specify the resource and class
+names explicitly when necessary.
+
+[item]
+
+Use the [cmd {installhull using}] command to create and install the
+hull for [cmd snit::widgetadaptor]s.
+
+[item]
+
+Use the [cmd install] command to create and install all
+components which are widgets.
+
+[item]
+
+Use the [cmd install] command to create and install
+components which aren't widgets if you'd like them to
+receive option values from the option database.
+
+[list_end]
+[para]
+
+The interaction of Tk widgets with the option database is a complex
+thing; the interaction of Snit with the option database is even more
+so, and repays attention to detail.
+
+
+[subsection {Do snit::types use the Tk option database?}]
+
+No, they don't; querying the option database requires a Tk window
+name, and [cmd snit::type]s don't have one.
+
+[para]
+
+If you create an instance of a [cmd snit::type] as a
+component of a [cmd snit::widget] or [cmd snit::widgetadaptor], on the
+other hand, and if any options are delegated to the component,
+and if you use [cmd install] to create and install it, then
+the megawidget will query the option database on the
+[cmd snit::type]'s behalf. This might or might not be what you
+want, so take care.
+
+[subsection {What is my snit::widget's widget class?}]
+
+Every Tk widget has a "widget class": a name that is used when adding
+option settings to the database. For Tk widgets, the widget class is
+the same as the widget command name with an initial capital. For
+example, the widget class of the Tk [cmd button] widget is
+[const Button].
+
+[para]
+
+Similarly, the widget class of a [cmd snit::widget] defaults to the
+unqualified type name with the first letter capitalized. For example,
+the widget class of
+
+[para]
+[example {snit::widget ::mylibrary::scrolledText { ... }
+}]
+[para]
+
+is [const ScrolledText].
+
+[para]
+
+The widget class can also be set explicitly using the
+[cmd widgetclass] statement within the [cmd snit::widget] definition:
+
+[para]
+[example {snit::widget ::mylibrary::scrolledText {
+ widgetclass Text
+
+ # ...
+}
+}]
+[para]
+
+The above definition says that a [cmd scrolledText] megawidget has the
+same widget class as an ordinary [cmd text] widget. This might or
+might not be a good idea, depending on how the rest of the megawidget
+is defined, and how its options are delegated.
+
+[subsection {What is my snit::widgetadaptor's widget class?}]
+
+The widget class of a [cmd snit::widgetadaptor] is just the widget
+class of its hull widget; Snit has no control over this.
+
+[para]
+
+Note that the widget class can be changed only for [cmd frame] and
+[cmd toplevel] widgets, which is why these are the valid hull types
+for [cmd snit::widget]s.
+
+[para]
+
+Try to use [cmd snit::widgetadaptor]s only to make small modifications
+to another widget's behavior. Then, it will usually not make sense to
+change the widget's widget class anyway.
+
+
+[subsection {What are option resource and class names?}]
+
+Every Tk widget option has three names: the option name, the resource
+name, and the class name.
+
+The option name begins with a hyphen and is all lowercase; it's used
+when creating widgets, and with the [cmd configure] and [cmd cget]
+commands.
+
+[para]
+
+The resource and class names are used to initialize option
+default values by querying the option database.
+The resource name is usually just the option
+name minus the hyphen, but may contain uppercase letters at word
+boundaries; the class name is usually just the resource
+name with an initial capital, but not always. For example, here are
+the option, resource, and class names for several Tk [cmd text]
+widget options:
+
+[para]
+[example { -background background Background
+ -borderwidth borderWidth BorderWidth
+ -insertborderwidth insertBorderWidth BorderWidth
+ -padx padX Pad
+}]
+[para]
+
+As is easily seen, sometimes the resource and class names can be
+inferred from the option name, but not always.
+
+
+[subsection {What are the resource and class names for my megawidget's options?}]
+
+For options implicitly delegated to a component using
+[cmd {delegate option *}], the resource and class names will be
+exactly those defined by the component. The [cmd configure] method
+returns these names, along with the option's default and current
+values:
+
+[para]
+[example {% snit::widget mytext {
+ delegate option * to text
+
+ constructor {args} {
+ install text using text .text
+ # ...
+ }
+
+ # ...
+}
+::mytext
+% mytext .text
+.text
+% .text configure -padx
+-padx padX Pad 1 1
+%
+}]
+[para]
+
+For all other options (whether locally defined or explicitly
+delegated), the resource and class names can be defined explicitly, or
+they can be allowed to have default values.
+
+[para]
+
+By default, the resource name is just the option name minus the
+hyphen; the the class name is just the option name with an initial
+capital letter. For example, suppose we explicitly delegate "-padx":
+
+[para]
+[example {% snit::widget mytext {
+ option -myvalue 5
+
+ delegate option -padx to text
+ delegate option * to text
+
+ constructor {args} {
+ install text using text .text
+ # ...
+ }
+
+ # ...
+}
+::mytext
+% mytext .text
+.text
+% .text configure -myvalue
+-myvalue myvalue Myvalue 5 5
+% .text configure -padx
+-padx padx Padx 1 1
+%
+}]
+[para]
+
+Here the resource and class names are chosen using the default rules.
+Often these rules are sufficient, but in the case of "-padx" we'd most
+likely prefer that the option's resource and class names are the same
+as for the built-in Tk widgets. This is easily done:
+
+[para]
+[example {% snit::widget mytext {
+ delegate option {-padx padX Pad} to text
+
+ # ...
+}
+::mytext
+% mytext .text
+.text
+% .text configure -padx
+-padx padX Pad 1 1
+%
+}]
+
+
+[subsection {How does Snit initialize my megawidget's locally-defined options?}]
+
+The option database is queried for each of the megawidget's
+locally-defined options, using the option's resource and class name.
+If the result isn't "", then it replaces the default value given in
+widget definition. In either case, the default can be overridden by
+the caller. For example,
+
+[para]
+[example {option add *Mywidget.texture pebbled
+
+snit::widget mywidget {
+ option -texture smooth
+ # ...
+}
+
+mywidget .mywidget -texture greasy
+}]
+[para]
+
+Here, [const -texture] would normally default to "smooth", but because of
+the entry added to the option database it defaults to "pebbled".
+However, the caller has explicitly overridden the default, and so the
+new widget will be "greasy".
+
+[subsection {How does Snit initialize delegated options?}]
+
+That depends on whether the options are delegated to the hull, or to
+some other component.
+
+
+[subsection {How does Snit initialize options delegated to the hull?}]
+
+A [cmd snit::widget]'s hull is a widget, and given that its class has
+been set it is expected to query the option database for itself. The
+only exception concerns options that are delegated to it with a
+different name. Consider the following code:
+
+[para]
+[example {option add *Mywidget.borderWidth 5
+option add *Mywidget.relief sunken
+option add *Mywidget.hullbackground red
+option add *Mywidget.background green
+
+snit::widget mywidget {
+ delegate option -borderwidth to hull
+ delegate option -hullbackground to hull as -background
+ delegate option * to hull
+ # ...
+}
+
+mywidget .mywidget
+
+set A [.mywidget cget -relief]
+set B [.mywidget cget -hullbackground]
+set C [.mywidget cget -background]
+set D [.mywidget cget -borderwidth]
+}]
+[para]
+
+The question is, what are the values of variables A, B, C and D?
+
+[para]
+
+The value of A is "sunken". The hull is a Tk frame which has been
+given the widget class [const Mywidget]; it will automatically query the
+option database and pick up this value. Since the [const -relief] option is
+implicitly delegated to the hull, Snit takes no action.
+
+[para]
+
+The value of B is "red". The hull will automatically pick up the
+value "green" for its [const -background] option, just as it picked up the
+[const -relief] value. However, Snit knows that [const -hullbackground]
+is mapped to the hull's [const -background] option; hence, it queries
+the option database for [const -hullbackground] and gets "red" and
+updates the hull accordingly.
+
+[para]
+
+The value of C is also "red", because [const -background] is implicitly
+delegated to the hull; thus, retrieving it is the same as retrieving
+[const -hullbackground]. Note that this case is unusual; the
+[const -background] option should probably have been excluded using the delegate
+statement's [const except] clause, or (more likely) delegated to some other
+component.
+
+[para]
+
+The value of D is "5", but not for the reason you think. Note that as
+it is defined above, the resource name for [const -borderwidth] defaults to
+[const borderwidth], whereas the option database entry is
+[const borderWidth], in
+accordance with the standard Tk naming for this option. As with
+[const -relief], the hull picks up its own [const -borderwidth]
+option before Snit
+does anything. Because the option is delegated under its own name,
+Snit assumes that the correct thing has happened, and doesn't worry
+about it any further. To avoid confusion, the
+[const -borderwidth] option
+should have been delegated like this:
+
+[para]
+[example { delegate option {-borderwidth borderWidth BorderWidth} to hull
+}]
+[para]
+
+For [cmd snit::widgetadaptor]s, the case is somewhat altered. Widget
+adaptors retain the widget class of their hull, and the hull is not
+created automatically by Snit. Instead, the [cmd snit::widgetadaptor]
+must call [cmd installhull] in its constructor. The normal way
+to do this is as follows:
+
+[para]
+[example {snit::widgetadaptor mywidget {
+ # ...
+ constructor {args} {
+ # ...
+ installhull using text -foreground white
+ # ...
+ }
+ # ...
+}
+}]
+[para]
+
+In this case, the [cmd installhull] command will create the hull using
+a command like this:
+
+[para]
+[example { set hull [text $win -foreground white]
+}]
+[para]
+
+The hull is a [cmd text] widget, so its widget class is [const Text]. Just
+as with [cmd snit::widget] hulls, Snit assumes that it will pick up
+all of its normal option values automatically, without help from Snit.
+Options delegated from a different name are initialized from the
+option database in the same way as described above.
+
+[para]
+
+In earlier versions of Snit, [cmd snit::widgetadaptor]s were expected
+to call [cmd installhull] like this:
+
+[para]
+[example { installhull [text $win -foreground white]
+}]
+[para]
+
+This form still works--but Snit will not query the option database as
+described above.
+
+[subsection {How does Snit initialize options delegated to other components?}]
+
+For hull components, Snit assumes that Tk will do most of the work
+automatically. Non-hull components are somewhat more complicated, because
+they are matched against the option database twice.
+
+[para]
+
+A component widget remains a widget still, and is therefore
+initialized from the option database in the usual way. A [cmd text]
+widget remains a [cmd text] widget whether it is a component of a
+megawidget or not, and will be created as such.
+
+[para]
+
+But then, the option database is queried for all options delegated to
+the component, and the component is initialized accordingly--provided
+that the [cmd install] command is used to create it.
+
+[para]
+
+Before option database support was added to Snit, the usual way to
+create a component was to simply create it in the constructor and
+assign its command name to the component variable:
+
+[para]
+[example {snit::widget mywidget {
+ delegate option -background to myComp
+
+ constructor {args} {
+ set myComp [text $win.text -foreground black]
+ }
+}
+}]
+[para]
+
+The drawback of this method is that Snit has no opportunity to
+initialize the component properly. Hence, the following approach is
+now used:
+
+[para]
+[example {snit::widget mywidget {
+ delegate option -background to myComp
+
+ constructor {args} {
+ install myComp using text $win.text -foreground black
+ }
+}
+}]
+[para]
+
+The [cmd install] command does the following:
+
+[para]
+[list_begin itemized]
+
+[item]
+
+Builds a list of the options explicitly included in the [cmd install]
+command--in this case, [const -foreground].
+
+[item]
+
+Queries the option database for all options delegated explicitly to
+the named component.
+
+[item]
+
+Creates the component using the specified command, after inserting
+into it a list of options and values read from the option database.
+Thus, the explicitly included options (like [const -foreground]) will
+override anything read from the option database.
+
+[item]
+
+If the widget definition implicitly delegated options to the component
+using [cmd {delegate option *}], then Snit calls the newly created
+component's [cmd configure] method to receive a list of all of the
+component's options. From this Snit builds a list of options
+implicitly delegated to the component which were not explicitly
+included in the [cmd install] command. For all such options, Snit
+queries the option database and configures the component accordingly.
+
+[list_end]
+
+You don't really need to know all of this; just use [cmd install] to
+install your components, and Snit will try to do the right thing.
+
+[subsection {What happens if I install a non-widget as a component of widget?}]
+
+A [cmd snit::type] never queries the option database.
+However, a [cmd snit::widget] can have non-widget components. And if
+options are delegated to those components, and if the [cmd install]
+command is used to install those components, then they will be
+initialized from the option database just as widget components are.
+
+[para]
+
+However, when used within a megawidget, [cmd install] assumes that the
+created component uses a reasonably standard widget-like creation
+syntax. If it doesn't, don't use [cmd install].
+
+[section {ENSEMBLE COMMANDS}]
+
+[subsection {What is an ensemble command?}]
+
+An ensemble command is a command with subcommands. Snit objects are
+all ensemble commands; however, the term more usually refers to
+commands like the standard Tcl commands [cmd string], [cmd file],
+and [cmd clock]. In a sense, these are singleton objects--there's
+only one instance of them.
+
+[subsection {How can I create an ensemble command using Snit?}]
+
+There are two ways--as a [cmd snit::type], or as an instance of
+a [cmd snit::type].
+
+[subsection {How can I create an ensemble command using an instance of a snit::type?}]
+
+Define a type whose [sectref {INSTANCE METHODS}] are the subcommands
+of your ensemble command. Then, create an instance of the type with
+the desired name.
+
+[para]
+
+For example, the following code uses [sectref {DELEGATION}] to create
+a work-alike for the standard [cmd string] command:
+
+[example {snit::type ::mynamespace::mystringtype {
+ delegate method * to stringhandler
+
+ constructor {} {
+ set stringhandler string
+ }
+}
+
+::mynamespace::mystringtype mystring
+}]
+
+We create the type in a namespace, so that the type command is hidden;
+then we create a single instance with the desired name--
+[cmd mystring], in this case.
+
+[para]
+
+This method has two drawbacks. First, it leaves the type command
+floating about. More seriously, your shiny new ensemble
+command will have [method info] and [method destroy] subcommands that
+you probably have no use for. But read on.
+
+[subsection {How can I create an ensemble command using a snit::type?}]
+
+Define a type whose [sectref {TYPE METHODS}] are the subcommands
+of your ensemble command.[para]
+
+For example, the following code uses [sectref {DELEGATION}] to create
+a work-alike for the standard [cmd string] command:
+
+[example {snit::type mystring {
+ delegate typemethod * to stringhandler
+
+ typeconstructor {
+ set stringhandler string
+ }
+}
+}]
+
+Now the type command itself is your ensemble command.
+
+[para]
+
+This method has only one drawback, and though it's major, it's
+also surmountable. Your new ensemble command will have
+[method create], [method info] and [method destroy] subcommands
+you don't want. And worse yet, since the [method create] method
+can be implicit, users of your command will accidentally be creating
+instances of your [cmd mystring] type if they should mispell one
+of the subcommands. The command will succeed--the first time--but
+won't do what's wanted. This is very bad.
+
+[para]
+
+The work around is to set some [sectref {PRAGMAS}], as shown here:
+
+[example {snit::type mystring {
+ pragma -hastypeinfo no
+ pragma -hastypedestroy no
+ pragma -hasinstances no
+
+ delegate typemethod * to stringhandler
+
+ typeconstructor {
+ set stringhandler string
+ }
+}
+}]
+
+Here we've used the [cmd pragma] statement to tell Snit that we don't
+want the [method info] typemethod or the [method destroy] typemethod,
+and that our type has no instances; this eliminates the
+[method create] typemethod and all related code. As
+a result, our ensemble command will be well-behaved, with no
+unexpected subcommands.
+
+[section {PRAGMAS}]
+
+[subsection {What is a pragma?}]
+
+A pragma is an option you can set in your type definitions that
+affects how the type is defined and how it works once it is defined.
+
+[subsection {How do I set a pragma?}]
+
+Use the [cmd pragma] statement. Each pragma is an option with a
+value; each time you use the [cmd pragma] statement you can set one or
+more of them.
+
+[subsection {How can I get rid of the "info" type method?}]
+
+Set the [const -hastypeinfo] pragma to [const no]:
+
+[example {snit::type dog {
+ pragma -hastypeinfo no
+ # ...
+}
+}]
+
+Snit will refrain from defining the [method info] type method.
+
+[subsection {How can I get rid of the "destroy" type method?}]
+
+Set the [const -hastypedestroy] pragma to [const no]:
+
+[example {snit::type dog {
+ pragma -hastypedestroy no
+ # ...
+}
+}]
+
+Snit will refrain from defining the [method destroy] type method.
+
+[subsection {How can I get rid of the "create" type method?}]
+
+Set the [const -hasinstances] pragma to [const no]:
+
+[example {snit::type dog {
+ pragma -hasinstances no
+ # ...
+}
+}]
+
+Snit will refrain from defining the [method create] type method;
+if you call the type command with an unknown method name, you'll get
+an error instead of a new instance of the type.
+
+[para]
+
+This is useful if you wish to use a [cmd snit::type] to define
+an ensemble command rather than a type with instances.
+
+[para]
+
+Pragmas [const -hastypemethods] and [const -hasinstances] cannot
+both be false (or there'd be nothing left).
+
+[subsection {How can I get rid of type methods altogether?}]
+
+Normal Tk widget type commands don't have subcommands; all they do is
+create widgets--in Snit terms, the type command calls the
+[method create] type method directly. To get the same behavior from
+Snit, set the [const -hastypemethods] pragma to [const no]:
+
+[example {snit::type dog {
+ pragma -hastypemethods no
+ #...
+}
+
+# Creates ::spot
+dog spot
+
+# Tries to create an instance called ::create
+dog create spot
+}]
+
+Pragmas [const -hastypemethods] and [const -hasinstances] cannot
+both be false (or there'd be nothing left).
+
+[subsection {Why can't I create an object that replaces an old object with the same name?}]
+
+Up until Snit 0.95, you could use any name for an instance of a
+[cmd snit::type], even if the name was already in use by some other
+object or command. You could do the following, for example:
+
+[example {snit::type dog { ... }
+
+dog proc
+}]
+
+You now have a new dog named "proc", which is probably not something
+that you really wanted to do. As a result, Snit now throws an error
+if your chosen instance name names an existing command. To restore
+the old behavior, set the [const -canreplace] pragma to [const yes]:
+
+[example {snit::type dog {
+ pragma -canreplace yes
+ # ...
+}
+}]
+
+[subsection {How can I make my simple type run faster?}]
+
+In Snit 1.x, you can set the [const -simpledispatch] pragma to [const yes].
+
+[para]
+
+Snit 1.x method dispatch is both flexible and fast, but the flexibility
+comes with a price. If your type doesn't require the flexibility, the
+[const -simpledispatch] pragma allows you to substitute a simpler
+dispatch mechanism that runs quite a bit faster. The limitations
+are these:
+
+[list_begin itemized]
+
+[item] Methods cannot be delegated.
+[item] [cmd uplevel] and [cmd upvar] do not work as expected: the
+caller's scope is two levels up rather than one.
+[item] The option-handling methods
+([cmd cget], [cmd configure], and [cmd configurelist]) are very
+slightly slower.
+[list_end]
+
+In Snit 2.2, the [const -simpledispatch] macro is obsolete, and
+ignored; all Snit 2.2 method dispatch is faster than Snit 1.x's
+[const -simpledispatch].
+
+[section {MACROS}]
+
+[subsection {What is a macro?}]
+
+A Snit macro is nothing more than a Tcl proc that's defined in the
+Tcl interpreter used to compile Snit type definitions.
+
+[subsection {What are macros good for?}]
+
+You can use Snit macros to define new type definition syntax, and to
+support conditional compilation.
+
+[subsection {How do I do conditional compilation?}]
+
+Suppose you want your type to use a fast C extension if it's
+available; otherwise, you'll fallback to a slower Tcl implementation.
+You want to define one set of methods in the first case, and another
+set in the second case. But how can your type definition know whether
+the fast C extension is available or not?
+
+[para]
+
+It's easily done. Outside of any type definition, define a macro that
+returns 1 if the extension is available, and 0 otherwise:
+
+[example {if {$gotFastExtension} {
+ snit::macro fastcode {} {return 1}
+} else {
+ snit::macro fastcode {} {return 0}
+}
+}]
+
+Then, use your macro in your type definition:
+
+[example {snit::type dog {
+
+ if {[fastcode]} {
+ # Fast methods
+ method bark {} {...}
+ method wagtail {} {...}
+ } else {
+ # Slow methods
+ method bark {} {...}
+ method wagtail {} {...}
+ }
+}
+}]
+
+[subsection {How do I define new type definition syntax?}]
+
+Use a macro. For example, your [cmd snit::widget]'s
+[const -background] option should be propagated to a number
+of component widgets. You could implement that like this:
+
+[example {snit::widget mywidget {
+ option -background -default white -configuremethod PropagateBackground
+
+ method PropagateBackground {option value} {
+ $comp1 configure $option $value
+ $comp2 configure $option $value
+ $comp3 configure $option $value
+ }
+}
+}]
+
+For one option, this is fine; if you've got a number of options, it
+becomes tedious and error prone. So package it as a macro:
+
+[example {snit::macro propagate {option "to" components} {
+ option $option -configuremethod Propagate$option
+
+ set body "\n"
+
+ foreach comp $components {
+ append body "\$$comp configure $option \$value\n"
+ }
+
+ method Propagate$option {option value} $body
+}
+}]
+
+Then you can use it like this:
+
+[example {snit::widget mywidget {
+ option -background default -white
+ option -foreground default -black
+
+ propagate -background to {comp1 comp2 comp3}
+ propagate -foreground to {comp1 comp2 comp3}
+}
+}]
+
+[subsection {Are there are restrictions on macro names?}]
+
+Yes, there are. You can't redefine any standard Tcl commands or Snit
+type definition statements. You can use any other command name,
+including the name of a previously defined macro.
+
+[para]
+
+If you're using Snit macros in your application, go ahead and name
+them in the global namespace, as shown above. But if you're using
+them to define types or widgets for use by others, you should define
+your macros in the same namespace as your types or widgets. That way,
+they won't conflict with other people's macros.
+
+[para]
+
+If my fancy [cmd snit::widget] is called [cmd ::mylib::mywidget],
+for example, then I should define my [cmd propagate] macro as
+[cmd ::mylib::propagate]:
+
+
+[example {snit::macro mylib::propagate {option "to" components} { ... }
+
+snit::widget ::mylib::mywidget {
+ option -background default -white
+ option -foreground default -black
+
+ mylib::propagate -background to {comp1 comp2 comp3}
+ mylib::propagate -foreground to {comp1 comp2 comp3}
+}
+}]
+
+
+[section {BUGS, IDEAS, FEEDBACK}]
+
+This document, and the package it describes, will undoubtedly contain
+bugs and other problems.
+
+Please report such in the category [emph snit] of the
+[uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}].
+
+Please also report any ideas for enhancements you may have for either
+package and/or documentation.
+
+
+[keywords class {object oriented} object C++]
+[keywords {Incr Tcl} BWidget]
+[keywords widget adaptors {widget adaptors} {mega widget}]
+[manpage_end]
--- /dev/null
+#-----------------------------------------------------------------------
+# TITLE:
+# validate.tcl
+#
+# AUTHOR:
+# Will Duquette
+#
+# DESCRIPTION:
+# Snit validation types.
+#
+#-----------------------------------------------------------------------
+
+namespace eval ::snit:: {
+ namespace export \
+ boolean \
+ double \
+ enum \
+ fpixels \
+ integer \
+ listtype \
+ pixels \
+ stringtype \
+ window
+}
+
+#-----------------------------------------------------------------------
+# snit::boolean
+
+snit::type ::snit::boolean {
+ #-------------------------------------------------------------------
+ # Type Methods
+
+ typemethod validate {value} {
+ if {![string is boolean -strict $value]} {
+ return -code error -errorcode INVALID \
+ "invalid boolean \"$value\", should be one of: 1, 0, true, false, yes, no, on, off"
+
+ }
+
+ return $value
+ }
+
+ #-------------------------------------------------------------------
+ # Constructor
+
+ # None needed; no options
+
+ #-------------------------------------------------------------------
+ # Public Methods
+
+ method validate {value} {
+ $type validate $value
+ }
+}
+
+#-----------------------------------------------------------------------
+# snit::double
+
+snit::type ::snit::double {
+ #-------------------------------------------------------------------
+ # Options
+
+ # -min value
+ #
+ # Minimum value
+
+ option -min -default "" -readonly 1
+
+ # -max value
+ #
+ # Maximum value
+
+ option -max -default "" -readonly 1
+
+ #-------------------------------------------------------------------
+ # Type Methods
+
+ typemethod validate {value} {
+ if {![string is double -strict $value]} {
+ return -code error -errorcode INVALID \
+ "invalid value \"$value\", expected double"
+ }
+
+ return $value
+ }
+
+ #-------------------------------------------------------------------
+ # Constructor
+
+ constructor {args} {
+ # FIRST, get the options
+ $self configurelist $args
+
+ if {"" != $options(-min) &&
+ ![string is double -strict $options(-min)]} {
+ return -code error \
+ "invalid -min: \"$options(-min)\""
+ }
+
+ if {"" != $options(-max) &&
+ ![string is double -strict $options(-max)]} {
+ return -code error \
+ "invalid -max: \"$options(-max)\""
+ }
+
+ if {"" != $options(-min) &&
+ "" != $options(-max) &&
+ $options(-max) < $options(-min)} {
+ return -code error "-max < -min"
+ }
+ }
+
+ #-------------------------------------------------------------------
+ # Public Methods
+
+ # Fixed method for the snit::double type.
+ # WHD, 6/7/2010.
+ method validate {value} {
+ $type validate $value
+
+ if {("" != $options(-min) && $value < $options(-min)) ||
+ ("" != $options(-max) && $value > $options(-max))} {
+
+ set msg "invalid value \"$value\", expected double"
+
+ if {"" != $options(-min) && "" != $options(-max)} {
+ append msg " in range $options(-min), $options(-max)"
+ } elseif {"" != $options(-min)} {
+ append msg " no less than $options(-min)"
+ } elseif {"" != $options(-max)} {
+ append msg " no greater than $options(-max)"
+ }
+
+ return -code error -errorcode INVALID $msg
+ }
+
+ return $value
+ }
+}
+
+#-----------------------------------------------------------------------
+# snit::enum
+
+snit::type ::snit::enum {
+ #-------------------------------------------------------------------
+ # Options
+
+ # -values list
+ #
+ # Valid values for this type
+
+ option -values -default {} -readonly 1
+
+ #-------------------------------------------------------------------
+ # Type Methods
+
+ typemethod validate {value} {
+ # No -values specified; it's always valid
+ return $value
+ }
+
+ #-------------------------------------------------------------------
+ # Constructor
+
+ constructor {args} {
+ $self configurelist $args
+
+ if {[llength $options(-values)] == 0} {
+ return -code error \
+ "invalid -values: \"\""
+ }
+ }
+
+ #-------------------------------------------------------------------
+ # Public Methods
+
+ method validate {value} {
+ if {[lsearch -exact $options(-values) $value] == -1} {
+ return -code error -errorcode INVALID \
+ "invalid value \"$value\", should be one of: [join $options(-values) {, }]"
+ }
+
+ return $value
+ }
+}
+
+#-----------------------------------------------------------------------
+# snit::fpixels
+
+snit::type ::snit::fpixels {
+ #-------------------------------------------------------------------
+ # Options
+
+ # -min value
+ #
+ # Minimum value
+
+ option -min -default "" -readonly 1
+
+ # -max value
+ #
+ # Maximum value
+
+ option -max -default "" -readonly 1
+
+ #-------------------------------------------------------------------
+ # Instance variables
+
+ variable min "" ;# -min, no suffix
+ variable max "" ;# -max, no suffix
+
+ #-------------------------------------------------------------------
+ # Type Methods
+
+ typemethod validate {value} {
+ if {[catch {winfo fpixels . $value} dummy]} {
+ return -code error -errorcode INVALID \
+ "invalid value \"$value\", expected fpixels"
+ }
+
+ return $value
+ }
+
+ #-------------------------------------------------------------------
+ # Constructor
+
+ constructor {args} {
+ # FIRST, get the options
+ $self configurelist $args
+
+ if {"" != $options(-min) &&
+ [catch {winfo fpixels . $options(-min)} min]} {
+ return -code error \
+ "invalid -min: \"$options(-min)\""
+ }
+
+ if {"" != $options(-max) &&
+ [catch {winfo fpixels . $options(-max)} max]} {
+ return -code error \
+ "invalid -max: \"$options(-max)\""
+ }
+
+ if {"" != $min &&
+ "" != $max &&
+ $max < $min} {
+ return -code error "-max < -min"
+ }
+ }
+
+ #-------------------------------------------------------------------
+ # Public Methods
+
+ method validate {value} {
+ $type validate $value
+
+ set val [winfo fpixels . $value]
+
+ if {("" != $min && $val < $min) ||
+ ("" != $max && $val > $max)} {
+
+ set msg "invalid value \"$value\", expected fpixels"
+
+ if {"" != $min && "" != $max} {
+ append msg " in range $options(-min), $options(-max)"
+ } elseif {"" != $min} {
+ append msg " no less than $options(-min)"
+ }
+
+ return -code error -errorcode INVALID $msg
+ }
+
+ return $value
+ }
+}
+
+#-----------------------------------------------------------------------
+# snit::integer
+
+snit::type ::snit::integer {
+ #-------------------------------------------------------------------
+ # Options
+
+ # -min value
+ #
+ # Minimum value
+
+ option -min -default "" -readonly 1
+
+ # -max value
+ #
+ # Maximum value
+
+ option -max -default "" -readonly 1
+
+ #-------------------------------------------------------------------
+ # Type Methods
+
+ typemethod validate {value} {
+ if {![string is integer -strict $value]} {
+ return -code error -errorcode INVALID \
+ "invalid value \"$value\", expected integer"
+ }
+
+ return $value
+ }
+
+ #-------------------------------------------------------------------
+ # Constructor
+
+ constructor {args} {
+ # FIRST, get the options
+ $self configurelist $args
+
+ if {"" != $options(-min) &&
+ ![string is integer -strict $options(-min)]} {
+ return -code error \
+ "invalid -min: \"$options(-min)\""
+ }
+
+ if {"" != $options(-max) &&
+ ![string is integer -strict $options(-max)]} {
+ return -code error \
+ "invalid -max: \"$options(-max)\""
+ }
+
+ if {"" != $options(-min) &&
+ "" != $options(-max) &&
+ $options(-max) < $options(-min)} {
+ return -code error "-max < -min"
+ }
+ }
+
+ #-------------------------------------------------------------------
+ # Public Methods
+
+ method validate {value} {
+ $type validate $value
+
+ if {("" != $options(-min) && $value < $options(-min)) ||
+ ("" != $options(-max) && $value > $options(-max))} {
+
+ set msg "invalid value \"$value\", expected integer"
+
+ if {"" != $options(-min) && "" != $options(-max)} {
+ append msg " in range $options(-min), $options(-max)"
+ } elseif {"" != $options(-min)} {
+ append msg " no less than $options(-min)"
+ }
+
+ return -code error -errorcode INVALID $msg
+ }
+
+ return $value
+ }
+}
+
+#-----------------------------------------------------------------------
+# snit::list
+
+snit::type ::snit::listtype {
+ #-------------------------------------------------------------------
+ # Options
+
+ # -type type
+ #
+ # Specifies a value type
+
+ option -type -readonly 1
+
+ # -minlen len
+ #
+ # Minimum list length
+
+ option -minlen -readonly 1 -default 0
+
+ # -maxlen len
+ #
+ # Maximum list length
+
+ option -maxlen -readonly 1
+
+ #-------------------------------------------------------------------
+ # Type Methods
+
+ typemethod validate {value} {
+ if {[catch {llength $value} result]} {
+ return -code error -errorcode INVALID \
+ "invalid value \"$value\", expected list"
+ }
+
+ return $value
+ }
+
+ #-------------------------------------------------------------------
+ # Constructor
+
+ constructor {args} {
+ # FIRST, get the options
+ $self configurelist $args
+
+ if {"" != $options(-minlen) &&
+ (![string is integer -strict $options(-minlen)] ||
+ $options(-minlen) < 0)} {
+ return -code error \
+ "invalid -minlen: \"$options(-minlen)\""
+ }
+
+ if {"" == $options(-minlen)} {
+ set options(-minlen) 0
+ }
+
+ if {"" != $options(-maxlen) &&
+ ![string is integer -strict $options(-maxlen)]} {
+ return -code error \
+ "invalid -maxlen: \"$options(-maxlen)\""
+ }
+
+ if {"" != $options(-maxlen) &&
+ $options(-maxlen) < $options(-minlen)} {
+ return -code error "-maxlen < -minlen"
+ }
+ }
+
+
+ #-------------------------------------------------------------------
+ # Methods
+
+ method validate {value} {
+ $type validate $value
+
+ set len [llength $value]
+
+ if {$len < $options(-minlen)} {
+ return -code error -errorcode INVALID \
+ "value has too few elements; at least $options(-minlen) expected"
+ } elseif {"" != $options(-maxlen)} {
+ if {$len > $options(-maxlen)} {
+ return -code error -errorcode INVALID \
+ "value has too many elements; no more than $options(-maxlen) expected"
+ }
+ }
+
+ # NEXT, check each value
+ if {"" != $options(-type)} {
+ foreach item $value {
+ set cmd $options(-type)
+ lappend cmd validate $item
+ uplevel \#0 $cmd
+ }
+ }
+
+ return $value
+ }
+}
+
+#-----------------------------------------------------------------------
+# snit::pixels
+
+snit::type ::snit::pixels {
+ #-------------------------------------------------------------------
+ # Options
+
+ # -min value
+ #
+ # Minimum value
+
+ option -min -default "" -readonly 1
+
+ # -max value
+ #
+ # Maximum value
+
+ option -max -default "" -readonly 1
+
+ #-------------------------------------------------------------------
+ # Instance variables
+
+ variable min "" ;# -min, no suffix
+ variable max "" ;# -max, no suffix
+
+ #-------------------------------------------------------------------
+ # Type Methods
+
+ typemethod validate {value} {
+ if {[catch {winfo pixels . $value} dummy]} {
+ return -code error -errorcode INVALID \
+ "invalid value \"$value\", expected pixels"
+ }
+
+ return $value
+ }
+
+ #-------------------------------------------------------------------
+ # Constructor
+
+ constructor {args} {
+ # FIRST, get the options
+ $self configurelist $args
+
+ if {"" != $options(-min) &&
+ [catch {winfo pixels . $options(-min)} min]} {
+ return -code error \
+ "invalid -min: \"$options(-min)\""
+ }
+
+ if {"" != $options(-max) &&
+ [catch {winfo pixels . $options(-max)} max]} {
+ return -code error \
+ "invalid -max: \"$options(-max)\""
+ }
+
+ if {"" != $min &&
+ "" != $max &&
+ $max < $min} {
+ return -code error "-max < -min"
+ }
+ }
+
+ #-------------------------------------------------------------------
+ # Public Methods
+
+ method validate {value} {
+ $type validate $value
+
+ set val [winfo pixels . $value]
+
+ if {("" != $min && $val < $min) ||
+ ("" != $max && $val > $max)} {
+
+ set msg "invalid value \"$value\", expected pixels"
+
+ if {"" != $min && "" != $max} {
+ append msg " in range $options(-min), $options(-max)"
+ } elseif {"" != $min} {
+ append msg " no less than $options(-min)"
+ }
+
+ return -code error -errorcode INVALID $msg
+ }
+
+ return $value
+ }
+}
+
+#-----------------------------------------------------------------------
+# snit::stringtype
+
+snit::type ::snit::stringtype {
+ #-------------------------------------------------------------------
+ # Options
+
+ # -minlen len
+ #
+ # Minimum list length
+
+ option -minlen -readonly 1 -default 0
+
+ # -maxlen len
+ #
+ # Maximum list length
+
+ option -maxlen -readonly 1
+
+ # -nocase 0|1
+ #
+ # globs and regexps are case-insensitive if -nocase 1.
+
+ option -nocase -readonly 1 -default 0
+
+ # -glob pattern
+ #
+ # Glob-match pattern, or ""
+
+ option -glob -readonly 1
+
+ # -regexp regexp
+ #
+ # Regular expression to match
+
+ option -regexp -readonly 1
+
+ #-------------------------------------------------------------------
+ # Type Methods
+
+ typemethod validate {value} {
+ # By default, any string (hence, any Tcl value) is valid.
+ return $value
+ }
+
+ #-------------------------------------------------------------------
+ # Constructor
+
+ constructor {args} {
+ # FIRST, get the options
+ $self configurelist $args
+
+ # NEXT, validate -minlen and -maxlen
+ if {"" != $options(-minlen) &&
+ (![string is integer -strict $options(-minlen)] ||
+ $options(-minlen) < 0)} {
+ return -code error \
+ "invalid -minlen: \"$options(-minlen)\""
+ }
+
+ if {"" == $options(-minlen)} {
+ set options(-minlen) 0
+ }
+
+ if {"" != $options(-maxlen) &&
+ ![string is integer -strict $options(-maxlen)]} {
+ return -code error \
+ "invalid -maxlen: \"$options(-maxlen)\""
+ }
+
+ if {"" != $options(-maxlen) &&
+ $options(-maxlen) < $options(-minlen)} {
+ return -code error "-maxlen < -minlen"
+ }
+
+ # NEXT, validate -nocase
+ if {[catch {snit::boolean validate $options(-nocase)} result]} {
+ return -code error "invalid -nocase: $result"
+ }
+
+ # Validate the glob
+ if {"" != $options(-glob) &&
+ [catch {string match $options(-glob) ""} dummy]} {
+ return -code error \
+ "invalid -glob: \"$options(-glob)\""
+ }
+
+ # Validate the regexp
+ if {"" != $options(-regexp) &&
+ [catch {regexp $options(-regexp) ""} dummy]} {
+ return -code error \
+ "invalid -regexp: \"$options(-regexp)\""
+ }
+ }
+
+
+ #-------------------------------------------------------------------
+ # Methods
+
+ method validate {value} {
+ # Usually we'd call [$type validate $value] here, but
+ # as it's a no-op, don't bother.
+
+ # FIRST, validate the length.
+ set len [string length $value]
+
+ if {$len < $options(-minlen)} {
+ return -code error -errorcode INVALID \
+ "too short: at least $options(-minlen) characters expected"
+ } elseif {"" != $options(-maxlen)} {
+ if {$len > $options(-maxlen)} {
+ return -code error -errorcode INVALID \
+ "too long: no more than $options(-maxlen) characters expected"
+ }
+ }
+
+ # NEXT, check the glob match, with or without case.
+ if {"" != $options(-glob)} {
+ if {$options(-nocase)} {
+ set result [string match -nocase $options(-glob) $value]
+ } else {
+ set result [string match $options(-glob) $value]
+ }
+
+ if {!$result} {
+ return -code error -errorcode INVALID \
+ "invalid value \"$value\""
+ }
+ }
+
+ # NEXT, check regexp match with or without case
+ if {"" != $options(-regexp)} {
+ if {$options(-nocase)} {
+ set result [regexp -nocase -- $options(-regexp) $value]
+ } else {
+ set result [regexp -- $options(-regexp) $value]
+ }
+
+ if {!$result} {
+ return -code error -errorcode INVALID \
+ "invalid value \"$value\""
+ }
+ }
+
+ return $value
+ }
+}
+
+#-----------------------------------------------------------------------
+# snit::window
+
+snit::type ::snit::window {
+ #-------------------------------------------------------------------
+ # Type Methods
+
+ typemethod validate {value} {
+ if {![winfo exists $value]} {
+ return -code error -errorcode INVALID \
+ "invalid value \"$value\", value is not a window"
+ }
+
+ return $value
+ }
+
+ #-------------------------------------------------------------------
+ # Constructor
+
+ # None needed; no options
+
+ #-------------------------------------------------------------------
+ # Public Methods
+
+ method validate {value} {
+ $type validate $value
+ }
+}
projects / scpubgit/TenDotTcl.git / commitdiff