snit/main1.tcl

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