tcl/widget.tcl

   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
  67 package require Tk
  68 package provide Widget 1.12
  69
  70 global WIDGET
  71 lappend WIDGET(containers) frame toplevel
  72 proc 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 ##
 669 array 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 ...]
 686 proc ScrolledText args {}
 687 proc scrolledtext args {}
 688 widget 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 }