1 #-----------------------------------------------------------------------
9 # Snit's Not Incr Tcl, a simple object system in Pure Tcl.
11 # Snit 1.x Compiler and Run-Time Library, Tcl 8.3 and later
13 # Copyright (C) 2003-2006 by William H. Duquette
14 # This code is licensed as described in license.txt.
16 #-----------------------------------------------------------------------
17 # Back-port to Tcl8.3 by Kenneth Green (kmg)
18 # Modified by Andreas Kupries.
19 # Further modified by Will Duquette 12 Aug 2006
21 # Local changes marked with "#kmg-tcl83"
24 # " trace add variable " -> "trace variable "
25 # " write " -> "w" in all calls to 'trace variable'
26 # " unset -nocomplain " -> "::snit83::unset -nocomplain"
27 #-----------------------------------------------------------------------
29 #-----------------------------------------------------------------------
32 namespace eval ::snit:: {
34 compile type widget widgetadaptor typemethod method macro
37 #-----------------------------------------------------------------------
40 namespace eval ::snit:: {
41 variable reservedArgs {type selfns win self}
43 # Widget classes which can be hulls (must have -class)
46 frame tk::frame ttk::frame
47 labelframe tk::labelframe ttk::labelframe
51 #-----------------------------------------------------------------------
52 # Snit Type Implementation template
54 namespace eval ::snit:: {
55 # Template type definition: All internal and user-visible Snit
56 # implementation code.
58 # The following placeholders will automatically be replaced with
59 # the client's code, in two passes:
62 # %COMPILEDDEFS% The compiled type definition.
65 # %TYPE% The fully qualified type name.
66 # %IVARDECS% Instance variable declarations
67 # %TVARDECS% Type variable declarations
68 # %TCONSTBODY% Type constructor body
69 # %INSTANCEVARS% The compiled instance variable initialization code.
70 # %TYPEVARS% The compiled type variable initialization code.
72 # This is the overall type template.
75 # This is the normal type proc
76 variable nominalTypeProc
78 # This is the "-hastypemethods no" type proc
79 variable simpleTypeProc
82 set ::snit::typeTemplate {
84 #-------------------------------------------------------------------
85 # The type's namespace definition and the user's type variables
87 namespace eval %TYPE% {%TYPEVARS%
90 #----------------------------------------------------------------
91 # Commands for use in methods, typemethods, etc.
93 # These are implemented as aliases into the Snit runtime library.
95 interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE%
96 interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE%
97 interp alias {} %TYPE%::typevariable {} ::variable
98 interp alias {} %TYPE%::variable {} ::snit::RT.variable
99 interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE%
100 interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE%
101 interp alias {} %TYPE%::myvar {} ::snit::RT.myvar
102 interp alias {} %TYPE%::varname {} ::snit::RT.myvar
103 interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE%
104 interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE%
105 interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod
106 interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE%
107 interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE%
109 #-------------------------------------------------------------------
110 # Snit's internal variables
112 namespace eval %TYPE% {
113 # Array: General Snit Info
115 # ns: The type's namespace
116 # hasinstances: T or F, from pragma -hasinstances.
117 # simpledispatch: T or F, from pragma -hasinstances.
118 # canreplace: T or F, from pragma -canreplace.
119 # counter: Count of instances created so far.
120 # widgetclass: Set by widgetclass statement.
121 # hulltype: Hull type (frame or toplevel) for widgets only.
122 # exceptmethods: Methods explicitly not delegated to *
123 # excepttypemethods: Methods explicitly not delegated to *
124 # tvardecs: Type variable declarations--for dynamic methods
125 # ivardecs: Instance variable declarations--for dyn. methods
126 typevariable Snit_info
127 set Snit_info(ns) %TYPE%::
128 set Snit_info(hasinstances) 1
129 set Snit_info(simpledispatch) 0
130 set Snit_info(canreplace) 0
131 set Snit_info(counter) 0
132 set Snit_info(widgetclass) {}
133 set Snit_info(hulltype) frame
134 set Snit_info(exceptmethods) {}
135 set Snit_info(excepttypemethods) {}
136 set Snit_info(tvardecs) {%TVARDECS%}
137 set Snit_info(ivardecs) {%IVARDECS%}
139 # Array: Public methods of this type.
140 # The index is the method name, or "*".
141 # The value is [list $pattern $componentName], where
142 # $componentName is "" for normal methods.
143 typevariable Snit_typemethodInfo
144 array unset Snit_typemethodInfo
146 # Array: Public methods of instances of this type.
147 # The index is the method name, or "*".
148 # The value is [list $pattern $componentName], where
149 # $componentName is "" for normal methods.
150 typevariable Snit_methodInfo
151 array unset Snit_methodInfo
153 # Array: option information. See dictionary.txt.
154 typevariable Snit_optionInfo
155 array unset Snit_optionInfo
156 set Snit_optionInfo(local) {}
157 set Snit_optionInfo(delegated) {}
158 set Snit_optionInfo(starcomp) {}
159 set Snit_optionInfo(except) {}
162 #----------------------------------------------------------------
165 # These commands are created or replaced during compilation:
168 # Snit_instanceVars selfns
170 # Initializes the instance variables, if any. Called during
173 proc %TYPE%::Snit_instanceVars {selfns} {
178 proc %TYPE%::Snit_typeconstructor {type} {
183 #----------------------------------------------------------------
186 # These commands might be replaced during compilation:
188 # Snit_destructor type selfns win self
190 # Default destructor for the type. By default, it does
191 # nothing. It's replaced by any user destructor.
192 # For types, it's called by method destroy; for widgettypes,
193 # it's called by a destroy event handler.
195 proc %TYPE%::Snit_destructor {type selfns win self} { }
197 #----------------------------------------------------------
198 # Compiled Definitions
202 #----------------------------------------------------------
203 # Finally, call the Type Constructor
205 %TYPE%::Snit_typeconstructor %TYPE%
208 #-----------------------------------------------------------------------
211 # These procs expect the fully-qualified type name to be
212 # substituted in for %TYPE%.
214 # This is the nominal type proc. It supports typemethods and
215 # delegated typemethods.
216 set ::snit::nominalTypeProc {
217 # Type dispatcher function. Note: This function lives
218 # in the parent of the %TYPE% namespace! All accesses to
219 # %TYPE% variables and methods must be qualified!
220 proc %TYPE% {{method ""} args} {
221 # First, if there's no method, and no args, and there's a create
222 # method, and this isn't a widget, then method is "create" and
224 if {"" == $method && [llength $args] == 0} {
225 ::variable %TYPE%::Snit_info
227 if {$Snit_info(hasinstances) && !$Snit_info(isWidget)} {
231 error "wrong \# args: should be \"%TYPE% method args\""
235 # Next, retrieve the command.
236 variable %TYPE%::Snit_typemethodCache
238 if {[catch {set Snit_typemethodCache($method)} commandRec]} {
239 set commandRec [::snit::RT.CacheTypemethodCommand %TYPE% $method]
241 if {[llength $commandRec] == 0} {
242 return -code error "\"%TYPE% $method\" is not defined"
246 # If we've got a real command, break.
247 if {[lindex $commandRec 0] == 0} {
251 # Otherwise, we need to look up again...if we can.
252 if {[llength $args] == 0} {
254 "wrong number args: should be \"%TYPE% $method method args\""
257 lappend method [lindex $args 0]
258 set args [lrange $args 1 end]
261 set command [lindex $commandRec 1]
263 # Pass along the return code unchanged.
264 set retval [catch {uplevel 1 $command $args} result]
270 return -code error -errorinfo $errorInfo \
271 -errorcode $errorCode $result
273 return -code $retval $result
281 # This is the simplified type proc for when there are no typemethods
282 # except create. In this case, it doesn't take a method argument;
283 # the method is always "create".
284 set ::snit::simpleTypeProc {
285 # Type dispatcher function. Note: This function lives
286 # in the parent of the %TYPE% namespace! All accesses to
287 # %TYPE% variables and methods must be qualified!
289 ::variable %TYPE%::Snit_info
291 # FIRST, if the are no args, the single arg is %AUTO%
292 if {[llength $args] == 0} {
293 if {$Snit_info(isWidget)} {
294 error "wrong \# args: should be \"%TYPE% name args\""
300 # NEXT, we're going to call the create method.
301 # Pass along the return code unchanged.
302 if {$Snit_info(isWidget)} {
303 set command [list ::snit::RT.widget.typemethod.create %TYPE%]
305 set command [list ::snit::RT.type.typemethod.create %TYPE%]
308 set retval [catch {uplevel 1 $command $args} result]
314 return -code error -errorinfo $errorInfo \
315 -errorcode $errorCode $result
317 return -code $retval $result
325 #-----------------------------------------------------------------------
328 # The following must be substituted into these proc bodies:
330 # %SELFNS% The instance namespace
331 # %WIN% The original instance name
332 # %TYPE% The fully-qualified type name
335 # Nominal instance proc body: supports method caching and delegation.
337 # proc $instanceName {method args} ....
338 set ::snit::nominalInstanceProc {
339 set self [set %SELFNS%::Snit_instance]
342 if {[catch {set %SELFNS%::Snit_methodCache($method)} commandRec]} {
343 set commandRec [snit::RT.CacheMethodCommand %TYPE% %SELFNS% %WIN% $self $method]
345 if {[llength $commandRec] == 0} {
347 "\"$self $method\" is not defined"
351 # If we've got a real command, break.
352 if {[lindex $commandRec 0] == 0} {
356 # Otherwise, we need to look up again...if we can.
357 if {[llength $args] == 0} {
359 "wrong number args: should be \"$self $method method args\""
362 lappend method [lindex $args 0]
363 set args [lrange $args 1 end]
366 set command [lindex $commandRec 1]
368 # Pass along the return code unchanged.
369 set retval [catch {uplevel 1 $command $args} result]
375 return -code error -errorinfo $errorInfo \
376 -errorcode $errorCode $result
378 return -code $retval $result
385 # Simplified method proc body: No delegation allowed; no support for
386 # upvar or exotic return codes or hierarchical methods. Designed for
387 # max speed for simple types.
389 # proc $instanceName {method args} ....
391 set ::snit::simpleInstanceProc {
392 set self [set %SELFNS%::Snit_instance]
394 if {[lsearch -exact ${%TYPE%::Snit_methods} $method] == -1} {
395 set optlist [join ${%TYPE%::Snit_methods} ", "]
396 set optlist [linsert $optlist "end-1" "or"]
397 error "bad option \"$method\": must be $optlist"
400 eval [linsert $args 0 \
401 %TYPE%::Snit_method$method %TYPE% %SELFNS% %WIN% $self]
405 #=======================================================================
406 # Snit Type Definition
408 # These are the procs used to define Snit types, widgets, and
412 #-----------------------------------------------------------------------
413 # Snit Compilation Variables
415 # The following variables are used while Snit is compiling a type,
416 # and are disposed afterwards.
418 namespace eval ::snit:: {
419 # The compiler variable contains the name of the slave interpreter
420 # used to compile type definitions.
423 # The compile array accumulates information about the type or
424 # widgettype being compiled. It is cleared before and after each
425 # compilation. It has these indices:
427 # type: The name of the type being compiled, for use
428 # in compilation procs.
429 # defs: Compiled definitions, both standard and client.
430 # which: type, widget, widgetadaptor
431 # instancevars: Instance variable definitions and initializations.
432 # ivprocdec: Instance variable proc declarations.
433 # tvprocdec: Type variable proc declarations.
434 # typeconstructor: Type constructor body.
435 # widgetclass: The widgetclass, for snit::widgets, only
436 # hasoptions: False, initially; set to true when first
438 # localoptions: Names of local options.
439 # delegatedoptions: Names of delegated options.
440 # localmethods: Names of locally defined methods.
441 # delegatesmethods: no if no delegated methods, yes otherwise.
442 # hashierarchic : no if no hierarchic methods, yes otherwise.
443 # components: Names of defined components.
444 # typecomponents: Names of defined typecomponents.
445 # typevars: Typevariable definitions and initializations.
446 # varnames: Names of instance variables
447 # typevarnames Names of type variables
448 # hasconstructor False, initially; true when constructor is
450 # resource-$opt The option's resource name
451 # class-$opt The option's class
452 # -default-$opt The option's default value
453 # -validatemethod-$opt The option's validate method
454 # -configuremethod-$opt The option's configure method
455 # -cgetmethod-$opt The option's cget method.
456 # -hastypeinfo The -hastypeinfo pragma
457 # -hastypedestroy The -hastypedestroy pragma
458 # -hastypemethods The -hastypemethods pragma
459 # -hasinfo The -hasinfo pragma
460 # -hasinstances The -hasinstances pragma
461 # -simpledispatch The -simpledispatch pragma
462 # -canreplace The -canreplace pragma
465 # This variable accumulates method dispatch information; it has
466 # the same structure as the %TYPE%::Snit_methodInfo array, and is
467 # used to initialize it.
470 # This variable accumulates typemethod dispatch information; it has
471 # the same structure as the %TYPE%::Snit_typemethodInfo array, and is
472 # used to initialize it.
473 variable typemethodInfo
475 # The following variable lists the reserved type definition statement
476 # names, e.g., the names you can't use as macros. It's built at
477 # compiler definition time using "info commands".
478 variable reservedwords {}
481 #-----------------------------------------------------------------------
482 # type compilation commands
484 # The type and widgettype commands use a slave interpreter to compile
485 # the type definition. These are the procs
486 # that are aliased into it.
488 # Initialize the compiler
489 proc ::snit::Comp.Init {} {
491 variable reservedwords
493 if {"" == $compiler} {
494 # Create the compiler's interpreter
495 set compiler [interp create]
497 # Initialize the interpreter
503 # Load package information
504 # TBD: see if this can be moved outside.
505 # @mdgen NODEP: ::snit::__does_not_exist__
506 catch {package require ::snit::__does_not_exist__}
508 # Protect some Tcl commands our type definitions
511 rename variable _variable
514 # Define compilation aliases.
515 $compiler alias pragma ::snit::Comp.statement.pragma
516 $compiler alias widgetclass ::snit::Comp.statement.widgetclass
517 $compiler alias hulltype ::snit::Comp.statement.hulltype
518 $compiler alias constructor ::snit::Comp.statement.constructor
519 $compiler alias destructor ::snit::Comp.statement.destructor
520 $compiler alias option ::snit::Comp.statement.option
521 $compiler alias oncget ::snit::Comp.statement.oncget
522 $compiler alias onconfigure ::snit::Comp.statement.onconfigure
523 $compiler alias method ::snit::Comp.statement.method
524 $compiler alias typemethod ::snit::Comp.statement.typemethod
525 $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor
526 $compiler alias proc ::snit::Comp.statement.proc
527 $compiler alias typevariable ::snit::Comp.statement.typevariable
528 $compiler alias variable ::snit::Comp.statement.variable
529 $compiler alias typecomponent ::snit::Comp.statement.typecomponent
530 $compiler alias component ::snit::Comp.statement.component
531 $compiler alias delegate ::snit::Comp.statement.delegate
532 $compiler alias expose ::snit::Comp.statement.expose
534 # Get the list of reserved words
535 set reservedwords [$compiler eval {info commands}]
539 # Compile a type definition, and return the results as a list of two
540 # items: the fully-qualified type name, and a script that will define
541 # the type when executed.
543 # which type, widget, or widgetadaptor
545 # body the type definition
546 proc ::snit::Comp.Compile {which type body} {
547 variable typeTemplate
548 variable nominalTypeProc
549 variable simpleTypeProc
553 variable typemethodInfo
555 # FIRST, qualify the name.
556 if {![string match "::*" $type]} {
557 # Get caller's namespace;
558 # append :: if not global namespace.
559 set ns [uplevel 2 [list namespace current]]
567 # NEXT, create and initialize the compiler, if needed.
570 # NEXT, initialize the class data
571 array unset methodInfo
572 array unset typemethodInfo
575 set compile(type) $type
577 set compile(which) $which
578 set compile(hasoptions) no
579 set compile(localoptions) {}
580 set compile(instancevars) {}
581 set compile(typevars) {}
582 set compile(delegatedoptions) {}
583 set compile(ivprocdec) {}
584 set compile(tvprocdec) {}
585 set compile(typeconstructor) {}
586 set compile(widgetclass) {}
587 set compile(hulltype) {}
588 set compile(localmethods) {}
589 set compile(delegatesmethods) no
590 set compile(hashierarchic) no
591 set compile(components) {}
592 set compile(typecomponents) {}
593 set compile(varnames) {}
594 set compile(typevarnames) {}
595 set compile(hasconstructor) no
596 set compile(-hastypedestroy) yes
597 set compile(-hastypeinfo) yes
598 set compile(-hastypemethods) yes
599 set compile(-hasinfo) yes
600 set compile(-hasinstances) yes
601 set compile(-simpledispatch) no
602 set compile(-canreplace) no
604 set isWidget [string match widget* $which]
605 set isWidgetAdaptor [string match widgetadaptor $which]
607 # NEXT, Evaluate the type's definition in the class interpreter.
610 # NEXT, Add the standard definitions
611 append compile(defs) \
612 "\nset %TYPE%::Snit_info(isWidget) $isWidget\n"
614 append compile(defs) \
615 "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n"
617 # Indicate whether the type can create instances that replace
619 append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n"
622 # Check pragmas for conflict.
624 if {!$compile(-hastypemethods) && !$compile(-hasinstances)} {
625 error "$which $type has neither typemethods nor instances"
628 if {$compile(-simpledispatch) && $compile(delegatesmethods)} {
629 error "$which $type requests -simpledispatch but delegates methods."
632 if {$compile(-simpledispatch) && $compile(hashierarchic)} {
633 error "$which $type requests -simpledispatch but defines hierarchical methods."
636 # If there are typemethods, define the standard typemethods and
637 # the nominal type proc. Otherwise define the simple type proc.
638 if {$compile(-hastypemethods)} {
639 # Add the info typemethod unless the pragma forbids it.
640 if {$compile(-hastypeinfo)} {
641 Comp.statement.delegate typemethod info \
642 using {::snit::RT.typemethod.info %t}
645 # Add the destroy typemethod unless the pragma forbids it.
646 if {$compile(-hastypedestroy)} {
647 Comp.statement.delegate typemethod destroy \
648 using {::snit::RT.typemethod.destroy %t}
651 # Add the nominal type proc.
652 append compile(defs) $nominalTypeProc
654 # Add the simple type proc.
655 append compile(defs) $simpleTypeProc
658 # Add standard methods/typemethods that only make sense if the
659 # type has instances.
660 if {$compile(-hasinstances)} {
661 # If we're using simple dispatch, remember that.
662 if {$compile(-simpledispatch)} {
663 append compile(defs) "\nset %TYPE%::Snit_info(simpledispatch) 1\n"
666 # Add the info method unless the pragma forbids it.
667 if {$compile(-hasinfo)} {
668 if {!$compile(-simpledispatch)} {
669 Comp.statement.delegate method info \
670 using {::snit::RT.method.info %t %n %w %s}
672 Comp.statement.method info {args} {
673 eval [linsert $args 0 \
674 ::snit::RT.method.info $type $selfns $win $self]
679 # Add the option handling stuff if there are any options.
680 if {$compile(hasoptions)} {
681 Comp.statement.variable options
683 if {!$compile(-simpledispatch)} {
684 Comp.statement.delegate method cget \
685 using {::snit::RT.method.cget %t %n %w %s}
686 Comp.statement.delegate method configurelist \
687 using {::snit::RT.method.configurelist %t %n %w %s}
688 Comp.statement.delegate method configure \
689 using {::snit::RT.method.configure %t %n %w %s}
691 Comp.statement.method cget {args} {
692 eval [linsert $args 0 \
693 ::snit::RT.method.cget $type $selfns $win $self]
695 Comp.statement.method configurelist {args} {
696 eval [linsert $args 0 \
697 ::snit::RT.method.configurelist $type $selfns $win $self]
699 Comp.statement.method configure {args} {
700 eval [linsert $args 0 \
701 ::snit::RT.method.configure $type $selfns $win $self]
706 # Add a default constructor, if they haven't already defined one.
707 # If there are options, it will configure args; otherwise it
709 if {!$compile(hasconstructor)} {
710 if {$compile(hasoptions)} {
711 Comp.statement.constructor {args} {
712 $self configurelist $args
715 Comp.statement.constructor {} {}
720 if {!$compile(-simpledispatch)} {
721 Comp.statement.delegate method destroy \
722 using {::snit::RT.method.destroy %t %n %w %s}
724 Comp.statement.method destroy {args} {
725 eval [linsert $args 0 \
726 ::snit::RT.method.destroy $type $selfns $win $self]
730 Comp.statement.delegate typemethod create \
731 using {::snit::RT.type.typemethod.create %t}
733 Comp.statement.delegate typemethod create \
734 using {::snit::RT.widget.typemethod.create %t}
737 # Save the list of method names, for -simpledispatch; otherwise,
738 # save the method info.
739 if {$compile(-simpledispatch)} {
740 append compile(defs) \
741 "\nset %TYPE%::Snit_methods [list $compile(localmethods)]\n"
743 append compile(defs) \
744 "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n"
748 append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n"
751 # NEXT, compiling the type definition built up a set of information
752 # about the type's locally defined options; add this information to
753 # the compiled definition.
756 # NEXT, compiling the type definition built up a set of information
757 # about the typemethods; save the typemethod info.
758 append compile(defs) \
759 "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n"
761 # NEXT, if this is a widget define the hull component if it isn't
764 Comp.DefineComponent hull
767 # NEXT, substitute the compiled definition into the type template
768 # to get the type definition script.
769 set defscript [Expand $typeTemplate \
770 %COMPILEDDEFS% $compile(defs)]
772 # NEXT, substitute the defined macros into the type definition script.
773 # This is done as a separate step so that the compile(defs) can
774 # contain the macros defined below.
776 set defscript [Expand $defscript \
778 %IVARDECS% $compile(ivprocdec) \
779 %TVARDECS% $compile(tvprocdec) \
780 %TCONSTBODY% $compile(typeconstructor) \
781 %INSTANCEVARS% $compile(instancevars) \
782 %TYPEVARS% $compile(typevars) \
787 return [list $type $defscript]
790 # Information about locally-defined options is accumulated during
791 # compilation, but not added to the compiled definition--the option
792 # statement can appear multiple times, so it's easier this way.
793 # This proc fills in Snit_optionInfo with the accumulated information.
795 # It also computes the option's resource and class names if needed.
797 # Note that the information for delegated options was put in
798 # Snit_optionInfo during compilation.
800 proc ::snit::Comp.SaveOptionInfo {} {
803 foreach option $compile(localoptions) {
804 if {"" == $compile(resource-$option)} {
805 set compile(resource-$option) [string range $option 1 end]
808 if {"" == $compile(class-$option)} {
809 set compile(class-$option) [Capitalize $compile(resource-$option)]
812 # NOTE: Don't verify that the validate, configure, and cget
813 # values name real methods; the methods might be defined outside
814 # the typedefinition using snit::method.
816 Mappend compile(defs) {
818 lappend %TYPE%::Snit_optionInfo(local) %OPTION%
820 set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1
821 set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE%
822 set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
823 set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT%
824 set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE%
825 set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE%
826 set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET%
827 set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY%
828 set %TYPE%::Snit_optionInfo(typespec-%OPTION%) %TYPESPEC%
830 %RESOURCE% $compile(resource-$option) \
831 %CLASS% $compile(class-$option) \
832 %DEFAULT% [list $compile(-default-$option)] \
833 %VALIDATE% [list $compile(-validatemethod-$option)] \
834 %CONFIGURE% [list $compile(-configuremethod-$option)] \
835 %CGET% [list $compile(-cgetmethod-$option)] \
836 %READONLY% $compile(-readonly-$option) \
837 %TYPESPEC% [list $compile(-type-$option)]
842 # Evaluates a compiled type definition, thus making the type available.
843 proc ::snit::Comp.Define {compResult} {
844 # The compilation result is a list containing the fully qualified
845 # type name and a script to evaluate to define the type.
846 set type [lindex $compResult 0]
847 set defscript [lindex $compResult 1]
849 # Execute the type definition script.
850 # Consider using namespace eval %TYPE%. See if it's faster.
851 if {[catch {eval $defscript} result]} {
852 namespace delete $type
853 catch {rename $type ""}
860 # Sets pragma options which control how the type is defined.
861 proc ::snit::Comp.statement.pragma {args} {
864 set errRoot "Error in \"pragma...\""
866 foreach {opt val} $args {
867 switch -exact -- $opt {
875 if {![string is boolean -strict $val]} {
876 error "$errRoot, \"$opt\" requires a boolean value"
878 set compile($opt) $val
881 error "$errRoot, unknown pragma"
887 # Defines a widget's option class name.
888 # This statement is only available for snit::widgets,
889 # not for snit::types or snit::widgetadaptors.
890 proc ::snit::Comp.statement.widgetclass {name} {
893 # First, widgetclass can only be set for true widgets
894 if {"widget" != $compile(which)} {
895 error "widgetclass cannot be set for snit::$compile(which)s"
898 # Next, validate the option name. We'll require that it begin
899 # with an uppercase letter.
900 set initial [string index $name 0]
901 if {![string is upper $initial]} {
902 error "widgetclass \"$name\" does not begin with an uppercase letter"
905 if {"" != $compile(widgetclass)} {
906 error "too many widgetclass statements"
910 Mappend compile(defs) {
911 set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS%
912 } %WIDGETCLASS% [list $name]
914 set compile(widgetclass) $name
917 # Defines a widget's hull type.
918 # This statement is only available for snit::widgets,
919 # not for snit::types or snit::widgetadaptors.
920 proc ::snit::Comp.statement.hulltype {name} {
924 # First, hulltype can only be set for true widgets
925 if {"widget" != $compile(which)} {
926 error "hulltype cannot be set for snit::$compile(which)s"
929 # Next, it must be one of the valid hulltypes (frame, toplevel, ...)
930 if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} {
931 error "invalid hulltype \"$name\", should be one of\
932 [join $hulltypes {, }]"
935 if {"" != $compile(hulltype)} {
936 error "too many hulltype statements"
940 Mappend compile(defs) {
941 set %TYPE%::Snit_info(hulltype) %HULLTYPE%
944 set compile(hulltype) $name
947 # Defines a constructor.
948 proc ::snit::Comp.statement.constructor {arglist body} {
951 CheckArgs "constructor" $arglist
953 # Next, add a magic reference to self.
954 set arglist [concat type selfns win self $arglist]
956 # Next, add variable declarations to body:
957 set body "%TVARDECS%%IVARDECS%\n$body"
959 set compile(hasconstructor) yes
960 append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n"
963 # Defines a destructor.
964 proc ::snit::Comp.statement.destructor {body} {
967 # Next, add variable declarations to body:
968 set body "%TVARDECS%%IVARDECS%\n$body"
970 append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n"
973 # Defines a type option. The option value can be a triple, specifying
974 # the option's -name, resource name, and class name.
975 proc ::snit::Comp.statement.option {optionDef args} {
978 # First, get the three option names.
979 set option [lindex $optionDef 0]
980 set resourceName [lindex $optionDef 1]
981 set className [lindex $optionDef 2]
983 set errRoot "Error in \"option [list $optionDef]...\""
985 # Next, validate the option name.
986 if {![Comp.OptionNameIsValid $option]} {
987 error "$errRoot, badly named option \"$option\""
990 if {[Contains $option $compile(delegatedoptions)]} {
991 error "$errRoot, cannot define \"$option\" locally, it has been delegated"
994 if {![Contains $option $compile(localoptions)]} {
995 # Remember that we've seen this one.
996 set compile(hasoptions) yes
997 lappend compile(localoptions) $option
999 # Initialize compilation info for this option.
1000 set compile(resource-$option) ""
1001 set compile(class-$option) ""
1002 set compile(-default-$option) ""
1003 set compile(-validatemethod-$option) ""
1004 set compile(-configuremethod-$option) ""
1005 set compile(-cgetmethod-$option) ""
1006 set compile(-readonly-$option) 0
1007 set compile(-type-$option) ""
1010 # NEXT, see if we have a resource name. If so, make sure it
1011 # isn't being redefined differently.
1012 if {"" != $resourceName} {
1013 if {"" == $compile(resource-$option)} {
1014 # If it's undefined, just save the value.
1015 set compile(resource-$option) $resourceName
1016 } elseif {![string equal $resourceName $compile(resource-$option)]} {
1017 # It's been redefined differently.
1018 error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\""
1022 # NEXT, see if we have a class name. If so, make sure it
1023 # isn't being redefined differently.
1024 if {"" != $className} {
1025 if {"" == $compile(class-$option)} {
1026 # If it's undefined, just save the value.
1027 set compile(class-$option) $className
1028 } elseif {![string equal $className $compile(class-$option)]} {
1029 # It's been redefined differently.
1030 error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\""
1034 # NEXT, handle the args; it's not an error to redefine these.
1035 if {[llength $args] == 1} {
1036 set compile(-default-$option) [lindex $args 0]
1038 foreach {optopt val} $args {
1039 switch -exact -- $optopt {
1044 set compile($optopt-$option) $val
1047 set compile($optopt-$option) $val
1049 if {[llength $val] == 1} {
1050 # The type spec *is* the validation object
1051 append compile(defs) \
1052 "\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n"
1054 # Compilation the creation of the validation object
1055 set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%]
1056 append compile(defs) \
1057 "\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n"
1061 if {![string is boolean -strict $val]} {
1062 error "$errRoot, -readonly requires a boolean, got \"$val\""
1064 set compile($optopt-$option) $val
1067 error "$errRoot, unknown option definition option \"$optopt\""
1074 # 1 if the option name is valid, 0 otherwise.
1075 proc ::snit::Comp.OptionNameIsValid {option} {
1076 if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} {
1083 # Defines an option's cget handler
1084 proc ::snit::Comp.statement.oncget {option body} {
1087 set errRoot "Error in \"oncget $option...\""
1089 if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
1090 return -code error "$errRoot, option \"$option\" is delegated"
1093 if {[lsearch -exact $compile(localoptions) $option] == -1} {
1094 return -code error "$errRoot, option \"$option\" unknown"
1097 Comp.statement.method _cget$option {_option} $body
1098 Comp.statement.option $option -cgetmethod _cget$option
1101 # Defines an option's configure handler.
1102 proc ::snit::Comp.statement.onconfigure {option arglist body} {
1105 if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
1106 return -code error "onconfigure $option: option \"$option\" is delegated"
1109 if {[lsearch -exact $compile(localoptions) $option] == -1} {
1110 return -code error "onconfigure $option: option \"$option\" unknown"
1113 if {[llength $arglist] != 1} {
1115 "onconfigure $option handler should have one argument, got \"$arglist\""
1118 CheckArgs "onconfigure $option" $arglist
1120 # Next, add a magic reference to the option name
1121 set arglist [concat _option $arglist]
1123 Comp.statement.method _configure$option $arglist $body
1124 Comp.statement.option $option -configuremethod _configure$option
1127 # Defines an instance method.
1128 proc ::snit::Comp.statement.method {method arglist body} {
1132 # FIRST, check the method name against previously defined
1134 Comp.CheckMethodName $method 0 ::snit::methodInfo \
1135 "Error in \"method [list $method]...\""
1137 if {[llength $method] > 1} {
1138 set compile(hashierarchic) yes
1141 # Remeber this method
1142 lappend compile(localmethods) $method
1144 CheckArgs "method [list $method]" $arglist
1146 # Next, add magic references to type and self.
1147 set arglist [concat type selfns win self $arglist]
1149 # Next, add variable declarations to body:
1150 set body "%TVARDECS%%IVARDECS%\n# END snit method prolog\n$body"
1152 # Next, save the definition script.
1153 if {[llength $method] == 1} {
1154 set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
1155 Mappend compile(defs) {
1156 proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY%
1157 } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
1159 set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
1161 Mappend compile(defs) {
1162 proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY%
1163 } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \
1168 # Check for name collisions; save prefix information.
1170 # method The name of the method or typemethod.
1171 # delFlag 1 if delegated, 0 otherwise.
1172 # infoVar The fully qualified name of the array containing
1173 # information about the defined methods.
1174 # errRoot The root string for any error messages.
1176 proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} {
1177 upvar $infoVar methodInfo
1179 # FIRST, make sure the method name is a valid Tcl list.
1180 if {[catch {lindex $method 0}]} {
1181 error "$errRoot, the name \"$method\" must have list syntax."
1184 # NEXT, check whether we can define it.
1185 if {![catch {set methodInfo($method)} data]} {
1186 # We can't redefine methods with submethods.
1187 if {[lindex $data 0] == 1} {
1188 error "$errRoot, \"$method\" has submethods."
1191 # You can't delegate a method that's defined locally,
1192 # and you can't define a method locally if it's been delegated.
1193 if {$delFlag && "" == [lindex $data 2]} {
1194 error "$errRoot, \"$method\" has been defined locally."
1195 } elseif {!$delFlag && "" != [lindex $data 2]} {
1196 error "$errRoot, \"$method\" has been delegated"
1200 # Handle hierarchical case.
1201 if {[llength $method] > 1} {
1204 while {[llength $tokens] > 1} {
1205 lappend prefix [lindex $tokens 0]
1206 set tokens [lrange $tokens 1 end]
1208 if {![catch {set methodInfo($prefix)} result]} {
1209 # Prefix is known. If it's not a prefix, throw an
1211 if {[lindex $result 0] == 0} {
1212 error "$errRoot, \"$prefix\" has no submethods."
1216 set methodInfo($prefix) [list 1]
1221 # Defines a typemethod method.
1222 proc ::snit::Comp.statement.typemethod {method arglist body} {
1224 variable typemethodInfo
1226 # FIRST, check the typemethod name against previously defined
1228 Comp.CheckMethodName $method 0 ::snit::typemethodInfo \
1229 "Error in \"typemethod [list $method]...\""
1231 CheckArgs "typemethod $method" $arglist
1233 # First, add magic reference to type.
1234 set arglist [concat type $arglist]
1236 # Next, add typevariable declarations to body:
1237 set body "%TVARDECS%\n# END snit method prolog\n$body"
1239 # Next, save the definition script
1240 if {[llength $method] == 1} {
1241 set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
1243 Mappend compile(defs) {
1244 proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY%
1245 } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
1247 set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
1249 Mappend compile(defs) {
1250 proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY%
1251 } %JMETHOD% [join $method _] \
1252 %ARGLIST% [list $arglist] %BODY% [list $body]
1257 # Defines a type constructor.
1258 proc ::snit::Comp.statement.typeconstructor {body} {
1261 if {"" != $compile(typeconstructor)} {
1262 error "too many typeconstructors"
1265 set compile(typeconstructor) $body
1268 # Defines a static proc in the type's namespace.
1269 proc ::snit::Comp.statement.proc {proc arglist body} {
1272 # If "ns" is defined, the proc can see instance variables.
1273 if {[lsearch -exact $arglist selfns] != -1} {
1274 # Next, add instance variable declarations to body:
1275 set body "%IVARDECS%\n$body"
1278 # The proc can always see typevariables.
1279 set body "%TVARDECS%\n$body"
1281 append compile(defs) "
1284 proc [list %TYPE%::$proc $arglist $body]
1288 # Defines a static variable in the type's namespace.
1289 proc ::snit::Comp.statement.typevariable {name args} {
1292 set errRoot "Error in \"typevariable $name...\""
1294 set len [llength $args]
1297 ($len == 2 && "-array" != [lindex $args 0])} {
1298 error "$errRoot, too many initializers"
1301 if {[lsearch -exact $compile(varnames) $name] != -1} {
1302 error "$errRoot, \"$name\" is already an instance variable"
1305 lappend compile(typevarnames) $name
1308 append compile(typevars) \
1309 "\n\t [list ::variable $name [lindex $args 0]]"
1310 } elseif {$len == 2} {
1311 append compile(typevars) \
1312 "\n\t [list ::variable $name]"
1313 append compile(typevars) \
1314 "\n\t [list array set $name [lindex $args 1]]"
1316 append compile(typevars) \
1317 "\n\t [list ::variable $name]"
1320 append compile(tvprocdec) "\n\t typevariable ${name}"
1323 # Defines an instance variable; the definition will go in the
1324 # type's create typemethod.
1325 proc ::snit::Comp.statement.variable {name args} {
1328 set errRoot "Error in \"variable $name...\""
1330 set len [llength $args]
1333 ($len == 2 && "-array" != [lindex $args 0])} {
1334 error "$errRoot, too many initializers"
1337 if {[lsearch -exact $compile(typevarnames) $name] != -1} {
1338 error "$errRoot, \"$name\" is already a typevariable"
1341 lappend compile(varnames) $name
1344 append compile(instancevars) \
1345 "\nset \${selfns}::$name [list [lindex $args 0]]\n"
1346 } elseif {$len == 2} {
1347 append compile(instancevars) \
1348 "\narray set \${selfns}::$name [list [lindex $args 1]]\n"
1351 append compile(ivprocdec) "\n\t "
1352 Mappend compile(ivprocdec) {::variable ${selfns}::%N} %N $name
1355 # Defines a typecomponent, and handles component options.
1357 # component The logical name of the delegate
1360 proc ::snit::Comp.statement.typecomponent {component args} {
1363 set errRoot "Error in \"typecomponent $component...\""
1365 # FIRST, define the component
1366 Comp.DefineTypecomponent $component $errRoot
1368 # NEXT, handle the options.
1372 foreach {opt val} $args {
1373 switch -exact -- $opt {
1375 set publicMethod $val
1378 set inheritFlag $val
1379 if {![string is boolean $inheritFlag]} {
1380 error "typecomponent $component -inherit: expected boolean value, got \"$val\""
1384 error "typecomponent $component: Invalid option \"$opt\""
1389 # NEXT, if -public specified, define the method.
1390 if {"" != $publicMethod} {
1391 Comp.statement.delegate typemethod [list $publicMethod *] to $component
1394 # NEXT, if "-inherit 1" is specified, delegate typemethod * to
1397 Comp.statement.delegate typemethod "*" to $component
1403 # Defines a name to be a typecomponent
1405 # The name becomes a typevariable; in addition, it gets a
1406 # write trace so that when it is set, all of the component mechanisms
1409 # component The component name
1411 proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} {
1414 if {[lsearch -exact $compile(varnames) $component] != -1} {
1415 error "$errRoot, \"$component\" is already an instance variable"
1418 if {[lsearch -exact $compile(typecomponents) $component] == -1} {
1419 # Remember we've done this.
1420 lappend compile(typecomponents) $component
1422 # Make it a type variable with no initial value
1423 Comp.statement.typevariable $component ""
1425 # Add a write trace to do the component thing.
1426 Mappend compile(typevars) {
1427 trace variable %COMP% w \
1428 [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%]
1429 } %TYPE% $compile(type) %COMP% $component
1433 # Defines a component, and handles component options.
1435 # component The logical name of the delegate
1438 # TBD: Ideally, it should be possible to call this statement multiple
1439 # times, possibly changing the option values. To do that, I'd need
1440 # to cache the option values and not act on them until *after* I'd
1441 # read the entire type definition.
1443 proc ::snit::Comp.statement.component {component args} {
1446 set errRoot "Error in \"component $component...\""
1448 # FIRST, define the component
1449 Comp.DefineComponent $component $errRoot
1451 # NEXT, handle the options.
1455 foreach {opt val} $args {
1456 switch -exact -- $opt {
1458 set publicMethod $val
1461 set inheritFlag $val
1462 if {![string is boolean $inheritFlag]} {
1463 error "component $component -inherit: expected boolean value, got \"$val\""
1467 error "component $component: Invalid option \"$opt\""
1472 # NEXT, if -public specified, define the method.
1473 if {"" != $publicMethod} {
1474 Comp.statement.delegate method [list $publicMethod *] to $component
1477 # NEXT, if -inherit is specified, delegate method/option * to
1480 Comp.statement.delegate method "*" to $component
1481 Comp.statement.delegate option "*" to $component
1486 # Defines a name to be a component
1488 # The name becomes an instance variable; in addition, it gets a
1489 # write trace so that when it is set, all of the component mechanisms
1492 # component The component name
1494 proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} {
1497 if {[lsearch -exact $compile(typevarnames) $component] != -1} {
1498 error "$errRoot, \"$component\" is already a typevariable"
1501 if {[lsearch -exact $compile(components) $component] == -1} {
1502 # Remember we've done this.
1503 lappend compile(components) $component
1505 # Make it an instance variable with no initial value
1506 Comp.statement.variable $component ""
1508 # Add a write trace to do the component thing.
1509 Mappend compile(instancevars) {
1510 trace variable ${selfns}::%COMP% w \
1511 [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%]
1512 } %TYPE% $compile(type) %COMP% $component
1516 # Creates a delegated method, typemethod, or option.
1517 proc ::snit::Comp.statement.delegate {what name args} {
1518 # FIRST, dispatch to correct handler.
1520 typemethod { Comp.DelegatedTypemethod $name $args }
1521 method { Comp.DelegatedMethod $name $args }
1522 option { Comp.DelegatedOption $name $args }
1524 error "Error in \"delegate $what $name...\", \"$what\"?"
1528 if {([llength $args] % 2) != 0} {
1529 error "Error in \"delegate $what $name...\", invalid syntax"
1533 # Creates a delegated typemethod delegating it to a particular
1534 # typecomponent or an arbitrary command.
1536 # method The name of the method
1537 # arglist Delegation options
1539 proc ::snit::Comp.DelegatedTypemethod {method arglist} {
1541 variable typemethodInfo
1543 set errRoot "Error in \"delegate typemethod [list $method]...\""
1545 # Next, parse the delegation options.
1550 set methodTail [lindex $method end]
1552 foreach {opt value} $arglist {
1553 switch -exact $opt {
1554 to { set component $value }
1555 as { set target $value }
1556 except { set exceptions $value }
1557 using { set pattern $value }
1559 error "$errRoot, unknown delegation option \"$opt\""
1564 if {"" == $component && "" == $pattern} {
1565 error "$errRoot, missing \"to\""
1568 if {"*" == $methodTail && "" != $target} {
1569 error "$errRoot, cannot specify \"as\" with \"*\""
1572 if {"*" != $methodTail && "" != $exceptions} {
1573 error "$errRoot, can only specify \"except\" with \"*\""
1576 if {"" != $pattern && "" != $target} {
1577 error "$errRoot, cannot specify both \"as\" and \"using\""
1580 foreach token [lrange $method 1 end-1] {
1581 if {"*" == $token} {
1582 error "$errRoot, \"*\" must be the last token."
1586 # NEXT, define the component
1587 if {"" != $component} {
1588 Comp.DefineTypecomponent $component $errRoot
1591 # NEXT, define the pattern.
1592 if {"" == $pattern} {
1593 if {"*" == $methodTail} {
1595 } elseif {"" != $target} {
1596 set pattern "%c $target"
1602 # Make sure the pattern is a valid list.
1603 if {[catch {lindex $pattern 0} result]} {
1604 error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
1607 # NEXT, check the method name against previously defined
1609 Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot
1611 set typemethodInfo($method) [list 0 $pattern $component]
1613 if {[string equal $methodTail "*"]} {
1614 Mappend compile(defs) {
1615 set %TYPE%::Snit_info(excepttypemethods) %EXCEPT%
1616 } %EXCEPT% [list $exceptions]
1621 # Creates a delegated method delegating it to a particular
1622 # component or command.
1624 # method The name of the method
1625 # arglist Delegation options.
1627 proc ::snit::Comp.DelegatedMethod {method arglist} {
1631 set errRoot "Error in \"delegate method [list $method]...\""
1633 # Next, parse the delegation options.
1638 set methodTail [lindex $method end]
1640 foreach {opt value} $arglist {
1641 switch -exact $opt {
1642 to { set component $value }
1643 as { set target $value }
1644 except { set exceptions $value }
1645 using { set pattern $value }
1647 error "$errRoot, unknown delegation option \"$opt\""
1652 if {"" == $component && "" == $pattern} {
1653 error "$errRoot, missing \"to\""
1656 if {"*" == $methodTail && "" != $target} {
1657 error "$errRoot, cannot specify \"as\" with \"*\""
1660 if {"*" != $methodTail && "" != $exceptions} {
1661 error "$errRoot, can only specify \"except\" with \"*\""
1664 if {"" != $pattern && "" != $target} {
1665 error "$errRoot, cannot specify both \"as\" and \"using\""
1668 foreach token [lrange $method 1 end-1] {
1669 if {"*" == $token} {
1670 error "$errRoot, \"*\" must be the last token."
1674 # NEXT, we delegate some methods
1675 set compile(delegatesmethods) yes
1677 # NEXT, define the component. Allow typecomponents.
1678 if {"" != $component} {
1679 if {[lsearch -exact $compile(typecomponents) $component] == -1} {
1680 Comp.DefineComponent $component $errRoot
1684 # NEXT, define the pattern.
1685 if {"" == $pattern} {
1686 if {"*" == $methodTail} {
1688 } elseif {"" != $target} {
1689 set pattern "%c $target"
1695 # Make sure the pattern is a valid list.
1696 if {[catch {lindex $pattern 0} result]} {
1697 error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
1700 # NEXT, check the method name against previously defined
1702 Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot
1704 # NEXT, save the method info.
1705 set methodInfo($method) [list 0 $pattern $component]
1707 if {[string equal $methodTail "*"]} {
1708 Mappend compile(defs) {
1709 set %TYPE%::Snit_info(exceptmethods) %EXCEPT%
1710 } %EXCEPT% [list $exceptions]
1714 # Creates a delegated option, delegating it to a particular
1715 # component and, optionally, to a particular option of that
1718 # optionDef The option definition
1719 # args definition arguments.
1721 proc ::snit::Comp.DelegatedOption {optionDef arglist} {
1724 # First, get the three option names.
1725 set option [lindex $optionDef 0]
1726 set resourceName [lindex $optionDef 1]
1727 set className [lindex $optionDef 2]
1729 set errRoot "Error in \"delegate option [list $optionDef]...\""
1731 # Next, parse the delegation options.
1736 foreach {opt value} $arglist {
1737 switch -exact $opt {
1738 to { set component $value }
1739 as { set target $value }
1740 except { set exceptions $value }
1742 error "$errRoot, unknown delegation option \"$opt\""
1747 if {"" == $component} {
1748 error "$errRoot, missing \"to\""
1751 if {"*" == $option && "" != $target} {
1752 error "$errRoot, cannot specify \"as\" with \"delegate option *\""
1755 if {"*" != $option && "" != $exceptions} {
1756 error "$errRoot, can only specify \"except\" with \"delegate option *\""
1759 # Next, validate the option name
1761 if {"*" != $option} {
1762 if {![Comp.OptionNameIsValid $option]} {
1763 error "$errRoot, badly named option \"$option\""
1767 if {[Contains $option $compile(localoptions)]} {
1768 error "$errRoot, \"$option\" has been defined locally"
1771 if {[Contains $option $compile(delegatedoptions)]} {
1772 error "$errRoot, \"$option\" is multiply delegated"
1775 # NEXT, define the component
1776 Comp.DefineComponent $component $errRoot
1778 # Next, define the target option, if not specified.
1779 if {![string equal $option "*"] &&
1780 [string equal $target ""]} {
1784 # NEXT, save the delegation data.
1785 set compile(hasoptions) yes
1787 if {![string equal $option "*"]} {
1788 lappend compile(delegatedoptions) $option
1790 # Next, compute the resource and class names, if they aren't
1793 if {"" == $resourceName} {
1794 set resourceName [string range $option 1 end]
1797 if {"" == $className} {
1798 set className [Capitalize $resourceName]
1801 Mappend compile(defs) {
1802 set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0
1803 set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES%
1804 set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
1805 lappend %TYPE%::Snit_optionInfo(delegated) %OPTION%
1806 set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%]
1807 lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION%
1808 } %OPTION% $option \
1811 %RES% $resourceName \
1814 Mappend compile(defs) {
1815 set %TYPE%::Snit_optionInfo(starcomp) %COMP%
1816 set %TYPE%::Snit_optionInfo(except) %EXCEPT%
1817 } %COMP% $component %EXCEPT% [list $exceptions]
1821 # Exposes a component, effectively making the component's command an
1824 # component The logical name of the delegate
1825 # "as" sugar; if not "", must be "as"
1826 # methodname The desired method name for the component's command, or ""
1828 proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} {
1832 # FIRST, define the component
1833 Comp.DefineComponent $component
1835 # NEXT, define the method just as though it were in the type
1837 if {[string equal $methodname ""]} {
1838 set methodname $component
1841 Comp.statement.method $methodname args [Expand {
1842 if {[llength $args] == 0} {
1846 if {[string equal $%COMPONENT% ""]} {
1847 error "undefined component \"%COMPONENT%\""
1851 set cmd [linsert $args 0 $%COMPONENT%]
1852 return [uplevel 1 $cmd]
1853 } %COMPONENT% $component]
1858 #-----------------------------------------------------------------------
1861 # Compile a type definition, and return the results as a list of two
1862 # items: the fully-qualified type name, and a script that will define
1863 # the type when executed.
1865 # which type, widget, or widgetadaptor
1866 # type the type name
1867 # body the type definition
1868 proc ::snit::compile {which type body} {
1869 return [Comp.Compile $which $type $body]
1872 proc ::snit::type {type body} {
1873 return [Comp.Define [Comp.Compile type $type $body]]
1876 proc ::snit::widget {type body} {
1877 return [Comp.Define [Comp.Compile widget $type $body]]
1880 proc ::snit::widgetadaptor {type body} {
1881 return [Comp.Define [Comp.Compile widgetadaptor $type $body]]
1884 proc ::snit::typemethod {type method arglist body} {
1885 # Make sure the type exists.
1886 if {![info exists ${type}::Snit_info]} {
1887 error "no such type: \"$type\""
1890 upvar ${type}::Snit_info Snit_info
1891 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
1893 # FIRST, check the typemethod name against previously defined
1895 Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \
1896 "Cannot define \"$method\""
1898 # NEXT, check the arguments
1899 CheckArgs "snit::typemethod $type $method" $arglist
1901 # Next, add magic reference to type.
1902 set arglist [concat type $arglist]
1904 # Next, add typevariable declarations to body:
1905 set body "$Snit_info(tvardecs)\n$body"
1908 if {[llength $method] == 1} {
1909 set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
1910 uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body]
1912 set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
1913 set suffix [join $method _]
1914 uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body]
1918 proc ::snit::method {type method arglist body} {
1919 # Make sure the type exists.
1920 if {![info exists ${type}::Snit_info]} {
1921 error "no such type: \"$type\""
1924 upvar ${type}::Snit_methodInfo Snit_methodInfo
1925 upvar ${type}::Snit_info Snit_info
1927 # FIRST, check the method name against previously defined
1929 Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \
1930 "Cannot define \"$method\""
1932 # NEXT, check the arguments
1933 CheckArgs "snit::method $type $method" $arglist
1935 # Next, add magic references to type and self.
1936 set arglist [concat type selfns win self $arglist]
1938 # Next, add variable declarations to body:
1939 set body "$Snit_info(tvardecs)$Snit_info(ivardecs)\n$body"
1942 if {[llength $method] == 1} {
1943 set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
1944 uplevel 1 [list proc ${type}::Snit_method$method $arglist $body]
1946 set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
1948 set suffix [join $method _]
1949 uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body]
1953 # Defines a proc within the compiler; this proc can call other
1954 # type definition statements, and thus can be used for meta-programming.
1955 proc ::snit::macro {name arglist body} {
1957 variable reservedwords
1959 # FIRST, make sure the compiler is defined.
1962 # NEXT, check the macro name against the reserved words
1963 if {[lsearch -exact $reservedwords $name] != -1} {
1964 error "invalid macro name \"$name\""
1967 # NEXT, see if the name has a namespace; if it does, define the
1969 set ns [namespace qualifiers $name]
1972 $compiler eval "namespace eval $ns {}"
1975 # NEXT, define the macro
1976 $compiler eval [list _proc $name $arglist $body]
1979 #-----------------------------------------------------------------------
1982 # These are utility functions used while compiling Snit types.
1984 # Builds a template from a tagged list of text blocks, then substitutes
1985 # all symbols in the mapTable, returning the expanded template.
1986 proc ::snit::Expand {template args} {
1987 return [string map $args $template]
1990 # Expands a template and appends it to a variable.
1991 proc ::snit::Mappend {varname template args} {
1992 upvar $varname myvar
1994 append myvar [string map $args $template]
1997 # Checks argument list against reserved args
1998 proc ::snit::CheckArgs {which arglist} {
1999 variable reservedArgs
2001 foreach name $reservedArgs {
2002 if {[Contains $name $arglist]} {
2003 error "$which's arglist may not contain \"$name\" explicitly"
2008 # Returns 1 if a value is in a list, and 0 otherwise.
2009 proc ::snit::Contains {value list} {
2010 if {[lsearch -exact $list $value] != -1} {
2017 # Capitalizes the first letter of a string.
2018 proc ::snit::Capitalize {text} {
2019 set first [string index $text 0]
2020 set rest [string range $text 1 end]
2021 return "[string toupper $first]$rest"
2024 # Converts an arbitrary white-space-delimited string into a list
2025 # by splitting on white-space and deleting empty tokens.
2027 proc ::snit::Listify {str} {
2029 foreach token [split [string trim $str]] {
2030 if {[string length $token] > 0} {
2031 lappend result $token
2039 #=======================================================================
2040 # Snit Runtime Library
2042 # These are procs used by Snit types and widgets at runtime.
2044 #-----------------------------------------------------------------------
2047 # Creates a new instance of the snit::type given its name and the args.
2049 # type The snit::type
2050 # name The instance name
2051 # args Args to pass to the constructor
2053 proc ::snit::RT.type.typemethod.create {type name args} {
2054 variable ${type}::Snit_info
2055 variable ${type}::Snit_optionInfo
2057 # FIRST, qualify the name.
2058 if {![string match "::*" $name]} {
2059 # Get caller's namespace;
2060 # append :: if not global namespace.
2061 set ns [uplevel 1 [list namespace current]]
2069 # NEXT, if %AUTO% appears in the name, generate a unique
2070 # command name. Otherwise, ensure that the name isn't in use.
2071 if {[string match "*%AUTO%*" $name]} {
2072 set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
2073 } elseif {$Snit_info(canreplace) && [llength [info commands $name]]} {
2077 # Had to add this elseif branch to pass test rename-1.5
2079 # Allowed to replace so must first destroy the prior instance
2082 } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} {
2083 error "command \"$name\" already exists"
2086 # NEXT, create the instance's namespace.
2088 [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
2089 namespace eval $selfns {}
2091 # NEXT, install the dispatcher
2092 RT.MakeInstanceCommand $type $selfns $name
2094 # Initialize the options to their defaults.
2095 upvar ${selfns}::options options
2096 foreach opt $Snit_optionInfo(local) {
2097 set options($opt) $Snit_optionInfo(default-$opt)
2100 # Initialize the instance vars to their defaults.
2101 # selfns must be defined, as it is used implicitly.
2102 ${type}::Snit_instanceVars $selfns
2104 # Execute the type's constructor.
2105 set errcode [catch {
2106 RT.ConstructInstance $type $selfns $name $args
2113 set theInfo $errorInfo
2114 set theCode $errorCode
2115 ::snit::RT.DestroyObject $type $selfns $name
2116 error "Error in constructor: $result" $theInfo $theCode
2119 # NEXT, return the object's name.
2123 # Creates a new instance of the snit::widget or snit::widgetadaptor
2124 # given its name and the args.
2126 # type The snit::widget or snit::widgetadaptor
2127 # name The instance name
2128 # args Args to pass to the constructor
2130 proc ::snit::RT.widget.typemethod.create {type name args} {
2131 variable ${type}::Snit_info
2132 variable ${type}::Snit_optionInfo
2134 # FIRST, if %AUTO% appears in the name, generate a unique
2136 if {[string match "*%AUTO%*" $name]} {
2137 set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
2140 # NEXT, create the instance's namespace.
2142 [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
2143 namespace eval $selfns { }
2145 # NEXT, Initialize the widget's own options to their defaults.
2146 upvar ${selfns}::options options
2147 foreach opt $Snit_optionInfo(local) {
2148 set options($opt) $Snit_optionInfo(default-$opt)
2151 # Initialize the instance vars to their defaults.
2152 ${type}::Snit_instanceVars $selfns
2154 # NEXT, if this is a normal widget (not a widget adaptor) then create a
2155 # frame as its hull. We set the frame's -class to the user's widgetclass,
2156 # or, if none, search for -class in the args list, otherwise default to
2157 # the basename of the $type with an initial upper case letter.
2158 if {!$Snit_info(isWidgetAdaptor)} {
2159 # FIRST, determine the class name
2160 set wclass $Snit_info(widgetclass)
2161 if {$Snit_info(widgetclass) == ""} {
2162 set idx [lsearch -exact $args -class]
2163 if {$idx >= 0 && ($idx%2 == 0)} {
2164 # -class exists and is in the -option position
2165 set wclass [lindex $args [expr {$idx+1}]]
2166 set args [lreplace $args $idx [expr {$idx+1}]]
2168 set wclass [::snit::Capitalize [namespace tail $type]]
2172 # NEXT, create the widget
2175 ${type}::installhull using $Snit_info(hulltype) -class $wclass
2177 # NEXT, let's query the option database for our
2178 # widget, now that we know that it exists.
2179 foreach opt $Snit_optionInfo(local) {
2180 set dbval [RT.OptionDbGet $type $name $opt]
2183 set options($opt) $dbval
2188 # Execute the type's constructor, and verify that it
2190 set errcode [catch {
2191 RT.ConstructInstance $type $selfns $name $args
2193 ::snit::RT.Component $type $selfns hull
2195 # Prepare to call the object's destructor when the
2196 # <Destroy> event is received. Use a Snit-specific bindtag
2197 # so that the widget name's tag is unencumbered.
2199 bind Snit$type$name <Destroy> [::snit::Expand {
2200 ::snit::RT.DestroyObject %TYPE% %NS% %W
2201 } %TYPE% $type %NS% $selfns]
2203 # Insert the bindtag into the list of bindtags right
2204 # after the widget name.
2205 set taglist [bindtags $name]
2206 set ndx [lsearch -exact $taglist $name]
2208 bindtags $name [linsert $taglist $ndx Snit$type$name]
2215 set theInfo $errorInfo
2216 set theCode $errorCode
2217 ::snit::RT.DestroyObject $type $selfns $name
2218 error "Error in constructor: $result" $theInfo $theCode
2221 # NEXT, return the object's name.
2226 # RT.MakeInstanceCommand type selfns instance
2228 # type The object type
2229 # selfns The instance namespace
2230 # instance The instance name
2232 # Creates the instance proc.
2234 proc ::snit::RT.MakeInstanceCommand {type selfns instance} {
2235 variable ${type}::Snit_info
2237 # FIRST, remember the instance name. The Snit_instance variable
2238 # allows the instance to figure out its current name given the
2239 # instance namespace.
2240 upvar ${selfns}::Snit_instance Snit_instance
2241 set Snit_instance $instance
2243 # NEXT, qualify the proc name if it's a widget.
2244 if {$Snit_info(isWidget)} {
2245 set procname ::$instance
2247 set procname $instance
2250 # NEXT, install the new proc
2251 if {!$Snit_info(simpledispatch)} {
2252 set instanceProc $::snit::nominalInstanceProc
2254 set instanceProc $::snit::simpleInstanceProc
2257 proc $procname {method args} \
2259 [list %SELFNS% $selfns %WIN% $instance %TYPE% $type] \
2263 # NEXT, add the trace.
2264 ::snit83::traceAddCommand $procname {rename delete} \
2265 [list ::snit::RT.InstanceTrace $type $selfns $instance]
2268 # This proc is called when the instance command is renamed.
2269 # If op is delete, then new will always be "", so op is redundant.
2271 # type The fully-qualified type name
2272 # selfns The instance namespace
2273 # win The original instance/tk window name.
2274 # old old instance command name
2275 # new new instance command name
2276 # op rename or delete
2278 # If the op is delete, we need to clean up the object; otherwise,
2279 # we need to track the change.
2281 # NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete
2282 # traces aren't propagated correctly. Instead, they silently
2283 # vanish. Add a catch to output any error message.
2285 proc ::snit::RT.InstanceTrace {type selfns win old new op} {
2286 variable ${type}::Snit_info
2288 # Note to developers ...
2289 # For Tcl 8.4.0, errors thrown in trace handlers vanish silently.
2290 # Therefore we catch them here and create some output to help in
2291 # debugging such problems.
2294 # FIRST, clean up if necessary
2296 if {$Snit_info(isWidget)} {
2299 ::snit::RT.DestroyObject $type $selfns $win
2302 # Otherwise, track the change.
2303 variable ${selfns}::Snit_instance
2304 set Snit_instance [uplevel 1 [list namespace which -command $new]]
2306 # Also, clear the instance caches, as many cached commands
2308 RT.ClearInstanceCaches $selfns
2312 # Pop up the console on Windows wish, to enable stdout.
2313 # This clobbers errorInfo on unix, so save it so we can print it.
2315 catch {console show}
2316 puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:"
2321 # Calls the instance constructor and handles related housekeeping.
2322 proc ::snit::RT.ConstructInstance {type selfns instance arglist} {
2323 variable ${type}::Snit_optionInfo
2324 variable ${selfns}::Snit_iinfo
2326 # Track whether we are constructed or not.
2327 set Snit_iinfo(constructed) 0
2329 # Call the user's constructor
2330 eval [linsert $arglist 0 \
2331 ${type}::Snit_constructor $type $selfns $instance $instance]
2333 set Snit_iinfo(constructed) 1
2335 # Validate the initial set of options (including defaults)
2336 foreach option $Snit_optionInfo(local) {
2337 set value [set ${selfns}::options($option)]
2339 if {"" != $Snit_optionInfo(typespec-$option)} {
2341 $Snit_optionInfo(typeobj-$option) validate $value
2343 return -code error "invalid $option default: $result"
2348 # Unset the configure cache for all -readonly options.
2349 # This ensures that the next time anyone tries to
2350 # configure it, an error is thrown.
2351 foreach opt $Snit_optionInfo(local) {
2352 if {$Snit_optionInfo(readonly-$opt)} {
2353 ::snit83::unset -nocomplain ${selfns}::Snit_configureCache($opt)
2360 # Returns a unique command name.
2362 # REQUIRE: type is a fully qualified name.
2363 # REQUIRE: name contains "%AUTO%"
2364 # PROMISE: the returned command name is unused.
2365 proc ::snit::RT.UniqueName {countervar type name} {
2366 upvar $countervar counter
2368 # FIRST, bump the counter and define the %AUTO% instance name;
2369 # then substitute it into the specified name. Wrap around at
2370 # 2^31 - 2 to prevent overflow problems.
2372 if {$counter > 2147483646} {
2375 set auto "[namespace tail $type]$counter"
2376 set candidate [Expand $name %AUTO% $auto]
2377 if {![llength [info commands $candidate]]} {
2383 # Returns a unique instance namespace, fully qualified.
2385 # countervar The name of a counter variable
2386 # type The instance's type
2388 # REQUIRE: type is fully qualified
2389 # PROMISE: The returned namespace name is unused.
2391 proc ::snit::RT.UniqueInstanceNamespace {countervar type} {
2392 upvar $countervar counter
2394 # FIRST, bump the counter and define the namespace name.
2395 # Then see if it already exists. Wrap around at
2396 # 2^31 - 2 to prevent overflow problems.
2398 if {$counter > 2147483646} {
2401 set ins "${type}::Snit_inst${counter}"
2402 if {![namespace exists $ins]} {
2408 # Retrieves an option's value from the option database.
2409 # Returns "" if no value is found.
2410 proc ::snit::RT.OptionDbGet {type self opt} {
2411 variable ${type}::Snit_optionInfo
2413 return [option get $self \
2414 $Snit_optionInfo(resource-$opt) \
2415 $Snit_optionInfo(class-$opt)]
2418 #-----------------------------------------------------------------------
2419 # Object Destruction
2421 # Implements the standard "destroy" method
2423 # type The snit type
2424 # selfns The instance's instance namespace
2425 # win The instance's original name
2426 # self The instance's current name
2428 proc ::snit::RT.method.destroy {type selfns win self} {
2429 variable ${selfns}::Snit_iinfo
2431 # Can't destroy the object if it isn't complete constructed.
2432 if {!$Snit_iinfo(constructed)} {
2433 return -code error "Called 'destroy' method in constructor"
2436 # Calls Snit_cleanup, which (among other things) calls the
2437 # user's destructor.
2438 ::snit::RT.DestroyObject $type $selfns $win
2441 # This is the function that really cleans up; it's automatically
2442 # called when any instance is destroyed, e.g., by "$object destroy"
2443 # for types, and by the <Destroy> event for widgets.
2445 # type The fully-qualified type name.
2446 # selfns The instance namespace
2447 # win The original instance command name.
2449 proc ::snit::RT.DestroyObject {type selfns win} {
2450 variable ${type}::Snit_info
2452 # If the variable Snit_instance doesn't exist then there's no
2453 # instance command for this object -- it's most likely a
2454 # widgetadaptor. Consequently, there are some things that
2455 # we don't need to do.
2456 if {[info exists ${selfns}::Snit_instance]} {
2457 upvar ${selfns}::Snit_instance instance
2459 # First, remove the trace on the instance name, so that we
2460 # don't call RT.DestroyObject recursively.
2461 RT.RemoveInstanceTrace $type $selfns $win $instance
2463 # Next, call the user's destructor
2464 ${type}::Snit_destructor $type $selfns $win $instance
2466 # Next, if this isn't a widget, delete the instance command.
2467 # If it is a widget, get the hull component's name, and rename
2468 # it back to the widget name
2470 # Next, delete the hull component's instance command,
2472 if {$Snit_info(isWidget)} {
2473 set hullcmd [::snit::RT.Component $type $selfns hull]
2475 catch {rename $instance ""}
2477 # Clear the bind event
2478 bind Snit$type$win <Destroy> ""
2480 if {[llength [info commands $hullcmd]]} {
2481 # FIRST, rename the hull back to its original name.
2482 # If the hull is itself a megawidget, it will have its
2483 # own cleanup to do, and it might not do it properly
2484 # if it doesn't have the right name.
2485 rename $hullcmd ::$instance
2491 catch {rename $instance ""}
2495 # Next, delete the instance's namespace. This kills any
2496 # instance variables.
2497 namespace delete $selfns
2502 # Remove instance trace
2504 # type The fully qualified type name
2505 # selfns The instance namespace
2506 # win The original instance name/Tk window name
2507 # instance The current instance name
2509 proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} {
2510 variable ${type}::Snit_info
2512 if {$Snit_info(isWidget)} {
2513 set procname ::$instance
2515 set procname $instance
2518 # NEXT, remove any trace on this name
2521 ::snit83::traceRemoveCommand $procname {rename delete} \
2522 [list ::snit::RT.InstanceTrace $type $selfns $win]
2526 #-----------------------------------------------------------------------
2527 # Typecomponent Management and Method Caching
2529 # Typecomponent trace; used for write trace on typecomponent
2530 # variables. Saves the new component object name, provided
2531 # that certain conditions are met. Also clears the typemethod
2534 proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} {
2535 upvar ${type}::Snit_info Snit_info
2536 upvar ${type}::${component} cvar
2537 upvar ${type}::Snit_typecomponents Snit_typecomponents
2539 # Save the new component value.
2540 set Snit_typecomponents($component) $cvar
2542 # Clear the typemethod cache.
2543 # TBD: can we unset just the elements related to
2545 ::snit83::unset -nocomplain -- ${type}::Snit_typemethodCache
2548 # Generates and caches the command for a typemethod.
2551 # method The name of the typemethod to call.
2553 # The return value is one of the following lists:
2555 # {} There's no such method.
2556 # {1} The method has submethods; look again.
2557 # {0 <command>} Here's the command to execute.
2559 proc snit::RT.CacheTypemethodCommand {type method} {
2560 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
2561 upvar ${type}::Snit_typecomponents Snit_typecomponents
2562 upvar ${type}::Snit_typemethodCache Snit_typemethodCache
2563 upvar ${type}::Snit_info Snit_info
2565 # FIRST, get the pattern data and the typecomponent name.
2566 set implicitCreate 0
2569 set starredMethod [lreplace $method end end *]
2570 set methodTail [lindex $method end]
2572 if {[info exists Snit_typemethodInfo($method)]} {
2574 } elseif {[info exists Snit_typemethodInfo($starredMethod)]} {
2575 if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} {
2576 set key $starredMethod
2580 } elseif {[llength $method] > 1} {
2582 } elseif {$Snit_info(hasinstances)} {
2583 # Assume the unknown name is an instance name to create, unless
2584 # this is a widget and the style of the name is wrong, or the
2585 # name mimics a standard typemethod.
2587 if {[set ${type}::Snit_info(isWidget)] &&
2588 ![string match ".*" $method]} {
2592 # Without this check, the call "$type info" will redefine the
2593 # standard "::info" command, with disastrous results. Since it's
2594 # a likely thing to do if !-typeinfo, put in an explicit check.
2595 if {"info" == $method || "destroy" == $method} {
2599 set implicitCreate 1
2600 set instanceName $method
2607 foreach {flag pattern compName} $Snit_typemethodInfo($key) {}
2613 # NEXT, build the substitution list
2618 %m [lindex $method end] \
2619 %j [join $method _]]
2621 if {"" != $compName} {
2622 if {![info exists Snit_typecomponents($compName)]} {
2623 error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\""
2626 lappend subList %c [list $Snit_typecomponents($compName)]
2631 foreach subpattern $pattern {
2632 lappend command [string map $subList $subpattern]
2635 if {$implicitCreate} {
2636 # In this case, $method is the name of the instance to
2637 # create. Don't cache, as we usually won't do this one
2639 lappend command $instanceName
2641 set Snit_typemethodCache($method) [list 0 $command]
2644 return [list 0 $command]
2648 #-----------------------------------------------------------------------
2649 # Component Management and Method Caching
2651 # Retrieves the object name given the component name.
2652 proc ::snit::RT.Component {type selfns name} {
2653 variable ${selfns}::Snit_components
2655 if {[catch {set Snit_components($name)} result]} {
2656 variable ${selfns}::Snit_instance
2658 error "component \"$name\" is undefined in $type $Snit_instance"
2664 # Component trace; used for write trace on component instance
2665 # variables. Saves the new component object name, provided
2666 # that certain conditions are met. Also clears the method
2669 proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} {
2670 upvar ${type}::Snit_info Snit_info
2671 upvar ${selfns}::${component} cvar
2672 upvar ${selfns}::Snit_components Snit_components
2674 # If they try to redefine the hull component after
2675 # it's been defined, that's an error--but only if
2676 # this is a widget or widget adaptor.
2677 if {"hull" == $component &&
2678 $Snit_info(isWidget) &&
2679 [info exists Snit_components($component)]} {
2680 set cvar $Snit_components($component)
2681 error "The hull component cannot be redefined"
2684 # Save the new component value.
2685 set Snit_components($component) $cvar
2687 # Clear the instance caches.
2688 # TBD: can we unset just the elements related to
2690 RT.ClearInstanceCaches $selfns
2693 # Generates and caches the command for a method.
2695 # type: The instance's type
2696 # selfns: The instance's private namespace
2697 # win: The instance's original name (a Tk widget name, for
2699 # self: The instance's current name.
2700 # method: The name of the method to call.
2702 # The return value is one of the following lists:
2704 # {} There's no such method.
2705 # {1} The method has submethods; look again.
2706 # {0 <command>} Here's the command to execute.
2708 proc ::snit::RT.CacheMethodCommand {type selfns win self method} {
2709 variable ${type}::Snit_info
2710 variable ${type}::Snit_methodInfo
2711 variable ${type}::Snit_typecomponents
2712 variable ${selfns}::Snit_components
2713 variable ${selfns}::Snit_methodCache
2715 # FIRST, get the pattern data and the component name.
2716 set starredMethod [lreplace $method end end *]
2717 set methodTail [lindex $method end]
2719 if {[info exists Snit_methodInfo($method)]} {
2721 } elseif {[info exists Snit_methodInfo($starredMethod)] &&
2722 [lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} {
2723 set key $starredMethod
2728 foreach {flag pattern compName} $Snit_methodInfo($key) {}
2734 # NEXT, build the substitution list
2739 %m [lindex $method end] \
2740 %j [join $method _] \
2745 if {"" != $compName} {
2746 if {[info exists Snit_components($compName)]} {
2747 set compCmd $Snit_components($compName)
2748 } elseif {[info exists Snit_typecomponents($compName)]} {
2749 set compCmd $Snit_typecomponents($compName)
2751 error "$type $self delegates method \"$method\" to undefined component \"$compName\""
2754 lappend subList %c [list $compCmd]
2757 # Note: The cached command will executed faster if it's
2761 foreach subpattern $pattern {
2762 lappend command [string map $subList $subpattern]
2765 set commandRec [list 0 $command]
2767 set Snit_methodCache($method) $commandRec
2773 # Looks up a method's command.
2775 # type: The instance's type
2776 # selfns: The instance's private namespace
2777 # win: The instance's original name (a Tk widget name, for
2779 # self: The instance's current name.
2780 # method: The name of the method to call.
2781 # errPrefix: Prefix for any error method
2782 proc ::snit::RT.LookupMethodCommand {type selfns win self method errPrefix} {
2783 set commandRec [snit::RT.CacheMethodCommand \
2784 $type $selfns $win $self \
2788 if {[llength $commandRec] == 0} {
2789 return -code error \
2790 "$errPrefix, \"$self $method\" is not defined"
2791 } elseif {[lindex $commandRec 0] == 1} {
2792 return -code error \
2793 "$errPrefix, wrong number args: should be \"$self\" $method method args"
2796 return [lindex $commandRec 1]
2800 # Clears all instance command caches
2801 proc ::snit::RT.ClearInstanceCaches {selfns} {
2802 ::snit83::unset -nocomplain -- ${selfns}::Snit_methodCache
2803 ::snit83::unset -nocomplain -- ${selfns}::Snit_cgetCache
2804 ::snit83::unset -nocomplain -- ${selfns}::Snit_configureCache
2805 ::snit83::unset -nocomplain -- ${selfns}::Snit_validateCache
2809 #-----------------------------------------------------------------------
2810 # Component Installation
2812 # Implements %TYPE%::installhull. The variables self and selfns
2813 # must be defined in the caller's context.
2815 # Installs the named widget as the hull of a
2816 # widgetadaptor. Once the widget is hijacked, its new name
2817 # is assigned to the hull component.
2819 proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} {
2820 variable ${type}::Snit_info
2821 variable ${type}::Snit_optionInfo
2824 upvar ${selfns}::hull hull
2825 upvar ${selfns}::options options
2827 # FIRST, make sure we can do it.
2828 if {!$Snit_info(isWidget)} {
2829 error "installhull is valid only for snit::widgetadaptors"
2832 if {[info exists ${selfns}::Snit_instance]} {
2833 error "hull already installed for $type $self"
2836 # NEXT, has it been created yet? If not, create it using
2837 # the specified arguments.
2838 if {"using" == $using} {
2839 # FIRST, create the widget
2840 set cmd [linsert $args 0 $widgetType $self]
2841 set obj [uplevel 1 $cmd]
2843 # NEXT, for each option explicitly delegated to the hull
2844 # that doesn't appear in the usedOpts list, get the
2845 # option database value and apply it--provided that the
2846 # real option name and the target option name are different.
2847 # (If they are the same, then the option database was
2848 # already queried as part of the normal widget creation.)
2850 # Also, we don't need to worry about implicitly delegated
2851 # options, as the option and target option names must be
2853 if {[info exists Snit_optionInfo(delegated-hull)]} {
2855 # FIRST, extract all option names from args
2857 set ndx [lsearch -glob $args "-*"]
2858 foreach {opt val} [lrange $args $ndx end] {
2859 lappend usedOpts $opt
2862 foreach opt $Snit_optionInfo(delegated-hull) {
2863 set target [lindex $Snit_optionInfo(target-$opt) 1]
2865 if {"$target" == $opt} {
2869 set result [lsearch -exact $usedOpts $target]
2871 if {$result != -1} {
2875 set dbval [RT.OptionDbGet $type $self $opt]
2876 $obj configure $target $dbval
2882 if {![string equal $obj $self]} {
2884 "hull name mismatch: \"$obj\" != \"$self\""
2888 # NEXT, get the local option defaults.
2889 foreach opt $Snit_optionInfo(local) {
2890 set dbval [RT.OptionDbGet $type $self $opt]
2893 set options($opt) $dbval
2898 # NEXT, do the magic
2902 set newName "::hull${i}$self"
2903 if {![llength [info commands $newName]]} {
2908 rename ::$self $newName
2909 RT.MakeInstanceCommand $type $selfns $self
2911 # Note: this relies on RT.ComponentTrace to do the dirty work.
2917 # Implements %TYPE%::install.
2919 # Creates a widget and installs it as the named component.
2920 # It expects self and selfns to be defined in the caller's context.
2922 proc ::snit::RT.install {type compName "using" widgetType winPath args} {
2923 variable ${type}::Snit_optionInfo
2924 variable ${type}::Snit_info
2927 upvar ${selfns}::$compName comp
2928 upvar ${selfns}::hull hull
2930 # We do the magic option database stuff only if $self is
2932 if {$Snit_info(isWidget)} {
2934 error "tried to install \"$compName\" before the hull exists"
2937 # FIRST, query the option database and save the results
2938 # into args. Insert them before the first option in the
2939 # list, in case there are any non-standard parameters.
2941 # Note: there might not be any delegated options; if so,
2944 if {[info exists Snit_optionInfo(delegated-$compName)]} {
2945 set ndx [lsearch -glob $args "-*"]
2947 foreach opt $Snit_optionInfo(delegated-$compName) {
2948 set dbval [RT.OptionDbGet $type $self $opt]
2951 set target [lindex $Snit_optionInfo(target-$opt) 1]
2952 set args [linsert $args $ndx $target $dbval]
2958 # NEXT, create the component and save it.
2959 set cmd [concat [list $widgetType $winPath] $args]
2960 set comp [uplevel 1 $cmd]
2962 # NEXT, handle the option database for "delegate option *",
2964 if {$Snit_info(isWidget) && [string equal $Snit_optionInfo(starcomp) $compName]} {
2965 # FIRST, get the list of option specs from the widget.
2966 # If configure doesn't work, skip it.
2967 if {[catch {$comp configure} specs]} {
2971 # NEXT, get the set of explicitly used options from args
2973 set ndx [lsearch -glob $args "-*"]
2974 foreach {opt val} [lrange $args $ndx end] {
2975 lappend usedOpts $opt
2978 # NEXT, "delegate option *" matches all options defined
2979 # by this widget that aren't defined by the widget as a whole,
2980 # and that aren't excepted. Plus, we skip usedOpts. So build
2981 # a list of the options it can't match.
2982 set skiplist [concat \
2984 $Snit_optionInfo(except) \
2985 $Snit_optionInfo(local) \
2986 $Snit_optionInfo(delegated)]
2988 # NEXT, loop over all of the component's options, and set
2989 # any not in the skip list for which there is an option
2991 foreach spec $specs {
2993 if {[llength $spec] != 5} {
2997 set opt [lindex $spec 0]
2999 if {[lsearch -exact $skiplist $opt] != -1} {
3003 set res [lindex $spec 1]
3004 set cls [lindex $spec 2]
3006 set dbvalue [option get $self $res $cls]
3008 if {"" != $dbvalue} {
3009 $comp configure $opt $dbvalue
3018 #-----------------------------------------------------------------------
3019 # Method/Variable Name Qualification
3021 # Implements %TYPE%::variable. Requires selfns.
3022 proc ::snit::RT.variable {varname} {
3025 if {![string match "::*" $varname]} {
3026 uplevel 1 [list upvar 1 ${selfns}::$varname $varname]
3028 # varname is fully qualified; let the standard
3029 # "variable" command handle it.
3030 uplevel 1 [list ::variable $varname]
3034 # Fully qualifies a typevariable name.
3036 # This is used to implement the mytypevar command.
3038 proc ::snit::RT.mytypevar {type name} {
3039 return ${type}::$name
3042 # Fully qualifies an instance variable name.
3044 # This is used to implement the myvar command.
3045 proc ::snit::RT.myvar {name} {
3047 return ${selfns}::$name
3050 # Use this like "list" to convert a proc call into a command
3051 # string to pass to another object (e.g., as a -command).
3052 # Qualifies the proc name properly.
3054 # This is used to implement the "myproc" command.
3056 proc ::snit::RT.myproc {type procname args} {
3057 set procname "${type}::$procname"
3058 return [linsert $args 0 $procname]
3062 proc ::snit::RT.codename {type name} {
3063 return "${type}::$name"
3066 # Use this like "list" to convert a typemethod call into a command
3067 # string to pass to another object (e.g., as a -command).
3068 # Inserts the type command at the beginning.
3070 # This is used to implement the "mytypemethod" command.
3072 proc ::snit::RT.mytypemethod {type args} {
3073 return [linsert $args 0 $type]
3076 # Use this like "list" to convert a method call into a command
3077 # string to pass to another object (e.g., as a -command).
3078 # Inserts the code at the beginning to call the right object, even if
3079 # the object's name has changed. Requires that selfns be defined
3080 # in the calling context, eg. can only be called in instance
3083 # This is used to implement the "mymethod" command.
3085 proc ::snit::RT.mymethod {args} {
3087 return [linsert $args 0 ::snit::RT.CallInstance ${selfns}]
3090 # Calls an instance method for an object given its
3091 # instance namespace and remaining arguments (the first of which
3092 # will be the method name.
3094 # selfns The instance namespace
3095 # args The arguments
3097 # Uses the selfns to determine $self, and calls the method
3098 # in the normal way.
3100 # This is used to implement the "mymethod" command.
3102 proc ::snit::RT.CallInstance {selfns args} {
3103 upvar ${selfns}::Snit_instance self
3105 set retval [catch {uplevel 1 [linsert $args 0 $self]} result]
3111 return -code error -errorinfo $errorInfo \
3112 -errorcode $errorCode $result
3114 return -code $retval $result
3121 # Looks for the named option in the named variable. If found,
3122 # it and its value are removed from the list, and the value
3123 # is returned. Otherwise, the default value is returned.
3124 # If the option is undelegated, it's own default value will be
3125 # used if none is specified.
3127 # Implements the "from" command.
3129 proc ::snit::RT.from {type argvName option {defvalue ""}} {
3130 variable ${type}::Snit_optionInfo
3131 upvar $argvName argv
3133 set ioption [lsearch -exact $argv $option]
3135 if {$ioption == -1} {
3136 if {"" == $defvalue &&
3137 [info exists Snit_optionInfo(default-$option)]} {
3138 return $Snit_optionInfo(default-$option)
3144 set ivalue [expr {$ioption + 1}]
3145 set value [lindex $argv $ivalue]
3147 set argv [lreplace $argv $ioption $ivalue]
3152 #-----------------------------------------------------------------------
3155 # Implements the standard "destroy" typemethod:
3156 # Destroys a type completely.
3158 # type The snit type
3160 proc ::snit::RT.typemethod.destroy {type} {
3161 variable ${type}::Snit_info
3163 # FIRST, destroy all instances
3164 foreach selfns [namespace children $type] {
3165 if {![namespace exists $selfns]} {
3168 upvar ${selfns}::Snit_instance obj
3170 if {$Snit_info(isWidget)} {
3173 if {[llength [info commands $obj]]} {
3179 # NEXT, destroy the type's data.
3180 namespace delete $type
3182 # NEXT, get rid of the type command.
3188 #-----------------------------------------------------------------------
3191 # Implements the standard "cget" method
3193 # type The snit type
3194 # selfns The instance's instance namespace
3195 # win The instance's original name
3196 # self The instance's current name
3197 # option The name of the option
3199 proc ::snit::RT.method.cget {type selfns win self option} {
3200 if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} {
3201 set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option]
3203 if {[llength $command] == 0} {
3204 return -code error "unknown option \"$option\""
3211 # Retrieves and caches the command that implements "cget" for the
3214 # type The snit type
3215 # selfns The instance's instance namespace
3216 # win The instance's original name
3217 # self The instance's current name
3218 # option The name of the option
3220 proc ::snit::RT.CacheCgetCommand {type selfns win self option} {
3221 variable ${type}::Snit_optionInfo
3222 variable ${selfns}::Snit_cgetCache
3224 if {[info exists Snit_optionInfo(islocal-$option)]} {
3225 # We know the item; it's either local, or explicitly delegated.
3226 if {$Snit_optionInfo(islocal-$option)} {
3227 # It's a local option. If it has a cget method defined,
3228 # use it; otherwise just return the value.
3230 if {"" == $Snit_optionInfo(cget-$option)} {
3231 set command [list set ${selfns}::options($option)]
3233 set command [snit::RT.LookupMethodCommand \
3234 $type $selfns $win $self \
3235 $Snit_optionInfo(cget-$option) \
3236 "can't cget $option"]
3238 lappend command $option
3241 set Snit_cgetCache($option) $command
3245 # Explicitly delegated option; get target
3246 set comp [lindex $Snit_optionInfo(target-$option) 0]
3247 set target [lindex $Snit_optionInfo(target-$option) 1]
3248 } elseif {"" != $Snit_optionInfo(starcomp) &&
3249 [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
3250 # Unknown option, but unknowns are delegated; get target.
3251 set comp $Snit_optionInfo(starcomp)
3257 # Get the component's object.
3258 set obj [RT.Component $type $selfns $comp]
3260 set command [list $obj cget $target]
3261 set Snit_cgetCache($option) $command
3266 # Implements the standard "configurelist" method
3268 # type The snit type
3269 # selfns The instance's instance namespace
3270 # win The instance's original name
3271 # self The instance's current name
3272 # optionlist A list of options and their values.
3274 proc ::snit::RT.method.configurelist {type selfns win self optionlist} {
3275 variable ${type}::Snit_optionInfo
3277 foreach {option value} $optionlist {
3278 # FIRST, get the configure command, caching it if need be.
3279 if {[catch {set ${selfns}::Snit_configureCache($option)} command]} {
3280 set command [snit::RT.CacheConfigureCommand \
3281 $type $selfns $win $self $option]
3283 if {[llength $command] == 0} {
3284 return -code error "unknown option \"$option\""
3288 # NEXT, if we have a type-validation object, use it.
3289 # TBD: Should test (islocal-$option) here, but islocal
3290 # isn't defined for implicitly delegated options.
3291 if {[info exists Snit_optionInfo(typeobj-$option)]
3292 && "" != $Snit_optionInfo(typeobj-$option)} {
3294 $Snit_optionInfo(typeobj-$option) validate $value
3296 return -code error "invalid $option value: $result"
3300 # NEXT, the caching the configure command also cached the
3301 # validate command, if any. If we have one, run it.
3302 set valcommand [set ${selfns}::Snit_validateCache($option)]
3304 if {[llength $valcommand]} {
3305 lappend valcommand $value
3306 uplevel 1 $valcommand
3309 # NEXT, configure the option with the value.
3310 lappend command $value
3317 # Retrieves and caches the command that stores the named option.
3318 # Also stores the command that validates the name option if any;
3319 # If none, the validate command is "", so that the cache is always
3322 # type The snit type
3323 # selfns The instance's instance namespace
3324 # win The instance's original name
3325 # self The instance's current name
3326 # option An option name
3328 proc ::snit::RT.CacheConfigureCommand {type selfns win self option} {
3329 variable ${type}::Snit_optionInfo
3330 variable ${selfns}::Snit_configureCache
3331 variable ${selfns}::Snit_validateCache
3333 if {[info exist Snit_optionInfo(islocal-$option)]} {
3334 # We know the item; it's either local, or explicitly delegated.
3336 if {$Snit_optionInfo(islocal-$option)} {
3337 # It's a local option.
3339 # If it's readonly, it throws an error if we're already
3341 if {$Snit_optionInfo(readonly-$option)} {
3342 if {[set ${selfns}::Snit_iinfo(constructed)]} {
3343 error "option $option can only be set at instance creation"
3347 # If it has a validate method, cache that for later.
3348 if {"" != $Snit_optionInfo(validate-$option)} {
3349 set command [snit::RT.LookupMethodCommand \
3350 $type $selfns $win $self \
3351 $Snit_optionInfo(validate-$option) \
3352 "can't validate $option"]
3354 lappend command $option
3355 set Snit_validateCache($option) $command
3357 set Snit_validateCache($option) ""
3360 # If it has a configure method defined,
3361 # cache it; otherwise, just set the value.
3363 if {"" == $Snit_optionInfo(configure-$option)} {
3364 set command [list set ${selfns}::options($option)]
3366 set command [snit::RT.LookupMethodCommand \
3367 $type $selfns $win $self \
3368 $Snit_optionInfo(configure-$option) \
3369 "can't configure $option"]
3371 lappend command $option
3374 set Snit_configureCache($option) $command
3378 # Delegated option: get target.
3379 set comp [lindex $Snit_optionInfo(target-$option) 0]
3380 set target [lindex $Snit_optionInfo(target-$option) 1]
3381 } elseif {$Snit_optionInfo(starcomp) != "" &&
3382 [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
3383 # Unknown option, but unknowns are delegated.
3384 set comp $Snit_optionInfo(starcomp)
3390 # There is no validate command in this case; save an empty string.
3391 set Snit_validateCache($option) ""
3393 # Get the component's object
3394 set obj [RT.Component $type $selfns $comp]
3396 set command [list $obj configure $target]
3397 set Snit_configureCache($option) $command
3402 # Implements the standard "configure" method
3404 # type The snit type
3405 # selfns The instance's instance namespace
3406 # win The instance's original name
3407 # self The instance's current name
3408 # args A list of options and their values, possibly empty.
3410 proc ::snit::RT.method.configure {type selfns win self args} {
3411 # If two or more arguments, set values as usual.
3412 if {[llength $args] >= 2} {
3413 ::snit::RT.method.configurelist $type $selfns $win $self $args
3417 # If zero arguments, acquire data for each known option
3418 # and return the list
3419 if {[llength $args] == 0} {
3421 foreach opt [RT.method.info.options $type $selfns $win $self] {
3422 # Refactor this, so that we don't need to call via $self.
3423 lappend result [RT.GetOptionDbSpec \
3424 $type $selfns $win $self $opt]
3430 # They want it for just one.
3431 set opt [lindex $args 0]
3433 return [RT.GetOptionDbSpec $type $selfns $win $self $opt]
3437 # Retrieves the option database spec for a single option.
3439 # type The snit type
3440 # selfns The instance's instance namespace
3441 # win The instance's original name
3442 # self The instance's current name
3443 # option The name of an option
3445 # TBD: This is a bad name. What it's returning is the
3446 # result of the configure query.
3448 proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} {
3449 variable ${type}::Snit_optionInfo
3451 upvar ${selfns}::Snit_components Snit_components
3452 upvar ${selfns}::options options
3454 if {[info exists options($opt)]} {
3455 # This is a locally-defined option. Just build the
3456 # list and return it.
3457 set res $Snit_optionInfo(resource-$opt)
3458 set cls $Snit_optionInfo(class-$opt)
3459 set def $Snit_optionInfo(default-$opt)
3461 return [list $opt $res $cls $def \
3462 [RT.method.cget $type $selfns $win $self $opt]]
3463 } elseif {[info exists Snit_optionInfo(target-$opt)]} {
3464 # This is an explicitly delegated option. The only
3465 # thing we don't have is the default.
3466 set res $Snit_optionInfo(resource-$opt)
3467 set cls $Snit_optionInfo(class-$opt)
3470 set logicalName [lindex $Snit_optionInfo(target-$opt) 0]
3471 set comp $Snit_components($logicalName)
3472 set target [lindex $Snit_optionInfo(target-$opt) 1]
3474 if {[catch {$comp configure $target} result]} {
3477 set defValue [lindex $result 3]
3480 return [list $opt $res $cls $defValue [$self cget $opt]]
3481 } elseif {"" != $Snit_optionInfo(starcomp) &&
3482 [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
3483 set logicalName $Snit_optionInfo(starcomp)
3485 set comp $Snit_components($logicalName)
3487 if {[catch {set value [$comp cget $target]} result]} {
3488 error "unknown option \"$opt\""
3491 if {![catch {$comp configure $target} result]} {
3492 # Replace the delegated option name with the local name.
3493 return [::snit::Expand $result $target $opt]
3496 # configure didn't work; return simple form.
3497 return [list $opt "" "" "" $value]
3499 error "unknown option \"$opt\""
3503 #-----------------------------------------------------------------------
3504 # Type Introspection
3506 # Implements the standard "info" typemethod.
3508 # type The snit type
3509 # command The info subcommand
3510 # args All other arguments.
3512 proc ::snit::RT.typemethod.info {type command args} {
3516 switch -exact $command {
3523 # TBD: it should be possible to delete this error
3525 set errflag [catch {
3526 uplevel 1 [linsert $args 0 \
3527 ::snit::RT.typemethod.info.$command $type]
3531 return -code error -errorinfo $errorInfo \
3532 -errorcode $errorCode $result
3538 error "\"$type info $command\" is not defined"
3544 # Returns a list of the type's typevariables whose names match a
3545 # pattern, excluding Snit internal variables.
3548 # pattern Optional. The glob pattern to match. Defaults
3551 proc ::snit::RT.typemethod.info.typevars {type {pattern *}} {
3553 foreach name [info vars "${type}::$pattern"] {
3554 set tail [namespace tail $name]
3555 if {![string match "Snit_*" $tail]} {
3556 lappend result $name
3563 # Returns a list of the type's methods whose names match a
3564 # pattern. If "delegate typemethod *" is used, the list may
3568 # pattern Optional. The glob pattern to match. Defaults
3571 proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} {
3572 variable ${type}::Snit_typemethodInfo
3573 variable ${type}::Snit_typemethodCache
3575 # FIRST, get the explicit names, skipping prefixes.
3578 foreach name [array names Snit_typemethodInfo $pattern] {
3579 if {[lindex $Snit_typemethodInfo($name) 0] != 1} {
3580 lappend result $name
3584 # NEXT, add any from the cache that aren't explicit.
3585 if {[info exists Snit_typemethodInfo(*)]} {
3586 # First, remove "*" from the list.
3587 set ndx [lsearch -exact $result "*"]
3589 set result [lreplace $result $ndx $ndx]
3592 foreach name [array names Snit_typemethodCache $pattern] {
3593 if {[lsearch -exact $result $name] == -1} {
3594 lappend result $name
3604 # Returns a method's list of arguments. does not work for delegated
3605 # methods, nor for the internal dispatch methods of multi-word
3608 proc ::snit::RT.typemethod.info.args {type method} {
3609 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
3611 # Snit_methodInfo: method -> list (flag cmd component)
3613 # flag : 1 -> internal dispatcher for multi-word method.
3614 # 0 -> regular method
3616 # cmd : template mapping from method to command prefix, may
3617 # contain placeholders for various pieces of information.
3619 # component : is empty for normal methods.
3621 #parray Snit_typemethodInfo
3623 if {![info exists Snit_typemethodInfo($method)]} {
3624 return -code error "Unknown typemethod \"$method\""
3626 foreach {flag cmd component} $Snit_typemethodInfo($method) break
3628 return -code error "Unknown typemethod \"$method\""
3630 if {$component != ""} {
3631 return -code error "Delegated typemethod \"$method\""
3634 set map [list %m $method %j [join $method _] %t $type]
3635 set theproc [lindex [string map $map $cmd] 0]
3636 return [lrange [::info args $theproc] 1 end]
3641 # Returns a method's body. does not work for delegated
3642 # methods, nor for the internal dispatch methods of multi-word
3645 proc ::snit::RT.typemethod.info.body {type method} {
3646 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
3648 # Snit_methodInfo: method -> list (flag cmd component)
3650 # flag : 1 -> internal dispatcher for multi-word method.
3651 # 0 -> regular method
3653 # cmd : template mapping from method to command prefix, may
3654 # contain placeholders for various pieces of information.
3656 # component : is empty for normal methods.
3658 #parray Snit_typemethodInfo
3660 if {![info exists Snit_typemethodInfo($method)]} {
3661 return -code error "Unknown typemethod \"$method\""
3663 foreach {flag cmd component} $Snit_typemethodInfo($method) break
3665 return -code error "Unknown typemethod \"$method\""
3667 if {$component != ""} {
3668 return -code error "Delegated typemethod \"$method\""
3671 set map [list %m $method %j [join $method _] %t $type]
3672 set theproc [lindex [string map $map $cmd] 0]
3673 return [RT.body [::info body $theproc]]
3676 # $type info default
3678 # Returns a method's list of arguments. does not work for delegated
3679 # methods, nor for the internal dispatch methods of multi-word
3682 proc ::snit::RT.typemethod.info.default {type method aname dvar} {
3684 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
3686 # Snit_methodInfo: method -> list (flag cmd component)
3688 # flag : 1 -> internal dispatcher for multi-word method.
3689 # 0 -> regular method
3691 # cmd : template mapping from method to command prefix, may
3692 # contain placeholders for various pieces of information.
3694 # component : is empty for normal methods.
3696 #parray Snit_methodInfo
3698 if {![info exists Snit_typemethodInfo($method)]} {
3699 return -code error "Unknown typemethod \"$method\""
3701 foreach {flag cmd component} $Snit_typemethodInfo($method) break
3703 return -code error "Unknown typemethod \"$method\""
3705 if {$component != ""} {
3706 return -code error "Delegated typemethod \"$method\""
3709 set map [list %m $method %j [join $method _] %t $type]
3710 set theproc [lindex [string map $map $cmd] 0]
3711 return [::info default $theproc $aname def]
3714 # Returns a list of the type's instances whose names match
3718 # pattern Optional. The glob pattern to match
3721 # REQUIRE: type is fully qualified.
3723 proc ::snit::RT.typemethod.info.instances {type {pattern *}} {
3726 foreach selfns [namespace children $type] {
3727 upvar ${selfns}::Snit_instance instance
3729 if {[string match $pattern $instance]} {
3730 lappend result $instance
3737 #-----------------------------------------------------------------------
3738 # Instance Introspection
3740 # Implements the standard "info" method.
3742 # type The snit type
3743 # selfns The instance's instance namespace
3744 # win The instance's original name
3745 # self The instance's current name
3746 # command The info subcommand
3747 # args All other arguments.
3749 proc ::snit::RT.method.info {type selfns win self command args} {
3750 switch -exact $command {
3760 set errflag [catch {
3761 uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \
3762 $type $selfns $win $self]
3767 return -code error -errorinfo $errorInfo $result
3773 # error "\"$self info $command\" is not defined"
3774 return -code error "\"$self info $command\" is not defined"
3781 # Returns the instance's type
3782 proc ::snit::RT.method.info.type {type selfns win self} {
3786 # $self info typevars
3788 # Returns the instance's type's typevariables
3789 proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} {
3790 return [RT.typemethod.info.typevars $type $pattern]
3793 # $self info typemethods
3795 # Returns the instance's type's typemethods
3796 proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} {
3797 return [RT.typemethod.info.typemethods $type $pattern]
3800 # Returns a list of the instance's methods whose names match a
3801 # pattern. If "delegate method *" is used, the list may
3805 # selfns The instance namespace
3806 # win The original instance name
3807 # self The current instance name
3808 # pattern Optional. The glob pattern to match. Defaults
3811 proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} {
3812 variable ${type}::Snit_methodInfo
3813 variable ${selfns}::Snit_methodCache
3815 # FIRST, get the explicit names, skipping prefixes.
3818 foreach name [array names Snit_methodInfo $pattern] {
3819 if {[lindex $Snit_methodInfo($name) 0] != 1} {
3820 lappend result $name
3824 # NEXT, add any from the cache that aren't explicit.
3825 if {[info exists Snit_methodInfo(*)]} {
3826 # First, remove "*" from the list.
3827 set ndx [lsearch -exact $result "*"]
3829 set result [lreplace $result $ndx $ndx]
3832 foreach name [array names Snit_methodCache $pattern] {
3833 if {[lsearch -exact $result $name] == -1} {
3834 lappend result $name
3844 # Returns a method's list of arguments. does not work for delegated
3845 # methods, nor for the internal dispatch methods of multi-word
3848 proc ::snit::RT.method.info.args {type selfns win self method} {
3850 upvar ${type}::Snit_methodInfo Snit_methodInfo
3852 # Snit_methodInfo: method -> list (flag cmd component)
3854 # flag : 1 -> internal dispatcher for multi-word method.
3855 # 0 -> regular method
3857 # cmd : template mapping from method to command prefix, may
3858 # contain placeholders for various pieces of information.
3860 # component : is empty for normal methods.
3862 #parray Snit_methodInfo
3864 if {![info exists Snit_methodInfo($method)]} {
3865 return -code error "Unknown method \"$method\""
3867 foreach {flag cmd component} $Snit_methodInfo($method) break
3869 return -code error "Unknown method \"$method\""
3871 if {$component != ""} {
3872 return -code error "Delegated method \"$method\""
3875 set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
3876 set theproc [lindex [string map $map $cmd] 0]
3877 return [lrange [::info args $theproc] 4 end]
3882 # Returns a method's body. does not work for delegated
3883 # methods, nor for the internal dispatch methods of multi-word
3886 proc ::snit::RT.method.info.body {type selfns win self method} {
3888 upvar ${type}::Snit_methodInfo Snit_methodInfo
3890 # Snit_methodInfo: method -> list (flag cmd component)
3892 # flag : 1 -> internal dispatcher for multi-word method.
3893 # 0 -> regular method
3895 # cmd : template mapping from method to command prefix, may
3896 # contain placeholders for various pieces of information.
3898 # component : is empty for normal methods.
3900 #parray Snit_methodInfo
3902 if {![info exists Snit_methodInfo($method)]} {
3903 return -code error "Unknown method \"$method\""
3905 foreach {flag cmd component} $Snit_methodInfo($method) break
3907 return -code error "Unknown method \"$method\""
3909 if {$component != ""} {
3910 return -code error "Delegated method \"$method\""
3913 set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
3914 set theproc [lindex [string map $map $cmd] 0]
3915 return [RT.body [::info body $theproc]]
3918 # $self info default
3920 # Returns a method's list of arguments. does not work for delegated
3921 # methods, nor for the internal dispatch methods of multi-word
3924 proc ::snit::RT.method.info.default {type selfns win self method aname dvar} {
3926 upvar ${type}::Snit_methodInfo Snit_methodInfo
3928 # Snit_methodInfo: method -> list (flag cmd component)
3930 # flag : 1 -> internal dispatcher for multi-word method.
3931 # 0 -> regular method
3933 # cmd : template mapping from method to command prefix, may
3934 # contain placeholders for various pieces of information.
3936 # component : is empty for normal methods.
3938 if {![info exists Snit_methodInfo($method)]} {
3939 return -code error "Unknown method \"$method\""
3941 foreach {flag cmd component} $Snit_methodInfo($method) break
3943 return -code error "Unknown method \"$method\""
3945 if {$component != ""} {
3946 return -code error "Delegated method \"$method\""
3949 set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
3950 set theproc [lindex [string map $map $cmd] 0]
3951 return [::info default $theproc $aname def]
3956 # Returns the instance's instance variables
3957 proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} {
3959 foreach name [info vars "${selfns}::$pattern"] {
3960 set tail [namespace tail $name]
3961 if {![string match "Snit_*" $tail]} {
3962 lappend result $name
3969 # $self info options
3971 # Returns a list of the names of the instance's options
3972 proc ::snit::RT.method.info.options {type selfns win self {pattern *}} {
3973 variable ${type}::Snit_optionInfo
3975 # First, get the local and explicitly delegated options
3976 set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)]
3978 # If "configure" works as for Tk widgets, add the resulting
3979 # options to the list. Skip excepted options
3980 if {"" != $Snit_optionInfo(starcomp)} {
3981 upvar ${selfns}::Snit_components Snit_components
3982 set logicalName $Snit_optionInfo(starcomp)
3983 set comp $Snit_components($logicalName)
3985 if {![catch {$comp configure} records]} {
3986 foreach record $records {
3987 set opt [lindex $record 0]
3988 if {[lsearch -exact $result $opt] == -1 &&
3989 [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
3996 # Next, apply the pattern
3999 foreach name $result {
4000 if {[string match $pattern $name]} {
4008 proc ::snit::RT.body {body} {
4009 regsub -all ".*# END snit method prolog\n" $body {} body