From: Matt S Trout Date: Sat, 4 Aug 2012 16:09:31 +0000 (+0000) Subject: commit a copy of snit X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d4567ecb6ca5553f47cd984a8f0a584d8251731b;p=scpubgit%2FTenDotTcl.git commit a copy of snit --- diff --git a/snit/ChangeLog b/snit/ChangeLog new file mode 100644 index 0000000..66a3ec3 --- /dev/null +++ b/snit/ChangeLog @@ -0,0 +1,1183 @@ +2011-12-13 Andreas Kupries + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-01-24 Andreas Kupries + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2010-06-07 Andreas Kupries + + * 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 + + * snitfaq.man: Fixed typo in 'package require' commands, reported + by sigzero@gmail.com. + +2009-12-07 Andreas Kupries + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2009-11-16 Andreas Kupries + + * 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 + + * 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 + + * 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 + + * snit.test: Updated to handle changes in command error messages + done in Tcl 8.6+. + +2009-09-28 Andreas Kupries + + * 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 + + * 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 + + * 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 + + * + * Released and tagged Tcllib 1.11.1 ======================== + * + +2008-10-16 Andreas Kupries + + * + * Released and tagged Tcllib 1.11 ======================== + * + +2008-08-20 Will Duquette + + * snitfaq.man: Finished up [SF Tcllib Bug 1658089]. + +2008-05-16 Andreas Kupries + + * snitfaq.man: Fixed the sectref argument order issues. + +2008-05-15 Andreas Kupries + + * snitfaq.man: Updated to changes in doctools (sub)section + reference handling. + +2007-12-04 Andreas Kupries + + * snit.test: Updated some results to changes in the Tcl 8.5 + head. This fixes [SF Tcllib Bug 1844106], reported by Larry + Virden . Thanks. + +2007-09-12 Andreas Kupries + + * + * Released and tagged Tcllib 1.10 ======================== + * + +2007-08-20 Andreas Kupries + + * snit.test: Fixed bad indices in tests causing the generation of + bogus expected error messages. + +2007-07-03 Andreas Kupries + + * 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 + + * 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 + + * snitfaq.man: Replaced deprecated {expand} with {*}. + +2007-05-01 Andreas Kupries + + * main2.tcl: [Bug 1710640]. Replaced deprecated {expand} with {*}. + + * snit.test: Updated to changes in 8.5a6. + +2007-03-21 Andreas Kupries + + * 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 + + * snitfaq.man: Fixed typos, etc. reported in [Bug 1658089]. + +2006-10-19 Jeff Hobbs + + * 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 + + * + * Released and tagged Tcllib 1.9 ======================== + * + +2006-09-20 Will Duquette + * 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 + + * 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 + * 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 + * 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 + * main2.tcl, snit.test: Fixed Bug 1532791: "snit2, + snit::widget problem". + +2006-08-12 Will Duquette + * 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 + * snit.man: Added documentation for how to define new + validation types. + +2006-08-09 Will Duquette + * 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 + * 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 + * 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 + * 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 + * 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 + + * snitfaq.man: Finally fixed the two ambigous section titles. + +2006-01-30 Andreas Kupries + + * snit.tcl: Fixed [SF Tcllib Bug 1414589], prevent the package + activation code from stomping on the global variable 'dir'. + +2006-01-29 Andreas Kupries + + * snit.test: Fixed use of duplicate test names. Whitespace police + as well. + +2006-01-26 Andreas Kupries + + * snit.test: More boilerplate simplified via use of test support. + +2006-01-19 Andreas Kupries + + * 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 + + * 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 + + * snit83.tcl: Replaced the direct use of / path separator with a + proper file join. + +2005-11-07 Andreas Kupries + + * 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 + + * + * Released and tagged Tcllib 1.8 ======================== + * + +2005-09-26 Andreas Kupries + + * 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 + + * snitfaq.man: Updated for Snit 2.0/1.1. + +2005-08-27 Will Duquette + + * 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 + + * snit.tcl, snit2.tcl: allow labelframe and ttk::labelframe as + hulltypes, and tk::(label)frame (planning ahead ...) + +2005-08-20 Will Duquette + + * 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 + + * snit.tcl (::snit::Comp.statement.hulltype): make hulltype one of + $::snit::hulltypes, allow ttk::frame + +2005-06-07 Will Duquette + + * 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 + + * 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 + + * 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 + + * snit.tcl (::snit::RT.DestroyObject) + * snit.test (test bug-2.1, bug-2.2): + Fixed [SF Tcllib Bug 1106375]. + +2005-06-04 Will Duquette + + * snit.tcl (::snit::Comp.statement.destructor): + * snit.test (test bug-1.1) + Fixed [SF Tcllib Bug 1161779]. + +2005-06-04 Will Duquette + + * 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 + + * snit.man: Fixed typo in the -configuremethod example. + +2005-02-14 Andreas Kupries + + * snitfaq.man: Fixed a number of typos reported by Bob Techentin, + see [SF Tcllib Bug 1050674]. + +2004-10-05 Andreas Kupries + + * + * Released and tagged Tcllib 1.7 ======================== + * + +2004-09-23 Andreas Kupries + + * 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 + + * snit.man: Documented hierarchical methods and typemethods. + + * Everything: Updated version to 0.97. + +2004-09-16 Will Duquette + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * README.txt Updated to reflect recent changes. + * snit.man + +2004-07-20 Will Duquette + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 " 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-05-15 Will Duquette + + * 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 + + * snit.test: Codified the requirement of Tcl 8.4 into + * pkgIndex.tcl: package index and test suite. + +2004-02-15 Andreas Kupries + + * + * Released and tagged Tcllib 1.6 ======================== + * + +2004-02-07 Will Duquette + + * 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 + + * 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 + + * All: Updated version to 0.92. + + * snit.tcl Snit now propagates errorCode properly when + * snit.test propagating errors. + +2003-12-01 Andreas Kupries + + * snit.man: Updated to changes in the .html files. + * snitfaq.man: + +2003-11-21 Will Duquette + + * 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 + + * snit.man: Fixed typos in documentation. + * snitfaq.man: + +2003-10-27 Will Duquette + + * snit.html: Fixed typos in documentation. + * faq.html: + +2003-10-27 Andreas Kupries + + * snit.man: Updated to changes in the .html files. + * snitfaq.man: + +2003-10-25 Will Duquette + + * 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 + + * snit.man: Updated from Will's html doc's. + +2003-10-23 Will Duquette + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * README.txt: Updated to reflect snit's presence in tcllib, and + to point to this ChangeLog file. + +2003-09-30 Andreas Kupries + + * 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 + + * 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 + + * 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 + + * 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: diff --git a/snit/README.tcl83.txt b/snit/README.tcl83.txt new file mode 100644 index 0000000..aaaf61f --- /dev/null +++ b/snit/README.tcl83.txt @@ -0,0 +1,57 @@ +#-------------------------------------------------------------------------- +# 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. diff --git a/snit/README.txt b/snit/README.txt new file mode 100644 index 0000000..e2d3c00 --- /dev/null +++ b/snit/README.txt @@ -0,0 +1,829 @@ +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 {....} + + which means that if the user of a Snit widget needs to bind to + on the widget name they've just wiped out Snit's + destructor. Consequently, Snit now creates a bindtag called + + Snit + + 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. + + diff --git a/snit/dictionary.txt b/snit/dictionary.txt new file mode 100644 index 0000000..e2a739a --- /dev/null +++ b/snit/dictionary.txt @@ -0,0 +1,125 @@ +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) = { ? ?} + where is 1 if the method has submethods + (in which case the other fields + are missing) and 0 if it doesn't. + 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) = { ? ?} + where is 1 if the method has submethods + (in which case the other fields + are missing) and 0 if it doesn't. + 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. + + diff --git a/snit/license.txt b/snit/license.txt new file mode 100644 index 0000000..8406c2e --- /dev/null +++ b/snit/license.txt @@ -0,0 +1,38 @@ +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. diff --git a/snit/main1.tcl b/snit/main1.tcl new file mode 100644 index 0000000..9cbe480 --- /dev/null +++ b/snit/main1.tcl @@ -0,0 +1,3987 @@ +#----------------------------------------------------------------------- +# 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 + # event is received. Use a Snit-specific bindtag + # so that the widget name's tag is unencumbered. + + bind Snit$type$name [::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 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 "" + + 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 } 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 } 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 +} diff --git a/snit/main1_83.tcl b/snit/main1_83.tcl new file mode 100644 index 0000000..d8b16f6 --- /dev/null +++ b/snit/main1_83.tcl @@ -0,0 +1,4011 @@ +#----------------------------------------------------------------------- +# 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 + # event is received. Use a Snit-specific bindtag + # so that the widget name's tag is unencumbered. + + bind Snit$type$name [::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 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 "" + + 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 } 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 } 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 +} diff --git a/snit/main2.tcl b/snit/main2.tcl new file mode 100644 index 0000000..d8d4a6b --- /dev/null +++ b/snit/main2.tcl @@ -0,0 +1,3888 @@ +#----------------------------------------------------------------------- +# 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 + # event is received. Use a Snit-specific bindtag + # so that the widget name's tag is unencumbered. + + bind Snit$type$name [::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 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 "" + + 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 +} diff --git a/snit/modules.txt b/snit/modules.txt new file mode 100644 index 0000000..c82bb5b --- /dev/null +++ b/snit/modules.txt @@ -0,0 +1,11 @@ +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 diff --git a/snit/pkgIndex.tcl b/snit/pkgIndex.tcl new file mode 100644 index 0000000..ff47c61 --- /dev/null +++ b/snit/pkgIndex.tcl @@ -0,0 +1,6 @@ +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]] diff --git a/snit/roadmap.txt b/snit/roadmap.txt new file mode 100644 index 0000000..d65a36c --- /dev/null +++ b/snit/roadmap.txt @@ -0,0 +1,180 @@ +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 + diff --git a/snit/roadmap2.txt b/snit/roadmap2.txt new file mode 100644 index 0000000..9902b86 --- /dev/null +++ b/snit/roadmap2.txt @@ -0,0 +1,177 @@ +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 + diff --git a/snit/snit.man b/snit/snit.man new file mode 100644 index 0000000..81ebd46 --- /dev/null +++ b/snit/snit.man @@ -0,0 +1,2865 @@ +[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 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] diff --git a/snit/snit.tcl b/snit/snit.tcl new file mode 100644 index 0000000..375e51a --- /dev/null +++ b/snit/snit.tcl @@ -0,0 +1,41 @@ +#----------------------------------------------------------------------- +# 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 diff --git a/snit/snit.test b/snit/snit.test new file mode 100644 index 0000000..66d7bd1 --- /dev/null +++ b/snit/snit.test @@ -0,0 +1,9109 @@ +# -*- 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 {} + +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 {wag} 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 diff --git a/snit/snit2.tcl b/snit/snit2.tcl new file mode 100644 index 0000000..3240d71 --- /dev/null +++ b/snit/snit2.tcl @@ -0,0 +1,32 @@ +#----------------------------------------------------------------------- +# 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 diff --git a/snit/snit_tcl83_utils.tcl b/snit/snit_tcl83_utils.tcl new file mode 100644 index 0000000..9dba59b --- /dev/null +++ b/snit/snit_tcl83_utils.tcl @@ -0,0 +1,231 @@ +#-------------------------------------------------------------------------- +# 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 + } + } +} diff --git a/snit/snitfaq.man b/snit/snitfaq.man new file mode 100644 index 0000000..945aacf --- /dev/null +++ b/snit/snitfaq.man @@ -0,0 +1,4159 @@ +[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 ] 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] diff --git a/snit/validate.tcl b/snit/validate.tcl new file mode 100644 index 0000000..4275e9b --- /dev/null +++ b/snit/validate.tcl @@ -0,0 +1,720 @@ +#----------------------------------------------------------------------- +# 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 + } +}