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