]> www.wagner.pp.ru Git - oss/fgis.git/blob - tcl/widget.tcl
Added logic to find GDAL installation.
[oss/fgis.git] / 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 }