1## Barebones requirements for creating and querying megawidgets 2## 3## Copyright 1997-8 Jeffrey Hobbs, jeff.hobbs@acm.org 4## 5## Initiated: 5 June 1997 6## Last Update: 1998 7## Modified by Kish Shen, June 1999: 8## Added widget_name to data array for use by hierarchy widget. container has 9## an extra . in the name 10 11package require Tk 8 12package require ::Utility 13package provide Widget 2.0 14 15##------------------------------------------------------------------------ 16## PROCEDURE 17## widget 18## 19## DESCRIPTION 20## Implements and modifies megawidgets 21## 22## ARGUMENTS 23## widget <subcommand> ?<args>? 24## 25## <classname> specifies a global array which is the name of a class and 26## contains options database information. 27## 28## add classname option ?args? 29## adds ... 30## 31## create classname 32## creates the widget class $classname based on the specifications 33## in the global array of the same name 34## 35## classes ?pattern? 36## returns the classes created with this command. 37## 38## delete classname option ?args? 39## deletes ... 40## 41## value classname key 42## returns the value of a key from the special class variable. 43## 44## OPTIONS 45## none 46## 47## RETURNS 48## the namespace for the widget class (::Widget::$CLASS) 49## 50## NAMESPACE & STATE 51## The namespace Widget is used, with public procedure "widget". 52## 53##------------------------------------------------------------------------ 54## 55## For a well-commented example for creating a megawidget using this method, 56## see the ScrolledText example at the end of the file. 57## 58## SHORT LIST OF IMPORTANT THINGS TO KNOW: 59## 60## Specify the "type", "base", & "components" keys of the $CLASS global array 61## 62## In the $w global array that is created for each instance of a megawidget, 63## the following keys are set by the "widget create $CLASS" procedure: 64## "base", "basecmd", "container", "class", any option specified in the 65## $CLASS array, each component will have a named key 66## 67## The following public methods are created for you in the namespace: 68## cget ::Widget::$CLASS::_cget 69## configure ::Widget::$CLASS::_configure 70## destruct ::Widget::$CLASS::_destruct 71## subwidget ::Widget::$CLASS::_subwidget 72## The following additional submethods are required (you write them): 73## construct ::Widget::$CLASS::construct 74## configure ::Widget::$CLASS::configure 75## You may want the following that will be called when appropriate: 76## init ::Widget::$CLASS::init 77## (after initial configuration) 78## destruct ::Widget::$CLASS::destruct 79## (called first thing when widget is being destroyed) 80## 81## All ::Widget::$CLASS::_* commands are considered public methods. The 82## megawidget routine will match your options and methods on a unique 83## substring basis. 84## 85## END OF SHORT LIST 86 87 88## Dummy call for indexers 89proc widget args {} 90 91namespace eval ::Widget {; 92 93namespace export -clear widget 94variable CLASSES 95variable CONTAINERS {frame toplevel} 96namespace import -force ::Utility::get_opts* 97 98;proc widget {cmd args} { 99 ## Establish the prefix of public commands 100 set prefix [namespace current]::_ 101 if {[string match {} [set arg [info commands $prefix$cmd]]]} { 102 set arg [info commands $prefix$cmd*] 103 } 104 switch [llength $arg] { 105 1 { return [uplevel $arg $args] } 106 0 { 107 set arg [info commands $prefix*] 108 regsub -all $prefix $arg {} arg 109 return -code error "unknown [lindex [info level 0] 0] method\ 110 \"$cmd\", must be one of: [join [lsort $arg] {, }]" 111 } 112 default { 113 regsub -all $prefix $arg {} arg 114 return -code error "ambiguous method \"$cmd\",\ 115 could be one of: [join [lsort $arg] {, }]" 116 } 117 } 118} 119 120;proc verify_class {CLASS} { 121 variable CLASSES 122 if {![info exists CLASSES($CLASS)]} { 123 return -code error "no known class \"$CLASS\"" 124 } 125 return 126} 127 128;proc _add {CLASS what args} { 129 variable CLASSES 130 verify_class $CLASS 131 if {[string match ${what}* options]} { 132 add_options $CLASSES($CLASS) $CLASS $args 133 } else { 134 return -code error "unknown type for add, must be one of:\ 135 options, components" 136 } 137} 138 139;proc _find_class {CLASS {root .}} { 140 if {[string match $CLASS [winfo class $root]]} { 141 return $root 142 } else { 143 foreach w [winfo children $root] { 144 set w [_find_class $CLASS $w] 145 if {[string compare {} $w]} { 146 return $w 147 } 148 } 149 } 150} 151 152;proc _delete {CLASS what args} { 153 variable CLASSES 154 verify_class $CLASS 155} 156 157;proc _classes {{pattern "*"}} { 158 variable CLASSES 159 return [array names CLASSES $pattern] 160} 161 162;proc _value {CLASS key} { 163 variable CLASSES 164 verify_class $CLASS 165 upvar \#0 $CLASSES($CLASS)::class class 166 if {[info exists class($key)]} { 167 return $class($key) 168 } else { 169 return -code error "unknown key \"$key\" in class \"$CLASS\"" 170 } 171} 172 173## handle 174## Handles the method calls for a widget. This is the command to which 175## all megawidget dummy commands are redirected for interpretation. 176## 177;proc handle {namesp w subcmd args} { 178 upvar \#0 ${namesp}::$w data 179 if {[string match {} [set arg [info commands ${namesp}::_$subcmd]]]} { 180 set arg [info commands ${namesp}::_$subcmd*] 181 } 182 set num [llength $arg] 183 if {$num==1} { 184 return [uplevel $arg [list $w] $args] 185 } elseif {$num} { 186 regsub -all "${namesp}::_" $arg {} arg 187 return -code error "ambiguous method \"$subcmd\",\ 188 could be one of: [join $arg {, }]" 189 } elseif {[catch {uplevel [list $data(basecmd) $subcmd] $args} err]} { 190 return -code error $err 191 } else { 192 return $err 193 } 194} 195 196## construct 197## Constructs the megawidget instance instantiation proc based on the 198## current knowledge of the megawidget. 199## 200;proc construct {namesp CLASS} { 201 upvar \#0 ${namesp}::class class \ 202 ${namesp}::components components 203 204 lappend dataArrayVals [list class $CLASS] 205 if {[string compare $class(type) $class(base)]} { 206 ## If -type and -base don't match, we need a special setup 207 lappend dataArrayVals "base \$w.[list [lindex $components(base) 1]]" \ 208 "basecmd ${namesp}::\$w.[list [lindex $components(base) 1]]" \ 209 "container ${namesp}::.\$w" \ 210 "widget_name \$w" 211 ## If the base widget is not the container, then we want to rename 212 ## its widget commands and add the CLASS and container bind tables 213 ## to its bindtags in case certain bindings are made 214 ## Interp alias is the optimal solution, but exposes 215 ## a bug in Tcl7/8 when renaming aliases 216 #interp alias {} \$base {} ::Widget::handle $namesp \$w 217 set renamingCmd "rename \$base \$data(basecmd) 218 ;proc ::\$base args \"uplevel ::Widget::handle $namesp \[list \$w\] \\\$args\" 219 bindtags \$base \[linsert \[bindtags \$base\] 1\ 220 [expr {[string match toplevel $class(type)]?{}:{$w}}] $CLASS\]" 221 } else { 222 ## -type and -base are the same, we only create for one 223 lappend dataArrayVals "base \$w" \ 224 "basecmd ${namesp}::\$w" \ 225 "container ${namesp}::\$w" \ 226 "widget_name \$w" 227 if {[string compare {} [lindex $components(base) 3]]} { 228 lappend dataArrayVals "[lindex $components(base) 3] \$w" 229 } 230 ## When the base widget and container are the same, we have a 231 ## straightforward renaming of commands 232 set renamingCmd {} 233 } 234 set baseConstruction {} 235 foreach name [array names components] { 236 if {[string match base $name]} { 237 continue 238 } 239 foreach {type wid opts} $components($name) break 240 lappend dataArrayVals "[list $name] \$w.[list $wid]" 241 lappend baseConstruction "$type \$w.[list $wid] $opts" 242 if {[string match toplevel $type]} { 243 lappend baseConstruction "wm withdraw \$data($name)" 244 } 245 } 246 set dataArrayVals [join $dataArrayVals " \\\n\t"] 247 ## the lsort ensure that parents are created before children 248 set baseConstruction [join [lsort -index 1 $baseConstruction] "\n "] 249 250 ## More of this proc could be configured ahead of time for increased 251 ## construction speed. It's delicate, so handle with extreme care. 252 ;proc ${namesp}::$CLASS {w args} [subst { 253 variable options 254 upvar \#0 ${namesp}::\$w data 255 $class(type) \$w -class $CLASS 256 [expr [string match toplevel $class(type)]?{wm withdraw \$w\n}:{}] 257 ## Populate data array with user definable options 258 foreach o \[array names options\] { 259 if {\[string match -* \$options(\$o)\]} continue 260 set data(\$o) \[option get \$w \[lindex \$options(\$o) 0\] $CLASS\] 261 } 262 263 ## Populate the data array 264 array set data \[list $dataArrayVals\] 265 ## Create all the base and component widgets 266 $baseConstruction 267 268 ## Allow for an initialization proc to be eval'ed 269 ## The user must create one 270 if {\[catch {construct \$w} err\]} { 271 catch {_destruct \$w} 272 return -code error \"megawidget construction error: \$err\" 273 } 274 275 set base \$data(base) 276 rename \$w \$data(container) 277 $renamingCmd 278 ;proc ::\$w args \"uplevel ::Widget::handle $namesp \[list \$w\] \\\$args\" 279 #interp alias {} \$w {} ::Widget::handle $namesp \$w 280 281 ## Do the configuring here and eval the post initialization procedure 282 if {(\[string compare {} \$args\] && \ 283 \[catch {uplevel 1 ${namesp}::_configure \$w \$args} err\]) || \ 284 \[catch {${namesp}::init \$w} err\]} { 285 catch { ${namesp}::_destruct \$w } 286 return -code error \"megawidget initialization error: \$err\" 287 } 288 289 return \$w 290 } 291 ] 292} 293 294;proc add_options {namesp CLASS optlist} { 295 upvar \#0 ${namesp}::class class \ 296 ${namesp}::options options \ 297 ${namesp}::widgets widgets 298 ## Go through the option definition, substituting for ALIAS where 299 ## necessary and setting up the options database for this $CLASS 300 ## There are several possible formats: 301 ## 1. -optname -optnamealias 302 ## 2. -optname dbname dbcname value 303 ## 3. -optname ALIAS componenttype option 304 ## 4. -optname ALIAS componenttype option dbname dbcname 305 foreach optdef $optlist { 306 foreach {optname alias type opt dbname dbcname} $optdef break 307 set len [llength $optdef] 308 switch -glob -- $alias { 309 -* { 310 if {$len != 2} { 311 return -code error "wrong \# args for option alias,\ 312 must be: {-aliasoptioname -realoptionname}" 313 } 314 set options($optname) $alias 315 continue 316 } 317 ALIAS - alias { 318 if {$len != 4 && $len != 6} { 319 return -code error "wrong \# args for ALIAS, must be:\ 320 {-optionname ALIAS componenttype option\ 321 ?databasename databaseclass?}" 322 } 323 if {![info exists widgets($type)]} { 324 return -code error "cannot create alias \"$optname\" to\ 325 $CLASS component type \"$type\" option \"$opt\":\ 326 component type does not exist" 327 } elseif {![info exists config($type)]} { 328 if {[string compare toplevel $type]} { 329 set w .__widget__$type 330 catch {destroy $w} 331 ## Make sure the component widget type exists, 332 ## returns the widget name, 333 ## and accepts configure as a subcommand 334 if {[catch {$type $w} result] || \ 335 [string compare $result $w] || \ 336 [catch {$w configure} config($type)]} { 337 ## Make sure we destroy it if it was a bad widget 338 catch {destroy $w} 339 ## Or rename it if it was a non-widget command 340 catch {rename $w {}} 341 return -code error "invalid widget type \"$type\"" 342 } 343 catch {destroy $w} 344 } else { 345 set config($type) [. configure] 346 } 347 } 348 set i [lsearch -glob $config($type) "$opt\[ \t\]*"] 349 if {$i == -1} { 350 return -code error "cannot create alias \"$o\" to $CLASS\ 351 component type \"$type\" option \"$opt\":\ 352 option does not exist" 353 } 354 if {$len==4} { 355 foreach {opt dbname dbcname def} \ 356 [lindex $config($type) $i] break 357 } elseif {$len==6} { 358 set def [lindex [lindex $config($type) $i] 3] 359 } 360 } 361 default { 362 if {$len != 4} { 363 return -code error "wrong \# args for option \"$optdef\",\ 364 must be:\ 365 {-optioname databasename databaseclass defaultval}" 366 } 367 foreach {optname dbname dbcname def} $optdef break 368 } 369 } 370 set options($optname) [list $dbname $dbcname $def] 371 option add *$CLASS.$dbname $def widgetDefault 372 } 373} 374 375;proc _create {CLASS args} { 376 if {![string match {[A-Z]*} $CLASS] || [string match { } $CLASS]} { 377 return -code error "invalid class name \"$CLASS\": it must begin\ 378 with a capital letter and contain no spaces" 379 } 380 381 variable CONTAINERS 382 variable CLASSES 383 set namesp [namespace current]::$CLASS 384 namespace eval $namesp { 385 variable class 386 variable options 387 variable components 388 variable widgets 389 catch {unset class} 390 catch {unset options} 391 catch {unset components} 392 catch {unset widgets} 393 } 394 upvar \#0 ${namesp}::class class \ 395 ${namesp}::options options \ 396 ${namesp}::components components \ 397 ${namesp}::widgets widgets 398 399 get_opts2 classopts $args { 400 -type frame 401 -base frame 402 -components {} 403 -options {} 404 } { 405 -type list 406 -base list 407 -components list 408 -options list 409 } 410 411 ## First check to see that their container type is valid 412 ## I'd like to include canvas and text, but they don't accept the 413 ## -class option yet, which would thus require some voodoo on the 414 ## part of the constructor to make it think it was the proper class 415 if {![regexp ^([join $CONTAINERS |])\$ $classopts(-type)]} { 416 return -code error "invalid class container type\ 417 \"$classopts(-type)\", must be one of:\ 418 [join $CONTAINERS {, }]" 419 } 420 421 ## Then check to see that their base widget type is valid 422 ## We will create a default widget of the appropriate type just in 423 ## case they use the DEFAULT keyword as a default value in their 424 ## megawidget class definition 425 if {[info exists classopts(-base)]} { 426 ## We check to see that we can create the base, that it returns 427 ## the same widget value we put in, and that it accepts cget. 428 if {[string match toplevel $classopts(-base)] && \ 429 [string compare toplevel $classopts(-type)]} { 430 return -code error "\"toplevel\" is not allowed as the base\ 431 widget of a megawidget (perhaps you intended it to\ 432 be the class type)" 433 } 434 } else { 435 ## The container is the default base widget 436 set classopts(-base) $classopts(-type) 437 } 438 439 ## Ensure that the class is set correctly 440 array set class [list class $CLASS \ 441 base $classopts(-base) \ 442 type $classopts(-type)] 443 444 set widgets($class(type)) 0 445 446 if {![info exists classopts(-components)]} { 447 set classopts(-components) {} 448 } 449 foreach compdef $classopts(-components) { 450 set opts {} 451 switch [llength $compdef] { 452 0 continue 453 1 { set name [set type [set wid $compdef]] } 454 2 { 455 set type [lindex $compdef 0] 456 set name [set wid [lindex $compdef 1]] 457 } 458 default { 459 foreach {type name wid opts} $compdef break 460 set opts [string trim $opts] 461 } 462 } 463 if {[info exists components($name)]} { 464 return -code error "component name \"$name\" occurs twice\ 465 in $CLASS class" 466 } 467 if {[info exists widnames($wid)]} { 468 return -code error "widget name \"$wid\" occurs twice\ 469 in $CLASS class" 470 } 471 if {[regexp {(^[\.A-Z]| |\.$)} $wid]} { 472 return -code error "invalid $CLASS class component widget\ 473 name \"$wid\": it cannot begin with a capital letter,\ 474 contain spaces or start or end with a \".\"" 475 } 476 if {[string match *.* $wid] && \ 477 ![info exists widnames([file root $wid])]} { 478 ## If the widget name contains a '.', then make sure we will 479 ## have created all the parents first. [file root $wid] is 480 ## a cheap trick to remove the last .child string from $wid 481 return -code error "no specified parent for $CLASS class\ 482 component widget name \"$wid\"" 483 } 484 if {[string match base $type]} { 485 set type $class(base) 486 set components(base) [list $type $wid $opts $name] 487 if {[string match $type $class(type)]} continue 488 } 489 set components($name) [list $type $wid $opts] 490 set widnames($wid) 0 491 set widgets($type) 0 492 } 493 if {![info exists components(base)]} { 494 set components(base) [list $class(base) $class(base) {}] 495 # What should we really do here? 496 #set components($class(base)) $components(base) 497 set widgets($class(base)) 0 498 if {![regexp ^([join $CONTAINERS |])\$ $class(base)] && \ 499 ![info exists components($class(base))]} { 500 set components($class(base)) $components(base) 501 } 502 } 503 504 ## Process options 505 add_options $namesp $CLASS $classopts(-options) 506 507 namespace eval $namesp { 508 set CLASS [namespace tail [namespace current]] 509 ## The _destruct must occur to remove excess state elements. 510 ## The [winfo class %W] will work in this Destroy, which is necessary 511 ## to determine if we are destroying the actual megawidget container. 512 bind $CLASS <Destroy> [namespace code { 513 if {[string compare {} [::widget classes [::winfo class %W]]]} { 514 if [catch {_destruct %W} err] { puts $err } 515 } 516 }] 517 } 518 ## This creates the basic constructor procedure for the class 519 ## as ${namesp}::$CLASS 520 construct $namesp $CLASS 521 522 ## Both $CLASS and [string tolower $CLASS] commands will be created 523 ## in the global namespace 524 namespace eval $namesp [list namespace export -clear $CLASS] 525 namespace eval :: [list namespace import -force ${namesp}::$CLASS] 526 interp alias {} ::[string tolower $CLASS] {} ::$CLASS 527 528 ## These are provided so that errors due to lack of the command 529 ## existing don't arise. Since they are stubbed out here, the 530 ## user can't depend on 'unknown' or 'auto_load' to get this proc. 531 if {[string match {} [info commands ${namesp}::construct]]} { 532 ;proc ${namesp}::construct {w} { 533 # the user should rewrite this 534 # without the following error, a simple megawidget that was just 535 # a frame would be created by default 536 return -code error "user must write their own\ 537 [lindex [info level 0] 0] function" 538 } 539 } 540 if {[string match {} [info commands ${namesp}::init]]} { 541 ;proc ${namesp}::init {w} { 542 # the user should rewrite this 543 } 544 } 545 546 ## The user is not supposed to change this proc 547 set comps [lsort [array names components]] 548 ;proc ${namesp}::_subwidget {w {widget return} args} [subst { 549 variable \$w 550 upvar 0 \$w data 551 switch -- \$widget { 552 return { 553 return [list $comps] 554 } 555 all { 556 if {\[string compare {} \$args\]} { 557 foreach sub [list $comps] { 558 catch {uplevel 1 \[list \$data(\$sub)\] \$args} 559 } 560 } else { 561 return [list $comps] 562 } 563 } 564 [join $comps { - }] { 565 if {\[string compare {} \$args\]} { 566 return \[uplevel 1 \[list \$data(\$widget)\] \$args\] 567 } else { 568 return \$data(\$widget) 569 } 570 } 571 default { 572 return -code error \"No \$data(class) subwidget \\\"\$widget\\\",\ 573 must be one of: [join $comps {, }]\" 574 } 575 } 576 }] 577 578 ## The user is not supposed to change this proc 579 ## Instead they create a ::Widget::$CLASS::destruct proc 580 ## Some of this may be redundant, but at least it does the job 581 ;proc ${namesp}::_destruct {w} " 582 upvar \#0 ${namesp}::\$w data 583 catch {${namesp}::destruct \$w} 584 catch {::destroy \$data(base)} 585 catch {::destroy \$w} 586 catch {rename \$data(basecmd) {}} 587 catch {rename ::\$data(base) {}} 588 catch {rename ::\$w {}} 589 catch {unset data} 590 return\n" 591 592 if {[string match {} [info commands ${namesp}::destruct]]} { 593 ## The user can optionally provide a special destroy handler 594 ;proc ${namesp}::destruct {w args} { 595 # empty 596 } 597 } 598 599 ## The user is not supposed to change this proc 600 ;proc ${namesp}::_cget {w args} { 601 if {[llength $args] != 1} { 602 return -code error "wrong \# args: should be \"$w cget option\"" 603 } 604 set namesp [namespace current] 605 upvar \#0 ${namesp}::$w data ${namesp}::options options 606 if {[info exists options($args)]&&[string match -* $options($args)]} { 607 set args $options($args) 608 } 609 if {[string match {} [set arg [array names data $args]]]} { 610 set arg [array names data ${args}*] 611 } 612 set num [llength $arg] 613 if {$num==1} { 614 return $data($arg) 615 } elseif {$num} { 616 return -code error "ambiguous option \"$args\",\ 617 must be one of: [join $arg {, }]" 618 } elseif {[catch {$data(basecmd) cget $args} err]} { 619 return -code error $err 620 } else { 621 return $err 622 } 623 } 624 625 ## The user is not supposed to change this proc 626 ## Instead they create a $CLASS:configure proc 627 ;proc ${namesp}::_configure {w args} { 628 set namesp [namespace current] 629 upvar \#0 ${namesp}::$w data ${namesp}::options options 630 631 set num [llength $args] 632 if {$num==1} { 633 if {[info exists options($args)] && \ 634 [string match -* $options($args)]} { 635 set args $options($args) 636 } 637 if {[string match {} [set arg [array names data $args]]]} { 638 set arg [array names data ${args}*] 639 } 640 set num [llength $arg] 641 if {$num==1} { 642 ## FIX one-elem config 643 return "[list $arg] $options($arg) [list $data($arg)]" 644 } elseif {$num} { 645 return -code error "ambiguous option \"$args\",\ 646 must be one of: [join $arg {, }]" 647 } elseif {[catch {$data(basecmd) configure $args} err]} { 648 return -code error $err 649 } else { 650 return $err 651 } 652 } elseif {$num} { 653 ## Group the {key val} pairs to be distributed 654 if {$num&1} { 655 set last [lindex $args end] 656 set args [lrange $args 0 [incr num -2]] 657 } 658 set widargs {} 659 set cmdargs {} 660 foreach {key val} $args { 661 if {[info exists options($key)] && \ 662 [string match -* $options($key)]} { 663 set key $options($key) 664 } 665 if {[string match {} [set arg [array names data $key]]]} { 666 set arg [array names data $key*] 667 } 668 set len [llength $arg] 669 if {$len==1} { 670 lappend widargs $arg $val 671 } elseif {$len} { 672 set ambarg [list $key $arg] 673 break 674 } else { 675 lappend cmdargs $key $val 676 } 677 } 678 if {[string compare {} $widargs]} { 679 uplevel ${namesp}::configure [list $w] $widargs 680 } 681 if {[string compare {} $cmdargs] && [catch \ 682 {uplevel [list $data(basecmd)] configure $cmdargs} err]} { 683 return -code error $err 684 } 685 if {[info exists ambarg]} { 686 return -code error "ambiguous option \"[lindex $ambarg 0]\",\ 687 must be one of: [join [lindex $ambarg 1] {, }]" 688 } 689 if {[info exists last]} { 690 return -code error "value for \"$last\" missing" 691 } 692 } else { 693 foreach opt [$data(basecmd) configure] { 694 set opts([lindex $opt 0]) [lrange $opt 1 end] 695 } 696 foreach opt [array names options] { 697 if {[string match -* $options($opt)]} { 698 set opts($opt) [string range $options($opt) 1 end] 699 } else { 700 set opts($opt) "$options($opt) [list $data($opt)]" 701 } 702 } 703 foreach opt [lsort [array names opts]] { 704 lappend config "$opt $opts($opt)" 705 } 706 return $config 707 } 708 } 709 710 if {[string match {} [info commands ${namesp}::configure]]} { 711 ## The user is intended to rewrite this one 712 ;proc ${namesp}::configure {w args} { 713 foreach {key val} $args { 714 puts "$w: configure $key to [list $value]" 715 } 716 } 717 } 718 719 set CLASSES($CLASS) $namesp 720 return $namesp 721} 722 723}; #end namespace ::Widget 724 725namespace eval :: { namespace import -force ::Widget::widget } 726 727######################################################################## 728########################## EXAMPLES #################################### 729######################################################################## 730 731######################################################################## 732########################## ScrolledText ################################ 733######################################################################## 734 735##------------------------------------------------------------------------ 736## PROCEDURE 737## scrolledtext 738## 739## DESCRIPTION 740## Implements a ScrolledText mega-widget 741## 742## ARGUMENTS 743## scrolledtext <window pathname> <options> 744## 745## OPTIONS 746## (Any text widget option may be used in addition to these) 747## 748## -autoscrollbar TCL_BOOLEAN DEFAULT: 1 749## Whether to have dynamic or static scrollbars. 750## 751## RETURNS: the window pathname 752## 753## METHODS/SUBCOMMANDS 754## These are the subcmds that an instance of this megawidget recognizes. 755## Aside from those listed here, it accepts subcmds that are valid for 756## text widgets. 757## 758## subwidget widget 759## Returns the true widget path of the specified widget. Valid 760## widgets are text, xscrollbar, yscrollbar. 761## 762## BINDINGS (in addition to default widget bindings) 763## 764## NAMESPACE & STATE 765## The megawidget creates a global array with the classname, and a 766## global array which is the name of each megawidget is created. The latter 767## array is deleted when the megawidget is destroyed. 768## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used. 769## Other procs that begin with $CLASSNAME are private. For each widget, 770## commands named .$widgetname and $CLASSNAME$widgetname are created. 771## 772## EXAMPLE USAGE: 773## 774## pack [scrolledtext .st -width 40 -height 10] -fill both -exp 1 775## 776##------------------------------------------------------------------------ 777 778## Each widget created will also have a global array created by the 779## instantiation procedure that is the name of the widget (represented 780## as $w below). There three special key names in the $CLASS array: 781## 782## -type 783## the type of base container we want to use (frame or toplevel). 784## This would default to frame. This widget will be created for us 785## by the constructor function. The $w array will have a "container" 786## key that will point to the exact widget name. 787## 788## -base 789## the base widget type for this class. This key is optional and 790## represents what kind of widget will be the base for the class. This 791## way we know what default methods/options you'll have. If not 792## specified, it defaults to the container type. 793## To the global $w array, the key "basecmd" will be added by the widget 794## instantiation function to point to a new proc that will be the direct 795## accessor command for the base widget ("text" in the case of the 796## ScrolledText megawidget). The $w "base" key will be the valid widget 797## name (for passing to [winfo] and such), but "basecmd" will be the 798## valid direct accessor function 799## 800## -components 801## the component widgets of the megawidget. This is a list of tuples 802## (ie: {{listbox listbox} {scrollbar yscrollbar} {scrollbar xscrollbar}}) 803## where each item is in the form {widgettype name}. These components 804## will be created before the $CLASS::construct proc is called and the $w 805## array will have keys with each name pointing to the appropriate 806## widget in it. Use these keys to access your subwidgets. It is from 807## this component list and the base and type about that the subwidget 808## method is created. 809## 810## -options 811## A list of lists, this specifies the 812## options that this megawidget handles. The value can either be a 813## 3-tuple list of the form {databaseName databaseClass defaultValue}, or 814## it can be one element matching -*, which means this key (say -bd) is 815## an alias for the option specified in the value (say -borderwidth) 816## which must be specified fully somewhere else in the class array. 817## 818## If the value is a list beginning with "ALIAS", then the option is derived 819## from a component of the megawidget. The form of the value must be a list 820## with the elements: 821## {ALIAS componenttype option ?databasename databaseclass?} 822## An example of this would be inheriting a label components anchor: 823## {ALIAS label -anchor labelAnchor Anchor} 824## If the databasename is not specified, it determines the final options 825## database info from the component and uses the components default value. 826## Otherwise, just the components default value is used. 827## 828## The $w array will be populated by the instantiation procedure with the 829## default values for all the specified $CLASS options. 830## 831 832# Create this to make sure there are registered in auto_mkindex 833# these must come before the [widget create ...] 834proc ScrolledText args {} 835proc scrolledtext args {} 836widget create ScrolledText -type frame -base text -components { 837 {base text text {-xscrollcommand [list $data(xscrollbar) set] \ 838 -yscrollcommand [list $data(yscrollbar) set]}} 839 {scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1 \ 840 -command [list $w xview]}} 841 {scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1 \ 842 -command [list $w yview]}} 843} -options { 844 {-autoscrollbar autoScrollbar AutoScrollbar 1} 845} 846 847## Then we "create" the widget. This makes all the necessary default widget 848## routines. It creates the public accessor functions ($CLASSNAME and 849## [string tolower $CLASSNAME]) as well as the public cget, configure, destroy 850## and subwidget methods. The cget and configure commands work like the 851## regular Tk ones. The destroy method is superfluous, as megawidgets will 852## respond properly to [destroy $widget] (the Tk destroy command). 853## The subwidget method has the following form: 854## 855## $widget subwidget name 856## name - the component widget name 857## Returns the widget patch to the component widget name. 858## Allows the user direct access to your subwidgets. 859## 860## THE USER SHOULD PROVIDE AT LEAST THE FOLLOWING: 861## 862## $NAMESPACE::construct {w} => return value ignored 863## w - the widget name, also the name of the global data array 864## This procedure is called by the public accessor (instantiation) proc 865## right after creating all component widgets and populating the global $w 866## array with all the default option values, the "base" key and the key 867## names for any other components. The user should then grid/pack all 868## subwidgets into $w. At this point, the initial configure has not 869## occured, so the widget options are all the default. If this proc 870## errors, so does the main creation routine, returning your error. 871## 872## $NAMESPACE::configure {w args} => return ignored (should be empty) 873## w - the widget name, also the name of the global data array 874## args - a list of key/vals (already verified to exist) 875## The user should process the key/vals however they require If this 876## proc errors, so does the main creation routine, returning your error. 877## 878## THE FOLLOWING IS OPTIONAL: 879## 880## $NAMESPACE::init {w} => return value ignored 881## w - the widget name, also the name of the global data array 882## This procedure is called after the public configure routine and after 883## the "basecmd" key has been added to the $w array. Ideally, this proc 884## would be used to do any widget specific one-time initialization. 885## 886## $NAMESPACE::destruct {w} => return ignored (should be empty) 887## w - the widget name, also the name of the global data array 888## A default destroy handler is provided that cleans up after the megawidget 889## (all state info), but if special cleanup stuff is needed, you would provide 890## it in this procedure. This is the first proc called in the default destroy 891## handler. 892## 893 894namespace eval ::Widget::ScrolledText {; 895 896;proc construct {w} { 897 upvar \#0 [namespace current]::$w data 898 899 grid $data(text) $data(yscrollbar) -sticky news 900 grid $data(xscrollbar) -sticky ew 901 grid columnconfig $w 0 -weight 1 902 grid rowconfig $w 0 -weight 1 903 grid remove $data(yscrollbar) $data(xscrollbar) 904 bind $data(text) <Configure> [namespace code [list resize $w 1]] 905} 906 907;proc configure {w args} { 908 upvar \#0 [namespace current]::$w data 909 set truth {^(1|yes|true|on)$} 910 foreach {key val} $args { 911 switch -- $key { 912 -autoscrollbar { 913 set data($key) [regexp -nocase $truth $val] 914 if {$data($key)} { 915 resize $w 0 916 } else { 917 grid $data(xscrollbar) 918 grid $data(yscrollbar) 919 } 920 } 921 } 922 } 923} 924 925# captures xview commands to the text widget 926;proc _xview {w args} { 927 upvar \#0 [namespace current]::$w data 928 if {[catch {uplevel $data(basecmd) xview $args} err]} { 929 return -code error $err 930 } 931} 932 933# captures yview commands to the text widget 934;proc _yview {w args} { 935 upvar \#0 [namespace current]::$w data 936 if {[catch {uplevel $data(basecmd) yview $args} err]} { 937 return -code error $err 938 } elseif {![winfo ismapped $data(xscrollbar)] && \ 939 [string compare {0 1} [$data(basecmd) xview]]} { 940 ## If the xscrollbar was unmapped, but is now needed, show it 941 grid $data(xscrollbar) 942 } 943} 944 945# captures insert commands to the text widget 946;proc _insert {w args} { 947 upvar \#0 [namespace current]::$w data 948 set code [catch {uplevel $data(basecmd) insert $args} err] 949 if {[winfo ismapped $w]} { resize $w 0 } 950 return -code $code $err 951} 952 953# captures delete commands to the text widget 954;proc _delete {w args} { 955 upvar \#0 [namespace current]::$w data 956 set code [catch {uplevel $data(basecmd) delete $args} err] 957 if {[winfo ismapped $w]} { resize $w 1 } 958 return -code $code $err 959} 960 961# called when the ScrolledText widget is resized by the user or possibly 962# needs the scrollbars (de|at)tached due to insert/delete. 963;proc resize {w d} { 964 upvar \#0 [namespace current]::$w data 965 ## Only when deleting should we consider removing the scrollbars 966 if {!$data(-autoscrollbar)} return 967 if {[string compare {0 1} [$data(basecmd) xview]]} { 968 grid $data(xscrollbar) 969 } elseif {$d} { 970 grid remove $data(xscrollbar) 971 } 972 if {[string compare {0 1} [$data(basecmd) yview]]} { 973 grid $data(yscrollbar) 974 } elseif {$d} { 975 grid remove $data(yscrollbar) 976 } 977} 978 979 980}; #end namespace ::Widget::ScrolledText