1
#-----------------------------------------------------------------------
9
# Simple Now In Tcl, a simple object system in Pure Tcl.
11
#-----------------------------------------------------------------------
13
package provide snit 0.97
15
#-----------------------------------------------------------------------
18
namespace eval ::snit:: {
20
compile type widget widgetadaptor typemethod method macro
23
#-----------------------------------------------------------------------
26
namespace eval ::snit:: {
27
variable reservedArgs {type selfns win self}
29
# If true, get a pretty, fixed-up stack trace. Otherwise, get raw
31
# NOTE: Not Yet Implemented
32
variable prettyStackTrace 1
35
#-----------------------------------------------------------------------
36
# Snit Type Implementation template
38
namespace eval ::snit:: {
39
# Template type definition: All internal and user-visible Snit
40
# implementation code.
42
# The following placeholders will automatically be replaced with
43
# the client's code, in two passes:
46
# %COMPILEDDEFS% The compiled type definition.
49
# %TYPE% The fully qualified type name.
50
# %IVARDECS% Instance variable declarations
51
# %TVARDECS% Type variable declarations
52
# %TCONSTBODY% Type constructor body
53
# %INSTANCEVARS% The compiled instance variable initialization code.
54
# %TYPEVARS% The compiled type variable initialization code.
56
# This is the overall type template.
59
# This is the normal type proc
60
variable nominalTypeProc
62
# This is the "-hastypemethods no" type proc
63
variable simpleTypeProc
66
set ::snit::typeTemplate {
68
#-------------------------------------------------------------------
69
# The type's namespace definition and the user's type variables
71
namespace eval %TYPE% {%TYPEVARS%
74
#----------------------------------------------------------------
75
# Commands for use in methods, typemethods, etc.
77
# These are implemented as aliases into the Snit runtime library.
79
interp alias {} %TYPE%::installhull {} ::snit::RT.installhull %TYPE%
80
interp alias {} %TYPE%::install {} ::snit::RT.install %TYPE%
81
interp alias {} %TYPE%::typevariable {} ::variable
82
interp alias {} %TYPE%::variable {} ::snit::RT.variable
83
interp alias {} %TYPE%::mytypevar {} ::snit::RT.mytypevar %TYPE%
84
interp alias {} %TYPE%::typevarname {} ::snit::RT.mytypevar %TYPE%
85
interp alias {} %TYPE%::myvar {} ::snit::RT.myvar
86
interp alias {} %TYPE%::varname {} ::snit::RT.myvar
87
interp alias {} %TYPE%::codename {} ::snit::RT.codename %TYPE%
88
interp alias {} %TYPE%::myproc {} ::snit::RT.myproc %TYPE%
89
interp alias {} %TYPE%::mymethod {} ::snit::RT.mymethod
90
interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE%
91
interp alias {} %TYPE%::from {} ::snit::RT.from %TYPE%
93
#-------------------------------------------------------------------
94
# Snit's internal variables
96
namespace eval %TYPE% {
97
# Array: General Snit Info
99
# ns: The type's namespace
100
# hasinstances: T or F, from pragma -hasinstances.
101
# simpledispatch: T or F, from pragma -hasinstances.
102
# canreplace: T or F, from pragma -canreplace.
103
# counter: Count of instances created so far.
104
# widgetclass: Set by widgetclass statement.
105
# hulltype: Hull type (frame or toplevel) for widgets only.
106
# exceptmethods: Methods explicitly not delegated to *
107
# excepttypemethods: Methods explicitly not delegated to *
108
# tvardecs: Type variable declarations--for dynamic methods
109
# ivardecs: Instance variable declarations--for dyn. methods
110
typevariable Snit_info
111
set Snit_info(ns) %TYPE%::
112
set Snit_info(hasinstances) 1
113
set Snit_info(simpledispatch) 0
114
set Snit_info(canreplace) 0
115
set Snit_info(counter) 0
116
set Snit_info(widgetclass) {}
117
set Snit_info(hulltype) frame
118
set Snit_info(exceptmethods) {}
119
set Snit_info(excepttypemethods) {}
120
set Snit_info(tvardecs) {%TVARDECS%}
121
set Snit_info(ivardecs) {%IVARDECS%}
123
# Array: Public methods of this type.
124
# The index is the method name, or "*".
125
# The value is [list $pattern $componentName], where
126
# $componentName is "" for normal methods.
127
typevariable Snit_typemethodInfo
128
array unset Snit_typemethodInfo
130
# Array: Public methods of instances of this type.
131
# The index is the method name, or "*".
132
# The value is [list $pattern $componentName], where
133
# $componentName is "" for normal methods.
134
typevariable Snit_methodInfo
135
array unset Snit_methodInfo
137
# Array: option information. See dictionary.txt.
138
typevariable Snit_optionInfo
139
array unset Snit_optionInfo
140
set Snit_optionInfo(local) {}
141
set Snit_optionInfo(delegated) {}
142
set Snit_optionInfo(starcomp) {}
143
set Snit_optionInfo(except) {}
146
#----------------------------------------------------------------
149
# These commands are created or replaced during compilation:
152
# Snit_instanceVars selfns
154
# Initializes the instance variables, if any. Called during
157
proc %TYPE%::Snit_instanceVars {selfns} {
162
proc %TYPE%::Snit_typeconstructor {type} {
167
#----------------------------------------------------------------
170
# These commands might be replaced during compilation:
172
# Snit_destructor type selfns win self
174
# Default destructor for the type. By default, it does
175
# nothing. It's replaced by any user destructor.
176
# For types, it's called by method destroy; for widgettypes,
177
# it's called by a destroy event handler.
179
proc %TYPE%::Snit_destructor {type selfns win self} { }
181
#----------------------------------------------------------
182
# Compiled Definitions
186
#----------------------------------------------------------
187
# Finally, call the Type Constructor
189
%TYPE%::Snit_typeconstructor %TYPE%
192
#-----------------------------------------------------------------------
195
# These procs expect the fully-qualified type name to be
196
# substituted in for %TYPE%.
198
# This is the nominal type proc. It supports typemethods and
199
# delegated typemethods.
200
set ::snit::nominalTypeProc {
201
# Type dispatcher function. Note: This function lives
202
# in the parent of the %TYPE% namespace! All accesses to
203
# %TYPE% variables and methods must be qualified!
204
proc %TYPE% {{method ""} args} {
205
# First, if there's no method, and no args, and there's a create
206
# method, and this isn't a widget, then method is "create" and
208
if {$method == "" && [llength $args] == 0} {
209
::variable %TYPE%::Snit_info
211
if {$Snit_info(hasinstances) && !$Snit_info(isWidget)} {
215
error "wrong \# args: should be \"%TYPE% method args\""
219
# Next, retrieve the command.
221
if {[catch {set %TYPE%::Snit_typemethodCache($method)} commandRec]} {
222
set commandRec [::snit::RT.CacheTypemethodCommand %TYPE% $method]
224
if {[llength $commandRec] == 0} {
225
return -code error "\"%TYPE% $method\" is not defined"
229
# If we've got a real command, break.
230
if {[lindex $commandRec 0] == 0} {
234
# Otherwise, we need to look up again...if we can.
235
if {[llength $args] == 0} {
237
"wrong number args: should be \"%TYPE% $method method args\""
240
lappend method [lindex $args 0]
241
set args [lrange $args 1 end]
244
set command [lindex $commandRec 1]
246
# Pass along the return code unchanged.
247
set retval [catch {uplevel $command $args} result]
253
return -code error -errorinfo $errorInfo \
254
-errorcode $errorCode $result
256
return -code $retval $result
264
# This is the simplified type proc for when there are no typemethods
265
# except create. In this case, it doesn't take a method argument;
266
# the method is always "create".
267
set ::snit::simpleTypeProc {
268
# Type dispatcher function. Note: This function lives
269
# in the parent of the %TYPE% namespace! All accesses to
270
# %TYPE% variables and methods must be qualified!
272
::variable %TYPE%::Snit_info
274
# FIRST, if the are no args, the single arg is %AUTO%
275
if {[llength $args] == 0} {
276
if {$Snit_info(isWidget)} {
277
error "wrong \# args: should be \"%TYPE% name args\""
283
# NEXT, we're going to call the create method.
284
# Pass along the return code unchanged.
285
if {$Snit_info(isWidget)} {
286
set command [list ::snit::RT.widget.typemethod.create %TYPE%]
288
set command [list ::snit::RT.type.typemethod.create %TYPE%]
291
set retval [catch {uplevel $command $args} result]
297
return -code error -errorinfo $errorInfo \
298
-errorcode $errorCode $result
300
return -code $retval $result
308
#-----------------------------------------------------------------------
311
# The following must be substituted into these proc bodies:
313
# %SELFNS% The instance namespace
314
# %WIN% The original instance name
315
# %TYPE% The fully-qualified type name
318
# Nominal instance proc body: supports method caching and delegation.
320
# proc $instanceName {method args} ....
321
set ::snit::nominalInstanceProc {
322
set self [set %SELFNS%::Snit_instance]
325
if {[catch {set %SELFNS%::Snit_methodCache($method)} commandRec]} {
326
set commandRec [snit::RT.CacheMethodCommand %TYPE% %SELFNS% %WIN% $self $method]
328
if {[llength $commandRec] == 0} {
330
"\"$self $method\" is not defined"
334
# If we've got a real command, break.
335
if {[lindex $commandRec 0] == 0} {
339
# Otherwise, we need to look up again...if we can.
340
if {[llength $args] == 0} {
342
"wrong number args: should be \"$self $method method args\""
345
lappend method [lindex $args 0]
346
set args [lrange $args 1 end]
349
set command [lindex $commandRec 1]
351
# Pass along the return code unchanged.
352
set retval [catch {uplevel 1 $command $args} result]
358
return -code error -errorinfo $errorInfo \
359
-errorcode $errorCode $result
361
return -code $retval $result
368
# Simplified method proc body: No delegation allowed; no support for
369
# upvar or exotic return codes or hierarchical methods. Designed for
370
# max speed for simple types.
372
# proc $instanceName {method args} ....
374
set ::snit::simpleInstanceProc {
375
set self [set %SELFNS%::Snit_instance]
377
if {[lsearch -exact ${%TYPE%::Snit_methods} $method] == -1} {
378
set optlist [join ${%TYPE%::Snit_methods} ", "]
379
set optlist [linsert $optlist "end-1" "or"]
380
error "bad option \"$method\": must be $optlist"
383
eval [linsert $args 0 \
384
%TYPE%::Snit_method$method %TYPE% %SELFNS% %WIN% $self]
388
#=======================================================================
389
# Snit Type Definition
391
# These are the procs used to define Snit types, widgets, and
395
#-----------------------------------------------------------------------
396
# Snit Compilation Variables
398
# The following variables are used while Snit is compiling a type,
399
# and are disposed afterwards.
401
namespace eval ::snit:: {
402
# The compiler variable contains the name of the slave interpreter
403
# used to compile type definitions.
406
# The compile array accumulates information about the type or
407
# widgettype being compiled. It is cleared before and after each
408
# compilation. It has these indices:
410
# type: The name of the type being compiled, for use
411
# in compilation procs.
412
# defs: Compiled definitions, both standard and client.
413
# which: type, widget, widgetadaptor
414
# instancevars: Instance variable definitions and initializations.
415
# ivprocdec: Instance variable proc declarations.
416
# tvprocdec: Type variable proc declarations.
417
# typeconstructor: Type constructor body.
418
# widgetclass: The widgetclass, for snit::widgets, only
419
# hasoptions: False, initially; set to true when first
421
# localoptions: Names of local options.
422
# delegatedoptions: Names of delegated options.
423
# localmethods: Names of locally defined methods.
424
# delegatesmethods: no if no delegated methods, yes otherwise.
425
# hashierarchic : no if no hierarchic methods, yes otherwise.
426
# components: Names of defined components.
427
# typecomponents: Names of defined typecomponents.
428
# typevars: Typevariable definitions and initializations.
429
# varnames: Names of instance variables
430
# typevarnames Names of type variables
431
# hasconstructor False, initially; true when constructor is
433
# resource-$opt The option's resource name
434
# class-$opt The option's class
435
# -default-$opt The option's default value
436
# -validatemethod-$opt The option's validate method
437
# -configuremethod-$opt The option's configure method
438
# -cgetmethod-$opt The option's cget method.
439
# -hastypeinfo The -hastypeinfo pragma
440
# -hastypedestroy The -hastypedestroy pragma
441
# -hastypemethods The -hastypemethods pragma
442
# -hasinfo The -hasinfo pragma
443
# -hasinstances The -hasinstances pragma
444
# -simpledispatch The -simpledispatch pragma
445
# -canreplace The -canreplace pragma
448
# This variable accumulates method dispatch information; it has
449
# the same structure as the %TYPE%::Snit_methodInfo array, and is
450
# used to initialize it.
453
# This variable accumulates typemethod dispatch information; it has
454
# the same structure as the %TYPE%::Snit_typemethodInfo array, and is
455
# used to initialize it.
456
variable typemethodInfo
458
# The following variable lists the reserved type definition statement
459
# names, e.g., the names you can't use as macros. It's built at
460
# compiler definition time using "info commands".
461
variable reservedwords {}
464
#-----------------------------------------------------------------------
465
# type compilation commands
467
# The type and widgettype commands use a slave interpreter to compile
468
# the type definition. These are the procs
469
# that are aliased into it.
471
# Initialize the compiler
472
proc ::snit::Comp.Init {} {
474
variable reservedwords
476
if {$compiler == ""} {
477
# Create the compiler's interpreter
478
set compiler [interp create]
480
# Initialize the interpreter
482
# Load package information
483
# TBD: see if this can be moved outside.
484
catch {package require ::snit::__does_not_exist__}
486
# Protect some Tcl commands our type definitions
489
rename variable _variable
492
# Define compilation aliases.
493
$compiler alias pragma ::snit::Comp.statement.pragma
494
$compiler alias widgetclass ::snit::Comp.statement.widgetclass
495
$compiler alias hulltype ::snit::Comp.statement.hulltype
496
$compiler alias constructor ::snit::Comp.statement.constructor
497
$compiler alias destructor ::snit::Comp.statement.destructor
498
$compiler alias option ::snit::Comp.statement.option
499
$compiler alias oncget ::snit::Comp.statement.oncget
500
$compiler alias onconfigure ::snit::Comp.statement.onconfigure
501
$compiler alias method ::snit::Comp.statement.method
502
$compiler alias typemethod ::snit::Comp.statement.typemethod
503
$compiler alias typeconstructor ::snit::Comp.statement.typeconstructor
504
$compiler alias proc ::snit::Comp.statement.proc
505
$compiler alias typevariable ::snit::Comp.statement.typevariable
506
$compiler alias variable ::snit::Comp.statement.variable
507
$compiler alias typecomponent ::snit::Comp.statement.typecomponent
508
$compiler alias component ::snit::Comp.statement.component
509
$compiler alias delegate ::snit::Comp.statement.delegate
510
$compiler alias expose ::snit::Comp.statement.expose
512
# Get the list of reserved words
513
set reservedwords [$compiler eval {info commands}]
517
# Compile a type definition, and return the results as a list of two
518
# items: the fully-qualified type name, and a script that will define
519
# the type when executed.
521
# which type, widget, or widgetadaptor
523
# body the type definition
524
proc ::snit::Comp.Compile {which type body} {
525
variable typeTemplate
526
variable nominalTypeProc
527
variable simpleTypeProc
531
variable typemethodInfo
533
# FIRST, qualify the name.
534
if {![string match "::*" $type]} {
535
# Get caller's namespace;
536
# append :: if not global namespace.
537
set ns [uplevel 2 namespace current]
545
# NEXT, create and initialize the compiler, if needed.
548
# NEXT, initialize the class data
549
array unset methodInfo
550
array unset typemethodInfo
553
set compile(type) $type
555
set compile(which) $which
556
set compile(hasoptions) no
557
set compile(localoptions) {}
558
set compile(instancevars) {}
559
set compile(typevars) {}
560
set compile(delegatedoptions) {}
561
set compile(ivprocdec) {}
562
set compile(tvprocdec) {}
563
set compile(typeconstructor) {}
564
set compile(widgetclass) {}
565
set compile(hulltype) {}
566
set compile(localmethods) {}
567
set compile(delegatesmethods) no
568
set compile(hashierarchic) no
569
set compile(components) {}
570
set compile(typecomponents) {}
571
set compile(varnames) {}
572
set compile(typevarnames) {}
573
set compile(hasconstructor) no
574
set compile(-hastypedestroy) yes
575
set compile(-hastypeinfo) yes
576
set compile(-hastypemethods) yes
577
set compile(-hasinfo) yes
578
set compile(-hasinstances) yes
579
set compile(-simpledispatch) no
580
set compile(-canreplace) no
582
set isWidget [string match widget* $which]
583
set isWidgetAdaptor [string match widgetadaptor $which]
585
# NEXT, Evaluate the type's definition in the class interpreter.
588
# NEXT, Add the standard definitions
589
append compile(defs) \
590
"\nset %TYPE%::Snit_info(isWidget) $isWidget\n"
592
append compile(defs) \
593
"\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n"
595
# Indicate whether the type can create instances that replace
597
append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n"
600
# Check pragmas for conflict.
602
if {!$compile(-hastypemethods) && !$compile(-hasinstances)} {
603
error "$which $type has neither typemethods nor instances"
606
if {$compile(-simpledispatch) && $compile(delegatesmethods)} {
607
error "$which $type requests -simpledispatch but delegates methods."
610
if {$compile(-simpledispatch) && $compile(hashierarchic)} {
611
error "$which $type requests -simpledispatch but defines hierarchical methods."
614
# If there are typemethods, define the standard typemethods and
615
# the nominal type proc. Otherwise define the simple type proc.
616
if {$compile(-hastypemethods)} {
617
# Add the info typemethod unless the pragma forbids it.
618
if {$compile(-hastypeinfo)} {
619
Comp.statement.delegate typemethod info \
620
using {::snit::RT.typemethod.info %t}
623
# Add the destroy typemethod unless the pragma forbids it.
624
if {$compile(-hastypedestroy)} {
625
Comp.statement.delegate typemethod destroy \
626
using {::snit::RT.typemethod.destroy %t}
629
# Add the nominal type proc.
630
append compile(defs) $nominalTypeProc
632
# Add the simple type proc.
633
append compile(defs) $simpleTypeProc
636
# Add standard methods/typemethods that only make sense if the
637
# type has instances.
638
if {$compile(-hasinstances)} {
639
# If we're using simple dispatch, remember that.
640
if {$compile(-simpledispatch)} {
641
append compile(defs) "\nset %TYPE%::Snit_info(simpledispatch) 1\n"
644
# Add the info method unless the pragma forbids it.
645
if {$compile(-hasinfo)} {
646
if {!$compile(-simpledispatch)} {
647
Comp.statement.delegate method info \
648
using {::snit::RT.method.info %t %n %w %s}
650
Comp.statement.method info {args} {
651
eval [linsert $args 0 \
652
::snit::RT.method.info $type $selfns $win $self]
657
# Add the option handling stuff if there are any options.
658
if {$compile(hasoptions)} {
659
Comp.statement.variable options
661
if {!$compile(-simpledispatch)} {
662
Comp.statement.delegate method cget \
663
using {::snit::RT.method.cget %t %n %w %s}
664
Comp.statement.delegate method configurelist \
665
using {::snit::RT.method.configurelist %t %n %w %s}
666
Comp.statement.delegate method configure \
667
using {::snit::RT.method.configure %t %n %w %s}
669
Comp.statement.method cget {args} {
670
eval [linsert $args 0 \
671
::snit::RT.method.cget $type $selfns $win $self]
673
Comp.statement.method configurelist {args} {
674
eval [linsert $args 0 \
675
::snit::RT.method.configurelist $type $selfns $win $self]
677
Comp.statement.method configure {args} {
678
eval [linsert $args 0 \
679
::snit::RT.method.configure $type $selfns $win $self]
684
# Add a default constructor, if they haven't already defined one.
685
# If there are options, it will configure args; otherwise it
687
if {!$compile(hasconstructor)} {
688
if {$compile(hasoptions)} {
689
Comp.statement.constructor {args} {
690
$self configurelist $args
693
Comp.statement.constructor {} {}
698
if {!$compile(-simpledispatch)} {
699
Comp.statement.delegate method destroy \
700
using {::snit::RT.method.destroy %t %n %w %s}
702
Comp.statement.method destroy {args} {
703
eval [linsert $args 0 \
704
::snit::RT.method.destroy $type $selfns $win $self]
708
Comp.statement.delegate typemethod create \
709
using {::snit::RT.type.typemethod.create %t}
711
Comp.statement.delegate typemethod create \
712
using {::snit::RT.widget.typemethod.create %t}
715
# Save the list of method names, for -simpledispatch; otherwise,
716
# save the method info.
717
if {$compile(-simpledispatch)} {
718
append compile(defs) \
719
"\nset %TYPE%::Snit_methods [list $compile(localmethods)]\n"
721
append compile(defs) \
722
"\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n"
726
append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n"
729
# NEXT, compiling the type definition built up a set of information
730
# about the type's locally defined options; add this information to
731
# the compiled definition.
734
# NEXT, compiling the type definition built up a set of information
735
# about the typemethods; save the typemethod info.
736
append compile(defs) \
737
"\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n"
739
# NEXT, if this is a widget define the hull component if it isn't
742
Comp.DefineComponent hull
745
# NEXT, substitute the compiled definition into the type template
746
# to get the type definition script.
747
set defscript [Expand $typeTemplate \
748
%COMPILEDDEFS% $compile(defs)]
750
# NEXT, substitute the defined macros into the type definition script.
751
# This is done as a separate step so that the compile(defs) can
752
# contain the macros defined below.
754
set defscript [Expand $defscript \
756
%IVARDECS% $compile(ivprocdec) \
757
%TVARDECS% $compile(tvprocdec) \
758
%TCONSTBODY% $compile(typeconstructor) \
759
%INSTANCEVARS% $compile(instancevars) \
760
%TYPEVARS% $compile(typevars) \
765
return [list $type $defscript]
768
# Information about locally-defined options is accumulated during
769
# compilation, but not added to the compiled definition--the option
770
# statement can appear multiple times, so it's easier this way.
771
# This proc fills in Snit_optionInfo with the accumulated information.
773
# It also computes the option's resource and class names if needed.
775
# Note that the information for delegated options was put in
776
# Snit_optionInfo during compilation.
778
proc ::snit::Comp.SaveOptionInfo {} {
781
foreach option $compile(localoptions) {
782
if {$compile(resource-$option) == ""} {
783
set compile(resource-$option) [string range $option 1 end]
786
if {$compile(class-$option) == ""} {
787
set compile(class-$option) [Capitalize $compile(resource-$option)]
790
# NOTE: Don't verify that the validate, configure, and cget
791
# values name real methods; the methods might be defined outside
792
# the typedefinition using snit::method.
794
Mappend compile(defs) {
796
lappend %TYPE%::Snit_optionInfo(local) %OPTION%
798
set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 1
799
set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RESOURCE%
800
set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
801
set %TYPE%::Snit_optionInfo(default-%OPTION%) %DEFAULT%
802
set %TYPE%::Snit_optionInfo(validate-%OPTION%) %VALIDATE%
803
set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE%
804
set %TYPE%::Snit_optionInfo(cget-%OPTION%) %CGET%
805
set %TYPE%::Snit_optionInfo(readonly-%OPTION%) %READONLY%
807
%RESOURCE% $compile(resource-$option) \
808
%CLASS% $compile(class-$option) \
809
%DEFAULT% [list $compile(-default-$option)] \
810
%VALIDATE% [list $compile(-validatemethod-$option)] \
811
%CONFIGURE% [list $compile(-configuremethod-$option)] \
812
%CGET% [list $compile(-cgetmethod-$option)] \
813
%READONLY% $compile(-readonly-$option)
818
# Evaluates a compiled type definition, thus making the type available.
819
proc ::snit::Comp.Define {compResult} {
820
# The compilation result is a list containing the fully qualified
821
# type name and a script to evaluate to define the type.
822
set type [lindex $compResult 0]
823
set defscript [lindex $compResult 1]
825
# Execute the type definition script.
826
# Consider using namespace eval %TYPE%. See if it's faster.
827
if {[catch {eval $defscript} result]} {
828
namespace delete $type
829
catch {rename $type ""}
836
# Sets pragma options which control how the type is defined.
837
proc ::snit::Comp.statement.pragma {args} {
840
set errRoot "Error in \"pragma...\""
842
foreach {opt val} $args {
843
switch -exact -- $opt {
851
if {![string is boolean -strict $val]} {
852
error "$errRoot, \"$opt\" requires a boolean value"
854
set compile($opt) $val
857
error "$errRoot, unknown pragma"
863
# Defines a widget's option class name.
864
# This statement is only available for snit::widgets,
865
# not for snit::types or snit::widgetadaptors.
866
proc ::snit::Comp.statement.widgetclass {name} {
869
# First, widgetclass can only be set for true widgets
870
if {"widget" != $compile(which)} {
871
error "widgetclass cannot be set for snit::$compile(which)s"
874
# Next, validate the option name. We'll require that it begin
875
# with an uppercase letter.
876
set initial [string index $name 0]
877
if {![string is upper $initial]} {
878
error "widgetclass \"$name\" does not begin with an uppercase letter"
881
if {"" != $compile(widgetclass)} {
882
error "too many widgetclass statements"
886
Mappend compile(defs) {
887
set %TYPE%::Snit_info(widgetclass) %WIDGETCLASS%
888
} %WIDGETCLASS% [list $name]
890
set compile(widgetclass) $name
893
# Defines a widget's hull type.
894
# This statement is only available for snit::widgets,
895
# not for snit::types or snit::widgetadaptors.
896
proc ::snit::Comp.statement.hulltype {name} {
899
# First, hulltype can only be set for true widgets
900
if {"widget" != $compile(which)} {
901
error "hulltype cannot be set for snit::$compile(which)s"
904
# Next, it must be either "frame" or "toplevel"
905
if {"frame" != $name && "toplevel" != $name} {
906
error "invalid hulltype \"$name\", should be \"frame\" or \"toplevel\""
909
if {"" != $compile(hulltype)} {
910
error "too many hulltype statements"
914
Mappend compile(defs) {
915
set %TYPE%::Snit_info(hulltype) %HULLTYPE%
918
set compile(hulltype) $name
921
# Defines a constructor.
922
proc ::snit::Comp.statement.constructor {arglist body} {
925
CheckArgs "constructor" $arglist
927
# Next, add a magic reference to self.
928
set arglist [concat type selfns win self $arglist]
930
# Next, add variable declarations to body:
931
set body "%TVARDECS%%IVARDECS%\n$body"
933
set compile(hasconstructor) yes
934
append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n"
937
# Defines a destructor.
938
proc ::snit::Comp.statement.destructor {body} {
941
# Next, add variable declarations to body:
942
set body "%TVARDECS%%IVARDECS%\n$body"
944
append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]"
947
# Defines a type option. The option value can be a triple, specifying
948
# the option's -name, resource name, and class name.
949
proc ::snit::Comp.statement.option {optionDef args} {
952
# First, get the three option names.
953
set option [lindex $optionDef 0]
954
set resourceName [lindex $optionDef 1]
955
set className [lindex $optionDef 2]
957
set errRoot "Error in \"option [list $optionDef]...\""
959
# Next, validate the option name.
960
if {![Comp.OptionNameIsValid $option]} {
961
error "$errRoot, badly named option \"$option\""
964
if {[Contains $option $compile(delegatedoptions)]} {
965
error "$errRoot, cannot define \"$option\" locally, it has been delegated"
968
if {![Contains $option $compile(localoptions)]} {
969
# Remember that we've seen this one.
970
set compile(hasoptions) yes
971
lappend compile(localoptions) $option
973
# Initialize compilation info for this option.
974
set compile(resource-$option) ""
975
set compile(class-$option) ""
976
set compile(-default-$option) ""
977
set compile(-validatemethod-$option) ""
978
set compile(-configuremethod-$option) ""
979
set compile(-cgetmethod-$option) ""
980
set compile(-readonly-$option) 0
983
# NEXT, see if we have a resource name. If so, make sure it
984
# isn't being redefined differently.
985
if {$resourceName != ""} {
986
if {$compile(resource-$option) == ""} {
987
# If it's undefined, just save the value.
988
set compile(resource-$option) $resourceName
989
} elseif {$resourceName != $compile(resource-$option)} {
990
# It's been redefined differently.
991
error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\""
995
# NEXT, see if we have a class name. If so, make sure it
996
# isn't being redefined differently.
997
if {$className != ""} {
998
if {$compile(class-$option) == ""} {
999
# If it's undefined, just save the value.
1000
set compile(class-$option) $className
1001
} elseif {$className != $compile(class-$option)} {
1002
# It's been redefined differently.
1003
error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\""
1007
# NEXT, handle the args; it's not an error to redefine these.
1008
if {[llength $args] == 1} {
1009
set compile(-default-$option) [lindex $args 0]
1011
foreach {optopt val} $args {
1012
switch -exact -- $optopt {
1017
set compile($optopt-$option) $val
1020
if {![string is boolean -strict $val]} {
1021
error "$errRoot, -readonly requires a boolean, got \"$val\""
1023
set compile($optopt-$option) $val
1026
error "$errRoot, unknown option definition option \"$optopt\""
1033
# 1 if the option name is valid, 0 otherwise.
1034
proc ::snit::Comp.OptionNameIsValid {option} {
1035
if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} {
1042
# Defines an option's cget handler
1043
proc ::snit::Comp.statement.oncget {option body} {
1046
set errRoot "Error in \"oncget $option...\""
1048
if {[lsearch $compile(delegatedoptions) $option] != -1} {
1049
error "$errRoot, option \"$option\" is delegated"
1052
if {[lsearch $compile(localoptions) $option] == -1} {
1053
error "$errRoot, option \"$option\" unknown"
1056
# Next, add variable declarations to body:
1057
set body "%TVARDECS%%IVARDECS%\n$body"
1059
Comp.statement.method _cget$option {_option} $body
1060
Comp.statement.option $option -cgetmethod _cget$option
1063
# Defines an option's configure handler.
1064
proc ::snit::Comp.statement.onconfigure {option arglist body} {
1067
if {[lsearch $compile(delegatedoptions) $option] != -1} {
1068
error "onconfigure $option: option \"$option\" is delegated"
1071
if {[lsearch $compile(localoptions) $option] == -1} {
1072
error "onconfigure $option: option \"$option\" unknown"
1075
if {[llength $arglist] != 1} {
1077
"onconfigure $option handler should have one argument, got \"$arglist\""
1080
CheckArgs "onconfigure $option" $arglist
1082
# Next, add a magic reference to the option name
1083
set arglist [concat _option $arglist]
1085
Comp.statement.method _configure$option $arglist $body
1086
Comp.statement.option $option -configuremethod _configure$option
1089
# Defines an instance method.
1090
proc ::snit::Comp.statement.method {method arglist body} {
1094
# FIRST, check the method name against previously defined
1096
Comp.CheckMethodName $method 0 ::snit::methodInfo \
1097
"Error in \"method [list $method]...\""
1099
if {[llength $method] > 1} {
1100
set compile(hashierarchic) yes
1103
# Remeber this method
1104
lappend compile(localmethods) $method
1106
CheckArgs "method [list $method]" $arglist
1108
# Next, add magic references to type and self.
1109
set arglist [concat type selfns win self $arglist]
1111
# Next, add variable declarations to body:
1112
set body "%TVARDECS%%IVARDECS%\n$body"
1114
# Next, save the definition script.
1115
if {[llength $method] == 1} {
1116
set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
1117
Mappend compile(defs) {
1118
proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY%
1119
} %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
1121
set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
1123
Mappend compile(defs) {
1124
proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY%
1125
} %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \
1130
# Check for name collisions; save prefix information.
1132
# method The name of the method or typemethod.
1133
# delFlag 1 if delegated, 0 otherwise.
1134
# infoVar The fully qualified name of the array containing
1135
# information about the defined methods.
1136
# errRoot The root string for any error messages.
1138
proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} {
1139
upvar $infoVar methodInfo
1141
# FIRST, make sure the method name is a valid Tcl list.
1142
if {[catch {lindex $method 0}]} {
1143
error "$errRoot, the name \"$method\" must have list syntax."
1146
# NEXT, check whether we can define it.
1147
if {![catch {set methodInfo($method)} data]} {
1148
# We can't redefine methods with submethods.
1149
if {[lindex $data 0] == 1} {
1150
error "$errRoot, \"$method\" has submethods."
1153
# You can't delegate a method that's defined locally,
1154
# and you can't define a method locally if it's been delegated.
1155
if {$delFlag && [lindex $data 2] == ""} {
1156
error "$errRoot, \"$method\" has been defined locally."
1157
} elseif {!$delFlag && [lindex $data 2] != ""} {
1158
error "$errRoot, \"$method\" has been delegated"
1162
# Handle hierarchical case.
1163
if {[llength $method] > 1} {
1166
while {[llength $tokens] > 1} {
1167
lappend prefix [lindex $tokens 0]
1168
set tokens [lrange $tokens 1 end]
1170
if {![catch {set methodInfo($prefix)} result]} {
1171
# Prefix is known. If it's not a prefix, throw an
1173
if {[lindex $result 0] == 0} {
1174
error "$errRoot, \"$prefix\" has no submethods."
1178
set methodInfo($prefix) [list 1]
1183
# Defines a typemethod method.
1184
proc ::snit::Comp.statement.typemethod {method arglist body} {
1186
variable typemethodInfo
1188
# FIRST, check the typemethod name against previously defined
1190
Comp.CheckMethodName $method 0 ::snit::typemethodInfo \
1191
"Error in \"typemethod [list $method]...\""
1193
CheckArgs "typemethod $method" $arglist
1195
# First, add magic reference to type.
1196
set arglist [concat type $arglist]
1198
# Next, add typevariable declarations to body:
1199
set body "%TVARDECS%\n$body"
1201
# Next, save the definition script
1202
if {[llength $method] == 1} {
1203
set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
1205
Mappend compile(defs) {
1206
proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY%
1207
} %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
1209
set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
1211
Mappend compile(defs) {
1212
proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY%
1213
} %JMETHOD% [join $method _] \
1214
%ARGLIST% [list $arglist] %BODY% [list $body]
1219
# Defines a type constructor.
1220
proc ::snit::Comp.statement.typeconstructor {body} {
1223
if {"" != $compile(typeconstructor)} {
1224
error "too many typeconstructors"
1227
set compile(typeconstructor) $body
1230
# Defines a static proc in the type's namespace.
1231
proc ::snit::Comp.statement.proc {proc arglist body} {
1234
# If "ns" is defined, the proc can see instance variables.
1235
if {[lsearch -exact $arglist selfns] != -1} {
1236
# Next, add instance variable declarations to body:
1237
set body "%IVARDECS%\n$body"
1240
# The proc can always see typevariables.
1241
set body "%TVARDECS%\n$body"
1243
append compile(defs) "
1246
proc [list %TYPE%::$proc $arglist $body]
1250
# Defines a static variable in the type's namespace.
1251
proc ::snit::Comp.statement.typevariable {name args} {
1254
set errRoot "Error in \"typevariable $name...\""
1256
set len [llength $args]
1259
($len == 2 && [lindex $args 0] != "-array")} {
1260
error "$errRoot, too many initializers"
1263
if {[lsearch -exact $compile(varnames) $name] != -1} {
1264
error "$errRoot, \"$name\" is already an instance variable"
1267
lappend compile(typevarnames) $name
1270
append compile(typevars) \
1271
"\n\t [list ::variable $name [lindex $args 0]]"
1272
} elseif {$len == 2} {
1273
append compile(typevars) \
1274
"\n\t [list ::variable $name]"
1275
append compile(typevars) \
1276
"\n\t [list array set $name [lindex $args 1]]"
1278
append compile(typevars) \
1279
"\n\t [list ::variable $name]"
1282
append compile(tvprocdec) "\n\t typevariable ${name}"
1285
# Defines an instance variable; the definition will go in the
1286
# type's create typemethod.
1287
proc ::snit::Comp.statement.variable {name args} {
1290
set errRoot "Error in \"variable $name...\""
1292
set len [llength $args]
1295
($len == 2 && [lindex $args 0] != "-array")} {
1296
error "$errRoot, too many initializers"
1299
if {[lsearch -exact $compile(typevarnames) $name] != -1} {
1300
error "$errRoot, \"$name\" is already a typevariable"
1303
lappend compile(varnames) $name
1306
append compile(instancevars) \
1307
"\nset \${selfns}::$name [list [lindex $args 0]]\n"
1308
} elseif {$len == 2} {
1309
append compile(instancevars) \
1310
"\narray set \${selfns}::$name [list [lindex $args 1]]\n"
1313
append compile(ivprocdec) "\n\t "
1314
Mappend compile(ivprocdec) {::variable ${selfns}::%N} %N $name
1317
# Defines a typecomponent, and handles component options.
1319
# component The logical name of the delegate
1322
proc ::snit::Comp.statement.typecomponent {component args} {
1325
set errRoot "Error in \"typecomponent $component...\""
1327
# FIRST, define the component
1328
Comp.DefineTypecomponent $component $errRoot
1330
# NEXT, handle the options.
1334
foreach {opt val} $args {
1335
switch -exact -- $opt {
1337
set publicMethod $val
1340
set inheritFlag $val
1341
if {![string is boolean $inheritFlag]} {
1342
error "typecomponent $component -inherit: expected boolean value, got \"$val\""
1346
error "typecomponent $component: Invalid option \"$opt\""
1351
# NEXT, if -public specified, define the method.
1352
if {$publicMethod != ""} {
1353
Comp.statement.delegate typemethod [list $publicMethod *] to $component
1356
# NEXT, if "-inherit 1" is specified, delegate typemethod * to
1359
Comp.statement.delegate typemethod "*" to $component
1365
# Defines a name to be a typecomponent
1367
# The name becomes a typevariable; in addition, it gets a
1368
# write trace so that when it is set, all of the component mechanisms
1371
# component The component name
1373
proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} {
1376
if {[lsearch -exact $compile(varnames) $component] != -1} {
1377
error "$errRoot, \"$component\" is already an instance variable"
1380
if {[lsearch $compile(typecomponents) $component] == -1} {
1381
# Remember we've done this.
1382
lappend compile(typecomponents) $component
1384
# Make it a type variable with no initial value
1385
Comp.statement.typevariable $component ""
1387
# Add a write trace to do the component thing.
1388
Mappend compile(typevars) {
1389
trace variable %COMP% w \
1390
[list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%]
1391
} %TYPE% $compile(type) %COMP% $component
1395
# Defines a component, and handles component options.
1397
# component The logical name of the delegate
1400
# TBD: Ideally, it should be possible to call this statement multiple
1401
# times, possibly changing the option values. To do that, I'd need
1402
# to cache the option values and not act on them until *after* I'd
1403
# read the entire type definition.
1405
proc ::snit::Comp.statement.component {component args} {
1408
set errRoot "Error in \"component $component...\""
1410
# FIRST, define the component
1411
Comp.DefineComponent $component $errRoot
1413
# NEXT, handle the options.
1417
foreach {opt val} $args {
1418
switch -exact -- $opt {
1420
set publicMethod $val
1423
set inheritFlag $val
1424
if {![string is boolean $inheritFlag]} {
1425
error "component $component -inherit: expected boolean value, got \"$val\""
1429
error "component $component: Invalid option \"$opt\""
1434
# NEXT, if -public specified, define the method.
1435
if {$publicMethod != ""} {
1436
Comp.statement.delegate method [list $publicMethod *] to $component
1439
# NEXT, if -inherit is specified, delegate method/option * to
1442
Comp.statement.delegate method "*" to $component
1443
Comp.statement.delegate option "*" to $component
1448
# Defines a name to be a component
1450
# The name becomes an instance variable; in addition, it gets a
1451
# write trace so that when it is set, all of the component mechanisms
1454
# component The component name
1456
proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} {
1459
if {[lsearch -exact $compile(typevarnames) $component] != -1} {
1460
error "$errRoot, \"$component\" is already a typevariable"
1463
if {[lsearch $compile(components) $component] == -1} {
1464
# Remember we've done this.
1465
lappend compile(components) $component
1467
# Make it an instance variable with no initial value
1468
Comp.statement.variable $component ""
1470
# Add a write trace to do the component thing.
1471
Mappend compile(instancevars) {
1472
trace variable ${selfns}::%COMP% w \
1473
[list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%]
1474
} %TYPE% $compile(type) %COMP% $component
1478
# Creates a delegated method, typemethod, or option.
1479
proc ::snit::Comp.statement.delegate {what name args} {
1480
# FIRST, dispatch to correct handler.
1482
typemethod { Comp.DelegatedTypemethod $name $args }
1483
method { Comp.DelegatedMethod $name $args }
1484
option { Comp.DelegatedOption $name $args }
1486
error "Error in \"delegate $what $name...\", \"$what\"?"
1490
if {([llength $args] % 2) != 0} {
1491
error "Error in \"delegate $what $name...\", invalid syntax"
1495
# Creates a delegated typemethod delegating it to a particular
1496
# typecomponent or an arbitrary command.
1498
# method The name of the method
1499
# arglist Delegation options
1501
proc ::snit::Comp.DelegatedTypemethod {method arglist} {
1503
variable typemethodInfo
1505
set errRoot "Error in \"delegate typemethod [list $method]...\""
1507
# Next, parse the delegation options.
1512
set methodTail [lindex $method end]
1514
foreach {opt value} $arglist {
1515
switch -exact $opt {
1516
to { set component $value }
1517
as { set target $value }
1518
except { set exceptions $value }
1519
using { set pattern $value }
1521
error "$errRoot, unknown delegation option \"$opt\""
1526
if {$component == "" && $pattern == ""} {
1527
error "$errRoot, missing \"to\""
1530
if {$methodTail == "*" && $target != ""} {
1531
error "$errRoot, cannot specify \"as\" with \"*\""
1534
if {$methodTail != "*" && $exceptions != ""} {
1535
error "$errRoot, can only specify \"except\" with \"*\""
1538
if {$pattern != "" && $target != ""} {
1539
error "$errRoot, cannot specify both \"as\" and \"using\""
1542
foreach token [lrange $method 1 end-1] {
1543
if {$token == "*"} {
1544
error "$errRoot, \"*\" must be the last token."
1548
# NEXT, define the component
1549
if {$component != ""} {
1550
Comp.DefineTypecomponent $component $errRoot
1553
# NEXT, define the pattern.
1554
if {$pattern == ""} {
1555
if {$methodTail == "*"} {
1557
} elseif {$target != ""} {
1558
set pattern "%c $target"
1564
# Make sure the pattern is a valid list.
1565
if {[catch {lindex $pattern 0} result]} {
1566
error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
1569
# NEXT, check the method name against previously defined
1571
Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot
1573
set typemethodInfo($method) [list 0 $pattern $component]
1575
if {[string equal $methodTail "*"]} {
1576
Mappend compile(defs) {
1577
set %TYPE%::Snit_info(excepttypemethods) %EXCEPT%
1578
} %EXCEPT% [list $exceptions]
1583
# Creates a delegated method delegating it to a particular
1584
# component or command.
1586
# method The name of the method
1587
# arglist Delegation options.
1589
proc ::snit::Comp.DelegatedMethod {method arglist} {
1593
set errRoot "Error in \"delegate method [list $method]...\""
1595
# Next, parse the delegation options.
1600
set methodTail [lindex $method end]
1602
foreach {opt value} $arglist {
1603
switch -exact $opt {
1604
to { set component $value }
1605
as { set target $value }
1606
except { set exceptions $value }
1607
using { set pattern $value }
1609
error "$errRoot, unknown delegation option \"$opt\""
1614
if {$component == "" && $pattern == ""} {
1615
error "$errRoot, missing \"to\""
1618
if {$methodTail == "*" && $target != ""} {
1619
error "$errRoot, cannot specify \"as\" with \"*\""
1622
if {$methodTail != "*" && $exceptions != ""} {
1623
error "$errRoot, can only specify \"except\" with \"*\""
1626
if {$pattern != "" && $target != ""} {
1627
error "$errRoot, cannot specify both \"as\" and \"using\""
1630
foreach token [lrange $method 1 end-1] {
1631
if {$token == "*"} {
1632
error "$errRoot, \"*\" must be the last token."
1636
# NEXT, we delegate some methods
1637
set compile(delegatesmethods) yes
1639
# NEXT, define the component. Allow typecomponents.
1640
if {$component != ""} {
1641
if {[lsearch -exact $compile(typecomponents) $component] == -1} {
1642
Comp.DefineComponent $component $errRoot
1646
# NEXT, define the pattern.
1647
if {$pattern == ""} {
1648
if {$methodTail == "*"} {
1650
} elseif {$target != ""} {
1651
set pattern "%c $target"
1657
# Make sure the pattern is a valid list.
1658
if {[catch {lindex $pattern 0} result]} {
1659
error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
1662
# NEXT, check the method name against previously defined
1664
Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot
1666
# NEXT, save the method info.
1667
set methodInfo($method) [list 0 $pattern $component]
1669
if {[string equal $methodTail "*"]} {
1670
Mappend compile(defs) {
1671
set %TYPE%::Snit_info(exceptmethods) %EXCEPT%
1672
} %EXCEPT% [list $exceptions]
1676
# Creates a delegated option, delegating it to a particular
1677
# component and, optionally, to a particular option of that
1680
# optionDef The option definition
1681
# args definition arguments.
1683
proc ::snit::Comp.DelegatedOption {optionDef arglist} {
1686
# First, get the three option names.
1687
set option [lindex $optionDef 0]
1688
set resourceName [lindex $optionDef 1]
1689
set className [lindex $optionDef 2]
1691
set errRoot "Error in \"delegate option [list $optionDef]...\""
1693
# Next, parse the delegation options.
1698
foreach {opt value} $arglist {
1699
switch -exact $opt {
1700
to { set component $value }
1701
as { set target $value }
1702
except { set exceptions $value }
1704
error "$errRoot, unknown delegation option \"$opt\""
1709
if {$component == ""} {
1710
error "$errRoot, missing \"to\""
1713
if {$option == "*" && $target != ""} {
1714
error "$errRoot, cannot specify \"as\" with \"delegate option *\""
1717
if {$option != "*" && $exceptions != ""} {
1718
error "$errRoot, can only specify \"except\" with \"delegate option *\""
1721
# Next, validate the option name
1723
if {"*" != $option} {
1724
if {![Comp.OptionNameIsValid $option]} {
1725
error "$errRoot, badly named option \"$option\""
1729
if {[Contains $option $compile(localoptions)]} {
1730
error "$errRoot, \"$option\" has been defined locally"
1733
if {[Contains $option $compile(delegatedoptions)]} {
1734
error "$errRoot, \"$option\" is multiply delegated"
1737
# NEXT, define the component
1738
Comp.DefineComponent $component $errRoot
1740
# Next, define the target option, if not specified.
1741
if {![string equal $option "*"] &&
1742
[string equal $target ""]} {
1746
# NEXT, save the delegation data.
1747
set compile(hasoptions) yes
1749
if {![string equal $option "*"]} {
1750
lappend compile(delegatedoptions) $option
1752
# Next, compute the resource and class names, if they aren't
1755
if {"" == $resourceName} {
1756
set resourceName [string range $option 1 end]
1759
if {"" == $className} {
1760
set className [Capitalize $resourceName]
1763
Mappend compile(defs) {
1764
set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0
1765
set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES%
1766
set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
1767
lappend %TYPE%::Snit_optionInfo(delegated) %OPTION%
1768
set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%]
1769
lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION%
1770
} %OPTION% $option \
1773
%RES% $resourceName \
1776
Mappend compile(defs) {
1777
set %TYPE%::Snit_optionInfo(starcomp) %COMP%
1778
set %TYPE%::Snit_optionInfo(except) %EXCEPT%
1779
} %COMP% $component %EXCEPT% [list $exceptions]
1783
# Exposes a component, effectively making the component's command an
1786
# component The logical name of the delegate
1787
# "as" sugar; if not "", must be "as"
1788
# methodname The desired method name for the component's command, or ""
1790
proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} {
1794
# FIRST, define the component
1795
Comp.DefineComponent $component
1797
# NEXT, define the method just as though it were in the type
1799
if {[string equal $methodname ""]} {
1800
set methodname $component
1803
Comp.statement.method $methodname args [Expand {
1804
if {[llength $args] == 0} {
1808
if {[string equal $%COMPONENT% ""]} {
1809
error "undefined component \"%COMPONENT%\""
1813
set cmd [linsert $args 0 $%COMPONENT%]
1814
return [uplevel 1 $cmd]
1815
} %COMPONENT% $component]
1820
#-----------------------------------------------------------------------
1823
# Compile a type definition, and return the results as a list of two
1824
# items: the fully-qualified type name, and a script that will define
1825
# the type when executed.
1827
# which type, widget, or widgetadaptor
1828
# type the type name
1829
# body the type definition
1830
proc ::snit::compile {which type body} {
1831
return [Comp.Compile $which $type $body]
1834
proc ::snit::type {type body} {
1835
return [Comp.Define [Comp.Compile type $type $body]]
1838
proc ::snit::widget {type body} {
1839
return [Comp.Define [Comp.Compile widget $type $body]]
1842
proc ::snit::widgetadaptor {type body} {
1843
return [Comp.Define [Comp.Compile widgetadaptor $type $body]]
1846
proc ::snit::typemethod {type method arglist body} {
1847
# Make sure the type exists.
1848
if {![info exists ${type}::Snit_info]} {
1849
error "no such type: \"$type\""
1852
upvar ${type}::Snit_info Snit_info
1853
upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
1855
# FIRST, check the typemethod name against previously defined
1857
Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \
1858
"Cannot define \"$method\""
1860
# NEXT, check the arguments
1861
CheckArgs "snit::typemethod $type $method" $arglist
1863
# Next, add magic reference to type.
1864
set arglist [concat type $arglist]
1866
# Next, add typevariable declarations to body:
1867
set body "$Snit_info(tvardecs)\n$body"
1870
if {[llength $method] == 1} {
1871
set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
1872
uplevel [list proc ${type}::Snit_typemethod$method $arglist $body]
1874
set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
1875
set suffix [join $method _]
1876
uplevel [list proc ${type}::Snit_htypemethod$suffix $arglist $body]
1880
proc ::snit::method {type method arglist body} {
1881
# Make sure the type exists.
1882
if {![info exists ${type}::Snit_info]} {
1883
error "no such type: \"$type\""
1886
upvar ${type}::Snit_methodInfo Snit_methodInfo
1887
upvar ${type}::Snit_info Snit_info
1889
# FIRST, check the method name against previously defined
1891
Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \
1892
"Cannot define \"$method\""
1894
# NEXT, check the arguments
1895
CheckArgs "snit::method $type $method" $arglist
1897
# Next, add magic references to type and self.
1898
set arglist [concat type selfns win self $arglist]
1900
# Next, add variable declarations to body:
1901
set body "$Snit_info(tvardecs)$Snit_info(ivardecs)\n$body"
1904
if {[llength $method] == 1} {
1905
set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
1906
uplevel [list proc ${type}::Snit_method$method $arglist $body]
1908
set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
1910
set suffix [join $method _]
1911
uplevel [list proc ${type}::Snit_hmethod$suffix $arglist $body]
1915
# Defines a proc within the compiler; this proc can call other
1916
# type definition statements, and thus can be used for meta-programming.
1917
proc ::snit::macro {name arglist body} {
1919
variable reservedwords
1921
# FIRST, make sure the compiler is defined.
1924
# NEXT, check the macro name against the reserved words
1925
if {[lsearch -exact $reservedwords $name] != -1} {
1926
error "invalid macro name \"$name\""
1929
# NEXT, see if the name has a namespace; if it does, define the
1931
set ns [namespace qualifiers $name]
1934
$compiler eval "namespace eval $ns {}"
1937
# NEXT, define the macro
1938
$compiler eval [list _proc $name $arglist $body]
1941
#-----------------------------------------------------------------------
1944
# These are utility functions used while compiling Snit types.
1946
# Builds a template from a tagged list of text blocks, then substitutes
1947
# all symbols in the mapTable, returning the expanded template.
1948
proc ::snit::Expand {template args} {
1949
return [string map $args $template]
1952
# Expands a template and appends it to a variable.
1953
proc ::snit::Mappend {varname template args} {
1954
upvar $varname myvar
1956
append myvar [string map $args $template]
1959
# Checks argument list against reserved args
1960
proc ::snit::CheckArgs {which arglist} {
1961
variable reservedArgs
1963
foreach name $reservedArgs {
1964
if {[Contains $name $arglist]} {
1965
error "$which's arglist may not contain \"$name\" explicitly"
1970
# Returns 1 if a value is in a list, and 0 otherwise.
1971
proc ::snit::Contains {value list} {
1972
if {[lsearch -exact $list $value] != -1} {
1979
# Capitalizes the first letter of a string.
1980
proc ::snit::Capitalize {text} {
1981
set first [string index $text 0]
1982
set rest [string range $text 1 end]
1983
return "[string toupper $first]$rest"
1986
# Converts an arbitrary white-space-delimited string into a list
1987
# by splitting on white-space and deleting empty tokens.
1989
proc ::snit::Listify {str} {
1991
foreach token [split [string trim $str]] {
1992
if {[string length $token] > 0} {
1993
lappend result $token
2001
#=======================================================================
2002
# Snit Runtime Library
2004
# These are procs used by Snit types and widgets at runtime.
2006
#-----------------------------------------------------------------------
2009
# Creates a new instance of the snit::type given its name and the args.
2011
# type The snit::type
2012
# name The instance name
2013
# args Args to pass to the constructor
2015
proc ::snit::RT.type.typemethod.create {type name args} {
2016
variable ${type}::Snit_info
2017
variable ${type}::Snit_optionInfo
2019
# FIRST, qualify the name.
2020
if {![string match "::*" $name]} {
2021
# Get caller's namespace;
2022
# append :: if not global namespace.
2023
set ns [uplevel 1 namespace current]
2031
# NEXT, if %AUTO% appears in the name, generate a unique
2032
# command name. Otherwise, ensure that the name isn't in use.
2033
if {[string match "*%AUTO%*" $name]} {
2034
set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
2035
} elseif {!$Snit_info(canreplace) && [info commands $name] != ""} {
2036
error "command \"$name\" already exists"
2039
# NEXT, create the instance's namespace.
2041
[::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
2042
namespace eval $selfns {}
2044
# NEXT, install the dispatcher
2045
RT.MakeInstanceCommand $type $selfns $name
2047
# Initialize the options to their defaults.
2048
upvar ${selfns}::options options
2049
foreach opt $Snit_optionInfo(local) {
2050
set options($opt) $Snit_optionInfo(default-$opt)
2053
# Initialize the instance vars to their defaults.
2054
# selfns must be defined, as it is used implicitly.
2055
${type}::Snit_instanceVars $selfns
2057
# Execute the type's constructor.
2058
set errcode [catch {
2059
RT.ConstructInstance $type $selfns $name $args
2066
set theInfo $errorInfo
2067
set theCode $errorCode
2068
::snit::RT.DestroyObject $type $selfns $name
2069
error "Error in constructor: $result" $theInfo $theCode
2072
# NEXT, return the object's name.
2076
# Creates a new instance of the snit::widget or snit::widgetadaptor
2077
# given its name and the args.
2079
# type The snit::widget or snit::widgetadaptor
2080
# name The instance name
2081
# args Args to pass to the constructor
2083
proc ::snit::RT.widget.typemethod.create {type name args} {
2084
variable ${type}::Snit_info
2085
variable ${type}::Snit_optionInfo
2087
# FIRST, if %AUTO% appears in the name, generate a unique
2089
if {[string match "*%AUTO%*" $name]} {
2090
set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
2093
# NEXT, create the instance's namespace.
2095
[::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
2096
namespace eval $selfns { }
2098
# NEXT, Initialize the widget's own options to their defaults.
2099
upvar ${selfns}::options options
2100
foreach opt $Snit_optionInfo(local) {
2101
set options($opt) $Snit_optionInfo(default-$opt)
2104
# Initialize the instance vars to their defaults.
2105
${type}::Snit_instanceVars $selfns
2107
# NEXT, if this is a normal widget (not a widget adaptor) then
2108
# create a frame as its hull. We set the frame's -class to
2109
# the user's widgetclass, or, if none, to the basename of
2110
# the $type with an initial upper case letter.
2111
if {!$Snit_info(isWidgetAdaptor)} {
2112
# FIRST, determine the class name
2113
if {"" == $Snit_info(widgetclass)} {
2114
set Snit_info(widgetclass) \
2115
[::snit::Capitalize [namespace tail $type]]
2118
# NEXT, create the widget
2121
${type}::installhull using \
2122
$Snit_info(hulltype) -class $Snit_info(widgetclass)
2124
# NEXT, let's query the option database for our
2125
# widget, now that we know that it exists.
2126
foreach opt $Snit_optionInfo(local) {
2127
set dbval [RT.OptionDbGet $type $name $opt]
2130
set options($opt) $dbval
2135
# Execute the type's constructor, and verify that it
2137
set errcode [catch {
2138
RT.ConstructInstance $type $selfns $name $args
2140
::snit::RT.Component $type $selfns hull
2142
# Prepare to call the object's destructor when the
2143
# <Destroy> event is received. Use a Snit-specific bindtag
2144
# so that the widget name's tag is unencumbered.
2146
bind Snit$type$name <Destroy> [::snit::Expand {
2147
::snit::RT.DestroyObject %TYPE% %NS% %W
2148
} %TYPE% $type %NS% $selfns]
2150
# Insert the bindtag into the list of bindtags right
2151
# after the widget name.
2152
set taglist [bindtags $name]
2153
set ndx [lsearch $taglist $name]
2155
bindtags $name [linsert $taglist $ndx Snit$type$name]
2162
set theInfo $errorInfo
2163
set theCode $errorCode
2164
::snit::RT.DestroyObject $type $selfns $name
2165
error "Error in constructor: $result" $theInfo $theCode
2168
# NEXT, return the object's name.
2173
# RT.MakeInstanceCommand type selfns instance
2175
# type The object type
2176
# selfns The instance namespace
2177
# instance The instance name
2179
# Creates the instance proc.
2181
proc ::snit::RT.MakeInstanceCommand {type selfns instance} {
2182
variable ${type}::Snit_info
2184
# FIRST, remember the instance name. The Snit_instance variable
2185
# allows the instance to figure out its current name given the
2186
# instance namespace.
2187
upvar ${selfns}::Snit_instance Snit_instance
2188
set Snit_instance $instance
2190
# NEXT, qualify the proc name if it's a widget.
2191
if {$Snit_info(isWidget)} {
2192
set procname ::$instance
2194
set procname $instance
2197
# NEXT, install the new proc
2198
if {!$Snit_info(simpledispatch)} {
2199
set instanceProc $::snit::nominalInstanceProc
2201
set instanceProc $::snit::simpleInstanceProc
2204
proc $procname {method args} \
2206
[list %SELFNS% $selfns %WIN% $instance %TYPE% $type] \
2209
#trace add command doesnt exist in tcl 8.3
2210
# NEXT, add the trace.
2211
#trace add command $procname {rename delete} \
2212
# [list ::snit::RT.InstanceTrace $type $selfns $instance]
2215
# This proc is called when the instance command is renamed.
2216
# If op is delete, then new will always be "", so op is redundant.
2218
# type The fully-qualified type name
2219
# selfns The instance namespace
2220
# win The original instance/tk window name.
2221
# old old instance command name
2222
# new new instance command name
2223
# op rename or delete
2225
# If the op is delete, we need to clean up the object; otherwise,
2226
# we need to track the change.
2228
# NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete
2229
# traces aren't propagated correctly. Instead, they silently
2230
# vanish. Add a catch to output any error message.
2232
proc ::snit::RT.InstanceTrace {type selfns win old new op} {
2233
variable ${type}::Snit_info
2235
# Note to developers ...
2236
# For Tcl 8.4.0, errors thrown in trace handlers vanish silently.
2237
# Therefore we catch them here and create some output to help in
2238
# debugging such problems.
2241
# FIRST, clean up if necessary
2243
if {$Snit_info(isWidget)} {
2246
::snit::RT.DestroyObject $type $selfns $win
2249
# Otherwise, track the change.
2250
variable ${selfns}::Snit_instance
2251
set Snit_instance [uplevel namespace which -command $new]
2253
# Also, clear the instance caches, as many cached commands
2255
RT.ClearInstanceCaches $selfns
2259
# Pop up the console on Windows wish, to enable stdout.
2260
# This clobbers errorInfo on unix, so save it so we can print it.
2262
catch {console show}
2263
puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:"
2268
# Calls the instance constructor and handles related housekeeping.
2269
proc ::snit::RT.ConstructInstance {type selfns instance arglist} {
2270
variable ${type}::Snit_optionInfo
2271
variable ${selfns}::Snit_iinfo
2273
# Track whether we are constructed or not.
2274
set Snit_iinfo(constructed) 0
2276
# Call the user's constructor
2277
eval [linsert $arglist 0 \
2278
${type}::Snit_constructor $type $selfns $instance $instance]
2280
set Snit_iinfo(constructed) 1
2282
# Unset the configure cache for all -readonly options.
2283
# This ensures that the next time anyone tries to
2284
# configure it, an error is thrown.
2285
foreach opt $Snit_optionInfo(local) {
2286
if {$Snit_optionInfo(readonly-$opt)} {
2287
catch { unset ${selfns}::Snit_configureCache($opt) }
2294
# Returns a unique command name.
2296
# REQUIRE: type is a fully qualified name.
2297
# REQUIRE: name contains "%AUTO%"
2298
# PROMISE: the returned command name is unused.
2299
proc ::snit::RT.UniqueName {countervar type name} {
2300
upvar $countervar counter
2302
# FIRST, bump the counter and define the %AUTO% instance name;
2303
# then substitute it into the specified name. Wrap around at
2304
# 2^31 - 2 to prevent overflow problems.
2306
if {$counter > 2147483646} {
2309
set auto "[namespace tail $type]$counter"
2310
set candidate [Expand $name %AUTO% $auto]
2311
if {[info commands $candidate] == ""} {
2317
# Returns a unique instance namespace, fully qualified.
2319
# countervar The name of a counter variable
2320
# type The instance's type
2322
# REQUIRE: type is fully qualified
2323
# PROMISE: The returned namespace name is unused.
2325
proc ::snit::RT.UniqueInstanceNamespace {countervar type} {
2326
upvar $countervar counter
2328
# FIRST, bump the counter and define the namespace name.
2329
# Then see if it already exists. Wrap around at
2330
# 2^31 - 2 to prevent overflow problems.
2332
if {$counter > 2147483646} {
2335
set ins "${type}::Snit_inst${counter}"
2336
#namespace exists command doesnt exist in tcl 8.3
2337
#therefore just removing and hoping that this will never fail
2338
#if {![namespace exists $ins]} {
2344
# Retrieves an option's value from the option database.
2345
# Returns "" if no value is found.
2346
proc ::snit::RT.OptionDbGet {type self opt} {
2347
variable ${type}::Snit_optionInfo
2349
return [option get $self \
2350
$Snit_optionInfo(resource-$opt) \
2351
$Snit_optionInfo(class-$opt)]
2354
#-----------------------------------------------------------------------
2355
# Object Destruction
2357
# Implements the standard "destroy" method
2359
# type The snit type
2360
# selfns The instance's instance namespace
2361
# win The instance's original name
2362
# self The instance's current name
2364
proc ::snit::RT.method.destroy {type selfns win self} {
2365
# Calls Snit_cleanup, which (among other things) calls the
2366
# user's destructor.
2367
::snit::RT.DestroyObject $type $selfns $win
2370
# This is the function that really cleans up; it's automatically
2371
# called when any instance is destroyed, e.g., by "$object destroy"
2372
# for types, and by the <Destroy> event for widgets.
2374
# type The fully-qualified type name.
2375
# selfns The instance namespace
2376
# win The original instance command name.
2378
proc ::snit::RT.DestroyObject {type selfns win} {
2379
variable ${type}::Snit_info
2381
# If the variable Snit_instance doesn't exist then there's no
2382
# instance command for this object -- it's most likely a
2383
# widgetadaptor. Consequently, there are some things that
2384
# we don't need to do.
2385
if {[info exists ${selfns}::Snit_instance]} {
2386
upvar ${selfns}::Snit_instance instance
2388
# First, remove the trace on the instance name, so that we
2389
# don't call RT.DestroyObject recursively.
2390
RT.RemoveInstanceTrace $type $selfns $win $instance
2392
# Next, call the user's destructor
2393
${type}::Snit_destructor $type $selfns $win $instance
2395
# Next, if this isn't a widget, delete the instance command.
2396
# If it is a widget, get the hull component's name, and rename
2397
# it back to the widget name
2399
# Next, delete the hull component's instance command,
2401
if {$Snit_info(isWidget)} {
2402
set hullcmd [::snit::RT.Component $type $selfns hull]
2404
catch {rename $instance ""}
2406
# Clear the bind event
2407
bind Snit$type$win <Destroy> ""
2409
if {[info command $hullcmd] != ""} {
2410
rename $hullcmd ::$instance
2413
catch {rename $instance ""}
2417
# Next, delete the instance's namespace. This kills any
2418
# instance variables.
2419
namespace delete $selfns
2422
# Remove instance trace
2424
# type The fully qualified type name
2425
# selfns The instance namespace
2426
# win The original instance name/Tk window name
2427
# instance The current instance name
2429
proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} {
2430
variable ${type}::Snit_info
2432
if {$Snit_info(isWidget)} {
2433
set procname ::$instance
2435
set procname $instance
2438
# NEXT, remove any trace on this name
2440
# trace remove command $procname {rename delete} \
2441
# [list ::snit::RT.InstanceTrace $type $selfns $win]
2445
#-----------------------------------------------------------------------
2446
# Typecomponent Management and Method Caching
2448
# Typecomponent trace; used for write trace on typecomponent
2449
# variables. Saves the new component object name, provided
2450
# that certain conditions are met. Also clears the typemethod
2453
proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} {
2454
upvar ${type}::Snit_info Snit_info
2455
upvar ${type}::${component} cvar
2456
upvar ${type}::Snit_typecomponents Snit_typecomponents
2458
# Save the new component value.
2459
set Snit_typecomponents($component) $cvar
2461
# Clear the typemethod cache.
2462
# TBD: can we unset just the elements related to
2464
catch { unset ${type}::Snit_typemethodCache }
2467
# Generates and caches the command for a typemethod.
2470
# method The name of the typemethod to call.
2472
# The return value is one of the following lists:
2474
# {} There's no such method.
2475
# {1} The method has submethods; look again.
2476
# {0 <command>} Here's the command to execute.
2478
proc snit::RT.CacheTypemethodCommand {type method} {
2479
upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
2480
upvar ${type}::Snit_typecomponents Snit_typecomponents
2481
upvar ${type}::Snit_typemethodCache Snit_typemethodCache
2482
upvar ${type}::Snit_info Snit_info
2484
# FIRST, get the pattern data and the typecomponent name.
2485
set implicitCreate 0
2488
set starredMethod [lreplace $method end end *]
2489
set methodTail [lindex $method end]
2491
if {[info exists Snit_typemethodInfo($method)]} {
2493
} elseif {[info exists Snit_typemethodInfo($starredMethod)]} {
2494
if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} {
2495
set key $starredMethod
2499
} elseif {$Snit_info(hasinstances)} {
2500
# Assume the unknown name is an instance name to create, unless
2501
# this is a widget and the style of the name is wrong, or the
2502
# name mimics a standard typemethod.
2504
if {[set ${type}::Snit_info(isWidget)] &&
2505
![string match ".*" $method]} {
2509
# Without this check, the call "$type info" will redefine the
2510
# standard "::info" command, with disastrous results. Since it's
2511
# a likely thing to do if !-typeinfo, put in an explicit check.
2512
if {$method == "info" || $method == "destroy"} {
2516
set implicitCreate 1
2517
set instanceName $method
2524
foreach {flag pattern compName} $Snit_typemethodInfo($key) {}
2530
# NEXT, build the substitution list
2535
%m [lindex $method end] \
2536
%j [join $method _]]
2538
if {$compName != ""} {
2539
if {![info exists Snit_typecomponents($compName)]} {
2540
error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\""
2543
lappend subList %c [list $Snit_typecomponents($compName)]
2548
foreach subpattern $pattern {
2549
lappend command [string map $subList $subpattern]
2552
if {$implicitCreate} {
2553
# In this case, $method is the name of the instance to
2554
# create. Don't cache, as we usually won't do this one
2556
lappend command $instanceName
2558
set Snit_typemethodCache($method) [list 0 $command]
2561
return [list 0 $command]
2565
#-----------------------------------------------------------------------
2566
# Component Management and Method Caching
2568
# Retrieves the object name given the component name.
2569
proc ::snit::RT.Component {type selfns name} {
2570
variable ${selfns}::Snit_components
2572
if {[catch {set Snit_components($name)} result]} {
2573
variable ${selfns}::Snit_instance
2575
error "component \"$name\" is undefined in $type $Snit_instance"
2581
# Component trace; used for write trace on component instance
2582
# variables. Saves the new component object name, provided
2583
# that certain conditions are met. Also clears the method
2586
proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} {
2587
upvar ${type}::Snit_info Snit_info
2588
upvar ${selfns}::${component} cvar
2589
upvar ${selfns}::Snit_components Snit_components
2591
# If they try to redefine the hull component after
2592
# it's been defined, that's an error--but only if
2593
# this is a widget or widget adaptor.
2594
if {"hull" == $component &&
2595
$Snit_info(isWidget) &&
2596
[info exists Snit_components($component)]} {
2597
set cvar $Snit_components($component)
2598
error "The hull component cannot be redefined"
2601
# Save the new component value.
2602
set Snit_components($component) $cvar
2604
# Clear the instance caches.
2605
# TBD: can we unset just the elements related to
2607
RT.ClearInstanceCaches $selfns
2610
# Generates and caches the command for a method.
2612
# type: The instance's type
2613
# selfns: The instance's private namespace
2614
# win: The instance's original name (a Tk widget name, for
2616
# self: The instance's current name.
2617
# method: The name of the method to call.
2619
# The return value is one of the following lists:
2621
# {} There's no such method.
2622
# {1} The method has submethods; look again.
2623
# {0 <command>} Here's the command to execute.
2625
proc ::snit::RT.CacheMethodCommand {type selfns win self method} {
2626
variable ${type}::Snit_info
2627
variable ${type}::Snit_methodInfo
2628
variable ${type}::Snit_typecomponents
2629
variable ${selfns}::Snit_components
2630
variable ${selfns}::Snit_methodCache
2632
# FIRST, get the pattern data and the component name.
2633
set starredMethod [lreplace $method end end *]
2634
set methodTail [lindex $method end]
2636
if {[info exists Snit_methodInfo($method)]} {
2638
} elseif {[info exists Snit_methodInfo($starredMethod)] &&
2639
[lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} {
2640
set key $starredMethod
2645
foreach {flag pattern compName} $Snit_methodInfo($key) {}
2651
# NEXT, build the substitution list
2656
%m [lindex $method end] \
2657
%j [join $method _] \
2662
if {$compName != ""} {
2663
if {[info exists Snit_components($compName)]} {
2664
set compCmd $Snit_components($compName)
2665
} elseif {[info exists Snit_typecomponents($compName)]} {
2666
set compCmd $Snit_typecomponents($compName)
2668
error "$type $self delegates method \"$method\" to undefined component \"$compName\""
2671
lappend subList %c [list $compCmd]
2674
# Note: The cached command will executed faster if it's
2678
foreach subpattern $pattern {
2679
lappend command [string map $subList $subpattern]
2682
set commandRec [list 0 $command]
2684
set Snit_methodCache($method) $commandRec
2690
# Looks up a method's command.
2692
# type: The instance's type
2693
# selfns: The instance's private namespace
2694
# win: The instance's original name (a Tk widget name, for
2696
# self: The instance's current name.
2697
# method: The name of the method to call.
2698
# errPrefix: Prefix for any error method
2699
proc ::snit::RT.LookupMethodCommand {type selfns win self method errPrefix} {
2700
set commandRec [snit::RT.CacheMethodCommand \
2701
$type $selfns $win $self \
2705
if {[llength $commandRec] == 0} {
2706
return -code error \
2707
"$errPrefix, \"$self $method\" is not defined"
2708
} elseif {[lindex $commandRec 0] == 1} {
2709
return -code error \
2710
"$errPrefix, wrong number args: should be \"$self\" $method method args"
2713
return [lindex $commandRec 1]
2717
# Clears all instance command caches
2718
proc ::snit::RT.ClearInstanceCaches {selfns} {
2719
catch { unset ${selfns}::Snit_methodCache }
2720
catch { unset ${selfns}::Snit_cgetCache }
2721
catch { unset ${selfns}::Snit_configureCache }
2722
catch { unset ${selfns}::Snit_validateCache }
2726
#-----------------------------------------------------------------------
2727
# Component Installation
2729
# Implements %TYPE%::installhull. The variables self and selfns
2730
# must be defined in the caller's context.
2732
# Installs the named widget as the hull of a
2733
# widgetadaptor. Once the widget is hijacked, its new name
2734
# is assigned to the hull component.
2736
proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} {
2737
variable ${type}::Snit_info
2738
variable ${type}::Snit_optionInfo
2741
upvar ${selfns}::hull hull
2742
upvar ${selfns}::options options
2744
# FIRST, make sure we can do it.
2745
if {!$Snit_info(isWidget)} {
2746
error "installhull is valid only for snit::widgetadaptors"
2749
if {[info exists ${selfns}::Snit_instance]} {
2750
error "hull already installed for $type $self"
2753
# NEXT, has it been created yet? If not, create it using
2754
# the specified arguments.
2755
if {"using" == $using} {
2756
# FIRST, create the widget
2757
set cmd [concat [list $widgetType $self] $args]
2758
set obj [uplevel 1 $cmd]
2760
# NEXT, for each option explicitly delegated to the hull
2761
# that doesn't appear in the usedOpts list, get the
2762
# option database value and apply it--provided that the
2763
# real option name and the target option name are different.
2764
# (If they are the same, then the option database was
2765
# already queried as part of the normal widget creation.)
2767
# Also, we don't need to worry about implicitly delegated
2768
# options, as the option and target option names must be
2770
if {[info exists Snit_optionInfo(delegated-hull)]} {
2772
# FIRST, extract all option names from args
2774
set ndx [lsearch -glob $args "-*"]
2775
foreach {opt val} [lrange $args $ndx end] {
2776
lappend usedOpts $opt
2779
foreach opt $Snit_optionInfo(delegated-hull) {
2780
set target [lindex $Snit_optionInfo(target-$opt) 1]
2782
if {"$target" == $opt} {
2786
set result [lsearch -exact $usedOpts $target]
2788
if {$result != -1} {
2792
set dbval [RT.OptionDbGet $type $self $opt]
2793
$obj configure $target $dbval
2799
if {![string equal $obj $self]} {
2801
"hull name mismatch: \"$obj\" != \"$self\""
2805
# NEXT, get the local option defaults.
2806
foreach opt $Snit_optionInfo(local) {
2807
set dbval [RT.OptionDbGet $type $self $opt]
2810
set options($opt) $dbval
2815
# NEXT, do the magic
2819
set newName "::hull${i}$self"
2820
if {"" == [info commands $newName]} {
2825
rename ::$self $newName
2826
RT.MakeInstanceCommand $type $selfns $self
2828
# Note: this relies on RT.ComponentTrace to do the dirty work.
2834
# Implements %TYPE%::install.
2836
# Creates a widget and installs it as the named component.
2837
# It expects self and selfns to be defined in the caller's context.
2839
proc ::snit::RT.install {type compName "using" widgetType winPath args} {
2840
variable ${type}::Snit_optionInfo
2841
variable ${type}::Snit_info
2844
upvar ${selfns}::$compName comp
2845
upvar ${selfns}::hull hull
2847
# We do the magic option database stuff only if $self is
2849
if {$Snit_info(isWidget)} {
2851
error "tried to install \"$compName\" before the hull exists"
2854
# FIRST, query the option database and save the results
2855
# into args. Insert them before the first option in the
2856
# list, in case there are any non-standard parameters.
2858
# Note: there might not be any delegated options; if so,
2861
if {[info exists Snit_optionInfo(delegated-$compName)]} {
2862
set ndx [lsearch -glob $args "-*"]
2864
foreach opt $Snit_optionInfo(delegated-$compName) {
2865
set dbval [RT.OptionDbGet $type $self $opt]
2868
set target [lindex $Snit_optionInfo(target-$opt) 1]
2869
set args [linsert $args $ndx $target $dbval]
2875
# NEXT, create the component and save it.
2876
set cmd [concat [list $widgetType $winPath] $args]
2877
catch { set comp [uplevel 1 $cmd] }
2879
# NEXT, handle the option database for "delegate option *",
2881
if {$Snit_info(isWidget) && $Snit_optionInfo(starcomp) == $compName} {
2882
# FIRST, get the list of option specs from the widget.
2883
# If configure doesn't work, skip it.
2884
if {[catch {$comp configure} specs]} {
2888
# NEXT, get the set of explicitly used options from args
2890
set ndx [lsearch -glob $args "-*"]
2891
foreach {opt val} [lrange $args $ndx end] {
2892
lappend usedOpts $opt
2895
# NEXT, "delegate option *" matches all options defined
2896
# by this widget that aren't defined by the widget as a whole,
2897
# and that aren't excepted. Plus, we skip usedOpts. So build
2898
# a list of the options it can't match.
2899
set skiplist [concat \
2901
$Snit_optionInfo(except) \
2902
$Snit_optionInfo(local) \
2903
$Snit_optionInfo(delegated)]
2905
# NEXT, loop over all of the component's options, and set
2906
# any not in the skip list for which there is an option
2908
foreach spec $specs {
2910
if {[llength $spec] != 5} {
2914
set opt [lindex $spec 0]
2916
if {[lsearch -exact $skiplist $opt] != -1} {
2920
set res [lindex $spec 1]
2921
set cls [lindex $spec 2]
2923
set dbvalue [option get $self $res $cls]
2925
if {"" != $dbvalue} {
2926
$comp configure $opt $dbvalue
2935
#-----------------------------------------------------------------------
2936
# Method/Variable Name Qualification
2938
# Implements %TYPE%::variable. Requires selfns.
2939
proc ::snit::RT.variable {varname} {
2942
if {![string match "::*" $varname]} {
2943
uplevel upvar ${selfns}::$varname $varname
2945
# varname is fully qualified; let the standard
2946
# "variable" command handle it.
2947
uplevel ::variable $varname
2951
# Fully qualifies a typevariable name.
2953
# This is used to implement the mytypevar command.
2955
proc ::snit::RT.mytypevar {type name} {
2956
return ${type}::$name
2959
# Fully qualifies an instance variable name.
2961
# This is used to implement the myvar command.
2962
proc ::snit::RT.myvar {name} {
2964
return ${selfns}::$name
2967
# Use this like "list" to convert a proc call into a command
2968
# string to pass to another object (e.g., as a -command).
2969
# Qualifies the proc name properly.
2971
# This is used to implement the "myproc" command.
2973
proc ::snit::RT.myproc {type procname args} {
2974
set procname "${type}::$procname"
2975
return [linsert $args 0 $procname]
2979
proc ::snit::RT.codename {type name} {
2980
return "${type}::$name"
2983
# Use this like "list" to convert a typemethod call into a command
2984
# string to pass to another object (e.g., as a -command).
2985
# Inserts the type command at the beginning.
2987
# This is used to implement the "mytypemethod" command.
2989
proc ::snit::RT.mytypemethod {type args} {
2990
return [linsert $args 0 $type]
2993
# Use this like "list" to convert a method call into a command
2994
# string to pass to another object (e.g., as a -command).
2995
# Inserts the code at the beginning to call the right object, even if
2996
# the object's name has changed. Requires that selfns be defined
2997
# in the calling context, eg. can only be called in instance
3000
# This is used to implement the "mymethod" command.
3002
proc ::snit::RT.mymethod {args} {
3004
return [linsert $args 0 ::snit::RT.CallInstance ${selfns}]
3007
# Calls an instance method for an object given its
3008
# instance namespace and remaining arguments (the first of which
3009
# will be the method name.
3011
# selfns The instance namespace
3012
# args The arguments
3014
# Uses the selfns to determine $self, and calls the method
3015
# in the normal way.
3017
# This is used to implement the "mymethod" command.
3019
proc ::snit::RT.CallInstance {selfns args} {
3020
upvar ${selfns}::Snit_instance self
3022
set retval [catch {uplevel 1 [linsert $args 0 $self]} result]
3028
return -code error -errorinfo $errorInfo \
3029
-errorcode $errorCode $result
3031
return -code $retval $result
3038
# Looks for the named option in the named variable. If found,
3039
# it and its value are removed from the list, and the value
3040
# is returned. Otherwise, the default value is returned.
3041
# If the option is undelegated, it's own default value will be
3042
# used if none is specified.
3044
# Implements the "from" command.
3046
proc ::snit::RT.from {type argvName option {defvalue ""}} {
3047
variable ${type}::Snit_optionInfo
3048
upvar $argvName argv
3050
set ioption [lsearch -exact $argv $option]
3052
if {$ioption == -1} {
3053
if {"" == $defvalue &&
3054
[info exists Snit_optionInfo(default-$option)]} {
3055
return $Snit_optionInfo(default-$option)
3061
set ivalue [expr {$ioption + 1}]
3062
set value [lindex $argv $ivalue]
3064
set argv [lreplace $argv $ioption $ivalue]
3069
#-----------------------------------------------------------------------
3072
# Implements the standard "destroy" typemethod:
3073
# Destroys a type completely.
3075
# type The snit type
3077
proc ::snit::RT.typemethod.destroy {type} {
3078
variable ${type}::Snit_info
3080
# FIRST, destroy all instances
3081
foreach selfns [namespace children $type] {
3082
#namespace exists command doesnt exist
3083
#if {![namespace exists $selfns]} {
3086
upvar ${selfns}::Snit_instance obj
3088
if {$Snit_info(isWidget)} {
3091
if {"" != [info commands $obj]} {
3097
# NEXT, destroy the type's data.
3098
namespace delete $type
3100
# NEXT, get rid of the type command.
3106
#-----------------------------------------------------------------------
3109
# Implements the standard "cget" method
3111
# type The snit type
3112
# selfns The instance's instance namespace
3113
# win The instance's original name
3114
# self The instance's current name
3115
# option The name of the option
3117
proc ::snit::RT.method.cget {type selfns win self option} {
3118
if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} {
3119
set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option]
3121
if {[llength $command] == 0} {
3122
return -code error "unknown option \"$option\""
3129
# Retrieves and caches the command that implements "cget" for the
3132
# type The snit type
3133
# selfns The instance's instance namespace
3134
# win The instance's original name
3135
# self The instance's current name
3136
# option The name of the option
3138
proc ::snit::RT.CacheCgetCommand {type selfns win self option} {
3139
variable ${type}::Snit_optionInfo
3140
variable ${selfns}::Snit_cgetCache
3142
if {[info exists Snit_optionInfo(islocal-$option)]} {
3143
# We know the item; it's either local, or explicitly delegated.
3144
if {$Snit_optionInfo(islocal-$option)} {
3145
# It's a local option. If it has a cget method defined,
3146
# use it; otherwise just return the value.
3148
if {$Snit_optionInfo(cget-$option) == ""} {
3149
set command [list set ${selfns}::options($option)]
3151
set command [snit::RT.LookupMethodCommand \
3152
$type $selfns $win $self \
3153
$Snit_optionInfo(cget-$option) \
3154
"can't cget $option"]
3156
lappend command $option
3159
set Snit_cgetCache($option) $command
3163
# Explicitly delegated option; get target
3164
set comp [lindex $Snit_optionInfo(target-$option) 0]
3165
set target [lindex $Snit_optionInfo(target-$option) 1]
3166
} elseif {$Snit_optionInfo(starcomp) != "" &&
3167
[lsearch -exact $Snit_optionInfo(except) $option] == -1} {
3168
# Unknown option, but unknowns are delegated; get target.
3169
set comp $Snit_optionInfo(starcomp)
3175
# Get the component's object.
3176
set obj [RT.Component $type $selfns $comp]
3178
set command [list $obj cget $target]
3179
set Snit_cgetCache($option) $command
3184
# Implements the standard "configurelist" method
3186
# type The snit type
3187
# selfns The instance's instance namespace
3188
# win The instance's original name
3189
# self The instance's current name
3190
# optionlist A list of options and their values.
3192
proc ::snit::RT.method.configurelist {type selfns win self optionlist} {
3193
variable ${type}::Snit_optionInfo
3195
foreach {option value} $optionlist {
3196
# FIRST, get the configure command, caching it if need be.
3197
if {[catch {set ${selfns}::Snit_configureCache($option)} command]} {
3198
set command [snit::RT.CacheConfigureCommand \
3199
$type $selfns $win $self $option]
3201
if {[llength $command] == 0} {
3202
return -code error "unknown option \"$option\""
3206
# NEXT, the caching the configure command also cached the
3207
# validate command, if any. If we have one, run it.
3208
set valcommand [set ${selfns}::Snit_validateCache($option)]
3210
if {$valcommand != ""} {
3211
lappend valcommand $value
3212
uplevel 1 $valcommand
3215
# NEXT, configure the option with the value.
3216
lappend command $value
3223
# Retrieves and caches the command that stores the named option.
3224
# Also stores the command that validates the name option if any;
3225
# If none, the validate command is "", so that the cache is always
3228
# type The snit type
3229
# selfns The instance's instance namespace
3230
# win The instance's original name
3231
# self The instance's current name
3232
# option An option name
3234
proc ::snit::RT.CacheConfigureCommand {type selfns win self option} {
3235
variable ${type}::Snit_optionInfo
3236
variable ${selfns}::Snit_configureCache
3237
variable ${selfns}::Snit_validateCache
3239
if {[info exist Snit_optionInfo(islocal-$option)]} {
3240
# We know the item; it's either local, or explicitly delegated.
3242
if {$Snit_optionInfo(islocal-$option)} {
3243
# It's a local option.
3245
# If it's readonly, it throws an error if we're already
3247
if {$Snit_optionInfo(readonly-$option)} {
3248
if {[set ${selfns}::Snit_iinfo(constructed)]} {
3249
error "option $option can only be set at instance creation"
3253
# If it has a validate method, cache that for later.
3254
if {$Snit_optionInfo(validate-$option) != ""} {
3255
set command [snit::RT.LookupMethodCommand \
3256
$type $selfns $win $self \
3257
$Snit_optionInfo(validate-$option) \
3258
"can't validate $option"]
3260
lappend command $option
3261
set Snit_validateCache($option) $command
3263
set Snit_validateCache($option) ""
3266
# If it has a configure method defined,
3267
# cache it; otherwise, just set the value.
3269
if {$Snit_optionInfo(configure-$option) == ""} {
3270
set command [list set ${selfns}::options($option)]
3272
set command [snit::RT.LookupMethodCommand \
3273
$type $selfns $win $self \
3274
$Snit_optionInfo(configure-$option) \
3275
"can't configure $option"]
3277
lappend command $option
3280
set Snit_configureCache($option) $command
3284
# Delegated option: get target.
3285
set comp [lindex $Snit_optionInfo(target-$option) 0]
3286
set target [lindex $Snit_optionInfo(target-$option) 1]
3287
} elseif {$Snit_optionInfo(starcomp) != "" &&
3288
[lsearch -exact $Snit_optionInfo(except) $option] == -1} {
3289
# Unknown option, but unknowns are delegated.
3290
set comp $Snit_optionInfo(starcomp)
3296
# There is no validate command in this case; save an empty string.
3297
set Snit_validateCache($option) ""
3299
# Get the component's object
3300
set obj [RT.Component $type $selfns $comp]
3302
set command [list $obj configure $target]
3303
set Snit_configureCache($option) $command
3308
# Implements the standard "configure" method
3310
# type The snit type
3311
# selfns The instance's instance namespace
3312
# win The instance's original name
3313
# self The instance's current name
3314
# args A list of options and their values, possibly empty.
3316
proc ::snit::RT.method.configure {type selfns win self args} {
3317
# If two or more arguments, set values as usual.
3318
if {[llength $args] >= 2} {
3319
::snit::RT.method.configurelist $type $selfns $win $self $args
3323
# If zero arguments, acquire data for each known option
3324
# and return the list
3325
if {[llength $args] == 0} {
3327
foreach opt [RT.method.info.options $type $selfns $win $self] {
3328
# Refactor this, so that we don't need to call via $self.
3329
lappend result [RT.GetOptionDbSpec \
3330
$type $selfns $win $self $opt]
3336
# They want it for just one.
3337
set opt [lindex $args 0]
3339
return [RT.GetOptionDbSpec $type $selfns $win $self $opt]
3343
# Retrieves the option database spec for a single option.
3345
# type The snit type
3346
# selfns The instance's instance namespace
3347
# win The instance's original name
3348
# self The instance's current name
3349
# option The name of an option
3351
# TBD: This is a bad name. What it's returning is the
3352
# result of the configure query.
3354
proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} {
3355
variable ${type}::Snit_optionInfo
3357
upvar ${selfns}::Snit_components Snit_components
3358
upvar ${selfns}::options options
3360
if {[info exists options($opt)]} {
3361
# This is a locally-defined option. Just build the
3362
# list and return it.
3363
set res $Snit_optionInfo(resource-$opt)
3364
set cls $Snit_optionInfo(class-$opt)
3365
set def $Snit_optionInfo(default-$opt)
3367
return [list $opt $res $cls $def \
3368
[RT.method.cget $type $selfns $win $self $opt]]
3369
} elseif {[info exists Snit_optionInfo(target-$opt)]} {
3370
# This is an explicitly delegated option. The only
3371
# thing we don't have is the default.
3372
set res $Snit_optionInfo(resource-$opt)
3373
set cls $Snit_optionInfo(class-$opt)
3376
set logicalName [lindex $Snit_optionInfo(target-$opt) 0]
3377
set comp $Snit_components($logicalName)
3378
set target [lindex $Snit_optionInfo(target-$opt) 1]
3380
if {[catch {$comp configure $target} result]} {
3383
set defValue [lindex $result 3]
3386
return [list $opt $res $cls $defValue [$self cget $opt]]
3387
} elseif {$Snit_optionInfo(starcomp) != "" &&
3388
[lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
3389
set logicalName $Snit_optionInfo(starcomp)
3391
set comp $Snit_components($logicalName)
3393
if {[catch {set value [$comp cget $target]} result]} {
3394
error "unknown option \"$opt\""
3397
if {![catch {$comp configure $target} result]} {
3398
# Replace the delegated option name with the local name.
3399
return [::snit::Expand $result $target $opt]
3402
# configure didn't work; return simple form.
3403
return [list $opt "" "" "" $value]
3405
error "unknown option \"$opt\""
3409
#-----------------------------------------------------------------------
3410
# Type Introspection
3412
# Implements the standard "info" typemethod.
3414
# type The snit type
3415
# command The info subcommand
3416
# args All other arguments.
3418
proc ::snit::RT.typemethod.info {type command args} {
3422
switch -exact $command {
3426
# TBD: it should be possible to delete this error
3428
set errflag [catch {
3429
uplevel ::snit::RT.typemethod.info.$command \
3434
return -code error -errorinfo $errorInfo \
3435
-errorcode $errorCode $result
3441
error "\"$type info $command\" is not defined"
3447
# Returns a list of the type's typevariables whose names match a
3448
# pattern, excluding Snit internal variables.
3451
# pattern Optional. The glob pattern to match. Defaults
3454
proc ::snit::RT.typemethod.info.typevars {type {pattern *}} {
3456
foreach name [info vars "${type}::$pattern"] {
3457
set tail [namespace tail $name]
3458
if {![string match "Snit_*" $tail]} {
3459
lappend result $name
3466
# Returns a list of the type's methods whose names match a
3467
# pattern. If "delegate typemethod *" is used, the list may
3471
# pattern Optional. The glob pattern to match. Defaults
3474
proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} {
3475
variable ${type}::Snit_typemethodInfo
3476
variable ${type}::Snit_typemethodCache
3478
# FIRST, get the explicit names, skipping prefixes.
3481
foreach name [array names Snit_typemethodInfo -glob $pattern] {
3482
if {[lindex $Snit_typemethodInfo($name) 0] != 1} {
3483
lappend result $name
3487
# NEXT, add any from the cache that aren't explicit.
3488
if {[info exists Snit_typemethodInfo(*)]} {
3489
# First, remove "*" from the list.
3490
set ndx [lsearch -exact $result "*"]
3492
set result [lreplace $result $ndx $ndx]
3495
foreach name [array names Snit_typemethodCache -glob $pattern] {
3496
if {[lsearch -exact $result $name] == -1} {
3497
lappend result $name
3505
# Returns a list of the type's instances whose names match
3509
# pattern Optional. The glob pattern to match
3512
# REQUIRE: type is fully qualified.
3514
proc ::snit::RT.typemethod.info.instances {type {pattern *}} {
3517
foreach selfns [namespace children $type] {
3518
upvar ${selfns}::Snit_instance instance
3520
if {[string match $pattern $instance]} {
3521
lappend result $instance
3528
#-----------------------------------------------------------------------
3529
# Instance Introspection
3531
# Implements the standard "info" method.
3533
# type The snit type
3534
# selfns The instance's instance namespace
3535
# win The instance's original name
3536
# self The instance's current name
3537
# command The info subcommand
3538
# args All other arguments.
3540
proc ::snit::RT.method.info {type selfns win self command args} {
3541
switch -exact $command {
3548
set errflag [catch {
3549
uplevel ::snit::RT.method.info.$command \
3550
$type $selfns $win $self $args
3555
return -code error -errorinfo $errorInfo $result
3561
# error "\"$self info $command\" is not defined"
3562
return -code error "\"$self info $command\" is not defined"
3569
# Returns the instance's type
3570
proc ::snit::RT.method.info.type {type selfns win self} {
3574
# $self info typevars
3576
# Returns the instance's type's typevariables
3577
proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} {
3578
return [RT.typemethod.info.typevars $type $pattern]
3581
# $self info typemethods
3583
# Returns the instance's type's typemethods
3584
proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} {
3585
return [RT.typemethod.info.typemethods $type $pattern]
3588
# Returns a list of the instance's methods whose names match a
3589
# pattern. If "delegate method *" is used, the list may
3593
# selfns The instance namespace
3594
# win The original instance name
3595
# self The current instance name
3596
# pattern Optional. The glob pattern to match. Defaults
3599
proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} {
3600
variable ${type}::Snit_methodInfo
3601
variable ${selfns}::Snit_methodCache
3603
# FIRST, get the explicit names, skipping prefixes.
3606
foreach name [array names Snit_methodInfo -glob $pattern] {
3607
if {[lindex $Snit_methodInfo($name) 0] != 1} {
3608
lappend result $name
3612
# NEXT, add any from the cache that aren't explicit.
3613
if {[info exists Snit_methodInfo(*)]} {
3614
# First, remove "*" from the list.
3615
set ndx [lsearch -exact $result "*"]
3617
set result [lreplace $result $ndx $ndx]
3620
foreach name [array names Snit_methodCache -glob $pattern] {
3621
if {[lsearch -exact $result $name] == -1} {
3622
lappend result $name
3632
# Returns the instance's instance variables
3633
proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} {
3635
foreach name [info vars "${selfns}::$pattern"] {
3636
set tail [namespace tail $name]
3637
if {![string match "Snit_*" $tail]} {
3638
lappend result $name
3645
# $self info options
3647
# Returns a list of the names of the instance's options
3648
proc ::snit::RT.method.info.options {type selfns win self {pattern *}} {
3649
variable ${type}::Snit_optionInfo
3651
# First, get the local and explicitly delegated options
3652
set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)]
3654
# If "configure" works as for Tk widgets, add the resulting
3655
# options to the list. Skip excepted options
3656
if {$Snit_optionInfo(starcomp) != ""} {
3657
upvar ${selfns}::Snit_components Snit_components
3658
set logicalName $Snit_optionInfo(starcomp)
3659
set comp $Snit_components($logicalName)
3661
if {![catch {$comp configure} records]} {
3662
foreach record $records {
3663
set opt [lindex $record 0]
3664
if {[lsearch -exact $result $opt] == -1 &&
3665
[lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
3672
# Next, apply the pattern
3675
foreach name $result {
3676
if {[string match $pattern $name]} {