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