snit/main2.tcl

   1 #-----------------------------------------------------------------------
   2 # TITLE:
   3 #       main2.tcl
   4 #
   5 # AUTHOR:
   6 #       Will Duquette
   7 #
   8 # DESCRIPTION:
   9 #       Snit's Not Incr Tcl, a simple object system in Pure Tcl.
  10 #
  11 #       Snit 2.x Compiler and Run-Time Library
  12 #
  13 #       Copyright (C) 2003-2006 by William H. Duquette
  14 #       This code is licensed as described in license.txt.
  15 #
  16 #-----------------------------------------------------------------------
  17
  18 #-----------------------------------------------------------------------
  19 # Namespace
  20
  21 namespace eval ::snit:: {
  22     namespace export \
  23         compile type widget widgetadaptor typemethod method macro
  24 }
  25
  26 #-----------------------------------------------------------------------
  27 # Some Snit variables
  28
  29 namespace eval ::snit:: {
  30     variable reservedArgs {type selfns win self}
  31
  32     # Widget classes which can be hulls (must have -class)
  33     variable hulltypes {
  34         toplevel tk::toplevel
  35         frame tk::frame ttk::frame
  36         labelframe tk::labelframe ttk::labelframe
  37     }
  38 }
  39
  40 #-----------------------------------------------------------------------
  41 # Snit Type Implementation template
  42
  43 namespace eval ::snit:: {
  44     # Template type definition: All internal and user-visible Snit
  45     # implementation code.
  46     #
  47     # The following placeholders will automatically be replaced with
  48     # the client's code, in two passes:
  49     #
  50     # First pass:
  51     # %COMPILEDDEFS%  The compiled type definition.
  52     #
  53     # Second pass:
  54     # %TYPE%          The fully qualified type name.
  55     # %IVARDECS%      Instance variable declarations
  56     # %TVARDECS%      Type variable declarations
  57     # %TCONSTBODY%    Type constructor body
  58     # %INSTANCEVARS%  The compiled instance variable initialization code.
  59     # %TYPEVARS%      The compiled type variable initialization code.
  60
  61     # This is the overall type template.
  62     variable typeTemplate
  63
  64     # This is the normal type proc
  65     variable nominalTypeProc
  66
  67     # This is the "-hastypemethods no" type proc
  68     variable simpleTypeProc
  69 }
  70
  71 set ::snit::typeTemplate {
  72
  73     #-------------------------------------------------------------------
  74     # The type's namespace definition and the user's type variables
  75
  76     namespace eval %TYPE% {%TYPEVARS%
  77     }
  78
  79     #----------------------------------------------------------------
  80     # Commands for use in methods, typemethods, etc.
  81     #
  82     # These are implemented as aliases into the Snit runtime library.
  83
  84     interp alias {} %TYPE%::installhull  {} ::snit::RT.installhull %TYPE%
  85     interp alias {} %TYPE%::install      {} ::snit::RT.install %TYPE%
  86     interp alias {} %TYPE%::typevariable {} ::variable
  87     interp alias {} %TYPE%::variable     {} ::snit::RT.variable
  88     interp alias {} %TYPE%::mytypevar    {} ::snit::RT.mytypevar %TYPE%
  89     interp alias {} %TYPE%::typevarname  {} ::snit::RT.mytypevar %TYPE%
  90     interp alias {} %TYPE%::myvar        {} ::snit::RT.myvar
  91     interp alias {} %TYPE%::varname      {} ::snit::RT.myvar
  92     interp alias {} %TYPE%::codename     {} ::snit::RT.codename %TYPE%
  93     interp alias {} %TYPE%::myproc       {} ::snit::RT.myproc %TYPE%
  94     interp alias {} %TYPE%::mymethod     {} ::snit::RT.mymethod
  95     interp alias {} %TYPE%::mytypemethod {} ::snit::RT.mytypemethod %TYPE%
  96     interp alias {} %TYPE%::from         {} ::snit::RT.from %TYPE%
  97
  98     #-------------------------------------------------------------------
  99     # Snit's internal variables
 100
 101     namespace eval %TYPE% {
 102         # Array: General Snit Info
 103         #
 104         # ns:                The type's namespace
 105         # hasinstances:      T or F, from pragma -hasinstances.
 106         # simpledispatch:    T or F, from pragma -hasinstances.
 107         # canreplace:        T or F, from pragma -canreplace.
 108         # counter:           Count of instances created so far.
 109         # widgetclass:       Set by widgetclass statement.
 110         # hulltype:          Hull type (frame or toplevel) for widgets only.
 111         # exceptmethods:     Methods explicitly not delegated to *
 112         # excepttypemethods: Methods explicitly not delegated to *
 113         # tvardecs:          Type variable declarations--for dynamic methods
 114         # ivardecs:          Instance variable declarations--for dyn. methods
 115         typevariable Snit_info
 116         set Snit_info(ns)      %TYPE%::
 117         set Snit_info(hasinstances) 1
 118         set Snit_info(simpledispatch) 0
 119         set Snit_info(canreplace) 0
 120         set Snit_info(counter) 0
 121         set Snit_info(widgetclass) {}
 122         set Snit_info(hulltype) frame
 123         set Snit_info(exceptmethods) {}
 124         set Snit_info(excepttypemethods) {}
 125         set Snit_info(tvardecs) {%TVARDECS%}
 126         set Snit_info(ivardecs) {%IVARDECS%}
 127
 128         # Array: Public methods of this type.
 129         # The index is the method name, or "*".
 130         # The value is [list $pattern $componentName], where
 131         # $componentName is "" for normal methods.
 132         typevariable Snit_typemethodInfo
 133         array unset Snit_typemethodInfo
 134
 135         # Array: Public methods of instances of this type.
 136         # The index is the method name, or "*".
 137         # The value is [list $pattern $componentName], where
 138         # $componentName is "" for normal methods.
 139         typevariable Snit_methodInfo
 140         array unset Snit_methodInfo
 141
 142         # Array: option information.  See dictionary.txt.
 143         typevariable Snit_optionInfo
 144         array unset Snit_optionInfo
 145         set Snit_optionInfo(local)     {}
 146         set Snit_optionInfo(delegated) {}
 147         set Snit_optionInfo(starcomp)  {}
 148         set Snit_optionInfo(except)    {}
 149     }
 150
 151     #----------------------------------------------------------------
 152     # Compiled Procs
 153     #
 154     # These commands are created or replaced during compilation:
 155
 156
 157     # Snit_instanceVars selfns
 158     #
 159     # Initializes the instance variables, if any.  Called during
 160     # instance creation.
 161
 162     proc %TYPE%::Snit_instanceVars {selfns} {
 163         %INSTANCEVARS%
 164     }
 165
 166     # Type Constructor
 167     proc %TYPE%::Snit_typeconstructor {type} {
 168         %TVARDECS%
 169         namespace path [namespace parent $type]
 170         %TCONSTBODY%
 171     }
 172
 173     #----------------------------------------------------------------
 174     # Default Procs
 175     #
 176     # These commands might be replaced during compilation:
 177
 178     # Snit_destructor type selfns win self
 179     #
 180     # Default destructor for the type.  By default, it does
 181     # nothing.  It's replaced by any user destructor.
 182     # For types, it's called by method destroy; for widgettypes,
 183     # it's called by a destroy event handler.
 184
 185     proc %TYPE%::Snit_destructor {type selfns win self} { }
 186
 187     #----------------------------------------------------------
 188     # Compiled Definitions
 189
 190     %COMPILEDDEFS%
 191
 192     #----------------------------------------------------------
 193     # Finally, call the Type Constructor
 194
 195     %TYPE%::Snit_typeconstructor %TYPE%
 196 }
 197
 198 #-----------------------------------------------------------------------
 199 # Type procs
 200 #
 201 # These procs expect the fully-qualified type name to be
 202 # substituted in for %TYPE%.
 203
 204 # This is the nominal type proc.  It supports typemethods and
 205 # delegated typemethods.
 206 set ::snit::nominalTypeProc {
 207     # WHD: Code for creating the type ensemble
 208     namespace eval %TYPE% {
 209         namespace ensemble create \
 210             -unknown [list ::snit::RT.UnknownTypemethod %TYPE% ""] \
 211             -prefixes 0
 212     }
 213 }
 214
 215 # This is the simplified type proc for when there are no typemethods
 216 # except create.  In this case, it doesn't take a method argument;
 217 # the method is always "create".
 218 set ::snit::simpleTypeProc {
 219     # Type dispatcher function.  Note: This function lives
 220     # in the parent of the %TYPE% namespace!  All accesses to
 221     # %TYPE% variables and methods must be qualified!
 222     proc %TYPE% {args} {
 223         ::variable %TYPE%::Snit_info
 224
 225         # FIRST, if the are no args, the single arg is %AUTO%
 226         if {[llength $args] == 0} {
 227             if {$Snit_info(isWidget)} {
 228                 error "wrong \# args: should be \"%TYPE% name args\""
 229             }
 230
 231             lappend args %AUTO%
 232         }
 233
 234         # NEXT, we're going to call the create method.
 235         # Pass along the return code unchanged.
 236         if {$Snit_info(isWidget)} {
 237             set command [list ::snit::RT.widget.typemethod.create %TYPE%]
 238         } else {
 239             set command [list ::snit::RT.type.typemethod.create %TYPE%]
 240         }
 241
 242         set retval [catch {uplevel 1 $command $args} result]
 243
 244         if {$retval} {
 245             if {$retval == 1} {
 246                 global errorInfo
 247                 global errorCode
 248                 return -code error -errorinfo $errorInfo \
 249                     -errorcode $errorCode $result
 250             } else {
 251                 return -code $retval $result
 252             }
 253         }
 254
 255         return $result
 256     }
 257 }
 258
 259 #=======================================================================
 260 # Snit Type Definition
 261 #
 262 # These are the procs used to define Snit types, widgets, and
 263 # widgetadaptors.
 264
 265
 266 #-----------------------------------------------------------------------
 267 # Snit Compilation Variables
 268 #
 269 # The following variables are used while Snit is compiling a type,
 270 # and are disposed afterwards.
 271
 272 namespace eval ::snit:: {
 273     # The compiler variable contains the name of the slave interpreter
 274     # used to compile type definitions.
 275     variable compiler ""
 276
 277     # The compile array accumulates information about the type or
 278     # widgettype being compiled.  It is cleared before and after each
 279     # compilation.  It has these indices:
 280     #
 281     # type:                  The name of the type being compiled, for use
 282     #                        in compilation procs.
 283     # defs:                  Compiled definitions, both standard and client.
 284     # which:                 type, widget, widgetadaptor
 285     # instancevars:          Instance variable definitions and initializations.
 286     # ivprocdec:             Instance variable proc declarations.
 287     # tvprocdec:             Type variable proc declarations.
 288     # typeconstructor:       Type constructor body.
 289     # widgetclass:           The widgetclass, for snit::widgets, only
 290     # hasoptions:            False, initially; set to true when first
 291     #                        option is defined.
 292     # localoptions:          Names of local options.
 293     # delegatedoptions:      Names of delegated options.
 294     # localmethods:          Names of locally defined methods.
 295     # delegatesmethods:      no if no delegated methods, yes otherwise.
 296     # hashierarchic       :  no if no hierarchic methods, yes otherwise.
 297     # components:            Names of defined components.
 298     # typecomponents:        Names of defined typecomponents.
 299     # typevars:              Typevariable definitions and initializations.
 300     # varnames:              Names of instance variables
 301     # typevarnames           Names of type variables
 302     # hasconstructor         False, initially; true when constructor is
 303     #                        defined.
 304     # resource-$opt          The option's resource name
 305     # class-$opt             The option's class
 306     # -default-$opt          The option's default value
 307     # -validatemethod-$opt   The option's validate method
 308     # -configuremethod-$opt  The option's configure method
 309     # -cgetmethod-$opt       The option's cget method.
 310     # -hastypeinfo           The -hastypeinfo pragma
 311     # -hastypedestroy        The -hastypedestroy pragma
 312     # -hastypemethods        The -hastypemethods pragma
 313     # -hasinfo               The -hasinfo pragma
 314     # -hasinstances          The -hasinstances pragma
 315     # -simpledispatch        The -simpledispatch pragma WHD: OBSOLETE
 316     # -canreplace            The -canreplace pragma
 317     variable compile
 318
 319     # This variable accumulates method dispatch information; it has
 320     # the same structure as the %TYPE%::Snit_methodInfo array, and is
 321     # used to initialize it.
 322     variable methodInfo
 323
 324     # This variable accumulates typemethod dispatch information; it has
 325     # the same structure as the %TYPE%::Snit_typemethodInfo array, and is
 326     # used to initialize it.
 327     variable typemethodInfo
 328
 329     # The following variable lists the reserved type definition statement
 330     # names, e.g., the names you can't use as macros.  It's built at
 331     # compiler definition time using "info commands".
 332     variable reservedwords {}
 333 }
 334
 335 #-----------------------------------------------------------------------
 336 # type compilation commands
 337 #
 338 # The type and widgettype commands use a slave interpreter to compile
 339 # the type definition.  These are the procs
 340 # that are aliased into it.
 341
 342 # Initialize the compiler
 343 proc ::snit::Comp.Init {} {
 344     variable compiler
 345     variable reservedwords
 346
 347     if {$compiler eq ""} {
 348         # Create the compiler's interpreter
 349         set compiler [interp create]
 350
 351         # Initialize the interpreter
 352         $compiler eval {
 353             catch {close stdout}
 354             catch {close stderr}
 355             catch {close stdin}
 356
 357             # Load package information
 358             # TBD: see if this can be moved outside.
 359             # @mdgen NODEP: ::snit::__does_not_exist__
 360             catch {package require ::snit::__does_not_exist__}
 361
 362             # Protect some Tcl commands our type definitions
 363             # will shadow.
 364             rename proc _proc
 365             rename variable _variable
 366         }
 367
 368         # Define compilation aliases.
 369         $compiler alias pragma          ::snit::Comp.statement.pragma
 370         $compiler alias widgetclass     ::snit::Comp.statement.widgetclass
 371         $compiler alias hulltype        ::snit::Comp.statement.hulltype
 372         $compiler alias constructor     ::snit::Comp.statement.constructor
 373         $compiler alias destructor      ::snit::Comp.statement.destructor
 374         $compiler alias option          ::snit::Comp.statement.option
 375         $compiler alias oncget          ::snit::Comp.statement.oncget
 376         $compiler alias onconfigure     ::snit::Comp.statement.onconfigure
 377         $compiler alias method          ::snit::Comp.statement.method
 378         $compiler alias typemethod      ::snit::Comp.statement.typemethod
 379         $compiler alias typeconstructor ::snit::Comp.statement.typeconstructor
 380         $compiler alias proc            ::snit::Comp.statement.proc
 381         $compiler alias typevariable    ::snit::Comp.statement.typevariable
 382         $compiler alias variable        ::snit::Comp.statement.variable
 383         $compiler alias typecomponent   ::snit::Comp.statement.typecomponent
 384         $compiler alias component       ::snit::Comp.statement.component
 385         $compiler alias delegate        ::snit::Comp.statement.delegate
 386         $compiler alias expose          ::snit::Comp.statement.expose
 387
 388         # Get the list of reserved words
 389         set reservedwords [$compiler eval {info commands}]
 390     }
 391 }
 392
 393 # Compile a type definition, and return the results as a list of two
 394 # items: the fully-qualified type name, and a script that will define
 395 # the type when executed.
 396 #
 397 # which         type, widget, or widgetadaptor
 398 # type          the type name
 399 # body          the type definition
 400 proc ::snit::Comp.Compile {which type body} {
 401     variable typeTemplate
 402     variable nominalTypeProc
 403     variable simpleTypeProc
 404     variable compile
 405     variable compiler
 406     variable methodInfo
 407     variable typemethodInfo
 408
 409     # FIRST, qualify the name.
 410     if {![string match "::*" $type]} {
 411         # Get caller's namespace;
 412         # append :: if not global namespace.
 413         set ns [uplevel 2 [list namespace current]]
 414         if {"::" != $ns} {
 415             append ns "::"
 416         }
 417
 418         set type "$ns$type"
 419     }
 420
 421     # NEXT, create and initialize the compiler, if needed.
 422     Comp.Init
 423
 424     # NEXT, initialize the class data
 425     array unset methodInfo
 426     array unset typemethodInfo
 427
 428     array unset compile
 429     set compile(type) $type
 430     set compile(defs) {}
 431     set compile(which) $which
 432     set compile(hasoptions) no
 433     set compile(localoptions) {}
 434     set compile(instancevars) {}
 435     set compile(typevars) {}
 436     set compile(delegatedoptions) {}
 437     set compile(ivprocdec) {}
 438     set compile(tvprocdec) {}
 439     set compile(typeconstructor) {}
 440     set compile(widgetclass) {}
 441     set compile(hulltype) {}
 442     set compile(localmethods) {}
 443     set compile(delegatesmethods) no
 444     set compile(hashierarchic) no
 445     set compile(components) {}
 446     set compile(typecomponents) {}
 447     set compile(varnames) {}
 448     set compile(typevarnames) {}
 449     set compile(hasconstructor) no
 450     set compile(-hastypedestroy) yes
 451     set compile(-hastypeinfo) yes
 452     set compile(-hastypemethods) yes
 453     set compile(-hasinfo) yes
 454     set compile(-hasinstances) yes
 455     set compile(-canreplace) no
 456
 457     set isWidget [string match widget* $which]
 458     set isWidgetAdaptor [string match widgetadaptor $which]
 459
 460     # NEXT, Evaluate the type's definition in the class interpreter.
 461     $compiler eval $body
 462
 463     # NEXT, Add the standard definitions
 464     append compile(defs) \
 465         "\nset %TYPE%::Snit_info(isWidget) $isWidget\n"
 466
 467     append compile(defs) \
 468         "\nset %TYPE%::Snit_info(isWidgetAdaptor) $isWidgetAdaptor\n"
 469
 470     # Indicate whether the type can create instances that replace
 471     # existing commands.
 472     append compile(defs) "\nset %TYPE%::Snit_info(canreplace) $compile(-canreplace)\n"
 473
 474
 475     # Check pragmas for conflict.
 476
 477     if {!$compile(-hastypemethods) && !$compile(-hasinstances)} {
 478         error "$which $type has neither typemethods nor instances"
 479     }
 480
 481     # If there are typemethods, define the standard typemethods and
 482     # the nominal type proc.  Otherwise define the simple type proc.
 483     if {$compile(-hastypemethods)} {
 484         # Add the info typemethod unless the pragma forbids it.
 485         if {$compile(-hastypeinfo)} {
 486             Comp.statement.delegate typemethod info \
 487                 using {::snit::RT.typemethod.info %t}
 488         }
 489
 490         # Add the destroy typemethod unless the pragma forbids it.
 491         if {$compile(-hastypedestroy)} {
 492             Comp.statement.delegate typemethod destroy \
 493                 using {::snit::RT.typemethod.destroy %t}
 494         }
 495
 496         # Add the nominal type proc.
 497         append compile(defs) $nominalTypeProc
 498     } else {
 499         # Add the simple type proc.
 500         append compile(defs) $simpleTypeProc
 501     }
 502
 503     # Add standard methods/typemethods that only make sense if the
 504     # type has instances.
 505     if {$compile(-hasinstances)} {
 506         # Add the info method unless the pragma forbids it.
 507         if {$compile(-hasinfo)} {
 508             Comp.statement.delegate method info \
 509                 using {::snit::RT.method.info %t %n %w %s}
 510         }
 511
 512         # Add the option handling stuff if there are any options.
 513         if {$compile(hasoptions)} {
 514             Comp.statement.variable options
 515
 516             Comp.statement.delegate method cget \
 517                 using {::snit::RT.method.cget %t %n %w %s}
 518             Comp.statement.delegate method configurelist \
 519                 using {::snit::RT.method.configurelist %t %n %w %s}
 520             Comp.statement.delegate method configure \
 521                 using {::snit::RT.method.configure %t %n %w %s}
 522         }
 523
 524         # Add a default constructor, if they haven't already defined one.
 525         # If there are options, it will configure args; otherwise it
 526         # will do nothing.
 527         if {!$compile(hasconstructor)} {
 528             if {$compile(hasoptions)} {
 529                 Comp.statement.constructor {args} {
 530                     $self configurelist $args
 531                 }
 532             } else {
 533                 Comp.statement.constructor {} {}
 534             }
 535         }
 536
 537         if {!$isWidget} {
 538             Comp.statement.delegate method destroy \
 539                 using {::snit::RT.method.destroy %t %n %w %s}
 540
 541             Comp.statement.delegate typemethod create \
 542                 using {::snit::RT.type.typemethod.create %t}
 543         } else {
 544             Comp.statement.delegate typemethod create \
 545                 using {::snit::RT.widget.typemethod.create %t}
 546         }
 547
 548         # Save the method info.
 549         append compile(defs) \
 550             "\narray set %TYPE%::Snit_methodInfo [list [array get methodInfo]]\n"
 551     } else {
 552         append compile(defs) "\nset %TYPE%::Snit_info(hasinstances) 0\n"
 553     }
 554
 555     # NEXT, compiling the type definition built up a set of information
 556     # about the type's locally defined options; add this information to
 557     # the compiled definition.
 558     Comp.SaveOptionInfo
 559
 560     # NEXT, compiling the type definition built up a set of information
 561     # about the typemethods; save the typemethod info.
 562     append compile(defs) \
 563         "\narray set %TYPE%::Snit_typemethodInfo [list [array get typemethodInfo]]\n"
 564
 565     # NEXT, if this is a widget define the hull component if it isn't
 566     # already defined.
 567     if {$isWidget} {
 568         Comp.DefineComponent hull
 569     }
 570
 571     # NEXT, substitute the compiled definition into the type template
 572     # to get the type definition script.
 573     set defscript [Expand $typeTemplate \
 574                        %COMPILEDDEFS% $compile(defs)]
 575
 576     # NEXT, substitute the defined macros into the type definition script.
 577     # This is done as a separate step so that the compile(defs) can
 578     # contain the macros defined below.
 579
 580     set defscript [Expand $defscript \
 581                        %TYPE%         $type \
 582                        %IVARDECS%     $compile(ivprocdec) \
 583                        %TVARDECS%     $compile(tvprocdec) \
 584                        %TCONSTBODY%   $compile(typeconstructor) \
 585                        %INSTANCEVARS% $compile(instancevars) \
 586                        %TYPEVARS%     $compile(typevars) \
 587                        ]
 588
 589     array unset compile
 590
 591     return [list $type $defscript]
 592 }
 593
 594 # Information about locally-defined options is accumulated during
 595 # compilation, but not added to the compiled definition--the option
 596 # statement can appear multiple times, so it's easier this way.
 597 # This proc fills in Snit_optionInfo with the accumulated information.
 598 #
 599 # It also computes the option's resource and class names if needed.
 600 #
 601 # Note that the information for delegated options was put in
 602 # Snit_optionInfo during compilation.
 603
 604 proc ::snit::Comp.SaveOptionInfo {} {
 605     variable compile
 606
 607     foreach option $compile(localoptions) {
 608         if {$compile(resource-$option) eq ""} {
 609             set compile(resource-$option) [string range $option 1 end]
 610         }
 611
 612         if {$compile(class-$option) eq ""} {
 613             set compile(class-$option) [Capitalize $compile(resource-$option)]
 614         }
 615
 616         # NOTE: Don't verify that the validate, configure, and cget
 617         # values name real methods; the methods might be defined outside
 618         # the typedefinition using snit::method.
 619
 620         Mappend compile(defs) {
 621             # Option %OPTION%
 622             lappend %TYPE%::Snit_optionInfo(local) %OPTION%
 623
 624             set %TYPE%::Snit_optionInfo(islocal-%OPTION%)   1
 625             set %TYPE%::Snit_optionInfo(resource-%OPTION%)  %RESOURCE%
 626             set %TYPE%::Snit_optionInfo(class-%OPTION%)     %CLASS%
 627             set %TYPE%::Snit_optionInfo(default-%OPTION%)   %DEFAULT%
 628             set %TYPE%::Snit_optionInfo(validate-%OPTION%)  %VALIDATE%
 629             set %TYPE%::Snit_optionInfo(configure-%OPTION%) %CONFIGURE%
 630             set %TYPE%::Snit_optionInfo(cget-%OPTION%)      %CGET%
 631             set %TYPE%::Snit_optionInfo(readonly-%OPTION%)  %READONLY%
 632             set %TYPE%::Snit_optionInfo(typespec-%OPTION%)  %TYPESPEC%
 633         }   %OPTION%    $option \
 634             %RESOURCE%  $compile(resource-$option) \
 635             %CLASS%     $compile(class-$option) \
 636             %DEFAULT%   [list $compile(-default-$option)] \
 637             %VALIDATE%  [list $compile(-validatemethod-$option)] \
 638             %CONFIGURE% [list $compile(-configuremethod-$option)] \
 639             %CGET%      [list $compile(-cgetmethod-$option)] \
 640             %READONLY%  $compile(-readonly-$option)               \
 641             %TYPESPEC%  [list $compile(-type-$option)]
 642     }
 643 }
 644
 645
 646 # Evaluates a compiled type definition, thus making the type available.
 647 proc ::snit::Comp.Define {compResult} {
 648     # The compilation result is a list containing the fully qualified
 649     # type name and a script to evaluate to define the type.
 650     set type [lindex $compResult 0]
 651     set defscript [lindex $compResult 1]
 652
 653     # Execute the type definition script.
 654     # Consider using namespace eval %TYPE%.  See if it's faster.
 655     if {[catch {eval $defscript} result]} {
 656         namespace delete $type
 657         catch {rename $type ""}
 658         error $result
 659     }
 660
 661     return $type
 662 }
 663
 664 # Sets pragma options which control how the type is defined.
 665 proc ::snit::Comp.statement.pragma {args} {
 666     variable compile
 667
 668     set errRoot "Error in \"pragma...\""
 669
 670     foreach {opt val} $args {
 671         switch -exact -- $opt {
 672             -hastypeinfo    -
 673             -hastypedestroy -
 674             -hastypemethods -
 675             -hasinstances   -
 676             -simpledispatch -
 677             -hasinfo        -
 678             -canreplace     {
 679                 if {![string is boolean -strict $val]} {
 680                     error "$errRoot, \"$opt\" requires a boolean value"
 681                 }
 682                 set compile($opt) $val
 683             }
 684             default {
 685                 error "$errRoot, unknown pragma"
 686             }
 687         }
 688     }
 689 }
 690
 691 # Defines a widget's option class name.
 692 # This statement is only available for snit::widgets,
 693 # not for snit::types or snit::widgetadaptors.
 694 proc ::snit::Comp.statement.widgetclass {name} {
 695     variable compile
 696
 697     # First, widgetclass can only be set for true widgets
 698     if {"widget" != $compile(which)} {
 699         error "widgetclass cannot be set for snit::$compile(which)s"
 700     }
 701
 702     # Next, validate the option name.  We'll require that it begin
 703     # with an uppercase letter.
 704     set initial [string index $name 0]
 705     if {![string is upper $initial]} {
 706         error "widgetclass \"$name\" does not begin with an uppercase letter"
 707     }
 708
 709     if {"" != $compile(widgetclass)} {
 710         error "too many widgetclass statements"
 711     }
 712
 713     # Next, save it.
 714     Mappend compile(defs) {
 715         set  %TYPE%::Snit_info(widgetclass) %WIDGETCLASS%
 716     } %WIDGETCLASS% [list $name]
 717
 718     set compile(widgetclass) $name
 719 }
 720
 721 # Defines a widget's hull type.
 722 # This statement is only available for snit::widgets,
 723 # not for snit::types or snit::widgetadaptors.
 724 proc ::snit::Comp.statement.hulltype {name} {
 725     variable compile
 726     variable hulltypes
 727
 728     # First, hulltype can only be set for true widgets
 729     if {"widget" != $compile(which)} {
 730         error "hulltype cannot be set for snit::$compile(which)s"
 731     }
 732
 733     # Next, it must be one of the valid hulltypes (frame, toplevel, ...)
 734     if {[lsearch -exact $hulltypes [string trimleft $name :]] == -1} {
 735         error "invalid hulltype \"$name\", should be one of\
 736                 [join $hulltypes {, }]"
 737     }
 738
 739     if {"" != $compile(hulltype)} {
 740         error "too many hulltype statements"
 741     }
 742
 743     # Next, save it.
 744     Mappend compile(defs) {
 745         set  %TYPE%::Snit_info(hulltype) %HULLTYPE%
 746     } %HULLTYPE% $name
 747
 748     set compile(hulltype) $name
 749 }
 750
 751 # Defines a constructor.
 752 proc ::snit::Comp.statement.constructor {arglist body} {
 753     variable compile
 754
 755     CheckArgs "constructor" $arglist
 756
 757     # Next, add a magic reference to self.
 758     set arglist [concat type selfns win self $arglist]
 759
 760     # Next, add variable declarations to body:
 761     set body "%TVARDECS%\n%IVARDECS%\n$body"
 762
 763     set compile(hasconstructor) yes
 764     append compile(defs) "proc %TYPE%::Snit_constructor [list $arglist] [list $body]\n"
 765 }
 766
 767 # Defines a destructor.
 768 proc ::snit::Comp.statement.destructor {body} {
 769     variable compile
 770
 771     # Next, add variable declarations to body:
 772     set body "%TVARDECS%\n%IVARDECS%\n$body"
 773
 774     append compile(defs) "proc %TYPE%::Snit_destructor {type selfns win self} [list $body]\n\n"
 775 }
 776
 777 # Defines a type option.  The option value can be a triple, specifying
 778 # the option's -name, resource name, and class name.
 779 proc ::snit::Comp.statement.option {optionDef args} {
 780     variable compile
 781
 782     # First, get the three option names.
 783     set option [lindex $optionDef 0]
 784     set resourceName [lindex $optionDef 1]
 785     set className [lindex $optionDef 2]
 786
 787     set errRoot "Error in \"option [list $optionDef]...\""
 788
 789     # Next, validate the option name.
 790     if {![Comp.OptionNameIsValid $option]} {
 791         error "$errRoot, badly named option \"$option\""
 792     }
 793
 794     if {$option in $compile(delegatedoptions)} {
 795         error "$errRoot, cannot define \"$option\" locally, it has been delegated"
 796     }
 797
 798     if {!($option in $compile(localoptions))} {
 799         # Remember that we've seen this one.
 800         set compile(hasoptions) yes
 801         lappend compile(localoptions) $option
 802
 803         # Initialize compilation info for this option.
 804         set compile(resource-$option)         ""
 805         set compile(class-$option)            ""
 806         set compile(-default-$option)         ""
 807         set compile(-validatemethod-$option)  ""
 808         set compile(-configuremethod-$option) ""
 809         set compile(-cgetmethod-$option)      ""
 810         set compile(-readonly-$option)        0
 811         set compile(-type-$option)            ""
 812     }
 813
 814     # NEXT, see if we have a resource name.  If so, make sure it
 815     # isn't being redefined differently.
 816     if {$resourceName ne ""} {
 817         if {$compile(resource-$option) eq ""} {
 818             # If it's undefined, just save the value.
 819             set compile(resource-$option) $resourceName
 820         } elseif {$resourceName ne $compile(resource-$option)} {
 821             # It's been redefined differently.
 822             error "$errRoot, resource name redefined from \"$compile(resource-$option)\" to \"$resourceName\""
 823         }
 824     }
 825
 826     # NEXT, see if we have a class name.  If so, make sure it
 827     # isn't being redefined differently.
 828     if {$className ne ""} {
 829         if {$compile(class-$option) eq ""} {
 830             # If it's undefined, just save the value.
 831             set compile(class-$option) $className
 832         } elseif {$className ne $compile(class-$option)} {
 833             # It's been redefined differently.
 834             error "$errRoot, class name redefined from \"$compile(class-$option)\" to \"$className\""
 835         }
 836     }
 837
 838     # NEXT, handle the args; it's not an error to redefine these.
 839     if {[llength $args] == 1} {
 840         set compile(-default-$option) [lindex $args 0]
 841     } else {
 842         foreach {optopt val} $args {
 843             switch -exact -- $optopt {
 844                 -default         -
 845                 -validatemethod  -
 846                 -configuremethod -
 847                 -cgetmethod      {
 848                     set compile($optopt-$option) $val
 849                 }
 850                 -type {
 851                     set compile($optopt-$option) $val
 852
 853                     if {[llength $val] == 1} {
 854                         # The type spec *is* the validation object
 855                         append compile(defs) \
 856                             "\nset %TYPE%::Snit_optionInfo(typeobj-$option) [list $val]\n"
 857                     } else {
 858                         # Compilation the creation of the validation object
 859                         set cmd [linsert $val 1 %TYPE%::Snit_TypeObj_%AUTO%]
 860                         append compile(defs) \
 861                             "\nset %TYPE%::Snit_optionInfo(typeobj-$option) \[$cmd\]\n"
 862                     }
 863                 }
 864                 -readonly        {
 865                     if {![string is boolean -strict $val]} {
 866                         error "$errRoot, -readonly requires a boolean, got \"$val\""
 867                     }
 868                     set compile($optopt-$option) $val
 869                 }
 870                 default {
 871                     error "$errRoot, unknown option definition option \"$optopt\""
 872                 }
 873             }
 874         }
 875     }
 876 }
 877
 878 # 1 if the option name is valid, 0 otherwise.
 879 proc ::snit::Comp.OptionNameIsValid {option} {
 880     if {![string match {-*} $option] || [string match {*[A-Z ]*} $option]} {
 881         return 0
 882     }
 883
 884     return 1
 885 }
 886
 887 # Defines an option's cget handler
 888 proc ::snit::Comp.statement.oncget {option body} {
 889     variable compile
 890
 891     set errRoot "Error in \"oncget $option...\""
 892
 893     if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
 894         return -code error "$errRoot, option \"$option\" is delegated"
 895     }
 896
 897     if {[lsearch -exact $compile(localoptions) $option] == -1} {
 898         return -code error "$errRoot, option \"$option\" unknown"
 899     }
 900
 901     Comp.statement.method _cget$option {_option} $body
 902     Comp.statement.option $option -cgetmethod _cget$option
 903 }
 904
 905 # Defines an option's configure handler.
 906 proc ::snit::Comp.statement.onconfigure {option arglist body} {
 907     variable compile
 908
 909     if {[lsearch -exact $compile(delegatedoptions) $option] != -1} {
 910         return -code error "onconfigure $option: option \"$option\" is delegated"
 911     }
 912
 913     if {[lsearch -exact $compile(localoptions) $option] == -1} {
 914         return -code error "onconfigure $option: option \"$option\" unknown"
 915     }
 916
 917     if {[llength $arglist] != 1} {
 918         error \
 919        "onconfigure $option handler should have one argument, got \"$arglist\""
 920     }
 921
 922     CheckArgs "onconfigure $option" $arglist
 923
 924     # Next, add a magic reference to the option name
 925     set arglist [concat _option $arglist]
 926
 927     Comp.statement.method _configure$option $arglist $body
 928     Comp.statement.option $option -configuremethod _configure$option
 929 }
 930
 931 # Defines an instance method.
 932 proc ::snit::Comp.statement.method {method arglist body} {
 933     variable compile
 934     variable methodInfo
 935
 936     # FIRST, check the method name against previously defined
 937     # methods.
 938     Comp.CheckMethodName $method 0 ::snit::methodInfo \
 939         "Error in \"method [list $method]...\""
 940
 941     if {[llength $method] > 1} {
 942         set compile(hashierarchic) yes
 943     }
 944
 945     # Remeber this method
 946     lappend compile(localmethods) $method
 947
 948     CheckArgs "method [list $method]" $arglist
 949
 950     # Next, add magic references to type and self.
 951     set arglist [concat type selfns win self $arglist]
 952
 953     # Next, add variable declarations to body:
 954     set body "%TVARDECS%\n%IVARDECS%\n# END snit method prolog\n$body"
 955
 956     # Next, save the definition script.
 957     if {[llength $method] == 1} {
 958         set methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
 959         Mappend compile(defs) {
 960             proc %TYPE%::Snit_method%METHOD% %ARGLIST% %BODY%
 961         } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
 962     } else {
 963         set methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
 964
 965         Mappend compile(defs) {
 966             proc %TYPE%::Snit_hmethod%JMETHOD% %ARGLIST% %BODY%
 967         } %JMETHOD% [join $method _] %ARGLIST% [list $arglist] \
 968             %BODY% [list $body]
 969     }
 970 }
 971
 972 # Check for name collisions; save prefix information.
 973 #
 974 # method        The name of the method or typemethod.
 975 # delFlag       1 if delegated, 0 otherwise.
 976 # infoVar       The fully qualified name of the array containing
 977 #               information about the defined methods.
 978 # errRoot       The root string for any error messages.
 979
 980 proc ::snit::Comp.CheckMethodName {method delFlag infoVar errRoot} {
 981     upvar $infoVar methodInfo
 982
 983     # FIRST, make sure the method name is a valid Tcl list.
 984     if {[catch {lindex $method 0}]} {
 985         error "$errRoot, the name \"$method\" must have list syntax."
 986     }
 987
 988     # NEXT, check whether we can define it.
 989     if {![catch {set methodInfo($method)} data]} {
 990         # We can't redefine methods with submethods.
 991         if {[lindex $data 0] == 1} {
 992             error "$errRoot, \"$method\" has submethods."
 993         }
 994
 995         # You can't delegate a method that's defined locally,
 996         # and you can't define a method locally if it's been delegated.
 997         if {$delFlag && [lindex $data 2] eq ""} {
 998             error "$errRoot, \"$method\" has been defined locally."
 999         } elseif {!$delFlag && [lindex $data 2] ne ""} {
1000             error "$errRoot, \"$method\" has been delegated"
1001         }
1002     }
1003
1004     # Handle hierarchical case.
1005     if {[llength $method] > 1} {
1006         set prefix {}
1007         set tokens $method
1008         while {[llength $tokens] > 1} {
1009             lappend prefix [lindex $tokens 0]
1010             set tokens [lrange $tokens 1 end]
1011
1012             if {![catch {set methodInfo($prefix)} result]} {
1013                 # Prefix is known.  If it's not a prefix, throw an
1014                 # error.
1015                 if {[lindex $result 0] == 0} {
1016                     error "$errRoot, \"$prefix\" has no submethods."
1017                 }
1018             }
1019
1020             set methodInfo($prefix) [list 1]
1021         }
1022     }
1023 }
1024
1025 # Defines a typemethod method.
1026 proc ::snit::Comp.statement.typemethod {method arglist body} {
1027     variable compile
1028     variable typemethodInfo
1029
1030     # FIRST, check the typemethod name against previously defined
1031     # typemethods.
1032     Comp.CheckMethodName $method 0 ::snit::typemethodInfo \
1033         "Error in \"typemethod [list $method]...\""
1034
1035     CheckArgs "typemethod $method" $arglist
1036
1037     # First, add magic reference to type.
1038     set arglist [concat type $arglist]
1039
1040     # Next, add typevariable declarations to body:
1041     set body "%TVARDECS%\n# END snit method prolog\n$body"
1042
1043     # Next, save the definition script
1044     if {[llength $method] == 1} {
1045         set typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
1046
1047         Mappend compile(defs) {
1048             proc %TYPE%::Snit_typemethod%METHOD% %ARGLIST% %BODY%
1049         } %METHOD% $method %ARGLIST% [list $arglist] %BODY% [list $body]
1050     } else {
1051         set typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
1052
1053         Mappend compile(defs) {
1054             proc %TYPE%::Snit_htypemethod%JMETHOD% %ARGLIST% %BODY%
1055         } %JMETHOD% [join $method _] \
1056             %ARGLIST% [list $arglist] %BODY% [list $body]
1057     }
1058 }
1059
1060
1061 # Defines a type constructor.
1062 proc ::snit::Comp.statement.typeconstructor {body} {
1063     variable compile
1064
1065     if {"" != $compile(typeconstructor)} {
1066         error "too many typeconstructors"
1067     }
1068
1069     set compile(typeconstructor) $body
1070 }
1071
1072 # Defines a static proc in the type's namespace.
1073 proc ::snit::Comp.statement.proc {proc arglist body} {
1074     variable compile
1075
1076     # If "ns" is defined, the proc can see instance variables.
1077     if {[lsearch -exact $arglist selfns] != -1} {
1078         # Next, add instance variable declarations to body:
1079         set body "%IVARDECS%\n$body"
1080     }
1081
1082     # The proc can always see typevariables.
1083     set body "%TVARDECS%\n$body"
1084
1085     append compile(defs) "
1086
1087         # Proc $proc
1088         proc [list %TYPE%::$proc $arglist $body]
1089     "
1090 }
1091
1092 # Defines a static variable in the type's namespace.
1093 proc ::snit::Comp.statement.typevariable {name args} {
1094     variable compile
1095
1096     set errRoot "Error in \"typevariable $name...\""
1097
1098     set len [llength $args]
1099
1100     if {$len > 2 ||
1101         ($len == 2 && [lindex $args 0] ne "-array")} {
1102         error "$errRoot, too many initializers"
1103     }
1104
1105     if {[lsearch -exact $compile(varnames) $name] != -1} {
1106         error "$errRoot, \"$name\" is already an instance variable"
1107     }
1108
1109     lappend compile(typevarnames) $name
1110
1111     if {$len == 1} {
1112         append compile(typevars) \
1113                 "\n\t    [list ::variable $name [lindex $args 0]]"
1114     } elseif {$len == 2} {
1115         append compile(typevars) \
1116             "\n\t    [list ::variable $name]"
1117         append compile(typevars) \
1118             "\n\t    [list array set $name [lindex $args 1]]"
1119     } else {
1120         append compile(typevars) \
1121                 "\n\t    [list ::variable $name]"
1122     }
1123
1124     if {$compile(tvprocdec) eq ""} {
1125         set compile(tvprocdec) "\n\t"
1126         append compile(tvprocdec) "namespace upvar [list $compile(type)]"
1127     }
1128     append compile(tvprocdec) " [list $name $name]"
1129 }
1130
1131 # Defines an instance variable; the definition will go in the
1132 # type's create typemethod.
1133 proc ::snit::Comp.statement.variable {name args} {
1134     variable compile
1135
1136     set errRoot "Error in \"variable $name...\""
1137
1138     set len [llength $args]
1139
1140     if {$len > 2 ||
1141         ($len == 2 && [lindex $args 0] ne "-array")} {
1142         error "$errRoot, too many initializers"
1143     }
1144
1145     if {[lsearch -exact $compile(typevarnames) $name] != -1} {
1146         error "$errRoot, \"$name\" is already a typevariable"
1147     }
1148
1149     lappend compile(varnames) $name
1150
1151     # Add a ::variable to instancevars, so that ::variable is used
1152     # at least once; ::variable makes the variable visible to
1153     # [info vars] even if no value is assigned.
1154     append  compile(instancevars) "\n"
1155     Mappend compile(instancevars) {::variable ${selfns}::%N} %N $name
1156
1157     if {$len == 1} {
1158         append compile(instancevars) \
1159             "\nset $name [list [lindex $args 0]]\n"
1160     } elseif {$len == 2} {
1161         append compile(instancevars) \
1162             "\narray set $name [list [lindex $args 1]]\n"
1163     }
1164
1165     if {$compile(ivprocdec) eq ""} {
1166         set compile(ivprocdec) "\n\t"
1167         append compile(ivprocdec) {namespace upvar $selfns}
1168     }
1169     append compile(ivprocdec) " [list $name $name]"
1170 }
1171
1172 # Defines a typecomponent, and handles component options.
1173 #
1174 # component     The logical name of the delegate
1175 # args          options.
1176
1177 proc ::snit::Comp.statement.typecomponent {component args} {
1178     variable compile
1179
1180     set errRoot "Error in \"typecomponent $component...\""
1181
1182     # FIRST, define the component
1183     Comp.DefineTypecomponent $component $errRoot
1184
1185     # NEXT, handle the options.
1186     set publicMethod ""
1187     set inheritFlag 0
1188
1189     foreach {opt val} $args {
1190         switch -exact -- $opt {
1191             -public {
1192                 set publicMethod $val
1193             }
1194             -inherit {
1195                 set inheritFlag $val
1196                 if {![string is boolean $inheritFlag]} {
1197     error "typecomponent $component -inherit: expected boolean value, got \"$val\""
1198                 }
1199             }
1200             default {
1201                 error "typecomponent $component: Invalid option \"$opt\""
1202             }
1203         }
1204     }
1205
1206     # NEXT, if -public specified, define the method.
1207     if {$publicMethod ne ""} {
1208         Comp.statement.delegate typemethod [list $publicMethod *] to $component
1209     }
1210
1211     # NEXT, if "-inherit 1" is specified, delegate typemethod * to
1212     # this component.
1213     if {$inheritFlag} {
1214         Comp.statement.delegate typemethod "*" to $component
1215     }
1216
1217 }
1218
1219
1220 # Defines a name to be a typecomponent
1221 #
1222 # The name becomes a typevariable; in addition, it gets a
1223 # write trace so that when it is set, all of the component mechanisms
1224 # get updated.
1225 #
1226 # component     The component name
1227
1228 proc ::snit::Comp.DefineTypecomponent {component {errRoot "Error"}} {
1229     variable compile
1230
1231     if {[lsearch -exact $compile(varnames) $component] != -1} {
1232         error "$errRoot, \"$component\" is already an instance variable"
1233     }
1234
1235     if {[lsearch -exact $compile(typecomponents) $component] == -1} {
1236         # Remember we've done this.
1237         lappend compile(typecomponents) $component
1238
1239         # Make it a type variable with no initial value
1240         Comp.statement.typevariable $component ""
1241
1242         # Add a write trace to do the component thing.
1243         Mappend compile(typevars) {
1244             trace add variable %COMP% write \
1245                 [list ::snit::RT.TypecomponentTrace [list %TYPE%] %COMP%]
1246         } %TYPE% $compile(type) %COMP% $component
1247     }
1248 }
1249
1250 # Defines a component, and handles component options.
1251 #
1252 # component     The logical name of the delegate
1253 # args          options.
1254 #
1255 # TBD: Ideally, it should be possible to call this statement multiple
1256 # times, possibly changing the option values.  To do that, I'd need
1257 # to cache the option values and not act on them until *after* I'd
1258 # read the entire type definition.
1259
1260 proc ::snit::Comp.statement.component {component args} {
1261     variable compile
1262
1263     set errRoot "Error in \"component $component...\""
1264
1265     # FIRST, define the component
1266     Comp.DefineComponent $component $errRoot
1267
1268     # NEXT, handle the options.
1269     set publicMethod ""
1270     set inheritFlag 0
1271
1272     foreach {opt val} $args {
1273         switch -exact -- $opt {
1274             -public {
1275                 set publicMethod $val
1276             }
1277             -inherit {
1278                 set inheritFlag $val
1279                 if {![string is boolean $inheritFlag]} {
1280     error "component $component -inherit: expected boolean value, got \"$val\""
1281                 }
1282             }
1283             default {
1284                 error "component $component: Invalid option \"$opt\""
1285             }
1286         }
1287     }
1288
1289     # NEXT, if -public specified, define the method.
1290     if {$publicMethod ne ""} {
1291         Comp.statement.delegate method [list $publicMethod *] to $component
1292     }
1293
1294     # NEXT, if -inherit is specified, delegate method/option * to
1295     # this component.
1296     if {$inheritFlag} {
1297         Comp.statement.delegate method "*" to $component
1298         Comp.statement.delegate option "*" to $component
1299     }
1300 }
1301
1302
1303 # Defines a name to be a component
1304 #
1305 # The name becomes an instance variable; in addition, it gets a
1306 # write trace so that when it is set, all of the component mechanisms
1307 # get updated.
1308 #
1309 # component     The component name
1310
1311 proc ::snit::Comp.DefineComponent {component {errRoot "Error"}} {
1312     variable compile
1313
1314     if {[lsearch -exact $compile(typevarnames) $component] != -1} {
1315         error "$errRoot, \"$component\" is already a typevariable"
1316     }
1317
1318     if {[lsearch -exact $compile(components) $component] == -1} {
1319         # Remember we've done this.
1320         lappend compile(components) $component
1321
1322         # Make it an instance variable with no initial value
1323         Comp.statement.variable $component ""
1324
1325         # Add a write trace to do the component thing.
1326         Mappend compile(instancevars) {
1327             trace add variable ${selfns}::%COMP% write \
1328                 [list ::snit::RT.ComponentTrace [list %TYPE%] $selfns %COMP%]
1329         } %TYPE% $compile(type) %COMP% $component
1330     }
1331 }
1332
1333 # Creates a delegated method, typemethod, or option.
1334 proc ::snit::Comp.statement.delegate {what name args} {
1335     # FIRST, dispatch to correct handler.
1336     switch $what {
1337         typemethod { Comp.DelegatedTypemethod $name $args }
1338         method     { Comp.DelegatedMethod     $name $args }
1339         option     { Comp.DelegatedOption     $name $args }
1340         default {
1341             error "Error in \"delegate $what $name...\", \"$what\"?"
1342         }
1343     }
1344
1345     if {([llength $args] % 2) != 0} {
1346         error "Error in \"delegate $what $name...\", invalid syntax"
1347     }
1348 }
1349
1350 # Creates a delegated typemethod delegating it to a particular
1351 # typecomponent or an arbitrary command.
1352 #
1353 # method    The name of the method
1354 # arglist       Delegation options
1355
1356 proc ::snit::Comp.DelegatedTypemethod {method arglist} {
1357     variable compile
1358     variable typemethodInfo
1359
1360     set errRoot "Error in \"delegate typemethod [list $method]...\""
1361
1362     # Next, parse the delegation options.
1363     set component ""
1364     set target ""
1365     set exceptions {}
1366     set pattern ""
1367     set methodTail [lindex $method end]
1368
1369     foreach {opt value} $arglist {
1370         switch -exact $opt {
1371             to     { set component $value  }
1372             as     { set target $value     }
1373             except { set exceptions $value }
1374             using  { set pattern $value    }
1375             default {
1376                 error "$errRoot, unknown delegation option \"$opt\""
1377             }
1378         }
1379     }
1380
1381     if {$component eq "" && $pattern eq ""} {
1382         error "$errRoot, missing \"to\""
1383     }
1384
1385     if {$methodTail eq "*" && $target ne ""} {
1386         error "$errRoot, cannot specify \"as\" with \"*\""
1387     }
1388
1389     if {$methodTail ne "*" && $exceptions ne ""} {
1390         error "$errRoot, can only specify \"except\" with \"*\""
1391     }
1392
1393     if {$pattern ne "" && $target ne ""} {
1394         error "$errRoot, cannot specify both \"as\" and \"using\""
1395     }
1396
1397     foreach token [lrange $method 1 end-1] {
1398         if {$token eq "*"} {
1399             error "$errRoot, \"*\" must be the last token."
1400         }
1401     }
1402
1403     # NEXT, define the component
1404     if {$component ne ""} {
1405         Comp.DefineTypecomponent $component $errRoot
1406     }
1407
1408     # NEXT, define the pattern.
1409     if {$pattern eq ""} {
1410         if {$methodTail eq "*"} {
1411             set pattern "%c %m"
1412         } elseif {$target ne ""} {
1413             set pattern "%c $target"
1414         } else {
1415             set pattern "%c %m"
1416         }
1417     }
1418
1419     # Make sure the pattern is a valid list.
1420     if {[catch {lindex $pattern 0} result]} {
1421         error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
1422     }
1423
1424     # NEXT, check the method name against previously defined
1425     # methods.
1426     Comp.CheckMethodName $method 1 ::snit::typemethodInfo $errRoot
1427
1428     set typemethodInfo($method) [list 0 $pattern $component]
1429
1430     if {[string equal $methodTail "*"]} {
1431         Mappend compile(defs) {
1432             set %TYPE%::Snit_info(excepttypemethods) %EXCEPT%
1433         } %EXCEPT% [list $exceptions]
1434     }
1435 }
1436
1437
1438 # Creates a delegated method delegating it to a particular
1439 # component or command.
1440 #
1441 # method        The name of the method
1442 # arglist       Delegation options.
1443
1444 proc ::snit::Comp.DelegatedMethod {method arglist} {
1445     variable compile
1446     variable methodInfo
1447
1448     set errRoot "Error in \"delegate method [list $method]...\""
1449
1450     # Next, parse the delegation options.
1451     set component ""
1452     set target ""
1453     set exceptions {}
1454     set pattern ""
1455     set methodTail [lindex $method end]
1456
1457     foreach {opt value} $arglist {
1458         switch -exact $opt {
1459             to     { set component $value  }
1460             as     { set target $value     }
1461             except { set exceptions $value }
1462             using  { set pattern $value    }
1463             default {
1464                 error "$errRoot, unknown delegation option \"$opt\""
1465             }
1466         }
1467     }
1468
1469     if {$component eq "" && $pattern eq ""} {
1470         error "$errRoot, missing \"to\""
1471     }
1472
1473     if {$methodTail eq "*" && $target ne ""} {
1474         error "$errRoot, cannot specify \"as\" with \"*\""
1475     }
1476
1477     if {$methodTail ne "*" && $exceptions ne ""} {
1478         error "$errRoot, can only specify \"except\" with \"*\""
1479     }
1480
1481     if {$pattern ne "" && $target ne ""} {
1482         error "$errRoot, cannot specify both \"as\" and \"using\""
1483     }
1484
1485     foreach token [lrange $method 1 end-1] {
1486         if {$token eq "*"} {
1487             error "$errRoot, \"*\" must be the last token."
1488         }
1489     }
1490
1491     # NEXT, we delegate some methods
1492     set compile(delegatesmethods) yes
1493
1494     # NEXT, define the component.  Allow typecomponents.
1495     if {$component ne ""} {
1496         if {[lsearch -exact $compile(typecomponents) $component] == -1} {
1497             Comp.DefineComponent $component $errRoot
1498         }
1499     }
1500
1501     # NEXT, define the pattern.
1502     if {$pattern eq ""} {
1503         if {$methodTail eq "*"} {
1504             set pattern "%c %m"
1505         } elseif {$target ne ""} {
1506             set pattern "%c $target"
1507         } else {
1508             set pattern "%c %m"
1509         }
1510     }
1511
1512     # Make sure the pattern is a valid list.
1513     if {[catch {lindex $pattern 0} result]} {
1514         error "$errRoot, the using pattern, \"$pattern\", is not a valid list"
1515     }
1516
1517     # NEXT, check the method name against previously defined
1518     # methods.
1519     Comp.CheckMethodName $method 1 ::snit::methodInfo $errRoot
1520
1521     # NEXT, save the method info.
1522     set methodInfo($method) [list 0 $pattern $component]
1523
1524     if {[string equal $methodTail "*"]} {
1525         Mappend compile(defs) {
1526             set %TYPE%::Snit_info(exceptmethods) %EXCEPT%
1527         } %EXCEPT% [list $exceptions]
1528     }
1529 }
1530
1531 # Creates a delegated option, delegating it to a particular
1532 # component and, optionally, to a particular option of that
1533 # component.
1534 #
1535 # optionDef     The option definition
1536 # args          definition arguments.
1537
1538 proc ::snit::Comp.DelegatedOption {optionDef arglist} {
1539     variable compile
1540
1541     # First, get the three option names.
1542     set option [lindex $optionDef 0]
1543     set resourceName [lindex $optionDef 1]
1544     set className [lindex $optionDef 2]
1545
1546     set errRoot "Error in \"delegate option [list $optionDef]...\""
1547
1548     # Next, parse the delegation options.
1549     set component ""
1550     set target ""
1551     set exceptions {}
1552
1553     foreach {opt value} $arglist {
1554         switch -exact $opt {
1555             to     { set component $value  }
1556             as     { set target $value     }
1557             except { set exceptions $value }
1558             default {
1559                 error "$errRoot, unknown delegation option \"$opt\""
1560             }
1561         }
1562     }
1563
1564     if {$component eq ""} {
1565         error "$errRoot, missing \"to\""
1566     }
1567
1568     if {$option eq "*" && $target ne ""} {
1569         error "$errRoot, cannot specify \"as\" with \"delegate option *\""
1570     }
1571
1572     if {$option ne "*" && $exceptions ne ""} {
1573         error "$errRoot, can only specify \"except\" with \"delegate option *\""
1574     }
1575
1576     # Next, validate the option name
1577
1578     if {"*" != $option} {
1579         if {![Comp.OptionNameIsValid $option]} {
1580             error "$errRoot, badly named option \"$option\""
1581         }
1582     }
1583
1584     if {$option in $compile(localoptions)} {
1585         error "$errRoot, \"$option\" has been defined locally"
1586     }
1587
1588     if {$option in $compile(delegatedoptions)} {
1589         error "$errRoot, \"$option\" is multiply delegated"
1590     }
1591
1592     # NEXT, define the component
1593     Comp.DefineComponent $component $errRoot
1594
1595     # Next, define the target option, if not specified.
1596     if {![string equal $option "*"] &&
1597         [string equal $target ""]} {
1598         set target $option
1599     }
1600
1601     # NEXT, save the delegation data.
1602     set compile(hasoptions) yes
1603
1604     if {![string equal $option "*"]} {
1605         lappend compile(delegatedoptions) $option
1606
1607         # Next, compute the resource and class names, if they aren't
1608         # already defined.
1609
1610         if {"" == $resourceName} {
1611             set resourceName [string range $option 1 end]
1612         }
1613
1614         if {"" == $className} {
1615             set className [Capitalize $resourceName]
1616         }
1617
1618         Mappend  compile(defs) {
1619             set %TYPE%::Snit_optionInfo(islocal-%OPTION%) 0
1620             set %TYPE%::Snit_optionInfo(resource-%OPTION%) %RES%
1621             set %TYPE%::Snit_optionInfo(class-%OPTION%) %CLASS%
1622             lappend %TYPE%::Snit_optionInfo(delegated) %OPTION%
1623             set %TYPE%::Snit_optionInfo(target-%OPTION%) [list %COMP% %TARGET%]
1624             lappend %TYPE%::Snit_optionInfo(delegated-%COMP%) %OPTION%
1625         }   %OPTION% $option \
1626             %COMP% $component \
1627             %TARGET% $target \
1628             %RES% $resourceName \
1629             %CLASS% $className
1630     } else {
1631         Mappend  compile(defs) {
1632             set %TYPE%::Snit_optionInfo(starcomp) %COMP%
1633             set %TYPE%::Snit_optionInfo(except) %EXCEPT%
1634         } %COMP% $component %EXCEPT% [list $exceptions]
1635     }
1636 }
1637
1638 # Exposes a component, effectively making the component's command an
1639 # instance method.
1640 #
1641 # component     The logical name of the delegate
1642 # "as"          sugar; if not "", must be "as"
1643 # methodname    The desired method name for the component's command, or ""
1644
1645 proc ::snit::Comp.statement.expose {component {"as" ""} {methodname ""}} {
1646     variable compile
1647
1648
1649     # FIRST, define the component
1650     Comp.DefineComponent $component
1651
1652     # NEXT, define the method just as though it were in the type
1653     # definition.
1654     if {[string equal $methodname ""]} {
1655         set methodname $component
1656     }
1657
1658     Comp.statement.method $methodname args [Expand {
1659         if {[llength $args] == 0} {
1660             return $%COMPONENT%
1661         }
1662
1663         if {[string equal $%COMPONENT% ""]} {
1664             error "undefined component \"%COMPONENT%\""
1665         }
1666
1667
1668         set cmd [linsert $args 0 $%COMPONENT%]
1669         return [uplevel 1 $cmd]
1670     } %COMPONENT% $component]
1671 }
1672
1673
1674
1675 #-----------------------------------------------------------------------
1676 # Public commands
1677
1678 # Compile a type definition, and return the results as a list of two
1679 # items: the fully-qualified type name, and a script that will define
1680 # the type when executed.
1681 #
1682 # which         type, widget, or widgetadaptor
1683 # type          the type name
1684 # body          the type definition
1685 proc ::snit::compile {which type body} {
1686     return [Comp.Compile $which $type $body]
1687 }
1688
1689 proc ::snit::type {type body} {
1690     return [Comp.Define [Comp.Compile type $type $body]]
1691 }
1692
1693 proc ::snit::widget {type body} {
1694     return [Comp.Define [Comp.Compile widget $type $body]]
1695 }
1696
1697 proc ::snit::widgetadaptor {type body} {
1698     return [Comp.Define [Comp.Compile widgetadaptor $type $body]]
1699 }
1700
1701 proc ::snit::typemethod {type method arglist body} {
1702     # Make sure the type exists.
1703     if {![info exists ${type}::Snit_info]} {
1704         error "no such type: \"$type\""
1705     }
1706
1707     upvar ${type}::Snit_info           Snit_info
1708     upvar ${type}::Snit_typemethodInfo Snit_typemethodInfo
1709
1710     # FIRST, check the typemethod name against previously defined
1711     # typemethods.
1712     Comp.CheckMethodName $method 0 ${type}::Snit_typemethodInfo \
1713         "Cannot define \"$method\""
1714
1715     # NEXT, check the arguments
1716     CheckArgs "snit::typemethod $type $method" $arglist
1717
1718     # Next, add magic reference to type.
1719     set arglist [concat type $arglist]
1720
1721     # Next, add typevariable declarations to body:
1722     set body "$Snit_info(tvardecs)\n$body"
1723
1724     # Next, define it.
1725     if {[llength $method] == 1} {
1726         set Snit_typemethodInfo($method) {0 "%t::Snit_typemethod%m %t" ""}
1727         uplevel 1 [list proc ${type}::Snit_typemethod$method $arglist $body]
1728     } else {
1729         set Snit_typemethodInfo($method) {0 "%t::Snit_htypemethod%j %t" ""}
1730         set suffix [join $method _]
1731         uplevel 1 [list proc ${type}::Snit_htypemethod$suffix $arglist $body]
1732     }
1733 }
1734
1735 proc ::snit::method {type method arglist body} {
1736     # Make sure the type exists.
1737     if {![info exists ${type}::Snit_info]} {
1738         error "no such type: \"$type\""
1739     }
1740
1741     upvar ${type}::Snit_methodInfo  Snit_methodInfo
1742     upvar ${type}::Snit_info        Snit_info
1743
1744     # FIRST, check the method name against previously defined
1745     # methods.
1746     Comp.CheckMethodName $method 0 ${type}::Snit_methodInfo \
1747         "Cannot define \"$method\""
1748
1749     # NEXT, check the arguments
1750     CheckArgs "snit::method $type $method" $arglist
1751
1752     # Next, add magic references to type and self.
1753     set arglist [concat type selfns win self $arglist]
1754
1755     # Next, add variable declarations to body:
1756     set body "$Snit_info(tvardecs)\n$Snit_info(ivardecs)\n$body"
1757
1758     # Next, define it.
1759     if {[llength $method] == 1} {
1760         set Snit_methodInfo($method) {0 "%t::Snit_method%m %t %n %w %s" ""}
1761         uplevel 1 [list proc ${type}::Snit_method$method $arglist $body]
1762     } else {
1763         set Snit_methodInfo($method) {0 "%t::Snit_hmethod%j %t %n %w %s" ""}
1764
1765         set suffix [join $method _]
1766         uplevel 1 [list proc ${type}::Snit_hmethod$suffix $arglist $body]
1767     }
1768 }
1769
1770 # Defines a proc within the compiler; this proc can call other
1771 # type definition statements, and thus can be used for meta-programming.
1772 proc ::snit::macro {name arglist body} {
1773     variable compiler
1774     variable reservedwords
1775
1776     # FIRST, make sure the compiler is defined.
1777     Comp.Init
1778
1779     # NEXT, check the macro name against the reserved words
1780     if {[lsearch -exact $reservedwords $name] != -1} {
1781         error "invalid macro name \"$name\""
1782     }
1783
1784     # NEXT, see if the name has a namespace; if it does, define the
1785     # namespace.
1786     set ns [namespace qualifiers $name]
1787
1788     if {$ns ne ""} {
1789         $compiler eval "namespace eval $ns {}"
1790     }
1791
1792     # NEXT, define the macro
1793     $compiler eval [list _proc $name $arglist $body]
1794 }
1795
1796 #-----------------------------------------------------------------------
1797 # Utility Functions
1798 #
1799 # These are utility functions used while compiling Snit types.
1800
1801 # Builds a template from a tagged list of text blocks, then substitutes
1802 # all symbols in the mapTable, returning the expanded template.
1803 proc ::snit::Expand {template args} {
1804     return [string map $args $template]
1805 }
1806
1807 # Expands a template and appends it to a variable.
1808 proc ::snit::Mappend {varname template args} {
1809     upvar $varname myvar
1810
1811     append myvar [string map $args $template]
1812 }
1813
1814 # Checks argument list against reserved args
1815 proc ::snit::CheckArgs {which arglist} {
1816     variable reservedArgs
1817
1818     foreach name $reservedArgs {
1819         if {$name in $arglist} {
1820             error "$which's arglist may not contain \"$name\" explicitly"
1821         }
1822     }
1823 }
1824
1825 # Capitalizes the first letter of a string.
1826 proc ::snit::Capitalize {text} {
1827     return [string toupper $text 0]
1828 }
1829
1830
1831 #=======================================================================
1832 # Snit Runtime Library
1833 #
1834 # These are procs used by Snit types and widgets at runtime.
1835
1836 #-----------------------------------------------------------------------
1837 # Object Creation
1838
1839 # Creates a new instance of the snit::type given its name and the args.
1840 #
1841 # type          The snit::type
1842 # name          The instance name
1843 # args          Args to pass to the constructor
1844
1845 proc ::snit::RT.type.typemethod.create {type name args} {
1846     variable ${type}::Snit_info
1847     variable ${type}::Snit_optionInfo
1848
1849     # FIRST, qualify the name.
1850     if {![string match "::*" $name]} {
1851         # Get caller's namespace;
1852         # append :: if not global namespace.
1853         set ns [uplevel 1 [list namespace current]]
1854         if {"::" != $ns} {
1855             append ns "::"
1856         }
1857
1858         set name "$ns$name"
1859     }
1860
1861     # NEXT, if %AUTO% appears in the name, generate a unique
1862     # command name.  Otherwise, ensure that the name isn't in use.
1863     if {[string match "*%AUTO%*" $name]} {
1864         set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
1865     } elseif {!$Snit_info(canreplace) && [llength [info commands $name]]} {
1866         error "command \"$name\" already exists"
1867     }
1868
1869     # NEXT, create the instance's namespace.
1870     set selfns \
1871         [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
1872     namespace eval $selfns {}
1873
1874     # NEXT, install the dispatcher
1875     RT.MakeInstanceCommand $type $selfns $name
1876
1877     # Initialize the options to their defaults.
1878     namespace upvar ${selfns} options options
1879
1880     foreach opt $Snit_optionInfo(local) {
1881         set options($opt) $Snit_optionInfo(default-$opt)
1882     }
1883
1884     # Initialize the instance vars to their defaults.
1885     # selfns must be defined, as it is used implicitly.
1886     ${type}::Snit_instanceVars $selfns
1887
1888     # Execute the type's constructor.
1889     set errcode [catch {
1890         RT.ConstructInstance $type $selfns $name $args
1891     } result]
1892
1893     if {$errcode} {
1894         global errorInfo
1895         global errorCode
1896
1897         set theInfo $errorInfo
1898         set theCode $errorCode
1899
1900         ::snit::RT.DestroyObject $type $selfns $name
1901         error "Error in constructor: $result" $theInfo $theCode
1902     }
1903
1904     # NEXT, return the object's name.
1905     return $name
1906 }
1907
1908 # Creates a new instance of the snit::widget or snit::widgetadaptor
1909 # given its name and the args.
1910 #
1911 # type          The snit::widget or snit::widgetadaptor
1912 # name          The instance name
1913 # args          Args to pass to the constructor
1914
1915 proc ::snit::RT.widget.typemethod.create {type name args} {
1916     variable ${type}::Snit_info
1917     variable ${type}::Snit_optionInfo
1918
1919     # FIRST, if %AUTO% appears in the name, generate a unique
1920     # command name.
1921     if {[string match "*%AUTO%*" $name]} {
1922         set name [::snit::RT.UniqueName Snit_info(counter) $type $name]
1923     }
1924
1925     # NEXT, create the instance's namespace.
1926     set selfns \
1927         [::snit::RT.UniqueInstanceNamespace Snit_info(counter) $type]
1928     namespace eval $selfns { }
1929
1930     # NEXT, Initialize the widget's own options to their defaults.
1931     namespace upvar $selfns options options
1932
1933     foreach opt $Snit_optionInfo(local) {
1934         set options($opt) $Snit_optionInfo(default-$opt)
1935     }
1936
1937     # Initialize the instance vars to their defaults.
1938     ${type}::Snit_instanceVars $selfns
1939
1940     # NEXT, if this is a normal widget (not a widget adaptor) then create a
1941     # frame as its hull.  We set the frame's -class to the user's widgetclass,
1942     # or, if none, search for -class in the args list, otherwise default to
1943     # the basename of the $type with an initial upper case letter.
1944     if {!$Snit_info(isWidgetAdaptor)} {
1945         # FIRST, determine the class name
1946         set wclass $Snit_info(widgetclass)
1947         if {$Snit_info(widgetclass) eq ""} {
1948             set idx [lsearch -exact $args -class]
1949             if {$idx >= 0 && ($idx%2 == 0)} {
1950                 # -class exists and is in the -option position
1951                 set wclass [lindex $args [expr {$idx+1}]]
1952                 set args [lreplace $args $idx [expr {$idx+1}]]
1953             } else {
1954                 set wclass [::snit::Capitalize [namespace tail $type]]
1955             }
1956         }
1957
1958         # NEXT, create the widget
1959         set self $name
1960         package require Tk
1961         ${type}::installhull using $Snit_info(hulltype) -class $wclass
1962
1963         # NEXT, let's query the option database for our
1964         # widget, now that we know that it exists.
1965         foreach opt $Snit_optionInfo(local) {
1966             set dbval [RT.OptionDbGet $type $name $opt]
1967
1968             if {"" != $dbval} {
1969                 set options($opt) $dbval
1970             }
1971         }
1972     }
1973
1974     # Execute the type's constructor, and verify that it
1975     # has a hull.
1976     set errcode [catch {
1977         RT.ConstructInstance $type $selfns $name $args
1978
1979         ::snit::RT.Component $type $selfns hull
1980
1981         # Prepare to call the object's destructor when the
1982         # <Destroy> event is received.  Use a Snit-specific bindtag
1983         # so that the widget name's tag is unencumbered.
1984
1985         bind Snit$type$name <Destroy> [::snit::Expand {
1986             ::snit::RT.DestroyObject %TYPE% %NS% %W
1987         } %TYPE% $type %NS% $selfns]
1988
1989         # Insert the bindtag into the list of bindtags right
1990         # after the widget name.
1991         set taglist [bindtags $name]
1992         set ndx [lsearch -exact $taglist $name]
1993         incr ndx
1994         bindtags $name [linsert $taglist $ndx Snit$type$name]
1995     } result]
1996
1997     if {$errcode} {
1998         global errorInfo
1999         global errorCode
2000
2001         set theInfo $errorInfo
2002         set theCode $errorCode
2003         ::snit::RT.DestroyObject $type $selfns $name
2004         error "Error in constructor: $result" $theInfo $theCode
2005     }
2006
2007     # NEXT, return the object's name.
2008     return $name
2009 }
2010
2011
2012 # RT.MakeInstanceCommand type selfns instance
2013 #
2014 # type        The object type
2015 # selfns      The instance namespace
2016 # instance    The instance name
2017 #
2018 # Creates the instance proc.
2019
2020 proc ::snit::RT.MakeInstanceCommand {type selfns instance} {
2021     variable ${type}::Snit_info
2022
2023     # FIRST, remember the instance name.  The Snit_instance variable
2024     # allows the instance to figure out its current name given the
2025     # instance namespace.
2026
2027     namespace upvar $selfns Snit_instance Snit_instance
2028
2029     set Snit_instance $instance
2030
2031     # NEXT, qualify the proc name if it's a widget.
2032     if {$Snit_info(isWidget)} {
2033         set procname ::$instance
2034     } else {
2035         set procname $instance
2036     }
2037
2038     # NEXT, install the new proc
2039     # WHD: Snit 2.0 code
2040
2041     set unknownCmd [list ::snit::RT.UnknownMethod $type $selfns $instance ""]
2042     set createCmd [list namespace ensemble create \
2043                        -command $procname \
2044                        -unknown $unknownCmd \
2045                        -prefixes 0]
2046
2047     namespace eval $selfns $createCmd
2048
2049     # NEXT, add the trace.
2050     trace add command $procname {rename delete} \
2051         [list ::snit::RT.InstanceTrace $type $selfns $instance]
2052 }
2053
2054 # This proc is called when the instance command is renamed.
2055 # If op is delete, then new will always be "", so op is redundant.
2056 #
2057 # type          The fully-qualified type name
2058 # selfns        The instance namespace
2059 # win           The original instance/tk window name.
2060 # old           old instance command name
2061 # new           new instance command name
2062 # op            rename or delete
2063 #
2064 # If the op is delete, we need to clean up the object; otherwise,
2065 # we need to track the change.
2066 #
2067 # NOTE: In Tcl 8.4.2 there's a bug: errors in rename and delete
2068 # traces aren't propagated correctly.  Instead, they silently
2069 # vanish.  Add a catch to output any error message.
2070
2071 proc ::snit::RT.InstanceTrace {type selfns win old new op} {
2072     variable ${type}::Snit_info
2073
2074     # Note to developers ...
2075     # For Tcl 8.4.0, errors thrown in trace handlers vanish silently.
2076     # Therefore we catch them here and create some output to help in
2077     # debugging such problems.
2078
2079     if {[catch {
2080         # FIRST, clean up if necessary
2081         if {"" == $new} {
2082             if {$Snit_info(isWidget)} {
2083                 destroy $win
2084             } else {
2085                 ::snit::RT.DestroyObject $type $selfns $win
2086             }
2087         } else {
2088             # Otherwise, track the change.
2089             variable ${selfns}::Snit_instance
2090             set Snit_instance [uplevel 1 [list namespace which -command $new]]
2091
2092             # Also, clear the instance caches, as many cached commands
2093             # might be invalid.
2094             RT.ClearInstanceCaches $selfns
2095         }
2096     } result]} {
2097         global errorInfo
2098         # Pop up the console on Windows wish, to enable stdout.
2099         # This clobbers errorInfo on unix, so save it so we can print it.
2100         set ei $errorInfo
2101         catch {console show}
2102         puts "Error in ::snit::RT.InstanceTrace $type $selfns $win $old $new $op:"
2103         puts $ei
2104     }
2105 }
2106
2107 # Calls the instance constructor and handles related housekeeping.
2108 proc ::snit::RT.ConstructInstance {type selfns instance arglist} {
2109     variable ${type}::Snit_optionInfo
2110     variable ${selfns}::Snit_iinfo
2111
2112     # Track whether we are constructed or not.
2113     set Snit_iinfo(constructed) 0
2114
2115     # Call the user's constructor
2116     eval [linsert $arglist 0 \
2117               ${type}::Snit_constructor $type $selfns $instance $instance]
2118
2119     set Snit_iinfo(constructed) 1
2120
2121     # Validate the initial set of options (including defaults)
2122     foreach option $Snit_optionInfo(local) {
2123         set value [set ${selfns}::options($option)]
2124
2125         if {$Snit_optionInfo(typespec-$option) ne ""} {
2126             if {[catch {
2127                 $Snit_optionInfo(typeobj-$option) validate $value
2128             } result]} {
2129                 return -code error "invalid $option default: $result"
2130             }
2131         }
2132     }
2133
2134     # Unset the configure cache for all -readonly options.
2135     # This ensures that the next time anyone tries to
2136     # configure it, an error is thrown.
2137     foreach opt $Snit_optionInfo(local) {
2138         if {$Snit_optionInfo(readonly-$opt)} {
2139             unset -nocomplain ${selfns}::Snit_configureCache($opt)
2140         }
2141     }
2142
2143     return
2144 }
2145
2146 # Returns a unique command name.
2147 #
2148 # REQUIRE: type is a fully qualified name.
2149 # REQUIRE: name contains "%AUTO%"
2150 # PROMISE: the returned command name is unused.
2151 proc ::snit::RT.UniqueName {countervar type name} {
2152     upvar $countervar counter
2153     while 1 {
2154         # FIRST, bump the counter and define the %AUTO% instance name;
2155         # then substitute it into the specified name.  Wrap around at
2156         # 2^31 - 2 to prevent overflow problems.
2157         incr counter
2158         if {$counter > 2147483646} {
2159             set counter 0
2160         }
2161         set auto "[namespace tail $type]$counter"
2162         set candidate [Expand $name %AUTO% $auto]
2163         if {![llength [info commands $candidate]]} {
2164             return $candidate
2165         }
2166     }
2167 }
2168
2169 # Returns a unique instance namespace, fully qualified.
2170 #
2171 # countervar     The name of a counter variable
2172 # type           The instance's type
2173 #
2174 # REQUIRE: type is fully qualified
2175 # PROMISE: The returned namespace name is unused.
2176
2177 proc ::snit::RT.UniqueInstanceNamespace {countervar type} {
2178     upvar $countervar counter
2179     while 1 {
2180         # FIRST, bump the counter and define the namespace name.
2181         # Then see if it already exists.  Wrap around at
2182         # 2^31 - 2 to prevent overflow problems.
2183         incr counter
2184         if {$counter > 2147483646} {
2185             set counter 0
2186         }
2187         set ins "${type}::Snit_inst${counter}"
2188         if {![namespace exists $ins]} {
2189             return $ins
2190         }
2191     }
2192 }
2193
2194 # Retrieves an option's value from the option database.
2195 # Returns "" if no value is found.
2196 proc ::snit::RT.OptionDbGet {type self opt} {
2197     variable ${type}::Snit_optionInfo
2198
2199     return [option get $self \
2200                 $Snit_optionInfo(resource-$opt) \
2201                 $Snit_optionInfo(class-$opt)]
2202 }
2203
2204 #-----------------------------------------------------------------------
2205 # Object Destruction
2206
2207 # Implements the standard "destroy" method
2208 #
2209 # type          The snit type
2210 # selfns        The instance's instance namespace
2211 # win           The instance's original name
2212 # self          The instance's current name
2213
2214 proc ::snit::RT.method.destroy {type selfns win self} {
2215     variable ${selfns}::Snit_iinfo
2216
2217     # Can't destroy the object if it isn't complete constructed.
2218     if {!$Snit_iinfo(constructed)} {
2219         return -code error "Called 'destroy' method in constructor"
2220     }
2221
2222     # Calls Snit_cleanup, which (among other things) calls the
2223     # user's destructor.
2224     ::snit::RT.DestroyObject $type $selfns $win
2225 }
2226
2227 # This is the function that really cleans up; it's automatically
2228 # called when any instance is destroyed, e.g., by "$object destroy"
2229 # for types, and by the <Destroy> event for widgets.
2230 #
2231 # type          The fully-qualified type name.
2232 # selfns        The instance namespace
2233 # win           The original instance command name.
2234
2235 proc ::snit::RT.DestroyObject {type selfns win} {
2236     variable ${type}::Snit_info
2237
2238     # If the variable Snit_instance doesn't exist then there's no
2239     # instance command for this object -- it's most likely a
2240     # widgetadaptor. Consequently, there are some things that
2241     # we don't need to do.
2242     if {[info exists ${selfns}::Snit_instance]} {
2243         namespace upvar $selfns Snit_instance instance
2244
2245         # First, remove the trace on the instance name, so that we
2246         # don't call RT.DestroyObject recursively.
2247         RT.RemoveInstanceTrace $type $selfns $win $instance
2248
2249         # Next, call the user's destructor
2250         ${type}::Snit_destructor $type $selfns $win $instance
2251
2252         # Next, if this isn't a widget, delete the instance command.
2253         # If it is a widget, get the hull component's name, and rename
2254         # it back to the widget name
2255
2256         # Next, delete the hull component's instance command,
2257         # if there is one.
2258         if {$Snit_info(isWidget)} {
2259             set hullcmd [::snit::RT.Component $type $selfns hull]
2260
2261             catch {rename $instance ""}
2262
2263             # Clear the bind event
2264             bind Snit$type$win <Destroy> ""
2265
2266             if {[llength [info commands $hullcmd]]} {
2267                 # FIRST, rename the hull back to its original name.
2268                 # If the hull is itself a megawidget, it will have its
2269                 # own cleanup to do, and it might not do it properly
2270                 # if it doesn't have the right name.
2271                 rename $hullcmd ::$instance
2272
2273                 # NEXT, destroy it.
2274                 destroy $instance
2275             }
2276         } else {
2277             catch {rename $instance ""}
2278         }
2279     }
2280
2281     # Next, delete the instance's namespace.  This kills any
2282     # instance variables.
2283     namespace delete $selfns
2284
2285     return
2286 }
2287
2288 # Remove instance trace
2289 #
2290 # type           The fully qualified type name
2291 # selfns         The instance namespace
2292 # win            The original instance name/Tk window name
2293 # instance       The current instance name
2294
2295 proc ::snit::RT.RemoveInstanceTrace {type selfns win instance} {
2296     variable ${type}::Snit_info
2297
2298     if {$Snit_info(isWidget)} {
2299         set procname ::$instance
2300     } else {
2301         set procname $instance
2302     }
2303
2304     # NEXT, remove any trace on this name
2305     catch {
2306         trace remove command $procname {rename delete} \
2307             [list ::snit::RT.InstanceTrace $type $selfns $win]
2308     }
2309 }
2310
2311 #-----------------------------------------------------------------------
2312 # Typecomponent Management and Method Caching
2313
2314 # Typecomponent trace; used for write trace on typecomponent
2315 # variables.  Saves the new component object name, provided
2316 # that certain conditions are met.  Also clears the typemethod
2317 # cache.
2318
2319 proc ::snit::RT.TypecomponentTrace {type component n1 n2 op} {
2320     namespace upvar $type \
2321         Snit_info           Snit_info \
2322         $component          cvar      \
2323         Snit_typecomponents Snit_typecomponents
2324
2325
2326     # Save the new component value.
2327     set Snit_typecomponents($component) $cvar
2328
2329     # Clear the typemethod cache.
2330     # TBD: can we unset just the elements related to
2331     # this component?
2332
2333     # WHD: Namespace 2.0 code
2334     namespace ensemble configure $type -map {}
2335 }
2336
2337 # WHD: Snit 2.0 code
2338 #
2339 # RT.UnknownTypemethod type eId eCmd method args
2340 #
2341 # type          The type
2342 # eId           The ensemble command ID; "" for the instance itself.
2343 # eCmd          The ensemble command name.
2344 # method        The unknown method name.
2345 # args          The additional arguments, if any.
2346 #
2347 # This proc looks up the method relative to the specified ensemble.
2348 # If no method is found, it assumes that the "create" method is
2349 # desired, and that the "method" is the instance name.  In this case,
2350 # it returns the "create" typemethod command with the instance name
2351 # appended; this will cause the instance to be created without updating
2352 # the -map.  If the method is found, the method's command is created and
2353 # added to the -map; the function returns the empty list.
2354
2355 proc snit::RT.UnknownTypemethod {type eId eCmd method args} {
2356     namespace upvar $type \
2357         Snit_typemethodInfo  Snit_typemethodInfo \
2358         Snit_typecomponents  Snit_typecomponents \
2359         Snit_info            Snit_info
2360
2361     # FIRST, get the pattern data and the typecomponent name.
2362     set implicitCreate 0
2363     set instanceName ""
2364
2365     set fullMethod $eId
2366     lappend fullMethod $method
2367     set starredMethod [concat $eId *]
2368     set methodTail $method
2369
2370     if {[info exists Snit_typemethodInfo($fullMethod)]} {
2371         set key $fullMethod
2372     } elseif {[info exists Snit_typemethodInfo($starredMethod)]} {
2373         if {[lsearch -exact $Snit_info(excepttypemethods) $methodTail] == -1} {
2374             set key $starredMethod
2375         } else {
2376             # WHD: The method is explicitly not delegated, so this is an error.
2377             # Or should we treat it as an instance name?
2378             return [list ]
2379         }
2380     } elseif {[llength $fullMethod] > 1} {
2381         return [list ]
2382     } elseif {$Snit_info(hasinstances)} {
2383         # Assume the unknown name is an instance name to create, unless
2384         # this is a widget and the style of the name is wrong, or the
2385         # name mimics a standard typemethod.
2386
2387         if {[set ${type}::Snit_info(isWidget)] &&
2388             ![string match ".*" $method]} {
2389             return [list ]
2390         }
2391
2392         # Without this check, the call "$type info" will redefine the
2393         # standard "::info" command, with disastrous results.  Since it's
2394         # a likely thing to do if !-typeinfo, put in an explicit check.
2395         if {$method eq "info" || $method eq "destroy"} {
2396             return [list ]
2397         }
2398
2399         set implicitCreate 1
2400         set instanceName $method
2401         set key create
2402         set method create
2403     } else {
2404         return [list ]
2405     }
2406
2407     foreach {flag pattern compName} $Snit_typemethodInfo($key) {}
2408
2409     if {$flag == 1} {
2410         # FIRST, define the ensemble command.
2411         lappend eId $method
2412
2413         set newCmd ${type}::Snit_ten[llength $eId]_[join $eId _]
2414
2415         set unknownCmd [list ::snit::RT.UnknownTypemethod \
2416                             $type $eId]
2417
2418         set createCmd [list namespace ensemble create \
2419                            -command $newCmd \
2420                            -unknown $unknownCmd \
2421                            -prefixes 0]
2422
2423         namespace eval $type $createCmd
2424
2425         # NEXT, add the method to the current ensemble
2426         set map [namespace ensemble configure $eCmd -map]
2427
2428         dict append map $method $newCmd
2429
2430         namespace ensemble configure $eCmd -map $map
2431
2432         return [list ]
2433     }
2434
2435     # NEXT, build the substitution list
2436     set subList [list \
2437                      %% % \
2438                      %t $type \
2439                      %M $fullMethod \
2440                      %m [lindex $fullMethod end] \
2441                      %j [join $fullMethod _]]
2442
2443     if {$compName ne ""} {
2444         if {![info exists Snit_typecomponents($compName)]} {
2445             error "$type delegates typemethod \"$method\" to undefined typecomponent \"$compName\""
2446         }
2447
2448         lappend subList %c [list $Snit_typecomponents($compName)]
2449     }
2450
2451     set command {}
2452
2453     foreach subpattern $pattern {
2454         lappend command [string map $subList $subpattern]
2455     }
2456
2457     if {$implicitCreate} {
2458         # In this case, $method is the name of the instance to
2459         # create.  Don't cache, as we usually won't do this one
2460         # again.
2461         lappend command $instanceName
2462         return $command
2463     }
2464
2465
2466     # NEXT, if the actual command name isn't fully qualified,
2467     # assume it's global.
2468     set cmd [lindex $command 0]
2469
2470     if {[string index $cmd 0] ne ":"} {
2471         set command [lreplace $command 0 0 "::$cmd"]
2472     }
2473
2474     # NEXT, update the ensemble map.
2475     set map [namespace ensemble configure $eCmd -map]
2476
2477     dict append map $method $command
2478
2479     namespace ensemble configure $eCmd -map $map
2480
2481     return [list ]
2482 }
2483
2484 #-----------------------------------------------------------------------
2485 # Component Management and Method Caching
2486
2487 # Retrieves the object name given the component name.
2488 proc ::snit::RT.Component {type selfns name} {
2489     variable ${selfns}::Snit_components
2490
2491     if {[catch {set Snit_components($name)} result]} {
2492         variable ${selfns}::Snit_instance
2493
2494         error "component \"$name\" is undefined in $type $Snit_instance"
2495     }
2496
2497     return $result
2498 }
2499
2500 # Component trace; used for write trace on component instance
2501 # variables.  Saves the new component object name, provided
2502 # that certain conditions are met.  Also clears the method
2503 # cache.
2504
2505 proc ::snit::RT.ComponentTrace {type selfns component n1 n2 op} {
2506     namespace upvar $type Snit_info Snit_info
2507     namespace upvar $selfns \
2508         $component      cvar            \
2509         Snit_components Snit_components
2510
2511     # If they try to redefine the hull component after
2512     # it's been defined, that's an error--but only if
2513     # this is a widget or widget adaptor.
2514     if {"hull" == $component &&
2515         $Snit_info(isWidget) &&
2516         [info exists Snit_components($component)]} {
2517         set cvar $Snit_components($component)
2518         error "The hull component cannot be redefined"
2519     }
2520
2521     # Save the new component value.
2522     set Snit_components($component) $cvar
2523
2524     # Clear the instance caches.
2525     # TBD: can we unset just the elements related to
2526     # this component?
2527     RT.ClearInstanceCaches $selfns
2528 }
2529
2530 # WHD: Snit 2.0 code
2531 #
2532 # RT.UnknownMethod type selfns win eId eCmd method args
2533 #
2534 # type       The type or widget command.
2535 # selfns     The instance namespace.
2536 # win        The original instance name.
2537 # eId        The ensemble command ID; "" for the instance itself.
2538 # eCmd       The real ensemble command name
2539 # method     The unknown method name
2540 # args       The additional arguments, if any.
2541 #
2542 # This proc looks up the method relative to the specific ensemble.
2543 # If no method is found, it returns an empty list; this will result in
2544 # the parent ensemble throwing an error.
2545 # If the method is found, the ensemble's -map is extended with the
2546 # correct command, and the empty list is returned; this caches the
2547 # method's command.  If the method is found, and it is also an
2548 # ensemble, the ensemble command is created with an empty map.
2549
2550 proc ::snit::RT.UnknownMethod {type selfns win eId eCmd method args} {
2551     variable ${type}::Snit_info
2552     variable ${type}::Snit_methodInfo
2553     variable ${type}::Snit_typecomponents
2554     variable ${selfns}::Snit_components
2555
2556     # FIRST, get the "self" value
2557     set self [set ${selfns}::Snit_instance]
2558
2559     # FIRST, get the pattern data and the component name.
2560     set fullMethod $eId
2561     lappend fullMethod $method
2562     set starredMethod [concat $eId *]
2563     set methodTail $method
2564
2565     if {[info exists Snit_methodInfo($fullMethod)]} {
2566         set key $fullMethod
2567     } elseif {[info exists Snit_methodInfo($starredMethod)] &&
2568               [lsearch -exact $Snit_info(exceptmethods) $methodTail] == -1} {
2569         set key $starredMethod
2570     } else {
2571         return [list ]
2572     }
2573
2574     foreach {flag pattern compName} $Snit_methodInfo($key) {}
2575
2576     if {$flag == 1} {
2577         # FIRST, define the ensemble command.
2578         lappend eId $method
2579
2580         # Fix provided by Anton Kovalenko; previously this call erroneously
2581         # used ${type} rather than ${selfns}.
2582         set newCmd ${selfns}::Snit_en[llength $eId]_[join $eId _]
2583
2584         set unknownCmd [list ::snit::RT.UnknownMethod \
2585                             $type $selfns $win $eId]
2586
2587         set createCmd [list namespace ensemble create \
2588                            -command $newCmd \
2589                            -unknown $unknownCmd \
2590                            -prefixes 0]
2591
2592         namespace eval $selfns $createCmd
2593
2594         # NEXT, add the method to the current ensemble
2595         set map [namespace ensemble configure $eCmd -map]
2596
2597         dict append map $method $newCmd
2598
2599         namespace ensemble configure $eCmd -map $map
2600
2601         return [list ]
2602     }
2603
2604     # NEXT, build the substitution list
2605     set subList [list \
2606                      %% % \
2607                      %t $type \
2608                      %M $fullMethod \
2609                      %m [lindex $fullMethod end] \
2610                      %j [join $fullMethod _] \
2611                      %n [list $selfns] \
2612                      %w [list $win] \
2613                      %s [list $self]]
2614
2615     if {$compName ne ""} {
2616         if {[info exists Snit_components($compName)]} {
2617             set compCmd $Snit_components($compName)
2618         } elseif {[info exists Snit_typecomponents($compName)]} {
2619             set compCmd $Snit_typecomponents($compName)
2620         } else {
2621             error "$type $self delegates method \"$fullMethod\" to undefined component \"$compName\""
2622         }
2623
2624         lappend subList %c [list $compCmd]
2625     }
2626
2627     # Note: The cached command will execute faster if it's
2628     # already a list.
2629     set command {}
2630
2631     foreach subpattern $pattern {
2632         lappend command [string map $subList $subpattern]
2633     }
2634
2635     # NEXT, if the actual command name isn't fully qualified,
2636     # assume it's global.
2637
2638     set cmd [lindex $command 0]
2639
2640     if {[string index $cmd 0] ne ":"} {
2641         set command [lreplace $command 0 0 "::$cmd"]
2642     }
2643
2644     # NEXT, update the ensemble map.
2645     set map [namespace ensemble configure $eCmd -map]
2646
2647     dict append map $method $command
2648
2649     namespace ensemble configure $eCmd -map $map
2650
2651     return [list ]
2652 }
2653
2654 # Clears all instance command caches
2655 proc ::snit::RT.ClearInstanceCaches {selfns} {
2656     # WHD: clear ensemble -map
2657     if {![info exists ${selfns}::Snit_instance]} {
2658         # Component variable set prior to constructor
2659         # via the "variable" type definition statement.
2660         return
2661     }
2662     set self [set ${selfns}::Snit_instance]
2663     namespace ensemble configure $self -map {}
2664
2665     unset -nocomplain -- ${selfns}::Snit_cgetCache
2666     unset -nocomplain -- ${selfns}::Snit_configureCache
2667     unset -nocomplain -- ${selfns}::Snit_validateCache
2668 }
2669
2670
2671 #-----------------------------------------------------------------------
2672 # Component Installation
2673
2674 # Implements %TYPE%::installhull.  The variables self and selfns
2675 # must be defined in the caller's context.
2676 #
2677 # Installs the named widget as the hull of a
2678 # widgetadaptor.  Once the widget is hijacked, its new name
2679 # is assigned to the hull component.
2680
2681 proc ::snit::RT.installhull {type {using "using"} {widgetType ""} args} {
2682     variable ${type}::Snit_info
2683     variable ${type}::Snit_optionInfo
2684     upvar 1 self self
2685     upvar 1 selfns selfns
2686     namespace upvar $selfns \
2687         hull    hull        \
2688         options options
2689
2690     # FIRST, make sure we can do it.
2691     if {!$Snit_info(isWidget)} {
2692         error "installhull is valid only for snit::widgetadaptors"
2693     }
2694
2695     if {[info exists ${selfns}::Snit_instance]} {
2696         error "hull already installed for $type $self"
2697     }
2698
2699     # NEXT, has it been created yet?  If not, create it using
2700     # the specified arguments.
2701     if {"using" == $using} {
2702         # FIRST, create the widget
2703         set cmd [linsert $args 0 $widgetType $self]
2704         set obj [uplevel 1 $cmd]
2705
2706         # NEXT, for each option explicitly delegated to the hull
2707         # that doesn't appear in the usedOpts list, get the
2708         # option database value and apply it--provided that the
2709         # real option name and the target option name are different.
2710         # (If they are the same, then the option database was
2711         # already queried as part of the normal widget creation.)
2712         #
2713         # Also, we don't need to worry about implicitly delegated
2714         # options, as the option and target option names must be
2715         # the same.
2716         if {[info exists Snit_optionInfo(delegated-hull)]} {
2717
2718             # FIRST, extract all option names from args
2719             set usedOpts {}
2720             set ndx [lsearch -glob $args "-*"]
2721             foreach {opt val} [lrange $args $ndx end] {
2722                 lappend usedOpts $opt
2723             }
2724
2725             foreach opt $Snit_optionInfo(delegated-hull) {
2726                 set target [lindex $Snit_optionInfo(target-$opt) 1]
2727
2728                 if {"$target" == $opt} {
2729                     continue
2730                 }
2731
2732                 set result [lsearch -exact $usedOpts $target]
2733
2734                 if {$result != -1} {
2735                     continue
2736                 }
2737
2738                 set dbval [RT.OptionDbGet $type $self $opt]
2739                 $obj configure $target $dbval
2740             }
2741         }
2742     } else {
2743         set obj $using
2744
2745         if {$obj ne $self} {
2746             error \
2747                 "hull name mismatch: \"$obj\" != \"$self\""
2748         }
2749     }
2750
2751     # NEXT, get the local option defaults.
2752     foreach opt $Snit_optionInfo(local) {
2753         set dbval [RT.OptionDbGet $type $self $opt]
2754
2755         if {"" != $dbval} {
2756             set options($opt) $dbval
2757         }
2758     }
2759
2760
2761     # NEXT, do the magic
2762     set i 0
2763     while 1 {
2764         incr i
2765         set newName "::hull${i}$self"
2766         if {![llength [info commands $newName]]} {
2767             break
2768         }
2769     }
2770
2771     rename ::$self $newName
2772     RT.MakeInstanceCommand $type $selfns $self
2773
2774     # Note: this relies on RT.ComponentTrace to do the dirty work.
2775     set hull $newName
2776
2777     return
2778 }
2779
2780 # Implements %TYPE%::install.
2781 #
2782 # Creates a widget and installs it as the named component.
2783 # It expects self and selfns to be defined in the caller's context.
2784
2785 proc ::snit::RT.install {type compName "using" widgetType winPath args} {
2786     variable ${type}::Snit_optionInfo
2787     variable ${type}::Snit_info
2788     upvar 1 self   self
2789     upvar 1 selfns selfns
2790
2791     namespace upvar ${selfns} \
2792         $compName comp        \
2793         hull      hull
2794
2795     # We do the magic option database stuff only if $self is
2796     # a widget.
2797     if {$Snit_info(isWidget)} {
2798         if {"" == $hull} {
2799             error "tried to install \"$compName\" before the hull exists"
2800         }
2801
2802         # FIRST, query the option database and save the results
2803         # into args.  Insert them before the first option in the
2804         # list, in case there are any non-standard parameters.
2805         #
2806         # Note: there might not be any delegated options; if so,
2807         # don't bother.
2808
2809         if {[info exists Snit_optionInfo(delegated-$compName)]} {
2810             set ndx [lsearch -glob $args "-*"]
2811
2812             foreach opt $Snit_optionInfo(delegated-$compName) {
2813                 set dbval [RT.OptionDbGet $type $self $opt]
2814
2815                 if {"" != $dbval} {
2816                     set target [lindex $Snit_optionInfo(target-$opt) 1]
2817                     set args [linsert $args $ndx $target $dbval]
2818                 }
2819             }
2820         }
2821     }
2822
2823     # NEXT, create the component and save it.
2824     set cmd [concat [list $widgetType $winPath] $args]
2825     set comp [uplevel 1 $cmd]
2826
2827     # NEXT, handle the option database for "delegate option *",
2828     # in widgets only.
2829     if {$Snit_info(isWidget) && $Snit_optionInfo(starcomp) eq $compName} {
2830         # FIRST, get the list of option specs from the widget.
2831         # If configure doesn't work, skip it.
2832         if {[catch {$comp configure} specs]} {
2833             return
2834         }
2835
2836         # NEXT, get the set of explicitly used options from args
2837         set usedOpts {}
2838         set ndx [lsearch -glob $args "-*"]
2839         foreach {opt val} [lrange $args $ndx end] {
2840             lappend usedOpts $opt
2841         }
2842
2843         # NEXT, "delegate option *" matches all options defined
2844         # by this widget that aren't defined by the widget as a whole,
2845         # and that aren't excepted.  Plus, we skip usedOpts.  So build
2846         # a list of the options it can't match.
2847         set skiplist [concat \
2848                           $usedOpts \
2849                           $Snit_optionInfo(except) \
2850                           $Snit_optionInfo(local) \
2851                           $Snit_optionInfo(delegated)]
2852
2853         # NEXT, loop over all of the component's options, and set
2854         # any not in the skip list for which there is an option
2855         # database value.
2856         foreach spec $specs {
2857             # Skip aliases
2858             if {[llength $spec] != 5} {
2859                 continue
2860             }
2861
2862             set opt [lindex $spec 0]
2863
2864             if {[lsearch -exact $skiplist $opt] != -1} {
2865                 continue
2866             }
2867
2868             set res [lindex $spec 1]
2869             set cls [lindex $spec 2]
2870
2871             set dbvalue [option get $self $res $cls]
2872
2873             if {"" != $dbvalue} {
2874                 $comp configure $opt $dbvalue
2875             }
2876         }
2877     }
2878
2879     return
2880 }
2881
2882
2883 #-----------------------------------------------------------------------
2884 # Method/Variable Name Qualification
2885
2886 # Implements %TYPE%::variable.  Requires selfns.
2887 proc ::snit::RT.variable {varname} {
2888     upvar 1 selfns selfns
2889
2890     if {![string match "::*" $varname]} {
2891         uplevel 1 [list upvar 1 ${selfns}::$varname $varname]
2892     } else {
2893         # varname is fully qualified; let the standard
2894         # "variable" command handle it.
2895         uplevel 1 [list ::variable $varname]
2896     }
2897 }
2898
2899 # Fully qualifies a typevariable name.
2900 #
2901 # This is used to implement the mytypevar command.
2902
2903 proc ::snit::RT.mytypevar {type name} {
2904     return ${type}::$name
2905 }
2906
2907 # Fully qualifies an instance variable name.
2908 #
2909 # This is used to implement the myvar command.
2910 proc ::snit::RT.myvar {name} {
2911     upvar 1 selfns selfns
2912     return ${selfns}::$name
2913 }
2914
2915 # Use this like "list" to convert a proc call into a command
2916 # string to pass to another object (e.g., as a -command).
2917 # Qualifies the proc name properly.
2918 #
2919 # This is used to implement the "myproc" command.
2920
2921 proc ::snit::RT.myproc {type procname args} {
2922     set procname "${type}::$procname"
2923     return [linsert $args 0 $procname]
2924 }
2925
2926 # DEPRECATED
2927 proc ::snit::RT.codename {type name} {
2928     return "${type}::$name"
2929 }
2930
2931 # Use this like "list" to convert a typemethod call into a command
2932 # string to pass to another object (e.g., as a -command).
2933 # Inserts the type command at the beginning.
2934 #
2935 # This is used to implement the "mytypemethod" command.
2936
2937 proc ::snit::RT.mytypemethod {type args} {
2938     return [linsert $args 0 $type]
2939 }
2940
2941 # Use this like "list" to convert a method call into a command
2942 # string to pass to another object (e.g., as a -command).
2943 # Inserts the code at the beginning to call the right object, even if
2944 # the object's name has changed.  Requires that selfns be defined
2945 # in the calling context, eg. can only be called in instance
2946 # code.
2947 #
2948 # This is used to implement the "mymethod" command.
2949
2950 proc ::snit::RT.mymethod {args} {
2951     upvar 1 selfns selfns
2952     return [linsert $args 0 ::snit::RT.CallInstance ${selfns}]
2953 }
2954
2955 # Calls an instance method for an object given its
2956 # instance namespace and remaining arguments (the first of which
2957 # will be the method name.
2958 #
2959 # selfns                The instance namespace
2960 # args                  The arguments
2961 #
2962 # Uses the selfns to determine $self, and calls the method
2963 # in the normal way.
2964 #
2965 # This is used to implement the "mymethod" command.
2966
2967 proc ::snit::RT.CallInstance {selfns args} {
2968     namespace upvar $selfns Snit_instance self
2969
2970     set retval [catch {uplevel 1 [linsert $args 0 $self]} result]
2971
2972     if {$retval} {
2973         if {$retval == 1} {
2974             global errorInfo
2975             global errorCode
2976             return -code error -errorinfo $errorInfo \
2977                 -errorcode $errorCode $result
2978         } else {
2979             return -code $retval $result
2980         }
2981     }
2982
2983     return $result
2984 }
2985
2986 # Looks for the named option in the named variable.  If found,
2987 # it and its value are removed from the list, and the value
2988 # is returned.  Otherwise, the default value is returned.
2989 # If the option is undelegated, it's own default value will be
2990 # used if none is specified.
2991 #
2992 # Implements the "from" command.
2993
2994 proc ::snit::RT.from {type argvName option {defvalue ""}} {
2995     namespace upvar $type Snit_optionInfo Snit_optionInfo
2996     upvar $argvName argv
2997
2998     set ioption [lsearch -exact $argv $option]
2999
3000     if {$ioption == -1} {
3001         if {"" == $defvalue &&
3002             [info exists Snit_optionInfo(default-$option)]} {
3003             return $Snit_optionInfo(default-$option)
3004         } else {
3005             return $defvalue
3006         }
3007     }
3008
3009     set ivalue [expr {$ioption + 1}]
3010     set value [lindex $argv $ivalue]
3011
3012     set argv [lreplace $argv $ioption $ivalue]
3013
3014     return $value
3015 }
3016
3017 #-----------------------------------------------------------------------
3018 # Type Destruction
3019
3020 # Implements the standard "destroy" typemethod:
3021 # Destroys a type completely.
3022 #
3023 # type          The snit type
3024
3025 proc ::snit::RT.typemethod.destroy {type} {
3026     variable ${type}::Snit_info
3027
3028     # FIRST, destroy all instances
3029     foreach selfns [namespace children $type "${type}::Snit_inst*"] {
3030         if {![namespace exists $selfns]} {
3031             continue
3032         }
3033
3034         namespace upvar $selfns Snit_instance obj
3035
3036         if {$Snit_info(isWidget)} {
3037             destroy $obj
3038         } else {
3039             if {[llength [info commands $obj]]} {
3040                 $obj destroy
3041             }
3042         }
3043     }
3044
3045     # NEXT, get rid of the type command.
3046     rename $type ""
3047
3048     # NEXT, destroy the type's data.
3049     namespace delete $type
3050 }
3051
3052
3053
3054 #-----------------------------------------------------------------------
3055 # Option Handling
3056
3057 # Implements the standard "cget" method
3058 #
3059 # type          The snit type
3060 # selfns        The instance's instance namespace
3061 # win           The instance's original name
3062 # self          The instance's current name
3063 # option        The name of the option
3064
3065 proc ::snit::RT.method.cget {type selfns win self option} {
3066     if {[catch {set ${selfns}::Snit_cgetCache($option)} command]} {
3067         set command [snit::RT.CacheCgetCommand $type $selfns $win $self $option]
3068
3069         if {[llength $command] == 0} {
3070             return -code error "unknown option \"$option\""
3071         }
3072     }
3073
3074     uplevel 1 $command
3075 }
3076
3077 # Retrieves and caches the command that implements "cget" for the
3078 # specified option.
3079 #
3080 # type          The snit type
3081 # selfns        The instance's instance namespace
3082 # win           The instance's original name
3083 # self          The instance's current name
3084 # option        The name of the option
3085
3086 proc ::snit::RT.CacheCgetCommand {type selfns win self option} {
3087     variable ${type}::Snit_optionInfo
3088     variable ${selfns}::Snit_cgetCache
3089
3090     if {[info exists Snit_optionInfo(islocal-$option)]} {
3091         # We know the item; it's either local, or explicitly delegated.
3092         if {$Snit_optionInfo(islocal-$option)} {
3093             # It's a local option.  If it has a cget method defined,
3094             # use it; otherwise just return the value.
3095
3096             if {$Snit_optionInfo(cget-$option) eq ""} {
3097                 set command [list set ${selfns}::options($option)]
3098             } else {
3099                 # WHD: Snit 2.0 code -- simpler, no slower.
3100                 set command [list \
3101                                  $self \
3102                                  {*}$Snit_optionInfo(cget-$option) \
3103                                  $option]
3104             }
3105
3106             set Snit_cgetCache($option) $command
3107             return $command
3108         }
3109
3110         # Explicitly delegated option; get target
3111         set comp [lindex $Snit_optionInfo(target-$option) 0]
3112         set target [lindex $Snit_optionInfo(target-$option) 1]
3113     } elseif {$Snit_optionInfo(starcomp) ne "" &&
3114               [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
3115         # Unknown option, but unknowns are delegated; get target.
3116         set comp $Snit_optionInfo(starcomp)
3117         set target $option
3118     } else {
3119         return ""
3120     }
3121
3122     # Get the component's object.
3123     set obj [RT.Component $type $selfns $comp]
3124
3125     set command [list $obj cget $target]
3126     set Snit_cgetCache($option) $command
3127
3128     return $command
3129 }
3130
3131 # Implements the standard "configurelist" method
3132 #
3133 # type          The snit type
3134 # selfns        The instance's instance namespace
3135 # win           The instance's original name
3136 # self          The instance's current name
3137 # optionlist    A list of options and their values.
3138
3139 proc ::snit::RT.method.configurelist {type selfns win self optionlist} {
3140     variable ${type}::Snit_optionInfo
3141
3142     foreach {option value} $optionlist {
3143         # FIRST, get the configure command, caching it if need be.
3144         if {[catch {set ${selfns}::Snit_configureCache($option)} command]} {
3145             set command [snit::RT.CacheConfigureCommand \
3146                              $type $selfns $win $self $option]
3147
3148             if {[llength $command] == 0} {
3149                 return -code error "unknown option \"$option\""
3150             }
3151         }
3152
3153         # NEXT, if we have a type-validation object, use it.
3154         # TBD: Should test (islocal-$option) here, but islocal
3155         # isn't defined for implicitly delegated options.
3156         if {[info exists Snit_optionInfo(typeobj-$option)]
3157             && $Snit_optionInfo(typeobj-$option) ne ""} {
3158             if {[catch {
3159                 $Snit_optionInfo(typeobj-$option) validate $value
3160             } result]} {
3161                 return -code error "invalid $option value: $result"
3162             }
3163         }
3164
3165         # NEXT, the caching the configure command also cached the
3166         # validate command, if any.  If we have one, run it.
3167         set valcommand [set ${selfns}::Snit_validateCache($option)]
3168
3169         if {[llength $valcommand]} {
3170             lappend valcommand $value
3171             uplevel 1 $valcommand
3172         }
3173
3174         # NEXT, configure the option with the value.
3175         lappend command $value
3176         uplevel 1 $command
3177     }
3178
3179     return
3180 }
3181
3182 # Retrieves and caches the command that stores the named option.
3183 # Also stores the command that validates the name option if any;
3184 # If none, the validate command is "", so that the cache is always
3185 # populated.
3186 #
3187 # type          The snit type
3188 # selfns        The instance's instance namespace
3189 # win           The instance's original name
3190 # self          The instance's current name
3191 # option        An option name
3192
3193 proc ::snit::RT.CacheConfigureCommand {type selfns win self option} {
3194     variable ${type}::Snit_optionInfo
3195     variable ${selfns}::Snit_configureCache
3196     variable ${selfns}::Snit_validateCache
3197
3198     if {[info exist Snit_optionInfo(islocal-$option)]} {
3199         # We know the item; it's either local, or explicitly delegated.
3200
3201         if {$Snit_optionInfo(islocal-$option)} {
3202             # It's a local option.
3203
3204             # If it's readonly, it throws an error if we're already
3205             # constructed.
3206             if {$Snit_optionInfo(readonly-$option)} {
3207                 if {[set ${selfns}::Snit_iinfo(constructed)]} {
3208                     error "option $option can only be set at instance creation"
3209                 }
3210             }
3211
3212             # If it has a validate method, cache that for later.
3213             if {$Snit_optionInfo(validate-$option) ne ""} {
3214                 # WHD: Snit 2.0 code -- simpler, no slower.
3215                 set command [list \
3216                                  $self \
3217                                  {*}$Snit_optionInfo(validate-$option) \
3218                                  $option]
3219
3220                 set Snit_validateCache($option) $command
3221             } else {
3222                 set Snit_validateCache($option) ""
3223             }
3224
3225             # If it has a configure method defined,
3226             # cache it; otherwise, just set the value.
3227             if {$Snit_optionInfo(configure-$option) eq ""} {
3228                 set command [list set ${selfns}::options($option)]
3229             } else {
3230                 # WHD: Snit 2.0 code -- simpler, no slower.
3231                 set command [list \
3232                                  $self \
3233                                  {*}$Snit_optionInfo(configure-$option) \
3234                                  $option]
3235             }
3236
3237             set Snit_configureCache($option) $command
3238             return $command
3239         }
3240
3241         # Delegated option: get target.
3242         set comp [lindex $Snit_optionInfo(target-$option) 0]
3243         set target [lindex $Snit_optionInfo(target-$option) 1]
3244     } elseif {$Snit_optionInfo(starcomp) != "" &&
3245               [lsearch -exact $Snit_optionInfo(except) $option] == -1} {
3246         # Unknown option, but unknowns are delegated.
3247         set comp $Snit_optionInfo(starcomp)
3248         set target $option
3249     } else {
3250         return ""
3251     }
3252
3253     # There is no validate command in this case; save an empty string.
3254     set Snit_validateCache($option) ""
3255
3256     # Get the component's object
3257     set obj [RT.Component $type $selfns $comp]
3258
3259     set command [list $obj configure $target]
3260     set Snit_configureCache($option) $command
3261
3262     return $command
3263 }
3264
3265 # Implements the standard "configure" method
3266 #
3267 # type          The snit type
3268 # selfns        The instance's instance namespace
3269 # win           The instance's original name
3270 # self          The instance's current name
3271 # args          A list of options and their values, possibly empty.
3272
3273 proc ::snit::RT.method.configure {type selfns win self args} {
3274     # If two or more arguments, set values as usual.
3275     if {[llength $args] >= 2} {
3276         ::snit::RT.method.configurelist $type $selfns $win $self $args
3277         return
3278     }
3279
3280     # If zero arguments, acquire data for each known option
3281     # and return the list
3282     if {[llength $args] == 0} {
3283         set result {}
3284         foreach opt [RT.method.info.options $type $selfns $win $self] {
3285             # Refactor this, so that we don't need to call via $self.
3286             lappend result [RT.GetOptionDbSpec \
3287                                 $type $selfns $win $self $opt]
3288         }
3289
3290         return $result
3291     }
3292
3293     # They want it for just one.
3294     set opt [lindex $args 0]
3295
3296     return [RT.GetOptionDbSpec $type $selfns $win $self $opt]
3297 }
3298
3299
3300 # Retrieves the option database spec for a single option.
3301 #
3302 # type          The snit type
3303 # selfns        The instance's instance namespace
3304 # win           The instance's original name
3305 # self          The instance's current name
3306 # option        The name of an option
3307 #
3308 # TBD: This is a bad name.  What it's returning is the
3309 # result of the configure query.
3310
3311 proc ::snit::RT.GetOptionDbSpec {type selfns win self opt} {
3312     variable ${type}::Snit_optionInfo
3313
3314     namespace upvar $selfns \
3315         Snit_components Snit_components \
3316         options         options
3317
3318     if {[info exists options($opt)]} {
3319         # This is a locally-defined option.  Just build the
3320         # list and return it.
3321         set res $Snit_optionInfo(resource-$opt)
3322         set cls $Snit_optionInfo(class-$opt)
3323         set def $Snit_optionInfo(default-$opt)
3324
3325         return [list $opt $res $cls $def \
3326                     [RT.method.cget $type $selfns $win $self $opt]]
3327     } elseif {[info exists Snit_optionInfo(target-$opt)]} {
3328         # This is an explicitly delegated option.  The only
3329         # thing we don't have is the default.
3330         set res $Snit_optionInfo(resource-$opt)
3331         set cls $Snit_optionInfo(class-$opt)
3332
3333         # Get the default
3334         set logicalName [lindex $Snit_optionInfo(target-$opt) 0]
3335         set comp $Snit_components($logicalName)
3336         set target [lindex $Snit_optionInfo(target-$opt) 1]
3337
3338         if {[catch {$comp configure $target} result]} {
3339             set defValue {}
3340         } else {
3341             set defValue [lindex $result 3]
3342         }
3343
3344         return [list $opt $res $cls $defValue [$self cget $opt]]
3345     } elseif {$Snit_optionInfo(starcomp) ne "" &&
3346               [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
3347         set logicalName $Snit_optionInfo(starcomp)
3348         set target $opt
3349         set comp $Snit_components($logicalName)
3350
3351         if {[catch {set value [$comp cget $target]} result]} {
3352             error "unknown option \"$opt\""
3353         }
3354
3355         if {![catch {$comp configure $target} result]} {
3356             # Replace the delegated option name with the local name.
3357             return [::snit::Expand $result $target $opt]
3358         }
3359
3360         # configure didn't work; return simple form.
3361         return [list $opt "" "" "" $value]
3362     } else {
3363         error "unknown option \"$opt\""
3364     }
3365 }
3366
3367 #-----------------------------------------------------------------------
3368 # Type Introspection
3369
3370 # Implements the standard "info" typemethod.
3371 #
3372 # type          The snit type
3373 # command       The info subcommand
3374 # args          All other arguments.
3375
3376 proc ::snit::RT.typemethod.info {type command args} {
3377     global errorInfo
3378     global errorCode
3379
3380     switch -exact $command {
3381         args        -
3382         body        -
3383         default     -
3384         typevars    -
3385         typemethods -
3386         instances {
3387             # TBD: it should be possible to delete this error
3388             # handling.
3389             set errflag [catch {
3390                 uplevel 1 [linsert $args 0 \
3391                                ::snit::RT.typemethod.info.$command $type]
3392             } result]
3393
3394             if {$errflag} {
3395                 return -code error -errorinfo $errorInfo \
3396                     -errorcode $errorCode $result
3397             } else {
3398                 return $result
3399             }
3400         }
3401         default {
3402             error "\"$type info $command\" is not defined"
3403         }
3404     }
3405 }
3406
3407
3408 # Returns a list of the type's typevariables whose names match a
3409 # pattern, excluding Snit internal variables.
3410 #
3411 # type          A Snit type
3412 # pattern       Optional.  The glob pattern to match.  Defaults
3413 #               to *.
3414
3415 proc ::snit::RT.typemethod.info.typevars {type {pattern *}} {
3416     set result {}
3417     foreach name [info vars "${type}::$pattern"] {
3418         set tail [namespace tail $name]
3419         if {![string match "Snit_*" $tail]} {
3420             lappend result $name
3421         }
3422     }
3423
3424     return $result
3425 }
3426
3427 # Returns a list of the type's methods whose names match a
3428 # pattern.  If "delegate typemethod *" is used, the list may
3429 # not be complete.
3430 #
3431 # type          A Snit type
3432 # pattern       Optional.  The glob pattern to match.  Defaults
3433 #               to *.
3434
3435 proc ::snit::RT.typemethod.info.typemethods {type {pattern *}} {
3436     variable ${type}::Snit_typemethodInfo
3437
3438     # FIRST, get the explicit names, skipping prefixes.
3439     set result {}
3440
3441     foreach name [array names Snit_typemethodInfo -glob $pattern] {
3442         if {[lindex $Snit_typemethodInfo($name) 0] != 1} {
3443             lappend result $name
3444         }
3445     }
3446
3447     # NEXT, add any from the cache that aren't explicit.
3448     # WHD: fixed up to use newstyle method cache/list of subcommands.
3449     if {[info exists Snit_typemethodInfo(*)]} {
3450         # First, remove "*" from the list.
3451         set ndx [lsearch -exact $result "*"]
3452         if {$ndx != -1} {
3453             set result [lreplace $result $ndx $ndx]
3454         }
3455
3456         # Next, get the type's -map
3457         array set typemethodCache [namespace ensemble configure $type -map]
3458
3459         # Next, get matching names from the cache that we don't already
3460         # know about.
3461         foreach name [array names typemethodCache -glob $pattern] {
3462             if {[lsearch -exact $result $name] == -1} {
3463                 lappend result $name
3464             }
3465         }
3466     }
3467
3468     return $result
3469 }
3470
3471 # $type info args
3472 #
3473 # Returns a method's list of arguments. does not work for delegated
3474 # methods, nor for the internal dispatch methods of multi-word
3475 # methods.
3476
3477 proc ::snit::RT.typemethod.info.args {type method} {
3478     upvar ${type}::Snit_typemethodInfo  Snit_typemethodInfo
3479
3480     # Snit_methodInfo: method -> list (flag cmd component)
3481
3482     # flag      : 1 -> internal dispatcher for multi-word method.
3483     #             0 -> regular method
3484     #
3485     # cmd       : template mapping from method to command prefix, may
3486     #             contain placeholders for various pieces of information.
3487     #
3488     # component : is empty for normal methods.
3489
3490     #parray Snit_typemethodInfo
3491
3492     if {![info exists Snit_typemethodInfo($method)]} {
3493         return -code error "Unknown typemethod \"$method\""
3494     }
3495     foreach {flag cmd component} $Snit_typemethodInfo($method) break
3496     if {$flag} {
3497         return -code error "Unknown typemethod \"$method\""
3498     }
3499     if {$component != ""} {
3500         return -code error "Delegated typemethod \"$method\""
3501     }
3502
3503     set map     [list %m $method %j [join $method _] %t $type]
3504     set theproc [lindex [string map $map $cmd] 0]
3505     return [lrange [::info args $theproc] 1 end]
3506 }
3507
3508 # $type info body
3509 #
3510 # Returns a method's body. does not work for delegated
3511 # methods, nor for the internal dispatch methods of multi-word
3512 # methods.
3513
3514 proc ::snit::RT.typemethod.info.body {type method} {
3515     upvar ${type}::Snit_typemethodInfo  Snit_typemethodInfo
3516
3517     # Snit_methodInfo: method -> list (flag cmd component)
3518
3519     # flag      : 1 -> internal dispatcher for multi-word method.
3520     #             0 -> regular method
3521     #
3522     # cmd       : template mapping from method to command prefix, may
3523     #             contain placeholders for various pieces of information.
3524     #
3525     # component : is empty for normal methods.
3526
3527     #parray Snit_typemethodInfo
3528
3529     if {![info exists Snit_typemethodInfo($method)]} {
3530         return -code error "Unknown typemethod \"$method\""
3531     }
3532     foreach {flag cmd component} $Snit_typemethodInfo($method) break
3533     if {$flag} {
3534         return -code error "Unknown typemethod \"$method\""
3535     }
3536     if {$component != ""} {
3537         return -code error "Delegated typemethod \"$method\""
3538     }
3539
3540     set map     [list %m $method %j [join $method _] %t $type]
3541     set theproc [lindex [string map $map $cmd] 0]
3542     return [RT.body [::info body $theproc]]
3543 }
3544
3545 # $type info default
3546 #
3547 # Returns a method's list of arguments. does not work for delegated
3548 # methods, nor for the internal dispatch methods of multi-word
3549 # methods.
3550
3551 proc ::snit::RT.typemethod.info.default {type method aname dvar} {
3552     upvar 1 $dvar def
3553     upvar ${type}::Snit_typemethodInfo  Snit_typemethodInfo
3554
3555     # Snit_methodInfo: method -> list (flag cmd component)
3556
3557     # flag      : 1 -> internal dispatcher for multi-word method.
3558     #             0 -> regular method
3559     #
3560     # cmd       : template mapping from method to command prefix, may
3561     #             contain placeholders for various pieces of information.
3562     #
3563     # component : is empty for normal methods.
3564
3565     #parray Snit_methodInfo
3566
3567     if {![info exists Snit_typemethodInfo($method)]} {
3568         return -code error "Unknown typemethod \"$method\""
3569     }
3570     foreach {flag cmd component} $Snit_typemethodInfo($method) break
3571     if {$flag} {
3572         return -code error "Unknown typemethod \"$method\""
3573     }
3574     if {$component != ""} {
3575         return -code error "Delegated typemethod \"$method\""
3576     }
3577
3578     set map     [list %m $method %j [join $method _] %t $type]
3579     set theproc [lindex [string map $map $cmd] 0]
3580     return [::info default $theproc $aname def]
3581 }
3582
3583 # Returns a list of the type's instances whose names match
3584 # a pattern.
3585 #
3586 # type          A Snit type
3587 # pattern       Optional.  The glob pattern to match
3588 #               Defaults to *
3589 #
3590 # REQUIRE: type is fully qualified.
3591
3592 proc ::snit::RT.typemethod.info.instances {type {pattern *}} {
3593     set result {}
3594
3595     foreach selfns [namespace children $type "${type}::Snit_inst*"] {
3596         namespace upvar $selfns Snit_instance instance
3597
3598         if {[string match $pattern $instance]} {
3599             lappend result $instance
3600         }
3601     }
3602
3603     return $result
3604 }
3605
3606 #-----------------------------------------------------------------------
3607 # Instance Introspection
3608
3609 # Implements the standard "info" method.
3610 #
3611 # type          The snit type
3612 # selfns        The instance's instance namespace
3613 # win           The instance's original name
3614 # self          The instance's current name
3615 # command       The info subcommand
3616 # args          All other arguments.
3617
3618 proc ::snit::RT.method.info {type selfns win self command args} {
3619     switch -exact $command {
3620         args        -
3621         body        -
3622         default     -
3623         type        -
3624         vars        -
3625         options     -
3626         methods     -
3627         typevars    -
3628         typemethods {
3629             set errflag [catch {
3630                 uplevel 1 [linsert $args 0 ::snit::RT.method.info.$command \
3631                                $type $selfns $win $self]
3632             } result]
3633
3634             if {$errflag} {
3635                 global errorInfo
3636                 return -code error -errorinfo $errorInfo $result
3637             } else {
3638                 return $result
3639             }
3640         }
3641         default {
3642             # error "\"$self info $command\" is not defined"
3643             return -code error "\"$self info $command\" is not defined"
3644         }
3645     }
3646 }
3647
3648 # $self info type
3649 #
3650 # Returns the instance's type
3651 proc ::snit::RT.method.info.type {type selfns win self} {
3652     return $type
3653 }
3654
3655 # $self info typevars
3656 #
3657 # Returns the instance's type's typevariables
3658 proc ::snit::RT.method.info.typevars {type selfns win self {pattern *}} {
3659     return [RT.typemethod.info.typevars $type $pattern]
3660 }
3661
3662 # $self info typemethods
3663 #
3664 # Returns the instance's type's typemethods
3665 proc ::snit::RT.method.info.typemethods {type selfns win self {pattern *}} {
3666     return [RT.typemethod.info.typemethods $type $pattern]
3667 }
3668
3669 # Returns a list of the instance's methods whose names match a
3670 # pattern.  If "delegate method *" is used, the list may
3671 # not be complete.
3672 #
3673 # type          A Snit type
3674 # selfns        The instance namespace
3675 # win           The original instance name
3676 # self          The current instance name
3677 # pattern       Optional.  The glob pattern to match.  Defaults
3678 #               to *.
3679
3680 proc ::snit::RT.method.info.methods {type selfns win self {pattern *}} {
3681     variable ${type}::Snit_methodInfo
3682
3683     # FIRST, get the explicit names, skipping prefixes.
3684     set result {}
3685
3686     foreach name [array names Snit_methodInfo -glob $pattern] {
3687         if {[lindex $Snit_methodInfo($name) 0] != 1} {
3688             lappend result $name
3689         }
3690     }
3691
3692     # NEXT, add any from the cache that aren't explicit.
3693     # WHD: Fixed up to use newstyle method cache/list of subcommands.
3694     if {[info exists Snit_methodInfo(*)]} {
3695         # First, remove "*" from the list.
3696         set ndx [lsearch -exact $result "*"]
3697         if {$ndx != -1} {
3698             set result [lreplace $result $ndx $ndx]
3699         }
3700
3701         # Next, get the instance's -map
3702         set self [set ${selfns}::Snit_instance]
3703
3704         array set methodCache [namespace ensemble configure $self -map]
3705
3706         # Next, get matching names from the cache that we don't already
3707         # know about.
3708         foreach name [array names methodCache -glob $pattern] {
3709             if {[lsearch -exact $result $name] == -1} {
3710                 lappend result $name
3711             }
3712         }
3713     }
3714
3715     return $result
3716 }
3717
3718 # $self info args
3719 #
3720 # Returns a method's list of arguments. does not work for delegated
3721 # methods, nor for the internal dispatch methods of multi-word
3722 # methods.
3723
3724 proc ::snit::RT.method.info.args {type selfns win self method} {
3725
3726     upvar ${type}::Snit_methodInfo  Snit_methodInfo
3727
3728     # Snit_methodInfo: method -> list (flag cmd component)
3729
3730     # flag      : 1 -> internal dispatcher for multi-word method.
3731     #             0 -> regular method
3732     #
3733     # cmd       : template mapping from method to command prefix, may
3734     #             contain placeholders for various pieces of information.
3735     #
3736     # component : is empty for normal methods.
3737
3738     #parray Snit_methodInfo
3739
3740     if {![info exists Snit_methodInfo($method)]} {
3741         return -code error "Unknown method \"$method\""
3742     }
3743     foreach {flag cmd component} $Snit_methodInfo($method) break
3744     if {$flag} {
3745         return -code error "Unknown method \"$method\""
3746     }
3747     if {$component != ""} {
3748         return -code error "Delegated method \"$method\""
3749     }
3750
3751     set map     [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
3752     set theproc [lindex [string map $map $cmd] 0]
3753     return [lrange [::info args $theproc] 4 end]
3754 }
3755
3756 # $self info body
3757 #
3758 # Returns a method's body. does not work for delegated
3759 # methods, nor for the internal dispatch methods of multi-word
3760 # methods.
3761
3762 proc ::snit::RT.method.info.body {type selfns win self method} {
3763
3764     upvar ${type}::Snit_methodInfo  Snit_methodInfo
3765
3766     # Snit_methodInfo: method -> list (flag cmd component)
3767
3768     # flag      : 1 -> internal dispatcher for multi-word method.
3769     #             0 -> regular method
3770     #
3771     # cmd       : template mapping from method to command prefix, may
3772     #             contain placeholders for various pieces of information.
3773     #
3774     # component : is empty for normal methods.
3775
3776     #parray Snit_methodInfo
3777
3778     if {![info exists Snit_methodInfo($method)]} {
3779         return -code error "Unknown method \"$method\""
3780     }
3781     foreach {flag cmd component} $Snit_methodInfo($method) break
3782     if {$flag} {
3783         return -code error "Unknown method \"$method\""
3784     }
3785     if {$component != ""} {
3786         return -code error "Delegated method \"$method\""
3787     }
3788
3789     set map     [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
3790     set theproc [lindex [string map $map $cmd] 0]
3791     return [RT.body [::info body $theproc]]
3792 }
3793
3794 # $self info default
3795 #
3796 # Returns a method's list of arguments. does not work for delegated
3797 # methods, nor for the internal dispatch methods of multi-word
3798 # methods.
3799
3800 proc ::snit::RT.method.info.default {type selfns win self method aname dvar} {
3801     upvar 1 $dvar def
3802     upvar ${type}::Snit_methodInfo  Snit_methodInfo
3803
3804     # Snit_methodInfo: method -> list (flag cmd component)
3805
3806     # flag      : 1 -> internal dispatcher for multi-word method.
3807     #             0 -> regular method
3808     #
3809     # cmd       : template mapping from method to command prefix, may
3810     #             contain placeholders for various pieces of information.
3811     #
3812     # component : is empty for normal methods.
3813
3814     if {![info exists Snit_methodInfo($method)]} {
3815         return -code error "Unknown method \"$method\""
3816     }
3817     foreach {flag cmd component} $Snit_methodInfo($method) break
3818     if {$flag} {
3819         return -code error "Unknown method \"$method\""
3820     }
3821     if {$component != ""} {
3822         return -code error "Delegated method \"$method\""
3823     }
3824
3825     set map     [list %m $method %j [join $method _] %t $type %n $selfns %w $win %s $self]
3826     set theproc [lindex [string map $map $cmd] 0]
3827     return [::info default $theproc $aname def]
3828 }
3829
3830 # $self info vars
3831 #
3832 # Returns the instance's instance variables
3833 proc ::snit::RT.method.info.vars {type selfns win self {pattern *}} {
3834     set result {}
3835     foreach name [info vars "${selfns}::$pattern"] {
3836         set tail [namespace tail $name]
3837         if {![string match "Snit_*" $tail]} {
3838             lappend result $name
3839         }
3840     }
3841
3842     return $result
3843 }
3844
3845 # $self info options
3846 #
3847 # Returns a list of the names of the instance's options
3848 proc ::snit::RT.method.info.options {type selfns win self {pattern *}} {
3849     variable ${type}::Snit_optionInfo
3850
3851     # First, get the local and explicitly delegated options
3852     set result [concat $Snit_optionInfo(local) $Snit_optionInfo(delegated)]
3853
3854     # If "configure" works as for Tk widgets, add the resulting
3855     # options to the list.  Skip excepted options
3856     if {$Snit_optionInfo(starcomp) ne ""} {
3857         namespace upvar $selfns Snit_components Snit_components
3858
3859         set logicalName $Snit_optionInfo(starcomp)
3860         set comp $Snit_components($logicalName)
3861
3862         if {![catch {$comp configure} records]} {
3863             foreach record $records {
3864                 set opt [lindex $record 0]
3865                 if {[lsearch -exact $result $opt] == -1 &&
3866                     [lsearch -exact $Snit_optionInfo(except) $opt] == -1} {
3867                     lappend result $opt
3868                 }
3869             }
3870         }
3871     }
3872
3873     # Next, apply the pattern
3874     set names {}
3875
3876     foreach name $result {
3877         if {[string match $pattern $name]} {
3878             lappend names $name
3879         }
3880     }
3881
3882     return $names
3883 }
3884
3885 proc ::snit::RT.body {body} {
3886     regsub -all ".*# END snit method prolog\n" $body {} body
3887     return $body
3888 }