1 #-----------------------------------------------------------------------
9 # Snit's Not Incr Tcl, a simple object system in Pure Tcl.
11 # Snit 2.x Compiler and Run-Time Library
13 # Copyright (C) 2003-2006 by William H. Duquette
14 # This code is licensed as described in license.txt.
16 #-----------------------------------------------------------------------
18 #-----------------------------------------------------------------------
21 namespace eval ::snit:: {
23 compile type widget widgetadaptor typemethod method macro
26 #-----------------------------------------------------------------------
29 namespace eval ::snit:: {
30 variable reservedArgs {type selfns win self}
32 # Widget classes which can be hulls (must have -class)
35 frame tk::frame ttk::frame
36 labelframe tk::labelframe ttk::labelframe
40 #-----------------------------------------------------------------------
41 # Snit Type Implementation template
43 namespace eval ::snit:: {
44 # Template type definition: All internal and user-visible Snit
45 # implementation code.
47 # The following placeholders will automatically be replaced with
48 # the client's code, in two passes:
51 # %COMPILEDDEFS% The compiled type definition.
54 # %TYPE% The fully qualified type name.
55 # %IVARDECS% Instance variable declarations
56 # %TVARDECS% Type variable declarations
57 # %TCONSTBODY% Type constructor body
58 # %INSTANCEVARS% The compiled instance variable initialization code.
59 # %TYPEVARS% The compiled type variable initialization code.
61 # This is the overall type template.
64 # This is the normal type proc
65 variable nominalTypeProc
67 # This is the "-hastypemethods no" type proc
68 variable simpleTypeProc
71 set ::snit::typeTemplate {
73 #-------------------------------------------------------------------
74 # The type's namespace definition and the user's type variables
76 namespace eval %TYPE% {%TYPEVARS%
79 #----------------------------------------------------------------
80 # Commands for use in methods, typemethods, etc.
82 # These are implemented as aliases into the Snit runtime library.
84 interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE%
85 interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE%
86 interp alias {} %TYPE%::typevariable {} ::variable
87 interp alias {} %TYPE%::variable {} ::snit::RT.variable
88 interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE%
89 interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE%
90 interp alias {} %TYPE%::myvar {} ::snit::RT.myvar
91 interp alias {} %TYPE%::varname {} ::snit::RT.myvar
92 interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE%
93 interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE%
94 interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod
95 interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE%
96 interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE%
98 #-------------------------------------------------------------------
99 # Snit's internal variables
101 namespace eval %TYPE% {
102 # Array: General Snit Info
104 # ns: The type's namespace
105 # hasinstances: T or F, from pragma -hasinstances.
106 # simpledispatch: T or F, from pragma -hasinstances.
107 # canreplace: T or F, from pragma -canreplace.
108 # counter: Count of instances created so far.
109 # widgetclass: Set by widgetclass statement.
110 # hulltype: Hull type (frame or toplevel) for widgets only.
111 # exceptmethods: Methods explicitly not delegated to *
112 # excepttypemethods: Methods explicitly not delegated to *
113 # tvardecs: Type variable declarations--for dynamic methods
114 # ivardecs: Instance variable declarations--for dyn. methods
115 typevariable Snit_info
116 set Snit_info(ns) %TYPE%::
117 set Snit_info(hasinstances) 1
118 set Snit_info(simpledispatch) 0
119 set Snit_info(canreplace) 0
120 set Snit_info(counter) 0
121 set Snit_info(widgetclass) {}
122 set Snit_info(hulltype) frame
123 set Snit_info(exceptmethods) {}
124 set Snit_info(excepttypemethods) {}
125 set Snit_info(tvardecs) {%TVARDECS%}
126 set Snit_info(ivardecs) {%IVARDECS%}
128 # Array: Public methods of this type.
129 # The index is the method name, or "*".
130 # The value is [list $pattern $componentName], where
131 # $componentName is "" for normal methods.
132 typevariable Snit_typemethodInfo
133 array unset Snit_typemethodInfo
135 # Array: Public methods of instances of this type.
136 # The index is the method name, or "*".
137 # The value is [list $pattern $componentName], where
138 # $componentName is "" for normal methods.
139 typevariable Snit_methodInfo
140 array unset Snit_methodInfo
142 # Array: option information. See dictionary.txt.
143 typevariable Snit_optionInfo
144 array unset Snit_optionInfo
145 set Snit_optionInfo(local) {}
146 set Snit_optionInfo(delegated) {}
147 set Snit_optionInfo(starcomp) {}
148 set Snit_optionInfo(except) {}
151 #----------------------------------------------------------------
154 # These commands are created or replaced during compilation:
157 # Snit_instanceVars selfns
159 # Initializes the instance variables, if any. Called during
162 proc %TYPE%::Snit_instanceVars {selfns} {
167 proc %TYPE%::Snit_typeconstructor {type} {
169 namespace path [namespace parent $type]
173 #----------------------------------------------------------------
176 # These commands might be replaced during compilation:
178 # Snit_destructor type selfns win self
180 # Default destructor for the type. By default, it does
181 # nothing. It's replaced by any user destructor.
182 # For types, it's called by method destroy; for widgettypes,
183 # it's called by a destroy event handler.
185 proc %TYPE%::Snit_destructor {type selfns win self} { }
187 #----------------------------------------------------------
188 # Compiled Definitions
192 #----------------------------------------------------------
193 # Finally, call the Type Constructor
195 %TYPE%::Snit_typeconstructor %TYPE%
198 #-----------------------------------------------------------------------
201 # These procs expect the fully-qualified type name to be
202 # substituted in for %TYPE%.
204 # This is the nominal type proc. It supports typemethods and
205 # delegated typemethods.
206 set ::snit::nominalTypeProc {
207 # WHD: Code for creating the type ensemble
208 namespace eval %TYPE% {
209 namespace ensemble create \
210 -unknown [list ::snit::RT.UnknownTypemethod %TYPE% ""] \
215 # This is the simplified type proc for when there are no typemethods
216 # except create. In this case, it doesn't take a method argument;
217 # the method is always "create".
218 set ::snit::simpleTypeProc {
219 # Type dispatcher function. Note: This function lives
220 # in the parent of the %TYPE% namespace! All accesses to
221 # %TYPE% variables and methods must be qualified!
223 ::variable %TYPE%::Snit_info
225 # FIRST, if the are no args, the single arg is %AUTO%
226 if {[llength $args] == 0} {
227 if {$Snit_info(isWidget)} {
228 error "wrong \# args: should be \"%TYPE% name args\""
234 # NEXT, we're going to call the create method.
235 # Pass along the return code unchanged.
236 if {$Snit_info(isWidget)} {
237 set command [list ::snit::RT.widget.typemethod.create %TYPE%]
239 set command [list ::snit::RT.type.typemethod.create %TYPE%]
242 set retval [catch {uplevel 1 $command $args} result]
248 return -code error -errorinfo $errorInfo \
249 -errorcode $errorCode $result
251 return -code $retval $result
259 #=======================================================================
260 # Snit Type Definition
262 # These are the procs used to define Snit types, widgets, and
266 #-----------------------------------------------------------------------
267 # Snit Compilation Variables
269 # The following variables are used while Snit is compiling a type,
270 # and are disposed afterwards.
272 namespace eval ::snit:: {
273 # The compiler variable contains the name of the slave interpreter
274 # used to compile type definitions.
277 # The compile array accumulates information about the type or
278 # widgettype being compiled. It is cleared before and after each
279 # compilation. It has these indices:
281 # type: The name of the type being compiled, for use
282 # in compilation procs.
283 # defs: Compiled definitions, both standard and client.
284 # which: type, widget, widgetadaptor
285 # instancevars: Instance variable definitions and initializations.
286 # ivprocdec: Instance variable proc declarations.
287 # tvprocdec: Type variable proc declarations.
288 # typeconstructor: Type constructor body.
289 # widgetclass: The widgetclass, for snit::widgets, only
290 # hasoptions: False, initially; set to true when first
292 # localoptions: Names of local options.
293 # delegatedoptions: Names of delegated options.
294 # localmethods: Names of locally defined methods.
295 # delegatesmethods: no if no delegated methods, yes otherwise.
296 # hashierarchic : no if no hierarchic methods, yes otherwise.
297 # components: Names of defined components.
298 # typecomponents: Names of defined typecomponents.
299 # typevars: Typevariable definitions and initializations.
300 # varnames: Names of instance variables
301 # typevarnames Names of type variables
302 # hasconstructor False, initially; true when constructor is
304 # resource-$opt The option's resource name
305 # class-$opt The option's class
306 # -default-$opt The option's default value
307 # -validatemethod-$opt The option's validate method
308 # -configuremethod-$opt The option's configure method
309 # -cgetmethod-$opt The option's cget method.
310 # -hastypeinfo The -hastypeinfo pragma
311 # -hastypedestroy The -hastypedestroy pragma
312 # -hastypemethods The -hastypemethods pragma
313 # -hasinfo The -hasinfo pragma
314 # -hasinstances The -hasinstances pragma
315 # -simpledispatch The -simpledispatch pragma WHD: OBSOLETE
316 # -canreplace The -canreplace pragma
319 # This variable accumulates method dispatch information; it has
320 # the same structure as the %TYPE%::Snit_methodInfo array, and is
321 # used to initialize it.
324 # This variable accumulates typemethod dispatch information; it has
325 # the same structure as the %TYPE%::Snit_typemethodInfo array, and is
326 # used to initialize it.
327 variable typemethodInfo
329 # The following variable lists the reserved type definition statement
330 # names, e.g., the names you can't use as macros. It's built at
331 # compiler definition time using "info commands".
332 variable reservedwords {}
335 #-----------------------------------------------------------------------
336 # type compilation commands
338 # The type and widgettype commands use a slave interpreter to compile
339 # the type definition. These are the procs
340 # that are aliased into it.
342 # Initialize the compiler
343 proc ::snit::Comp.Init {} {
345 variable reservedwords
347 if {$compiler eq ""} {
348 # Create the compiler's interpreter
349 set compiler [interp create]
351 # Initialize the interpreter
357 # Load package information
358 # TBD: see if this can be moved outside.
359 # @mdgen NODEP: ::snit::__does_not_exist__
360 catch {package require ::snit::__does_not_exist__}
362 # Protect some Tcl commands our type definitions
365 rename variable _variable
368 # Define compilation aliases.
369 $compiler alias pragma ::snit::Comp.statement.pragma
370 $compiler alias widgetclass ::snit::Comp.statement.widgetclass
371 $compiler alias hulltype ::snit::Comp.statement.hulltype
372 $compiler alias constructor ::snit::Comp.statement.constructor
373 $compiler alias destructor ::snit::Comp.statement.destructor
374 $compiler alias option ::snit::Comp.statement.option
375 $compiler alias oncget ::snit::Comp.statement.oncget
376 $compiler alias onconfigure ::snit::Comp.statement.onconfigure
377 $compiler alias method ::snit::Comp.statement.method
378 $compiler alias typemethod ::snit::Comp.statement.typemethod
379 $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor
380 $compiler alias proc ::snit::Comp.statement.proc
381 $compiler alias typevariable ::snit::Comp.statement.typevariable
382 $compiler alias variable ::snit::Comp.statement.variable
383 $compiler alias typecomponent ::snit::Comp.statement.typecomponent
384 $compiler alias component ::snit::Comp.statement.component
385 $compiler alias delegate ::snit::Comp.statement.delegate
386 $compiler alias expose ::snit::Comp.statement.expose
388 # Get the list of reserved words
389 set reservedwords [$compiler eval {info commands}]
393 # Compile a type definition, and return the results as a list of two
394 # items: the fully-qualified type name, and a script that will define
395 # the type when executed.
397 # which type, widget, or widgetadaptor
399 # body the type definition
400 proc ::snit::Comp.Compile {which type body} {
401 variable typeTemplate
402 variable nominalTypeProc
403 variable simpleTypeProc
407 variable typemethodInfo
409 # FIRST, qualify the name.
410 if {![string match "::*" $type]} {
411 # Get caller's namespace;
412 # append :: if not global namespace.
413 set ns [uplevel 2 [list namespace current]]
421 # NEXT, create and initialize the compiler, if needed.
424 # NEXT, initialize the class data
425 array unset methodInfo
426 array unset typemethodInfo
429 set compile(type) $type
431 set compile(which) $which
432 set compile(hasoptions) no
433 set compile(localoptions) {}
434 set compile(instancevars) {}
435 set compile(typevars) {}
436 set compile(delegatedoptions) {}
437 set compile(ivprocdec) {}
438 set compile(tvprocdec) {}
439 set compile(typeconstructor) {}
440 set compile(widgetclass) {}
441 set compile(hulltype) {}
442 set compile(localmethods) {}
443 set compile(delegatesmethods) no
444 set compile(hashierarchic) no
445 set compile(components) {}
446 set compile(typecomponents) {}
447 set compile(varnames) {}
448 set compile(typevarnames) {}
449 set compile(hasconstructor) no
450 set compile(-hastypedestroy) yes
451 set compile(-hastypeinfo) yes
452 set compile(-hastypemethods) yes
453 set compile(-hasinfo) yes
454 set compile(-hasinstances) yes
455 set compile(-canreplace) no
457 set isWidget [string match widget* $which]
458 set isWidgetAdaptor [string match widgetadaptor $which]
460 # NEXT, Evaluate the type's definition in the class interpreter.
463 # NEXT, Add the standard definitions
464 append compile(defs) \
465 "\nset %TYPE%::Snit_info(isWidget) $isWidget\n"
467 append compile(defs) \
468 "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n"
470 # Indicate whether the type can create instances that replace
472 append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n"
475 # Check pragmas for conflict.
477 if {!$compile(-hastypemethods) && !$compile(-hasinstances)} {
478 error "$which $type has neither typemethods nor instances"
481 # If there are typemethods, define the standard typemethods and
482 # the nominal type proc. Otherwise define the simple type proc.
483 if {$compile(-hastypemethods)} {
484 # Add the info typemethod unless the pragma forbids it.
485 if {$compile(-hastypeinfo)} {
486 Comp.statement.delegate typemethod info \
487 using {::snit::RT.typemethod.info %t}
490 # Add the destroy typemethod unless the pragma forbids it.
491 if {$compile(-hastypedestroy)} {
492 Comp.statement.delegate typemethod destroy \
493 using {::snit::RT.typemethod.destroy %t}
496 # Add the nominal type proc.
497 append compile(defs) $nominalTypeProc
499 # Add the simple type proc.
500 append compile(defs) $simpleTypeProc
503 # Add standard methods/typemethods that only make sense if the
504 # type has instances.
505 if {$compile(-hasinstances)} {
506 # Add the info method unless the pragma forbids it.
507 if {$compile(-hasinfo)} {
508 Comp.statement.delegate method info \
509 using {::snit::RT.method.info %t %n %w %s}
512 # Add the option handling stuff if there are any options.
513 if {$compile(hasoptions)} {
514 Comp.statement.variable options
516 Comp.statement.delegate method cget \
517 using {::snit::RT.method.cget %t %n %w %s}
518 Comp.statement.delegate method configurelist \
519 using {::snit::RT.method.configurelist %t %n %w %s}
520 Comp.statement.delegate method configure \
521 using {::snit::RT.method.configure %t %n %w %s}
524 # Add a default constructor, if they haven't already defined one.
525 # If there are options, it will configure args; otherwise it
527 if {!$compile(hasconstructor)} {
528 if {$compile(hasoptions)} {
529 Comp.statement.constructor {args} {
530 $self configurelist $args
533 Comp.statement.constructor {} {}
538 Comp.statement.delegate method destroy \
539 using {::snit::RT.method.destroy %t %n %w %s}
541 Comp.statement.delegate typemethod create \
542 using {::snit::RT.type.typemethod.create %t}
544 Comp.statement.delegate typemethod create \
545 using {::snit::RT.widget.typemethod.create %t}
548 # Save the method info.
549 append compile(defs) \
550 "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n"
552 append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n"
555 # NEXT, compiling the type definition built up a set of information
556 # about the type's locally defined options; add this information to
557 # the compiled definition.
560 # NEXT, compiling the type definition built up a set of information
561 # about the typemethods; save the typemethod info.
562 append compile(defs) \
563 "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n"
565 # NEXT, if this is a widget define the hull component if it isn't
568 Comp.DefineComponent hull
571 # NEXT, substitute the compiled definition into the type template
572 # to get the type definition script.
573 set defscript [Expand $typeTemplate \
574 %COMPILEDDEFS% $compile(defs)]
576 # NEXT, substitute the defined macros into the type definition script.
577 # This is done as a separate step so that the compile(defs) can
578 # contain the macros defined below.
580 set defscript [Expand $defscript \
582 %IVARDECS% $compile(ivprocdec) \
583 %TVARDECS% $compile(tvprocdec) \
584 %TCONSTBODY% $compile(typeconstructor) \
585 %INSTANCEVARS% $compile(instancevars) \
586 %TYPEVARS% $compile(typevars) \
591 return [list $type $defscript]
594 # Information about locally-defined options is accumulated during
595 # compilation, but not added to the compiled definition--the option
596 # statement can appear multiple times, so it's easier this way.
597 # This proc fills in Snit_optionInfo with the accumulated information.
599 # It also computes the option's resource and class names if needed.
601 # Note that the information for delegated options was put in
602 # Snit_optionInfo during compilation.
604 proc ::snit::Comp.SaveOptionInfo {} {
607 foreach option $compile(localoptions) {
608 if {$compile(resource-$option) eq ""} {
609 set compile(resource-$option) [string range $option 1 end]
612 if {$compile(class-$option) eq ""} {
613 set compile(class-$option) [Capitalize $compile(resource-$option)]
616 # NOTE: Don't verify that the validate, configure, and cget
617 # values name real methods; the methods might be defined outside
618 # the typedefinition using snit::method.
620 Mappend compile(defs) {
622 lappend %TYPE%::Snit_optionInfo(local) %OPTION%
624 set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1
625 set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE%
626 set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
627 set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT%
628 set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE%
629 set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE%
630 set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET%
631 set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY%
632 set %TYPE%::Snit_optionInfo(typespec-%OPTION%) %TYPESPEC%
634 %RESOURCE% $compile(resource-$option) \
635 %CLASS% $compile(class-$option) \
636 %DEFAULT% [list $compile(-default-$option)] \
637 %VALIDATE% [list $compile(-validatemethod-$option)] \
638 %CONFIGURE% [list $compile(-configuremethod-$option)] \
639 %CGET% [list $compile(-cgetmethod-$option)] \
640 %READONLY% $compile(-readonly-$option) \
641 %TYPESPEC% [list $compile(-type-$option)]
646 # Evaluates a compiled type definition, thus making the type available.
647 proc ::snit::Comp.Define {compResult} {
648 # The compilation result is a list containing the fully qualified
649 # type name and a script to evaluate to define the type.
650 set type [lindex $compResult 0]
651 set defscript [lindex $compResult 1]
653 # Execute the type definition script.
654 # Consider using namespace eval %TYPE%. See if it's faster.
655 if {[catch {eval $defscript} result]} {
656 namespace delete $type
657 catch {rename $type ""}
664 # Sets pragma options which control how the type is defined.
665 proc ::snit::Comp.statement.pragma {args} {
668 set errRoot "Error in \"pragma...\""
670 foreach {opt val} $args {
671 switch -exact -- $opt {
679 if {![string is boolean -strict $val]} {
680 error "$errRoot, \"$opt\" requires a boolean value"
682 set compile($opt) $val
685 error "$errRoot, unknown pragma"
691 # Defines a widget's option class name.
692 # This statement is only available for snit::widgets,
693 # not for snit::types or snit::widgetadaptors.
694 proc ::snit::Comp.statement.widgetclass {name} {
697 # First, widgetclass can only be set for true widgets
698 if {"widget" != $compile(which)} {
699 error "widgetclass cannot be set for snit::$compile(which)s"
702 # Next, validate the option name. We'll require that it begin
703 # with an uppercase letter.
704 set initial [string index $name 0]
705 if {![string is upper $initial]} {
706 error "widgetclass \"$name\" does not begin with an uppercase letter"
709 if {"" != $compile(widgetclass)} {
710 error "too many widgetclass statements"
714 Mappend compile(defs) {
715 set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS%
716 } %WIDGETCLASS% [list $name]
718 set compile(widgetclass) $name
721 # Defines a widget's hull type.
722 # This statement is only available for snit::widgets,
723 # not for snit::types or snit::widgetadaptors.
724 proc ::snit::Comp.statement.hulltype {name} {
728 # First, hulltype can only be set for true widgets
729 if {"widget" != $compile(which)} {
730 error "hulltype cannot be set for snit::$compile(which)s"
733 # Next, it must be one of the valid hulltypes (frame, toplevel, ...)
734 if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} {
735 error "invalid hulltype \"$name\", should be one of\
736 [join $hulltypes {, }]"
739 if {"" != $compile(hulltype)} {
740 error "too many hulltype statements"
744 Mappend compile(defs) {
745 set %TYPE%::Snit_info(hulltype) %HULLTYPE%
748 set compile(hulltype) $name
751 # Defines a constructor.
752 proc ::snit::Comp.statement.constructor {arglist body} {
755 CheckArgs "constructor" $arglist
757 # Next, add a magic reference to self.
758 set arglist [concat type selfns win self $arglist]
760 # Next, add variable declarations to body:
761 set body "%TVARDECS%\n%IVARDECS%\n$body"
763 set compile(hasconstructor) yes
764 append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n"
767 # Defines a destructor.
768 proc ::snit::Comp.statement.destructor {body} {
771 # Next, add variable declarations to body:
772 set body "%TVARDECS%\n%IVARDECS%\n$body"
774 append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n"
777 # Defines a type option. The option value can be a triple, specifying
778 # the option's -name, resource name, and class name.
779 proc ::snit::Comp.statement.option {optionDef args} {
782 # First, get the three option names.
783 set option [lindex $optionDef 0]
784 set resourceName [lindex $optionDef 1]
785 set className [lindex $optionDef 2]
787 set errRoot "Error in \"option [list $optionDef]...\""
789 # Next, validate the option name.
790 if {![Comp.OptionNameIsValid $option]} {
791 error "$errRoot, badly named option \"$option\""
794 if {$option in $compile(delegatedoptions)} {
795 error "$errRoot, cannot define \"$option\" locally, it has been delegated"
798 if {!($option in $compile(localoptions))} {
799 # Remember that we've seen this one.
800 set compile(hasoptions) yes
801 lappend compile(localoptions) $option
803 # Initialize compilation info for this option.
804 set compile(resource-$option) ""
805 set compile(class-$option) ""
806 set compile(-default-$option) ""
807 set compile(-validatemethod-$option) ""
808 set compile(-configuremethod-$option) ""
809 set compile(-cgetmethod-$option) ""
810 set compile(-readonly-$option) 0
811 set compile(-type-$option) ""
814 # NEXT, see if we have a resource name. If so, make sure it
815 # isn't being redefined differently.
816 if {$resourceName ne ""} {
817 if {$compile(resource-$option) eq ""} {
818 # If it's undefined, just save the value.
819 set compile(resource-$option) $resourceName
820 } elseif {$resourceName ne $compile(resource-$option)} {
821 # It's been redefined differently.
822 error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\""
826 # NEXT, see if we have a class name. If so, make sure it
827 # isn't being redefined differently.
828 if {$className ne ""} {
829 if {$compile(class-$option) eq ""} {
830 # If it's undefined, just save the value.
831 set compile(class-$option) $className
832 } elseif {$className ne $compile(class-$option)} {
833 # It's been redefined differently.
834 error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\""
838 # NEXT, handle the args; it's not an error to redefine these.
839 if {[llength $args] == 1} {
840 set compile(-default-$option) [lindex $args 0]
842 foreach {optopt val} $args {
843 switch -exact -- $optopt {
848 set compile($optopt-$option) $val
851 set compile($optopt-$option) $val
853 if {[llength $val] == 1} {
854 # The type spec *is* the validation object
855 append compile(defs) \
856 "\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n"
858 # Compilation the creation of the validation object
859 set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%]
860 append compile(defs) \
861 "\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n"
865 if {![string is boolean -strict $val]} {
866 error "$errRoot, -readonly requires a boolean, got \"$val\""
868 set compile($optopt-$option) $val
871 error "$errRoot, unknown option definition option \"$optopt\""
878 # 1 if the option name is valid, 0 otherwise.
879 proc ::snit::Comp.OptionNameIsValid {option} {
880 if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} {
887 # Defines an option's cget handler
888 proc ::snit::Comp.statement.oncget {option body} {
891 set errRoot "Error in \"oncget $option...\""
893 if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
894 return -code error "$errRoot, option \"$option\" is delegated"
897 if {[lsearch -exact $compile(localoptions) $option] == -1} {
898 return -code error "$errRoot, option \"$option\" unknown"
901 Comp.statement.method _cget$option {_option} $body
902 Comp.statement.option $option -cgetmethod _cget$option
905 # Defines an option's configure handler.
906 proc ::snit::Comp.statement.onconfigure {option arglist body} {
909 if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
910 return -code error "onconfigure $option: option \"$option\" is delegated"
913 if {[lsearch -exact $compile(localoptions) $option] == -1} {
914 return -code error "onconfigure $option: option \"$option\" unknown"
917 if {[llength $arglist] != 1} {
919 "onconfigure $option handler should have one argument, got \"$arglist\""
922 CheckArgs "onconfigure $option" $arglist
924 # Next, add a magic reference to the option name
925 set arglist [concat _option $arglist]
927 Comp.statement.method _configure$option $arglist $body
928 Comp.statement.option $option -configuremethod _configure$option
931 # Defines an instance method.
932 proc ::snit::Comp.statement.method {method arglist body} {
936 # FIRST, check the method name against previously defined
938 Comp.CheckMethodName $method 0 ::snit::methodInfo \
939 "Error in \"method [list $method]...\""
941 if {[llength $method] > 1} {
942 set compile(hashierarchic) yes
945 # Remeber this method
946 lappend compile(localmethods) $method
948 CheckArgs "method [list $method]" $arglist
950 # Next, add magic references to type and self.
951 set arglist [concat type selfns win self $arglist]
953 # Next, add variable declarations to body:
954 set body "%TVARDECS%\n%IVARDECS%\n# END snit method prolog\n$body"
956 # Next, save the definition script.
957 if {[llength $method] == 1} {
958 set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
959 Mappend compile(defs) {
960 proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY%
961 } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
963 set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
965 Mappend compile(defs) {
966 proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY%
967 } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \
972 # Check for name collisions; save prefix information.
974 # method The name of the method or typemethod.
975 # delFlag 1 if delegated, 0 otherwise.
976 # infoVar The fully qualified name of the array containing
977 # information about the defined methods.
978 # errRoot The root string for any error messages.
980 proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} {
981 upvar $infoVar methodInfo
983 # FIRST, make sure the method name is a valid Tcl list.
984 if {[catch {lindex $method 0}]} {
985 error "$errRoot, the name \"$method\" must have list syntax."
988 # NEXT, check whether we can define it.
989 if {![catch {set methodInfo($method)} data]} {
990 # We can't redefine methods with submethods.
991 if {[lindex $data 0] == 1} {
992 error "$errRoot, \"$method\" has submethods."
995 # You can't delegate a method that's defined locally,
996 # and you can't define a method locally if it's been delegated.
997 if {$delFlag && [lindex $data 2] eq ""} {
998 error "$errRoot, \"$method\" has been defined locally."
999 } elseif {!$delFlag && [lindex $data 2] ne ""} {
1000 error "$errRoot, \"$method\" has been delegated"
1004 # Handle hierarchical case.
1005 if {[llength $method] > 1} {
1008 while {[llength $tokens] > 1} {
1009 lappend prefix [lindex $tokens 0]
1010 set tokens [lrange $tokens 1 end]
1012 if {![catch {set methodInfo($prefix)} result]} {
1013 # Prefix is known. If it's not a prefix, throw an
1015 if {[lindex $result 0] == 0} {
1016 error "$errRoot, \"$prefix\" has no submethods."
1020 set methodInfo($prefix) [list 1]
1025 # Defines a typemethod method.
1026 proc ::snit::Comp.statement.typemethod {method arglist body} {
1028 variable typemethodInfo
1030 # FIRST, check the typemethod name against previously defined
1032 Comp.CheckMethodName $method 0 ::snit::typemethodInfo \
1033 "Error in \"typemethod [list $method]...\""
1035 CheckArgs "typemethod $method" $arglist
1037 # First, add magic reference to type.
1038 set arglist [concat type $arglist]
1040 # Next, add typevariable declarations to body:
1041 set body "%TVARDECS%\n# END snit method prolog\n$body"
1043 # Next, save the definition script
1044 if {[llength $method] == 1} {
1045 set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
1047 Mappend compile(defs) {
1048 proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY%
1049 } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
1051 set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
1053 Mappend compile(defs) {
1054 proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY%
1055 } %JMETHOD% [join $method _] \
1056 %ARGLIST% [list $arglist] %BODY% [list $body]
1061 # Defines a type constructor.
1062 proc ::snit::Comp.statement.typeconstructor {body} {
1065 if {"" != $compile(typeconstructor)} {
1066 error "too many typeconstructors"
1069 set compile(typeconstructor) $body
1072 # Defines a static proc in the type's namespace.
1073 proc ::snit::Comp.statement.proc {proc arglist body} {
1076 # If "ns" is defined, the proc can see instance variables.
1077 if {[lsearch -exact $arglist selfns] != -1} {
1078 # Next, add instance variable declarations to body:
1079 set body "%IVARDECS%\n$body"
1082 # The proc can always see typevariables.
1083 set body "%TVARDECS%\n$body"
1085 append compile(defs) "
1088 proc [list %TYPE%::$proc $arglist $body]
1092 # Defines a static variable in the type's namespace.
1093 proc ::snit::Comp.statement.typevariable {name args} {
1096 set errRoot "Error in \"typevariable $name...\""
1098 set len [llength $args]
1101 ($len == 2 && [lindex $args 0] ne "-array")} {
1102 error "$errRoot, too many initializers"
1105 if {[lsearch -exact $compile(varnames) $name] != -1} {
1106 error "$errRoot, \"$name\" is already an instance variable"
1109 lappend compile(typevarnames) $name
1112 append compile(typevars) \
1113 "\n\t [list ::variable $name [lindex $args 0]]"
1114 } elseif {$len == 2} {
1115 append compile(typevars) \
1116 "\n\t [list ::variable $name]"
1117 append compile(typevars) \
1118 "\n\t [list array set $name [lindex $args 1]]"
1120 append compile(typevars) \
1121 "\n\t [list ::variable $name]"
1124 if {$compile(tvprocdec) eq ""} {
1125 set compile(tvprocdec) "\n\t"
1126 append compile(tvprocdec) "namespace upvar [list $compile(type)]"
1128 append compile(tvprocdec) " [list $name $name]"
1131 # Defines an instance variable; the definition will go in the
1132 # type's create typemethod.
1133 proc ::snit::Comp.statement.variable {name args} {
1136 set errRoot "Error in \"variable $name...\""
1138 set len [llength $args]
1141 ($len == 2 && [lindex $args 0] ne "-array")} {
1142 error "$errRoot, too many initializers"
1145 if {[lsearch -exact $compile(typevarnames) $name] != -1} {
1146 error "$errRoot, \"$name\" is already a typevariable"
1149 lappend compile(varnames) $name
1151 # Add a ::variable to instancevars, so that ::variable is used
1152 # at least once; ::variable makes the variable visible to
1153 # [info vars] even if no value is assigned.
1154 append compile(instancevars) "\n"
1155 Mappend compile(instancevars) {::variable ${selfns}::%N} %N $name
1158 append compile(instancevars) \
1159 "\nset $name [list [lindex $args 0]]\n"
1160 } elseif {$len == 2} {
1161 append compile(instancevars) \
1162 "\narray set $name [list [lindex $args 1]]\n"
1165 if {$compile(ivprocdec) eq ""} {
1166 set compile(ivprocdec) "\n\t"
1167 append compile(ivprocdec) {namespace upvar $selfns}
1169 append compile(ivprocdec) " [list $name $name]"
1172 # Defines a typecomponent, and handles component options.
1174 # component The logical name of the delegate
1177 proc ::snit::Comp.statement.typecomponent {component args} {
1180 set errRoot "Error in \"typecomponent $component...\""
1182 # FIRST, define the component
1183 Comp.DefineTypecomponent $component $errRoot
1185 # NEXT, handle the options.
1189 foreach {opt val} $args {
1190 switch -exact -- $opt {
1192 set publicMethod $val
1195 set inheritFlag $val
1196 if {![string is boolean $inheritFlag]} {
1197 error "typecomponent $component -inherit: expected boolean value, got \"$val\""
1201 error "typecomponent $component: Invalid option \"$opt\""
1206 # NEXT, if -public specified, define the method.
1207 if {$publicMethod ne ""} {
1208 Comp.statement.delegate typemethod [list $publicMethod *] to $component
1211 # NEXT, if "-inherit 1" is specified, delegate typemethod * to
1214 Comp.statement.delegate typemethod "*" to $component
1220 # Defines a name to be a typecomponent
1222 # The name becomes a typevariable; in addition, it gets a
1223 # write trace so that when it is set, all of the component mechanisms
1226 # component The component name
1228 proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} {
1231 if {[lsearch -exact $compile(varnames) $component] != -1} {
1232 error "$errRoot, \"$component\" is already an instance variable"
1235 if {[lsearch -exact $compile(typecomponents) $component] == -1} {
1236 # Remember we've done this.
1237 lappend compile(typecomponents) $component
1239 # Make it a type variable with no initial value
1240 Comp.statement.typevariable $component ""
1242 # Add a write trace to do the component thing.
1243 Mappend compile(typevars) {
1244 trace add variable %COMP% write \
1245 [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%]
1246 } %TYPE% $compile(type) %COMP% $component
1250 # Defines a component, and handles component options.
1252 # component The logical name of the delegate
1255 # TBD: Ideally, it should be possible to call this statement multiple
1256 # times, possibly changing the option values. To do that, I'd need
1257 # to cache the option values and not act on them until *after* I'd
1258 # read the entire type definition.
1260 proc ::snit::Comp.statement.component {component args} {
1263 set errRoot "Error in \"component $component...\""
1265 # FIRST, define the component
1266 Comp.DefineComponent $component $errRoot
1268 # NEXT, handle the options.
1272 foreach {opt val} $args {
1273 switch -exact -- $opt {
1275 set publicMethod $val
1278 set inheritFlag $val
1279 if {![string is boolean $inheritFlag]} {
1280 error "component $component -inherit: expected boolean value, got \"$val\""
1284 error "component $component: Invalid option \"$opt\""
1289 # NEXT, if -public specified, define the method.
1290 if {$publicMethod ne ""} {
1291 Comp.statement.delegate method [list $publicMethod *] to $component
1294 # NEXT, if -inherit is specified, delegate method/option * to
1297 Comp.statement.delegate method "*" to $component
1298 Comp.statement.delegate option "*" to $component
1303 # Defines a name to be a component
1305 # The name becomes an instance variable; in addition, it gets a
1306 # write trace so that when it is set, all of the component mechanisms
1309 # component The component name
1311 proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} {
1314 if {[lsearch -exact $compile(typevarnames) $component] != -1} {
1315 error "$errRoot, \"$component\" is already a typevariable"
1318 if {[lsearch -exact $compile(components) $component] == -1} {
1319 # Remember we've done this.
1320 lappend compile(components) $component
1322 # Make it an instance variable with no initial value
1323 Comp.statement.variable $component ""
1325 # Add a write trace to do the component thing.
1326 Mappend compile(instancevars) {
1327 trace add variable ${selfns}::%COMP% write \
1328 [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%]
1329 } %TYPE% $compile(type) %COMP% $component
1333 # Creates a delegated method, typemethod, or option.
1334 proc ::snit::Comp.statement.delegate {what name args} {
1335 # FIRST, dispatch to correct handler.
1337 typemethod { Comp.DelegatedTypemethod $name $args }
1338 method { Comp.DelegatedMethod $name $args }
1339 option { Comp.DelegatedOption $name $args }
1341 error "Error in \"delegate $what $name...\", \"$what\"?"
1345 if {([llength $args] % 2) != 0} {
1346 error "Error in \"delegate $what $name...\", invalid syntax"
1350 # Creates a delegated typemethod delegating it to a particular
1351 # typecomponent or an arbitrary command.
1353 # method The name of the method
1354 # arglist Delegation options
1356 proc ::snit::Comp.DelegatedTypemethod {method arglist} {
1358 variable typemethodInfo
1360 set errRoot "Error in \"delegate typemethod [list $method]...\""
1362 # Next, parse the delegation options.
1367 set methodTail [lindex $method end]
1369 foreach {opt value} $arglist {
1370 switch -exact $opt {
1371 to { set component $value }
1372 as { set target $value }
1373 except { set exceptions $value }
1374 using { set pattern $value }
1376 error "$errRoot, unknown delegation option \"$opt\""
1381 if {$component eq "" && $pattern eq ""} {
1382 error "$errRoot, missing \"to\""
1385 if {$methodTail eq "*" && $target ne ""} {
1386 error "$errRoot, cannot specify \"as\" with \"*\""
1389 if {$methodTail ne "*" && $exceptions ne ""} {
1390 error "$errRoot, can only specify \"except\" with \"*\""
1393 if {$pattern ne "" && $target ne ""} {
1394 error "$errRoot, cannot specify both \"as\" and \"using\""
1397 foreach token [lrange $method 1 end-1] {
1398 if {$token eq "*"} {
1399 error "$errRoot, \"*\" must be the last token."
1403 # NEXT, define the component
1404 if {$component ne ""} {
1405 Comp.DefineTypecomponent $component $errRoot
1408 # NEXT, define the pattern.
1409 if {$pattern eq ""} {
1410 if {$methodTail eq "*"} {
1412 } elseif {$target ne ""} {
1413 set pattern "%c $target"
1419 # Make sure the pattern is a valid list.
1420 if {[catch {lindex $pattern 0} result]} {
1421 error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
1424 # NEXT, check the method name against previously defined
1426 Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot
1428 set typemethodInfo($method) [list 0 $pattern $component]
1430 if {[string equal $methodTail "*"]} {
1431 Mappend compile(defs) {
1432 set %TYPE%::Snit_info(excepttypemethods) %EXCEPT%
1433 } %EXCEPT% [list $exceptions]
1438 # Creates a delegated method delegating it to a particular
1439 # component or command.
1441 # method The name of the method
1442 # arglist Delegation options.
1444 proc ::snit::Comp.DelegatedMethod {method arglist} {
1448 set errRoot "Error in \"delegate method [list $method]...\""
1450 # Next, parse the delegation options.
1455 set methodTail [lindex $method end]
1457 foreach {opt value} $arglist {
1458 switch -exact $opt {
1459 to { set component $value }
1460 as { set target $value }
1461 except { set exceptions $value }
1462 using { set pattern $value }
1464 error "$errRoot, unknown delegation option \"$opt\""
1469 if {$component eq "" && $pattern eq ""} {
1470 error "$errRoot, missing \"to\""
1473 if {$methodTail eq "*" && $target ne ""} {
1474 error "$errRoot, cannot specify \"as\" with \"*\""
1477 if {$methodTail ne "*" && $exceptions ne ""} {
1478 error "$errRoot, can only specify \"except\" with \"*\""
1481 if {$pattern ne "" && $target ne ""} {
1482 error "$errRoot, cannot specify both \"as\" and \"using\""
1485 foreach token [lrange $method 1 end-1] {
1486 if {$token eq "*"} {
1487 error "$errRoot, \"*\" must be the last token."
1491 # NEXT, we delegate some methods
1492 set compile(delegatesmethods) yes
1494 # NEXT, define the component. Allow typecomponents.
1495 if {$component ne ""} {
1496 if {[lsearch -exact $compile(typecomponents) $component] == -1} {
1497 Comp.DefineComponent $component $errRoot
1501 # NEXT, define the pattern.
1502 if {$pattern eq ""} {
1503 if {$methodTail eq "*"} {
1505 } elseif {$target ne ""} {
1506 set pattern "%c $target"
1512 # Make sure the pattern is a valid list.
1513 if {[catch {lindex $pattern 0} result]} {
1514 error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
1517 # NEXT, check the method name against previously defined
1519 Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot
1521 # NEXT, save the method info.
1522 set methodInfo($method) [list 0 $pattern $component]
1524 if {[string equal $methodTail "*"]} {
1525 Mappend compile(defs) {
1526 set %TYPE%::Snit_info(exceptmethods) %EXCEPT%
1527 } %EXCEPT% [list $exceptions]
1531 # Creates a delegated option, delegating it to a particular
1532 # component and, optionally, to a particular option of that
1535 # optionDef The option definition
1536 # args definition arguments.
1538 proc ::snit::Comp.DelegatedOption {optionDef arglist} {
1541 # First, get the three option names.
1542 set option [lindex $optionDef 0]
1543 set resourceName [lindex $optionDef 1]
1544 set className [lindex $optionDef 2]
1546 set errRoot "Error in \"delegate option [list $optionDef]...\""
1548 # Next, parse the delegation options.
1553 foreach {opt value} $arglist {
1554 switch -exact $opt {
1555 to { set component $value }
1556 as { set target $value }
1557 except { set exceptions $value }
1559 error "$errRoot, unknown delegation option \"$opt\""
1564 if {$component eq ""} {
1565 error "$errRoot, missing \"to\""
1568 if {$option eq "*" && $target ne ""} {
1569 error "$errRoot, cannot specify \"as\" with \"delegate option *\""
1572 if {$option ne "*" && $exceptions ne ""} {
1573 error "$errRoot, can only specify \"except\" with \"delegate option *\""
1576 # Next, validate the option name
1578 if {"*" != $option} {
1579 if {![Comp.OptionNameIsValid $option]} {
1580 error "$errRoot, badly named option \"$option\""
1584 if {$option in $compile(localoptions)} {
1585 error "$errRoot, \"$option\" has been defined locally"
1588 if {$option in $compile(delegatedoptions)} {
1589 error "$errRoot, \"$option\" is multiply delegated"
1592 # NEXT, define the component
1593 Comp.DefineComponent $component $errRoot
1595 # Next, define the target option, if not specified.
1596 if {![string equal $option "*"] &&
1597 [string equal $target ""]} {
1601 # NEXT, save the delegation data.
1602 set compile(hasoptions) yes
1604 if {![string equal $option "*"]} {
1605 lappend compile(delegatedoptions) $option
1607 # Next, compute the resource and class names, if they aren't
1610 if {"" == $resourceName} {
1611 set resourceName [string range $option 1 end]
1614 if {"" == $className} {
1615 set className [Capitalize $resourceName]
1618 Mappend compile(defs) {
1619 set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0
1620 set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES%
1621 set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
1622 lappend %TYPE%::Snit_optionInfo(delegated) %OPTION%
1623 set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%]
1624 lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION%
1625 } %OPTION% $option \
1628 %RES% $resourceName \
1631 Mappend compile(defs) {
1632 set %TYPE%::Snit_optionInfo(starcomp) %COMP%
1633 set %TYPE%::Snit_optionInfo(except) %EXCEPT%
1634 } %COMP% $component %EXCEPT% [list $exceptions]
1638 # Exposes a component, effectively making the component's command an
1641 # component The logical name of the delegate
1642 # "as" sugar; if not "", must be "as"
1643 # methodname The desired method name for the component's command, or ""
1645 proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} {
1649 # FIRST, define the component
1650 Comp.DefineComponent $component
1652 # NEXT, define the method just as though it were in the type
1654 if {[string equal $methodname ""]} {
1655 set methodname $component
1658 Comp.statement.method $methodname args [Expand {
1659 if {[llength $args] == 0} {
1663 if {[string equal $%COMPONENT% ""]} {
1664 error "undefined component \"%COMPONENT%\""
1668 set cmd [linsert $args 0 $%COMPONENT%]
1669 return [uplevel 1 $cmd]
1670 } %COMPONENT% $component]
1675 #-----------------------------------------------------------------------
1678 # Compile a type definition, and return the results as a list of two
1679 # items: the fully-qualified type name, and a script that will define
1680 # the type when executed.
1682 # which type, widget, or widgetadaptor
1683 # type the type name
1684 # body the type definition
1685 proc ::snit::compile {which type body} {
1686 return [Comp.Compile $which $type $body]
1689 proc ::snit::type {type body} {
1690 return [Comp.Define [Comp.Compile type $type $body]]
1693 proc ::snit::widget {type body} {
1694 return [Comp.Define [Comp.Compile widget $type $body]]
1697 proc ::snit::widgetadaptor {type body} {
1698 return [Comp.Define [Comp.Compile widgetadaptor $type $body]]
1701 proc ::snit::typemethod {type method arglist body} {
1702 # Make sure the type exists.
1703 if {![info exists ${type}::Snit_info]} {
1704 error "no such type: \"$type\""
1707 upvar ${type}::Snit_info Snit_info
1708 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
1710 # FIRST, check the typemethod name against previously defined
1712 Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \
1713 "Cannot define \"$method\""
1715 # NEXT, check the arguments
1716 CheckArgs "snit::typemethod $type $method" $arglist
1718 # Next, add magic reference to type.
1719 set arglist [concat type $arglist]
1721 # Next, add typevariable declarations to body:
1722 set body "$Snit_info(tvardecs)\n$body"
1725 if {[llength $method] == 1} {
1726 set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
1727 uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body]
1729 set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
1730 set suffix [join $method _]
1731 uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body]
1735 proc ::snit::method {type method arglist body} {
1736 # Make sure the type exists.
1737 if {![info exists ${type}::Snit_info]} {
1738 error "no such type: \"$type\""
1741 upvar ${type}::Snit_methodInfo Snit_methodInfo
1742 upvar ${type}::Snit_info Snit_info
1744 # FIRST, check the method name against previously defined
1746 Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \
1747 "Cannot define \"$method\""
1749 # NEXT, check the arguments
1750 CheckArgs "snit::method $type $method" $arglist
1752 # Next, add magic references to type and self.
1753 set arglist [concat type selfns win self $arglist]
1755 # Next, add variable declarations to body:
1756 set body "$Snit_info(tvardecs)\n$Snit_info(ivardecs)\n$body"
1759 if {[llength $method] == 1} {
1760 set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
1761 uplevel 1 [list proc ${type}::Snit_method$method $arglist $body]
1763 set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
1765 set suffix [join $method _]
1766 uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body]
1770 # Defines a proc within the compiler; this proc can call other
1771 # type definition statements, and thus can be used for meta-programming.
1772 proc ::snit::macro {name arglist body} {
1774 variable reservedwords
1776 # FIRST, make sure the compiler is defined.
1779 # NEXT, check the macro name against the reserved words
1780 if {[lsearch -exact $reservedwords $name] != -1} {
1781 error "invalid macro name \"$name\""
1784 # NEXT, see if the name has a namespace; if it does, define the
1786 set ns [namespace qualifiers $name]
1789 $compiler eval "namespace eval $ns {}"
1792 # NEXT, define the macro
1793 $compiler eval [list _proc $name $arglist $body]
1796 #-----------------------------------------------------------------------
1799 # These are utility functions used while compiling Snit types.
1801 # Builds a template from a tagged list of text blocks, then substitutes
1802 # all symbols in the mapTable, returning the expanded template.
1803 proc ::snit::Expand {template args} {
1804 return [string map $args $template]
1807 # Expands a template and appends it to a variable.
1808 proc ::snit::Mappend {varname template args} {
1809 upvar $varname myvar
1811 append myvar [string map $args $template]
1814 # Checks argument list against reserved args
1815 proc ::snit::CheckArgs {which arglist} {
1816 variable reservedArgs
1818 foreach name $reservedArgs {
1819 if {$name in $arglist} {
1820 error "$which's arglist may not contain \"$name\" explicitly"
1825 # Capitalizes the first letter of a string.
1826 proc ::snit::Capitalize {text} {
1827 return [string toupper $text 0]
1831 #=======================================================================
1832 # Snit Runtime Library
1834 # These are procs used by Snit types and widgets at runtime.
1836 #-----------------------------------------------------------------------
1839 # Creates a new instance of the snit::type given its name and the args.
1841 # type The snit::type
1842 # name The instance name
1843 # args Args to pass to the constructor
1845 proc ::snit::RT.type.typemethod.create {type name args} {
1846 variable ${type}::Snit_info
1847 variable ${type}::Snit_optionInfo
1849 # FIRST, qualify the name.
1850 if {![string match "::*" $name]} {
1851 # Get caller's namespace;
1852 # append :: if not global namespace.
1853 set ns [uplevel 1 [list namespace current]]
1861 # NEXT, if %AUTO% appears in the name, generate a unique
1862 # command name. Otherwise, ensure that the name isn't in use.
1863 if {[string match "*%AUTO%*" $name]} {
1864 set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
1865 } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} {
1866 error "command \"$name\" already exists"
1869 # NEXT, create the instance's namespace.
1871 [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
1872 namespace eval $selfns {}
1874 # NEXT, install the dispatcher
1875 RT.MakeInstanceCommand $type $selfns $name
1877 # Initialize the options to their defaults.
1878 namespace upvar ${selfns} options options
1880 foreach opt $Snit_optionInfo(local) {
1881 set options($opt) $Snit_optionInfo(default-$opt)
1884 # Initialize the instance vars to their defaults.
1885 # selfns must be defined, as it is used implicitly.
1886 ${type}::Snit_instanceVars $selfns
1888 # Execute the type's constructor.
1889 set errcode [catch {
1890 RT.ConstructInstance $type $selfns $name $args
1897 set theInfo $errorInfo
1898 set theCode $errorCode
1900 ::snit::RT.DestroyObject $type $selfns $name
1901 error "Error in constructor: $result" $theInfo $theCode
1904 # NEXT, return the object's name.
1908 # Creates a new instance of the snit::widget or snit::widgetadaptor
1909 # given its name and the args.
1911 # type The snit::widget or snit::widgetadaptor
1912 # name The instance name
1913 # args Args to pass to the constructor
1915 proc ::snit::RT.widget.typemethod.create {type name args} {
1916 variable ${type}::Snit_info
1917 variable ${type}::Snit_optionInfo
1919 # FIRST, if %AUTO% appears in the name, generate a unique
1921 if {[string match "*%AUTO%*" $name]} {
1922 set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
1925 # NEXT, create the instance's namespace.
1927 [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
1928 namespace eval $selfns { }
1930 # NEXT, Initialize the widget's own options to their defaults.
1931 namespace upvar $selfns options options
1933 foreach opt $Snit_optionInfo(local) {
1934 set options($opt) $Snit_optionInfo(default-$opt)
1937 # Initialize the instance vars to their defaults.
1938 ${type}::Snit_instanceVars $selfns
1940 # NEXT, if this is a normal widget (not a widget adaptor) then create a
1941 # frame as its hull. We set the frame's -class to the user's widgetclass,
1942 # or, if none, search for -class in the args list, otherwise default to
1943 # the basename of the $type with an initial upper case letter.
1944 if {!$Snit_info(isWidgetAdaptor)} {
1945 # FIRST, determine the class name
1946 set wclass $Snit_info(widgetclass)
1947 if {$Snit_info(widgetclass) eq ""} {
1948 set idx [lsearch -exact $args -class]
1949 if {$idx >= 0 && ($idx%2 == 0)} {
1950 # -class exists and is in the -option position
1951 set wclass [lindex $args [expr {$idx+1}]]
1952 set args [lreplace $args $idx [expr {$idx+1}]]
1954 set wclass [::snit::Capitalize [namespace tail $type]]
1958 # NEXT, create the widget
1961 ${type}::installhull using $Snit_info(hulltype) -class $wclass
1963 # NEXT, let's query the option database for our
1964 # widget, now that we know that it exists.
1965 foreach opt $Snit_optionInfo(local) {
1966 set dbval [RT.OptionDbGet $type $name $opt]
1969 set options($opt) $dbval
1974 # Execute the type's constructor, and verify that it
1976 set errcode [catch {
1977 RT.ConstructInstance $type $selfns $name $args
1979 ::snit::RT.Component $type $selfns hull
1981 # Prepare to call the object's destructor when the
1982 # <Destroy> event is received. Use a Snit-specific bindtag
1983 # so that the widget name's tag is unencumbered.
1985 bind Snit$type$name <Destroy> [::snit::Expand {
1986 ::snit::RT.DestroyObject %TYPE% %NS% %W
1987 } %TYPE% $type %NS% $selfns]
1989 # Insert the bindtag into the list of bindtags right
1990 # after the widget name.
1991 set taglist [bindtags $name]
1992 set ndx [lsearch -exact $taglist $name]
1994 bindtags $name [linsert $taglist $ndx Snit$type$name]
2001 set theInfo $errorInfo
2002 set theCode $errorCode
2003 ::snit::RT.DestroyObject $type $selfns $name
2004 error "Error in constructor: $result" $theInfo $theCode
2007 # NEXT, return the object's name.
2012 # RT.MakeInstanceCommand type selfns instance
2014 # type The object type
2015 # selfns The instance namespace
2016 # instance The instance name
2018 # Creates the instance proc.
2020 proc ::snit::RT.MakeInstanceCommand {type selfns instance} {
2021 variable ${type}::Snit_info
2023 # FIRST, remember the instance name. The Snit_instance variable
2024 # allows the instance to figure out its current name given the
2025 # instance namespace.
2027 namespace upvar $selfns Snit_instance Snit_instance
2029 set Snit_instance $instance
2031 # NEXT, qualify the proc name if it's a widget.
2032 if {$Snit_info(isWidget)} {
2033 set procname ::$instance
2035 set procname $instance
2038 # NEXT, install the new proc
2039 # WHD: Snit 2.0 code
2041 set unknownCmd [list ::snit::RT.UnknownMethod $type $selfns $instance ""]
2042 set createCmd [list namespace ensemble create \
2043 -command $procname \
2044 -unknown $unknownCmd \
2047 namespace eval $selfns $createCmd
2049 # NEXT, add the trace.
2050 trace add command $procname {rename delete} \
2051 [list ::snit::RT.InstanceTrace $type $selfns $instance]
2054 # This proc is called when the instance command is renamed.
2055 # If op is delete, then new will always be "", so op is redundant.
2057 # type The fully-qualified type name
2058 # selfns The instance namespace
2059 # win The original instance/tk window name.
2060 # old old instance command name
2061 # new new instance command name
2062 # op rename or delete
2064 # If the op is delete, we need to clean up the object; otherwise,
2065 # we need to track the change.
2067 # NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete
2068 # traces aren't propagated correctly. Instead, they silently
2069 # vanish. Add a catch to output any error message.
2071 proc ::snit::RT.InstanceTrace {type selfns win old new op} {
2072 variable ${type}::Snit_info
2074 # Note to developers ...
2075 # For Tcl 8.4.0, errors thrown in trace handlers vanish silently.
2076 # Therefore we catch them here and create some output to help in
2077 # debugging such problems.
2080 # FIRST, clean up if necessary
2082 if {$Snit_info(isWidget)} {
2085 ::snit::RT.DestroyObject $type $selfns $win
2088 # Otherwise, track the change.
2089 variable ${selfns}::Snit_instance
2090 set Snit_instance [uplevel 1 [list namespace which -command $new]]
2092 # Also, clear the instance caches, as many cached commands
2094 RT.ClearInstanceCaches $selfns
2098 # Pop up the console on Windows wish, to enable stdout.
2099 # This clobbers errorInfo on unix, so save it so we can print it.
2101 catch {console show}
2102 puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:"
2107 # Calls the instance constructor and handles related housekeeping.
2108 proc ::snit::RT.ConstructInstance {type selfns instance arglist} {
2109 variable ${type}::Snit_optionInfo
2110 variable ${selfns}::Snit_iinfo
2112 # Track whether we are constructed or not.
2113 set Snit_iinfo(constructed) 0
2115 # Call the user's constructor
2116 eval [linsert $arglist 0 \
2117 ${type}::Snit_constructor $type $selfns $instance $instance]
2119 set Snit_iinfo(constructed) 1
2121 # Validate the initial set of options (including defaults)
2122 foreach option $Snit_optionInfo(local) {
2123 set value [set ${selfns}::options($option)]
2125 if {$Snit_optionInfo(typespec-$option) ne ""} {
2127 $Snit_optionInfo(typeobj-$option) validate $value
2129 return -code error "invalid $option default: $result"
2134 # Unset the configure cache for all -readonly options.
2135 # This ensures that the next time anyone tries to
2136 # configure it, an error is thrown.
2137 foreach opt $Snit_optionInfo(local) {
2138 if {$Snit_optionInfo(readonly-$opt)} {
2139 unset -nocomplain ${selfns}::Snit_configureCache($opt)
2146 # Returns a unique command name.
2148 # REQUIRE: type is a fully qualified name.
2149 # REQUIRE: name contains "%AUTO%"
2150 # PROMISE: the returned command name is unused.
2151 proc ::snit::RT.UniqueName {countervar type name} {
2152 upvar $countervar counter
2154 # FIRST, bump the counter and define the %AUTO% instance name;
2155 # then substitute it into the specified name. Wrap around at
2156 # 2^31 - 2 to prevent overflow problems.
2158 if {$counter > 2147483646} {
2161 set auto "[namespace tail $type]$counter"
2162 set candidate [Expand $name %AUTO% $auto]
2163 if {![llength [info commands $candidate]]} {
2169 # Returns a unique instance namespace, fully qualified.
2171 # countervar The name of a counter variable
2172 # type The instance's type
2174 # REQUIRE: type is fully qualified
2175 # PROMISE: The returned namespace name is unused.
2177 proc ::snit::RT.UniqueInstanceNamespace {countervar type} {
2178 upvar $countervar counter
2180 # FIRST, bump the counter and define the namespace name.
2181 # Then see if it already exists. Wrap around at
2182 # 2^31 - 2 to prevent overflow problems.
2184 if {$counter > 2147483646} {
2187 set ins "${type}::Snit_inst${counter}"
2188 if {![namespace exists $ins]} {
2194 # Retrieves an option's value from the option database.
2195 # Returns "" if no value is found.
2196 proc ::snit::RT.OptionDbGet {type self opt} {
2197 variable ${type}::Snit_optionInfo
2199 return [option get $self \
2200 $Snit_optionInfo(resource-$opt) \
2201 $Snit_optionInfo(class-$opt)]
2204 #-----------------------------------------------------------------------
2205 # Object Destruction
2207 # Implements the standard "destroy" method
2209 # type The snit type
2210 # selfns The instance's instance namespace
2211 # win The instance's original name
2212 # self The instance's current name
2214 proc ::snit::RT.method.destroy {type selfns win self} {
2215 variable ${selfns}::Snit_iinfo
2217 # Can't destroy the object if it isn't complete constructed.
2218 if {!$Snit_iinfo(constructed)} {
2219 return -code error "Called 'destroy' method in constructor"
2222 # Calls Snit_cleanup, which (among other things) calls the
2223 # user's destructor.
2224 ::snit::RT.DestroyObject $type $selfns $win
2227 # This is the function that really cleans up; it's automatically
2228 # called when any instance is destroyed, e.g., by "$object destroy"
2229 # for types, and by the <Destroy> event for widgets.
2231 # type The fully-qualified type name.
2232 # selfns The instance namespace
2233 # win The original instance command name.
2235 proc ::snit::RT.DestroyObject {type selfns win} {
2236 variable ${type}::Snit_info
2238 # If the variable Snit_instance doesn't exist then there's no
2239 # instance command for this object -- it's most likely a
2240 # widgetadaptor. Consequently, there are some things that
2241 # we don't need to do.
2242 if {[info exists ${selfns}::Snit_instance]} {
2243 namespace upvar $selfns Snit_instance instance
2245 # First, remove the trace on the instance name, so that we
2246 # don't call RT.DestroyObject recursively.
2247 RT.RemoveInstanceTrace $type $selfns $win $instance
2249 # Next, call the user's destructor
2250 ${type}::Snit_destructor $type $selfns $win $instance
2252 # Next, if this isn't a widget, delete the instance command.
2253 # If it is a widget, get the hull component's name, and rename
2254 # it back to the widget name
2256 # Next, delete the hull component's instance command,
2258 if {$Snit_info(isWidget)} {
2259 set hullcmd [::snit::RT.Component $type $selfns hull]
2261 catch {rename $instance ""}
2263 # Clear the bind event
2264 bind Snit$type$win <Destroy> ""
2266 if {[llength [info commands $hullcmd]]} {
2267 # FIRST, rename the hull back to its original name.
2268 # If the hull is itself a megawidget, it will have its
2269 # own cleanup to do, and it might not do it properly
2270 # if it doesn't have the right name.
2271 rename $hullcmd ::$instance
2277 catch {rename $instance ""}
2281 # Next, delete the instance's namespace. This kills any
2282 # instance variables.
2283 namespace delete $selfns
2288 # Remove instance trace
2290 # type The fully qualified type name
2291 # selfns The instance namespace
2292 # win The original instance name/Tk window name
2293 # instance The current instance name
2295 proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} {
2296 variable ${type}::Snit_info
2298 if {$Snit_info(isWidget)} {
2299 set procname ::$instance
2301 set procname $instance
2304 # NEXT, remove any trace on this name
2306 trace remove command $procname {rename delete} \
2307 [list ::snit::RT.InstanceTrace $type $selfns $win]
2311 #-----------------------------------------------------------------------
2312 # Typecomponent Management and Method Caching
2314 # Typecomponent trace; used for write trace on typecomponent
2315 # variables. Saves the new component object name, provided
2316 # that certain conditions are met. Also clears the typemethod
2319 proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} {
2320 namespace upvar $type \
2321 Snit_info Snit_info \
2323 Snit_typecomponents Snit_typecomponents
2326 # Save the new component value.
2327 set Snit_typecomponents($component) $cvar
2329 # Clear the typemethod cache.
2330 # TBD: can we unset just the elements related to
2333 # WHD: Namespace 2.0 code
2334 namespace ensemble configure $type -map {}
2337 # WHD: Snit 2.0 code
2339 # RT.UnknownTypemethod type eId eCmd method args
2342 # eId The ensemble command ID; "" for the instance itself.
2343 # eCmd The ensemble command name.
2344 # method The unknown method name.
2345 # args The additional arguments, if any.
2347 # This proc looks up the method relative to the specified ensemble.
2348 # If no method is found, it assumes that the "create" method is
2349 # desired, and that the "method" is the instance name. In this case,
2350 # it returns the "create" typemethod command with the instance name
2351 # appended; this will cause the instance to be created without updating
2352 # the -map. If the method is found, the method's command is created and
2353 # added to the -map; the function returns the empty list.
2355 proc snit::RT.UnknownTypemethod {type eId eCmd method args} {
2356 namespace upvar $type \
2357 Snit_typemethodInfo Snit_typemethodInfo \
2358 Snit_typecomponents Snit_typecomponents \
2361 # FIRST, get the pattern data and the typecomponent name.
2362 set implicitCreate 0
2366 lappend fullMethod $method
2367 set starredMethod [concat $eId *]
2368 set methodTail $method
2370 if {[info exists Snit_typemethodInfo($fullMethod)]} {
2372 } elseif {[info exists Snit_typemethodInfo($starredMethod)]} {
2373 if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} {
2374 set key $starredMethod
2376 # WHD: The method is explicitly not delegated, so this is an error.
2377 # Or should we treat it as an instance name?
2380 } elseif {[llength $fullMethod] > 1} {
2382 } elseif {$Snit_info(hasinstances)} {
2383 # Assume the unknown name is an instance name to create, unless
2384 # this is a widget and the style of the name is wrong, or the
2385 # name mimics a standard typemethod.
2387 if {[set ${type}::Snit_info(isWidget)] &&
2388 ![string match ".*" $method]} {
2392 # Without this check, the call "$type info" will redefine the
2393 # standard "::info" command, with disastrous results. Since it's
2394 # a likely thing to do if !-typeinfo, put in an explicit check.
2395 if {$method eq "info" || $method eq "destroy"} {
2399 set implicitCreate 1
2400 set instanceName $method
2407 foreach {flag pattern compName} $Snit_typemethodInfo($key) {}
2410 # FIRST, define the ensemble command.
2413 set newCmd ${type}::Snit_ten[llength $eId]_[join $eId _]
2415 set unknownCmd [list ::snit::RT.UnknownTypemethod \
2418 set createCmd [list namespace ensemble create \
2420 -unknown $unknownCmd \
2423 namespace eval $type $createCmd
2425 # NEXT, add the method to the current ensemble
2426 set map [namespace ensemble configure $eCmd -map]
2428 dict append map $method $newCmd
2430 namespace ensemble configure $eCmd -map $map
2435 # NEXT, build the substitution list
2440 %m [lindex $fullMethod end] \
2441 %j [join $fullMethod _]]
2443 if {$compName ne ""} {
2444 if {![info exists Snit_typecomponents($compName)]} {
2445 error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\""
2448 lappend subList %c [list $Snit_typecomponents($compName)]
2453 foreach subpattern $pattern {
2454 lappend command [string map $subList $subpattern]
2457 if {$implicitCreate} {
2458 # In this case, $method is the name of the instance to
2459 # create. Don't cache, as we usually won't do this one
2461 lappend command $instanceName
2466 # NEXT, if the actual command name isn't fully qualified,
2467 # assume it's global.
2468 set cmd [lindex $command 0]
2470 if {[string index $cmd 0] ne ":"} {
2471 set command [lreplace $command 0 0 "::$cmd"]
2474 # NEXT, update the ensemble map.
2475 set map [namespace ensemble configure $eCmd -map]
2477 dict append map $method $command
2479 namespace ensemble configure $eCmd -map $map
2484 #-----------------------------------------------------------------------
2485 # Component Management and Method Caching
2487 # Retrieves the object name given the component name.
2488 proc ::snit::RT.Component {type selfns name} {
2489 variable ${selfns}::Snit_components
2491 if {[catch {set Snit_components($name)} result]} {
2492 variable ${selfns}::Snit_instance
2494 error "component \"$name\" is undefined in $type $Snit_instance"
2500 # Component trace; used for write trace on component instance
2501 # variables. Saves the new component object name, provided
2502 # that certain conditions are met. Also clears the method
2505 proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} {
2506 namespace upvar $type Snit_info Snit_info
2507 namespace upvar $selfns \
2509 Snit_components Snit_components
2511 # If they try to redefine the hull component after
2512 # it's been defined, that's an error--but only if
2513 # this is a widget or widget adaptor.
2514 if {"hull" == $component &&
2515 $Snit_info(isWidget) &&
2516 [info exists Snit_components($component)]} {
2517 set cvar $Snit_components($component)
2518 error "The hull component cannot be redefined"
2521 # Save the new component value.
2522 set Snit_components($component) $cvar
2524 # Clear the instance caches.
2525 # TBD: can we unset just the elements related to
2527 RT.ClearInstanceCaches $selfns
2530 # WHD: Snit 2.0 code
2532 # RT.UnknownMethod type selfns win eId eCmd method args
2534 # type The type or widget command.
2535 # selfns The instance namespace.
2536 # win The original instance name.
2537 # eId The ensemble command ID; "" for the instance itself.
2538 # eCmd The real ensemble command name
2539 # method The unknown method name
2540 # args The additional arguments, if any.
2542 # This proc looks up the method relative to the specific ensemble.
2543 # If no method is found, it returns an empty list; this will result in
2544 # the parent ensemble throwing an error.
2545 # If the method is found, the ensemble's -map is extended with the
2546 # correct command, and the empty list is returned; this caches the
2547 # method's command. If the method is found, and it is also an
2548 # ensemble, the ensemble command is created with an empty map.
2550 proc ::snit::RT.UnknownMethod {type selfns win eId eCmd method args} {
2551 variable ${type}::Snit_info
2552 variable ${type}::Snit_methodInfo
2553 variable ${type}::Snit_typecomponents
2554 variable ${selfns}::Snit_components
2556 # FIRST, get the "self" value
2557 set self [set ${selfns}::Snit_instance]
2559 # FIRST, get the pattern data and the component name.
2561 lappend fullMethod $method
2562 set starredMethod [concat $eId *]
2563 set methodTail $method
2565 if {[info exists Snit_methodInfo($fullMethod)]} {
2567 } elseif {[info exists Snit_methodInfo($starredMethod)] &&
2568 [lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} {
2569 set key $starredMethod
2574 foreach {flag pattern compName} $Snit_methodInfo($key) {}
2577 # FIRST, define the ensemble command.
2580 # Fix provided by Anton Kovalenko; previously this call erroneously
2581 # used ${type} rather than ${selfns}.
2582 set newCmd ${selfns}::Snit_en[llength $eId]_[join $eId _]
2584 set unknownCmd [list ::snit::RT.UnknownMethod \
2585 $type $selfns $win $eId]
2587 set createCmd [list namespace ensemble create \
2589 -unknown $unknownCmd \
2592 namespace eval $selfns $createCmd
2594 # NEXT, add the method to the current ensemble
2595 set map [namespace ensemble configure $eCmd -map]
2597 dict append map $method $newCmd
2599 namespace ensemble configure $eCmd -map $map
2604 # NEXT, build the substitution list
2609 %m [lindex $fullMethod end] \
2610 %j [join $fullMethod _] \
2615 if {$compName ne ""} {
2616 if {[info exists Snit_components($compName)]} {
2617 set compCmd $Snit_components($compName)
2618 } elseif {[info exists Snit_typecomponents($compName)]} {
2619 set compCmd $Snit_typecomponents($compName)
2621 error "$type $self delegates method \"$fullMethod\" to undefined component \"$compName\""
2624 lappend subList %c [list $compCmd]
2627 # Note: The cached command will execute faster if it's
2631 foreach subpattern $pattern {
2632 lappend command [string map $subList $subpattern]
2635 # NEXT, if the actual command name isn't fully qualified,
2636 # assume it's global.
2638 set cmd [lindex $command 0]
2640 if {[string index $cmd 0] ne ":"} {
2641 set command [lreplace $command 0 0 "::$cmd"]
2644 # NEXT, update the ensemble map.
2645 set map [namespace ensemble configure $eCmd -map]
2647 dict append map $method $command
2649 namespace ensemble configure $eCmd -map $map
2654 # Clears all instance command caches
2655 proc ::snit::RT.ClearInstanceCaches {selfns} {
2656 # WHD: clear ensemble -map
2657 if {![info exists ${selfns}::Snit_instance]} {
2658 # Component variable set prior to constructor
2659 # via the "variable" type definition statement.
2662 set self [set ${selfns}::Snit_instance]
2663 namespace ensemble configure $self -map {}
2665 unset -nocomplain -- ${selfns}::Snit_cgetCache
2666 unset -nocomplain -- ${selfns}::Snit_configureCache
2667 unset -nocomplain -- ${selfns}::Snit_validateCache
2671 #-----------------------------------------------------------------------
2672 # Component Installation
2674 # Implements %TYPE%::installhull. The variables self and selfns
2675 # must be defined in the caller's context.
2677 # Installs the named widget as the hull of a
2678 # widgetadaptor. Once the widget is hijacked, its new name
2679 # is assigned to the hull component.
2681 proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} {
2682 variable ${type}::Snit_info
2683 variable ${type}::Snit_optionInfo
2685 upvar 1 selfns selfns
2686 namespace upvar $selfns \
2690 # FIRST, make sure we can do it.
2691 if {!$Snit_info(isWidget)} {
2692 error "installhull is valid only for snit::widgetadaptors"
2695 if {[info exists ${selfns}::Snit_instance]} {
2696 error "hull already installed for $type $self"
2699 # NEXT, has it been created yet? If not, create it using
2700 # the specified arguments.
2701 if {"using" == $using} {
2702 # FIRST, create the widget
2703 set cmd [linsert $args 0 $widgetType $self]
2704 set obj [uplevel 1 $cmd]
2706 # NEXT, for each option explicitly delegated to the hull
2707 # that doesn't appear in the usedOpts list, get the
2708 # option database value and apply it--provided that the
2709 # real option name and the target option name are different.
2710 # (If they are the same, then the option database was
2711 # already queried as part of the normal widget creation.)
2713 # Also, we don't need to worry about implicitly delegated
2714 # options, as the option and target option names must be
2716 if {[info exists Snit_optionInfo(delegated-hull)]} {
2718 # FIRST, extract all option names from args
2720 set ndx [lsearch -glob $args "-*"]
2721 foreach {opt val} [lrange $args $ndx end] {
2722 lappend usedOpts $opt
2725 foreach opt $Snit_optionInfo(delegated-hull) {
2726 set target [lindex $Snit_optionInfo(target-$opt) 1]
2728 if {"$target" == $opt} {
2732 set result [lsearch -exact $usedOpts $target]
2734 if {$result != -1} {
2738 set dbval [RT.OptionDbGet $type $self $opt]
2739 $obj configure $target $dbval
2745 if {$obj ne $self} {
2747 "hull name mismatch: \"$obj\" != \"$self\""
2751 # NEXT, get the local option defaults.
2752 foreach opt $Snit_optionInfo(local) {
2753 set dbval [RT.OptionDbGet $type $self $opt]
2756 set options($opt) $dbval
2761 # NEXT, do the magic
2765 set newName "::hull${i}$self"
2766 if {![llength [info commands $newName]]} {
2771 rename ::$self $newName
2772 RT.MakeInstanceCommand $type $selfns $self
2774 # Note: this relies on RT.ComponentTrace to do the dirty work.
2780 # Implements %TYPE%::install.
2782 # Creates a widget and installs it as the named component.
2783 # It expects self and selfns to be defined in the caller's context.
2785 proc ::snit::RT.install {type compName "using" widgetType winPath args} {
2786 variable ${type}::Snit_optionInfo
2787 variable ${type}::Snit_info
2789 upvar 1 selfns selfns
2791 namespace upvar ${selfns} \
2795 # We do the magic option database stuff only if $self is
2797 if {$Snit_info(isWidget)} {
2799 error "tried to install \"$compName\" before the hull exists"
2802 # FIRST, query the option database and save the results
2803 # into args. Insert them before the first option in the
2804 # list, in case there are any non-standard parameters.
2806 # Note: there might not be any delegated options; if so,
2809 if {[info exists Snit_optionInfo(delegated-$compName)]} {
2810 set ndx [lsearch -glob $args "-*"]
2812 foreach opt $Snit_optionInfo(delegated-$compName) {
2813 set dbval [RT.OptionDbGet $type $self $opt]
2816 set target [lindex $Snit_optionInfo(target-$opt) 1]
2817 set args [linsert $args $ndx $target $dbval]
2823 # NEXT, create the component and save it.
2824 set cmd [concat [list $widgetType $winPath] $args]
2825 set comp [uplevel 1 $cmd]
2827 # NEXT, handle the option database for "delegate option *",
2829 if {$Snit_info(isWidget) && $Snit_optionInfo(starcomp) eq $compName} {
2830 # FIRST, get the list of option specs from the widget.
2831 # If configure doesn't work, skip it.
2832 if {[catch {$comp configure} specs]} {
2836 # NEXT, get the set of explicitly used options from args
2838 set ndx [lsearch -glob $args "-*"]
2839 foreach {opt val} [lrange $args $ndx end] {
2840 lappend usedOpts $opt
2843 # NEXT, "delegate option *" matches all options defined
2844 # by this widget that aren't defined by the widget as a whole,
2845 # and that aren't excepted. Plus, we skip usedOpts. So build
2846 # a list of the options it can't match.
2847 set skiplist [concat \
2849 $Snit_optionInfo(except) \
2850 $Snit_optionInfo(local) \
2851 $Snit_optionInfo(delegated)]
2853 # NEXT, loop over all of the component's options, and set
2854 # any not in the skip list for which there is an option
2856 foreach spec $specs {
2858 if {[llength $spec] != 5} {
2862 set opt [lindex $spec 0]
2864 if {[lsearch -exact $skiplist $opt] != -1} {
2868 set res [lindex $spec 1]
2869 set cls [lindex $spec 2]
2871 set dbvalue [option get $self $res $cls]
2873 if {"" != $dbvalue} {
2874 $comp configure $opt $dbvalue
2883 #-----------------------------------------------------------------------
2884 # Method/Variable Name Qualification
2886 # Implements %TYPE%::variable. Requires selfns.
2887 proc ::snit::RT.variable {varname} {
2888 upvar 1 selfns selfns
2890 if {![string match "::*" $varname]} {
2891 uplevel 1 [list upvar 1 ${selfns}::$varname $varname]
2893 # varname is fully qualified; let the standard
2894 # "variable" command handle it.
2895 uplevel 1 [list ::variable $varname]
2899 # Fully qualifies a typevariable name.
2901 # This is used to implement the mytypevar command.
2903 proc ::snit::RT.mytypevar {type name} {
2904 return ${type}::$name
2907 # Fully qualifies an instance variable name.
2909 # This is used to implement the myvar command.
2910 proc ::snit::RT.myvar {name} {
2911 upvar 1 selfns selfns
2912 return ${selfns}::$name
2915 # Use this like "list" to convert a proc call into a command
2916 # string to pass to another object (e.g., as a -command).
2917 # Qualifies the proc name properly.
2919 # This is used to implement the "myproc" command.
2921 proc ::snit::RT.myproc {type procname args} {
2922 set procname "${type}::$procname"
2923 return [linsert $args 0 $procname]
2927 proc ::snit::RT.codename {type name} {
2928 return "${type}::$name"
2931 # Use this like "list" to convert a typemethod call into a command
2932 # string to pass to another object (e.g., as a -command).
2933 # Inserts the type command at the beginning.
2935 # This is used to implement the "mytypemethod" command.
2937 proc ::snit::RT.mytypemethod {type args} {
2938 return [linsert $args 0 $type]
2941 # Use this like "list" to convert a method call into a command
2942 # string to pass to another object (e.g., as a -command).
2943 # Inserts the code at the beginning to call the right object, even if
2944 # the object's name has changed. Requires that selfns be defined
2945 # in the calling context, eg. can only be called in instance
2948 # This is used to implement the "mymethod" command.
2950 proc ::snit::RT.mymethod {args} {
2951 upvar 1 selfns selfns
2952 return [linsert $args 0 ::snit::RT.CallInstance ${selfns}]
2955 # Calls an instance method for an object given its
2956 # instance namespace and remaining arguments (the first of which
2957 # will be the method name.
2959 # selfns The instance namespace
2960 # args The arguments
2962 # Uses the selfns to determine $self, and calls the method
2963 # in the normal way.
2965 # This is used to implement the "mymethod" command.
2967 proc ::snit::RT.CallInstance {selfns args} {
2968 namespace upvar $selfns Snit_instance self
2970 set retval [catch {uplevel 1 [linsert $args 0 $self]} result]
2976 return -code error -errorinfo $errorInfo \
2977 -errorcode $errorCode $result
2979 return -code $retval $result
2986 # Looks for the named option in the named variable. If found,
2987 # it and its value are removed from the list, and the value
2988 # is returned. Otherwise, the default value is returned.
2989 # If the option is undelegated, it's own default value will be
2990 # used if none is specified.
2992 # Implements the "from" command.
2994 proc ::snit::RT.from {type argvName option {defvalue ""}} {
2995 namespace upvar $type Snit_optionInfo Snit_optionInfo
2996 upvar $argvName argv
2998 set ioption [lsearch -exact $argv $option]
3000 if {$ioption == -1} {
3001 if {"" == $defvalue &&
3002 [info exists Snit_optionInfo(default-$option)]} {
3003 return $Snit_optionInfo(default-$option)
3009 set ivalue [expr {$ioption + 1}]
3010 set value [lindex $argv $ivalue]
3012 set argv [lreplace $argv $ioption $ivalue]
3017 #-----------------------------------------------------------------------
3020 # Implements the standard "destroy" typemethod:
3021 # Destroys a type completely.
3023 # type The snit type
3025 proc ::snit::RT.typemethod.destroy {type} {
3026 variable ${type}::Snit_info
3028 # FIRST, destroy all instances
3029 foreach selfns [namespace children $type "${type}::Snit_inst*"] {
3030 if {![namespace exists $selfns]} {
3034 namespace upvar $selfns Snit_instance obj
3036 if {$Snit_info(isWidget)} {
3039 if {[llength [info commands $obj]]} {
3045 # NEXT, get rid of the type command.
3048 # NEXT, destroy the type's data.
3049 namespace delete $type
3054 #-----------------------------------------------------------------------
3057 # Implements the standard "cget" method
3059 # type The snit type
3060 # selfns The instance's instance namespace
3061 # win The instance's original name
3062 # self The instance's current name
3063 # option The name of the option
3065 proc ::snit::RT.method.cget {type selfns win self option} {
3066 if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} {
3067 set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option]
3069 if {[llength $command] == 0} {
3070 return -code error "unknown option \"$option\""
3077 # Retrieves and caches the command that implements "cget" for the
3080 # type The snit type
3081 # selfns The instance's instance namespace
3082 # win The instance's original name
3083 # self The instance's current name
3084 # option The name of the option
3086 proc ::snit::RT.CacheCgetCommand {type selfns win self option} {
3087 variable ${type}::Snit_optionInfo
3088 variable ${selfns}::Snit_cgetCache
3090 if {[info exists Snit_optionInfo(islocal-$option)]} {
3091 # We know the item; it's either local, or explicitly delegated.
3092 if {$Snit_optionInfo(islocal-$option)} {
3093 # It's a local option. If it has a cget method defined,
3094 # use it; otherwise just return the value.
3096 if {$Snit_optionInfo(cget-$option) eq ""} {
3097 set command [list set ${selfns}::options($option)]
3099 # WHD: Snit 2.0 code -- simpler, no slower.
3102 {*}$Snit_optionInfo(cget-$option) \
3106 set Snit_cgetCache($option) $command
3110 # Explicitly delegated option; get target
3111 set comp [lindex $Snit_optionInfo(target-$option) 0]
3112 set target [lindex $Snit_optionInfo(target-$option) 1]
3113 } elseif {$Snit_optionInfo(starcomp) ne "" &&
3114 [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
3115 # Unknown option, but unknowns are delegated; get target.
3116 set comp $Snit_optionInfo(starcomp)
3122 # Get the component's object.
3123 set obj [RT.Component $type $selfns $comp]
3125 set command [list $obj cget $target]
3126 set Snit_cgetCache($option) $command
3131 # Implements the standard "configurelist" method
3133 # type The snit type
3134 # selfns The instance's instance namespace
3135 # win The instance's original name
3136 # self The instance's current name
3137 # optionlist A list of options and their values.
3139 proc ::snit::RT.method.configurelist {type selfns win self optionlist} {
3140 variable ${type}::Snit_optionInfo
3142 foreach {option value} $optionlist {
3143 # FIRST, get the configure command, caching it if need be.
3144 if {[catch {set ${selfns}::Snit_configureCache($option)} command]} {
3145 set command [snit::RT.CacheConfigureCommand \
3146 $type $selfns $win $self $option]
3148 if {[llength $command] == 0} {
3149 return -code error "unknown option \"$option\""
3153 # NEXT, if we have a type-validation object, use it.
3154 # TBD: Should test (islocal-$option) here, but islocal
3155 # isn't defined for implicitly delegated options.
3156 if {[info exists Snit_optionInfo(typeobj-$option)]
3157 && $Snit_optionInfo(typeobj-$option) ne ""} {
3159 $Snit_optionInfo(typeobj-$option) validate $value
3161 return -code error "invalid $option value: $result"
3165 # NEXT, the caching the configure command also cached the
3166 # validate command, if any. If we have one, run it.
3167 set valcommand [set ${selfns}::Snit_validateCache($option)]
3169 if {[llength $valcommand]} {
3170 lappend valcommand $value
3171 uplevel 1 $valcommand
3174 # NEXT, configure the option with the value.
3175 lappend command $value
3182 # Retrieves and caches the command that stores the named option.
3183 # Also stores the command that validates the name option if any;
3184 # If none, the validate command is "", so that the cache is always
3187 # type The snit type
3188 # selfns The instance's instance namespace
3189 # win The instance's original name
3190 # self The instance's current name
3191 # option An option name
3193 proc ::snit::RT.CacheConfigureCommand {type selfns win self option} {
3194 variable ${type}::Snit_optionInfo
3195 variable ${selfns}::Snit_configureCache
3196 variable ${selfns}::Snit_validateCache
3198 if {[info exist Snit_optionInfo(islocal-$option)]} {
3199 # We know the item; it's either local, or explicitly delegated.
3201 if {$Snit_optionInfo(islocal-$option)} {
3202 # It's a local option.
3204 # If it's readonly, it throws an error if we're already
3206 if {$Snit_optionInfo(readonly-$option)} {
3207 if {[set ${selfns}::Snit_iinfo(constructed)]} {
3208 error "option $option can only be set at instance creation"
3212 # If it has a validate method, cache that for later.
3213 if {$Snit_optionInfo(validate-$option) ne ""} {
3214 # WHD: Snit 2.0 code -- simpler, no slower.
3217 {*}$Snit_optionInfo(validate-$option) \
3220 set Snit_validateCache($option) $command
3222 set Snit_validateCache($option) ""
3225 # If it has a configure method defined,
3226 # cache it; otherwise, just set the value.
3227 if {$Snit_optionInfo(configure-$option) eq ""} {
3228 set command [list set ${selfns}::options($option)]
3230 # WHD: Snit 2.0 code -- simpler, no slower.
3233 {*}$Snit_optionInfo(configure-$option) \
3237 set Snit_configureCache($option) $command
3241 # Delegated option: get target.
3242 set comp [lindex $Snit_optionInfo(target-$option) 0]
3243 set target [lindex $Snit_optionInfo(target-$option) 1]
3244 } elseif {$Snit_optionInfo(starcomp) != "" &&
3245 [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
3246 # Unknown option, but unknowns are delegated.
3247 set comp $Snit_optionInfo(starcomp)
3253 # There is no validate command in this case; save an empty string.
3254 set Snit_validateCache($option) ""
3256 # Get the component's object
3257 set obj [RT.Component $type $selfns $comp]
3259 set command [list $obj configure $target]
3260 set Snit_configureCache($option) $command
3265 # Implements the standard "configure" method
3267 # type The snit type
3268 # selfns The instance's instance namespace
3269 # win The instance's original name
3270 # self The instance's current name
3271 # args A list of options and their values, possibly empty.
3273 proc ::snit::RT.method.configure {type selfns win self args} {
3274 # If two or more arguments, set values as usual.
3275 if {[llength $args] >= 2} {
3276 ::snit::RT.method.configurelist $type $selfns $win $self $args
3280 # If zero arguments, acquire data for each known option
3281 # and return the list
3282 if {[llength $args] == 0} {
3284 foreach opt [RT.method.info.options $type $selfns $win $self] {
3285 # Refactor this, so that we don't need to call via $self.
3286 lappend result [RT.GetOptionDbSpec \
3287 $type $selfns $win $self $opt]
3293 # They want it for just one.
3294 set opt [lindex $args 0]
3296 return [RT.GetOptionDbSpec $type $selfns $win $self $opt]
3300 # Retrieves the option database spec for a single option.
3302 # type The snit type
3303 # selfns The instance's instance namespace
3304 # win The instance's original name
3305 # self The instance's current name
3306 # option The name of an option
3308 # TBD: This is a bad name. What it's returning is the
3309 # result of the configure query.
3311 proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} {
3312 variable ${type}::Snit_optionInfo
3314 namespace upvar $selfns \
3315 Snit_components Snit_components \
3318 if {[info exists options($opt)]} {
3319 # This is a locally-defined option. Just build the
3320 # list and return it.
3321 set res $Snit_optionInfo(resource-$opt)
3322 set cls $Snit_optionInfo(class-$opt)
3323 set def $Snit_optionInfo(default-$opt)
3325 return [list $opt $res $cls $def \
3326 [RT.method.cget $type $selfns $win $self $opt]]
3327 } elseif {[info exists Snit_optionInfo(target-$opt)]} {
3328 # This is an explicitly delegated option. The only
3329 # thing we don't have is the default.
3330 set res $Snit_optionInfo(resource-$opt)
3331 set cls $Snit_optionInfo(class-$opt)
3334 set logicalName [lindex $Snit_optionInfo(target-$opt) 0]
3335 set comp $Snit_components($logicalName)
3336 set target [lindex $Snit_optionInfo(target-$opt) 1]
3338 if {[catch {$comp configure $target} result]} {
3341 set defValue [lindex $result 3]
3344 return [list $opt $res $cls $defValue [$self cget $opt]]
3345 } elseif {$Snit_optionInfo(starcomp) ne "" &&
3346 [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
3347 set logicalName $Snit_optionInfo(starcomp)
3349 set comp $Snit_components($logicalName)
3351 if {[catch {set value [$comp cget $target]} result]} {
3352 error "unknown option \"$opt\""
3355 if {![catch {$comp configure $target} result]} {
3356 # Replace the delegated option name with the local name.
3357 return [::snit::Expand $result $target $opt]
3360 # configure didn't work; return simple form.
3361 return [list $opt "" "" "" $value]
3363 error "unknown option \"$opt\""
3367 #-----------------------------------------------------------------------
3368 # Type Introspection
3370 # Implements the standard "info" typemethod.
3372 # type The snit type
3373 # command The info subcommand
3374 # args All other arguments.
3376 proc ::snit::RT.typemethod.info {type command args} {
3380 switch -exact $command {
3387 # TBD: it should be possible to delete this error
3389 set errflag [catch {
3390 uplevel 1 [linsert $args 0 \
3391 ::snit::RT.typemethod.info.$command $type]
3395 return -code error -errorinfo $errorInfo \
3396 -errorcode $errorCode $result
3402 error "\"$type info $command\" is not defined"
3408 # Returns a list of the type's typevariables whose names match a
3409 # pattern, excluding Snit internal variables.
3412 # pattern Optional. The glob pattern to match. Defaults
3415 proc ::snit::RT.typemethod.info.typevars {type {pattern *}} {
3417 foreach name [info vars "${type}::$pattern"] {
3418 set tail [namespace tail $name]
3419 if {![string match "Snit_*" $tail]} {
3420 lappend result $name
3427 # Returns a list of the type's methods whose names match a
3428 # pattern. If "delegate typemethod *" is used, the list may
3432 # pattern Optional. The glob pattern to match. Defaults
3435 proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} {
3436 variable ${type}::Snit_typemethodInfo
3438 # FIRST, get the explicit names, skipping prefixes.
3441 foreach name [array names Snit_typemethodInfo -glob $pattern] {
3442 if {[lindex $Snit_typemethodInfo($name) 0] != 1} {
3443 lappend result $name
3447 # NEXT, add any from the cache that aren't explicit.
3448 # WHD: fixed up to use newstyle method cache/list of subcommands.
3449 if {[info exists Snit_typemethodInfo(*)]} {
3450 # First, remove "*" from the list.
3451 set ndx [lsearch -exact $result "*"]
3453 set result [lreplace $result $ndx $ndx]
3456 # Next, get the type's -map
3457 array set typemethodCache [namespace ensemble configure $type -map]
3459 # Next, get matching names from the cache that we don't already
3461 foreach name [array names typemethodCache -glob $pattern] {
3462 if {[lsearch -exact $result $name] == -1} {
3463 lappend result $name
3473 # Returns a method's list of arguments. does not work for delegated
3474 # methods, nor for the internal dispatch methods of multi-word
3477 proc ::snit::RT.typemethod.info.args {type method} {
3478 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
3480 # Snit_methodInfo: method -> list (flag cmd component)
3482 # flag : 1 -> internal dispatcher for multi-word method.
3483 # 0 -> regular method
3485 # cmd : template mapping from method to command prefix, may
3486 # contain placeholders for various pieces of information.
3488 # component : is empty for normal methods.
3490 #parray Snit_typemethodInfo
3492 if {![info exists Snit_typemethodInfo($method)]} {
3493 return -code error "Unknown typemethod \"$method\""
3495 foreach {flag cmd component} $Snit_typemethodInfo($method) break
3497 return -code error "Unknown typemethod \"$method\""
3499 if {$component != ""} {
3500 return -code error "Delegated typemethod \"$method\""
3503 set map [list %m $method %j [join $method _] %t $type]
3504 set theproc [lindex [string map $map $cmd] 0]
3505 return [lrange [::info args $theproc] 1 end]
3510 # Returns a method's body. does not work for delegated
3511 # methods, nor for the internal dispatch methods of multi-word
3514 proc ::snit::RT.typemethod.info.body {type method} {
3515 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
3517 # Snit_methodInfo: method -> list (flag cmd component)
3519 # flag : 1 -> internal dispatcher for multi-word method.
3520 # 0 -> regular method
3522 # cmd : template mapping from method to command prefix, may
3523 # contain placeholders for various pieces of information.
3525 # component : is empty for normal methods.
3527 #parray Snit_typemethodInfo
3529 if {![info exists Snit_typemethodInfo($method)]} {
3530 return -code error "Unknown typemethod \"$method\""
3532 foreach {flag cmd component} $Snit_typemethodInfo($method) break
3534 return -code error "Unknown typemethod \"$method\""
3536 if {$component != ""} {
3537 return -code error "Delegated typemethod \"$method\""
3540 set map [list %m $method %j [join $method _] %t $type]
3541 set theproc [lindex [string map $map $cmd] 0]
3542 return [RT.body [::info body $theproc]]
3545 # $type info default
3547 # Returns a method's list of arguments. does not work for delegated
3548 # methods, nor for the internal dispatch methods of multi-word
3551 proc ::snit::RT.typemethod.info.default {type method aname dvar} {
3553 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
3555 # Snit_methodInfo: method -> list (flag cmd component)
3557 # flag : 1 -> internal dispatcher for multi-word method.
3558 # 0 -> regular method
3560 # cmd : template mapping from method to command prefix, may
3561 # contain placeholders for various pieces of information.
3563 # component : is empty for normal methods.
3565 #parray Snit_methodInfo
3567 if {![info exists Snit_typemethodInfo($method)]} {
3568 return -code error "Unknown typemethod \"$method\""
3570 foreach {flag cmd component} $Snit_typemethodInfo($method) break
3572 return -code error "Unknown typemethod \"$method\""
3574 if {$component != ""} {
3575 return -code error "Delegated typemethod \"$method\""
3578 set map [list %m $method %j [join $method _] %t $type]
3579 set theproc [lindex [string map $map $cmd] 0]
3580 return [::info default $theproc $aname def]
3583 # Returns a list of the type's instances whose names match
3587 # pattern Optional. The glob pattern to match
3590 # REQUIRE: type is fully qualified.
3592 proc ::snit::RT.typemethod.info.instances {type {pattern *}} {
3595 foreach selfns [namespace children $type "${type}::Snit_inst*"] {
3596 namespace upvar $selfns Snit_instance instance
3598 if {[string match $pattern $instance]} {
3599 lappend result $instance
3606 #-----------------------------------------------------------------------
3607 # Instance Introspection
3609 # Implements the standard "info" method.
3611 # type The snit type
3612 # selfns The instance's instance namespace
3613 # win The instance's original name
3614 # self The instance's current name
3615 # command The info subcommand
3616 # args All other arguments.
3618 proc ::snit::RT.method.info {type selfns win self command args} {
3619 switch -exact $command {
3629 set errflag [catch {
3630 uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \
3631 $type $selfns $win $self]
3636 return -code error -errorinfo $errorInfo $result
3642 # error "\"$self info $command\" is not defined"
3643 return -code error "\"$self info $command\" is not defined"
3650 # Returns the instance's type
3651 proc ::snit::RT.method.info.type {type selfns win self} {
3655 # $self info typevars
3657 # Returns the instance's type's typevariables
3658 proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} {
3659 return [RT.typemethod.info.typevars $type $pattern]
3662 # $self info typemethods
3664 # Returns the instance's type's typemethods
3665 proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} {
3666 return [RT.typemethod.info.typemethods $type $pattern]
3669 # Returns a list of the instance's methods whose names match a
3670 # pattern. If "delegate method *" is used, the list may
3674 # selfns The instance namespace
3675 # win The original instance name
3676 # self The current instance name
3677 # pattern Optional. The glob pattern to match. Defaults
3680 proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} {
3681 variable ${type}::Snit_methodInfo
3683 # FIRST, get the explicit names, skipping prefixes.
3686 foreach name [array names Snit_methodInfo -glob $pattern] {
3687 if {[lindex $Snit_methodInfo($name) 0] != 1} {
3688 lappend result $name
3692 # NEXT, add any from the cache that aren't explicit.
3693 # WHD: Fixed up to use newstyle method cache/list of subcommands.
3694 if {[info exists Snit_methodInfo(*)]} {
3695 # First, remove "*" from the list.
3696 set ndx [lsearch -exact $result "*"]
3698 set result [lreplace $result $ndx $ndx]
3701 # Next, get the instance's -map
3702 set self [set ${selfns}::Snit_instance]
3704 array set methodCache [namespace ensemble configure $self -map]
3706 # Next, get matching names from the cache that we don't already
3708 foreach name [array names methodCache -glob $pattern] {
3709 if {[lsearch -exact $result $name] == -1} {
3710 lappend result $name
3720 # Returns a method's list of arguments. does not work for delegated
3721 # methods, nor for the internal dispatch methods of multi-word
3724 proc ::snit::RT.method.info.args {type selfns win self method} {
3726 upvar ${type}::Snit_methodInfo Snit_methodInfo
3728 # Snit_methodInfo: method -> list (flag cmd component)
3730 # flag : 1 -> internal dispatcher for multi-word method.
3731 # 0 -> regular method
3733 # cmd : template mapping from method to command prefix, may
3734 # contain placeholders for various pieces of information.
3736 # component : is empty for normal methods.
3738 #parray Snit_methodInfo
3740 if {![info exists Snit_methodInfo($method)]} {
3741 return -code error "Unknown method \"$method\""
3743 foreach {flag cmd component} $Snit_methodInfo($method) break
3745 return -code error "Unknown method \"$method\""
3747 if {$component != ""} {
3748 return -code error "Delegated method \"$method\""
3751 set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
3752 set theproc [lindex [string map $map $cmd] 0]
3753 return [lrange [::info args $theproc] 4 end]
3758 # Returns a method's body. does not work for delegated
3759 # methods, nor for the internal dispatch methods of multi-word
3762 proc ::snit::RT.method.info.body {type selfns win self method} {
3764 upvar ${type}::Snit_methodInfo Snit_methodInfo
3766 # Snit_methodInfo: method -> list (flag cmd component)
3768 # flag : 1 -> internal dispatcher for multi-word method.
3769 # 0 -> regular method
3771 # cmd : template mapping from method to command prefix, may
3772 # contain placeholders for various pieces of information.
3774 # component : is empty for normal methods.
3776 #parray Snit_methodInfo
3778 if {![info exists Snit_methodInfo($method)]} {
3779 return -code error "Unknown method \"$method\""
3781 foreach {flag cmd component} $Snit_methodInfo($method) break
3783 return -code error "Unknown method \"$method\""
3785 if {$component != ""} {
3786 return -code error "Delegated method \"$method\""
3789 set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
3790 set theproc [lindex [string map $map $cmd] 0]
3791 return [RT.body [::info body $theproc]]
3794 # $self info default
3796 # Returns a method's list of arguments. does not work for delegated
3797 # methods, nor for the internal dispatch methods of multi-word
3800 proc ::snit::RT.method.info.default {type selfns win self method aname dvar} {
3802 upvar ${type}::Snit_methodInfo Snit_methodInfo
3804 # Snit_methodInfo: method -> list (flag cmd component)
3806 # flag : 1 -> internal dispatcher for multi-word method.
3807 # 0 -> regular method
3809 # cmd : template mapping from method to command prefix, may
3810 # contain placeholders for various pieces of information.
3812 # component : is empty for normal methods.
3814 if {![info exists Snit_methodInfo($method)]} {
3815 return -code error "Unknown method \"$method\""
3817 foreach {flag cmd component} $Snit_methodInfo($method) break
3819 return -code error "Unknown method \"$method\""
3821 if {$component != ""} {
3822 return -code error "Delegated method \"$method\""
3825 set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
3826 set theproc [lindex [string map $map $cmd] 0]
3827 return [::info default $theproc $aname def]
3832 # Returns the instance's instance variables
3833 proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} {
3835 foreach name [info vars "${selfns}::$pattern"] {
3836 set tail [namespace tail $name]
3837 if {![string match "Snit_*" $tail]} {
3838 lappend result $name
3845 # $self info options
3847 # Returns a list of the names of the instance's options
3848 proc ::snit::RT.method.info.options {type selfns win self {pattern *}} {
3849 variable ${type}::Snit_optionInfo
3851 # First, get the local and explicitly delegated options
3852 set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)]
3854 # If "configure" works as for Tk widgets, add the resulting
3855 # options to the list. Skip excepted options
3856 if {$Snit_optionInfo(starcomp) ne ""} {
3857 namespace upvar $selfns Snit_components Snit_components
3859 set logicalName $Snit_optionInfo(starcomp)
3860 set comp $Snit_components($logicalName)
3862 if {![catch {$comp configure} records]} {
3863 foreach record $records {
3864 set opt [lindex $record 0]
3865 if {[lsearch -exact $result $opt] == -1 &&
3866 [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
3873 # Next, apply the pattern
3876 foreach name $result {
3877 if {[string match $pattern $name]} {
3885 proc ::snit::RT.body {body} {
3886 regsub -all ".*# END snit method prolog\n" $body {} body