A Widget Library
Check-in [401a955574]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:scrub mailto and obvious email refs to hobbs
Timelines: family | ancestors | trunk
Files: files | file ages | folders
SHA1:401a9555743a17822a56ff3e20abf9bed63d6eb8
User & Date: hobbs 2005-07-12 23:28:10
Context
2005-07-12
23:28
scrub mailto and obvious email refs to hobbs Leaf check-in: 401a955574 user: hobbs tags: trunk
2003-12-03
05:26
handle some 8.4 behavior changes check-in: eefd4f8fba user: hobbs tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to LICENSE.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
		   * COPYRIGHT AND LICENSE TERMS *

(This file blatantly stolen from Tcl/Tk license and adapted - thus assume
it falls under similar license terms).

This software is copyrighted by Jeffrey Hobbs <jeff.hobbs@acm.org>.  The
following terms apply to all files associated with the software unless
explicitly disclaimed in individual files.

The authors hereby grant permission to use, copy, modify, distribute, and
license this software and its documentation for any purpose, provided that
existing copyright notices are retained in all copies and that this notice
is included verbatim in any distributions.  No written agreement, license,





|







1
2
3
4
5
6
7
8
9
10
11
12
13
		   * COPYRIGHT AND LICENSE TERMS *

(This file blatantly stolen from Tcl/Tk license and adapted - thus assume
it falls under similar license terms).

This software is copyrighted by Jeffrey Hobbs <jeff at hobbs org>.  The
following terms apply to all files associated with the software unless
explicitly disclaimed in individual files.

The authors hereby grant permission to use, copy, modify, distribute, and
license this software and its documentation for any purpose, provided that
existing copyright notices are retained in all copies and that this notice
is included verbatim in any distributions.  No written agreement, license,

Changes to library/calculator.tcl.

1
2
3
4
5
6
7
8
9
##
## Copyright 1996-1997 Jeffrey Hobbs, jeff.hobbs@acm.org
##
## WORK IN PROGRESS - NOT FUNCTIONAL
##

package require Widget 2.0
package provide Calculator 1.0


|







1
2
3
4
5
6
7
8
9
##
## Copyright 1996-1997 Jeffrey Hobbs, jeff at hobbs org
##
## WORK IN PROGRESS - NOT FUNCTIONAL
##

package require Widget 2.0
package provide Calculator 1.0

Changes to library/combobox.tcl.

1
2
3
4
5
6
7
8
9
##
## Copyright 1996-8 Jeffrey Hobbs, jeff.hobbs@acm.org
##
package require Widget 2.0
package provide Combobox 2.0

## FIX:
## popdown listbox on Configure


|







1
2
3
4
5
6
7
8
9
##
## Copyright 1996-8 Jeffrey Hobbs, jeff at hobbs org
##
package require Widget 2.0
package provide Combobox 2.0

## FIX:
## popdown listbox on Configure

Changes to library/console.tcl.

405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
##

