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.4 and later
13 # Copyright (C) 2003-2006 by William H. Duquette
14 # This code is licensed as described in license.txt.
16 #-----------------------------------------------------------------------
18 #-----------------------------------------------------------------------
21 namespace eval ::snit:: {
23 compile type widget widgetadaptor typemethod method macro
26 #-----------------------------------------------------------------------
29 namespace eval ::snit:: {
30 variable reservedArgs {type selfns win self}
32 # Widget classes which can be hulls (must have -class)
35 frame tk::frame ttk::frame
36 labelframe tk::labelframe ttk::labelframe
40 #-----------------------------------------------------------------------
41 # Snit Type Implementation template
43 namespace eval ::snit:: {
44 # Template type definition: All internal and user-visible Snit
45 # implementation code.
47 # The following placeholders will automatically be replaced with
48 # the client's code, in two passes:
51 # %COMPILEDDEFS% The compiled type definition.
54 # %TYPE% The fully qualified type name.
55 # %IVARDECS% Instance variable declarations
56 # %TVARDECS% Type variable declarations
57 # %TCONSTBODY% Type constructor body
58 # %INSTANCEVARS% The compiled instance variable initialization code.
59 # %TYPEVARS% The compiled type variable initialization code.
61 # This is the overall type template.
64 # This is the normal type proc
65 variable nominalTypeProc
67 # This is the "-hastypemethods no" type proc
68 variable simpleTypeProc
71 set ::snit::typeTemplate {
73 #-------------------------------------------------------------------
74 # The type's namespace definition and the user's type variables
76 namespace eval %TYPE% {%TYPEVARS%
79 #----------------------------------------------------------------
80 # Commands for use in methods, typemethods, etc.
82 # These are implemented as aliases into the Snit runtime library.
84 interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE%
85 interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE%
86 interp alias {} %TYPE%::typevariable {} ::variable
87 interp alias {} %TYPE%::variable {} ::snit::RT.variable
88 interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE%
89 interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE%
90 interp alias {} %TYPE%::myvar {} ::snit::RT.myvar
91 interp alias {} %TYPE%::varname {} ::snit::RT.myvar
92 interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE%
93 interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE%
94 interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod
95 interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE%
96 interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE%
98 #-------------------------------------------------------------------
99 # Snit's internal variables
101 namespace eval %TYPE% {
102 # Array: General Snit Info
104 # ns: The type's namespace
105 # hasinstances: T or F, from pragma -hasinstances.
106 # simpledispatch: T or F, from pragma -hasinstances.
107 # canreplace: T or F, from pragma -canreplace.
108 # counter: Count of instances created so far.
109 # widgetclass: Set by widgetclass statement.
110 # hulltype: Hull type (frame or toplevel) for widgets only.
111 # exceptmethods: Methods explicitly not delegated to *
112 # excepttypemethods: Methods explicitly not delegated to *
113 # tvardecs: Type variable declarations--for dynamic methods
114 # ivardecs: Instance variable declarations--for dyn. methods
115 typevariable Snit_info
116 set Snit_info(ns) %TYPE%::
117 set Snit_info(hasinstances) 1
118 set Snit_info(simpledispatch) 0
119 set Snit_info(canreplace) 0
120 set Snit_info(counter) 0
121 set Snit_info(widgetclass) {}
122 set Snit_info(hulltype) frame
123 set Snit_info(exceptmethods) {}
124 set Snit_info(excepttypemethods) {}
125 set Snit_info(tvardecs) {%TVARDECS%}
126 set Snit_info(ivardecs) {%IVARDECS%}
128 # Array: Public methods of this type.
129 # The index is the method name, or "*".
130 # The value is [list $pattern $componentName], where
131 # $componentName is "" for normal methods.
132 typevariable Snit_typemethodInfo
133 array unset Snit_typemethodInfo
135 # Array: Public methods of instances of this type.
136 # The index is the method name, or "*".
137 # The value is [list $pattern $componentName], where
138 # $componentName is "" for normal methods.
139 typevariable Snit_methodInfo
140 array unset Snit_methodInfo
142 # Array: option information. See dictionary.txt.
143 typevariable Snit_optionInfo
144 array unset Snit_optionInfo
145 set Snit_optionInfo(local) {}
146 set Snit_optionInfo(delegated) {}
147 set Snit_optionInfo(starcomp) {}
148 set Snit_optionInfo(except) {}
151 #----------------------------------------------------------------
154 # These commands are created or replaced during compilation:
157 # Snit_instanceVars selfns
159 # Initializes the instance variables, if any. Called during
162 proc %TYPE%::Snit_instanceVars {selfns} {
167 proc %TYPE%::Snit_typeconstructor {type} {
172 #----------------------------------------------------------------
175 # These commands might be replaced during compilation:
177 # Snit_destructor type selfns win self
179 # Default destructor for the type. By default, it does
180 # nothing. It's replaced by any user destructor.
181 # For types, it's called by method destroy; for widgettypes,
182 # it's called by a destroy event handler.
184 proc %TYPE%::Snit_destructor {type selfns win self} { }
186 #----------------------------------------------------------
187 # Compiled Definitions
191 #----------------------------------------------------------
192 # Finally, call the Type Constructor
194 %TYPE%::Snit_typeconstructor %TYPE%
197 #-----------------------------------------------------------------------
200 # These procs expect the fully-qualified type name to be
201 # substituted in for %TYPE%.
203 # This is the nominal type proc. It supports typemethods and
204 # delegated typemethods.
205 set ::snit::nominalTypeProc {
206 # Type dispatcher function. Note: This function lives
207 # in the parent of the %TYPE% namespace! All accesses to
208 # %TYPE% variables and methods must be qualified!
209 proc %TYPE% {{method ""} args} {
210 # First, if there's no method, and no args, and there's a create
211 # method, and this isn't a widget, then method is "create" and
213 if {"" == $method && [llength $args] == 0} {
214 ::variable %TYPE%::Snit_info
216 if {$Snit_info(hasinstances) && !$Snit_info(isWidget)} {
220 error "wrong \# args: should be \"%TYPE% method args\""
224 # Next, retrieve the command.
225 variable %TYPE%::Snit_typemethodCache
227 if {[catch {set Snit_typemethodCache($method)} commandRec]} {
228 set commandRec [::snit::RT.CacheTypemethodCommand %TYPE% $method]
230 if {[llength $commandRec] == 0} {
231 return -code error "\"%TYPE% $method\" is not defined"
235 # If we've got a real command, break.
236 if {[lindex $commandRec 0] == 0} {
240 # Otherwise, we need to look up again...if we can.
241 if {[llength $args] == 0} {
243 "wrong number args: should be \"%TYPE% $method method args\""
246 lappend method [lindex $args 0]
247 set args [lrange $args 1 end]
250 set command [lindex $commandRec 1]
252 # Pass along the return code unchanged.
253 set retval [catch {uplevel 1 $command $args} result]
259 return -code error -errorinfo $errorInfo \
260 -errorcode $errorCode $result
262 return -code $retval $result
270 # This is the simplified type proc for when there are no typemethods
271 # except create. In this case, it doesn't take a method argument;
272 # the method is always "create".
273 set ::snit::simpleTypeProc {
274 # Type dispatcher function. Note: This function lives
275 # in the parent of the %TYPE% namespace! All accesses to
276 # %TYPE% variables and methods must be qualified!
278 ::variable %TYPE%::Snit_info
280 # FIRST, if the are no args, the single arg is %AUTO%
281 if {[llength $args] == 0} {
282 if {$Snit_info(isWidget)} {
283 error "wrong \# args: should be \"%TYPE% name args\""
289 # NEXT, we're going to call the create method.
290 # Pass along the return code unchanged.
291 if {$Snit_info(isWidget)} {
292 set command [list ::snit::RT.widget.typemethod.create %TYPE%]
294 set command [list ::snit::RT.type.typemethod.create %TYPE%]
297 set retval [catch {uplevel 1 $command $args} result]
303 return -code error -errorinfo $errorInfo \
304 -errorcode $errorCode $result
306 return -code $retval $result
314 #-----------------------------------------------------------------------
317 # The following must be substituted into these proc bodies:
319 # %SELFNS% The instance namespace
320 # %WIN% The original instance name
321 # %TYPE% The fully-qualified type name
324 # Nominal instance proc body: supports method caching and delegation.
326 # proc $instanceName {method args} ....
327 set ::snit::nominalInstanceProc {
328 set self [set %SELFNS%::Snit_instance]
331 if {[catch {set %SELFNS%::Snit_methodCache($method)} commandRec]} {
332 set commandRec [snit::RT.CacheMethodCommand %TYPE% %SELFNS% %WIN% $self $method]
334 if {[llength $commandRec] == 0} {
336 "\"$self $method\" is not defined"
340 # If we've got a real command, break.
341 if {[lindex $commandRec 0] == 0} {
345 # Otherwise, we need to look up again...if we can.
346 if {[llength $args] == 0} {
348 "wrong number args: should be \"$self $method method args\""
351 lappend method [lindex $args 0]
352 set args [lrange $args 1 end]
355 set command [lindex $commandRec 1]
357 # Pass along the return code unchanged.
358 set retval [catch {uplevel 1 $command $args} result]
364 return -code error -errorinfo $errorInfo \
365 -errorcode $errorCode $result
367 return -code $retval $result
374 # Simplified method proc body: No delegation allowed; no support for
375 # upvar or exotic return codes or hierarchical methods. Designed for
376 # max speed for simple types.
378 # proc $instanceName {method args} ....
380 set ::snit::simpleInstanceProc {
381 set self [set %SELFNS%::Snit_instance]
383 if {[lsearch -exact ${%TYPE%::Snit_methods} $method] == -1} {
384 set optlist [join ${%TYPE%::Snit_methods} ", "]
385 set optlist [linsert $optlist "end-1" "or"]
386 error "bad option \"$method\": must be $optlist"
389 eval [linsert $args 0 \
390 %TYPE%::Snit_method$method %TYPE% %SELFNS% %WIN% $self]
394 #=======================================================================
395 # Snit Type Definition
397 # These are the procs used to define Snit types, widgets, and
401 #-----------------------------------------------------------------------
402 # Snit Compilation Variables
404 # The following variables are used while Snit is compiling a type,
405 # and are disposed afterwards.
407 namespace eval ::snit:: {
408 # The compiler variable contains the name of the slave interpreter
409 # used to compile type definitions.
412 # The compile array accumulates information about the type or
413 # widgettype being compiled. It is cleared before and after each
414 # compilation. It has these indices:
416 # type: The name of the type being compiled, for use
417 # in compilation procs.
418 # defs: Compiled definitions, both standard and client.
419 # which: type, widget, widgetadaptor
420 # instancevars: Instance variable definitions and initializations.
421 # ivprocdec: Instance variable proc declarations.
422 # tvprocdec: Type variable proc declarations.
423 # typeconstructor: Type constructor body.
424 # widgetclass: The widgetclass, for snit::widgets, only
425 # hasoptions: False, initially; set to true when first
427 # localoptions: Names of local options.
428 # delegatedoptions: Names of delegated options.
429 # localmethods: Names of locally defined methods.
430 # delegatesmethods: no if no delegated methods, yes otherwise.
431 # hashierarchic : no if no hierarchic methods, yes otherwise.
432 # components: Names of defined components.
433 # typecomponents: Names of defined typecomponents.
434 # typevars: Typevariable definitions and initializations.
435 # varnames: Names of instance variables
436 # typevarnames Names of type variables
437 # hasconstructor False, initially; true when constructor is
439 # resource-$opt The option's resource name
440 # class-$opt The option's class
441 # -default-$opt The option's default value
442 # -validatemethod-$opt The option's validate method
443 # -configuremethod-$opt The option's configure method
444 # -cgetmethod-$opt The option's cget method.
445 # -hastypeinfo The -hastypeinfo pragma
446 # -hastypedestroy The -hastypedestroy pragma
447 # -hastypemethods The -hastypemethods pragma
448 # -hasinfo The -hasinfo pragma
449 # -hasinstances The -hasinstances pragma
450 # -simpledispatch The -simpledispatch pragma
451 # -canreplace The -canreplace pragma
454 # This variable accumulates method dispatch information; it has
455 # the same structure as the %TYPE%::Snit_methodInfo array, and is
456 # used to initialize it.
459 # This variable accumulates typemethod dispatch information; it has
460 # the same structure as the %TYPE%::Snit_typemethodInfo array, and is
461 # used to initialize it.
462 variable typemethodInfo
464 # The following variable lists the reserved type definition statement
465 # names, e.g., the names you can't use as macros. It's built at
466 # compiler definition time using "info commands".
467 variable reservedwords {}
470 #-----------------------------------------------------------------------
471 # type compilation commands
473 # The type and widgettype commands use a slave interpreter to compile
474 # the type definition. These are the procs
475 # that are aliased into it.
477 # Initialize the compiler
478 proc ::snit::Comp.Init {} {
480 variable reservedwords
482 if {"" == $compiler} {
483 # Create the compiler's interpreter
484 set compiler [interp create]
486 # Initialize the interpreter
492 # Load package information
493 # TBD: see if this can be moved outside.
494 # @mdgen NODEP: ::snit::__does_not_exist__
495 catch {package require ::snit::__does_not_exist__}
497 # Protect some Tcl commands our type definitions
500 rename variable _variable
503 # Define compilation aliases.
504 $compiler alias pragma ::snit::Comp.statement.pragma
505 $compiler alias widgetclass ::snit::Comp.statement.widgetclass
506 $compiler alias hulltype ::snit::Comp.statement.hulltype
507 $compiler alias constructor ::snit::Comp.statement.constructor
508 $compiler alias destructor ::snit::Comp.statement.destructor
509 $compiler alias option ::snit::Comp.statement.option
510 $compiler alias oncget ::snit::Comp.statement.oncget
511 $compiler alias onconfigure ::snit::Comp.statement.onconfigure
512 $compiler alias method ::snit::Comp.statement.method
513 $compiler alias typemethod ::snit::Comp.statement.typemethod
514 $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor
515 $compiler alias proc ::snit::Comp.statement.proc
516 $compiler alias typevariable ::snit::Comp.statement.typevariable
517 $compiler alias variable ::snit::Comp.statement.variable
518 $compiler alias typecomponent ::snit::Comp.statement.typecomponent
519 $compiler alias component ::snit::Comp.statement.component
520 $compiler alias delegate ::snit::Comp.statement.delegate
521 $compiler alias expose ::snit::Comp.statement.expose
523 # Get the list of reserved words
524 set reservedwords [$compiler eval {info commands}]
528 # Compile a type definition, and return the results as a list of two
529 # items: the fully-qualified type name, and a script that will define
530 # the type when executed.
532 # which type, widget, or widgetadaptor
534 # body the type definition
535 proc ::snit::Comp.Compile {which type body} {
536 variable typeTemplate
537 variable nominalTypeProc
538 variable simpleTypeProc
542 variable typemethodInfo
544 # FIRST, qualify the name.
545 if {![string match "::*" $type]} {
546 # Get caller's namespace;
547 # append :: if not global namespace.
548 set ns [uplevel 2 [list namespace current]]
556 # NEXT, create and initialize the compiler, if needed.
559 # NEXT, initialize the class data
560 array unset methodInfo
561 array unset typemethodInfo
564 set compile(type) $type
566 set compile(which) $which
567 set compile(hasoptions) no
568 set compile(localoptions) {}
569 set compile(instancevars) {}
570 set compile(typevars) {}
571 set compile(delegatedoptions) {}
572 set compile(ivprocdec) {}
573 set compile(tvprocdec) {}
574 set compile(typeconstructor) {}
575 set compile(widgetclass) {}
576 set compile(hulltype) {}
577 set compile(localmethods) {}
578 set compile(delegatesmethods) no
579 set compile(hashierarchic) no
580 set compile(components) {}
581 set compile(typecomponents) {}
582 set compile(varnames) {}
583 set compile(typevarnames) {}
584 set compile(hasconstructor) no
585 set compile(-hastypedestroy) yes
586 set compile(-hastypeinfo) yes
587 set compile(-hastypemethods) yes
588 set compile(-hasinfo) yes
589 set compile(-hasinstances) yes
590 set compile(-simpledispatch) no
591 set compile(-canreplace) no
593 set isWidget [string match widget* $which]
594 set isWidgetAdaptor [string match widgetadaptor $which]
596 # NEXT, Evaluate the type's definition in the class interpreter.
599 # NEXT, Add the standard definitions
600 append compile(defs) \
601 "\nset %TYPE%::Snit_info(isWidget) $isWidget\n"
603 append compile(defs) \
604 "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n"
606 # Indicate whether the type can create instances that replace
608 append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n"
611 # Check pragmas for conflict.
613 if {!$compile(-hastypemethods) && !$compile(-hasinstances)} {
614 error "$which $type has neither typemethods nor instances"
617 if {$compile(-simpledispatch) && $compile(delegatesmethods)} {
618 error "$which $type requests -simpledispatch but delegates methods."
621 if {$compile(-simpledispatch) && $compile(hashierarchic)} {
622 error "$which $type requests -simpledispatch but defines hierarchical methods."
625 # If there are typemethods, define the standard typemethods and
626 # the nominal type proc. Otherwise define the simple type proc.
627 if {$compile(-hastypemethods)} {
628 # Add the info typemethod unless the pragma forbids it.
629 if {$compile(-hastypeinfo)} {
630 Comp.statement.delegate typemethod info \
631 using {::snit::RT.typemethod.info %t}
634 # Add the destroy typemethod unless the pragma forbids it.
635 if {$compile(-hastypedestroy)} {
636 Comp.statement.delegate typemethod destroy \
637 using {::snit::RT.typemethod.destroy %t}
640 # Add the nominal type proc.
641 append compile(defs) $nominalTypeProc
643 # Add the simple type proc.
644 append compile(defs) $simpleTypeProc
647 # Add standard methods/typemethods that only make sense if the
648 # type has instances.
649 if {$compile(-hasinstances)} {
650 # If we're using simple dispatch, remember that.
651 if {$compile(-simpledispatch)} {
652 append compile(defs) "\nset %TYPE%::Snit_info(simpledispatch) 1\n"
655 # Add the info method unless the pragma forbids it.
656 if {$compile(-hasinfo)} {
657 if {!$compile(-simpledispatch)} {
658 Comp.statement.delegate method info \
659 using {::snit::RT.method.info %t %n %w %s}
661 Comp.statement.method info {args} {
662 eval [linsert $args 0 \
663 ::snit::RT.method.info $type $selfns $win $self]
668 # Add the option handling stuff if there are any options.
669 if {$compile(hasoptions)} {
670 Comp.statement.variable options
672 if {!$compile(-simpledispatch)} {
673 Comp.statement.delegate method cget \
674 using {::snit::RT.method.cget %t %n %w %s}
675 Comp.statement.delegate method configurelist \
676 using {::snit::RT.method.configurelist %t %n %w %s}
677 Comp.statement.delegate method configure \
678 using {::snit::RT.method.configure %t %n %w %s}
680 Comp.statement.method cget {args} {
681 eval [linsert $args 0 \
682 ::snit::RT.method.cget $type $selfns $win $self]
684 Comp.statement.method configurelist {args} {
685 eval [linsert $args 0 \
686 ::snit::RT.method.configurelist $type $selfns $win $self]
688 Comp.statement.method configure {args} {
689 eval [linsert $args 0 \
690 ::snit::RT.method.configure $type $selfns $win $self]
695 # Add a default constructor, if they haven't already defined one.
696 # If there are options, it will configure args; otherwise it
698 if {!$compile(hasconstructor)} {
699 if {$compile(hasoptions)} {
700 Comp.statement.constructor {args} {
701 $self configurelist $args
704 Comp.statement.constructor {} {}
709 if {!$compile(-simpledispatch)} {
710 Comp.statement.delegate method destroy \
711 using {::snit::RT.method.destroy %t %n %w %s}
713 Comp.statement.method destroy {args} {
714 eval [linsert $args 0 \
715 ::snit::RT.method.destroy $type $selfns $win $self]
719 Comp.statement.delegate typemethod create \
720 using {::snit::RT.type.typemethod.create %t}
722 Comp.statement.delegate typemethod create \
723 using {::snit::RT.widget.typemethod.create %t}
726 # Save the list of method names, for -simpledispatch; otherwise,
727 # save the method info.
728 if {$compile(-simpledispatch)} {
729 append compile(defs) \
730 "\nset %TYPE%::Snit_methods [list $compile(localmethods)]\n"
732 append compile(defs) \
733 "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n"
737 append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n"
740 # NEXT, compiling the type definition built up a set of information
741 # about the type's locally defined options; add this information to
742 # the compiled definition.
745 # NEXT, compiling the type definition built up a set of information
746 # about the typemethods; save the typemethod info.
747 append compile(defs) \
748 "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n"
750 # NEXT, if this is a widget define the hull component if it isn't
753 Comp.DefineComponent hull
756 # NEXT, substitute the compiled definition into the type template
757 # to get the type definition script.
758 set defscript [Expand $typeTemplate \
759 %COMPILEDDEFS% $compile(defs)]
761 # NEXT, substitute the defined macros into the type definition script.
762 # This is done as a separate step so that the compile(defs) can
763 # contain the macros defined below.
765 set defscript [Expand $defscript \
767 %IVARDECS% $compile(ivprocdec) \
768 %TVARDECS% $compile(tvprocdec) \
769 %TCONSTBODY% $compile(typeconstructor) \
770 %INSTANCEVARS% $compile(instancevars) \
771 %TYPEVARS% $compile(typevars) \
776 return [list $type $defscript]
779 # Information about locally-defined options is accumulated during
780 # compilation, but not added to the compiled definition--the option
781 # statement can appear multiple times, so it's easier this way.
782 # This proc fills in Snit_optionInfo with the accumulated information.
784 # It also computes the option's resource and class names if needed.
786 # Note that the information for delegated options was put in
787 # Snit_optionInfo during compilation.
789 proc ::snit::Comp.SaveOptionInfo {} {
792 foreach option $compile(localoptions) {
793 if {"" == $compile(resource-$option)} {
794 set compile(resource-$option) [string range $option 1 end]
797 if {"" == $compile(class-$option)} {
798 set compile(class-$option) [Capitalize $compile(resource-$option)]
801 # NOTE: Don't verify that the validate, configure, and cget
802 # values name real methods; the methods might be defined outside
803 # the typedefinition using snit::method.
805 Mappend compile(defs) {
807 lappend %TYPE%::Snit_optionInfo(local) %OPTION%
809 set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1
810 set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE%
811 set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
812 set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT%
813 set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE%
814 set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE%
815 set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET%
816 set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY%
817 set %TYPE%::Snit_optionInfo(typespec-%OPTION%) %TYPESPEC%
819 %RESOURCE% $compile(resource-$option) \
820 %CLASS% $compile(class-$option) \
821 %DEFAULT% [list $compile(-default-$option)] \
822 %VALIDATE% [list $compile(-validatemethod-$option)] \
823 %CONFIGURE% [list $compile(-configuremethod-$option)] \
824 %CGET% [list $compile(-cgetmethod-$option)] \
825 %READONLY% $compile(-readonly-$option) \
826 %TYPESPEC% [list $compile(-type-$option)]
831 # Evaluates a compiled type definition, thus making the type available.
832 proc ::snit::Comp.Define {compResult} {
833 # The compilation result is a list containing the fully qualified
834 # type name and a script to evaluate to define the type.
835 set type [lindex $compResult 0]
836 set defscript [lindex $compResult 1]
838 # Execute the type definition script.
839 # Consider using namespace eval %TYPE%. See if it's faster.
840 if {[catch {eval $defscript} result]} {
841 namespace delete $type
842 catch {rename $type ""}
849 # Sets pragma options which control how the type is defined.
850 proc ::snit::Comp.statement.pragma {args} {
853 set errRoot "Error in \"pragma...\""
855 foreach {opt val} $args {
856 switch -exact -- $opt {
864 if {![string is boolean -strict $val]} {
865 error "$errRoot, \"$opt\" requires a boolean value"
867 set compile($opt) $val
870 error "$errRoot, unknown pragma"
876 # Defines a widget's option class name.
877 # This statement is only available for snit::widgets,
878 # not for snit::types or snit::widgetadaptors.
879 proc ::snit::Comp.statement.widgetclass {name} {
882 # First, widgetclass can only be set for true widgets
883 if {"widget" != $compile(which)} {
884 error "widgetclass cannot be set for snit::$compile(which)s"
887 # Next, validate the option name. We'll require that it begin
888 # with an uppercase letter.
889 set initial [string index $name 0]
890 if {![string is upper $initial]} {
891 error "widgetclass \"$name\" does not begin with an uppercase letter"
894 if {"" != $compile(widgetclass)} {
895 error "too many widgetclass statements"
899 Mappend compile(defs) {
900 set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS%
901 } %WIDGETCLASS% [list $name]
903 set compile(widgetclass) $name
906 # Defines a widget's hull type.
907 # This statement is only available for snit::widgets,
908 # not for snit::types or snit::widgetadaptors.
909 proc ::snit::Comp.statement.hulltype {name} {
913 # First, hulltype can only be set for true widgets
914 if {"widget" != $compile(which)} {
915 error "hulltype cannot be set for snit::$compile(which)s"
918 # Next, it must be one of the valid hulltypes (frame, toplevel, ...)
919 if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} {
920 error "invalid hulltype \"$name\", should be one of\
921 [join $hulltypes {, }]"
924 if {"" != $compile(hulltype)} {
925 error "too many hulltype statements"
929 Mappend compile(defs) {
930 set %TYPE%::Snit_info(hulltype) %HULLTYPE%
933 set compile(hulltype) $name
936 # Defines a constructor.
937 proc ::snit::Comp.statement.constructor {arglist body} {
940 CheckArgs "constructor" $arglist
942 # Next, add a magic reference to self.
943 set arglist [concat type selfns win self $arglist]
945 # Next, add variable declarations to body:
946 set body "%TVARDECS%%IVARDECS%\n$body"
948 set compile(hasconstructor) yes
949 append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n"
952 # Defines a destructor.
953 proc ::snit::Comp.statement.destructor {body} {
956 # Next, add variable declarations to body:
957 set body "%TVARDECS%%IVARDECS%\n$body"
959 append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n"
962 # Defines a type option. The option value can be a triple, specifying
963 # the option's -name, resource name, and class name.
964 proc ::snit::Comp.statement.option {optionDef args} {
967 # First, get the three option names.
968 set option [lindex $optionDef 0]
969 set resourceName [lindex $optionDef 1]
970 set className [lindex $optionDef 2]
972 set errRoot "Error in \"option [list $optionDef]...\""
974 # Next, validate the option name.
975 if {![Comp.OptionNameIsValid $option]} {
976 error "$errRoot, badly named option \"$option\""
979 if {[Contains $option $compile(delegatedoptions)]} {
980 error "$errRoot, cannot define \"$option\" locally, it has been delegated"
983 if {![Contains $option $compile(localoptions)]} {
984 # Remember that we've seen this one.
985 set compile(hasoptions) yes
986 lappend compile(localoptions) $option
988 # Initialize compilation info for this option.
989 set compile(resource-$option) ""
990 set compile(class-$option) ""
991 set compile(-default-$option) ""
992 set compile(-validatemethod-$option) ""
993 set compile(-configuremethod-$option) ""
994 set compile(-cgetmethod-$option) ""
995 set compile(-readonly-$option) 0
996 set compile(-type-$option) ""
999 # NEXT, see if we have a resource name. If so, make sure it
1000 # isn't being redefined differently.
1001 if {"" != $resourceName} {
1002 if {"" == $compile(resource-$option)} {
1003 # If it's undefined, just save the value.
1004 set compile(resource-$option) $resourceName
1005 } elseif {![string equal $resourceName $compile(resource-$option)]} {
1006 # It's been redefined differently.
1007 error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\""
1011 # NEXT, see if we have a class name. If so, make sure it
1012 # isn't being redefined differently.
1013 if {"" != $className} {
1014 if {"" == $compile(class-$option)} {
1015 # If it's undefined, just save the value.
1016 set compile(class-$option) $className
1017 } elseif {![string equal $className $compile(class-$option)]} {
1018 # It's been redefined differently.
1019 error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\""
1023 # NEXT, handle the args; it's not an error to redefine these.
1024 if {[llength $args] == 1} {
1025 set compile(-default-$option) [lindex $args 0]
1027 foreach {optopt val} $args {
1028 switch -exact -- $optopt {
1033 set compile($optopt-$option) $val
1036 set compile($optopt-$option) $val
1038 if {[llength $val] == 1} {
1039 # The type spec *is* the validation object
1040 append compile(defs) \
1041 "\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n"
1043 # Compilation the creation of the validation object
1044 set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%]
1045 append compile(defs) \
1046 "\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n"
1050 if {![string is boolean -strict $val]} {
1051 error "$errRoot, -readonly requires a boolean, got \"$val\""
1053 set compile($optopt-$option) $val
1056 error "$errRoot, unknown option definition option \"$optopt\""
1063 # 1 if the option name is valid, 0 otherwise.
1064 proc ::snit::Comp.OptionNameIsValid {option} {
1065 if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} {
1072 # Defines an option's cget handler
1073 proc ::snit::Comp.statement.oncget {option body} {
1076 set errRoot "Error in \"oncget $option...\""
1078 if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
1079 return -code error "$errRoot, option \"$option\" is delegated"
1082 if {[lsearch -exact $compile(localoptions) $option] == -1} {
1083 return -code error "$errRoot, option \"$option\" unknown"
1086 Comp.statement.method _cget$option {_option} $body
1087 Comp.statement.option $option -cgetmethod _cget$option
1090 # Defines an option's configure handler.
1091 proc ::snit::Comp.statement.onconfigure {option arglist body} {
1094 if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
1095 return -code error "onconfigure $option: option \"$option\" is delegated"
1098 if {[lsearch -exact $compile(localoptions) $option] == -1} {
1099 return -code error "onconfigure $option: option \"$option\" unknown"
1102 if {[llength $arglist] != 1} {
1104 "onconfigure $option handler should have one argument, got \"$arglist\""
1107 CheckArgs "onconfigure $option" $arglist
1109 # Next, add a magic reference to the option name
1110 set arglist [concat _option $arglist]
1112 Comp.statement.method _configure$option $arglist $body
1113 Comp.statement.option $option -configuremethod _configure$option
1116 # Defines an instance method.
1117 proc ::snit::Comp.statement.method {method arglist body} {
1121 # FIRST, check the method name against previously defined
1123 Comp.CheckMethodName $method 0 ::snit::methodInfo \
1124 "Error in \"method [list $method]...\""
1126 if {[llength $method] > 1} {
1127 set compile(hashierarchic) yes
1130 # Remeber this method
1131 lappend compile(localmethods) $method
1133 CheckArgs "method [list $method]" $arglist
1135 # Next, add magic references to type and self.
1136 set arglist [concat type selfns win self $arglist]
1138 # Next, add variable declarations to body:
1139 set body "%TVARDECS%%IVARDECS%\n# END snit method prolog\n$body"
1141 # Next, save the definition script.
1142 if {[llength $method] == 1} {
1143 set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
1144 Mappend compile(defs) {
1145 proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY%
1146 } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
1148 set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
1150 Mappend compile(defs) {
1151 proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY%
1152 } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \
1157 # Check for name collisions; save prefix information.
1159 # method The name of the method or typemethod.
1160 # delFlag 1 if delegated, 0 otherwise.
1161 # infoVar The fully qualified name of the array containing
1162 # information about the defined methods.
1163 # errRoot The root string for any error messages.
1165 proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} {
1166 upvar $infoVar methodInfo
1168 # FIRST, make sure the method name is a valid Tcl list.
1169 if {[catch {lindex $method 0}]} {
1170 error "$errRoot, the name \"$method\" must have list syntax."
1173 # NEXT, check whether we can define it.
1174 if {![catch {set methodInfo($method)} data]} {
1175 # We can't redefine methods with submethods.
1176 if {[lindex $data 0] == 1} {
1177 error "$errRoot, \"$method\" has submethods."
1180 # You can't delegate a method that's defined locally,
1181 # and you can't define a method locally if it's been delegated.
1182 if {$delFlag && "" == [lindex $data 2]} {
1183 error "$errRoot, \"$method\" has been defined locally."
1184 } elseif {!$delFlag && "" != [lindex $data 2]} {
1185 error "$errRoot, \"$method\" has been delegated"
1189 # Handle hierarchical case.
1190 if {[llength $method] > 1} {
1193 while {[llength $tokens] > 1} {
1194 lappend prefix [lindex $tokens 0]
1195 set tokens [lrange $tokens 1 end]
1197 if {![catch {set methodInfo($prefix)} result]} {
1198 # Prefix is known. If it's not a prefix, throw an
1200 if {[lindex $result 0] == 0} {
1201 error "$errRoot, \"$prefix\" has no submethods."
1205 set methodInfo($prefix) [list 1]
1210 # Defines a typemethod method.
1211 proc ::snit::Comp.statement.typemethod {method arglist body} {
1213 variable typemethodInfo
1215 # FIRST, check the typemethod name against previously defined
1217 Comp.CheckMethodName $method 0 ::snit::typemethodInfo \
1218 "Error in \"typemethod [list $method]...\""
1220 CheckArgs "typemethod $method" $arglist
1222 # First, add magic reference to type.
1223 set arglist [concat type $arglist]
1225 # Next, add typevariable declarations to body:
1226 set body "%TVARDECS%\n# END snit method prolog\n$body"
1228 # Next, save the definition script
1229 if {[llength $method] == 1} {
1230 set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
1232 Mappend compile(defs) {
1233 proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY%
1234 } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
1236 set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
1238 Mappend compile(defs) {
1239 proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY%
1240 } %JMETHOD% [join $method _] \
1241 %ARGLIST% [list $arglist] %BODY% [list $body]
1246 # Defines a type constructor.
1247 proc ::snit::Comp.statement.typeconstructor {body} {
1250 if {"" != $compile(typeconstructor)} {
1251 error "too many typeconstructors"
1254 set compile(typeconstructor) $body
1257 # Defines a static proc in the type's namespace.
1258 proc ::snit::Comp.statement.proc {proc arglist body} {
1261 # If "ns" is defined, the proc can see instance variables.
1262 if {[lsearch -exact $arglist selfns] != -1} {
1263 # Next, add instance variable declarations to body:
1264 set body "%IVARDECS%\n$body"
1267 # The proc can always see typevariables.
1268 set body "%TVARDECS%\n$body"
1270 append compile(defs) "
1273 proc [list %TYPE%::$proc $arglist $body]
1277 # Defines a static variable in the type's namespace.
1278 proc ::snit::Comp.statement.typevariable {name args} {
1281 set errRoot "Error in \"typevariable $name...\""
1283 set len [llength $args]
1286 ($len == 2 && "-array" != [lindex $args 0])} {
1287 error "$errRoot, too many initializers"
1290 if {[lsearch -exact $compile(varnames) $name] != -1} {
1291 error "$errRoot, \"$name\" is already an instance variable"
1294 lappend compile(typevarnames) $name
1297 append compile(typevars) \
1298 "\n\t [list ::variable $name [lindex $args 0]]"
1299 } elseif {$len == 2} {
1300 append compile(typevars) \
1301 "\n\t [list ::variable $name]"
1302 append compile(typevars) \
1303 "\n\t [list array set $name [lindex $args 1]]"
1305 append compile(typevars) \
1306 "\n\t [list ::variable $name]"
1309 append compile(tvprocdec) "\n\t typevariable ${name}"
1312 # Defines an instance variable; the definition will go in the
1313 # type's create typemethod.
1314 proc ::snit::Comp.statement.variable {name args} {
1317 set errRoot "Error in \"variable $name...\""
1319 set len [llength $args]
1322 ($len == 2 && "-array" != [lindex $args 0])} {
1323 error "$errRoot, too many initializers"
1326 if {[lsearch -exact $compile(typevarnames) $name] != -1} {
1327 error "$errRoot, \"$name\" is already a typevariable"
1330 lappend compile(varnames) $name
1333 append compile(instancevars) \
1334 "\nset \${selfns}::$name [list [lindex $args 0]]\n"
1335 } elseif {$len == 2} {
1336 append compile(instancevars) \
1337 "\narray set \${selfns}::$name [list [lindex $args 1]]\n"
1340 append compile(ivprocdec) "\n\t "
1341 Mappend compile(ivprocdec) {::variable ${selfns}::%N} %N $name
1344 # Defines a typecomponent, and handles component options.
1346 # component The logical name of the delegate
1349 proc ::snit::Comp.statement.typecomponent {component args} {
1352 set errRoot "Error in \"typecomponent $component...\""
1354 # FIRST, define the component
1355 Comp.DefineTypecomponent $component $errRoot
1357 # NEXT, handle the options.
1361 foreach {opt val} $args {
1362 switch -exact -- $opt {
1364 set publicMethod $val
1367 set inheritFlag $val
1368 if {![string is boolean $inheritFlag]} {
1369 error "typecomponent $component -inherit: expected boolean value, got \"$val\""
1373 error "typecomponent $component: Invalid option \"$opt\""
1378 # NEXT, if -public specified, define the method.
1379 if {"" != $publicMethod} {
1380 Comp.statement.delegate typemethod [list $publicMethod *] to $component
1383 # NEXT, if "-inherit 1" is specified, delegate typemethod * to
1386 Comp.statement.delegate typemethod "*" to $component
1392 # Defines a name to be a typecomponent
1394 # The name becomes a typevariable; in addition, it gets a
1395 # write trace so that when it is set, all of the component mechanisms
1398 # component The component name
1400 proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} {
1403 if {[lsearch -exact $compile(varnames) $component] != -1} {
1404 error "$errRoot, \"$component\" is already an instance variable"
1407 if {[lsearch -exact $compile(typecomponents) $component] == -1} {
1408 # Remember we've done this.
1409 lappend compile(typecomponents) $component
1411 # Make it a type variable with no initial value
1412 Comp.statement.typevariable $component ""
1414 # Add a write trace to do the component thing.
1415 Mappend compile(typevars) {
1416 trace add variable %COMP% write \
1417 [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%]
1418 } %TYPE% $compile(type) %COMP% $component
1422 # Defines a component, and handles component options.
1424 # component The logical name of the delegate
1427 # TBD: Ideally, it should be possible to call this statement multiple
1428 # times, possibly changing the option values. To do that, I'd need
1429 # to cache the option values and not act on them until *after* I'd
1430 # read the entire type definition.
1432 proc ::snit::Comp.statement.component {component args} {
1435 set errRoot "Error in \"component $component...\""
1437 # FIRST, define the component
1438 Comp.DefineComponent $component $errRoot
1440 # NEXT, handle the options.
1444 foreach {opt val} $args {
1445 switch -exact -- $opt {
1447 set publicMethod $val
1450 set inheritFlag $val
1451 if {![string is boolean $inheritFlag]} {
1452 error "component $component -inherit: expected boolean value, got \"$val\""
1456 error "component $component: Invalid option \"$opt\""
1461 # NEXT, if -public specified, define the method.
1462 if {"" != $publicMethod} {
1463 Comp.statement.delegate method [list $publicMethod *] to $component
1466 # NEXT, if -inherit is specified, delegate method/option * to
1469 Comp.statement.delegate method "*" to $component
1470 Comp.statement.delegate option "*" to $component
1475 # Defines a name to be a component
1477 # The name becomes an instance variable; in addition, it gets a
1478 # write trace so that when it is set, all of the component mechanisms
1481 # component The component name
1483 proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} {
1486 if {[lsearch -exact $compile(typevarnames) $component] != -1} {
1487 error "$errRoot, \"$component\" is already a typevariable"
1490 if {[lsearch -exact $compile(components) $component] == -1} {
1491 # Remember we've done this.
1492 lappend compile(components) $component
1494 # Make it an instance variable with no initial value
1495 Comp.statement.variable $component ""
1497 # Add a write trace to do the component thing.
1498 Mappend compile(instancevars) {
1499 trace add variable ${selfns}::%COMP% write \
1500 [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%]
1501 } %TYPE% $compile(type) %COMP% $component
1505 # Creates a delegated method, typemethod, or option.
1506 proc ::snit::Comp.statement.delegate {what name args} {
1507 # FIRST, dispatch to correct handler.
1509 typemethod { Comp.DelegatedTypemethod $name $args }
1510 method { Comp.DelegatedMethod $name $args }
1511 option { Comp.DelegatedOption $name $args }
1513 error "Error in \"delegate $what $name...\", \"$what\"?"
1517 if {([llength $args] % 2) != 0} {
1518 error "Error in \"delegate $what $name...\", invalid syntax"
1522 # Creates a delegated typemethod delegating it to a particular
1523 # typecomponent or an arbitrary command.
1525 # method The name of the method
1526 # arglist Delegation options
1528 proc ::snit::Comp.DelegatedTypemethod {method arglist} {
1530 variable typemethodInfo
1532 set errRoot "Error in \"delegate typemethod [list $method]...\""
1534 # Next, parse the delegation options.
1539 set methodTail [lindex $method end]
1541 foreach {opt value} $arglist {
1542 switch -exact $opt {
1543 to { set component $value }
1544 as { set target $value }
1545 except { set exceptions $value }
1546 using { set pattern $value }
1548 error "$errRoot, unknown delegation option \"$opt\""
1553 if {"" == $component && "" == $pattern} {
1554 error "$errRoot, missing \"to\""
1557 if {"*" == $methodTail && "" != $target} {
1558 error "$errRoot, cannot specify \"as\" with \"*\""
1561 if {"*" != $methodTail && "" != $exceptions} {
1562 error "$errRoot, can only specify \"except\" with \"*\""
1565 if {"" != $pattern && "" != $target} {
1566 error "$errRoot, cannot specify both \"as\" and \"using\""
1569 foreach token [lrange $method 1 end-1] {
1570 if {"*" == $token} {
1571 error "$errRoot, \"*\" must be the last token."
1575 # NEXT, define the component
1576 if {"" != $component} {
1577 Comp.DefineTypecomponent $component $errRoot
1580 # NEXT, define the pattern.
1581 if {"" == $pattern} {
1582 if {"*" == $methodTail} {
1584 } elseif {"" != $target} {
1585 set pattern "%c $target"
1591 # Make sure the pattern is a valid list.
1592 if {[catch {lindex $pattern 0} result]} {
1593 error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
1596 # NEXT, check the method name against previously defined
1598 Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot
1600 set typemethodInfo($method) [list 0 $pattern $component]
1602 if {[string equal $methodTail "*"]} {
1603 Mappend compile(defs) {
1604 set %TYPE%::Snit_info(excepttypemethods) %EXCEPT%
1605 } %EXCEPT% [list $exceptions]
1610 # Creates a delegated method delegating it to a particular
1611 # component or command.
1613 # method The name of the method
1614 # arglist Delegation options.
1616 proc ::snit::Comp.DelegatedMethod {method arglist} {
1620 set errRoot "Error in \"delegate method [list $method]...\""
1622 # Next, parse the delegation options.
1627 set methodTail [lindex $method end]
1629 foreach {opt value} $arglist {
1630 switch -exact $opt {
1631 to { set component $value }
1632 as { set target $value }
1633 except { set exceptions $value }
1634 using { set pattern $value }
1636 error "$errRoot, unknown delegation option \"$opt\""
1641 if {"" == $component && "" == $pattern} {
1642 error "$errRoot, missing \"to\""
1645 if {"*" == $methodTail && "" != $target} {
1646 error "$errRoot, cannot specify \"as\" with \"*\""
1649 if {"*" != $methodTail && "" != $exceptions} {
1650 error "$errRoot, can only specify \"except\" with \"*\""
1653 if {"" != $pattern && "" != $target} {
1654 error "$errRoot, cannot specify both \"as\" and \"using\""
1657 foreach token [lrange $method 1 end-1] {
1658 if {"*" == $token} {
1659 error "$errRoot, \"*\" must be the last token."
1663 # NEXT, we delegate some methods
1664 set compile(delegatesmethods) yes
1666 # NEXT, define the component. Allow typecomponents.
1667 if {"" != $component} {
1668 if {[lsearch -exact $compile(typecomponents) $component] == -1} {
1669 Comp.DefineComponent $component $errRoot
1673 # NEXT, define the pattern.
1674 if {"" == $pattern} {
1675 if {"*" == $methodTail} {
1677 } elseif {"" != $target} {
1678 set pattern "%c $target"
1684 # Make sure the pattern is a valid list.
1685 if {[catch {lindex $pattern 0} result]} {
1686 error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
1689 # NEXT, check the method name against previously defined
1691 Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot
1693 # NEXT, save the method info.
1694 set methodInfo($method) [list 0 $pattern $component]
1696 if {[string equal $methodTail "*"]} {
1697 Mappend compile(defs) {
1698 set %TYPE%::Snit_info(exceptmethods) %EXCEPT%
1699 } %EXCEPT% [list $exceptions]
1703 # Creates a delegated option, delegating it to a particular
1704 # component and, optionally, to a particular option of that
1707 # optionDef The option definition
1708 # args definition arguments.
1710 proc ::snit::Comp.DelegatedOption {optionDef arglist} {
1713 # First, get the three option names.
1714 set option [lindex $optionDef 0]
1715 set resourceName [lindex $optionDef 1]
1716 set className [lindex $optionDef 2]
1718 set errRoot "Error in \"delegate option [list $optionDef]...\""
1720 # Next, parse the delegation options.
1725 foreach {opt value} $arglist {
1726 switch -exact $opt {
1727 to { set component $value }
1728 as { set target $value }
1729 except { set exceptions $value }
1731 error "$errRoot, unknown delegation option \"$opt\""
1736 if {"" == $component} {
1737 error "$errRoot, missing \"to\""
1740 if {"*" == $option && "" != $target} {
1741 error "$errRoot, cannot specify \"as\" with \"delegate option *\""
1744 if {"*" != $option && "" != $exceptions} {
1745 error "$errRoot, can only specify \"except\" with \"delegate option *\""
1748 # Next, validate the option name
1750 if {"*" != $option} {
1751 if {![Comp.OptionNameIsValid $option]} {
1752 error "$errRoot, badly named option \"$option\""
1756 if {[Contains $option $compile(localoptions)]} {
1757 error "$errRoot, \"$option\" has been defined locally"
1760 if {[Contains $option $compile(delegatedoptions)]} {
1761 error "$errRoot, \"$option\" is multiply delegated"
1764 # NEXT, define the component
1765 Comp.DefineComponent $component $errRoot
1767 # Next, define the target option, if not specified.
1768 if {![string equal $option "*"] &&
1769 [string equal $target ""]} {
1773 # NEXT, save the delegation data.
1774 set compile(hasoptions) yes
1776 if {![string equal $option "*"]} {
1777 lappend compile(delegatedoptions) $option
1779 # Next, compute the resource and class names, if they aren't
1782 if {"" == $resourceName} {
1783 set resourceName [string range $option 1 end]
1786 if {"" == $className} {
1787 set className [Capitalize $resourceName]
1790 Mappend compile(defs) {
1791 set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0
1792 set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES%
1793 set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
1794 lappend %TYPE%::Snit_optionInfo(delegated) %OPTION%
1795 set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%]
1796 lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION%
1797 } %OPTION% $option \
1800 %RES% $resourceName \
1803 Mappend compile(defs) {
1804 set %TYPE%::Snit_optionInfo(starcomp) %COMP%
1805 set %TYPE%::Snit_optionInfo(except) %EXCEPT%
1806 } %COMP% $component %EXCEPT% [list $exceptions]
1810 # Exposes a component, effectively making the component's command an
1813 # component The logical name of the delegate
1814 # "as" sugar; if not "", must be "as"
1815 # methodname The desired method name for the component's command, or ""
1817 proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} {
1821 # FIRST, define the component
1822 Comp.DefineComponent $component
1824 # NEXT, define the method just as though it were in the type
1826 if {[string equal $methodname ""]} {
1827 set methodname $component
1830 Comp.statement.method $methodname args [Expand {
1831 if {[llength $args] == 0} {
1835 if {[string equal $%COMPONENT% ""]} {
1836 error "undefined component \"%COMPONENT%\""
1840 set cmd [linsert $args 0 $%COMPONENT%]
1841 return [uplevel 1 $cmd]
1842 } %COMPONENT% $component]
1847 #-----------------------------------------------------------------------
1850 # Compile a type definition, and return the results as a list of two
1851 # items: the fully-qualified type name, and a script that will define
1852 # the type when executed.
1854 # which type, widget, or widgetadaptor
1855 # type the type name
1856 # body the type definition
1857 proc ::snit::compile {which type body} {
1858 return [Comp.Compile $which $type $body]
1861 proc ::snit::type {type body} {
1862 return [Comp.Define [Comp.Compile type $type $body]]
1865 proc ::snit::widget {type body} {
1866 return [Comp.Define [Comp.Compile widget $type $body]]
1869 proc ::snit::widgetadaptor {type body} {
1870 return [Comp.Define [Comp.Compile widgetadaptor $type $body]]
1873 proc ::snit::typemethod {type method arglist body} {
1874 # Make sure the type exists.
1875 if {![info exists ${type}::Snit_info]} {
1876 error "no such type: \"$type\""
1879 upvar ${type}::Snit_info Snit_info
1880 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
1882 # FIRST, check the typemethod name against previously defined
1884 Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \
1885 "Cannot define \"$method\""
1887 # NEXT, check the arguments
1888 CheckArgs "snit::typemethod $type $method" $arglist
1890 # Next, add magic reference to type.
1891 set arglist [concat type $arglist]
1893 # Next, add typevariable declarations to body:
1894 set body "$Snit_info(tvardecs)\n$body"
1897 if {[llength $method] == 1} {
1898 set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
1899 uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body]
1901 set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
1902 set suffix [join $method _]
1903 uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body]
1907 proc ::snit::method {type method arglist body} {
1908 # Make sure the type exists.
1909 if {![info exists ${type}::Snit_info]} {
1910 error "no such type: \"$type\""
1913 upvar ${type}::Snit_methodInfo Snit_methodInfo
1914 upvar ${type}::Snit_info Snit_info
1916 # FIRST, check the method name against previously defined
1918 Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \
1919 "Cannot define \"$method\""
1921 # NEXT, check the arguments
1922 CheckArgs "snit::method $type $method" $arglist
1924 # Next, add magic references to type and self.
1925 set arglist [concat type selfns win self $arglist]
1927 # Next, add variable declarations to body:
1928 set body "$Snit_info(tvardecs)$Snit_info(ivardecs)\n$body"
1931 if {[llength $method] == 1} {
1932 set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
1933 uplevel 1 [list proc ${type}::Snit_method$method $arglist $body]
1935 set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
1937 set suffix [join $method _]
1938 uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body]
1942 # Defines a proc within the compiler; this proc can call other
1943 # type definition statements, and thus can be used for meta-programming.
1944 proc ::snit::macro {name arglist body} {
1946 variable reservedwords
1948 # FIRST, make sure the compiler is defined.
1951 # NEXT, check the macro name against the reserved words
1952 if {[lsearch -exact $reservedwords $name] != -1} {
1953 error "invalid macro name \"$name\""
1956 # NEXT, see if the name has a namespace; if it does, define the
1958 set ns [namespace qualifiers $name]
1961 $compiler eval "namespace eval $ns {}"
1964 # NEXT, define the macro
1965 $compiler eval [list _proc $name $arglist $body]
1968 #-----------------------------------------------------------------------
1971 # These are utility functions used while compiling Snit types.
1973 # Builds a template from a tagged list of text blocks, then substitutes
1974 # all symbols in the mapTable, returning the expanded template.
1975 proc ::snit::Expand {template args} {
1976 return [string map $args $template]
1979 # Expands a template and appends it to a variable.
1980 proc ::snit::Mappend {varname template args} {
1981 upvar $varname myvar
1983 append myvar [string map $args $template]
1986 # Checks argument list against reserved args
1987 proc ::snit::CheckArgs {which arglist} {
1988 variable reservedArgs
1990 foreach name $reservedArgs {
1991 if {[Contains $name $arglist]} {
1992 error "$which's arglist may not contain \"$name\" explicitly"
1997 # Returns 1 if a value is in a list, and 0 otherwise.
1998 proc ::snit::Contains {value list} {
1999 if {[lsearch -exact $list $value] != -1} {
2006 # Capitalizes the first letter of a string.
2007 proc ::snit::Capitalize {text} {
2008 return [string toupper $text 0]
2011 # Converts an arbitrary white-space-delimited string into a list
2012 # by splitting on white-space and deleting empty tokens.
2014 proc ::snit::Listify {str} {
2016 foreach token [split [string trim $str]] {
2017 if {[string length $token] > 0} {
2018 lappend result $token
2026 #=======================================================================
2027 # Snit Runtime Library
2029 # These are procs used by Snit types and widgets at runtime.
2031 #-----------------------------------------------------------------------
2034 # Creates a new instance of the snit::type given its name and the args.
2036 # type The snit::type
2037 # name The instance name
2038 # args Args to pass to the constructor
2040 proc ::snit::RT.type.typemethod.create {type name args} {
2041 variable ${type}::Snit_info
2042 variable ${type}::Snit_optionInfo
2044 # FIRST, qualify the name.
2045 if {![string match "::*" $name]} {
2046 # Get caller's namespace;
2047 # append :: if not global namespace.
2048 set ns [uplevel 1 [list namespace current]]
2056 # NEXT, if %AUTO% appears in the name, generate a unique
2057 # command name. Otherwise, ensure that the name isn't in use.
2058 if {[string match "*%AUTO%*" $name]} {
2059 set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
2060 } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} {
2061 error "command \"$name\" already exists"
2064 # NEXT, create the instance's namespace.
2066 [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
2067 namespace eval $selfns {}
2069 # NEXT, install the dispatcher
2070 RT.MakeInstanceCommand $type $selfns $name
2072 # Initialize the options to their defaults.
2073 upvar ${selfns}::options options
2074 foreach opt $Snit_optionInfo(local) {
2075 set options($opt) $Snit_optionInfo(default-$opt)
2078 # Initialize the instance vars to their defaults.
2079 # selfns must be defined, as it is used implicitly.
2080 ${type}::Snit_instanceVars $selfns
2082 # Execute the type's constructor.
2083 set errcode [catch {
2084 RT.ConstructInstance $type $selfns $name $args
2091 set theInfo $errorInfo
2092 set theCode $errorCode
2093 ::snit::RT.DestroyObject $type $selfns $name
2094 error "Error in constructor: $result" $theInfo $theCode
2097 # NEXT, return the object's name.
2101 # Creates a new instance of the snit::widget or snit::widgetadaptor
2102 # given its name and the args.
2104 # type The snit::widget or snit::widgetadaptor
2105 # name The instance name
2106 # args Args to pass to the constructor
2108 proc ::snit::RT.widget.typemethod.create {type name args} {
2109 variable ${type}::Snit_info
2110 variable ${type}::Snit_optionInfo
2112 # FIRST, if %AUTO% appears in the name, generate a unique
2114 if {[string match "*%AUTO%*" $name]} {
2115 set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
2118 # NEXT, create the instance's namespace.
2120 [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
2121 namespace eval $selfns { }
2123 # NEXT, Initialize the widget's own options to their defaults.
2124 upvar ${selfns}::options options
2125 foreach opt $Snit_optionInfo(local) {
2126 set options($opt) $Snit_optionInfo(default-$opt)
2129 # Initialize the instance vars to their defaults.
2130 ${type}::Snit_instanceVars $selfns
2132 # NEXT, if this is a normal widget (not a widget adaptor) then create a
2133 # frame as its hull. We set the frame's -class to the user's widgetclass,
2134 # or, if none, search for -class in the args list, otherwise default to
2135 # the basename of the $type with an initial upper case letter.
2136 if {!$Snit_info(isWidgetAdaptor)} {
2137 # FIRST, determine the class name
2138 set wclass $Snit_info(widgetclass)
2139 if {$Snit_info(widgetclass) eq ""} {
2140 set idx [lsearch -exact $args -class]
2141 if {$idx >= 0 && ($idx%2 == 0)} {
2142 # -class exists and is in the -option position
2143 set wclass [lindex $args [expr {$idx+1}]]
2144 set args [lreplace $args $idx [expr {$idx+1}]]
2146 set wclass [::snit::Capitalize [namespace tail $type]]
2150 # NEXT, create the widget
2153 ${type}::installhull using $Snit_info(hulltype) -class $wclass
2155 # NEXT, let's query the option database for our
2156 # widget, now that we know that it exists.
2157 foreach opt $Snit_optionInfo(local) {
2158 set dbval [RT.OptionDbGet $type $name $opt]
2161 set options($opt) $dbval
2166 # Execute the type's constructor, and verify that it
2168 set errcode [catch {
2169 RT.ConstructInstance $type $selfns $name $args
2171 ::snit::RT.Component $type $selfns hull
2173 # Prepare to call the object's destructor when the
2174 # <Destroy> event is received. Use a Snit-specific bindtag
2175 # so that the widget name's tag is unencumbered.
2177 bind Snit$type$name <Destroy> [::snit::Expand {
2178 ::snit::RT.DestroyObject %TYPE% %NS% %W
2179 } %TYPE% $type %NS% $selfns]
2181 # Insert the bindtag into the list of bindtags right
2182 # after the widget name.
2183 set taglist [bindtags $name]
2184 set ndx [lsearch -exact $taglist $name]
2186 bindtags $name [linsert $taglist $ndx Snit$type$name]
2193 set theInfo $errorInfo
2194 set theCode $errorCode
2195 ::snit::RT.DestroyObject $type $selfns $name
2196 error "Error in constructor: $result" $theInfo $theCode
2199 # NEXT, return the object's name.
2204 # RT.MakeInstanceCommand type selfns instance
2206 # type The object type
2207 # selfns The instance namespace
2208 # instance The instance name
2210 # Creates the instance proc.
2212 proc ::snit::RT.MakeInstanceCommand {type selfns instance} {
2213 variable ${type}::Snit_info
2215 # FIRST, remember the instance name. The Snit_instance variable
2216 # allows the instance to figure out its current name given the
2217 # instance namespace.
2218 upvar ${selfns}::Snit_instance Snit_instance
2219 set Snit_instance $instance
2221 # NEXT, qualify the proc name if it's a widget.
2222 if {$Snit_info(isWidget)} {
2223 set procname ::$instance
2225 set procname $instance
2228 # NEXT, install the new proc
2229 if {!$Snit_info(simpledispatch)} {
2230 set instanceProc $::snit::nominalInstanceProc
2232 set instanceProc $::snit::simpleInstanceProc
2235 proc $procname {method args} \
2237 [list %SELFNS% $selfns %WIN% $instance %TYPE% $type] \
2240 # NEXT, add the trace.
2241 trace add command $procname {rename delete} \
2242 [list ::snit::RT.InstanceTrace $type $selfns $instance]
2245 # This proc is called when the instance command is renamed.
2246 # If op is delete, then new will always be "", so op is redundant.
2248 # type The fully-qualified type name
2249 # selfns The instance namespace
2250 # win The original instance/tk window name.
2251 # old old instance command name
2252 # new new instance command name
2253 # op rename or delete
2255 # If the op is delete, we need to clean up the object; otherwise,
2256 # we need to track the change.
2258 # NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete
2259 # traces aren't propagated correctly. Instead, they silently
2260 # vanish. Add a catch to output any error message.
2262 proc ::snit::RT.InstanceTrace {type selfns win old new op} {
2263 variable ${type}::Snit_info
2265 # Note to developers ...
2266 # For Tcl 8.4.0, errors thrown in trace handlers vanish silently.
2267 # Therefore we catch them here and create some output to help in
2268 # debugging such problems.
2271 # FIRST, clean up if necessary
2273 if {$Snit_info(isWidget)} {
2276 ::snit::RT.DestroyObject $type $selfns $win
2279 # Otherwise, track the change.
2280 variable ${selfns}::Snit_instance
2281 set Snit_instance [uplevel 1 [list namespace which -command $new]]
2283 # Also, clear the instance caches, as many cached commands
2285 RT.ClearInstanceCaches $selfns
2289 # Pop up the console on Windows wish, to enable stdout.
2290 # This clobbers errorInfo on unix, so save it so we can print it.
2292 catch {console show}
2293 puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:"
2298 # Calls the instance constructor and handles related housekeeping.
2299 proc ::snit::RT.ConstructInstance {type selfns instance arglist} {
2300 variable ${type}::Snit_optionInfo
2301 variable ${selfns}::Snit_iinfo
2303 # Track whether we are constructed or not.
2304 set Snit_iinfo(constructed) 0
2306 # Call the user's constructor
2307 eval [linsert $arglist 0 \
2308 ${type}::Snit_constructor $type $selfns $instance $instance]
2310 set Snit_iinfo(constructed) 1
2312 # Validate the initial set of options (including defaults)
2313 foreach option $Snit_optionInfo(local) {
2314 set value [set ${selfns}::options($option)]
2316 if {"" != $Snit_optionInfo(typespec-$option)} {
2318 $Snit_optionInfo(typeobj-$option) validate $value
2320 return -code error "invalid $option default: $result"
2325 # Unset the configure cache for all -readonly options.
2326 # This ensures that the next time anyone tries to
2327 # configure it, an error is thrown.
2328 foreach opt $Snit_optionInfo(local) {
2329 if {$Snit_optionInfo(readonly-$opt)} {
2330 unset -nocomplain ${selfns}::Snit_configureCache($opt)
2337 # Returns a unique command name.
2339 # REQUIRE: type is a fully qualified name.
2340 # REQUIRE: name contains "%AUTO%"
2341 # PROMISE: the returned command name is unused.
2342 proc ::snit::RT.UniqueName {countervar type name} {
2343 upvar $countervar counter
2345 # FIRST, bump the counter and define the %AUTO% instance name;
2346 # then substitute it into the specified name. Wrap around at
2347 # 2^31 - 2 to prevent overflow problems.
2349 if {$counter > 2147483646} {
2352 set auto "[namespace tail $type]$counter"
2353 set candidate [Expand $name %AUTO% $auto]
2354 if {![llength [info commands $candidate]]} {
2360 # Returns a unique instance namespace, fully qualified.
2362 # countervar The name of a counter variable
2363 # type The instance's type
2365 # REQUIRE: type is fully qualified
2366 # PROMISE: The returned namespace name is unused.
2368 proc ::snit::RT.UniqueInstanceNamespace {countervar type} {
2369 upvar $countervar counter
2371 # FIRST, bump the counter and define the namespace name.
2372 # Then see if it already exists. Wrap around at
2373 # 2^31 - 2 to prevent overflow problems.
2375 if {$counter > 2147483646} {
2378 set ins "${type}::Snit_inst${counter}"
2379 if {![namespace exists $ins]} {
2385 # Retrieves an option's value from the option database.
2386 # Returns "" if no value is found.
2387 proc ::snit::RT.OptionDbGet {type self opt} {
2388 variable ${type}::Snit_optionInfo
2390 return [option get $self \
2391 $Snit_optionInfo(resource-$opt) \
2392 $Snit_optionInfo(class-$opt)]
2395 #-----------------------------------------------------------------------
2396 # Object Destruction
2398 # Implements the standard "destroy" method
2400 # type The snit type
2401 # selfns The instance's instance namespace
2402 # win The instance's original name
2403 # self The instance's current name
2405 proc ::snit::RT.method.destroy {type selfns win self} {
2406 variable ${selfns}::Snit_iinfo
2408 # Can't destroy the object if it isn't complete constructed.
2409 if {!$Snit_iinfo(constructed)} {
2410 return -code error "Called 'destroy' method in constructor"
2413 # Calls Snit_cleanup, which (among other things) calls the
2414 # user's destructor.
2415 ::snit::RT.DestroyObject $type $selfns $win
2418 # This is the function that really cleans up; it's automatically
2419 # called when any instance is destroyed, e.g., by "$object destroy"
2420 # for types, and by the <Destroy> event for widgets.
2422 # type The fully-qualified type name.
2423 # selfns The instance namespace
2424 # win The original instance command name.
2426 proc ::snit::RT.DestroyObject {type selfns win} {
2427 variable ${type}::Snit_info
2429 # If the variable Snit_instance doesn't exist then there's no
2430 # instance command for this object -- it's most likely a
2431 # widgetadaptor. Consequently, there are some things that
2432 # we don't need to do.
2433 if {[info exists ${selfns}::Snit_instance]} {
2434 upvar ${selfns}::Snit_instance instance
2436 # First, remove the trace on the instance name, so that we
2437 # don't call RT.DestroyObject recursively.
2438 RT.RemoveInstanceTrace $type $selfns $win $instance
2440 # Next, call the user's destructor
2441 ${type}::Snit_destructor $type $selfns $win $instance
2443 # Next, if this isn't a widget, delete the instance command.
2444 # If it is a widget, get the hull component's name, and rename
2445 # it back to the widget name
2447 # Next, delete the hull component's instance command,
2449 if {$Snit_info(isWidget)} {
2450 set hullcmd [::snit::RT.Component $type $selfns hull]
2452 catch {rename $instance ""}
2454 # Clear the bind event
2455 bind Snit$type$win <Destroy> ""
2457 if {[llength [info commands $hullcmd]]} {
2458 # FIRST, rename the hull back to its original name.
2459 # If the hull is itself a megawidget, it will have its
2460 # own cleanup to do, and it might not do it properly
2461 # if it doesn't have the right name.
2462 rename $hullcmd ::$instance
2468 catch {rename $instance ""}
2472 # Next, delete the instance's namespace. This kills any
2473 # instance variables.
2474 namespace delete $selfns
2479 # Remove instance trace
2481 # type The fully qualified type name
2482 # selfns The instance namespace
2483 # win The original instance name/Tk window name
2484 # instance The current instance name
2486 proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} {
2487 variable ${type}::Snit_info
2489 if {$Snit_info(isWidget)} {
2490 set procname ::$instance
2492 set procname $instance
2495 # NEXT, remove any trace on this name
2497 trace remove command $procname {rename delete} \
2498 [list ::snit::RT.InstanceTrace $type $selfns $win]
2502 #-----------------------------------------------------------------------
2503 # Typecomponent Management and Method Caching
2505 # Typecomponent trace; used for write trace on typecomponent
2506 # variables. Saves the new component object name, provided
2507 # that certain conditions are met. Also clears the typemethod
2510 proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} {
2511 upvar ${type}::Snit_info Snit_info
2512 upvar ${type}::${component} cvar
2513 upvar ${type}::Snit_typecomponents Snit_typecomponents
2515 # Save the new component value.
2516 set Snit_typecomponents($component) $cvar
2518 # Clear the typemethod cache.
2519 # TBD: can we unset just the elements related to
2521 unset -nocomplain -- ${type}::Snit_typemethodCache
2524 # Generates and caches the command for a typemethod.
2527 # method The name of the typemethod to call.
2529 # The return value is one of the following lists:
2531 # {} There's no such method.
2532 # {1} The method has submethods; look again.
2533 # {0 <command>} Here's the command to execute.
2535 proc snit::RT.CacheTypemethodCommand {type method} {
2536 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
2537 upvar ${type}::Snit_typecomponents Snit_typecomponents
2538 upvar ${type}::Snit_typemethodCache Snit_typemethodCache
2539 upvar ${type}::Snit_info Snit_info
2541 # FIRST, get the pattern data and the typecomponent name.
2542 set implicitCreate 0
2545 set starredMethod [lreplace $method end end *]
2546 set methodTail [lindex $method end]
2548 if {[info exists Snit_typemethodInfo($method)]} {
2550 } elseif {[info exists Snit_typemethodInfo($starredMethod)]} {
2551 if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} {
2552 set key $starredMethod
2556 } elseif {[llength $method] > 1} {
2558 } elseif {$Snit_info(hasinstances)} {
2559 # Assume the unknown name is an instance name to create, unless
2560 # this is a widget and the style of the name is wrong, or the
2561 # name mimics a standard typemethod.
2563 if {[set ${type}::Snit_info(isWidget)] &&
2564 ![string match ".*" $method]} {
2568 # Without this check, the call "$type info" will redefine the
2569 # standard "::info" command, with disastrous results. Since it's
2570 # a likely thing to do if !-typeinfo, put in an explicit check.
2571 if {"info" == $method || "destroy" == $method} {
2575 set implicitCreate 1
2576 set instanceName $method
2583 foreach {flag pattern compName} $Snit_typemethodInfo($key) {}
2589 # NEXT, build the substitution list
2594 %m [lindex $method end] \
2595 %j [join $method _]]
2597 if {"" != $compName} {
2598 if {![info exists Snit_typecomponents($compName)]} {
2599 error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\""
2602 lappend subList %c [list $Snit_typecomponents($compName)]
2607 foreach subpattern $pattern {
2608 lappend command [string map $subList $subpattern]
2611 if {$implicitCreate} {
2612 # In this case, $method is the name of the instance to
2613 # create. Don't cache, as we usually won't do this one
2615 lappend command $instanceName
2617 set Snit_typemethodCache($method) [list 0 $command]
2620 return [list 0 $command]
2624 #-----------------------------------------------------------------------
2625 # Component Management and Method Caching
2627 # Retrieves the object name given the component name.
2628 proc ::snit::RT.Component {type selfns name} {
2629 variable ${selfns}::Snit_components
2631 if {[catch {set Snit_components($name)} result]} {
2632 variable ${selfns}::Snit_instance
2634 error "component \"$name\" is undefined in $type $Snit_instance"
2640 # Component trace; used for write trace on component instance
2641 # variables. Saves the new component object name, provided
2642 # that certain conditions are met. Also clears the method
2645 proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} {
2646 upvar ${type}::Snit_info Snit_info
2647 upvar ${selfns}::${component} cvar
2648 upvar ${selfns}::Snit_components Snit_components
2650 # If they try to redefine the hull component after
2651 # it's been defined, that's an error--but only if
2652 # this is a widget or widget adaptor.
2653 if {"hull" == $component &&
2654 $Snit_info(isWidget) &&
2655 [info exists Snit_components($component)]} {
2656 set cvar $Snit_components($component)
2657 error "The hull component cannot be redefined"
2660 # Save the new component value.
2661 set Snit_components($component) $cvar
2663 # Clear the instance caches.
2664 # TBD: can we unset just the elements related to
2666 RT.ClearInstanceCaches $selfns
2669 # Generates and caches the command for a method.
2671 # type: The instance's type
2672 # selfns: The instance's private namespace
2673 # win: The instance's original name (a Tk widget name, for
2675 # self: The instance's current name.
2676 # method: The name of the method to call.
2678 # The return value is one of the following lists:
2680 # {} There's no such method.
2681 # {1} The method has submethods; look again.
2682 # {0 <command>} Here's the command to execute.
2684 proc ::snit::RT.CacheMethodCommand {type selfns win self method} {
2685 variable ${type}::Snit_info
2686 variable ${type}::Snit_methodInfo
2687 variable ${type}::Snit_typecomponents
2688 variable ${selfns}::Snit_components
2689 variable ${selfns}::Snit_methodCache
2691 # FIRST, get the pattern data and the component name.
2692 set starredMethod [lreplace $method end end *]
2693 set methodTail [lindex $method end]
2695 if {[info exists Snit_methodInfo($method)]} {
2697 } elseif {[info exists Snit_methodInfo($starredMethod)] &&
2698 [lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} {
2699 set key $starredMethod
2704 foreach {flag pattern compName} $Snit_methodInfo($key) {}
2710 # NEXT, build the substitution list
2715 %m [lindex $method end] \
2716 %j [join $method _] \
2721 if {"" != $compName} {
2722 if {[info exists Snit_components($compName)]} {
2723 set compCmd $Snit_components($compName)
2724 } elseif {[info exists Snit_typecomponents($compName)]} {
2725 set compCmd $Snit_typecomponents($compName)
2727 error "$type $self delegates method \"$method\" to undefined component \"$compName\""
2730 lappend subList %c [list $compCmd]
2733 # Note: The cached command will executed faster if it's
2737 foreach subpattern $pattern {
2738 lappend command [string map $subList $subpattern]
2741 set commandRec [list 0 $command]
2743 set Snit_methodCache($method) $commandRec
2749 # Looks up a method's command.
2751 # type: The instance's type
2752 # selfns: The instance's private namespace
2753 # win: The instance's original name (a Tk widget name, for
2755 # self: The instance's current name.
2756 # method: The name of the method to call.
2757 # errPrefix: Prefix for any error method
2758 proc ::snit::RT.LookupMethodCommand {type selfns win self method errPrefix} {
2759 set commandRec [snit::RT.CacheMethodCommand \
2760 $type $selfns $win $self \
2764 if {[llength $commandRec] == 0} {
2765 return -code error \
2766 "$errPrefix, \"$self $method\" is not defined"
2767 } elseif {[lindex $commandRec 0] == 1} {
2768 return -code error \
2769 "$errPrefix, wrong number args: should be \"$self\" $method method args"
2772 return [lindex $commandRec 1]
2776 # Clears all instance command caches
2777 proc ::snit::RT.ClearInstanceCaches {selfns} {
2778 unset -nocomplain -- ${selfns}::Snit_methodCache
2779 unset -nocomplain -- ${selfns}::Snit_cgetCache
2780 unset -nocomplain -- ${selfns}::Snit_configureCache
2781 unset -nocomplain -- ${selfns}::Snit_validateCache
2785 #-----------------------------------------------------------------------
2786 # Component Installation
2788 # Implements %TYPE%::installhull. The variables self and selfns
2789 # must be defined in the caller's context.
2791 # Installs the named widget as the hull of a
2792 # widgetadaptor. Once the widget is hijacked, its new name
2793 # is assigned to the hull component.
2795 proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} {
2796 variable ${type}::Snit_info
2797 variable ${type}::Snit_optionInfo
2800 upvar ${selfns}::hull hull
2801 upvar ${selfns}::options options
2803 # FIRST, make sure we can do it.
2804 if {!$Snit_info(isWidget)} {
2805 error "installhull is valid only for snit::widgetadaptors"
2808 if {[info exists ${selfns}::Snit_instance]} {
2809 error "hull already installed for $type $self"
2812 # NEXT, has it been created yet? If not, create it using
2813 # the specified arguments.
2814 if {"using" == $using} {
2815 # FIRST, create the widget
2816 set cmd [linsert $args 0 $widgetType $self]
2817 set obj [uplevel 1 $cmd]
2819 # NEXT, for each option explicitly delegated to the hull
2820 # that doesn't appear in the usedOpts list, get the
2821 # option database value and apply it--provided that the
2822 # real option name and the target option name are different.
2823 # (If they are the same, then the option database was
2824 # already queried as part of the normal widget creation.)
2826 # Also, we don't need to worry about implicitly delegated
2827 # options, as the option and target option names must be
2829 if {[info exists Snit_optionInfo(delegated-hull)]} {
2831 # FIRST, extract all option names from args
2833 set ndx [lsearch -glob $args "-*"]
2834 foreach {opt val} [lrange $args $ndx end] {
2835 lappend usedOpts $opt
2838 foreach opt $Snit_optionInfo(delegated-hull) {
2839 set target [lindex $Snit_optionInfo(target-$opt) 1]
2841 if {"$target" == $opt} {
2845 set result [lsearch -exact $usedOpts $target]
2847 if {$result != -1} {
2851 set dbval [RT.OptionDbGet $type $self $opt]
2852 $obj configure $target $dbval
2858 if {![string equal $obj $self]} {
2860 "hull name mismatch: \"$obj\" != \"$self\""
2864 # NEXT, get the local option defaults.
2865 foreach opt $Snit_optionInfo(local) {
2866 set dbval [RT.OptionDbGet $type $self $opt]
2869 set options($opt) $dbval
2874 # NEXT, do the magic
2878 set newName "::hull${i}$self"
2879 if {![llength [info commands $newName]]} {
2884 rename ::$self $newName
2885 RT.MakeInstanceCommand $type $selfns $self
2887 # Note: this relies on RT.ComponentTrace to do the dirty work.
2893 # Implements %TYPE%::install.
2895 # Creates a widget and installs it as the named component.
2896 # It expects self and selfns to be defined in the caller's context.
2898 proc ::snit::RT.install {type compName "using" widgetType winPath args} {
2899 variable ${type}::Snit_optionInfo
2900 variable ${type}::Snit_info
2903 upvar ${selfns}::$compName comp
2904 upvar ${selfns}::hull hull
2906 # We do the magic option database stuff only if $self is
2908 if {$Snit_info(isWidget)} {
2910 error "tried to install \"$compName\" before the hull exists"
2913 # FIRST, query the option database and save the results
2914 # into args. Insert them before the first option in the
2915 # list, in case there are any non-standard parameters.
2917 # Note: there might not be any delegated options; if so,
2920 if {[info exists Snit_optionInfo(delegated-$compName)]} {
2921 set ndx [lsearch -glob $args "-*"]
2923 foreach opt $Snit_optionInfo(delegated-$compName) {
2924 set dbval [RT.OptionDbGet $type $self $opt]
2927 set target [lindex $Snit_optionInfo(target-$opt) 1]
2928 set args [linsert $args $ndx $target $dbval]
2934 # NEXT, create the component and save it.
2935 set cmd [concat [list $widgetType $winPath] $args]
2936 set comp [uplevel 1 $cmd]
2938 # NEXT, handle the option database for "delegate option *",
2940 if {$Snit_info(isWidget) && [string equal $Snit_optionInfo(starcomp) $compName]} {
2941 # FIRST, get the list of option specs from the widget.
2942 # If configure doesn't work, skip it.
2943 if {[catch {$comp configure} specs]} {
2947 # NEXT, get the set of explicitly used options from args
2949 set ndx [lsearch -glob $args "-*"]
2950 foreach {opt val} [lrange $args $ndx end] {
2951 lappend usedOpts $opt
2954 # NEXT, "delegate option *" matches all options defined
2955 # by this widget that aren't defined by the widget as a whole,
2956 # and that aren't excepted. Plus, we skip usedOpts. So build
2957 # a list of the options it can't match.
2958 set skiplist [concat \
2960 $Snit_optionInfo(except) \
2961 $Snit_optionInfo(local) \
2962 $Snit_optionInfo(delegated)]
2964 # NEXT, loop over all of the component's options, and set
2965 # any not in the skip list for which there is an option
2967 foreach spec $specs {
2969 if {[llength $spec] != 5} {
2973 set opt [lindex $spec 0]
2975 if {[lsearch -exact $skiplist $opt] != -1} {
2979 set res [lindex $spec 1]
2980 set cls [lindex $spec 2]
2982 set dbvalue [option get $self $res $cls]
2984 if {"" != $dbvalue} {
2985 $comp configure $opt $dbvalue
2994 #-----------------------------------------------------------------------
2995 # Method/Variable Name Qualification
2997 # Implements %TYPE%::variable. Requires selfns.
2998 proc ::snit::RT.variable {varname} {
3001 if {![string match "::*" $varname]} {
3002 uplevel 1 [list upvar 1 ${selfns}::$varname $varname]
3004 # varname is fully qualified; let the standard
3005 # "variable" command handle it.
3006 uplevel 1 [list ::variable $varname]
3010 # Fully qualifies a typevariable name.
3012 # This is used to implement the mytypevar command.
3014 proc ::snit::RT.mytypevar {type name} {
3015 return ${type}::$name
3018 # Fully qualifies an instance variable name.
3020 # This is used to implement the myvar command.
3021 proc ::snit::RT.myvar {name} {
3023 return ${selfns}::$name
3026 # Use this like "list" to convert a proc call into a command
3027 # string to pass to another object (e.g., as a -command).
3028 # Qualifies the proc name properly.
3030 # This is used to implement the "myproc" command.
3032 proc ::snit::RT.myproc {type procname args} {
3033 set procname "${type}::$procname"
3034 return [linsert $args 0 $procname]
3038 proc ::snit::RT.codename {type name} {
3039 return "${type}::$name"
3042 # Use this like "list" to convert a typemethod call into a command
3043 # string to pass to another object (e.g., as a -command).
3044 # Inserts the type command at the beginning.
3046 # This is used to implement the "mytypemethod" command.
3048 proc ::snit::RT.mytypemethod {type args} {
3049 return [linsert $args 0 $type]
3052 # Use this like "list" to convert a method call into a command
3053 # string to pass to another object (e.g., as a -command).
3054 # Inserts the code at the beginning to call the right object, even if
3055 # the object's name has changed. Requires that selfns be defined
3056 # in the calling context, eg. can only be called in instance
3059 # This is used to implement the "mymethod" command.
3061 proc ::snit::RT.mymethod {args} {
3063 return [linsert $args 0 ::snit::RT.CallInstance ${selfns}]
3066 # Calls an instance method for an object given its
3067 # instance namespace and remaining arguments (the first of which
3068 # will be the method name.
3070 # selfns The instance namespace
3071 # args The arguments
3073 # Uses the selfns to determine $self, and calls the method
3074 # in the normal way.
3076 # This is used to implement the "mymethod" command.
3078 proc ::snit::RT.CallInstance {selfns args} {
3079 upvar ${selfns}::Snit_instance self
3081 set retval [catch {uplevel 1 [linsert $args 0 $self]} result]
3087 return -code error -errorinfo $errorInfo \
3088 -errorcode $errorCode $result
3090 return -code $retval $result
3097 # Looks for the named option in the named variable. If found,
3098 # it and its value are removed from the list, and the value
3099 # is returned. Otherwise, the default value is returned.
3100 # If the option is undelegated, it's own default value will be
3101 # used if none is specified.
3103 # Implements the "from" command.
3105 proc ::snit::RT.from {type argvName option {defvalue ""}} {
3106 variable ${type}::Snit_optionInfo
3107 upvar $argvName argv
3109 set ioption [lsearch -exact $argv $option]
3111 if {$ioption == -1} {
3112 if {"" == $defvalue &&
3113 [info exists Snit_optionInfo(default-$option)]} {
3114 return $Snit_optionInfo(default-$option)
3120 set ivalue [expr {$ioption + 1}]
3121 set value [lindex $argv $ivalue]
3123 set argv [lreplace $argv $ioption $ivalue]
3128 #-----------------------------------------------------------------------
3131 # Implements the standard "destroy" typemethod:
3132 # Destroys a type completely.
3134 # type The snit type
3136 proc ::snit::RT.typemethod.destroy {type} {
3137 variable ${type}::Snit_info
3139 # FIRST, destroy all instances
3140 foreach selfns [namespace children $type "${type}::Snit_inst*"] {
3141 if {![namespace exists $selfns]} {
3144 upvar ${selfns}::Snit_instance obj
3146 if {$Snit_info(isWidget)} {
3149 if {[llength [info commands $obj]]} {
3155 # NEXT, destroy the type's data.
3156 namespace delete $type
3158 # NEXT, get rid of the type command.
3164 #-----------------------------------------------------------------------
3167 # Implements the standard "cget" method
3169 # type The snit type
3170 # selfns The instance's instance namespace
3171 # win The instance's original name
3172 # self The instance's current name
3173 # option The name of the option
3175 proc ::snit::RT.method.cget {type selfns win self option} {
3176 if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} {
3177 set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option]
3179 if {[llength $command] == 0} {
3180 return -code error "unknown option \"$option\""
3187 # Retrieves and caches the command that implements "cget" for the
3190 # type The snit type
3191 # selfns The instance's instance namespace
3192 # win The instance's original name
3193 # self The instance's current name
3194 # option The name of the option
3196 proc ::snit::RT.CacheCgetCommand {type selfns win self option} {
3197 variable ${type}::Snit_optionInfo
3198 variable ${selfns}::Snit_cgetCache
3200 if {[info exists Snit_optionInfo(islocal-$option)]} {
3201 # We know the item; it's either local, or explicitly delegated.
3202 if {$Snit_optionInfo(islocal-$option)} {
3203 # It's a local option. If it has a cget method defined,
3204 # use it; otherwise just return the value.
3206 if {"" == $Snit_optionInfo(cget-$option)} {
3207 set command [list set ${selfns}::options($option)]
3209 set command [snit::RT.LookupMethodCommand \
3210 $type $selfns $win $self \
3211 $Snit_optionInfo(cget-$option) \
3212 "can't cget $option"]
3214 lappend command $option
3217 set Snit_cgetCache($option) $command
3221 # Explicitly delegated option; get target
3222 set comp [lindex $Snit_optionInfo(target-$option) 0]
3223 set target [lindex $Snit_optionInfo(target-$option) 1]
3224 } elseif {"" != $Snit_optionInfo(starcomp) &&
3225 [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
3226 # Unknown option, but unknowns are delegated; get target.
3227 set comp $Snit_optionInfo(starcomp)
3233 # Get the component's object.
3234 set obj [RT.Component $type $selfns $comp]
3236 set command [list $obj cget $target]
3237 set Snit_cgetCache($option) $command
3242 # Implements the standard "configurelist" method
3244 # type The snit type
3245 # selfns The instance's instance namespace
3246 # win The instance's original name
3247 # self The instance's current name
3248 # optionlist A list of options and their values.
3250 proc ::snit::RT.method.configurelist {type selfns win self optionlist} {
3251 variable ${type}::Snit_optionInfo
3253 foreach {option value} $optionlist {
3254 # FIRST, get the configure command, caching it if need be.
3255 if {[catch {set ${selfns}::Snit_configureCache($option)} command]} {
3256 set command [snit::RT.CacheConfigureCommand \
3257 $type $selfns $win $self $option]
3259 if {[llength $command] == 0} {
3260 return -code error "unknown option \"$option\""
3264 # NEXT, if we have a type-validation object, use it.
3265 # TBD: Should test (islocal-$option) here, but islocal
3266 # isn't defined for implicitly delegated options.
3267 if {[info exists Snit_optionInfo(typeobj-$option)]
3268 && "" != $Snit_optionInfo(typeobj-$option)} {
3270 $Snit_optionInfo(typeobj-$option) validate $value
3272 return -code error "invalid $option value: $result"
3276 # NEXT, the caching the configure command also cached the
3277 # validate command, if any. If we have one, run it.
3278 set valcommand [set ${selfns}::Snit_validateCache($option)]
3280 if {[llength $valcommand]} {
3281 lappend valcommand $value
3282 uplevel 1 $valcommand
3285 # NEXT, configure the option with the value.
3286 lappend command $value
3293 # Retrieves and caches the command that stores the named option.
3294 # Also stores the command that validates the name option if any;
3295 # If none, the validate command is "", so that the cache is always
3298 # type The snit type
3299 # selfns The instance's instance namespace
3300 # win The instance's original name
3301 # self The instance's current name
3302 # option An option name
3304 proc ::snit::RT.CacheConfigureCommand {type selfns win self option} {
3305 variable ${type}::Snit_optionInfo
3306 variable ${selfns}::Snit_configureCache
3307 variable ${selfns}::Snit_validateCache
3309 if {[info exist Snit_optionInfo(islocal-$option)]} {
3310 # We know the item; it's either local, or explicitly delegated.
3312 if {$Snit_optionInfo(islocal-$option)} {
3313 # It's a local option.
3315 # If it's readonly, it throws an error if we're already
3317 if {$Snit_optionInfo(readonly-$option)} {
3318 if {[set ${selfns}::Snit_iinfo(constructed)]} {
3319 error "option $option can only be set at instance creation"
3323 # If it has a validate method, cache that for later.
3324 if {"" != $Snit_optionInfo(validate-$option)} {
3325 set command [snit::RT.LookupMethodCommand \
3326 $type $selfns $win $self \
3327 $Snit_optionInfo(validate-$option) \
3328 "can't validate $option"]
3330 lappend command $option
3331 set Snit_validateCache($option) $command
3333 set Snit_validateCache($option) ""
3336 # If it has a configure method defined,
3337 # cache it; otherwise, just set the value.
3339 if {"" == $Snit_optionInfo(configure-$option)} {
3340 set command [list set ${selfns}::options($option)]
3342 set command [snit::RT.LookupMethodCommand \
3343 $type $selfns $win $self \
3344 $Snit_optionInfo(configure-$option) \
3345 "can't configure $option"]
3347 lappend command $option
3350 set Snit_configureCache($option) $command
3354 # Delegated option: get target.
3355 set comp [lindex $Snit_optionInfo(target-$option) 0]
3356 set target [lindex $Snit_optionInfo(target-$option) 1]
3357 } elseif {$Snit_optionInfo(starcomp) != "" &&
3358 [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
3359 # Unknown option, but unknowns are delegated.
3360 set comp $Snit_optionInfo(starcomp)
3366 # There is no validate command in this case; save an empty string.
3367 set Snit_validateCache($option) ""
3369 # Get the component's object
3370 set obj [RT.Component $type $selfns $comp]
3372 set command [list $obj configure $target]
3373 set Snit_configureCache($option) $command
3378 # Implements the standard "configure" method
3380 # type The snit type
3381 # selfns The instance's instance namespace
3382 # win The instance's original name
3383 # self The instance's current name
3384 # args A list of options and their values, possibly empty.
3386 proc ::snit::RT.method.configure {type selfns win self args} {
3387 # If two or more arguments, set values as usual.
3388 if {[llength $args] >= 2} {
3389 ::snit::RT.method.configurelist $type $selfns $win $self $args
3393 # If zero arguments, acquire data for each known option
3394 # and return the list
3395 if {[llength $args] == 0} {
3397 foreach opt [RT.method.info.options $type $selfns $win $self] {
3398 # Refactor this, so that we don't need to call via $self.
3399 lappend result [RT.GetOptionDbSpec \
3400 $type $selfns $win $self $opt]
3406 # They want it for just one.
3407 set opt [lindex $args 0]
3409 return [RT.GetOptionDbSpec $type $selfns $win $self $opt]
3413 # Retrieves the option database spec for a single option.
3415 # type The snit type
3416 # selfns The instance's instance namespace
3417 # win The instance's original name
3418 # self The instance's current name
3419 # option The name of an option
3421 # TBD: This is a bad name. What it's returning is the
3422 # result of the configure query.
3424 proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} {
3425 variable ${type}::Snit_optionInfo
3427 upvar ${selfns}::Snit_components Snit_components
3428 upvar ${selfns}::options options
3430 if {[info exists options($opt)]} {
3431 # This is a locally-defined option. Just build the
3432 # list and return it.
3433 set res $Snit_optionInfo(resource-$opt)
3434 set cls $Snit_optionInfo(class-$opt)
3435 set def $Snit_optionInfo(default-$opt)
3437 return [list $opt $res $cls $def \
3438 [RT.method.cget $type $selfns $win $self $opt]]
3439 } elseif {[info exists Snit_optionInfo(target-$opt)]} {
3440 # This is an explicitly delegated option. The only
3441 # thing we don't have is the default.
3442 set res $Snit_optionInfo(resource-$opt)
3443 set cls $Snit_optionInfo(class-$opt)
3446 set logicalName [lindex $Snit_optionInfo(target-$opt) 0]
3447 set comp $Snit_components($logicalName)
3448 set target [lindex $Snit_optionInfo(target-$opt) 1]
3450 if {[catch {$comp configure $target} result]} {
3453 set defValue [lindex $result 3]
3456 return [list $opt $res $cls $defValue [$self cget $opt]]
3457 } elseif {"" != $Snit_optionInfo(starcomp) &&
3458 [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
3459 set logicalName $Snit_optionInfo(starcomp)
3461 set comp $Snit_components($logicalName)
3463 if {[catch {set value [$comp cget $target]} result]} {
3464 error "unknown option \"$opt\""
3467 if {![catch {$comp configure $target} result]} {
3468 # Replace the delegated option name with the local name.
3469 return [::snit::Expand $result $target $opt]
3472 # configure didn't work; return simple form.
3473 return [list $opt "" "" "" $value]
3475 error "unknown option \"$opt\""
3479 #-----------------------------------------------------------------------
3480 # Type Introspection
3482 # Implements the standard "info" typemethod.
3484 # type The snit type
3485 # command The info subcommand
3486 # args All other arguments.
3488 proc ::snit::RT.typemethod.info {type command args} {
3492 switch -exact $command {
3499 # TBD: it should be possible to delete this error
3501 set errflag [catch {
3502 uplevel 1 [linsert $args 0 \
3503 ::snit::RT.typemethod.info.$command $type]
3507 return -code error -errorinfo $errorInfo \
3508 -errorcode $errorCode $result
3514 error "\"$type info $command\" is not defined"
3520 # Returns a list of the type's typevariables whose names match a
3521 # pattern, excluding Snit internal variables.
3524 # pattern Optional. The glob pattern to match. Defaults
3527 proc ::snit::RT.typemethod.info.typevars {type {pattern *}} {
3529 foreach name [info vars "${type}::$pattern"] {
3530 set tail [namespace tail $name]
3531 if {![string match "Snit_*" $tail]} {
3532 lappend result $name
3539 # Returns a list of the type's methods whose names match a
3540 # pattern. If "delegate typemethod *" is used, the list may
3544 # pattern Optional. The glob pattern to match. Defaults
3547 proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} {
3548 variable ${type}::Snit_typemethodInfo
3549 variable ${type}::Snit_typemethodCache
3551 # FIRST, get the explicit names, skipping prefixes.
3554 foreach name [array names Snit_typemethodInfo $pattern] {
3555 if {[lindex $Snit_typemethodInfo($name) 0] != 1} {
3556 lappend result $name
3560 # NEXT, add any from the cache that aren't explicit.
3561 if {[info exists Snit_typemethodInfo(*)]} {
3562 # First, remove "*" from the list.
3563 set ndx [lsearch -exact $result "*"]
3565 set result [lreplace $result $ndx $ndx]
3568 foreach name [array names Snit_typemethodCache $pattern] {
3569 if {[lsearch -exact $result $name] == -1} {
3570 lappend result $name
3580 # Returns a method's list of arguments. does not work for delegated
3581 # methods, nor for the internal dispatch methods of multi-word
3584 proc ::snit::RT.typemethod.info.args {type method} {
3585 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
3587 # Snit_methodInfo: method -> list (flag cmd component)
3589 # flag : 1 -> internal dispatcher for multi-word method.
3590 # 0 -> regular method
3592 # cmd : template mapping from method to command prefix, may
3593 # contain placeholders for various pieces of information.
3595 # component : is empty for normal methods.
3597 #parray Snit_typemethodInfo
3599 if {![info exists Snit_typemethodInfo($method)]} {
3600 return -code error "Unknown typemethod \"$method\""
3602 foreach {flag cmd component} $Snit_typemethodInfo($method) break
3604 return -code error "Unknown typemethod \"$method\""
3606 if {$component != ""} {
3607 return -code error "Delegated typemethod \"$method\""
3610 set map [list %m $method %j [join $method _] %t $type]
3611 set theproc [lindex [string map $map $cmd] 0]
3612 return [lrange [::info args $theproc] 1 end]
3617 # Returns a method's body. does not work for delegated
3618 # methods, nor for the internal dispatch methods of multi-word
3621 proc ::snit::RT.typemethod.info.body {type method} {
3622 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
3624 # Snit_methodInfo: method -> list (flag cmd component)
3626 # flag : 1 -> internal dispatcher for multi-word method.
3627 # 0 -> regular method
3629 # cmd : template mapping from method to command prefix, may
3630 # contain placeholders for various pieces of information.
3632 # component : is empty for normal methods.
3634 #parray Snit_typemethodInfo
3636 if {![info exists Snit_typemethodInfo($method)]} {
3637 return -code error "Unknown typemethod \"$method\""
3639 foreach {flag cmd component} $Snit_typemethodInfo($method) break
3641 return -code error "Unknown typemethod \"$method\""
3643 if {$component != ""} {
3644 return -code error "Delegated typemethod \"$method\""
3647 set map [list %m $method %j [join $method _] %t $type]
3648 set theproc [lindex [string map $map $cmd] 0]
3649 return [RT.body [::info body $theproc]]
3652 # $type info default
3654 # Returns a method's list of arguments. does not work for delegated
3655 # methods, nor for the internal dispatch methods of multi-word
3658 proc ::snit::RT.typemethod.info.default {type method aname dvar} {
3660 upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
3662 # Snit_methodInfo: method -> list (flag cmd component)
3664 # flag : 1 -> internal dispatcher for multi-word method.
3665 # 0 -> regular method
3667 # cmd : template mapping from method to command prefix, may
3668 # contain placeholders for various pieces of information.
3670 # component : is empty for normal methods.
3672 #parray Snit_methodInfo
3674 if {![info exists Snit_typemethodInfo($method)]} {
3675 return -code error "Unknown typemethod \"$method\""
3677 foreach {flag cmd component} $Snit_typemethodInfo($method) break
3679 return -code error "Unknown typemethod \"$method\""
3681 if {$component != ""} {
3682 return -code error "Delegated typemethod \"$method\""
3685 set map [list %m $method %j [join $method _] %t $type]
3686 set theproc [lindex [string map $map $cmd] 0]
3687 return [::info default $theproc $aname def]
3690 # Returns a list of the type's instances whose names match
3694 # pattern Optional. The glob pattern to match
3697 # REQUIRE: type is fully qualified.
3699 proc ::snit::RT.typemethod.info.instances {type {pattern *}} {
3702 foreach selfns [namespace children $type "${type}::Snit_inst*"] {
3703 upvar ${selfns}::Snit_instance instance
3705 if {[string match $pattern $instance]} {
3706 lappend result $instance
3713 #-----------------------------------------------------------------------
3714 # Instance Introspection
3716 # Implements the standard "info" method.
3718 # type The snit type
3719 # selfns The instance's instance namespace
3720 # win The instance's original name
3721 # self The instance's current name
3722 # command The info subcommand
3723 # args All other arguments.
3725 proc ::snit::RT.method.info {type selfns win self command args} {
3726 switch -exact $command {
3736 set errflag [catch {
3737 uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \
3738 $type $selfns $win $self]
3743 return -code error -errorinfo $errorInfo $result
3749 # error "\"$self info $command\" is not defined"
3750 return -code error "\"$self info $command\" is not defined"
3757 # Returns the instance's type
3758 proc ::snit::RT.method.info.type {type selfns win self} {
3762 # $self info typevars
3764 # Returns the instance's type's typevariables
3765 proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} {
3766 return [RT.typemethod.info.typevars $type $pattern]
3769 # $self info typemethods
3771 # Returns the instance's type's typemethods
3772 proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} {
3773 return [RT.typemethod.info.typemethods $type $pattern]
3776 # Returns a list of the instance's methods whose names match a
3777 # pattern. If "delegate method *" is used, the list may
3781 # selfns The instance namespace
3782 # win The original instance name
3783 # self The current instance name
3784 # pattern Optional. The glob pattern to match. Defaults
3787 proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} {
3788 variable ${type}::Snit_methodInfo
3789 variable ${selfns}::Snit_methodCache
3791 # FIRST, get the explicit names, skipping prefixes.
3794 foreach name [array names Snit_methodInfo $pattern] {
3795 if {[lindex $Snit_methodInfo($name) 0] != 1} {
3796 lappend result $name
3800 # NEXT, add any from the cache that aren't explicit.
3801 if {[info exists Snit_methodInfo(*)]} {
3802 # First, remove "*" from the list.
3803 set ndx [lsearch -exact $result "*"]
3805 set result [lreplace $result $ndx $ndx]
3808 foreach name [array names Snit_methodCache $pattern] {
3809 if {[lsearch -exact $result $name] == -1} {
3810 lappend result $name
3820 # Returns a method's list of arguments. does not work for delegated
3821 # methods, nor for the internal dispatch methods of multi-word
3824 proc ::snit::RT.method.info.args {type selfns win self method} {
3826 upvar ${type}::Snit_methodInfo Snit_methodInfo
3828 # Snit_methodInfo: method -> list (flag cmd component)
3830 # flag : 1 -> internal dispatcher for multi-word method.
3831 # 0 -> regular method
3833 # cmd : template mapping from method to command prefix, may
3834 # contain placeholders for various pieces of information.
3836 # component : is empty for normal methods.
3838 #parray Snit_methodInfo
3840 if {![info exists Snit_methodInfo($method)]} {
3841 return -code error "Unknown method \"$method\""
3843 foreach {flag cmd component} $Snit_methodInfo($method) break
3845 return -code error "Unknown method \"$method\""
3847 if {$component != ""} {
3848 return -code error "Delegated method \"$method\""
3851 set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
3852 set theproc [lindex [string map $map $cmd] 0]
3853 return [lrange [::info args $theproc] 4 end]
3858 # Returns a method's body. does not work for delegated
3859 # methods, nor for the internal dispatch methods of multi-word
3862 proc ::snit::RT.method.info.body {type selfns win self method} {
3864 upvar ${type}::Snit_methodInfo Snit_methodInfo
3866 # Snit_methodInfo: method -> list (flag cmd component)
3868 # flag : 1 -> internal dispatcher for multi-word method.
3869 # 0 -> regular method
3871 # cmd : template mapping from method to command prefix, may
3872 # contain placeholders for various pieces of information.
3874 # component : is empty for normal methods.
3876 #parray Snit_methodInfo
3878 if {![info exists Snit_methodInfo($method)]} {
3879 return -code error "Unknown method \"$method\""
3881 foreach {flag cmd component} $Snit_methodInfo($method) break
3883 return -code error "Unknown method \"$method\""
3885 if {$component != ""} {
3886 return -code error "Delegated method \"$method\""
3889 set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
3890 set theproc [lindex [string map $map $cmd] 0]
3891 return [RT.body [::info body $theproc]]
3894 # $self info default
3896 # Returns a method's list of arguments. does not work for delegated
3897 # methods, nor for the internal dispatch methods of multi-word
3900 proc ::snit::RT.method.info.default {type selfns win self method aname dvar} {
3902 upvar ${type}::Snit_methodInfo Snit_methodInfo
3904 # Snit_methodInfo: method -> list (flag cmd component)
3906 # flag : 1 -> internal dispatcher for multi-word method.
3907 # 0 -> regular method
3909 # cmd : template mapping from method to command prefix, may
3910 # contain placeholders for various pieces of information.
3912 # component : is empty for normal methods.
3914 if {![info exists Snit_methodInfo($method)]} {
3915 return -code error "Unknown method \"$method\""
3917 foreach {flag cmd component} $Snit_methodInfo($method) break
3919 return -code error "Unknown method \"$method\""
3921 if {$component != ""} {
3922 return -code error "Delegated method \"$method\""
3925 set map [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
3926 set theproc [lindex [string map $map $cmd] 0]
3927 return [::info default $theproc $aname def]
3932 # Returns the instance's instance variables
3933 proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} {
3935 foreach name [info vars "${selfns}::$pattern"] {
3936 set tail [namespace tail $name]
3937 if {![string match "Snit_*" $tail]} {
3938 lappend result $name
3945 # $self info options
3947 # Returns a list of the names of the instance's options
3948 proc ::snit::RT.method.info.options {type selfns win self {pattern *}} {
3949 variable ${type}::Snit_optionInfo
3951 # First, get the local and explicitly delegated options
3952 set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)]
3954 # If "configure" works as for Tk widgets, add the resulting
3955 # options to the list. Skip excepted options
3956 if {"" != $Snit_optionInfo(starcomp)} {
3957 upvar ${selfns}::Snit_components Snit_components
3958 set logicalName $Snit_optionInfo(starcomp)
3959 set comp $Snit_components($logicalName)
3961 if {![catch {$comp configure} records]} {
3962 foreach record $records {
3963 set opt [lindex $record 0]
3964 if {[lsearch -exact $result $opt] == -1 &&
3965 [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
3972 # Next, apply the pattern
3975 foreach name $result {
3976 if {[string match $pattern $name]} {
3984 proc ::snit::RT.body {body} {
3985 regsub -all ".*# END snit method prolog\n" $body {} body