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