namespace eval ::Widget::Console {;

variable class
array set class {
    release	{December 1998}
    contact	"jeff.hobbs@acm.org"
    docs	"http://tkcon.sourceforge.net/"
    slavealias	{ console }
    slaveprocs	{ alias dir dump lremove puts echo unknown tcl_unknown which }
}
if {![info exists class(active)]} { set class(active) {} }
set class(version) [package provide Console]
set class(WWW) [expr {[info exists ::embed_args] \







|







405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
##

namespace eval ::Widget::Console {;

variable class
array set class {
    release	{December 1998}
    contact	"jeff at hobbs org"
    docs	"http://tkcon.sourceforge.net/"
    slavealias	{ console }
    slaveprocs	{ alias dir dump lremove puts echo unknown tcl_unknown which }
}
if {![info exists class(active)]} { set class(active) {} }
set class(version) [package provide Console]
set class(WWW) [expr {[info exists ::embed_args] \

Changes to library/hierarchy.tcl.

1
2
3
4
5
6
7
8
9
10
##
## Layout routines taken from oooold code, author unkown.
## Copyright 1995-1998 Jeffrey Hobbs, jeff.hobbs@acm.org
##
## Last Update: 28 June 1997
##
package require Widget 2.0
package provide Hierarchy 2.0

##-----------------------------------------------------------------------


|







1
2
3
4
5
6
7
8
9
10
##
## Layout routines taken from oooold code, author unkown.
## Copyright 1995-1998 Jeffrey Hobbs, jeff at hobbs org
##
## Last Update: 28 June 1997
##
package require Widget 2.0
package provide Hierarchy 2.0

##-----------------------------------------------------------------------

Changes to library/pane.tcl.

1
2
3
4
5
6
7
8
9
10
11
## Paned Window Procs inspired by code by Stephen Uhler @ Sun.
## Thanks to John Ellson (ellson@lucent.com) for bug reports & code ideas.
##
## Copyright 1996-1997 Jeffrey Hobbs, jeff.hobbs@acm.org
##
package provide Pane 1.0

##------------------------------------------------------------------
## PROCEDURE
##	pane
##



|







1
2
3
4
5
6
7
8
9
10
11
## Paned Window Procs inspired by code by Stephen Uhler @ Sun.
## Thanks to John Ellson (ellson@lucent.com) for bug reports & code ideas.
##
## Copyright 1996-1997 Jeffrey Hobbs, jeff at hobbs org
##
package provide Pane 1.0

##------------------------------------------------------------------
## PROCEDURE
##	pane
##

Changes to library/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# Tcl package index file, version 1.0

package ifneeded AllWidgets 1.0 {
    package require Widget
    package require BalloonHelp
    package require Calculator
    package require Combobox
    package require Console
    package require Hierarchy
    package require Megalist
    package require Pane
    package require Progressbar
    package require Tabnotebook
    package require Ventry
    package provide AllWidgets 1.0
}

package ifneeded BalloonHelp 2.0 [list tclPkgSetup $dir BalloonHelp 2.0 {
    {balloonhelp.tcl source {
	balloonhelp
}   }   }]



|











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# Tcl package index file, version 1.0

package ifneeded AllWidgets 2.0 {
    package require Widget
    package require BalloonHelp
    package require Calculator
    package require Combobox
    package require Console
    package require Hierarchy
    package require Megalist
    package require Pane
    package require Progressbar
    package require Tabnotebook
    package require Ventry
    package provide AllWidgets 2.0
}

package ifneeded BalloonHelp 2.0 [list tclPkgSetup $dir BalloonHelp 2.0 {
    {balloonhelp.tcl source {
	balloonhelp
}   }   }]

Changes to library/progressbar.tcl.

1
2
3
4
5
6
7
8
9
##
## Copyright 1996-1997 Jeffrey Hobbs, jeff.hobbs@acm.org
## Some Enhancements done by Steve Ball
##
package require Widget 2.0
package provide Progressbar 2.0

##------------------------------------------------------------------------
## PROCEDURE

|







1
2
3
4
5
6
7
8
9
##
## Copyright 1996-1997 Jeffrey Hobbs, jeff at hobbs org
## Some Enhancements done by Steve Ball
##
package require Widget 2.0
package provide Progressbar 2.0

##------------------------------------------------------------------------
## PROCEDURE

Changes to library/tabnotebook.tcl.

1
2
3
4
5
6
7
8
9
##
## Copyright 1997-8 Jeffrey Hobbs, jeff.hobbs@acm.org, CADIX International
##
package require Widget 2.0
package provide Tabnotebook 2.0

## FIX:
## option state of subitems could be kept in a clearer array
## -relief for .tab.hold should be flat initially

|







1
2
3
4
5
6
7
8
9
##
## Copyright 1997-8 Jeffrey Hobbs, jeff at hobbs org, CADIX International
##
package require Widget 2.0
package provide Tabnotebook 2.0

## FIX:
## option state of subitems could be kept in a clearer array
## -relief for .tab.hold should be flat initially

Changes to library/util-color.tcl.

61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
    if {![string compare $b "UNSET"]} {
	set clip $g
	if {[regexp {^-?(0-9)+$} $r]} {
	    foreach {r g b} $r {break}
	} else {
	    foreach {r g b} [winfo rgb . $r] {break}
	}
    } 
    set max 255
    set len 2
    if {($r > 255) || ($g > 255) || ($b > 255)} {
	if {$clip} {
	    set r [expr {$r>>8}]; set g [expr {$g>>8}]; set b [expr {$b>>8}]
	} else {
	    set max 65535







|







61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
    if {![string compare $b "UNSET"]} {
	set clip $g
	if {[regexp {^-?(0-9)+$} $r]} {
	    foreach {r g b} $r {break}
	} else {
	    foreach {r g b} [winfo rgb . $r] {break}
	}
    }
    set max 255
    set len 2
    if {($r > 255) || ($g > 255) || ($b > 255)} {
	if {$clip} {
	    set r [expr {$r>>8}]; set g [expr {$g>>8}]; set b [expr {$b>>8}]
	} else {
	    set max 65535

Changes to library/util-string.tcl.

131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
#   P2		substitute for $P while processing, defaults to \254
#		this char must not be in the input text
# Returns:
#   text with lines no longer than $len, except where a single word
#   is longer than $len chars.  Does not preserve paragraph boundaries.
#
;proc wrap_lines "txt {len 75} {P \n\n} {P2 \254}" {
    # @author Jeffrey Hobbs <jeff.hobbs@acm.org>
    #
    # @c Wraps the given <a text> into multiple lines not
    # @c exceeding <a len> characters each. Lines shorter
    # @c than <a len> characters might get filled up.
    #
    # @a text:	The string to operate on.
    # @a len:	The maximum allowed length of a single line.







|







131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
#   P2		substitute for $P while processing, defaults to \254
#		this char must not be in the input text
# Returns:
#   text with lines no longer than $len, except where a single word
#   is longer than $len chars.  Does not preserve paragraph boundaries.
#
;proc wrap_lines "txt {len 75} {P \n\n} {P2 \254}" {
    # @author Jeffrey Hobbs <jeff at hobbs org>
    #
    # @c Wraps the given <a text> into multiple lines not
    # @c exceeding <a len> characters each. Lines shorter
    # @c than <a len> characters might get filled up.
    #
    # @a text:	The string to operate on.
    # @a len:	The maximum allowed length of a single line.

Changes to library/ventry.tcl.

1
2
3
4
5
6
7
8
9
10
## self-validating entry widget
##
## Copyright 1997-8 Jeffrey Hobbs, jeff.hobbs@acm.org, CADIX International
##
package require Widget 2.0
package provide Ventry 2.0

##------------------------------------------------------------------------
## PROCEDURE
##	ventry


|







1
2
3
4
5
6
7
8
9
10
## self-validating entry widget
##
## Copyright 1997-8 Jeffrey Hobbs, jeff at hobbs org, CADIX International
##
package require Widget 2.0
package provide Ventry 2.0

##------------------------------------------------------------------------
## PROCEDURE
##	ventry

Changes to library/widget.tcl.

1
2
3
4
5
6
7
8
9
10
..
83
84
85
86
87
88
89
90
91
92
93
94
95
96

97
98
99
100
101
102
103
104
105
106
107
...
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
...
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
...
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
...
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
...
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
...
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
...
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
...
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
...
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
...
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
...
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
...
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
...
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
...
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
...
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
...
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
...
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
...
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
## Barebones requirements for creating and querying megawidgets
##
## Copyright 1997-9 Jeffrey Hobbs, jeff.hobbs@acm.org
##
## Initiated: 5 June 1997
## Last Update: 1999

## FIX: config flag, option for setting all child widgets by default

package require Tk 8
................................................................................
##
## END OF SHORT LIST


## Dummy call for indexers
proc widget args {}

namespace eval ::Widget {;

namespace export -clear widget
variable CLASSES
variable CONTAINERS {frame toplevel}
namespace import -force ::Utility::get_opts*


;proc widget {cmd args} {
    ## Establish the prefix of public commands
    set prefix [namespace current]::_
    if {[string match {} [set arg [info commands $prefix$cmd]]]} {
	set arg [info commands $prefix$cmd*]
    }
    switch [llength $arg] {
	1 { return [uplevel $arg $args] }
	0 {
	    set arg [info commands $prefix*]
	    regsub -all $prefix $arg {} arg
................................................................................
	    regsub -all $prefix $arg {} arg
	    return -code error "ambiguous method \"$cmd\",\
		    could be one of: [join [lsort $arg] {, }]"
	}
    }
}

;proc verify_class {CLASS} {
    variable CLASSES
    if {![info exists CLASSES($CLASS)]} {
	return -code error "no known class \"$CLASS\""
    }
    return
}

;proc _add {CLASS what args} {
    variable CLASSES
    verify_class $CLASS
    if {[string match ${what}* options]} {
	add_options $CLASSES($CLASS) $CLASS $args
    } else {
	return -code error "unknown type for add, must be one of:\
		options, components"
    }
}

;proc _find_class {CLASS {root .}} {
    if {[string match $CLASS [winfo class $root]]} {
	return $root
    } else {
	foreach w [winfo children $root] {
	    set w [_find_class $CLASS $w]
	    if {[string compare {} $w]} {
		return $w
	    }
	}
    }
}

;proc _delete {CLASS what args} {
    variable CLASSES
    verify_class $CLASS
}

;proc _classes {{pattern "*"}} {
    variable CLASSES
    return [array names CLASSES $pattern]
}

;proc _value {CLASS key} {
    variable CLASSES
    verify_class $CLASS
    upvar \#0 $CLASSES($CLASS)::class class
    if {[info exists class($key)]} {
	return $class($key)
    } else {
	return -code error "unknown key \"$key\" in class \"$CLASS\""
................................................................................
    }
}

## handle
## Handles the method calls for a widget.  This is the command to which
## all megawidget dummy commands are redirected for interpretation.
##
;proc handle {namesp w subcmd args} {
    upvar \#0 ${namesp}::$w data
    if {[string match {} [set arg [info commands ${namesp}::_$subcmd]]]} {
	set arg [info commands ${namesp}::_$subcmd*]
    }
    set num [llength $arg]
    if {$num==1} {
	return [uplevel $arg [list $w] $args]
    } elseif {$num} {
	regsub -all "${namesp}::_" $arg {} arg
................................................................................
    }
}

## construct
## Constructs the megawidget instance instantiation proc based on the
## current knowledge of the megawidget. 
##
;proc construct {namesp CLASS} {
    upvar \#0 ${namesp}::class class \
	    ${namesp}::components components

    lappend dataArrayVals [list class $CLASS]
    if {[string compare $class(type) $class(base)]} {
	## If -type and -base don't match, we need a special setup
	lappend dataArrayVals "base \$w.[list [lindex $components(base) 1]]" \
		"basecmd ${namesp}::\$w.[list [lindex $components(base) 1]]" \
		"container ${namesp}::.\$w"
	## If the base widget is not the container, then we want to rename
	## its widget commands and add the CLASS and container bind tables
	## to its bindtags in case certain bindings are made
	## Interp alias is the optimal solution, but exposes
	## a bug in Tcl7/8 when renaming aliases
	#interp alias {} \$base {} ::Widget::handle $namesp \$w
	set renamingCmd "rename \$base \$data(basecmd)
	;proc ::\$base args \"uplevel ::Widget::handle $namesp \[list \$w\] \\\$args\"
	bindtags \$base \[linsert \[bindtags \$base\] 1\
		[expr {[string match toplevel $class(type)]?{}:{$w}}] $CLASS\]"
    } else {
	## -type and -base are the same, we only create for one
	lappend dataArrayVals "base \$w" \
		"basecmd ${namesp}::\$w" \
		"container ${namesp}::\$w"
	if {[string compare {} [lindex $components(base) 3]]} {
	    lappend dataArrayVals "[lindex $components(base) 3] \$w"
	}
	## When the base widget and container are the same, we have a
	## straightforward renaming of commands
	set renamingCmd {}
    }
    set baseConstruction {}
    foreach name [array names components] {	
	if {[string match base $name]} {
	    continue
	}
	foreach {type wid opts} $components($name) break
	lappend dataArrayVals "[list $name] \$w.[list $wid]"
	lappend baseConstruction "$type \$w.[list $wid] $opts"
	if {[string match toplevel $type]} {
	    lappend baseConstruction "wm withdraw \$data($name)"
	}
    }
    set dataArrayVals [join $dataArrayVals " \\\n\t"]
    ## the lsort ensure that parents are created before children
    set baseConstruction [join [lsort -index 1 $baseConstruction] "\n    "]

    ## More of this proc could be configured ahead of time for increased
    ## construction speed.  It's delicate, so handle with extreme care.
    ;proc ${namesp}::$CLASS {w args} [subst {
	variable options
	upvar \#0 ${namesp}::\$w data
	$class(type) \$w -class $CLASS
	[expr [string match toplevel $class(type)]?{wm withdraw \$w\n}:{}]
	## Populate data array with user definable options
	foreach o \[array names options\] {
	    if {\[string match -* \$options(\$o)\]} continue
	    set data(\$o) \[option get \$w \[lindex \$options(\$o) 0\] $CLASS\]
	}

	## Populate the data array
................................................................................
	    catch {_destruct \$w}
	    return -code error \"megawidget construction error: \$err\"
	}

	set base \$data(base)
	rename \$w \$data(container)
	$renamingCmd
	#;proc ::\$w args \"uplevel ::Widget::handle $namesp \[list \$w\] \\\$args\"
	interp alias {} \$w {} ::Widget::handle $namesp \$w

	## Do the configuring here and eval the post initialization procedure
	if {(\[llength \$args\] && \
		\[catch {uplevel 1 ${namesp}::_configure \$w \$args} err\]) || \
		\[catch {${namesp}::init \$w} err\]} {
	    catch { ${namesp}::_destruct \$w }
................................................................................
	}

	return \$w
    }
    ]
}

;proc add_options {namesp CLASS optlist} {
    upvar \#0 ${namesp}::class class \
	    ${namesp}::options options \
	    ${namesp}::widgets widgets
    ## Go through the option definition, substituting for ALIAS where
    ## necessary and setting up the options database for this $CLASS
    ## There are several possible formats:
    ## 1. -optname -optnamealias
................................................................................
			    ?databasename databaseclass?}"
		}
		if {![info exists widgets($type)]} {
		    return -code error "cannot create alias \"$optname\" to\
			    $CLASS component type \"$type\" option \"$opt\":\
			    component type does not exist"
		} elseif {![info exists config($type)]} {
		    if {[string compare toplevel $type]} {
			set w .__widget__$type
			catch {destroy $w}
			## Make sure the component widget type exists,
			## returns the widget name,
			## and accepts configure as a subcommand
			if {[catch {$type $w} result] || \
				[string compare $result $w] || \
				[catch {$w configure} config($type)]} {
			    ## Make sure we destroy it if it was a bad widget
			    catch {destroy $w}
			    ## Or rename it if it was a non-widget command
			    catch {rename $w {}}
			    return -code error "invalid widget type \"$type\""
			}
................................................................................
	    }
	}
	set options($optname) [list $dbname $dbcname $def]
	option add *$CLASS.$dbname $def widgetDefault
    }
}

;proc _create {CLASS args} {
    if {![string match {[A-Z]*} $CLASS] || [string match { } $CLASS]} {
	return -code error "invalid class name \"$CLASS\": it must begin\
		with a capital letter and contain no spaces"
    }

    variable CONTAINERS
    variable CLASSES
    set namesp [namespace current]::$CLASS
................................................................................
    ## Then check to see that their base widget type is valid
    ## We will create a default widget of the appropriate type just in
    ## case they use the DEFAULT keyword as a default value in their
    ## megawidget class definition
    if {[info exists classopts(-base)]} {
	## We check to see that we can create the base, that it returns
	## the same widget value we put in, and that it accepts cget.
	if {[string match toplevel $classopts(-base)] && \
		[string compare toplevel $classopts(-type)]} {
	    return -code error "\"toplevel\" is not allowed as the base\
		    widget of a megawidget (perhaps you intended it to\
		    be the class type)"
	}
    } else {
	## The container is the default base widget
	set classopts(-base) $classopts(-type)
................................................................................
		![info exists widnames([file root $wid])]} {
	    ## If the widget name contains a '.', then make sure we will
	    ## have created all the parents first.  [file root $wid] is
	    ## a cheap trick to remove the last .child string from $wid
	    return -code error "no specified parent for $CLASS class\
		    component widget name \"$wid\""
	}
	if {[string match base $type]} {
	    set type $class(base)
	    set components(base) [list $type $wid $opts $name]
	    if {[string match $type $class(type)]} continue
	}
	set components($name) [list $type $wid $opts]
	set widnames($wid) 0
	set widgets($type) 0
    }
    if {![info exists components(base)]} {
	set components(base) [list $class(base) $class(base) {}]
................................................................................

    namespace eval $namesp {
	set CLASS [namespace tail [namespace current]]
	## The _destruct must occur to remove excess state elements.
	## The [winfo class %W] will work in this Destroy, which is necessary
	## to determine if we are destroying the actual megawidget container.
	bind $CLASS <Destroy> [namespace code {
	    if {[string compare {} [::widget classes [::winfo class %W]]]} {
		if [catch {_destruct %W} err] { puts $err }
	    }
	}]
    }
    ## This creates the basic constructor procedure for the class
    ## as ${namesp}::$CLASS
    construct $namesp $CLASS
................................................................................
    namespace eval $namesp [list namespace export -clear $CLASS]
    namespace eval :: [list namespace import -force ${namesp}::$CLASS]
    interp alias {} ::[string tolower $CLASS] {} ::$CLASS

    ## These are provided so that errors due to lack of the command
    ## existing don't arise.  Since they are stubbed out here, the
    ## user can't depend on 'unknown' or 'auto_load' to get this proc.
    if {[string match {} [info commands ${namesp}::construct]]} {
	;proc ${namesp}::construct {w} {
	    # the user should rewrite this
	    # without the following error, a simple megawidget that was just
	    # a frame would be created by default
	    return -code error "user must write their own\
		    [lindex [info level 0] 0] function"
	}
    }
    if {[string match {} [info commands ${namesp}::init]]} {
	;proc ${namesp}::init {w} {
	    # the user should rewrite this
	}
    }

    ## The user is not supposed to change this proc
    set comps [lsort [array names components]]
    ;proc ${namesp}::_subwidget {w {widget return} args} [subst {
	variable \$w
	upvar 0 \$w data
	switch -- \$widget {
	    return	{
		return [list $comps]
	    }
	    all {
................................................................................
	    }
	}
    }]

    ## The user is not supposed to change this proc
    ## Instead they create a ::Widget::$CLASS::destruct proc
    ## Some of this may be redundant, but at least it does the job
    ;proc ${namesp}::_destruct {w} "
    upvar \#0 ${namesp}::\$w data
    catch {${namesp}::destruct \$w}
    catch {::destroy \$data(base)}
    catch {::destroy \$w}
    catch {rename \$data(basecmd) {}}
    catch {rename ::\$data(base) {}}
    catch {rename ::\$w {}}
    catch {unset data}
    return\n"
    
    if {[string match {} [info commands ${namesp}::destruct]]} {
	## The user can optionally provide a special destroy handler
	;proc ${namesp}::destruct {w args} {
	    # empty
	}
    }

    ## The user is not supposed to change this proc
    ;proc ${namesp}::_cget {w args} {
	if {[llength $args] != 1} {
	    return -code error "wrong \# args: should be \"$w cget option\""
	}
	set namesp [namespace current]
	upvar \#0 ${namesp}::$w data ${namesp}::options options
	if {[info exists options($args)]&&[string match -* $options($args)]} {
	    set args $options($args)
	}
	if {[string match {} [set arg [array names data $args]]]} {
	    set arg [array names data ${args}*]
	}
	set num [llength $arg]
	if {$num==1} {
	    return $data($arg)
	} elseif {$num} {
	    return -code error "ambiguous option \"$args\",\
................................................................................
	} else {
	    return $err
	}
    }

    ## The user is not supposed to change this proc
    ## Instead they create a $CLASS:configure proc
    ;proc ${namesp}::_configure {w args} {
	set namesp [namespace current]
	upvar \#0 ${namesp}::$w data ${namesp}::options options \
		${namesp}::components components

	set num [llength $args]
	if {$num==1} {
	    ## Request for one config option
	    if {[info exists options($args)] && \
		    [string match -* $options($args)]} {
		set args $options($args)
	    }
	    if {[string match {} [set arg [array names data $args]]]} {
		set arg [array names data ${args}*]
	    }
	    set num [llength $arg]
	    if {$num==1} {
		## FIX one-elem config
		return "[list $arg] $options($arg) [list $data($arg)]"
	    } elseif {$num} {
................................................................................
	    set widargs {}
	    set cmdargs {}
	    foreach {key val} $args {
		if {[info exists options($key)] && \
			[string match -* $options($key)]} {
		    set key $options($key)
		}
		if {[string match {} [set arg [array names data $key]]]} {
		    set arg [array names data $key*]
		}
		set len [llength $arg]
		if {$len==1} {
		    lappend widargs $arg $val
		} elseif {$len} {
		    set ambarg [list $key $arg]
................................................................................
		    lappend cmdargs $key $val
		}
	    }
	    if {[llength $widargs]} {
		uplevel ${namesp}::configure [list $w] $widargs
	    }
#	    if {[llength $cmdargs]} {
#		;proc _configure {w args} {
#		    catch {uplevel [list $w] configure $args}
#		    set n [namespace current]
#		    foreach c [winfo children $w] {
#			uplevel ${n}::_configure [list $c] $args
#		    }
#		}
#		uplevel widget configure [list $w] $cmdargs
................................................................................
	    foreach opt [lsort [array names opts]] {
		lappend config "$opt $opts($opt)"
	    }
	    return $config
	}
    }

    if {[string match {} [info commands ${namesp}::configure]]} {
	## The user is intended to rewrite this one
	;proc ${namesp}::configure {w args}  {
	    foreach {key val} $args {
		puts "$w: configure $key to [list $value]"
	    }
	}
    }

    set CLASSES($CLASS) $namesp
    return $namesp
}

# Redefine private Tk function tkFocusOK to recognize our widgets
#
;proc _tkFocusOK w {
    if {[llength [info commands widget]] && \
	    [llength [widget classes [winfo class $w]]]} {
	return 0
    }
    set code [catch {$w cget -takefocus} value]
    if {($code == 0) && ($value != "")} {
	if {$value == 0} {
................................................................................
    set code [catch {$w cget -state} value]
    if {($code == 0) && ($value == "disabled")} {
	return 0
    }
    regexp Key|Focus "[bind $w] [bind [winfo class $w]]"
}

}; #end namespace ::Widget

namespace eval :: {
    namespace import -force ::Widget::widget
    if {$tk_version < 8.4} {
	catch {tkFocusOK .}; # we want this auto-loaded
	interp alias {} tkFocusOK {} widget tkFocusOK
    } else {
	catch {tk::FocusOK .}; # we want this auto-loaded
................................................................................
## (all state info), but if special cleanup stuff is needed, you would provide
## it in this procedure.  This is the first proc called in the default destroy
## handler.
##

namespace eval ::Widget::ScrolledText {;

;proc construct {w} {
    upvar \#0 [namespace current]::$w data

    grid $data(text) $data(yscrollbar) -sticky news
    grid $data(xscrollbar) -sticky ew
    grid columnconfig $w 0 -weight 1
    grid rowconfig $w 0 -weight 1
    grid remove $data(yscrollbar) $data(xscrollbar)
    bind $data(text) <Configure> [namespace code [list resize $w 1]]
}

;proc configure {w args} {
    upvar \#0 [namespace current]::$w data
    set truth {^(1|yes|true|on)$}
    foreach {key val} $args {
	switch -- $key {
	    -autoscrollbar	{
		set data($key) [regexp -nocase $truth $val]
		if {$data($key)} {
		    resize $w 0
		} else {
		    grid $data(xscrollbar)
		    grid $data(yscrollbar)
		}
	    }
	}
    }
}

# captures xview commands to the text widget
;proc _xview {w args} {
    upvar \#0 [namespace current]::$w data
    if {[catch {uplevel $data(basecmd) xview $args} err]} {
	return -code error $err
    }
}

# captures yview commands to the text widget
;proc _yview {w args} {
    upvar \#0 [namespace current]::$w data
    if {[catch {uplevel $data(basecmd) yview $args} err]} {
	return -code error $err
    } elseif {![winfo ismapped $data(xscrollbar)] && \
	    [string compare {0 1} [$data(basecmd) xview]]} {
	## If the xscrollbar was unmapped, but is now needed, show it
	grid $data(xscrollbar)
    }
}

# captures insert commands to the text widget
;proc _insert {w args} {
    upvar \#0 [namespace current]::$w data
    set code [catch {uplevel $data(basecmd) insert $args} err]
    if {[winfo ismapped $w]} { resize $w 0 }
    return -code $code $err
}

# captures delete commands to the text widget
;proc _delete {w args} {
    upvar \#0 [namespace current]::$w data
    set code [catch {uplevel $data(basecmd) delete $args} err]
    if {[winfo ismapped $w]} { resize $w 1 }
    return -code $code $err
}

# called when the ScrolledText widget is resized by the user or possibly
# needs the scrollbars (de|at)tached due to insert/delete.
;proc resize {w d} {
    upvar \#0 [namespace current]::$w data
    ## Only when deleting should we consider removing the scrollbars
    if {!$data(-autoscrollbar)} return
    set base $data(basecmd)
    ## We will have to disable the Configure event temporarily, to
    ## prevent looping due to a quirk in geometry management where
    ## adding/removing the scrollbar changes the widget size.
    set W $data(text)
    set bind [bind $W <Configure>]
    bind $W <Configure> {}
    if {[string compare {0 1} [$base xview]]} {
	grid $data(xscrollbar)
    } elseif {$d} {
	grid remove $data(xscrollbar)
    }
    if {[string compare {0 1} [$base yview]]} {
	grid $data(yscrollbar)
    } elseif {$d} {
	grid remove $data(yscrollbar)
    }
    ## As with the Configure problem, it can affect the cursor too...
    $base see insert
    after 100 [list bind $W <Configure> $bind]
}


}; #end namespace ::Widget::ScrolledText


|







 







|

|
|
|
|
|
>
|


|







 







|







|










|
|




|






|




|




|







 







|

|







 







|




|











|

|





|








|





|









|



|







 







|







 







|







 







|






|







 







|
|







 







|
|







 







|


|







 







|







 







|
|







|
|






|







 







|










|

|





|








|







 







|











|







 







|







 







|







 







|

|












|







 







<
<







 







|










|

<



|












|







|




|






|







|








|










|




|











1
2
3
4
5
6
7
8
9
10
..
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
...
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
...
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
...
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
...
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
...
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
...
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
...
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
...
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
...
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
...
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
...
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
...
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
...
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
...
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
...
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
...
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
...
758
759
760
761
762
763
764


765
766
767
768
769
770
771
...
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957

958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
## Barebones requirements for creating and querying megawidgets
##
## Copyright 1997-9 Jeffrey Hobbs, jeff at hobbs org
##
## Initiated: 5 June 1997
## Last Update: 1999

## FIX: config flag, option for setting all child widgets by default

package require Tk 8
................................................................................
##
## END OF SHORT LIST


## Dummy call for indexers
proc widget args {}

namespace eval ::Widget {

    namespace export -clear widget
    variable CLASSES
    variable CONTAINERS {frame toplevel}
    namespace import -force ::Utility::get_opts*
}

proc ::Widget::widget {cmd args} {
    ## Establish the prefix of public commands
    set prefix [namespace current]::_
    if {[string equal {} [set arg [info commands $prefix$cmd]]]} {
	set arg [info commands $prefix$cmd*]
    }
    switch [llength $arg] {
	1 { return [uplevel $arg $args] }
	0 {
	    set arg [info commands $prefix*]
	    regsub -all $prefix $arg {} arg
................................................................................
	    regsub -all $prefix $arg {} arg
	    return -code error "ambiguous method \"$cmd\",\
		    could be one of: [join [lsort $arg] {, }]"
	}
    }
}

proc ::Widget::verify_class {CLASS} {
    variable CLASSES
    if {![info exists CLASSES($CLASS)]} {
	return -code error "no known class \"$CLASS\""
    }
    return
}

proc ::Widget::_add {CLASS what args} {
    variable CLASSES
    verify_class $CLASS
    if {[string match ${what}* options]} {
	add_options $CLASSES($CLASS) $CLASS $args
    } else {
	return -code error "unknown type for add, must be one of:\
		options, components"
    }
}

proc ::Widget::_find_class {CLASS {root .}} {
    if {[string equal $CLASS [winfo class $root]]} {
	return $root
    } else {
	foreach w [winfo children $root] {
	    set w [_find_class $CLASS $w]
	    if {![string equal {} $w]} {
		return $w
	    }
	}
    }
}

proc ::Widget::_delete {CLASS what args} {
    variable CLASSES
    verify_class $CLASS
}

proc ::Widget::_classes {{pattern "*"}} {
    variable CLASSES
    return [array names CLASSES $pattern]
}

proc ::Widget::_value {CLASS key} {
    variable CLASSES
    verify_class $CLASS
    upvar \#0 $CLASSES($CLASS)::class class
    if {[info exists class($key)]} {
	return $class($key)
    } else {
	return -code error "unknown key \"$key\" in class \"$CLASS\""
................................................................................
    }
}

## handle
## Handles the method calls for a widget.  This is the command to which
## all megawidget dummy commands are redirected for interpretation.
##
proc ::Widget::handle {namesp w subcmd args} {
    upvar \#0 ${namesp}::$w data
    if {[string equal {} [set arg [info commands ${namesp}::_$subcmd]]]} {
	set arg [info commands ${namesp}::_$subcmd*]
    }
    set num [llength $arg]
    if {$num==1} {
	return [uplevel $arg [list $w] $args]
    } elseif {$num} {
	regsub -all "${namesp}::_" $arg {} arg
................................................................................
    }
}

## construct
## Constructs the megawidget instance instantiation proc based on the
## current knowledge of the megawidget. 
##
proc ::Widget::construct {namesp CLASS} {
    upvar \#0 ${namesp}::class class \
	    ${namesp}::components components

    lappend dataArrayVals [list class $CLASS]
    if {![string equal $class(type) $class(base)]} {
	## If -type and -base don't match, we need a special setup
	lappend dataArrayVals "base \$w.[list [lindex $components(base) 1]]" \
		"basecmd ${namesp}::\$w.[list [lindex $components(base) 1]]" \
		"container ${namesp}::.\$w"
	## If the base widget is not the container, then we want to rename
	## its widget commands and add the CLASS and container bind tables
	## to its bindtags in case certain bindings are made
	## Interp alias is the optimal solution, but exposes
	## a bug in Tcl7/8 when renaming aliases
	#interp alias {} \$base {} ::Widget::handle $namesp \$w
	set renamingCmd "rename \$base \$data(basecmd)
	proc ::\$base args \"uplevel ::Widget::handle $namesp \[list \$w\] \\\$args\"
	bindtags \$base \[linsert \[bindtags \$base\] 1\
		[expr {[string equal toplevel $class(type)]?{}:{$w}}] $CLASS\]"
    } else {
	## -type and -base are the same, we only create for one
	lappend dataArrayVals "base \$w" \
		"basecmd ${namesp}::\$w" \
		"container ${namesp}::\$w"
	if {![string equal {} [lindex $components(base) 3]]} {
	    lappend dataArrayVals "[lindex $components(base) 3] \$w"
	}
	## When the base widget and container are the same, we have a
	## straightforward renaming of commands
	set renamingCmd {}
    }
    set baseConstruction {}
    foreach name [array names components] {	
	if {[string equal base $name]} {
	    continue
	}
	foreach {type wid opts} $components($name) break
	lappend dataArrayVals "[list $name] \$w.[list $wid]"
	lappend baseConstruction "$type \$w.[list $wid] $opts"
	if {[string equal toplevel $type]} {
	    lappend baseConstruction "wm withdraw \$data($name)"
	}
    }
    set dataArrayVals [join $dataArrayVals " \\\n\t"]
    ## the lsort ensure that parents are created before children
    set baseConstruction [join [lsort -index 1 $baseConstruction] "\n    "]

    ## More of this proc could be configured ahead of time for increased
    ## construction speed.  It's delicate, so handle with extreme care.
    proc ${namesp}::$CLASS {w args} [subst {
	variable options
	upvar \#0 ${namesp}::\$w data
	$class(type) \$w -class $CLASS
	[expr [string equal toplevel $class(type)]?{wm withdraw \$w\n}:{}]
	## Populate data array with user definable options
	foreach o \[array names options\] {
	    if {\[string match -* \$options(\$o)\]} continue
	    set data(\$o) \[option get \$w \[lindex \$options(\$o) 0\] $CLASS\]
	}

	## Populate the data array
................................................................................
	    catch {_destruct \$w}
	    return -code error \"megawidget construction error: \$err\"
	}

	set base \$data(base)
	rename \$w \$data(container)
	$renamingCmd
	#proc ::\$w args \"uplevel ::Widget::handle $namesp \[list \$w\] \\\$args\"
	interp alias {} \$w {} ::Widget::handle $namesp \$w

	## Do the configuring here and eval the post initialization procedure
	if {(\[llength \$args\] && \
		\[catch {uplevel 1 ${namesp}::_configure \$w \$args} err\]) || \
		\[catch {${namesp}::init \$w} err\]} {
	    catch { ${namesp}::_destruct \$w }
................................................................................
	}

	return \$w
    }
    ]
}

proc ::Widget::add_options {namesp CLASS optlist} {
    upvar \#0 ${namesp}::class class \
	    ${namesp}::options options \
	    ${namesp}::widgets widgets
    ## Go through the option definition, substituting for ALIAS where
    ## necessary and setting up the options database for this $CLASS
    ## There are several possible formats:
    ## 1. -optname -optnamealias
................................................................................
			    ?databasename databaseclass?}"
		}
		if {![info exists widgets($type)]} {
		    return -code error "cannot create alias \"$optname\" to\
			    $CLASS component type \"$type\" option \"$opt\":\
			    component type does not exist"
		} elseif {![info exists config($type)]} {
		    if {![string equal toplevel $type]} {
			set w .__widget__$type
			catch {destroy $w}
			## Make sure the component widget type exists,
			## returns the widget name,
			## and accepts configure as a subcommand
			if {[catch {$type $w} result] || \
				![string equal $result $w] || \
				[catch {$w configure} config($type)]} {
			    ## Make sure we destroy it if it was a bad widget
			    catch {destroy $w}
			    ## Or rename it if it was a non-widget command
			    catch {rename $w {}}
			    return -code error "invalid widget type \"$type\""
			}
................................................................................
	    }
	}
	set options($optname) [list $dbname $dbcname $def]
	option add *$CLASS.$dbname $def widgetDefault
    }
}

proc ::Widget::_create {CLASS args} {
    if {![string match {[A-Z]*} $CLASS] || [string equal { } $CLASS]} {
	return -code error "invalid class name \"$CLASS\": it must begin\
		with a capital letter and contain no spaces"
    }

    variable CONTAINERS
    variable CLASSES
    set namesp [namespace current]::$CLASS
................................................................................
    ## Then check to see that their base widget type is valid
    ## We will create a default widget of the appropriate type just in
    ## case they use the DEFAULT keyword as a default value in their
    ## megawidget class definition
    if {[info exists classopts(-base)]} {
	## We check to see that we can create the base, that it returns
	## the same widget value we put in, and that it accepts cget.
	if {[string equal toplevel $classopts(-base)] && \
		![string equal toplevel $classopts(-type)]} {
	    return -code error "\"toplevel\" is not allowed as the base\
		    widget of a megawidget (perhaps you intended it to\
		    be the class type)"
	}
    } else {
	## The container is the default base widget
	set classopts(-base) $classopts(-type)
................................................................................
		![info exists widnames([file root $wid])]} {
	    ## If the widget name contains a '.', then make sure we will
	    ## have created all the parents first.  [file root $wid] is
	    ## a cheap trick to remove the last .child string from $wid
	    return -code error "no specified parent for $CLASS class\
		    component widget name \"$wid\""
	}
	if {[string equal base $type]} {
	    set type $class(base)
	    set components(base) [list $type $wid $opts $name]
	    if {[string equal $type $class(type)]} continue
	}
	set components($name) [list $type $wid $opts]
	set widnames($wid) 0
	set widgets($type) 0
    }
    if {![info exists components(base)]} {
	set components(base) [list $class(base) $class(base) {}]
................................................................................

    namespace eval $namesp {
	set CLASS [namespace tail [namespace current]]
	## The _destruct must occur to remove excess state elements.
	## The [winfo class %W] will work in this Destroy, which is necessary
	## to determine if we are destroying the actual megawidget container.
	bind $CLASS <Destroy> [namespace code {
	    if {![string equal {} [::widget classes [::winfo class %W]]]} {
		if [catch {_destruct %W} err] { puts $err }
	    }
	}]
    }
    ## This creates the basic constructor procedure for the class
    ## as ${namesp}::$CLASS
    construct $namesp $CLASS
................................................................................
    namespace eval $namesp [list namespace export -clear $CLASS]
    namespace eval :: [list namespace import -force ${namesp}::$CLASS]
    interp alias {} ::[string tolower $CLASS] {} ::$CLASS

    ## These are provided so that errors due to lack of the command
    ## existing don't arise.  Since they are stubbed out here, the
    ## user can't depend on 'unknown' or 'auto_load' to get this proc.
    if {[string equal {} [info commands ${namesp}::construct]]} {
	proc ${namesp}::construct {w} {
	    # the user should rewrite this
	    # without the following error, a simple megawidget that was just
	    # a frame would be created by default
	    return -code error "user must write their own\
		    [lindex [info level 0] 0] function"
	}
    }
    if {[string equal {} [info commands ${namesp}::init]]} {
	proc ${namesp}::init {w} {
	    # the user should rewrite this
	}
    }

    ## The user is not supposed to change this proc
    set comps [lsort [array names components]]
    proc ${namesp}::_subwidget {w {widget return} args} [subst {
	variable \$w
	upvar 0 \$w data
	switch -- \$widget {
	    return	{
		return [list $comps]
	    }
	    all {
................................................................................
	    }
	}
    }]

    ## The user is not supposed to change this proc
    ## Instead they create a ::Widget::$CLASS::destruct proc
    ## Some of this may be redundant, but at least it does the job
    proc ${namesp}::_destruct {w} "
    upvar \#0 ${namesp}::\$w data
    catch {${namesp}::destruct \$w}
    catch {::destroy \$data(base)}
    catch {::destroy \$w}
    catch {rename \$data(basecmd) {}}
    catch {rename ::\$data(base) {}}
    catch {rename ::\$w {}}
    catch {unset data}
    return\n"
    
    if {[string equal {} [info commands ${namesp}::destruct]]} {
	## The user can optionally provide a special destroy handler
	proc ${namesp}::destruct {w args} {
	    # empty
	}
    }

    ## The user is not supposed to change this proc
    proc ${namesp}::_cget {w args} {
	if {[llength $args] != 1} {
	    return -code error "wrong \# args: should be \"$w cget option\""
	}
	set namesp [namespace current]
	upvar \#0 ${namesp}::$w data ${namesp}::options options
	if {[info exists options($args)]&&[string match -* $options($args)]} {
	    set args $options($args)
	}
	if {[string equal {} [set arg [array names data $args]]]} {
	    set arg [array names data ${args}*]
	}
	set num [llength $arg]
	if {$num==1} {
	    return $data($arg)
	} elseif {$num} {
	    return -code error "ambiguous option \"$args\",\
................................................................................
	} else {
	    return $err
	}
    }

    ## The user is not supposed to change this proc
    ## Instead they create a $CLASS:configure proc
    proc ${namesp}::_configure {w args} {
	set namesp [namespace current]
	upvar \#0 ${namesp}::$w data ${namesp}::options options \
		${namesp}::components components

	set num [llength $args]
	if {$num==1} {
	    ## Request for one config option
	    if {[info exists options($args)] && \
		    [string match -* $options($args)]} {
		set args $options($args)
	    }
	    if {[string equal {} [set arg [array names data $args]]]} {
		set arg [array names data ${args}*]
	    }
	    set num [llength $arg]
	    if {$num==1} {
		## FIX one-elem config
		return "[list $arg] $options($arg) [list $data($arg)]"
	    } elseif {$num} {
................................................................................
	    set widargs {}
	    set cmdargs {}
	    foreach {key val} $args {
		if {[info exists options($key)] && \
			[string match -* $options($key)]} {
		    set key $options($key)
		}
		if {[string equal {} [set arg [array names data $key]]]} {
		    set arg [array names data $key*]
		}
		set len [llength $arg]
		if {$len==1} {
		    lappend widargs $arg $val
		} elseif {$len} {
		    set ambarg [list $key $arg]
................................................................................
		    lappend cmdargs $key $val
		}
	    }
	    if {[llength $widargs]} {
		uplevel ${namesp}::configure [list $w] $widargs
	    }
#	    if {[llength $cmdargs]} {
#		proc _configure {w args} {
#		    catch {uplevel [list $w] configure $args}
#		    set n [namespace current]
#		    foreach c [winfo children $w] {
#			uplevel ${n}::_configure [list $c] $args
#		    }
#		}
#		uplevel widget configure [list $w] $cmdargs
................................................................................
	    foreach opt [lsort [array names opts]] {
		lappend config "$opt $opts($opt)"
	    }
	    return $config
	}
    }

    if {[string equal {} [info commands ${namesp}::configure]]} {
	## The user is intended to rewrite this one
	proc ${namesp}::configure {w args}  {
	    foreach {key val} $args {
		puts "$w: configure $key to [list $value]"
	    }
	}
    }

    set CLASSES($CLASS) $namesp
    return $namesp
}

# Redefine private Tk function tkFocusOK to recognize our widgets
#
proc ::Widget::_tkFocusOK w {
    if {[llength [info commands widget]] && \
	    [llength [widget classes [winfo class $w]]]} {
	return 0
    }
    set code [catch {$w cget -takefocus} value]
    if {($code == 0) && ($value != "")} {
	if {$value == 0} {
................................................................................
    set code [catch {$w cget -state} value]
    if {($code == 0) && ($value == "disabled")} {
	return 0
    }
    regexp Key|Focus "[bind $w] [bind [winfo class $w]]"
}



namespace eval :: {
    namespace import -force ::Widget::widget
    if {$tk_version < 8.4} {
	catch {tkFocusOK .}; # we want this auto-loaded
	interp alias {} tkFocusOK {} widget tkFocusOK
    } else {
	catch {tk::FocusOK .}; # we want this auto-loaded
................................................................................
## (all state info), but if special cleanup stuff is needed, you would provide
## it in this procedure.  This is the first proc called in the default destroy
## handler.
##

namespace eval ::Widget::ScrolledText {;

proc construct {w} {
    upvar \#0 [namespace current]::$w data

    grid $data(text) $data(yscrollbar) -sticky news
    grid $data(xscrollbar) -sticky ew
    grid columnconfig $w 0 -weight 1
    grid rowconfig $w 0 -weight 1
    grid remove $data(yscrollbar) $data(xscrollbar)
    bind $data(text) <Configure> [namespace code [list resize $w 1]]
}

proc configure {w args} {
    upvar \#0 [namespace current]::$w data

    foreach {key val} $args {
	switch -- $key {
	    -autoscrollbar	{
		set data($key) [string is true -strict $val]
		if {$data($key)} {
		    resize $w 0
		} else {
		    grid $data(xscrollbar)
		    grid $data(yscrollbar)
		}
	    }
	}
    }
}

# captures xview commands to the text widget
proc _xview {w args} {
    upvar \#0 [namespace current]::$w data
    if {[catch {uplevel $data(basecmd) xview $args} err]} {
	return -code error $err
    }
}

# captures yview commands to the text widget
proc _yview {w args} {
    upvar \#0 [namespace current]::$w data
    if {[catch {uplevel $data(basecmd) yview $args} err]} {
	return -code error $err
    } elseif {![winfo ismapped $data(xscrollbar)] && \
	    ![string equal {0 1} [$data(basecmd) xview]]} {
	## If the xscrollbar was unmapped, but is now needed, show it
	grid $data(xscrollbar)
    }
}

# captures insert commands to the text widget
proc _insert {w args} {
    upvar \#0 [namespace current]::$w data
    set code [catch {uplevel $data(basecmd) insert $args} err]
    if {[winfo ismapped $w]} { resize $w 0 }
    return -code $code $err
}

# captures delete commands to the text widget
proc _delete {w args} {
    upvar \#0 [namespace current]::$w data
    set code [catch {uplevel $data(basecmd) delete $args} err]
    if {[winfo ismapped $w]} { resize $w 1 }
    return -code $code $err
}

# called when the ScrolledText widget is resized by the user or possibly
# needs the scrollbars (de|at)tached due to insert/delete.
proc resize {w d} {
    upvar \#0 [namespace current]::$w data
    ## Only when deleting should we consider removing the scrollbars
    if {!$data(-autoscrollbar)} return
    set base $data(basecmd)
    ## We will have to disable the Configure event temporarily, to
    ## prevent looping due to a quirk in geometry management where
    ## adding/removing the scrollbar changes the widget size.
    set W $data(text)
    set bind [bind $W <Configure>]
    bind $W <Configure> {}
    if {![string equal {0 1} [$base xview]]} {
	grid $data(xscrollbar)
    } elseif {$d} {
	grid remove $data(xscrollbar)
    }
    if {![string equal {0 1} [$base yview]]} {
	grid $data(yscrollbar)
    } elseif {$d} {
	grid remove $data(yscrollbar)
    }
    ## As with the Configure problem, it can affect the cursor too...
    $base see insert
    after 100 [list bind $W <Configure> $bind]
}


}; #end namespace ::Widget::ScrolledText