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