snit/main1_83.tcl

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