A Widget Library
Check-in [9638cf7a81]
Not logged in

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

Overview
Comment:initial import of widget package into tcllib repository
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 9638cf7a81e7ce1473af70003aa1daa9bd323c19
User & Date: hobbs 2001-06-25 23:05:50.000
Context
2001-06-26
00:39
* library/calculator.tcl: * library/console.tcl: * library/hierarchy.tcl: * library/megalist.tcl: * library/pane.tcl: * library/progressbar.tcl: * library/util-color.tcl: * library/util.tcl: * library/ventry.tcl: corrected code that procheck complained about * library/util-find.tcl: * library/util-list.tcl: removed - they weren't ready yet check-in: 59bcef3c64 user: hobbs tags: trunk
2001-06-25
23:05
initial import of widget package into tcllib repository check-in: 9638cf7a81 user: hobbs tags: trunk
23:05
initial empty check-in check-in: 51780a4330 user: root tags: trunk
Changes
Unified Diff Ignore Whitespace Patch
Added ChangeLog.








>
>
>
>
1
2
3
4
2001-06-25  Jeff Hobbs  <[email protected]>

	* initial import of widget code into tcllib repository

Added LICENSE.txt.
















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
		   * 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 <[email protected]>.  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,
or royalty fee is required for any of the authorized uses.

IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR
DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF,
EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE IS
PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO
OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.

RESTRICTED RIGHTS: Use, duplication or disclosure by the U.S. government
is subject to the restrictions as set forth in subparagraph (c) (1) (ii)
of the Rights in Technical Data and Computer Software Clause as DFARS
252.227-7013 and FAR 52.227-19.

SPECIAL NOTES:

This software is also falls under the bourbon_ware clause:

  Should you find this software useful in your daily work, you should
  feel obliged to take the author out for a drink if the opportunity
  presents itself.  The user may feel exempt from this clause if they are
  under 21 or think the author has already partaken of too many drinks.
Added demo/TOUR.tcl.












































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
#!/bin/sh
# The next line is executed by /bin/sh, but not tcl \
exec wish $0 ${1+"$@"}

# tour --
#
#	Tour of the megawidget of package ::Widget
#
# Copyright (c) 1997 Jeffrey Hobbs
#

package require Tk
if {![info exists TOUR(LOADED)]} {
    set TOUR(SCRIPT) [info script]
    foreach dir [list \
	    [file join [file dirname $TOUR(SCRIPT)] .. library] \
	    ] {
	if {[lsearch -exact $auto_path $dir]==-1} {
	    lappend auto_path $dir
	}
    }
    if {[string compare unix $tcl_platform(platform)]} {
	# get rid of the console on windows/mac
	catch {rename console winconsole}
    }
    set TOUR(LOADED) 0
}

## AllWidgets will end up including:
# Widget
#   ::Utility
#   ::Utility::dump
#   ::Utility::string
#   ::Utility::number
#   ::Utility::tk
#   ::Utility::expand
# BalloonHelp
# Calculator
# Combobox
# Console
# Hierarchy
# Megalist
# Pane  
# Progressbar
# Tabnotebook
# Ventry
package require AllWidgets

destroy .tab .exit

tabnotebook .tab
button .exit -text "Exit" -command exit

namespace import -force ::Utility::*

grid .tab -sticky news
grid .exit -sticky ew
grid rowconfigure . 0 -weight 1
grid columnconfig . 0 -weight 1

foreach n {
    Main Combobox Console Hierarchy Megalist Progressbar Ventry Script
} {
    set TOUR($n) [frame .tab.[string tolower $n]]
    .tab add $n -window $TOUR($n)
}
.tab activate Main

# get_comments --
#
#   Gets the major comments out of a file.  If not a real filename,
#   assume it is a package name that has a particular ifneeded setup.
#
# Arguments:
#   file	file to get comments out of.
# Results:
#   Returns the related comments.
#
proc get_comments {file} {
    if {![file exists $file]} {
	set version [package provide $file]
	if {[string match {} $version]} { return "## No Comments Found" }
	set loadstr [package ifneeded $file $version]
	if {[string match tclPkgSetup* $loadstr]} {
	    set file [lindex [lindex [lindex $loadstr 4] 0] 0]
	} else {
	    # this expects 8.1 regexps
	    regexp {(\w+.tcl)} $loadstr file
	}
	if {![file exists $file]} {
	    return "## Couldn't determine file for package '$file'"
	}
    }
    set fid [open $file]
    set comments {}
    set last 0
    while {[gets $fid line] != -1} {
	if {[string match "##*" $line]} {
	    append comments $line\n
	    set last 1
	} elseif {$last} {
	    append comments \n
	    set last 0
	}
    }
    return $comments
}


## Main Tab
##
set f $TOUR(Main)
pack [scrolledtext $f.t] -fill both -expand 1
$f.t insert 1.0 "Welcome to the widget tour.

In the above tabs you will find basic examples with small feature
descriptions of the various widgets in this package.

This tour itself uses the Tabnotebook widget as the basic container
for the widget tour.
"

## Combobox Tab
##
set f $TOUR(Combobox)
scrolledtext $f.t -height 5
set w [frame $f.p]
combobox $w.c1 -labeltext "Basic Combobox: "
combobox $w.c2 -labeltext "Windows-like Combobox:" \
	-width 15 -textvariable myvar -click single \
	-list {{first choice} {second} {another choice} {final choice}}
if {[string compare windows $tcl_platform(platform)]} {
    $w.c2 configure -bg white -selectforeground blue
}
label $w.l -text "Value:"
label $w.myvar -textvariable myvar
grid $w.c1 - - -sticky ew
grid $w.c2 $w.l $w.myvar -sticky ew
grid columnconfig $w 0 -weight 1
pane $f.t $f.p -orient vertical -dynamic yes

$f.t insert 1.0 "Combobox class widget.

The combobox emulates the Tix widget of the same name.

Major comments for class:
[get_comments Combobox]
"

## Console Tab
##
set f $TOUR(Console)
pack [scrolledtext $f.t -height 5] -fill x
pack [console $f.c -height 10] -fill both -expand 1
pane $f.t $f.c -orient vertical

$f.t insert 1.0 "Console class widget.

This is an interactive console for Tcl/Tk derived from TkCon.  It
presents an interactive window into the interpreter, with many
features to assist in interactive debugging.

Major comments for class:
[get_comments Console]
"

## Hierarchy Tab
##
set f $TOUR(Hierarchy)
scrolledtext $f.t -height 5
frame $f.p
set TOUR(Hierarchy,w) [hierarchy_widget $f.p.w -root .]
set TOUR(Hierarchy,d) [hierarchy_dir $f.p.d -root [file dirname [pwd]] \
	-showparent "Parent" -showfiles 1]
pane $f.t $f.p -orient vertical
pane $f.p.w $f.p.d -dynamic 1

$f.t insert 1.0 "Paned window management and the Hierarchy class widgets.

The hierarchy widgets displayed are for widget and file touring.

Major comments for class Hierarchy:
[get_comments Hierarchy]
"

## Megalist Tab
##
set f $TOUR(Megalist)
pack [scrolledtext $f.t -height 5] -fill x

$f.t insert 1.0 "Major comments for class Megalist:
[get_comments Megalist]
"

## Progressbar Tab
##
set f $TOUR(Progressbar)
pack [scrolledtext $f.t -height 5] -fill x
pack [progressbar $f.p0 -labelt "Progress Bar" -variable ::P(0)] -side bottom
pack [progressbar $f.p1 -labelt "Slow" -orient v -variable ::P(1)] -side left
pack [progressbar $f.p2 -labelt "Fast" -orient v -variable ::P(2)] -side left

$f.t insert 1.0 "Major comments for class Progressbar:
[get_comments Progressbar]
"
# self-rescheduling incr proc for progressbars
proc increase {varname {val 10} {delay 600}} {
    upvar $varname var
    set var [expr {($var+$val)%100}]
    after $delay [info level 0]
}
array set ::P {0 0 1 0 2 0 3 0}
increase ::P(0)
increase ::P(1) 1
increase ::P(2) 5 150

## Ventry Tab
##
set f $TOUR(Ventry)
pack [scrolledtext $f.t -height 5] -fill x
pack [ventry $f.v1 -labeltext "Integers:" -labelwidth 14 -validate key \
	-vcmd {regexp {^[-+]?[0-9]*$} %P}] -fill x
pack [ventry $f.v2 -labeltext "Max 8 chars:" -labelwidth 14 -validate key \
	-vcmd {expr {[string length %P]<=8}}] -fill x
pack [ventry $f.v3 -labeltext "Date on focus:" -labelwidth 14 \
	-validate focusout -validatecmd {check_date %W %s} \
	-invalidcmd {warn "Invalid Date specified"}] -fill x

proc check_date {w date} {
    if {[string match {} $date]} { return 1 }
    $w delete 0 end
    set code [validate date $date]
    if {$code} {
	$w insert 0 [clock format [clock scan $date]]
    } else {
	focus -force [$w subwidget entry]
    }
    return $code
}

$f.t insert 1.0 "Ventry class widget.

Major comments for class:
[get_comments Ventry]
"

## Script Tab
##
set f $TOUR(Script)
scrolledtext $f.t -wrap none
button $f.rerun -text "Rerun Buffer" -command rerun
button $f.reload -text "Reload Script" -command {reload 1}

grid $f.t -
grid $f.rerun $f.reload
grid rowconfig $f 0 -weight 1
grid columnconfig $f 0 -weight 1
grid columnconfig $f 1 -weight 1

proc reload {{force 0}} {
    global TOUR
    
    set text $TOUR(Script).t
    $text delete 1.0 end
    if {$force || !$TOUR(LOADED)} {
	if {[catch {open $TOUR(SCRIPT)} fid]} {
	    $text insert 1.0 $fid
	} else {
	    $text insert 1.0 [read $fid]
	    close $fid
	}
    } else {
	$text insert 1.0 $TOUR(BUFFER)
    }
    set TOUR(BUFFER) [$text get 1.0 end-1c]
}

proc rerun {} {
    global TOUR
    ## Get data from text widget
    set TOUR(BUFFER) [$TOUR(Script).t get 1.0 end-1c]
    uplevel \#0 $TOUR(BUFFER)
}

reload

## Balloon Help
##
balloonhelp clear
balloonhelp .exit "The Exit Button"
balloonhelp $TOUR(Hierarchy,w) "Widget hierarchy"
balloonhelp $TOUR(Hierarchy,d) "Directory hierarchy"

set TOUR(LOADED) 1
Added library/balloonhelp.tcl.






















































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
##
## Copyright 1996-8 Jeffrey Hobbs, [email protected]
##
## Initiated: 28 October 1996
##
package provide BalloonHelp 2.0

##------------------------------------------------------------------------
## PROCEDURE
##	balloonhelp
##
## DESCRIPTION
##	Implements a balloon help system
##
## ARGUMENTS
##	balloonhelp <option> ?arg?
##
## clear ?pattern?
##	Stops the specified widgets (defaults to all) from showing balloon
##	help.
##
## delay ?millisecs?
##	Query or set the delay.  The delay is in milliseconds and must
##	be at least 50.  Returns the delay.
##
## disable OR off
##	Disables all balloon help.
##
## enable OR on
##	Enables balloon help for defined widgets.
##
## <widget> ?-index index? ?message?
##	If -index is specified, then <widget> is assumed to be a menu
##	and the index represents what index into the menu (either the
##	numerical index or the label) to associate the balloon help
##	message with.  Balloon help does not appear for disabled menu items.
##	If message is {}, then the balloon help for that
##	widget is removed.  The widget must exist prior to calling
##	balloonhelp.  The current balloon help message for <widget> is
##	returned, if any.
##
## RETURNS: varies (see methods above)
##
## NAMESPACE & STATE
##	The global array BalloonHelp is used.  Procs begin with BalloonHelp.
## The overrideredirected toplevel is named $BalloonHelp(TOPLEVEL).
##
## EXAMPLE USAGE:
##	balloonhelp .button "A Button"
##	balloonhelp .menu -index "Load" "Loads a file"
##
##------------------------------------------------------------------------

namespace eval ::Widget::BalloonHelp {;

namespace export -clear balloonhelp
variable BalloonHelp

## The extra :hide call in <Enter> is necessary to catch moving to
## child widgets where the <Leave> event won't be generated
bind Balloons <Enter> [namespace code {
    #BalloonHelp:hide
    variable BalloonHelp
    set BalloonHelp(LAST) -1
    if {$BalloonHelp(enabled) && [info exists BalloonHelp(%W)]} {
	set BalloonHelp(AFTERID) [after $BalloonHelp(DELAY) \
		[namespace code [list show %W $BalloonHelp(%W)]]]
    }
}]

bind Menu <<MenuSelect>>	[namespace code { menuMotion %W }]
bind Balloons <Leave>		[namespace code hide]
bind Balloons <Any-KeyPress>	[namespace code hide]
bind Balloons <Any-Button>	[namespace code hide]

array set BalloonHelp {
    enabled	1
    DELAY	500
    AFTERID	{}
    LAST	-1
    TOPLEVEL	.__balloonhelp__
}

proc balloonhelp {w args} {
    variable BalloonHelp
    switch -- $w {
	clear	{
	    if {[llength $args]==0} { set args .* }
	    clear $args
	}
	delay	{
	    if {[llength $args]} {
		if {![regexp {^[0-9]+$} $args] || $args<50} {
		    return -code error "BalloonHelp delay must be an\
			    integer greater than 50 (delay is in millisecs)"
		}
		return [set BalloonHelp(DELAY) $args]
	    } else {
		return $BalloonHelp(DELAY)
	    }
	}
	off - disable	{
	    set BalloonHelp(enabled) 0
	    hide
	}
	on - enable	{
	    set BalloonHelp(enabled) 1
	}
	default {
	    set i $w
	    if {[llength $args]} {
		set i [uplevel 1 [namespace code "register [list $w] $args"]]
	    }
	    set b $BalloonHelp(TOPLEVEL)
	    if {![winfo exists $b]} {
		toplevel $b
		wm overrideredirect $b 1
		wm positionfrom $b program
		wm withdraw $b
		pack [label $b.l -highlightthickness 0 -relief raised -bd 1 \
			-background lightyellow -fg black]
	    }
	    if {[info exists BalloonHelp($i)]} { return $BalloonHelp($i) }
	}
    }
}

;proc register {w args} {
    variable BalloonHelp
    set key [lindex $args 0]
    while {[string match -* $key]} {
	switch -- $key {
	    -index	{
		if {[catch {$w entrycget 1 -label}]} {
		    return -code error "widget \"$w\" does not seem to be a\
			    menu, which is required for the -index switch"
		}
		set index [lindex $args 1]
		set args [lreplace $args 0 1]
	    }
	    default	{
		return -code error "unknown option \"$key\": should be -index"
	    }
	}
	set key [lindex $args 0]
    }
    if {[llength $args] != 1} {
	return -code error "wrong \# args: should be \"balloonhelp widget\
		?-index index? message\""
    }
    if {[string match {} $key]} {
	clear $w
    } else {
	if {![winfo exists $w]} {
	    return -code error "bad window path name \"$w\""
	}
	if {[info exists index]} {
	    set BalloonHelp($w,$index) $key
	    #bindtags $w [linsert [bindtags $w] end BalloonsMenu]
	    return $w,$index
	} else {
	    set BalloonHelp($w) $key
	    bindtags $w [linsert [bindtags $w] end Balloons]
	    return $w
	}
    }
}

;proc clear {{pattern .*}} {
    variable BalloonHelp
    foreach w [array names BalloonHelp $pattern] {
	unset BalloonHelp($w)
	if {[winfo exists $w]} {
	    set tags [bindtags $w]
	    if {[set i [lsearch $tags Balloons]] != -1} {
		bindtags $w [lreplace $tags $i $i]
	    }
	    ## We don't remove BalloonsMenu because there
	    ## might be other indices that use it
	}
    }
}

;proc show {w msg {i {}}} {
    ## Use string match to allow that the help will be shown when
    ## the pointer is in any child of the desired widget
    if {![winfo exists $w] || ![string match \
	    $w* [eval winfo containing [winfo pointerxy $w]]]} return

    variable BalloonHelp
    global tcl_platform
    set b $BalloonHelp(TOPLEVEL)
    $b.l configure -text $msg
    update idletasks
    if {[string compare {} $i]} {
	set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[$w yposition $i]+25}]
	if {($y+[winfo reqheight $b])>[winfo screenheight $w]} {
	    set y [expr {[winfo rooty $w]+[$w yposition $i]-\
		    [winfo reqheight $b]-5}]
	}
    } else {
	set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[winfo height $w]+5}]
	if {($y+[winfo reqheight $b])>[winfo screenheight $w]} {
	    set y [expr {[winfo rooty $w]-[winfo reqheight $b]-5}]
	}
    }
    set x [expr {[winfo rootx $w]+[winfo vrootx $w]+\
	    ([winfo width $w]-[winfo reqwidth $b])/2}]
    if {$x<0} {
	set x 0
    } elseif {($x+[winfo reqwidth $b])>[winfo screenwidth $w]} {
	set x [expr {[winfo screenwidth $w]-[winfo reqwidth $b]}]
    }
    wm geometry $b +$x+$y
    if {[string match windows $tcl_platform(platform)]} {
	## Yes, this is only needed on Windows
	update idletasks
    }
    wm deiconify $b
    raise $b
}

;proc menuMotion {w} {
    variable BalloonHelp
    if {$BalloonHelp(enabled)} {
	set cur [$w index active]
	## The next two lines (all uses of LAST) are necessary until the
	## <<MenuSelect>> event is properly coded for Unix/(Windows)?
	if {$cur == $BalloonHelp(LAST)} return
	set BalloonHelp(LAST) $cur
	## a little inlining - this is :hide
	after cancel $BalloonHelp(AFTERID)
	catch {wm withdraw $BalloonHelp(TOPLEVEL)}
	if {[info exists BalloonHelp($w,$cur)] || \
		(![catch {$w entrycget $cur -label} cur] && \
		[info exists BalloonHelp($w,$cur)])} {
	    set BalloonHelp(AFTERID) [after $BalloonHelp(DELAY) \
		    [namespace code [list show $w $BalloonHelp($w,$cur) $cur]]]
	}
    }
}

;proc hide {args} {
    variable BalloonHelp
    after cancel $BalloonHelp(AFTERID)
    catch {wm withdraw $BalloonHelp(TOPLEVEL)}
}

}; # end namespace ::Widget::BalloonHelp

namespace eval :: {namespace import -force ::Widget::BalloonHelp::balloonhelp}
Added library/calculator.tcl.






































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
##
## Copyright 1996-1997 Jeffrey Hobbs, [email protected]
##
## WORK IN PROGRESS - NOT FUNCTIONAL
##

package require Widget 2.0
package provide Calculator 1.0

proc Calculator args {}
proc calculator args {}
widget create Calculator -type frame -base frame -components {
    {frame menubar mbar {-relief raised -bd 1}}
    {listbox data data {-height 5 -bg white \
	    -yscrollcommand [list $data(yscrollbar) set] \
	    -xscrollcommand [list $data(xscrollbar) set] \
	    -selectbackground yellow -selectborderwidth 0 \
	    -selectmode single -takefocus 1}}
    {scrollbar yscrollbar sy {-takefocus 0 -bd 1 -orient v \
	    -command [list $data(data) yview]}}
    {scrollbar xscrollbar sx {-takefocus 0 -bd 1 -orient h \
	    -command [list $data(data) xview]}}
    {entry entry e {-bg white -takefocus 1}}
    {frame modef}
    {frame buttons}
    {label label lbl {-fg \#0000FF -textvariable ${w}(message)}}
} -options {
    {-base	base	Base	DEC}
    {-degree	degree	Degree	RAD}
    {-menubar	menuBar	MenuBar	1}
    {-mode	mode	Mode	Trig}
    {-status	status	Status	0}
    {-type	type	Type	REG}
}

namespace eval ::Widget::Calculator {;

variable class
array set class {
    constants	{
	pi	3.141592654
	e	2.718281828
    }
}

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

    array set data {
	index		end
	modes		{Scientific Logical Financial}
    }

    grid $data(menubar)	-	-sticky ew
    grid $data(data)    $data(yscrollbar)	-sticky news
    grid $data(xscrollbar)	-sticky ew
    grid $data(entry)	-	-sticky ew
    grid $data(modef)	-	-sticky ew
    grid $data(buttons)	-	-sticky news
    grid $data(label)	-	-sticky ew
    grid columnconfig $w 0 -weight 1
    grid rowconfigure $w 1 -weight 1
    grid remove $data(yscrollbar) $data(xscrollbar) $data(label)

    initMenus $w

    set b $data(buttons)
    for {set i 0} {$i < 10} {incr i} {
	button $b.$i -text $i -width 3 -bg \#d9d9FF \
		-command [namespace code [list _num $i]]
    }
    foreach i {A B C D E F} {
	button $b.[string tolower $i] -text $i -width 3 -bg \#d9d9FF \
		-command [namespace code [list _num $i]]
    }
    button $b.del  -text DEL	-command [namespace code [list _backspace $w]]
    button $b.clr  -text CLR	-command [namespace code [list _clear $w]]
    button $b.drop -text Drop	-command [namespace code [list _drop $w]]
    button $b.swap -text Swap	-command [namespace code [list _swap $w]]
    button $b.sign -text +/-	-command [namespace code [list _changesign $w]]
    button $b.inv  -text 1/x	-command [namespace code [list _invert $w]]
    button $b.xtoy -text x^y	-command [namespace code [list _func $w pow]]
    button $b.sqr  -text x^2	-command [namespace code [list _sqr $w]]
    button $b.sqrt -text Sqrt	-command [namespace code [list _sqrt $w]]
    button $b.perc -text %	-command [namespace code [list _percent $w]]
    button $b.dot  -text .	-command [namespace code [list _decimal $w]]
    button $b.add  -text + -bg yellow \
	    -command [namespace code [list _binary $w +]]
    button $b.sub  -text - -bg yellow \
	    -command [namespace code [list _binary $w -]]
    button $b.mul  -text * -bg yellow \
	    -command [namespace code [list _binary $w *]]
    button $b.div  -text / -bg yellow \
	    -command [namespace code [list _binary $w /]]

    grid $b.inv $b.sqr $b.sqrt $b.perc -sticky news
    grid $b.d $b.e $b.f $b.clr -sticky nsew
    grid $b.a $b.b $b.c $b.del -sticky nsew
    grid $b.7 $b.8 $b.9 $b.add -sticky nsew
    grid $b.4 $b.5 $b.6 $b.sub -sticky nsew
    grid $b.1 $b.2 $b.3 $b.mul -sticky nsew
    grid $b.sign $b.0 $b.dot $b.div -sticky nsew
    grid columnconfig $b 0 -weight 1
    grid columnconfig $b 1 -weight 1
    grid columnconfig $b 2 -weight 1
    grid columnconfig $b 3 -weight 1

    ## Standard bindings
    ##
    bind Calculator <<CalcNumber>>	[namespace code [list _num $i]]
    bind Calculator <<CalcBinOp>>	[namespace code [list _binary $w %K]]
    event add <<CalcBinOp>> <KP_Add> <KP_Subtract> <KP_Multiply> <KP_Divide> \
	    + - * /
    bind Calculator <Return>		[namespace code [list _enter $w]]
    bind Calculator <KP_Enter>		[namespace code [list _enter $w]]
    bind Calculator <KP_Decimal>	[namespace code [list _decimal $w]]
    bind Calculator .			[namespace code [list _decimal $w]]

    bind Calculator <Shift-BackSpace>	[namespace code [list _drop $w]]
    bind Calculator <BackSpace>		[namespace code [list _backspace $w]]

    _push $w {}
    recursive_bind $w
}

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

    set truth {^(1|yes|true|on)$}
    foreach {key val} $args {
	switch -- $key {
	    -base	{
		if {![regexp -nocase {^(DEC|HEX|OCT|BIN)$} $val]} {
		    return -code error "bad value \"$val\", must be one of:\
			    dec, hex, oct, bin"
		}
		set val [string toupper $val]
	    }
	    -degree	{
		if {![regexp -nocase {^(RAD|GRAD|DEG)$} $val]} {
		    return -code error "bad value \"$val\",\
			    must be one of: rad, grad, deg"
		}
		set val [string toupper $val]
	    }
	    -menubar	{
		if {[set val [regexp -nocase $truth $val]]} {
		    grid $data(menubar)
		} else {
		    grid remove $data(menubar)
		}
	    }
	    -mode	{
		if {![regexp -nocase ^([join $data(modes) |])\$ $val]} {
		    return -code error "bad value \"$val\",\
			    must be one of: [join $data(modes) {, }]"
		}
		set val [string toupper $val]
	    }
	    -status	{
		if {[set val [regexp -nocase $truth $val]]} {
		    grid $data(label)
		} else {
		    grid remove $data(label)
		}
	    }
	    -type	{
		if {![regexp -nocase ^([join $data(types) |])\$ $val]} {
		    return -code error "bad value \"$val\",\
			    must be one of: [join $data(types) {, }]"
		}
		set val [string toupper $val]
	    }
	}
	set data($key) $val
    }
}

;proc recursive_bind w {
    foreach c [winfo children $w] {
	if {[string compare Entry [winfo class $c]]} {
	    bindtags $c [concat [bindtags $c] Calculator]
	}
	recursive_bind $c
    }
}

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

    ## File Menu
    ##
    set m $data(menubar).file
    pack [menubutton $m -text "File" -underline 0 -menu $m.m] -side left
    set m [menu $m.m]
    $m add command -label "Save" -underline 0

    ## Math Menu
    ##
    set m $data(menubar).math
    pack [menubutton $m -text "Math" -underline 0 -menu $m.m] -side left
    set m [menu $m.m]
    $m add cascade -label "Constants" -menu $m.const

    ## Constants Menu
    ##
    menu $m.const -postcommand [list winConst $w $m.const]

    ## Help Menu
    ##
    set m $data(menubar).help
    pack [menubutton $m -text "Help" -underline 0 -menu $m.m] -side right
    set m [menu $m.m]
    $m add command -label "About" -command [list _about $w]
}

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

    if {[string compare $msg {}]} {
	tk_dialog $w.error "Calculator Error" $msg error 0 Oops
    }
}

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

    array set const $data(constants)
    _push $w {}
}

;proc _convert {w from to args} {
    upvar \#0 [namespace current]::$w data

    foreach num $args {
    }
}

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

    set arg1 [_pop $w]
    if {[string match {} $arg1]} { return 0 }
    _push $w [expr 0 - $arg1]
    _push $w {}
}

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

    _pop $w
    _push $w {}
}

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

    if {[string match {} [_peek $w]]} {
	_pop $w
	_push $w {}
	return
    }
    set arg1 [_pop $w]
    set arg2 [string trimright $arg1 .]
    _push $w $arg2
}

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

    set arg1 [_pop $w]
    set arg2 [_pop $w]
    if {[string match {} $arg2]} {
	_push $w $arg1
	if {[string compare $arg1 {}]} { _push $w {} }
	return
    }
    _push $w [expr double($arg2) $op $arg1]
    _push $w {}
}

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

    if {[string len $ip] > 3} {
	set fmt {([0-9])([0-9])([0-9])}
	switch [expr [string len $ip]%3] {
	    0 { regsub -all $fmt $ip {\1\2\3,} ip }
	    1 { regsub -all $fmt $ip {\1,\2\3} ip }
	    2 { regsub -all $fmt $ip {\1\2,\3} ip }
	}
	set ip [string trimright $ip ,]
    }
    return $ip
}

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

    if {[string match {} [$data(data) get $data(index)]]} {
	_push $w 0.
    } else {
	set arg1 [_pop $w]
	_push $w [string trimright $arg1 .].
    }
}

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

    set push 0
    if {[string match {} [$data(data) get $data(index)]]} {
	set push 1
    }
    set stk [_pop $w]
    if {[string match {} $stk]} { return 0 }
    _push $w $stk
    if $push { _push $w $stk }
    _push $w {}
}

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

    set arg1 [_pop $w]
    set arg2 [_pop $w]
    if {[string match {} $arg2]} {
	_push $w $arg1
	if {[string compare $arg1 {}]} { _push $w {} }
	return 0
    }
    _push $w [expr $op ($arg2, $arg1)]
    _push $w {}
}

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

    if {[string match {} [set arg1 [_pop $w]]} { return 0 }
    if {$arg1 == 0} {
	calcerror $w "Division by 0 error"
	return 0
    }
    _push $w [expr 1.0 / $arg1]
    _push $w {}
}

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

    set idx $data(index)
    if {[string match {} [$data(data) get $idx]]} {
	$data(data) delete $idx
	set stk {}
    } else {
	set stk [_pop $w $idx]
    }
    _push $w $stk$val $idx
}

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

    set arg1 [_pop $w]
    set arg2 [_pop $w]
    if {[string compare $arg2 {}]} {
	_push $w $arg1
	if {[string compare $arg1 {}]} { _push $w {} }
	return 0
    }
    _push $w $arg1
    _push $w $arg2
    _push $w {}
}

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

    set arg1 [_pop $w]
    if {[llength $arg1]} {
	_push $w [expr $op ($arg1)]
	_push $w {}
    } else { return 0 }
}

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

    if {[string match {} $idx]} { set idx [$data(data) curselection] }
    if {[string match {} [$data(data) get $idx]]} { $data(data) delete $idx }
    regsub -all {,} [$data(data) get $idx] {} val
    return $val
}

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

    if {[string match {} $idx]} { set idx [$data(data) curselection] }
    if {[string match {} [$data(data) get $idx]]} { $data(data) delete $idx }
    set val [$data(data) get $idx]
    if {[string match {} $val]} {
	calcerror $w "Not enough arguments"
	return
    }
    $data(data) delete $idx
    regsub -all {,} $val {} val
    $data(data) selection clear 0 end
    $data(data) selection set $idx $idx
    $data(data) see $idx
    if {[string compare end $data(index)]} {
	set data(index) [expr $idx+1]
    }
    return $val
}

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

    if {[string match {} $idx]} { set idx $data(index) }
    if {[string match {} [$data(data) get $idx]]} { $data(data) delete $idx }

    switch $data(-base) {
	DEC {
	    regsub -all {^0+} $val {} val
	    ## break into sign, integer, fractional and exponent parts
	    if {[regexp {^([-+])?([0-9]*)(\.)?([0-9]*)?(e[-+]?[0-9]+)?$} \
		    $val full sign ip dec fp ee]} {
		if {[string match {} $ip]} {
		    if {[string compare $full {}]} { set ip 0 }
		} else { set ip [commify $w $ip] }
		set val $sign$ip$dec$fp$ee
	    } else {
		#if [scan $val %d]
	    }
	}
	OCT {
	    if {![regsub -all {^0+} $val {0} val]} {
		set val 0$val
	    }
	}
	HEX {  }
	BIN {  }
    }
    $data(data) insert $idx $val
    $data(data) selection clear 0 end
    $data(data) selection set $idx $idx
    $data(data) see $idx
    #set data(index) $idx
}

}; # end namespace ::Widget::Calculator
Added library/combobox.tcl.














































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
##
## Copyright 1996-8 Jeffrey Hobbs, [email protected]
##
package require Widget 2.0
package provide Combobox 2.0

## FIX:
## popdown listbox on Configure

##------------------------------------------------------------------------
## PROCEDURE
##	combobox
##
## DESCRIPTION
##	Implements a Combobox megawidget
##
## ARGUMENTS
##	combobox <window pathname> <options>
##
## OPTIONS
##	(Any entry widget option may be used in addition to these)
##
## -click single|double			DEFAULT: double
##	Whether a single or double-click will select an item in the listbox.
##	If you choose single click, then the selection will follow the
##	motion of the mouse (Windows-like).
##
## -command script			DEFAULT: {}
##	Script to evaluate when a selection is made.
##
## -editable TCL_BOOLEAN		DEFAULT: 1
##	Whether to allow the user to edit the entry widget contents
##
## -grab type				DEFAULT: local
##	Type of grab (local, none, global) to use when listbox appears.
##
## -labelanchor anchor			DEFAULT: c
##	Anchor for the label.  Reasonable values are c, w and e.
##
## -labeltext string			DEFAULT: {}
##	Text for the label
##
## -labelwidth #			DEFAULT: 0 (self-sizing)
##	Width for the label
##
## -list list				DEFAULT: {}
##	List for the listbox
##
## -listheight #			DEFAULT: 5
##	Height of the listbox.  If the number of items exceeds this
##	height, a scrollbar will automatically be added. 0 means auto-size
##
## -postcommand script			DEFAULT: {}
##	A command which is evaluated before the listbox pops up.
##
## -prunelist TCL_BOOLEAN		DEFAULT: 0
##	Whether to prevent duplicate listbox items
##
## -state normal|disabled		DEFAULT: normal
##	Same as for entry, but also disables the button
##
## -tabexpand TCL_BOOLEAN		DEFAULT: 1
##	Whether to allow tab expansion in entry widget (uses listbox items)
##
## RETURNS: the window pathname
##
## BINDINGS (in addition to default widget bindings)
##
## <Double-1> or <Escape> in the entry widget, or selecting the
## button will toggle the listbox portion.
## 
## <Escape> will close the listbox without a selection.
## 
## <Tab> in the entry widget searches the listbox for a unique match.
## 
## <(Double-)1> in the listbox selects that item, configurable with -click.
##
## METHODS
##	These are the methods that the Combobox recognizes.  Aside from
##	those listed here, it accepts what is valid for entry widgets.
##
## configure ?option? ?value option value ...?
## cget option
##	Standard tk widget routines.
##
## add ?string?
##	Adds the string to the listbox.
##	If string is not specified, it uses what's in the entry widget.
##
## expand ?string?
##	Expands the string based on the contents of the listbox.
##	If string is not specified, it uses what's in the entry widget.
##
## popdown
##	Pops the listbox down (no error when already unmapped)
##
## popup
##	Pops the listbox up (no error when already mapped)
##
## toggle
##	Toggles whether the listbox is mapped or not.
##
## set string
##	Sets the entry widget (or its textvariable, if it exists) to
##	the value of string.
##
## subwidget widget
##	Returns the true widget path of the specified widget.  Valid
##	widgets are label, listbox, entry, toplevel, scrollbar.
##
## NAMESPACE & STATE
##	The megawidget creates a global array with the classname, and a
## global array which is the name of each megawidget is created.  The latter
## array is deleted when the megawidget is destroyed.
##	Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used.
## Other procs that begin with $CLASSNAME are private.  For each widget,
## commands named .$widgetname and $CLASSNAME$widgetname are created.
##
## EXAMPLE USAGE:
##
## pack [combobox .combo -label "Hello: "]
## pack [combobox .combo -width 15 -textvariable myvar]
##
##------------------------------------------------------------------------


# Create this to make sure there are registered in auto_mkindex
# these must come before the [widget create ...]
proc Combobox args {}
proc combobox args {}
widget create Combobox -type frame -base entry -components {
    label
    {button button button {-image ::Widget::Combobox::Image \
	    -command [namespace code [list _toggle $w]]}}
    {toplevel toplevel drop {-cursor arrow}}
    {listbox listbox drop.lbox {-selectmode single \
	    -width 5 -height $data(-listheight) \
	    -yscrollcommand [list $data(scrollbar) set]}}
    {scrollbar scrollbar drop.sy {-orient vertical \
	    -command [list $data(listbox) yview]}}
} -options {
    {-bd		-borderwidth}
    {-borderwidth	borderWidth	BorderWidth	0}
    {-bg		-background}
    {-background	ALIAS entry -background}
    {-click		click		Click		double}
    {-command		command	Command		{}}
    {-editable		editable	Editable	1}
    {-grab		grab		Grab		local}
    {-labeltext		labelText	Text		{}}
    {-labelwidth	labelWidth	Width		0}
    {-labelanchor	ALIAS label -anchor labelAnchor Anchor}
    {-list		list		List		{}}
    {-listheight	listHeight	ListHeight	5}
    {-postcommand	postCommand	Command		{}}
    {-prunelist		pruneList	PruneList	0}
    {-relief		relief		Relief		flat}
    {-state		ALIAS entry -state}
    {-tabexpand		tabExpand	TabExpand	1}
}

namespace eval ::Widget::Combobox {;

namespace import -force ::Utility::best_match

;proc construct {w} {
    variable $w
    upvar 0 $w data

    ## Removable List Box
    wm overrideredirect $data(toplevel) 1
    wm transient $data(toplevel) [winfo toplevel $w]
    wm group $data(toplevel) [winfo toplevel $w]
    ## this shouldn't be necessary... (bug on Windows?)
    wm withdraw $data(toplevel)

    bind $data(toplevel) <Unmap> [list catch [list grab release $w]]

    grid $data(label) $data(entry) $data(button) -in $w -sticky news
    grid configure $data(button) -sticky ns
    grid columnconfig $w 1 -weight 1
    grid $data(listbox) $data(scrollbar) -in $data(toplevel) -sticky ns
    grid configure $data(listbox) -sticky news
    grid remove $data(scrollbar) $data(label)
    grid columnconfig $data(toplevel) 0 -weight 1
    grid rowconfigure $data(toplevel) 0 -weight 1

    ## These are not in a class (like ComboboxList) because we need to
    ## allow -click to work on an instance basis.  For the same reason,
    ## we can't use any virtual events.
    bind $data(listbox) <Escape>   [namespace code [list $w popdown]]
    bind $data(listbox) <Double-1> \
	    [namespace code "get [list $w] \[%W get \[%W nearest %y\]\]"]
    bind $data(listbox) <Return> \
	    [namespace code "get [list $w] \[%W get active\]"]
}

;proc configure { w args } {
    variable $w
    upvar 0 $w data

    set truth {^(1|yes|true|on)$}
    foreach {key val} $args {
	switch -- $key {
	    -borderwidth - -relief { .$w configure $key $val }
	    -background	{
		$data(basecmd) configure -bg $val
		$data(listbox) configure -bg $val
	    }
	    -click	{
		switch [string tolower $val] {
		    single	{
			bind $data(listbox) <Double-1> {}
			bind $data(listbox) <1> [namespace code "get \
				[list $w] \[%W get \[%W nearest %y\]\]"]
			bind $data(listbox) <Motion> {
			    %W selection clear 0 end
			    %W selection set [%W nearest %y]
			}
		    }
		    double	{
			bind $data(listbox) <Double-1> [namespace code "get \
				[list $w] \[%W get \[%W nearest %y\]\]"]
			bind $data(listbox) <1> {}
			bind $data(listbox) <Motion> {}
		    }
		    default	{
			return -code error "bad $key option \"$val\": must be\
				single or double"
		    }
		}
	    }
	    -editable	{
		if {[set val [regexp $truth $val]]} {
		    $data(basecmd) configure -state normal
		} else {
		    $data(basecmd) configure -state disabled
		}
	    }
	    -grab	{
		if {![regexp {^(local|global|none)$} $val junk val]} {
		    return -code error "bad $key option \"$val\": must be\
			    local, grab, or none"
		}
	    }
	    -list	{
		$data(listbox) delete 0 end
		eval $data(listbox) insert end $val
	    }
	    -labelanchor { $data(label) configure -anchor $val }
	    -labeltext	{
		$data(label) configure -text $val
		if {[string compare {} $val]} {
		    grid $data(label)
		} else {
		    grid remove $data(label)
		}
	    }
	    -labelwidth	{ $data(label) configure -width $val }
	    -listheight	{ $data(listbox) configure -height $val }
	    -state	{
		$data(basecmd) configure -state $val
		$data(button) configure -state $val
		if {[string match "disabled" $val] && \
			[winfo ismapped $data(toplevel)]} {
		    wm withdraw $data(toplevel)
		    catch {grab release $w}
		}
	    }
	    -prunelist	-
	    -tabexpand	{ set val [regexp $truth $val] }
	}
	set data($key) $val
    }
}

bind Combobox <Double-1>	{ %W toggle }
bind Combobox <Escape>		{ %W toggle }
bind Combobox <Tab>		{ %W expand [%W get]; break }
bind Combobox <Unmap>		{ catch {grab release %W} }
bind Combobox <Destroy>		{ catch {grab release %W} }

;proc _toggle {w} {
    variable $w
    upvar 0 $w data

    if {[winfo ismapped $data(toplevel)]} {
	_popdown $w
    } else {
	_popup $w
    }
}

;proc _popup {w} {
    variable $w
    upvar 0 $w data

    if {[winfo ismapped $data(toplevel)]} {
	return
    }
    global tcl_platform
    uplevel \#0 $data(-postcommand)
    focus $data(entry)
    set size [$data(listbox) size]
    ## If -listheight is 0, the listbox will auto-size
    if {$data(-listheight) && ($size > $data(-listheight))} {
	$data(listbox) configure -height $data(-listheight)
	grid $data(scrollbar)
    } else {
	$data(listbox) configure -height $size
	grid remove $data(scrollbar)
    }
    ## The update is required to get the window to properly size itself
    ## before it is popped up the first time.
    update idletasks
    set W [expr {[winfo width $data(entry)]+[winfo width $data(button)]}]
    set H [winfo reqheight $data(toplevel)]
    set y [expr {[winfo rooty $data(entry)]+[winfo height $data(entry)]}]
    ## Make it pop up upwards if there is not enough screen downwards
    if {($y+$H)>[winfo screenheight $w]} {
	set y [expr {[winfo rooty $data(entry)]-$H}]
    }
    set x [winfo rootx $data(entry)]
    wm geometry $data(toplevel) ${W}x${H}+${x}+${y}
    ## This is required to get the window to pop up in the right place
    ## on Windows, doesn't affect Unix
    update idletasks
    wm deiconify $data(toplevel)
    if {[string match local $data(-grab)]} {
	grab $w
    } elseif {[string match global $data(-grab)]} {
	grab -global $w
    }
    raise $data(toplevel)
    focus $data(listbox)
}

;proc _popdown {w} {
    variable $w
    upvar 0 $w data

    if {![winfo ismapped $data(toplevel)]} {
	return
    }
    wm withdraw $data(toplevel)
    catch {grab release $w}
    focus $data(entry)
}

;proc _expand {w {str {}}} {
    variable $w
    upvar 0 $w data

    if {!$data(-tabexpand)} return
    if {[string match {} $str]} { set str [$data(basecmd) get] }
    set found 0
    foreach item [$data(listbox) get 0 end] {
	if {[string match ${str}* $item]} {
	    incr found
	    lappend match $item
	}
    }
    if {$found} {
	set state [$data(basecmd) cget -state]
	$data(basecmd) config -state normal
	$data(basecmd) delete 0 end
	if {$found>1} {
	    set match [best_match $match $str]
	} else {
	    set match [lindex $match 0]
	}
	$data(basecmd) insert end $match
	$data(basecmd) config -state $state
    } else { bell }
}

;proc _add {w {str {}}} {
    variable $w
    upvar 0 $w data

    if {[string match {} $str]} { set str [$data(basecmd) get] }
    set i 1
    if {!$data(-prunelist)} {
	foreach l [$data(listbox) get 0 end] {
	    if {![string compare $l $str]} { set i 0 ; break }
	}
    }
    if {$i} { $data(listbox) insert end $str }
}

;proc _set {w str} {
    variable $w
    upvar 0 $w data

    set var [$data(basecmd) cget -textvar]
    if {[string compare {} $var] && [uplevel \#0 info exists [list $var]]} {
	global $var
	set $var $str
    } else {
	set state [$data(basecmd) cget -state]
	$data(basecmd) config -state normal
	$data(basecmd) delete 0 end
	$data(basecmd) insert 0 $str
	$data(basecmd) config -state $state
    }
}

;proc get {w i} {
    variable $w
    upvar 0 $w data

    set e $data(basecmd)
    if {[$data(listbox) size]} {
	set state [$e cget -state]
	$e config -state normal
	$e delete 0 end
	$e insert end $i
	$e config -state $state
	if {[string compare $data(-command) {}]} {
	    uplevel \#0 $data(-command) $i
	}
    }
    wm withdraw $data(toplevel)
    focus $data(base)
}

}; # end namespace ::Widget::Combobox

## Button Bitmap
##
image create bitmap ::Widget::Combobox::Image -data {#define downbut_width 14
#define downbut_height 14
static char downbut_bits[] = {
    0x00, 0x00, 0xe0, 0x01, 0xe0, 0x01, 0xe0, 0x01, 0xe0, 0x01, 0xfc, 0x0f,
    0xf8, 0x07, 0xf0, 0x03, 0xe0, 0x01, 0xc0, 0x00, 0x00, 0x00, 0xfe, 0x1f,
    0xfe, 0x1f, 0x00, 0x00};
}

return
Added library/console.tcl.












































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
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
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
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
614
615
616
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
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
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
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
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
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
##
## Copyright 1996-8 Jeffrey Hobbs, [email protected]
##
## Based off previous work for TkCon
##
package require Widget 2.0

## From ::Utility, we need:
## lremove
## and we get for slaves (not necessary):
## alias, echo, dir/ls, dump
#package require ::Utility 1.0
;proc lremove {args} {
    set all 0
    if {[string match \-a* [lindex $args 0]]} {
	set all 1
	set args [lreplace $args 0 0]
    }
    set l [lindex $args 0]
    foreach i [join [lreplace $args 0 0]] {
	if {[set ix [lsearch -exact $l $i]] == -1} continue
	set l [lreplace $l $ix $ix]
	if {$all} {
	    while {[set ix [lsearch -exact $l $i]] != -1} {
		set l [lreplace $l $ix $ix]
	    }
	}
    }
    return $l
}

# highlight --
#    searches in text widget for $str and highlights it
#    If $str is empty, it just deletes any highlighting
#    This really belongs in ::Utility::tk
# Arguments:
#   w			text widget
#   str			string to search for
#   -nocase		specifies to be case insensitive
#   -regexp		specifies that $str is a pattern
#   -tag   tagId	name of tag in text widget
#   -color color	color of tag in text widget
# Results:
#   Returns ...
#
;proc highlight {w str args} {
    $w tag remove __highlight 1.0 end
    array set opts {
	-nocase	0
	-regexp	0
	-tag	__highlight
	-color	yellow
    }
    set args [get_opts opts $args {-nocase 0 -regexp 0 -tag 1 -color 1}]
    if {[string match {} $str]} return
    set pass {}
    if {$opts(-nocase)} { append pass "-nocase " }
    if {$opts(-regexp)} { append pass "-regexp " }
    $w tag configure $opts(-tag) -background $opts(-color)
    $w mark set $opts(-tag) 1.0
    while {[string compare {} [set ix [eval $w search $pass -count numc -- \
	    [list $str] $opts(-tag) end]]]} {
	$w tag add $opts(-tag) $ix ${ix}+${numc}c
	$w mark set $opts(-tag) ${ix}+1c
    }
    catch {$w see $opts(-tag).first}
    return [expr {[llength [$w tag ranges $opts(-tag)]]/2}]
}

# highlight_dialog --
#
#   creates minimal dialog interface to highlight
#
# Arguments:
#   w	text widget
#   str	optional seed string for HIGHLIGHT(string)
# Results:
#   Returns null.
#
proc highlight_dialog {w {str {}}} {
    variable HIGHLIGHT

    set namesp [namespace current]
    set var ${namesp}::HIGHLIGHT
    set base $w.__highlight
    if {![winfo exists $base]} {
	toplevel $base
	wm withdraw $base
	wm title $base "Find String"

	pack [frame $base.f] -fill x -expand 1
	label $base.f.l -text "Find:"
	entry $base.f.e -textvariable ${var}($w,string)
	pack [frame $base.opt] -fill x
	checkbutton $base.opt.c -text "Case Sensitive" \
		-variable ${var}($w,nocase)
	checkbutton $base.opt.r -text "Use Regexp" -variable ${var}($w,regexp)
	pack $base.f.l -side left
	pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
	pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
	pack [frame $base.btn] -fill both
	button $base.btn.fnd -text "Find" -width 6
	button $base.btn.clr -text "Clear" -width 6
	button $base.btn.dis -text "Dismiss" -width 6
	eval pack [winfo children $base.btn] -padx 4 -pady 2 \
		-side left -fill both

	focus $base.f.e

	bind $base.f.e <Return> [list $base.btn.fnd invoke]
	bind $base.f.e <Escape> [list $base.btn.dis invoke]
    }
    ## FIX namespace
    $base.btn.fnd config -command [namespace code \
	    "highlight [list $w] \[set ${var}($w,string)\] \
	    \[expr {\[set ${var}($w,nocase)\]?{}:{-nocase}}] \
	    \[expr {\[set ${var}($w,regexp)\]?{-regexp}:{}}] \
	    -tag __highlight -color [list yellow]"]
    $base.btn.clr config -command \
	    "[list $w] tag remove __highlight 1.0 end;\
	    set [list ${var}($w,string)] {}"
    $base.btn.dis config -command \
	    "[list $w] tag remove __highlight 1.0 end;\
	    wm withdraw [list $base]"
    if {[string compare {} $str]} {
	set ${var}($w,string) $str
	$base.btn.fnd invoke
    }

    if {[string compare normal [wm state $base]]} {
	wm deiconify $base
    } else {
	raise $base
    }
    $base.f.e select range 0 end
}

package provide Console 2.0

##------------------------------------------------------------------------
## PROCEDURE
##	console
##
## DESCRIPTION
##	Implements a console mega-widget
##
## ARGUMENTS
##	console <window pathname> <options>
##
## OPTIONS
##	(Any frame widget option may be used in addition to these)
##
##  -blinkcolor color			DEFAULT: #FFFF00 (yellow)
##	Specifies the background blink color for brace highlighting.
##	This doubles as the highlight color for the find box.
##
##  -blinkrange TCL_BOOLEAN		DEFAULT: 1
##	When doing electric brace matching, specifies whether to blink
##	the entire range or just the matching braces.
##
##  -blinktime delay			DEFAULT: 500
##	For electric brace matching, specifies the amount of time to
##	blink the background for.
##
##  -grabputs TCL_BOOLEAN		DEFAULT: 1
##	Whether this console should grab the "puts" default output
##
##  -lightbrace TCL_BOOLEAN		DEFAULT: 1
##	Specifies whether to activate electric brace matching.
##
##  -lightcmd TCL_BOOLEAN		DEFAULT: 1
##	Specifies whether to highlight recognized commands.
##
##  -proccolor color			DEFAULT: #008800 (darkgreen)
##	Specifies the color to highlight recognized procs.
##
##  -prompt string	DEFAULT: {([file tail [pwd]]) [history nextid] % }
##	The equivalent of the tcl_prompt1 variable.
##
##  -promptcolor color			DEFAULT: #8F4433 (brown)
##	Specifies the prompt color.
##
##  -stdincolor color			DEFAULT: #000000 (black)
##	Specifies the color for "stdin".
##	This doubles as the console foreground color.
##
##  -stdoutcolor color			DEFAULT: #0000FF (blue)
##	Specifies the color for "stdout".
##
##  -stderrcolor color			DEFAULT: #FF0000 (red)
##	Specifies the color for "stderr".
##
##  -showmultiple TCL_BOOLEAN		DEFAULT: 1
##	For file/proc/var completion, specifies whether to display
##	completions when multiple choices are possible.
##
##  -showmenu TCL_BOOLEAN		DEFAULT: 1
##	Specifies whether to show the menubar.
##
##  -subhistory TCL_BOOLEAN		DEFAULT: 1
##	Specifies whether to allow substitution in the history.
##
##  -varcolor color			DEFAULT: #FFC0D0 (pink)
##	Specifies the color for "stderr".
##
## RETURNS: the window pathname
##
## BINDINGS (these are the bindings for Console, used in the text widget)
##
## <<Console_ExpandFile>>	<Key-Tab>
## <<Console_ExpandProc>>	<Control-Shift-Key-P>
## <<Console_ExpandVar>>	<Control-Shift-Key-V>
## <<Console_Tab>>		<Control-Key-i>
## <<Console_Eval>>		<Key-Return> <Key-KP_Enter>
##
## <<Console_Clear>>		<Control-Key-l>
## <<Console_KillLine>>		<Control-Key-k>
## <<Console_Transpose>>	<Control-Key-t>
## <<Console_ClearLine>>	<Control-Key-u>
## <<Console_SaveCommand>>	<Control-Key-z>
##
## <<Console_Prev>>		<Key-Up>
## <<Console_Next>>		<Key-Down>
## <<Console_NextImmediate>>	<Control-Key-n>
## <<Console_PrevImmediate>>	<Control-Key-p>
## <<Console_PrevSearch>>	<Control-Key-r>
## <<Console_NextSearch>>	<Control-Key-s>
##
## <<Console_Exit>>		<Control-Key-q>
## <<Console_New>>		<Control-Key-N>
## <<Console_Close>>		<Control-Key-w>
## <<Console_About>>		<Control-Key-A>
## <<Console_Help>>		<Control-Key-H>
## <<Console_Find>>		<Control-Key-F>
##
## METHODS
##	These are the methods that the console megawidget recognizes.
##
## configure ?option? ?value option value ...?
## cget option
##	Standard tk widget routines.
##
## load ?filename?
##	Loads the named file into the current interpreter.
##	If no file is specified, it pops up the file requester.
##
## save ?filename?
##	Saves the console buffer to the named file.
##	If no file is specified, it pops up the file requester.
##
## clear ?percentage?
##	Clears a percentage of the console buffer (1-100).  If no
##	percentage is specified, the entire buffer is cleared.
##
## error
##	Displays the last error in the interpreter in a dialog box.
##
## hide
##	Withdraws the console from the screen
##
## history ?-newline?
##	Prints out the history without numbers (basically providing a
##	list of the commands you've used).
##
## show
##	Deiconifies and raises the console
##
## subwidget widget
##	Returns the true widget path of the specified widget.  Valid
##	widgets are console, yscrollbar, menubar.
##
## NAMESPACE & STATE
##	The megawidget creates a global array with the classname, and a
## global array which is the name of each megawidget is created.  The latter
## array is deleted when the megawidget is destroyed.
##	Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used.
## Other procs that begin with $CLASSNAME are private.  For each widget,
## commands named .$widgetname and $CLASSNAME$widgetname are created.
##
## EXAMPLE USAGE:
##
## console .con -height 20 -showmenu false
## pack .con -fill both -expand 1
##------------------------------------------------------------------------

foreach pkg [info loaded {}] {
    set file [lindex $pkg 0]
    set name [lindex $pkg 1]
    if {![catch {set version [package require $name]}]} {
	if {[string match {} [package ifneeded $name $version]]} {
	    package ifneeded $name $version "load [list $file $name]"
	}
    }
}
catch {unset file name version}

# Create this to make sure there are registered in auto_mkindex
# these must come before the [widget create ...]
proc Console args {}
proc console args {}
widget create Console -type frame -base text -components {
    {base console console {-wrap char -setgrid 1 \
	    -yscrollcommand [list $data(yscrollbar) set] \
	    -foreground $data(-stdincolor)}}
    {frame menubar menubar {-relief raised -bd 1}}
    {scrollbar yscrollbar sy {-takefocus 0 -bd 1 \
	    -command [list $data(console) yview]}}
} -options {
    {-blinkcolor	blinkColor	BlinkColor	\#FFFF00}
    {-proccolor		procColor	ProcColor	\#008800}
    {-promptcolor	promptColor	PromptColor	\#8F4433}
    {-stdincolor	stdinColor	StdinColor	\#000000}
    {-stdoutcolor	stdoutColor	StdoutColor	\#0000FF}
    {-stderrcolor	stderrColor	StderrColor	\#FF0000}
    {-varcolor		varColor	VarColor	\#FFC0D0}

    {-blinkrange	blinkRange	BlinkRange	1}
    {-blinktime		blinkTime	BlinkTime	500}
    {-grabputs		grabPuts	GrabPuts	1}
    {-lightbrace	lightBrace	LightBrace	1}
    {-lightcmd		lightCmd	LightCmd	1}
    {-showmultiple	showMultiple	ShowMultiple	1}
    {-showmenu		showMenu	ShowMenu	1}
    {-subhistory	subhistory	SubHistory	1}

    {-abouttext		aboutText	AboutText	{}}
}

if {[info exists ::embed_args] || [info exists ::browser_args]} {
    widget add Console option {-prompt prompt Prompt {[history nextid] % }}
} else {
    widget add Console option {-prompt prompt Prompt \
	    {([file tail [pwd]]) [history nextid] % }}
}

widget add Console option [list -abouttitle aboutTitle AboutTitle \
	"About Console v[package provide Console]"]

##
## BEGIN CONSOLE DIALOG
##

# Create this to make sure there are registered in auto_mkindex
# these must come before the [widget create ...]
proc ConsoleDialog args {}
proc consoledialog args {}
widget create ConsoleDialog -type toplevel -base console -options {
    {-title	title	Title	"Console Dialog"}
}

namespace eval ::Widget::ConsoleDialog {;

variable class
array set class [list version [package provide Console]]

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

    wm title $w $data(-title)

    grid $data(console) -in $w -sticky news
    grid columnconfig $w 0 -weight 1
    grid rowconfig $w 0 -weight 1
}

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

    #set truth {^(1|yes|true|on)$}
    foreach {key val} $args {
	switch -- $key {
	    -title	{ wm title $w $val }
	}
	set data($key) $val
    }
}

;proc _hide w { if {[winfo exists $w]} { wm withdraw $w } }

;proc _show w { if {[winfo exists $w]} { wm deiconify $w; raise $w } }

}; # end namespace ::Widget::ConsoleDialog

##
## END CONSOLE DIALOG
##

##
## CONSOLE MEGAWIDGET
##

namespace eval ::Widget::Console {;

variable class
array set class {
    release	{December 1998}
    contact	"[email protected]"
    docs	"http://www.purl.org/net/hobbs/tcl/script/tkcon/"
    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]||[info exists ::browser_args]]

catch {highlight}
if {[string compare {} [info commands ::Utility::lremove]]} {
    namespace import -force ::Utility::*
}

## console -
# ARGS:	w	- widget pathname of the Console console
# Calls:	InitUI
# Outputs:	errors found in Console resource file
##
;proc construct {w} {
    upvar \#0 [namespace current]::$w data

    global auto_path tcl_pkgPath tcl_interactive
    set tcl_interactive 0

    ## Private variables
    array set data {
	app {} appname {} apptype {} namesp {} deadapp 0
	cmdbuf {} cmdsave {} errorInfo {}
	event 1 histid 0 find {} find,case 0 find,reg 0
    }

    if {![info exists tcl_pkgPath]} {
	set dir [file join [file dirname [info nameofexec]] lib]
	if {[string compare {} [info commands @scope]]} {
	    set dir [file join $dir itcl]
	}
	catch {namespace eval :: [list source [file join $dir pkgIndex.tcl]]}
    }
    catch {tclPkgUnknown dummy-name dummy-version}

    InitMenus $w

    grid $data(menubar) - -sticky ew
    grid $data(console) $data(yscrollbar) -sticky news
    grid columnconfig $w 0 -weight 1
    grid rowconfig $w 1 -weight 1

    prompt $w "console display active\n"

    set c $data(console)
    foreach col {prompt stdout stderr stdin proc} {
	$c tag configure $col -foreground $data(-${col}color)
    }
    $c tag configure var -background $data(-varcolor)
    $c tag configure blink -background $data(-blinkcolor)
}

;proc init {w} {
    upvar \#0 [namespace current]::$w data
    variable class
    bind $w <Destroy> [bind $class(class) <Destroy>]
    bindtags $w [list $w [winfo toplevel $w] all]
    set c $data(console)
    bindtags $c [list $c Console PostConsole $w all]
    if {$data(-grabputs) && [lsearch $class(active) $c] == -1} {
	set class(active) [linsert $class(active) 0 $c]
    }
}

;proc destruct w {
    variable class
    upvar \#0 [namespace current]::$w data
    set class(active) [lremove $class(active) $data(console)]
}

;proc configure { w args } {
    set namesp [namespace current]
    upvar \#0 ${namesp}::$w data
    variable class

    set truth {^(1|yes|true|on)$}
    set c $data(console)
    foreach {key val} $args {
	switch -- $key {
	    -blinkcolor	{
		$c tag config blink -background $val
		$c tag config __highlight -background $val
	    }
	    -proccolor   { $c tag config proc   -foreground $val }
	    -promptcolor { $c tag config prompt -foreground $val }
	    -stdincolor  {
		$c tag config stdin -foreground $val
		$c config -foreground $val
	    }
	    -stdoutcolor { $c tag config stdout -foreground $val }
	    -stderrcolor { $c tag config stderr -foreground $val }

	    -blinktime		{
		if {![regexp {[0-9]+} $val]} {
		    return -code error "$key option requires an integer value"
		} elseif {$val < 100} {
		    return -code error "$key option must be greater than 100"
		}
	    }
	    -grabputs	{
		if {[set val [regexp -nocase $truth $val]]} {
		    set class(active) [linsert $class(active) 0 $c]
		} else {
		    set class(active) [lremove -all $class(active) $c]
		}
	    }
	    -prompt		{
		if {[catch {namespace eval :: [list subst $val]} err]} {
		    return -code error "\"$val\" threw an error:\n$err"
		}
	    }
	    -showmenu	{
		if {[set val [regexp -nocase $truth $val]]} {
		    grid $data(menubar)
		} else {
		    grid remove $data(menubar)
		}
	    }
	    -lightbrace	-
	    -lightcmd	-
	    -showmultiple -
	    -subhistory	{ set val [regexp -nocase $truth $val] }
	}
	set data($key) $val
    }
}

;proc Exit {w args} {
    exit
}

## Eval - evaluates commands input into console window
## This is the first stage of the evaluating commands in the console.
## They need to be broken up into consituent commands (by CmdSep) in
## case a multiple commands were pasted in, then each is eval'ed (by
## EvalCmd) in turn.  Any uncompleted command will not be eval'ed.
# ARGS:	w	- console text widget
# Calls:	CmdGet, CmdSep, EvalCmd
## 
;proc Eval {w} {
    set incomplete [CmdSep [CmdGet $w] cmds last]
    $w mark set insert end-1c
    $w insert end \n
    if {[llength $cmds]} {
	foreach c $cmds {EvalCmd $w $c}
	$w insert insert $last {}
    } elseif {!$incomplete} {
	EvalCmd $w $last
    }
    $w see insert
}

## EvalCmd - evaluates a single command, adding it to history
# ARGS:	w	- console text widget
# 	cmd	- the command to evaluate
# Calls:	prompt
# Outputs:	result of command to stdout (or stderr if error occured)
# Returns:	next event number
## 
;proc EvalCmd {w cmd} {
    ## HACK to get $W as we need it
    set W [winfo parent $w]
    upvar \#0 [namespace current]::$W data

    $w mark set output end
    if {[string compare {} $cmd]} {
	set code 0
	if {$data(-subhistory)} {
	    set ev [EvalSlave history nextid]
	    incr ev -1
	    if {[string match !! $cmd]} {
		set code [catch {EvalSlave history event $ev} cmd]
		if {!$code} {$w insert output $cmd\n stdin}
	    } elseif {[regexp {^!(.+)$} $cmd dummy evnt]} {
		## Check last event because history event is broken
		set code [catch {EvalSlave history event $ev} cmd]
		if {!$code && ![string match ${evnt}* $cmd]} {
		    set code [catch {EvalSlave history event $evnt} cmd]
		}
		if {!$code} {$w insert output $cmd\n stdin}
	    } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} {
		set code [catch {EvalSlave history event $ev} cmd]
		if {!$code} {
		    regsub -all -- $old $cmd $new cmd
		    $w insert output $cmd\n stdin
		}
	    }
	}
	if {$code} {
	    $w insert output $cmd\n stderr
	} else {
	    ## We are about to evaluate the command, so move the limit
	    ## mark to ensure that further <Return>s don't cause double
	    ## evaluation of this command - for cases like the command
	    ## has a vwait or something in it
	    $w mark set limit end
	    EvalSlave history add $cmd
	    if {[catch {EvalAttached $cmd} res]} {
		if {[catch {EvalAttached {set errorInfo}} err]} {
		    set data(errorInfo) "Error getting errorInfo:\n$err"
		} else {
		    set data(errorInfo) $err
		}
		$w insert output $res\n stderr
	    } elseif {[string compare {} $res]} {
		$w insert output $res\n stdout
	    }
	}
    }
    prompt $W
    set data(event) [EvalSlave history nextid]
}

## EvalSlave - evaluates the args in the associated slave
## args should be passed to this procedure like they would be at
## the command line (not like to 'eval').
# ARGS:	args	- the command and args to evaluate
##
;proc EvalSlave {args} {
    uplevel \#0 $args
}

## EvalAttached
##
;proc EvalAttached {args} {
    uplevel \#0 eval $args
}

## CmdGet - gets the current command from the console widget
# ARGS:	w	- console text widget
# Returns:	text which compromises current command line
## 
;proc CmdGet w {
    if {[string match {} [$w tag nextrange prompt limit end]]} {
	$w tag add stdin limit end-1c
	return [$w get limit end-1c]
    }
}

## CmdSep - separates multiple commands into a list and remainder
# ARGS:	cmd	- (possible) multiple command to separate
# 	list	- varname for the list of commands that were separated.
#	rmd	- varname of any remainder (like an incomplete final command).
#		If there is only one command, it's placed in this var.
# Returns:	constituent command info in varnames specified by list & rmd.
## 
;proc CmdSep {cmd list last} {
    upvar 1 $list cmds $last inc
    set inc {}
    set cmds {}
    foreach c [split [string trimleft $cmd] \n] {
	if {[string compare $inc {}]} {
	    append inc \n$c
	} else {
	    append inc [string trimleft $c]
	}
	if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} {
	    ## FIX: is this necessary?
	    if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
	    set inc {}
	}
    }
    set i [string compare $inc {}]
    if {!$i && [string compare $cmds {}] && ![string match *\n $cmd]} {
	set inc [lindex $cmds end]
	set cmds [lreplace $cmds end end]
    }
    return $i
}

## prompt - displays the prompt in the console widget
# ARGS:	w	- console text widget
# Outputs:	prompt (specified in data(-prompt)) to console
## 
;proc prompt {W {pre {}} {post {}} {prompt {}}} {
    upvar \#0 [namespace current]::$W data

    set w $data(console)
    if {[string compare {} $pre]} { $w insert end $pre stdout }
    set i [$w index end-1c]
    if {[string compare {} $data(appname)]} {
	$w insert end ">$data(appname)< " prompt
    }
    if {[string compare {} $prompt]} {
	$w insert end $prompt prompt
    } else {
	$w insert end [EvalSlave subst $data(-prompt)] prompt
    }
    $w mark set output $i
    $w mark set insert end
    $w mark set limit insert
    $w mark gravity limit left
    if {[string compare {} $post]} { $w insert end $post stdin }
    $w see end
}

## About - gives about info for Console
##
;proc About W {
    variable class
    upvar \#0 [namespace current]::$W data

    set w $W.about
    if {[winfo exists $w]} {
	wm deiconify $w
    } else {
	global tk_patchLevel tcl_patchLevel tcl_platform
	toplevel $w
	wm title $w $data(-abouttitle)
	button $w.b -text Dismiss -command [list wm withdraw $w]
	text $w.text -height 9 -bd 1 -width 62
	pack $w.b -fill x -side bottom
	pack $w.text -fill both -side left -expand 1
	$w.text tag config center -justify center
	$w.text tag config title -justify center -font {Courier 18 bold}
	$w.text insert 1.0 $data(-abouttitle) title \
		"$data(-abouttext)\n\nConsole Copyright 1995-1998\
		Jeffrey Hobbs, $class(contact)\
		\nRelease Date: v$class(version), $class(release)\
		\nDocumentation available at:\n$class(docs)\
		\nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center
    }
}

## InitMenus - inits the menubar and popup for the console
# ARGS:	W	- console megawidget
## 
;proc InitMenus W {
    set V [namespace current]::$W
    upvar \#0 $V data

    set w    $data(menubar)
    set text $data(console)

    if {[catch {menu $w.pop -tearoff 0}]} {
	label $w.label -text "Menus not available in plugin mode"
	pack $w.label
	return
    }
    #bind [winfo toplevel $w] <Button-3> "tk_popup $w.pop %X %Y"
    bind $text <Button-3> "tk_popup $w.pop %X %Y"

    ## Console Menu
    ## FIX - get the attachment stuff working
    set n cons
    set l "Console"
    pack [menubutton $w.$n  -text $l -underline 0 -menu $w.$n.m] -side left
    $w.pop add cascade -label $l -underline 0 -menu $w.pop.$n
    foreach m [list [menu $w.$n.m -disabledforeground $data(-promptcolor)] \
	    [menu $w.pop.$n -disabledforeground $data(-promptcolor)]] {
	$m add command -label "Console $W" -state disabled
	$m add command -label "Clear Console " -underline 1 \
		-accelerator [event info <<Console_Clear>>] \
		-command [namespace code [list _clear $W]]
	$m add command -label "Load File" -underline 0 \
		-command [namespace code [list _load $W]]
	$m add cascade -label "Save ..." -underline 0 -menu $m.save
	$m add separator
	$m add cascade -label "Attach Console" -underline 7 -menu $m.apps \
		-state disabled
	$m add cascade -label "Attach Namespace" -underline 7 -menu $m.name \
		-state disabled
	$m add separator
	$m add command -label "Exit" -underline 1 \
		-accelerator [event info <<Console_Exit>>] \
		-command [namespace code [list Exit $W]]

	## Save Menu
	##
	set s $m.save
	menu $s -disabledforeground $data(-promptcolor) -tearoff 0
	$s add command -label "All"	-underline 0 \
		-command [namespace code [list _save $W all]]
	$s add command -label "History"	-underline 0 \
		-command [namespace code [list _save $W history]]
	$s add command -label "Stdin"	-underline 3 \
		-command [namespace code [list _save $W stdin]]
	$s add command -label "Stdout"	-underline 3 \
		-command [namespace code [list _save $W stdout]]
	$s add command -label "Stderr"	-underline 3 \
		-command [namespace code [list _save $W stderr]]

	## Attach Console Menu
	##
	menu $m.apps -disabledforeground $data(-promptcolor) \
		-postcommand [namespace code [list AttachMenu $W $m.apps]]

	## Attach Interpreter Menu
	##
	menu $m.int -disabledforeground $data(-promptcolor) -tearoff 0 \
		-postcommand [namespace code [list AttachMenu $W $m.int interp]]

	## Attach Namespace Menu
	##
	menu $m.name -disabledforeground $data(-promptcolor) -tearoff 0 \
		-postcommand [namespace code [list AttachMenu $W $m.name namespace]]
    }

    ## Edit Menu
    ##
    set n edit
    set l "Edit"
    pack [menubutton $w.$n -text $l -underline 0 -menu $w.$n.m] -side left
    $w.pop add cascade -label $l -underline 0 -menu $w.pop.$n
    foreach m [list [menu $w.$n.m] [menu $w.pop.$n]] {
	$m add command -label "Cut"   -underline 1 \
		-accelerator [lindex [event info <<Cut>>] 0] \
		-command [namespace code [list Cut $text]]
	$m add command -label "Copy"  -underline 1 \
		-accelerator [lindex [event info <<Copy>>] 0] \
		-command [namespace code [list Copy $text]]
	$m add command -label "Paste" -underline 0 \
		-accelerator [lindex [event info <<Paste>>] 0] \
		-command [namespace code [list Paste $text]]
	$m add separator
	$m add command -label "Find"  -underline 0 \
		-accelerator [lindex [event info <<Console_Find>>] 0] \
		-command [namespace code [list FindBox $W]]
	$m add separator
	$m add command -label "Last Error" -underline 0 \
		-command [list $W error]
    }

    ## Prefs Menu
    ##
    set n pref
    set l "Prefs"
    pack [menubutton $w.$n -text $l -underline 0 -menu $w.$n.m] -side left
    $w.pop add cascade -label $l -underline 0 -menu $w.pop.$n
    foreach m [list [menu $w.$n.m] [menu $w.pop.$n]] {
	$m add checkbutton -label "Brace Highlighting" \
		-variable $V\(-lightbrace\)
	$m add checkbutton -label "Command Highlighting" \
		-variable $V\(-lightcmd\)
	$m add checkbutton -label "Grab Puts Output" \
		-variable $V\(-grabputs\) \
		-command [namespace code "configure [list $W] \
		-grabputs \[set ${V}(-grabputs)\]"]
	$m add checkbutton -label "History Substitution" \
		-variable $V\(-subhistory\)
	$m add checkbutton -label "Show Multiple Matches" \
		-variable $V\(-showmultiple\)
	$m add checkbutton -label "Show Menubar" \
		-variable $V\(-showmenu\) \
		-command [namespace code "configure [list $W] \
		-showmenu \[set ${V}(-showmenu)\]"]
    }

    ## History Menu
    ##
    set n hist
    set l "History"
    pack [menubutton $w.$n -text $l -underline 0 -menu $w.$n.m] -side left
    $w.pop add cascade -label $l -underline 0 -menu $w.pop.$n
    foreach m [list $w.$n.m $w.pop.$n] {
	menu $m -disabledforeground $data(-promptcolor) \
		-postcommand [namespace code [list HistoryMenu $W $m]]
    }

    ## Help Menu
    ##
    set n help
    set l "Help"
    pack [menubutton $w.$n -text $l -underline 0 -menu $w.$n.m] -side right
    $w.pop add cascade -label $l -underline 0 -menu $w.pop.$n
    foreach m [list [menu $w.$n.m] [menu $w.pop.$n]] {
	$m config -disabledfore $data(-promptcolor)
	$m add command -label "About " -underline 0 \
		-accelerator [event info <<Console_About>>] \
		-command [namespace code [list About $W]]
    }

    bind $W <<Console_Exit>>	[namespace code [list Exit $W]]
    bind $W <<Console_About>>	[namespace code [list About $W]]
    bind $W <<Console_Help>>	[namespace code [list Help $W]]
    bind $W <<Console_Find>>	[namespace code [list FindBox $W]]

    ## Menu items need null PostConsole bindings to avoid the TagProc
    ##
    foreach ev [bind $W] {
	bind PostConsole $ev {
	    # empty
	}
    }
}

# AttachMenu --
#
#   ADD COMMENTS HERE
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
;proc AttachMenu {W m {type default}} {
    upvar \#0 [namespace current]::$W data
}

## HistoryMenu - dynamically build the menu for attached interpreters
##
# ARGS:	w	- menu widget
##
;proc HistoryMenu {W w} {
    upvar \#0 [namespace current]::$W data

    if {![winfo exists $w]} return
    set id [EvalSlave history nextid]
    if {$data(histid)==$id} return
    set data(histid) $id
    $w delete 0 end
    set con $data(console)
    while {$id>0 && ($id>$data(histid)-10) && \
	    ![catch {EvalSlave history event [incr id -1]} tmp]} {
	set lbl [lindex [split $tmp "\n"] 0]
	if {[string len $lbl]>32} { set lbl [string range $tmp 0 29]... }
	$w add command -label "$id: $lbl" -command [namespace code "
	$con delete limit end
	$con insert limit [list $tmp]
	$con see end
	Eval $con\n"]
    }
}

## FindBox - creates minimal dialog interface to Find
# ARGS:	w	- text widget
#	str	- optional seed string for data(find)
##
;proc FindBox {W {str {}}} {
    set V [namespace current]::$W
    upvar \#0 $V data

    highlight_dialog $data(console)
    return

    set t $data(console)
    set base $W.find
    if {![winfo exists $base]} {
	toplevel $base
	wm withdraw $base
	wm title $base "Console Find"

	pack [frame $base.f] -fill x -expand 1
	label $base.f.l -text "Find:"
	entry $base.f.e -textvar $V\(find\)
	pack [frame $base.opt] -fill x
	checkbutton $base.opt.c -text "Case Sensitive" -var ${V}(find,case)
	checkbutton $base.opt.r -text "Use Regexp" -var ${V}(find,reg)
	pack $base.f.l -side left
	pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
	pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
	pack [frame $base.btn] -fill both
	button $base.btn.fnd -text "Find" -width 6
	button $base.btn.clr -text "Clear" -width 6
	button $base.btn.dis -text "Dismiss" -width 6
	eval pack [winfo children $base.btn] -padx 4 -pady 2 \
		-side left -fill both

	focus $base.f.e

	bind $base.f.e <Return> [list $base.btn.fnd invoke]
	bind $base.f.e <Escape> [list $base.btn.dis invoke]
    }
    $base.btn.fnd config -command [namespace code \
	    "highlight [list $data(console)] \[set ${V}(find)\] \
	    \[expr {\[set ${V}(find,case)\]?{}:{-nocase}}] \
	    \[expr {\[set ${V}(find,reg)\]?{-regexp}:{}}] \
	    -tag __highlight -color [list $data(-blinkcolor)]"]
    $base.btn.clr config -command "
    $t tag remove __highlight 1.0 end
    set ${V}(find) {}
    "
    $base.btn.dis config -command "
    $t tag remove __highlight 1.0 end
    wm withdraw $base
    "
    if {[string compare {} $str]} {
	set data(find) $str
	$base.btn.fnd invoke
    }

    if {[string compare normal [wm state $base]]} {
	wm deiconify $base
    } else { raise $base }
    $base.f.e select range 0 end
}

## savecommand - saves a command in a buffer for later retrieval
#
##
;proc savecommand {w} {
    upvar \#0 [namespace current]::[winfo parent $w] data

    set tmp $data(cmdsave)
    set data(cmdsave) [CmdGet $w]
    if {[string match {} $data(cmdsave)]} {
	set data(cmdsave) $tmp
    } else {
	$w delete limit end-1c
    }
    $w insert limit $tmp
    $w see end
}

## _load - sources a file into the console
# ARGS:	fn	- (optional) filename to source in
# Returns:	selected filename ({} if nothing was selected)
## 
;proc _load {W {fn ""}} {
    set types {
	{{Tcl Files}	{.tcl .tk}}
	{{Text Files}	{.txt}}
	{{All Files}	*}
    }
    if {
	[string match {} $fn] &&
	([catch {tk_getOpenFile -filetypes $types \
	    -title "Source File into Attached Interpreter"} fn]
	|| [string match {} $fn])
    } { return }
    EvalAttached [list source $fn]
}

## _save - saves the console buffer to a file
## This does not eval in a slave because it's not necessary
# ARGS:	w	- console text widget
# 	fn	- (optional) filename to save to
## 
;proc _save {W {type ""} {fn ""}} {
    upvar \#0 [namespace current]::$W data

    set c $data(console)
    if {![regexp -nocase {^(all|history|stdin|stdout|stderr)$} $type]} {
	array set s { 0 All 1 History 2 Stdin 3 Stdout 4 Stderr 5 Cancel }
	## Allow user to specify what kind of stuff to save
	set type [tk_dialog $W.savetype "Save Type" \
		"What part of the console text do you want to save?" \
		questhead 0 $s(0) $s(1) $s(2) $s(3) $s(4) $s(5)]
	if {$type == 5 || $type == -1} return
	set type $s($type)
    }
    if {[string match {} $fn]} {
	set types {
	    {{Text Files}	{.txt}}
	    {{Tcl Files}	{.tcl .tk}}
	    {{All Files}	*}
	}
	if {[catch {tk_getSaveFile -filetypes $types -title "Save $type"} fn] \
		|| [string match {} $fn]} return
    }
    set type [string tolower $type]
    set output {}
    switch $type {
	stdin -	stdout - stderr {
	    foreach {first last} [$c tag ranges $type] {
		lappend output [$c get $first $last]
	    }
	    set output [join $data \n]
	}
	history		{ set output [_history $W] }
	all - default	{ set output [$c get 1.0 end-1c] }
    }
    if {[catch {open $fn w} fid]} {
	return -code error "Save Error: Unable to open '$fn' for writing\n$fid"
    }
    puts $fid $output
    close $fid
}

## clear - clears the buffer of the console (not the history though)
## 
;proc _clear {W {pcnt 100}} {
    upvar \#0 [namespace current]::$W data

    set data(tmp) [CmdGet $data(console)]
    if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} {
	return -code error \
		"invalid percentage to clear: must be 1-100 (100 default)"
    } elseif {$pcnt == 100} {
	$data(console) delete 1.0 end
    } else {
	set tmp [expr $pcnt/100.0*[$data(console) index end]]
	$data(console) delete 1.0 "$tmp linestart"
    }
    prompt $W {} $data(tmp)
}

;proc _error {W} {
    ## Outputs stack caused by last error.
    upvar \#0 [namespace current]::$W data
    set info $data(errorInfo)
    if {[string match {} $info]} { set info {errorInfo empty} }
    catch {destroy $W.error}
    set w [toplevel $W.error]
    wm title $w "Console Last Error"
    button $w.close -text Dismiss -command [list destroy $w]
    scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview]
    text $w.text -yscrollcommand [list $w.sy set]
    pack $w.close -side bottom -fill x
    pack $w.sy -side right -fill y
    pack $w.text -fill both -expand 1
    $w.text insert 1.0 $info
    $w.text config -state disabled
}

## _event - searches for history based on a string
## Search forward (next) if $int>0, otherwise search back (prev)
# ARGS:	W	- console widget
##
;proc _event {W int {str {}}} {
    upvar \#0 [namespace current]::$W data

    if {!$int} return
    set w $data(console)

    set nextid [EvalSlave history nextid]
    if {[string compare {} $str]} {
	## String is not empty, do an event search
	set event $data(event)
	if {$int < 0 && $event == $nextid} { set data(cmdbuf) $str }
	set len [string len $data(cmdbuf)]
	incr len -1
	if {$int > 0} {
	    ## Search history forward
	    while {$event < $nextid} {
		if {[incr event] == $nextid} {
		    $w delete limit end
		    $w insert limit $data(cmdbuf)
		    break
		} elseif {![catch {EvalSlave history event $event} res] \
			&& ![string compare $data(cmdbuf) \
			[string range $res 0 $len]]} {
		    $w delete limit end
		    $w insert limit $res
		    break
		}
	    }
	    set data(event) $event
	} else {
	    ## Search history reverse
	    while {![catch {EvalSlave history event [incr event -1]} res]} {
		if {![string compare $data(cmdbuf) \
			[string range $res 0 $len]]} {
		    $w delete limit end
		    $w insert limit $res
		    set data(event) $event
		    break
		}
	    }
	} 
    } else {
	## String is empty, just get next/prev event
	if {$int > 0} {
	    ## Goto next command in history
	    if {$data(event) < $nextid} {
		$w delete limit end
		if {[incr data(event)] == $nextid} {
		    $w insert limit $data(cmdbuf)
		} else {
		    $w insert limit [EvalSlave history event $data(event)]
		}
	    }
	} else {
	    ## Goto previous command in history
	    if {$data(event) == $nextid} {set data(cmdbuf) [CmdGet $w]}
	    if {[catch {EvalSlave history event [incr data(event) -1]} res]} {
		incr data(event)
	    } else {
		$w delete limit end
		$w insert limit $res
	    }
	}
    }
    $w mark set insert end
    $w see end
}

;proc _history {W args} {
    set sub {\2}
    if {[string match -n* $args]} { append sub "\n" }
    set h [EvalSlave history]
    regsub -all "( *\[0-9\]+  |\t)(\[^\n\]*\n?)" $h $sub h
    return $h
}

##
## Some procedures to make up for lack of built-in shell commands
##

## puts
## This allows me to capture all stdout/stderr to the console window
# ARGS:	same as usual	
# Outputs:	the string with a color-coded text tag
## 
if {![catch {rename ::puts ::console_tcl_puts}]} {
    ;proc ::puts args {
	if {![catch {widget value Console active} active] && \
		[winfo exists [lindex $active 0]]} {
	    set w [lindex $active 0]
	    set len [llength $args]
	    if {$len==1} {
		eval $w insert output $args stdout {\n} stdout
		$w see output
	    } elseif {$len==2 && [regexp {(stdout|stderr|-nonewline)} \
		    [lindex $args 0] junk tmp]} {
		if {[string compare $tmp -nonewline]} {
		    eval $w insert output [lreplace $args 0 0] $tmp {\n} $tmp
		} else {
		    eval $w insert output [lreplace $args 0 0] stdout
		}
		$w see output
	    } elseif {$len==3 && \
		    [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} {
		if {[string compare [lreplace $args 1 2] -nonewline]} {
		    eval $w insert output [lrange $args 1 1] $tmp
		} else {
		    eval $w insert output [lreplace $args 0 1] $tmp
		}
		$w see output
	    } else {
		global errorCode errorInfo
		if {[catch "::console_tcl_puts $args" msg]} {
		    regsub console_tcl_puts $msg puts msg
		    regsub -all console_tcl_puts \
			    $errorInfo puts errorInfo
		    error $msg
		}
		return $msg
	    }
	    if {$len} update
	} else {
	    global errorCode errorInfo
	    if {[catch "::console_tcl_puts $args" msg]} {
		regsub console_tcl_puts $msg puts msg
		regsub -all console_tcl_puts $errorInfo puts errorInfo
		error $msg
	    }
	    return $msg
	}
    }
}

if {!$class(WWW)} {;
## We exclude the reworking of unknown for the plugin

## Unknown changed to get output into Console window
# unknown:
# Invoked automatically whenever an unknown command is encountered.
# Works through a list of "unknown handlers" that have been registered
# to deal with unknown commands.  Extensions can integrate their own
# handlers into the "unknown" facility via "unknown_handle".
#
# If a handler exists that recognizes the command, then it will
# take care of the command action and return a valid result or a
# Tcl error.  Otherwise, it should return "-code continue" (=2)
# and responsibility for the command is passed to the next handler.
#
# Arguments:
# args -	A list whose elements are the words of the original
#		command, including the command name.

proc ::unknown args {
    global unknown_handler_order unknown_handlers errorInfo errorCode

    #
    # Be careful to save error info now, and restore it later
    # for each handler.  Some handlers generate their own errors
    # and disrupt handling.
    #
    set savedErrorCode $errorCode
    set savedErrorInfo $errorInfo

    if {![info exists unknown_handler_order] || \
	    ![info exists unknown_handlers]} {
	set unknown_handlers(tcl) tcl_unknown
	set unknown_handler_order tcl
    }

    foreach handler $unknown_handler_order {
        set status [catch {uplevel $unknown_handlers($handler) $args} result]

        if {$status == 1} {
            #
            # Strip the last five lines off the error stack (they're
            # from the "uplevel" command).
            #
            set new [split $errorInfo \n]
            set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
            return -code $status -errorcode $errorCode \
		    -errorinfo $new $result

        } elseif {$status != 4} {
            return -code $status $result
        }

        set errorCode $savedErrorCode
        set errorInfo $savedErrorInfo
    }

    set name [lindex $args 0]
    return -code error "invalid command name \"$name\""
}

# tcl_unknown:
# Invoked when a Tcl command is invoked that doesn't exist in the
# interpreter:
#
#	1. See if the autoload facility can locate the command in a
#	   Tcl script file.  If so, load it and execute it.
#	2. If the command was invoked interactively at top-level:
#	    (a) see if the command exists as an executable UNIX program.
#		If so, "exec" the command.
#	    (b) see if the command requests csh-like history substitution
#		in one of the common forms !!, !<number>, or ^old^new.  If
#		so, emulate csh's history substitution.
#	    (c) see if the command is a unique abbreviation for another
#		command.  If so, invoke the command.
#
# Arguments:
# args -	A list whose elements are the words of the original
#		command, including the command name.

proc ::tcl_unknown args {
    global auto_noexec auto_noload env unknown_pending tcl_interactive
    global errorCode errorInfo

    # Save the values of errorCode and errorInfo variables, since they
    # may get modified if caught errors occur below.  The variables will
    # be restored just before re-executing the missing command.

    set savedErrorCode $errorCode
    set savedErrorInfo $errorInfo
    set name [lindex $args 0]
    if {![info exists auto_noload]} {
	#
	# Make sure we're not trying to load the same proc twice.
	#
	if {[info exists unknown_pending($name)]} {
	    return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
	}
	set unknown_pending($name) pending;
	set ret [catch {auto_load $name} msg]
	unset unknown_pending($name);
	if {$ret != 0} {
	    return -code $ret -errorcode $errorCode \
		    "error while autoloading \"$name\": $msg"
	}
	if {![array size unknown_pending]} {
	    unset unknown_pending
	}
	if {$msg} {
	    set errorCode $savedErrorCode
	    set errorInfo $savedErrorInfo
	    set code [catch {uplevel 1 $args} msg]
	    if {$code ==  1} {
		#
		# Strip the last five lines off the error stack (they're
		# from the "uplevel" command).
		#

		set new [split $errorInfo \n]
		set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
		return -code error -errorcode $errorCode \
			-errorinfo $new $msg
	    } else {
		return -code $code $msg
	    }
	}
    }
    if {[info level] == 1 && [string match {} [info script]] \
	    && [info exists tcl_interactive] && $tcl_interactive} {
	if {![info exists auto_noexec]} {
	    set new [auto_execok $name]
	    if {[string compare $new ""]} {
		set errorCode $savedErrorCode
		set errorInfo $savedErrorInfo
                set redir ""
                if {[info commands console] == ""} {
                    set redir ">&@stdout <@stdin"
                }
                return [uplevel exec $redir $new [lrange $args 1 end]]
	    }
	}
	set errorCode $savedErrorCode
	set errorInfo $savedErrorInfo
	##
	## History substitution moved into EvalCmd
	##
	set ret [catch {set cmds [info commands $name*]} msg]
	if {![string compare $name "::"]} {
	    set name ""
	}
	if {$ret != 0} {
	    return -code $ret -errorcode $errorCode \
		"error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
	}
	if {[llength $cmds] == 1} {
	    return [uplevel [lreplace $args 0 0 $cmds]]
	}
	if {[llength $cmds]} {
	    if {$name == ""} {
		return -code error "empty command name \"\""
	    } else {
		return -code error \
			"ambiguous command name \"$name\": [lsort $cmds]"
	    }
	}
    }
    return -code continue
}

}; # end switch on proc unknown

switch -glob $tcl_platform(platform) {
    win* { set META Alt }
    mac* { set META Command }
    default { set META Meta }
}

# ClipboardKeysyms --
# This procedure is invoked to identify the keys that correspond to
# the "copy", "cut", and "paste" functions for the clipboard.
#
# Arguments:
# copy -	Name of the key (keysym name plus modifiers, if any,
#		such as "Meta-y") used for the copy operation.
# cut -		Name of the key used for the cut operation.
# paste -	Name of the key used for the paste operation.

;proc ClipboardKeysyms {copy cut paste} {
    bind Console <$copy>	[namespace code {Copy %W}]
    bind Console <$cut>		[namespace code {Cut %W}]
    bind Console <$paste>	[namespace code {Paste %W}]
}

;proc Cut w {
    if {[string match $w [selection own -displayof $w]]} {
	clipboard clear -displayof $w
	catch {
	    clipboard append -displayof $w [selection get -displayof $w]
	    if {[$w compare sel.first >= limit]} {$w delete sel.first sel.last}
	}
    }
}
;proc Copy w {
    if {[string match $w [selection own -displayof $w]]} {
	clipboard clear -displayof $w
	catch {clipboard append -displayof $w [selection get -displayof $w]}
    }
}

;proc Paste w {
    if {
	![catch {selection get -displayof $w} tmp] ||
	![catch {selection get -displayof $w -type TEXT} tmp] ||
	![catch {selection get -displayof $w -selection CLIPBOARD} tmp]
    } {
	if {[$w compare insert < limit]} {$w mark set insert end}
	$w insert insert $tmp
	$w see insert
	if {[string match *\n* $tmp]} {Eval $w}
    }
}

## Get all Text bindings into Console
foreach ev [bind Text] { bind Console $ev [namespace code [bind Text $ev]] }
## We don't want newline insertion
bind Console <Control-Key-o> {}

foreach {ev key} {
    <<Console_Prev>>		<Key-Up>
    <<Console_Next>>		<Key-Down>
    <<Console_NextImmediate>>	<Control-Key-n>
    <<Console_PrevImmediate>>	<Control-Key-p>
    <<Console_PrevSearch>>	<Control-Key-r>
    <<Console_NextSearch>>	<Control-Key-s>

    <<Console_Expand>>		<Key-Tab>
    <<Console_ExpandFile>>	<Key-Escape>
    <<Console_ExpandProc>>	<Control-Shift-Key-P>
    <<Console_ExpandVar>>	<Control-Shift-Key-V>
    <<Console_Tab>>		<Control-Key-i>
    <<Console_Tab>>		<Meta-Key-i>
    <<Console_Eval>>		<Key-Return>
    <<Console_Eval>>		<Key-KP_Enter>

    <<Console_Clear>>		<Control-Key-l>
    <<Console_KillLine>>	<Control-Key-k>
    <<Console_Transpose>>	<Control-Key-t>
    <<Console_ClearLine>>	<Control-Key-u>
    <<Console_SaveCommand>>	<Control-Key-z>

    <<Console_Exit>>		<Control-Key-q>
    <<Console_New>>		<Control-Key-N>
    <<Console_Close>>		<Control-Key-w>
    <<Console_About>>		<Control-Key-A>
    <<Console_Help>>		<Control-Key-H>
    <<Console_Find>>		<Control-Key-F>
} {
    event add $ev $key
    bind Console $key {}
}
catch {unset ev key}

## Redefine for Console what we need
##
event delete <<Paste>> <Control-V>
ClipboardKeysyms <Copy> <Cut> <Paste>

bind Console <Insert> {catch {Insert %W [selection get -displayof %W]}}

bind Console <Triple-1> {+
catch {
    eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last]
    eval %W tag remove sel sel.last-1c
    %W mark set insert sel.first
}
}

bind Console <<Console_Expand>> [namespace code {
    if {[%W compare insert > limit]} {Expand %W}
    break
}]
bind Console <<Console_ExpandFile>> [namespace code {
    if {[%W compare insert > limit]} {Expand %W path}
    break
}]
bind Console <<Console_ExpandProc>> [namespace code {
    if {[%W compare insert > limit]} {Expand %W proc}
    break
}]
bind Console <<Console_ExpandVar>> [namespace code {
    if {[%W compare insert > limit]} {Expand %W var}
    break
}]
bind Console <<Console_Tab>> [namespace code {
    if {[%W compare insert >= limit]} {	Insert %W \t }
}]
bind Console <<Console_Eval>> [namespace code { Eval %W }]
bind Console <Delete> {
    if {[string compare {} [%W tag nextrange sel 1.0 end]] \
	    && [%W compare sel.first >= limit]} {
	%W delete sel.first sel.last
    } elseif {[%W compare insert >= limit]} {
	%W delete insert
	%W see insert
    }
}
bind Console <BackSpace> {
    if {[string compare {} [%W tag nextrange sel 1.0 end]] \
	    && [%W compare sel.first >= limit]} {
	%W delete sel.first sel.last
    } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} {
	%W delete insert-1c
	%W see insert
    }
}
bind Console <Control-h> [bind Console <BackSpace>]

bind Console <KeyPress> [namespace code { Insert %W %A }]

bind Console <Control-a> {
    if {[%W compare {limit linestart} == {insert linestart}]} {
	tkTextSetCursor %W limit
    } else {
	tkTextSetCursor %W {insert linestart}
    }
}
bind Console <Control-d> {
    if {[%W compare insert < limit]} break
    %W delete insert
}
bind Console <<Console_KillLine>> {
    if {[%W compare insert < limit]} break
    if {[%W compare insert == {insert lineend}]} {
	%W delete insert
    } else {
	%W delete insert {insert lineend}
    }
}
bind Console <<Console_Clear>> [namespace code { _clear [winfo parent %W] }]
bind Console <<Console_Prev>> [namespace code {
    if {[%W compare {insert linestart} != {limit linestart}]} {
	tkTextSetCursor %W [tkTextUpDownLine %W -1]
    } else {
	_event [winfo parent %W] -1
    }
}]
bind Console <<Console_Next>> [namespace code {
    if {[%W compare {insert linestart} != {end-1c linestart}]} {
	tkTextSetCursor %W [tkTextUpDownLine %W 1]
    } else {
	_event [winfo parent %W] 1
    }
}]
bind Console <<Console_NextImmediate>> [namespace code {
    _event [winfo parent %W] 1
}]
bind Console <<Console_PrevImmediate>> [namespace code {
    _event [winfo parent %W] -1
}]
bind Console <<Console_PrevSearch>> [namespace code {
    _event [winfo parent %W] -1 [CmdGet %W]
}]
bind Console <<Console_NextSearch>> [namespace code {
    _event [winfo parent %W] 1 [CmdGet %W]
}]
bind Console <<Console_Transpose>> {
    ## Transpose current and previous chars
    if {[%W compare insert > limit]} { tkTextTranspose %W }
}
bind Console <<Console_ClearLine>> {
    ## Clear command line (Unix shell staple)
    %W delete limit end
}
bind Console <<Console_SaveCommand>> [namespace code {
    ## Save command buffer (swaps with current command)
    savecommand %W
}]
catch {bind Console <Key-Page_Up>   { tkTextScrollPages %W -1 }}
catch {bind Console <Key-Prior>     { tkTextScrollPages %W -1 }}
catch {bind Console <Key-Page_Down> { tkTextScrollPages %W 1 }}
catch {bind Console <Key-Next>      { tkTextScrollPages %W 1 }}
bind Console <$META-d> {
    if {[%W compare insert >= limit]} {
	%W delete insert {insert wordend}
    }
}
bind Console <$META-BackSpace> {
    if {[%W compare {insert -1c wordstart} >= limit]} {
	%W delete {insert -1c wordstart} insert
    }
}
bind Console <$META-Delete> {
    if {[%W compare insert >= limit]} {
	%W delete insert {insert wordend}
    }
}
bind Console <ButtonRelease-2> {
    ## Try and get the default selection, then try and get the selection
    ## type TEXT, then try and get the clipboard if nothing else is available
    if {
	(!$tkPriv(mouseMoved) || $tk_strictMotif) &&
	(![catch {selection get -displayof %W} tkPriv(junk)] ||
	![catch {selection get -displayof %W -type TEXT} tkPriv(junk)] ||
	![catch {selection get -displayof %W \
		-selection CLIPBOARD} tkPriv(junk)])
    } {
	if {[%W compare @%x,%y < limit]} {
	    %W insert end $tkPriv(junk)
	} else {
	    %W insert @%x,%y $tkPriv(junk)
	}
	if {[string match *\n* $tkPriv(junk)]} {
	    namespace inscope ::Widget::Console { Eval %W }
	}
    }
}

##
## End Console bindings
##

##
## Bindings for doing special things based on certain keys
##
bind PostConsole <Key-parenright> [namespace code {
    if {[string compare \\ [%W get insert-2c]]} {MatchPair %W \( \) limit}
}]
bind PostConsole <Key-bracketright> [namespace code {
    if {[string compare \\ [%W get insert-2c]]} {MatchPair %W \[ \] limit}
}]
bind PostConsole <Key-braceright> [namespace code {
    if {[string compare \\ [%W get insert-2c]]} {MatchPair %W \{ \} limit}
}]
bind PostConsole <Key-quotedbl> [namespace code {
    if {[string compare \\ [%W get insert-2c]]} {MatchQuote %W limit}
}]

bind PostConsole <KeyPress> [namespace code {
    if {[string compare {} %A]} {TagProc %W}
}]


## TagProc - tags a procedure in the console if it's recognized
## This procedure is not perfect.  However, making it perfect wastes
## too much CPU time...  Also it should check the existence of a command
## in whatever is the connected slave, not the master interpreter.
##
;proc TagProc w {
    upvar \#0 [namespace current]::[winfo parent $w] data
    if {!$data(-lightcmd)} return
    set exp "\[^\\]\[\[ \t\n\r\;{}\"\$]"
    set i [$w search -backwards -regexp $exp insert-1c limit-1c]
    if {[string compare {} $i]} {append i +2c} {set i limit}
    regsub -all {[[\\\?\*]} [$w get $i "insert-1c wordend"] {\\\0} c
    if {[string compare {} [EvalAttached info commands [list $c]]]} {
	$w tag add proc $i "insert-1c wordend"
    } else {
	$w tag remove proc $i "insert-1c wordend"
    }
    if {[string compare {} [EvalAttached info vars [list $c]]]} {
	$w tag add var $i "insert-1c wordend"
    } else {
	$w tag remove var $i "insert-1c wordend"
    }
}

## MatchPair - blinks a matching pair of characters
## c2 is assumed to be at the text index 'insert'.
## This proc is really loopy and took me an hour to figure out given
## all possible combinations with escaping except for escaped \'s.
## It doesn't take into account possible commenting... Oh well.  If
## anyone has something better, I'd like to see/use it.  This is really
## only efficient for small contexts.
# ARGS:	w	- console text widget
# 	c1	- first char of pair
# 	c2	- second char of pair
# Calls:	blink
## 
;proc MatchPair {w c1 c2 {lim 1.0}} {
    upvar \#0 [namespace current]::[winfo parent $w] data
    if {!$data(-lightbrace) || $data(-blinktime)<100} return
    if {[string compare [set ix [$w search -back $c1 insert $lim]] {}]} {
	while {[string match {\\} [$w get $ix-1c]] && \
		[string compare [set ix [$w search -back $c1 $ix-1c $lim]] {}]} {}
	set i1 insert-1c
	while {[string compare $ix {}]} {
	    set i0 $ix
	    set j 0
	    while {[string compare [set i0 [$w search $c2 $i0 $i1]] {}]} {
		append i0 +1c
		if {[string match {\\} [$w get $i0-2c]]} continue
		incr j
	    }
	    if {!$j} break
	    set i1 $ix
	    while {$j && [string compare \
		    [set ix [$w search -back $c1 $ix $lim]] {}]} {
		if {[string match {\\} [$w get $ix-1c]]} continue
		incr j -1
	    }
	}
	if {[string match {} $ix]} { set ix [$w index $lim] }
    } else {
	set ix [$w index $lim]
    }
    if {$data(-blinkrange)} {
	blink $w $data(-blinktime) $ix [$w index insert]
    } else {
	blink $w $data(-blinktime) $ix $ix+1c \
		[$w index insert-1c] [$w index insert]
    }
}

## MatchQuote - blinks between matching quotes.
## Blinks just the quote if it's unmatched, otherwise blinks quoted string
## The quote to match is assumed to be at the text index 'insert'.
# ARGS:	w	- console text widget
# Calls:	blink
## 
;proc MatchQuote {w {lim 1.0}} {
    upvar \#0 [namespace current]::[winfo parent $w] data
    if {!$data(-lightbrace) || $data(-blinktime)<100} return
    set i insert-1c
    set j 0
    while {[string compare {} [set i [$w search -back \" $i $lim]]]} {
	if {[string match {\\} [$w get $i-1c]]} continue
	if {!$j} {set i0 $i}
	incr j
    }
    if {[expr $j%2]} {
	if {$data(-blinkrange)} {
	    blink $w $data(-blinktime) $i0 [$w index insert]
	} else {
	    blink $w $data(-blinktime) $i0 $i0+1c \
		    [$w index insert-1c] [$w index insert]
	}
    } else {
	blink $w $data(-blinktime) [$w index insert-1c] \
		[$w index insert]
    }
}

## blink - blinks between 2 indices for a specified duration.
# ARGS:	w	- console text widget
#	delay	- millisecs to blink for
# 	args	- indices of regions to blink
# Outputs:	blinks selected characters in $w
## 
;proc blink {w delay args} {
    eval $w tag add blink $args
    after $delay eval $w tag remove blink $args
    return
}


## Insert
## Insert a string into a text console at the point of the insertion cursor.
## If there is a selection in the text, and it covers the point of the
## insertion cursor, then delete the selection before inserting.
# ARGS:	w	- text window in which to insert the string
# 	s	- string to insert (usually just a single char)
# Outputs:	$s to text widget
## 
;proc Insert {w s} {
    if {[string match {} $s] || [string match disabled [$w cget -state]]} {
	return
    }
    if {[$w comp insert < limit]} {
	$w mark set insert end
    }
    catch {
	if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} {
	    $w delete sel.first sel.last
	}
    }
    $w insert insert $s
    $w see insert
}

## Expand - 
# ARGS:	w	- text widget in which to expand str
# 	type	- type of expansion (path / proc / variable)
# Calls:	Expand(Pathname|Procname|Variable)
# Outputs:	The string to match is expanded to the longest possible match.
#		If data(-showmultiple) is non-zero and the user longest match
#		equaled the string to expand, then all possible matches are
#		output to stdout.  Triggers bell if no matches are found.
# Returns:	number of matches found
## 
## FIX: make namespace aware
;proc Expand {w {type ""}} {
    set exp "\[^\\]\[\[ \t\n\r{}\"\$]"
    set tmp [$w search -backwards -regexp $exp insert-1c limit-1c]
    if {[string compare {} $tmp]} {append tmp +2c} else {set tmp limit}
    if {[$w compare $tmp >= insert]} return
    set str [$w get $tmp insert]
    switch -glob $type {
	pa* { set res [ExpandPathname $str] }
	pr* { set res [ExpandProcname $str] }
	v*  { set res [ExpandVariable $str] }
	default {
	    set res {}
	    foreach t {Pathname Procname Variable} {
		if {[string compare {} [set res [Expand$t $str]]]} break
	    }
	}
    }
    set len [llength $res]
    if {$len} {
	$w delete $tmp insert
	$w insert $tmp [lindex $res 0]
	if {$len > 1} {
	    upvar \#0 [namespace current]::[winfo parent $w] data
	    if {$data(-showmultiple) && \
		    ![string compare [lindex $res 0] $str]} {
		puts stdout [lsort [lreplace $res 0 0]]
	    }
	}
    } else { bell }
    return [incr len -1]
}

## ExpandPathname - expand a file pathname based on $str
## This is based on UNIX file name conventions
# ARGS:	str	- partial file pathname to expand
# Calls:	ExpandBestMatch
# Returns:	list containing longest unique match followed by all the
#		possible further matches
## 
;proc ExpandPathname str {
    set pwd [EvalAttached pwd]
    if {[catch {EvalAttached [list cd [file dirname $str]]} err]} {
	return -code error $err
    }
    if {[catch {lsort -dict [EvalAttached [list glob [file tail $str]*]]} m]} {
	set match {}
    } else {
	if {[llength $m] > 1} {
	    global tcl_platform
	    if {[string match windows $tcl_platform(platform)]} {
		## Windows is screwy because it's can be case insensitive
		set tmp [best_match [string tolower $m] \
			[string tolower [file tail $str]]]
	    } else {
		set tmp [best_match $m [file tail $str]]
	    }
	    if {[string match ?*/* $str]} {
		set tmp [file dirname $str]/$tmp
	    } elseif {[string match /* $str]} {
		set tmp /$tmp
	    }
	    regsub -all { } $tmp {\\ } tmp
	    set match [linsert $m 0 $tmp]
	} else {
	    ## This may look goofy, but it handles spaces in path names
	    eval append match $m
	    if {[file isdir $match]} {append match /}
	    if {[string match ?*/* $str]} {
		set match [file dirname $str]/$match
	    } elseif {[string match /* $str]} {
		set match /$match
	    }
	    regsub -all { } $match {\\ } match
	    ## Why is this one needed and the ones below aren't!!
	    set match [list $match]
	}
    }
    EvalAttached [list cd $pwd]
    return $match
}

## ExpandProcname - expand a tcl proc name based on $str
# ARGS:	str	- partial proc name to expand
# Calls:	best_match
# Returns:	list containing longest unique match followed by all the
#		possible further matches
## 
;proc ExpandProcname str {
    set match [EvalAttached [list info commands $str*]]
    if {[llength $match] > 1} {
	regsub -all { } [best_match $match $str] {\\ } str
	set match [linsert $match 0 $str]
    } else {
	regsub -all { } $match {\\ } match
    }
    return $match
}

## ExpandVariable - expand a tcl variable name based on $str
# ARGS:	str	- partial tcl var name to expand
# Calls:	best_match
# Returns:	list containing longest unique match followed by all the
#		possible further matches
## 
;proc ExpandVariable str {
    if {[regexp {([^\(]*)\((.*)} $str junk ary str]} {
	## Looks like they're trying to expand an array.
	set match [EvalAttached [list array names $ary $str*]]
	if {[llength $match] > 1} {
	    set vars $ary\([best_match $match $str]
	    foreach var $match {lappend vars $ary\($var\)}
	    return $vars
	} else {set match $ary\($match\)}
	## Space transformation avoided for array names.
    } else {
	set match [EvalAttached [list info vars $str*]]
	if {[llength $match] > 1} {
	    regsub -all { } [best_match $match $str] {\\ } str
	    set match [linsert $match 0 $str]
	} else {
	    regsub -all { } $match {\\ } match
	}
    }
    return $match
}

## resource - re'source's this script into current console
## Meant primarily for my development of this program.  It follows
## links until the ultimate source is found.
##
set class(SCRIPT) [info script]
if {!$class(WWW)} {
    while {[string match link [file type $class(SCRIPT)]]} {
	set link [file readlink $class(SCRIPT)]
	if {[string match relative [file pathtype $link]]} {
	    set class(SCRIPT) [file join \
		    [file dirname $class(SCRIPT)] $link]
	} else {
	    set class(SCRIPT) $link
	}
    }
    catch {unset link}
    if {[string match relative [file pathtype $class(SCRIPT)]]} {
	set class(SCRIPT) [file join [pwd] $class(SCRIPT)]
    }
}

;proc resource {} {
    upvar \#0 [namespace current] class
    uplevel \#0 [list source $class(SCRIPT)]
}

}; # end namespace ::Widget::Console
Added library/digraph.tcl.














































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
# digraph.tcl --
#
# This file defines the bindings for Tk widgets to provide
# procedures that allow the input of the extended latin charset
# (often referred to as digraphs).
#
# Copyright (c) 1998 Jeffrey Hobbs

package require Tk 8

namespace eval ::digraph {;

namespace export -clear digraph

variable wid
array set char {
    `A	�	A`	�	`a	�	a`	�
    'A	�	A'	�	'a	�	a'	�
    ^A	�	A^	�	^a	�	a^	�
    ~A	�	A~	�	~a	�	a~	�
    \"A	�	A\"	�	\"a	�	a\"	�
    *A	�	A*	�	*a	�	a*	�
    AE	�			ae	�

    ,C	�	C,	�	,c	�	c,	�

    -D	�	D-	�	-d	�	d-	�

    `E	�	E`	�	`e	�	e`	�
    'E	�	E'	�	'e	�	e'	�
    ^E	�	E^	�	^e	�	e^	�
    \"E	�	E\"	�	\"e	�	e\"	�

    `I	�	I`	�	`i	�	i`	�
    'I	�	I'	�	'i	�	i'	�
    ^I	�	I^	�	^i	�	i^	�
    \"I	�	I\"	�	\"i	�	i\"	�

    ~N	�	N~	�	~n	�	n~	�

    `O	�	O`	�	`o	�	o`	�
    'O	�	O'	�	'o	�	o'	�
    ^O	�	O^	�	^o	�	o^	�
    ~O	�	O~	�	~o	�	o~	�
    \"O	�	O\"	�	\"o	�	o\"	�
    /O	�	O/	�	/o	�	o/	�

    `U	�	U`	�	`u	�	u`	�
    'U	�	U'	�	'u	�	u'	�
    ^U	�	U^	�	^u	�	u^	�
    \"U	�	U\"	�	\"u	�	u\"	�

    'Y	�	'y	�	\"y	�	y\"	�

    ss	�

    !!	�	||	�	\"\"	�	,,	�
    c/	�	/c	�	C/	�	/C	�
    l-	�	-l	�	L-	�	-L	�
    ox	�	xo	�	OX	�	XO	�
    y-	�	-y	�	Y-	�	-Y	�

    co	�	oc	�	CO	�	OC	�
    <<	�	>>	�
    ro	�	or	�	RO	�	OR	�
    -^	�	^-	�	-+	�	+-	�
    ^2	�	2^	�	^3	�	3^	�
    ,u	�	u,	�	.^	�	^.	�
    P|	�	|P	�	p|	�	|p	�
    14	�	41	�	12	�	21	�
    34	�	43	�	??	�	xx	�
}

proc translate {c} {
    variable char
    if {[info exists char($c)]} {return $char($c)}
    return $c
}

proc insert {w type a k} {
    variable wid
    if {[info exists wid($w)]} {
	# This means we have already established the echar binding
	if {[info exists wid(FIRST.$w)]} {
	    # This means that we are in the middle of setting an echar
	    # By default, it will be these two chars
	    set char [translate "$wid(FIRST.$w)$a"]
	    switch -exact $type {
		TkConsole	{ tkConInsert $w $char }
		Text		{ tkTextInsert $w $char }
		Entry		{ tkEntryInsert $w $char }
		Table		{ $w insert active insert $char }
		default		{ catch { $w insert $char } }
	    }
	    bind $w <KeyPress> $wid($w)
	    unset wid($w)
	    unset wid(FIRST.$w)
	} else {
	    # This means we are getting the first part of the echar
	    if {[string compare $a {}]} {
		set wid(FIRST.$w) $a
	    } else {
		# For Text widget, after the Multi_key,
		# it does some weird things to Tk's keysym translations
		switch -glob $k {
		    apostrophe	{set wid(FIRST.$w) "'"}
		    grave	{set wid(FIRST.$w) "`"}
		    comma	{set wid(FIRST.$w) ","}
		    quotedbl	{set wid(FIRST.$w) "\""}
		    asciitilde	{set wid(FIRST.$w) "~"}
		    asciicurcum	{set wid(FIRST.$w) "^"}
		    Control* - Shift* - Caps_Lock - Alt* - Meta* {
			# ignore this anomaly
			return
		    }
		    default	{
			# bogus first char, just end state transition now
			bind $w <KeyPress> $wid($w)
			unset wid($w)
		    }
		}
	    }
	}
    } else {
	# Cache the widget's binding, it doesn't matter if there isn't one
	# If the class has a special binding, then this could be redone
	set wid($w) [bind $w <KeyPress>]
	# override the binding
	bind $w <KeyPress> [namespace code \
		"insert %W [list $type] %A %K; break"]
    }
}

# w is either a specific widget, or a class
proc digraph {w} {
    if {[winfo exists $w]} {
	# it is a specific widget
    } else {
	# it is a class of widgets
	if {[string compare [info commands digraph$w] {}]} {
	    digraph$w
	} else {
	    bind $w <<Digraph>> [namespace code \
		"insert %W [list $w] %A %K; break"]
	}
    }
}

proc digraphText args {
    bind Text <<Digraph>> [namespace code { insert %W Text %A %K; break }]
    bind Text <Key-Escape> {}
}

proc digraphEntry args {
    bind Entry <<Digraph>> [namespace code { insert %W Entry %A %K; break }]
    bind Entry <Key-Escape> {}
}

proc digraphTable args {
    bind Table <<Digraph>> [namespace code { insert %W Table %A %K; break }]
    #bind Table <Key-Escape> {}
}

proc digraphTkConsole args {
    bind TkConsole <<Digraph>> [namespace code {
	insert %W TkConsole %A %K
	break
    }
    ]
    event delete <<TkCon_ExpandFile>> <Key-Escape>
}

}; # end creation of digraph namespace

# THE EVENT YOU CHOOSE IS IMPORTANT - You should also make sure that that
# event is not bound to the class already (for example, most bind <Escape>
# to {# nothing}, but Table uses it for the reread and TkConsole uses it
# for TkCon_ExpandFile).  The Sun <Multi_key> works already, but you might
# want to define special state keys

event add <<Digraph>> <Key-Escape> <Mode_switch>


Added library/hierarchy.tcl.


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
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
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
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
614
615
616
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
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
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
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
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
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
##
## Layout routines taken from oooold code, author unkown.
## Copyright 1995-1998 Jeffrey Hobbs, [email protected]
##
## Last Update: 28 June 1997
##
package require Widget 2.0
package provide Hierarchy 2.0

##-----------------------------------------------------------------------
## PROCEDURE(S)
##	hierarchy, hierarchy_dir, hierarchy_widget
##
## ARGUMENTS && DESCRIPTION
##
## hierarchy <window pathname> <options>
##	Implements a hierarchical listbox
## hierarchy_dir <window pathname> <options>
##	Implements a hierarchical listbox using a directory view structure
##	for the default methods
## hierarchy_widget <window pathname> <options>
##	Implements a hierarchical listbox using a widget view structure
##	for the default methods
##
## OPTIONS
##	(Any canvas option may be used with a hierarchy)
##
## -autoscrollbar TCL_BOOLEAN			DEFAULT: 1
##	Determines whether scrollbars automagically pop-up or
##	are permanently there.
##
## -browsecmd procedure				DEFAULT: noop
##	A command which the widget will execute when the node is expanded
##	to retrieve the children of a node.  The widget and node path are
##	appended to the command as a list of node names which
##	form a path to the node from the root.  Thus the first
##	element of this list will always be the root node.
##
## -command procedure				DEFAULT: noop
##	A command which the widget will execute when the node is toggled.
##	The name of the widget, the node path, and whether the children of
##	the node are showing (0/1) is appended to the procedure args.
##
## -decoration TCL_BOOLEAN			DEFAULT: 1
##	If this is true, the "tree" lines are drawn.
##
## -expand #					DEFAULT: 1
##	an integer value for an initial depth to expand to.
##
## -font fontname				DEFAULT: fixed
##	The default font used for the text.
##
## -foreground color				DEFAULT: black
##	The default foreground color used for text of unselected nodes.
##
## -ipad #					DEFAULT: 3
##	The internal space added between the image and the text for a
##	given node.
##
## -nodelook procedure				DEFAULT: noop
##	A command the widget will execute to get the look of a node.
##	The node is appended to the command as a list of
##	node-names which form a path to the node from the root.
##	Thus the first element of this list will always be the
##	root node.  Also appended is a 
##	boolean value which indicates whether the node's children
##	are currently displayed.  This allows the node's
##	look to change if it is "opened" or "closed".
##
##	This command must return a 4-tuple list containing:
##		0. the text to display at the node
##		1. the font to use for the text
##		2. an image to display
##		3. the foreground color to use for the node
##	If no font (ie. {}) is specified then
##	the value from -font is used.  If no image is specified
##	then no image is displayed.
##	The default is a command to which produces a nice look
##	for a file manager.  
##
## -paddepth #					DEFAULT: 12
##	The indent space added for child branches.
##
## -padstack #					DEFAULT: 2
##	The space added between two rows
##
## -root rootname				DEFAULT: {}
##  	The name of the root node of the tree.  Each node
##	name must be unique amongst the children of each node.
##
## -selectbackground color			DEFAULT: red
##	The default background color used for the text of selected nodes.
##
## -selectmode (single|browse|multiple)		DEFAULT: browse
##	Like listbox modes, "multiple" is a mix of multiple && extended.
##
## -showall TCL_BOOLEAN				DEFAULT: 0
##	For directory nodelook, also show Unix '.' (hidden) files/dirs.
##
## -showfiles TCL_BOOLEAN			DEFAULT: 0
##	Show files as well as directories.
##
## -showparent string				DEFAULT: {}
##	For hierarchy_dir nodelook, if string != {}, then it will show that
##	string which will reset the root node to its parent.
##
## METHODS
##	These are the methods that the hierachical listbox object recognizes.
##	(ie - hierachy .h ; .h <method> <args>)
##	Any unique substring is acceptable
##
## configure ?option? ?value option value ...?
## cget option
##	Standard tk widget routines.
##
## close index
##	Closes the specified index (will trigger -command).
##
## curselection
##	Returns the indices of the selected items.  This differs from the
##	listbox method because indices here have no implied order.
##
## get index ?index ...?
##	Returns the node paths of the items referenced.  Ranges are not
##	allowed.  Index specification is like that allowed by the index
##	method.
##
## qget index ?index ...?
##	As above, but the indices must be that of the item (as returned
##	by the index or curselection method).
##
## index index
##	Returns the hierarchy numerical index of the item (the numerical
##	index has no implied order relative to the list items).  index
##	may be of the form:
##
##	number - Specifies the element as a numerical index.
##	root   - specifies the root item.
##	string - Specifis an item that has that text in it's node.
##	@x,y   - Indicates the element that covers the point in
##		the listbox window specified by x and y (in pixel
##		coordinates).  If no element covers that point,
##		then the closest element to that point is used.
##
## open index
##	Opens the specified index (will trigger -command).
##
## see index
##	Ensures that the item specified by the index is viewable.
##
## refresh
##	Refreshes all open nodes
##
## selection option arg
##	This works like the listbox selection method with the following
##	exceptions:
##
##	The selection clear option can take multiple indices, but not a range.
##	No arguments to clear means clear all the selected elements.
##
##	The selection set option can take multiple indices, but not a range.
##	The key word 'all' sets the selection for all elements.
##
## size
##	Returns the number of items in the hierarchical listbox.
##
## toggle index
##	Toggles (open or closed) the item specified by index
##	(triggers -command).
##
## BINDINGS
##	Most Button-1 bindings on the hierarchy work in the same manner
##	as those for the listbox widget, as defined by the selectmode.
##	Those that vary are listed below:
##
## <Double-Button-1>
##	Toggles a node in the hierarchy
##
## NAMESPACE & STATE
##	The megawidget creates a global array with the classname, and a
## global array which is the name of each megawidget is created.  The latter
## array is deleted when the megawidget is destroyed.
##	Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used.
## Other procs that begin with $CLASSNAME are private.  For each widget,
## commands named .$widgetname and $CLASSNAME$widgetname are created.
##
##-----------------------------------------------------------------------

# Create this to make sure there are registered in auto_mkindex
# these must come before the [widget create ...]
proc Hierarchy args {}
proc hierarchy args {}

## In general, we cannot use $data(basecmd) in the construction, but the
## scrollbar commands won't be called until after it really exists as a
## proper command
widget create Hierarchy -type frame -base canvas -components {
    {base canvas canvas {-relief sunken -bd 1 -highlightthickness 1 \
	    -yscrollcommand [list $data(yscrollbar) set] \
	    -xscrollcommand [list $data(xscrollbar) set]}}
    {scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1\
	    -command [list $data(basecmd) xview]}}
    {scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1\
	    -command [list $data(basecmd) yview]}}
} -options {
    {-autoscrollbar	autoScrollbar	AutoScrollbar	1}
    {-browsecmd		browseCmd	BrowseCmd	{}}
    {-command		command		Command		{}}
    {-decoration	decoration	Decoration	1}
    {-expand		expand		Expand		1}
    {-font		font		Font		fixed}
    {-foreground	foreground	Foreground	black}
    {-ipad		ipad		Ipad		3}
    {-nodelook		nodeLook	NodeLook	{}}
    {-paddepth		padDepth	PadDepth	12}
    {-padstack		padStack	PadStack	2}
    {-root		root		Root		{}}
    {-selectmode	selectMode	SelectMode	browse}
    {-selectbackground	selectBackground SelectBackground red}
    {-state		state		State		normal}

    {-showall		showAll		ShowAll		0}
    {-showparent	showParent	ShowParent	{}}
    {-showfiles		showFiles	ShowFiles	0}
}

proc hierarchy_dir {w args} {
    uplevel [list hierarchy $w -root [pwd] \
	    -nodelook  {namespace inscope ::Widget::Hierarchy FileLook} \
	    -command   {namespace inscope ::Widget::Hierarchy FileActivate} \
	    -browsecmd {namespace inscope ::Widget::Hierarchy FileList}] \
	    $args
}

proc hierarchy_widget {w args} {
    uplevel [list hierarchy $w -root . \
	    -nodelook  {namespace inscope ::Widget::Hierarchy WidgetLook} \
	    -command   {namespace inscope ::Widget::Hierarchy WidgetActivate} \
	    -browsecmd {namespace inscope ::Widget::Hierarchy WidgetList}] \
	    $args
}

if {[string match windows $tcl_platform(platform)] && \
	![catch {package require registry}]} {
proc hierarchy_registry {w args} {
    uplevel [list hierarchy $w -root "Localhost" \
	    -nodelook  {namespace inscope ::Widget::Hierarchy RegistryLook} \
	    -command   {namespace inscope ::Widget::Hierarchy RegistryAct} \
	    -browsecmd {namespace inscope ::Widget::Hierarchy RegistryList}] \
	    $args
}
}

namespace eval ::Widget::Hierarchy {;

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

    ## Private variables
    array set data [list \
	    hasnodelook	0 \
	    halfpstk	[expr $data(-padstack)/2] \
	    width	400 \
	    ]

    grid $data(canvas) $data(yscrollbar) -sticky news
    grid $data(xscrollbar) -sticky ew
    grid columnconfig $w 0 -weight 1
    grid rowconfig $w 0 -weight 1
    bind $data(canvas) <Configure> [namespace code [list Resize $w %w %h]]
}

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

    set data(:$data(-root),showkids) 0
    ExpandNodeN $w $data(-root) $data(-expand)
    if {[catch {$w see $data(-root)}]} {
	$data(basecmd) configure -scrollregion {0 0 1 1}
    }
}

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

    set truth {^(1|yes|true|on)$}
    array set config { resize 0 root 0 showall 0 }
    foreach {key val} $args {
	switch -- $key {
	    -autoscrollbar {
		set val [regexp -nocase $truth $val]
		if {$val} {
		    set config(resize) 1
		} else {
		    grid $data(xscrollbar)
		    grid $data(yscrollbar)
		}
	    }
	    -decoration	{ set val [regexp -nocase $truth $val] }
	    -padstack	{ set data(halfpstk) [expr {$val/2}] }
	    -nodelook	{
		## We set this special bool val because it saves some
		## computation in ExpandNode, a deeply nested proc
		set data(hasnodelook) [string compare $val {}]
	    }
	    -root		{
		if {[info exists data(:$data(-root),showkids)]} {
		    ## All data about items and selection should be
		    ## cleared and the items deleted
		    foreach name [concat [array names data :*] \
			    [array names data S,*]] {unset data($name)}
		    $data(basecmd) delete all
		    set data(-root) $val
		    set config(root) 1
		    ## Avoid setting data($key) below
		    continue
		}
	    }
	    -selectbackground {
		foreach i [array names data S,*] {
		    $data(basecmd) itemconfigure [string range $i 2 end] \
			    -fill $val
		}
	    }
	    -state	{
		if {![regexp {^(normal|disabled)$} $val junk val]} {
		    return -code error "bad state value \"$val\":\
			    must be normal or disabled"
		}
	    }
	    -showall	-
	    -showfiles	{
		set val [regexp -nocase $truth $val]
		if {$val == $data($key)} continue
		set config(showall) 1
	    }
	}
	set data($key) $val
    }
    if {$config(root)} {
	set data(:$val,showkids) 0
	ExpandNodeN $w $val $data(-expand)
    } elseif {$config(showall) && [info exists data(:$data(-root),showkids)]} {
	_refresh $w
    } elseif {$config(resize)} {
	Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
    }
}

## Cryptic source code arguments explained:
## (these, or a similar form, might appear as variables later)
## np   == node path
## cnp  == changed np
## knp  == kids np
## xcnp == extra cnp

;proc _index { w idx } {
    upvar \#0 [namespace current]::$w data
    set c $data(basecmd)
    if {[string match all $idx]} {
	return [$c find withtag box]
    } elseif {[regexp {^(root|anchor)$} $idx]} {
	return [$c find withtag box:$data(-root)]
    }
    foreach i [$c find withtag $idx] {
	if {[string match rec* [$c type $i]]} { return $i }
    }
    if {[regexp {@(-?[0-9]+),(-?[0-9]+)} $idx z x y]} {
	return [$c find closest [$w canvasx $x] [$w canvasy $y] 1 text]
    }
    foreach i [$c find withtag box:[lindex $idx 0]] { return $i }
    return -code error "bad hierarchy index \"$idx\":\
	    must be current, @x,y, a number, or a node name"
}

;proc _selection { w args } {
    if {[string match {} $args]} {
	return -code error \
		"wrong \# args: should be \"$w selection option args\""
    }
    upvar \#0 [namespace current]::$w data
    set err [catch {_index $w [lindex $args 1]} idx]
    switch -glob -- [lindex $args 0] {
	an* {
	    ## anchor
	    ## stubbed out - too complicated to support
	}
	cl* {
	    ## clear
	    set c $data(basecmd)
	    if {$err} {
		foreach arg [array names data S,*] { unset data($arg) }
		$c itemconfig box -fill {}
	    } else {
		catch {unset data(S,$idx)}
		$c itemconfig $idx -fill {}
		foreach idx [lrange $args 2 end] {
		    if {[catch {_index $w $idx} idx]} {
			catch {unset data(S,$idx)}
			$c itemconfig $idx -fill {}
		    }
		}
	    }
	}
	in* {
	    ## includes
	    if {$err} {
		if {[llength $args]==2} {
		    return -code error $idx
		} else {
		    return -code error "wrong \# args:\
			    should be \"$w selection includes index\""
		}
	    }
	    return [info exists data(S,$idx)]
	}
	se* {
	    ## set
	    if {$err} {
		if {[string compare {} $args]} return
		return -code error "wrong \# args:\
			should be \"$w selection set index ?index ...?\""
	    } else {
		set c $data(basecmd); set col $data(-selectbackground)
		if {[string match all [lindex $args 1]]} {
		    foreach i $idx { set data(S,$i) 1 }
		    $c itemconfig box -fill $col
		} else {
		    set data(S,$idx) 1
		    $c itemconfig $idx -fill $col
		    foreach idx [lrange $args 2 end] {
			if {![catch {_index $w $idx} idx]} {
			    set data(S,$idx) 1
			    $c itemconfig $idx -fill $col
			}
		    }
		}
	    }
	}
	default {
	    return -code error "bad selection option \"[lindex $args 0]\":\
		    must be clear, includes, set"
	}
    }
}

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

    set res {}
    foreach i [array names data S,*] { lappend res [string range $i 2 end] }
    return $res
}

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

    set nps {}
    foreach arg $args {
	if {![catch {_index $w $arg} idx] && \
		[string compare {} $idx]} {
	    set tags [$data(basecmd) gettags $idx]
	    if {[set i [lsearch -glob $tags box:*]]>-1} {
		lappend nps [string range [lindex $tags $i] 4 end]
	    }
	}
    }
    return $nps
}

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

    ## Quick get.  Avoids expensive _index call
    set nps {}
    foreach arg $args {
	set tags [$data(basecmd) itemcget $arg -tags]
	if {[set i [lsearch -glob $tags box:*]]>-1} {
	    lappend nps [string range [lindex $tags $i] 4 end]
	}
    }
    return $nps
}

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

    if {[catch {_index $w $args} idx]} {
	return -code error $idx
    } elseif {[string compare {} $idx]} {
	set c $data(basecmd)
	foreach {x y x1 y1} [$c bbox $idx] {top btm} [$c yview] {
	    set stk [lindex [$c cget -scrollregion] 3]
	    set pos [expr (($y1+$y)/2.0)/$stk - ($btm-$top)/2.0]
	}
	$c yview moveto $pos
    }
}

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

    array set expanded [array get data ":*,showkids"]
    foreach i [concat [array names data :*] \
	    [array names data S,*]] {unset data($i)}
    $data(basecmd) delete all
    ## -dec makes it sort in root-first order
    foreach i [lsort -ascii -decreasing [array names expanded]] {
	if {$expanded($i)} {
	    regexp {^:(.*),showkids$} $i junk np
	    ## Quick way to remove the last element of a list
	    set prnt [lreplace $np end end]
	    ## checks to get rid of dead, previously opened nodes
	    if {[string match {} $prnt] || ([info exists data(:$prnt,kids)] \
		    && [lsearch -exact $data(:$prnt,kids) \
		    [lindex $np end]] != -1)} {
		set data($i) 0
		ExpandNode $w $np
	    }
	}
    }
    Redraw $w $data(-root)
    Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
}

;proc _size {w} {
    upvar \#0 [namespace current]::$w data
    return [llength [$data(basecmd) find withtag box]]
}

## This will be the one called by <Double-Button-1> on the canvas,
## if -state is normal, so we have to make sure that $w is correct.
##
;proc _toggle { w index } {
    toggle $w $index toggle
}

;proc _close { w index } {
    toggle $w $index close
}

;proc _open { w index } {
    toggle $w $index open
}

;proc toggle { w index which } {
    if {[string compare Hierarchy [winfo class $w]]} {
	set w [winfo parent $w]
    }
    upvar \#0 [namespace current]::$w data

    if {[string match {} [set np [_get $w $index]]]} return
    set np [lindex $np 0]

    set old [$data(basecmd) cget -cursor]
    $data(basecmd) config -cursor watch
    update
    switch $which {
	close	{ CollapseNodeAll $w $np }
	open	{ ExpandNodeN $w $np 1 }
	toggle	{
	    if {$data(:$np,showkids)} {
		CollapseNodeAll $w $np
	    } else {
		ExpandNodeN $w $np 1
	    }
	}
    }
    if {[string compare {} $data(-command)]} {
	uplevel \#0 $data(-command) [list $w $np $data(:$np,showkids)]
    }
    $data(basecmd) config -cursor $old
    return
}

;proc Resize { w wid hgt } {
    upvar \#0 [namespace current]::$w data
    set c $data(basecmd)
    if {[string compare {} [set box [$c bbox image text]]]} {
	set X [lindex $box 2]
	set Y [lindex $box 3]
	if {$data(-autoscrollbar)} {
	    ## 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(canvas)
	    set bind [bind $W <Configure>]
	    bind $W <Configure> {}
	    if {$wid>$X} {
		set X $wid
		grid remove $data(xscrollbar)
	    } else {
		grid $data(xscrollbar)
	    }
	    if {$hgt>$Y} {
		set Y $hgt
		grid remove $data(yscrollbar)
	    } else {
		grid $data(yscrollbar)
	    }
	    after 100 [list bind $W <Configure> $bind]
	}
	$c config -scrollregion "0 0 $X $Y"
	## This makes full width highlight boxes
	## data(width) is the default width of boxes
	if {$X>$data(width)} {
	    set data(width) $X
	    foreach b [$c find withtag box] {
		foreach {x y x1 y1} [$c coords $b] { $c coords $b 0 $y $X $y1 }
	    }
	}
    } elseif {$data(-autoscrollbar)} {
	grid remove $data(xscrollbar) $data(yscrollbar)
    }
}

;proc CollapseNodeAll { w np } {
    if {[CollapseNode $w $np]} {
	upvar \#0 [namespace current]::$w data
	Redraw $w $np
	DiscardChildren $w $np
	Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
    }
}

;proc ExpandNodeN { w np n } {
    upvar \#0 [namespace current]::$w data
    if {[ExpandNodeN_aux $w $np $n] || \
	    ([string compare $data(-root) {}] && \
	    ![string compare $data(-root) $np])} {
	Redraw $w $np
	Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
    }
}

;proc ExpandNodeN_aux { w np n } {
    if {![ExpandNode $w $np]} { return 0 }
    if {$n==1} { return 1 }
    incr n -1
    upvar \#0 [namespace current]::$w data
    foreach k $data(:$np,kids) {
	ExpandNodeN_aux $w "$np [list $k]" $n
    }
    return 1
}

########################################################################
##
## Private routines to collapse and expand a single node w/o redrawing
## Most routines return 0/1 to indicate if any change has occurred
##
########################################################################

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

    if {$data(:$np,showkids)} { return 0 }
    set data(:$np,showkids) 1
    if {![info exists data(:$np,kids)]} {
	if {[string compare $data(-browsecmd) {}]} {
	    set data(:$np,kids) [uplevel \#0 $data(-browsecmd) [list $w $np]]
	} else {
	    set data(:$np,kids) {}
	}
    }
    if $data(hasnodelook) {
	set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 1]]
    } else {
	set data(:$np,look) {}
    }
    if {[string match {} $data(:$np,kids)]} {
	## This is needed when there are no kids to make sure the
	## look of the node will be updated appropriately
	foreach {txt font img fg} $data(:$np,look) {
	    lappend tags box:$np box $np
	    set c $data(basecmd)
	    if {[string compare $img {}]} {
		## Catch just in case the image doesn't exist
		catch {
		    $c itemconfigure img:$np -image $img
		    lappend tags $img
		}
	    }
	    if {[string compare $txt {}]} {
		if {[string match {} $font]} { set font $data(-font) }
		if {[string match {} $fg]}   { set fg $data(-foreground) }
		$c itemconfigure txt:$np -fill $fg -text $txt -font $font
		## FIX: use [list txt: $txt] instead of $txt
		## Here and in recompute, otherwise if the name of
		## the text is an existing tag, we get an error
		if {[string compare $np $txt]} { lappend tags $txt }
	    }
	    $c itemconfigure box:$np -tags $tags
	    ## We only want to go through once
	    break
	}
	return 0
    }
    foreach k $data(:$np,kids) {
	set knp "$np [list $k]"
	## Check to make sure it doesn't already exist,
	## in case we are refreshing the node or something
	if {![info exists data(:$knp,showkids)]} { set data(:$knp,showkids) 0 }
	if $data(hasnodelook) {
	    set data(:$knp,look) [uplevel \#0 $data(-nodelook) [list $w $knp 0]]
	} else {
	    set data(:$knp,look) {}
	}
    }
    return 1
}

;proc CollapseNode { w np } {
    upvar \#0 [namespace current]::$w data
    if {!$data(:$np,showkids)} { return 0 }
    set data(:$np,showkids) 0
    if {[string match {} $data(:$np,kids)]} { return 0 }
    if {[string compare $data(-nodelook) {}]} {
	set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 0]]
    } else {
	set data(:$np,look) {}
    }
    foreach k $data(:$np,kids) { CollapseNode $w "$np [list $k]" }
    return 1
}

;proc DiscardChildren { w np } {
    upvar \#0 [namespace current]::$w data
    if {[info exists data(:$np,kids)]} {
	foreach k $data(:$np,kids) {
	    set knp "$np [list $k]"
	    $data(basecmd) delete img:$knp txt:$knp box:$knp
	    foreach i {showkids look stkusg stack iwidth offset} {
		catch {unset data(:$knp,$i)}
	    }
	    DiscardChildren $w $knp
	}
	unset data(:$np,kids)
    }
}

## REDRAW mechanism
## 2 parts:	recompute offsets of all children from changed node path
##		then redraw children based on their offsets and look
##
;proc Redraw { w cnp } {
    upvar \#0 [namespace current]::$w data

    set c $data(basecmd)
    # When a node changes, the positions of a whole lot of things
    # change.  The size of the scroll region also changes.
    $c delete decor

    # Calculate the new offset locations of everything
    Recompute $w $data(-root) [lrange $cnp 1 end]

    # Next recursively move all the bits around to their correct positions.
    # We choose an initial point (4,4) to begin at.
    Redraw_aux $w $data(-root) 4 4

    # Necessary to make sure find closest gets the right item
    # ordering: image > text > box
    after idle "catch { [list $c] raise image text; [list $c] lower box text }"
}

## RECOMPUTE recurses through the tree working out the relative offsets
## of children from their parents in terms of stack values.  
##
## "cnp" is either empty or a node name which indicates where the only
## changes have occured in the hierarchy since the last call to Recompute.
## This is used because when a node is toggled on/off deep in the
## hierarchy then not all the positions of items need to be recomputed.
## The only ones that do are everything below the changed node (of
## course), and also everything which might depend on the stack usage of
## that node (i.e. everything above it).  Specifically the usages of the
## changed node's siblings do *not* need to be recomputed.
##
;proc Recompute { w np cnp } {
    upvar \#0 [namespace current]::$w data
    # If the cnp now has only one element then
    # it must be one of the children of the current node.
    # We do not need to Recompute the usages of its siblings if it is.
    set cnode_is_child [expr {[llength $cnp]==1}]
    if {$cnode_is_child} {
	set cnode [lindex $cnp 0]
    } else {
	set xcnp [lrange $cnp 1 end]
    }
    
    # Run through the children, recursively calculating their usage of
    # stack real-estate, and allocating an intial placement for each child
    #
    # Values do not need to be recomputed for siblings of the changed
    # node and their descendants.  For the cnode itself, in the
    # recursive call we set the value of cnode to {} to prevent
    # any further cnode checks.

    set children_stack 0
    if {$data(:$np,showkids)} { 
	foreach k $data(:$np,kids) {
	    set knp "$np [list $k]"
	    set data(:$knp,offset) $children_stack
	    if {$cnode_is_child && [string match $cnode $k]} {
		set data(:$knp,stkusg) [Recompute $w $knp {}]
	    } elseif {!$cnode_is_child} {
		set data(:$knp,stkusg) [Recompute $w $knp $xcnp]
	    }
	    incr children_stack $data(:$knp,stkusg)
	    incr children_stack $data(-padstack)
	}
    }

    ## Make the image/text if they don't exist.
    ## Positioning occurs in Redraw_aux.
    ## And calculate the stack usage of our little piece of the world.
    set img_height 0; set img_width 0; set txt_width 0; set txt_height 0

    foreach {txt font img fg} $data(:$np,look) {
	lappend tags box:$np box $np
	set c $data(basecmd)
	if {[string compare $img {}]} {
	    if {[string match {} [$c find withtag img:$np]]} {
		$c create image 0 0 -anchor nw -tags [list img:$np image]
	    }
	    ## Catch just in case the image doesn't exist
	    catch {
		$c itemconfigure img:$np -image $img
		lappend tags $img
		foreach {x y img_width img_height} [$c bbox img:$np] {
		    incr img_width -$x; incr img_height -$y
		}
	    }
	}
	if {[string compare $txt {}]} {
	    if {[string match {} [$c find withtag txt:$np]]} {
		$c create text 0 0 -anchor nw -tags [list txt:$np text]
	    }
	    if {[string match {} $font]} { set font $data(-font) }
	    if {[string match {} $fg]}   { set fg $data(-foreground) }
	    $c itemconfigure txt:$np -fill $fg -text $txt -font $font
	    if {[string compare $np $txt]} { lappend tags $txt }
	    foreach {x y txt_width txt_height} [$c bbox txt:$np] {
		incr txt_width -$x; incr txt_height -$y
	    }
	}
	if {[string match {} [$c find withtag box:$np]]} {
	    $c create rect 0 0 1 1 -tags [list box:$np box] -outline {}
	}
	$c itemconfigure box:$np -tags $tags
	## We only want to go through this once
	break
    }

    set stack [expr {$txt_height>$img_height?$txt_height:$img_height}]

    # Now reposition the children downward by "stack"
    set overall_stack [expr {$children_stack+$stack}]

    if {$data(:$np,showkids)} { 
	set off [expr {$stack+$data(-padstack)}]
	foreach k $data(:$np,kids) {
	    set knp "$np [list $k]"
	    incr data(:$knp,offset) $off
	}
    }
    # remember some facts for locating the image and drawing decor
    array set data [list :$np,stack $stack :$np,iwidth $img_width]

    return $overall_stack
}

;proc Redraw_aux {w np deppos stkpos} {
    upvar \#0 [namespace current]::$w data

    set c $data(basecmd)
    $c coords img:$np $deppos $stkpos
    $c coords txt:$np [expr {$deppos+$data(:$np,iwidth)+$data(-ipad)}] $stkpos
    $c coords box:$np 0 [expr {$stkpos-$data(halfpstk)}] \
	    $data(width) [expr {$stkpos+$data(:$np,stack)+$data(halfpstk)}]

    if {!$data(:$np,showkids) || [string match {} $data(:$np,kids)]} return

    set minkid_stkpos 100000
    set maxkid_stkpos 0
    set bar_deppos [expr {$deppos+$data(-paddepth)/2}]
    set kid_deppos [expr {$deppos+$data(-paddepth)}]

    foreach k $data(:$np,kids) {
	set knp "$np [list $k]"
	set kid_stkpos [expr {$stkpos+$data(:$knp,offset)}]
	Redraw_aux $w $knp $kid_deppos $kid_stkpos
	
	if {$data(-decoration)} {
	    if {$kid_stkpos<$minkid_stkpos} {set minkid_stkpos $kid_stkpos}
	    set kid_stkpos [expr {$kid_stkpos+$data(:$knp,stack)/2}]
	    if {$kid_stkpos>$maxkid_stkpos} {set maxkid_stkpos $kid_stkpos}
	    
	    $c create line $bar_deppos $kid_stkpos $kid_deppos $kid_stkpos \
		    -width 1 -tags decor
	}
    }
    if {$data(-decoration)} {
	$c create line $bar_deppos $minkid_stkpos $bar_deppos $maxkid_stkpos \
		-width 1 -tags decor
    }
}


##
## DEFAULT BINDINGS FOR HIERARCHY
##
## Since we give no border to the frame, all Hierarchy bindings
## will always register on the canvas widget
##
bind Hierarchy <Double-Button-1> {
    set w [winfo parent %W]
    if {[string match normal [$w cget -state]]} {
	$w toggle @%x,%y
    }
}
bind Hierarchy <ButtonPress-1> {
    if {[winfo exists %W]} {
	namespace eval ::Widget::Hierarchy \
		[list BeginSelect [winfo parent %W] @%x,%y]
    }
}
bind Hierarchy <B1-Motion> {
    set tkPriv(x) %x
    set tkPriv(y) %y
    namespace eval ::Widget::Hierarchy [list Motion [winfo parent %W] @%x,%y]
}
bind Hierarchy <ButtonRelease-1> { tkCancelRepeat }
bind Hierarchy <Shift-1>   [namespace code \
	{ BeginExtend [winfo parent %W] @%x,%y }]
bind Hierarchy <Control-1> [namespace code \
	{ BeginToggle [winfo parent %W] @%x,%y }]
bind Hierarchy <B1-Leave> {
    set tkPriv(x) %x
    set tkPriv(y) %y
    namespace eval ::Widget::Hierarchy [list AutoScan [winfo parent %W]]
}
bind Hierarchy <B1-Enter>	{ tkCancelRepeat }

## Should reserve L/R U/D for traversing nodes
bind Hierarchy <Up>		{ %W yview scroll -1 units }
bind Hierarchy <Down>		{ %W yview scroll  1 units }
bind Hierarchy <Left>		{ %W xview scroll -1 units }
bind Hierarchy <Right>		{ %W xview scroll  1 units }

bind Hierarchy <Control-Up>	{ %W yview scroll -1 pages }
bind Hierarchy <Control-Down>	{ %W yview scroll  1 pages }
bind Hierarchy <Control-Left>	{ %W xview scroll -1 pages }
bind Hierarchy <Control-Right>	{ %W xview scroll  1 pages }
bind Hierarchy <Prior>		{ %W yview scroll -1 pages }
bind Hierarchy <Next>		{ %W yview scroll  1 pages }
bind Hierarchy <Control-Prior>	{ %W xview scroll -1 pages }
bind Hierarchy <Control-Next>	{ %W xview scroll  1 pages }
bind Hierarchy <Home>		{ %W xview moveto 0 }
bind Hierarchy <End>		{ %W xview moveto 1 }
bind Hierarchy <Control-slash>	[namespace code \
	{ SelectAll [winfo parent %W] }]
bind Hierarchy <Control-backslash> [namespace code \
	{ [winfo parent %W] selection clear }]

bind Hierarchy <2> {
    set tkPriv(x) %x
    set tkPriv(y) %y
    %W scan mark %x %y
}
bind Hierarchy <B2-Motion> {
    %W scan dragto $tkPriv(x) %y
}

## BINDING HELPER PROCEDURES
##
## These are mostly mirrored from the Listbox class bindings.
##
## Some of these are hacked up to be more efficient by making calls
## that require forknowledge of the megawidget structure.
##

# BeginSelect --
#
# This procedure is typically invoked on button-1 presses.  It begins
# the process of making a selection in the hierarchy.  Its exact behavior
# depends on the selection mode currently in effect for the hierarchy;
# see the Motif documentation for details.
#
# Arguments:
# w -		The hierarchy widget.
# el -		The element for the selection operation (typically the
#		one under the pointer).  Must be in numerical form.

;proc BeginSelect {w el} {
    global tkPriv
    if {[catch {_index $w $el} el]} return
    _selection $w clear
    _selection $w set $el
    set tkPriv(hierarchyPrev) $el
}

# Motion --
#
# This procedure is called to process mouse motion events while
# button 1 is down.  It may move or extend the selection, depending
# on the hierarchy's selection mode.
#
# Arguments:
# w -		The hierarchy widget.
# el -		The element under the pointer (must be a number).

;proc Motion {w el} {
    global tkPriv
    if {[catch {_index $w $el} el] || \
	    [string match $el $tkPriv(hierarchyPrev)]} return
    switch [_cget $w -selectmode] {
	browse {
	    _selection $w clear 0 end
	    if {![catch {_selection $w set $el}]} {
		set tkPriv(hierarchyPrev) $el
	    }
	}
	multiple {
	    ## This happens when a double-1 occurs and all the index boxes
	    ## have changed
	    if {[catch {_selection $w includes \
		    $tkPriv(hierarchyPrev)} inc]} {
		set tkPriv(hierarchyPrev) [_index $w $el]
		return
	    }
	    if {$inc} {
		_selection $w set $el
	    } else {
		_selection $w clear $el
	    }
	    set tkPriv(hierarchyPrev) $el
	}
    }
}

# BeginExtend --
#
# This procedure is typically invoked on shift-button-1 presses.  It
# begins the process of extending a selection in the hierarchy.  Its
# exact behavior depends on the selection mode currently in effect
# for the hierarchy;
#
# Arguments:
# w -		The hierarchy widget.
# el -		The element for the selection operation (typically the
#		one under the pointer).  Must be in numerical form.

;proc BeginExtend {w el} {
    if {[catch {_index $w $el} el]} return
    if {[string match multiple [_cget $w -selectmode]]} {
	Motion $w $el
    }
}

# BeginToggle --
#
# This procedure is typically invoked on control-button-1 presses.  It
# begins the process of toggling a selection in the hierarchy.  Its
# exact behavior depends on the selection mode currently in effect
# for the hierarchy;  see the Motif documentation for details.
#
# Arguments:
# w -		The hierarchy widget.
# el -		The element for the selection operation (typically the
#		one under the pointer).  Must be in numerical form.

;proc BeginToggle {w el} {
    global tkPriv
    if {[catch {_index $w $el} el]} return
    if {[string match multiple [_cget $w -selectmode]]} {
	_selection $w anchor $el
	if {[_selection $w includes $el]} {
	    _selection $w clear $el
	} else {
	    _selection $w set $el
	}
	set tkPriv(hierarchyPrev) $el
    }
}

# AutoScan --
# This procedure is invoked when the mouse leaves an entry window
# with button 1 down.  It scrolls the window up, down, left, or
# right, depending on where the mouse left the window, and reschedules
# itself as an "after" command so that the window continues to scroll until
# the mouse moves back into the window or the mouse button is released.
#
# Arguments:
# w -		The hierarchy widget.

;proc AutoScan {w} {
    global tkPriv
    if {![winfo exists $w]} return
    set x $tkPriv(x)
    set y $tkPriv(y)
    if {$y>=[winfo height $w]} {
	$w yview scroll 1 units
    } elseif {$y<0} {
	$w yview scroll -1 units
    } elseif {$x>=[winfo width $w]} {
	$w xview scroll 2 units
    } elseif {$x<0} {
	$w xview scroll -2 units
    } else {
	return
    }
    #Motion $w [$w index @$x,$y]
    set tkPriv(afterId) [after 50 [namespace current]::AutoScan $w]
}

# SelectAll
#
# This procedure is invoked to handle the "select all" operation.
# For single and browse mode, it just selects the root element.
# Otherwise it selects everything in the widget.
#
# Arguments:
# w -		The hierarchy widget.

;proc SelectAll w {
    if {[regexp (browse|single) [_cget $w -selectmode]]} {
	_selection $w clear
	_selection $w set root
    } else {
	_selection $w set all
    }
}

#------------------------------------------------------------
# Default nodelook methods
#------------------------------------------------------------

;proc FileLook { w np isopen } {
    upvar \#0 [namespace current]::$w data
    set path [eval file join $np]
    set file [lindex $np end]
    set bmp  {}
    if {[file readable $path]} {
	if {[file isdirectory $path]} {
	    if {$isopen} {
		## We know that kids will always be set by the time
		## the isopen is set to 1
		if {[string compare $data(:$np,kids) {}]} {
		    set bmp ::Widget::Hierarchy::bmp:dir_minus
		} else {
		    set bmp ::Widget::Hierarchy::bmp:dir
		}
	    } else {
		set bmp ::Widget::Hierarchy::bmp:dir_plus
	    }
	    if 0 {
		## NOTE: accurate, but very expensive
		if {[string compare [FileList $w $np] {}]} {
		    set bmp [expr {$isopen ?\
			    {::Widget::Hierarchy::bmp:dir_minus} :\
			    {::Widget::Hierarchy::bmp:dir_plus}}]
		} else {
		    set bmp ::Widget::Hierarchy::bmp:dir
		}
	    }
	}
	set fg \#000000
    } elseif {[string compare $data(-showparent) {}] && \
	    [string match $data(-showparent) $file]} {
	set fg \#0000FF
	set bmp ::Widget::Hierarchy::bmp:up
    } else {
	set fg \#a9a9a9
	if {[file isdirectory $path]} {set bmp ::Widget::Hierarchy::bmp:dir}
    }
    return [list $file $data(-font) $bmp $fg] 
}

## FileList
# ARGS:	w	hierarchy widget
#	np	node path	
# Returns:	directory listing
##
;proc FileList { w np } {
    set pwd [pwd]
    if {[catch "cd \[file join $np\]"]} {
	set list {}
    } else {
	global tcl_platform
	upvar \#0 [namespace current]::$w data
	set str *
	if {!$data(-showfiles)} { append str / }
	if {$data(-showall) && [string match unix $tcl_platform(platform)]} {
	    ## NOTE: Use of non-core lremove
	    if {[catch {lsort [concat [glob -nocomplain $str] \
		    [lremove [glob -nocomplain .$str] {. ..}]]} list]} {
		return {}
	    }
	} else {
	    ## The extra catch is necessary for unusual error conditions
	    if {[catch {lsort [glob -nocomplain $str]} list]} {
		return {}
	    }
	}
	set root $data(-root)
	if {[string compare {} $data(-showparent)] && \
		[string match $root $np]} {
	    if {![regexp {^(.:)?/+$} $root] && \
		    [string compare [file dir $root] $root]} {
		set list [linsert $list 0 $data(-showparent)]
	    }
	}
    }
    cd $pwd
    return $list
}

;proc FileActivate { w np isopen } {
    upvar \#0 [namespace current]::$w data
    set path [eval file join $np]
    if {[file isdirectory $path]} return
    if {[string compare $data(-showparent) {}] && \
	    [string match $data(-showparent) [lindex $np end]]} {
	$w configure -root [file dir $data(-root)]
    }
}

;proc WidgetLook { W np isopen } {
    upvar \#0 [namespace current]::$W data
    if {$data(-showall)} {
	set w [lindex $np end]
    } else {
	set w [join $np {}]
	regsub {\.\.} $w {.} w
    }
    if {[string compare [winfo children $w] {}]} {set fg blue} {set fg black}
    return [list "\[[winfo class $w]\] [lindex $np end]" {} {} $fg]
}

;proc WidgetList { W np } {
    upvar \#0 [namespace current]::$W data
    if {$data(-showall)} {
	set w [lindex $np end]
    } else {
	set w [join $np {}]
	regsub {\.\.} $w {.} w
    }
    set kids {}
    foreach i [lsort [winfo children $w]] {
	if {$data(-showall)} {
	    lappend kids $i
	} else {
	    lappend kids [file extension $i]
	}
    }
    return $kids
}

;proc WidgetActivate { w np isopen } {}

;proc RegistryLook { W np isopen } {
    upvar \#0 [namespace current]::$W data
    if {$isopen} {
	## We know that kids will always be set by the time
	## the isopen is set to 1
	if {[string compare $data(:$np,kids) {}]} {
	    set bmp ::Widget::Hierarchy::bmp:dir_minus
	} else {
	    set bmp ::Widget::Hierarchy::bmp:dir
	}
    } else {
	set bmp ::Widget::Hierarchy::bmp:dir_plus
    }
    return [list [lindex $np end] {} $bmp {}]
}

;proc RegistryList { W np } {
    upvar \#0 [namespace current]::$W data
    set np [join [lrange $np 1 end] \\]
    #puts [info level 0]:$np
    if {[string match "" $np]} {
	set kids {HKEY_LOCAL_MACHINE HKEY_USERS HKEY_CLASSES_ROOT HKEY_CURRENT_USER HKEY_CURRENT_CONFIG}
    } else {
	set kids [lsort -dictionary [registry keys $np]]
    }
    return $kids
}

;proc RegistryAct { w np isopen } {}

## BITMAPS
##
image create bitmap ::Widget::Hierarchy::bmp:dir -data {#define folder_width 16
#define folder_height 12
static char folder_bits[] = {
  0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
  0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
image create bitmap ::Widget::Hierarchy::bmp:dir_plus -data {#define folder_plus_width 16
  #define folder_plus_height 12
static char folder_plus_bits[] = {
  0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x82, 0x40,
  0x82, 0x40, 0xe2, 0x43, 0x82, 0x40, 0x82, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
image create bitmap ::Widget::Hierarchy::bmp:dir_minus -data {#define folder_minus_width 16
#define folder_minus_height 12
static char folder_minus_bits[] = {
  0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
  0x02, 0x40, 0xe2, 0x43, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
image create bitmap ::Widget::Hierarchy::bmp:up -data {#define up.xbm_width 16
#define up.xbm_height 12
static unsigned char up.xbm_bits[] = {
  0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x7c, 0x00, 0xfe, 0x00, 0x38, 0x00,
  0x38, 0x00, 0x38, 0x00, 0xf8, 0x7f, 0xf0, 0x7f, 0xe0, 0x7f, 0x00, 0x00};}
image create bitmap ::Widget::Hierarchy::bmp:text -data {#define text_width 15
#define text_height 14
static char text_bits[] = {
  0xff,0x07,0x01,0x0c,0x01,0x04,0x01,0x24,0xf9,0x7d,0x01,0x78,0x01,0x40,0xf1,
  0x41,0x01,0x40,0x01,0x40,0xf1,0x41,0x01,0x40,0x01,0x40,0xff,0x7f};}

}; # end namespace ::Widget::Hierarchy

return
Added library/megalist.tcl.








































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
##
## megalist.tcl
##
## Copyright 1997-8 Jeffrey Hobbs
##
package require Widget 2.0
package provide Megalist 1.0

##------------------------------------------------------------------------
## PROCEDURE
##	megalist
##
## ARGUMENTS && DESCRIPTION
##
## megalist  <window pathname> <options>
##        Implements a megalist which displays a sorted and filtered 
## list of lists.
##
## OPTIONS
## 
## -sortby item                                 DEFAULT: none
##      Specifies which item to sort on.
##
## -sort TCL_BOOLEAN                            DEFAULT: 1
##      If true the sort buttons appear and the lists are sorted 
##      by the item specified by -sortby. If false the sort buttons
##      disappear and the lists are not sorted.
##
##
## -showfilters TCL_BOOLEAN                     DEFAULT: 0 
##
## -shownames TCL_BOOLEAN                       DEFAULT: 1 
##
## METHODS
##	These are the methods that the megalist object recognizes.
##	(ie - megalist .m ; .m <method> <args>)
##	Any unique substring is acceptable
##
## load list
##      Each element in the list is displayed as a row in the widget.
##      Each element in the row is assigned to an item starting from the left.
##      If there are less item elements than items blanks are assigned.
##      If there are more item elements than items they are ignored.    
##
## add item ?args?
##      Adds a display for the new item in the list. 
##
## delete item ?item ...?
##      Deletes the item(s) and removes the display(s).
##
## itemconfigure item ?option? ?value option value ...?
##      Query or modify the configuration options of the item.
##
## itemcget item option
##      Returns the current value of the item's configuration option.
##      
## names ?pattern?
##      Returns the item names that match pattern. Defaults to *.
##
## BINDINGS
##
## NAMESPACE & STATE
##	The megawidget creates a global array with the classname, and a
## global array which is the name of each megawidget is created.  The latter
## array is deleted when the megawidget is destroyed.
##	Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used.
## Other procs that begin with $CLASSNAME are private.  For each widget,
## commands named .$widgetname and $CLASSNAME$widgetname are created.
##
##
##------------------------------------------------------------------------
##
##

# Create this to make sure there are registered in auto_mkindex
# these must come before the [widget create ...]
proc Megalist args {}
proc megalist args {}

widget create Megalist -type frame -base frame -components {
    {frame hold hold {-height 200 -width 200 -bg pink}}
    {scrollbar yscrollbar sy {-bd 1 -takefocus 0 -highlightthickness 0 \
	    -orient v -command [namespace code [list lbset $w yview]]}}
} -options {
    {-sortby		sortby		SortBy		{}}
    {-sortcmd		sortcmd		SortCmd	::Widget::Megalist::sort}  
    {-shownames		shownames	ShowNames	1}
    {-showfilters	showfilters	ShowFilters	0}
    {-style		style		Style		listbox}
    {-font		font		Font		fixed}
    {-selectproc	selectProc	SelectProc	{}}
    {-dataproc		dataProc	DataProc	{}}
    {-filtercmd		filtercmd	FilterCmd ::Widget::Megalist::filter}
}

namespace eval ::Widget::Megalist {;

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

    ## Private variables
    array set data [list \
	order	{} \
	lists	{} \
	count	0  \
	height	0  \
	reload	{} \
	data	{} \
	]

    grid $data(hold) $data(yscrollbar) -sticky news
    grid config $data(yscrollbar) -sticky ns
    grid columnconfig $w 0 -weight 1
    grid rowconfig $w 0 -weight 1

}

;proc init w {
}

;proc destruct w {
    upvar \#0 [namespace current]::$w data
    catch {pane forget $data(hold)}
}

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

    set truth {^(1|yes|true|on)$}
    set reload 0
    foreach {key val} $args {
	switch -- $key {
	    -sortby {
		if {[llength $val]>1} {
		    return -code error "multiple sort fields not supported"
		}
		if {![string compare $val $data(-sortby)]} continue
		foreach v $val {
		    if {[lsearch $data(order) $v] == -1} {
			return -code error "unrecognized field \"$name\""
		    }
		}
		if {[info exists set($v)]} {
		    return -code error "field \"$name\" set twice"
		}
		set set($v) 0
		set reload 1
	    }

	    -showfilters {
		set val [regexp -nocase $truth $val]
		if {$data(-showfilters) == $val} continue
		if $data(-showfilters) {
		    foreach name $data(order) {
			pack forget $data(hold).$name.e
		    }
		} else {
		    foreach name $data(order) {
			pack $data(hold).$name.e -fill x \
				-before $data(hold).$name.c
		    } 
		}
	    }
	    -shownames {
		set val [regexp -nocase $truth $val]
		if { $data(-shownames) == $val } {continue}
		if $data(-shownames) {
		    foreach name $data(order) {
			pack forget $data(hold).$name.b
		    }
		} else {
		    set x c
		    if [winfo exists $data(hold).$name.e] {
			set x e
		    }
		    foreach name $data(order) {
			pack $data(hold).$name.b -fill x \
				-before $data(hold).$name.$x
		    } 
		}
	    }
	}
	set data($key) $val
    }
    if {$reload} {_refresh $w}
}

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

    if {[string match {} $data(order)]} {
	return -code error "no fields in megalist"
    }
    set data(data) $args

    catch {$data(err) load $args} result
    _refresh $w

    return $result
}

#refresh or reload?
;proc _refresh {w} {
    upvar \#0 [namespace current]::$w data
    after cancel $data(reload)
    set data(reload) [after idle load $w]
    return
}

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

    if {[string match {} $data(data)]} return
  
    foreach name $data(order) {
	set box $data(hold).$name.c
	$box delete 0 end
	eval $box insert end [$data(err) fldmsg $name]
    }
}

;proc setsort {w b name} {
    upvar \#0 [namespace current]::$w data
    array set config $data(I:$name)
    if {[string compare $name $data(-sortby)]} {
	set data(-sortby) $name
	set config(-order) increasing
    } else {
	if {[string compare increasing $config(-order)]} {
	    set config(-order) increasing
	} else {
	    set config(-order) decreasing
	}
    }
    set data(I:$name) [array get config]
    _refresh $w
}

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

    if {[info exists data(I:$name)]} {
	# Ensure name doesn't already exist
	return -code error "field \"$name\" already exists"
    }
    if {[regexp {(^[\.A-Z]|[ \.])} $name]} {
	return -code error "invalid item name \"$name\": it cannot begin\
		with a capital letter, or contain spaces or \".\""
    }
    if {[llength $args]&1} {
	return -code error "wrong \# of args to add method \"$args\""
    }

    get_opts2 config $args {
	-filtertype	match
	-match		*
	-sort		ascii
    }
    set data(I:$name) [array get config]
    set data(IF:$name) $config(-match)

    lappend data(order) $name

    if {[catch {additem $w} result]} {
	set data(order) [lreplace $data(order) end end] 
	unset data(I:$name) data(IF:$name)
	return -code error $result
    }

    add $w $name

    return $name
}

;proc additem {w args} {
    upvar \#0 [namespace current]::$w data
    
    foreach name $data(order) {
	array set config $data(I:$name)
	set field [list $name -sort $config(-sort)]
	lappend fields $field
	unset config
    }
}

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

    array set config $data(I:$name)
    set f [frame $data(hold).$name]
    button $f.b -text $name -bd 1 -highlightthickness 0 \
	    -takefocus 0 -padx 6 -pady 2 \
	    -command [namespace code [list setsort $w $f.b $name]]
    entry $f.e -textvariable ${w}(IF:$name) -bd 1 \
	    -highlightthickness 0 -takefocus 0 -justify center
    set box [listbox $f.c -highlightthickness 0 -bd 0 -takefocus 0 \
	    -yscrollcommand [namespace code [list scroll $w]] -exportsel 0]
    $f.c xview moveto 0
    if $data(-shownames) { pack $f.b -fill x}
    if $data(-showfilters) {pack $f.e -fill x}
    pack $f.c -fill both -expand 1
    pane $f -parent $data(hold) -handlelook {-bd 1 -width 2}

    bind $f.c <ButtonRelease-1> [namespace code [list select $w $f.c]]
    bind $f.e <Return> [namespace code [list _refresh $w]]

    set $data(IF:$name) $config(-match)
}

;proc select {w p} {
    upvar \#0 [namespace current]::$w data
    if [string match {} [set idx [$p curselection]]] {return}
    foreach i $data(order) {
	$w.hold.$i.c selection clear 0 end
	$w.hold.$i.c selection set $idx
    }
    if {[string compare {} $data(-selectproc)]} {
	foreach i $data(order) {
	    lappend select [$w.hold.$i.c get $idx]
	}
	## No $select here!
	if {[string compare {} $select]} {
	    eval $data(-selectproc) $w $select
	}
    }
}

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

    foreach name $args {
	## Don't complain about unknown items when deleting
	set wid $data(hold).$name
	catch {
	    unset data(I:$name) data(IF:$name)
	    pane forget $data(hold) $wid
	    destroy $wid
	}
	if {[set i [lsearch -exact $data(order) $name]] != -1} {
	    set data(order) [lreplace $data(order) $i $i]
	}
	if {[set i [lsearch -exact $data(-sortby) $name]] != -1} {
	    set data(-sortby) [lreplace $data(-sortby) $i $i]
	}
    }
}

## _itemconfigure
## configure a progressbar constituent item
##
;proc _itemconfigure {w name args} {
    upvar \#0 [namespace current]::$w data

    if {![info exists data(I:$name)]} {
	return -code error "unknown field \"$name\""
    }

    array set config $data(I:$name)
    if {[catch {$data(err) field $name $args} result]} {
	$data(err) field $name [array get config]
	return -code error $result
    } 

    if {[llength $args] > 1} {
	array set config $args
	set data(IF:$name) $config(match)
	set data(I:$name) $args
	_refresh $w
    }
    return $result
}

## _itemcget
## Returns a single item option
##
;proc _itemcget {w name opt} {
    upvar \#0 [namespace current]::$w data

    if {![info exists data(I:$name)]} {
	return -code error "unknown item \"$name\""
    }
    array set config $data(I:$name)
    ## Ensure that we are getting a -'ed value
    if {![info exists config(-[string range $opt 1 end])]} {
	return -code error "unknown option \"$opt\""
    }
    return $config($opt)
}

## _names
## Return a list of item names
##
;proc _names {w {pattern *}} {
    upvar \#0 [namespace current]::$w data

    set names {}
    foreach name $data(order) {
	if {[string match $pattern $name]} {
	    lappend names $name
	}
    }
    return $names
}

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

    foreach name $data(order) {
	eval [list $data(hold).$name.c] $args
    }
}

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

    eval $data(yscrollbar) set $args
    lbset $w yview moveto [lindex $args 0]
}

}; # end namespace ::Widget::Megalist
Added library/pane.tcl.








































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
## Paned Window Procs inspired by code by Stephen Uhler @ Sun.
## Thanks to John Ellson ([email protected]) for bug reports & code ideas.
##
## Copyright 1996-1997 Jeffrey Hobbs, [email protected]
##
package provide Pane 1.0

##------------------------------------------------------------------
## PROCEDURE
##	pane
##
## DESCRIPTION
##	paned window management function
##
## METHODS
##
##  pane configure <widget> ?<widget> ...? ?<option> <value>?
##  pane <widget> ?<widget> ...? ?<option> <value>?
##	Sets up the management of the named widgets as paned windows.
##
##	OPTIONS
##	-dynamic	Whether to dynamically resize or to resize only
##			when the user lets go of the handle
##	-orient		Orientation of window to determing tiling.
##			Can be either horizontal (default) or vertical.
##	-parent		A master widget to use for the slaves.
##			Defaults to the parent of the first widget.
##	-handlelook	Options to pass to the handle during 'frame' creation.
##	-handleplace	Options to pass to the handle during 'place'ment.
##			Make sure you know what you're doing.
##
##  pane forget <master> ?<slave> ...?
##	If called without a slave name, it forgets all slaves and removes
##	all handles, otherwise just removes the named slave(s) and redraws.
##
##  pane info <slave>
##	Returns the value of [place info <slave>].
##
##  pane slaves <master>
##	Returns the slaves currently managed by <master>.
##
##  pane master <slave>
##	Returns the master currently managing <slave>.
##
## BEHAVIORAL NOTES
##	pane is a limited interface to paned window management.  Error
##  catching is minimal.  When you add more widgets to an already managed
##  parent, all the fractions are recalculated.  Handles have the name
##  $parent.__h#, and will be created/destroyed automagically.  You must
##  use 'pane forget $parent' to clean up what 'pane' creates, otherwise
##  critical state info about the parent pane will not be deleted.  This
##  could support -before/after without too much effort if the desire
##  was there.  Because this uses 'place', you have to take the same care
##  to size the parent yourself.
##
## VERSION 1.0
##
## EXAMPLES AT END OF FILE
##

## FIX: should be able to set original ratio

proc pane {opt args} {
    global PANE
    switch -glob -- $opt {
	c* { eval pane_config $args }
	f* {
	    set p [lindex $args 0]
	    if {[info exists PANE($p,w)]} {
		if {[llength $args]==1} {
		    foreach w $PANE($p,w) { catch {place forget $w} }
		    foreach w [array names PANE $p,*] { unset PANE($w) }
		    if {![catch {winfo children $p} kids]} {
			foreach w $kids {
			    if {[string match *.__h* $w]} { destroy $w }
			}
		    }
		} else {
		    foreach w [lrange $args 1 end] {
			place forget $w
			set i [lsearch -exact $PANE($p,w) $w]
			set PANE($p,w) [lreplace $PANE($p,w) $i $i]
		    }
		    if [llength $PANE($p,w)] {
			eval pane_config $PANE($p,w)
		    } else {
			pane forget $p
		    }
		}
	    } else {
		
	    }
	}
	i* { return [place info $args] }
	s* {
	    if {[info exists PANE($args,w)]} {
		return $PANE($args,w)
	    } {
		return {}
	    }
	}
	m* {
	    foreach w [array names PANE *,w] {
		if {[lsearch $PANE($w) $args] != -1} {
		    regexp {([^,]*),w} $w . res
		    return $res
		}
	    }
	    return -code error \
		    "no master found. perhaps $args is not a pane slave?"
	}
	default { eval pane_config [list $opt] $args }
    }
}

##
## PRIVATE FUNCTIONS
##
## I don't advise playing with these because they are slapped together
## and delicate.  I don't recommend calling them directly either.
##

;proc pane_config args {
    global PANE
    array set opt {orn none par {} dyn 0 hpl {} hlk {}}
    set wids {}
    for {set i 0;set num [llength $args];set cargs {}} {$i<$num} {incr i} {
	set arg [lindex $args $i]
	if [winfo exists $arg] { lappend wids $arg; continue }
	set val [lindex $args [incr i]]
	switch -glob -- $arg {
	    -d*	{ set opt(dyn) [regexp -nocase {^(1|yes|true|on)$} $val] }
	    -o*	{ set opt(orn) $val }
	    -p*	{ set opt(par) $val }
	    -handlep*	{ set opt(hpl) $val }
	    -handlel*	{ set opt(hlk) $val }
	    default	{ return -code error "unknown option \"$arg\"" }
	}
    }
    if {[string match {} $wids]} {
	return -code error "no widgets specified to configure"
    }
    if {[string compare {} $opt(par)]} {
	set p $opt(par)
    } else {
	set p [winfo parent [lindex $wids 0]]
    }
    if {[string match none $opt(orn)]} {
	if {![info exists PANE($p,o)]} { set PANE($p,o) h }
    } else {
	set PANE($p,o) $opt(orn)
    }
    if {[string match h* $PANE($p,o)]} {
	set owh height; set wh width; set xy x; set hv h
    } else {
	set owh width; set wh height; set xy y; set hv v
    }
    if ![info exists PANE($p,w)] { set PANE($p,w) {} }
    foreach w [winfo children $p] {
	if {[string match *.__h* $w]} { destroy $w }
    }
    foreach w $wids {
	set i [lsearch -exact $PANE($p,w) $w]
	if {$i<0} { lappend PANE($p,w) $w }
    }
    set ll [llength $PANE($p,w)]
    set frac [expr {1.0/$ll}]
    set pos 0.0
    array set hndconf $opt(hlk)
    if {![info exists hndconf(-$wh)]} {
	set hndconf(-$wh) 4
    }
    foreach w $PANE($p,w) {
	place forget $w
	place $w -in $p -rel$owh 1 -rel$xy $pos -$wh -$hndconf(-$wh) \
		-rel$wh $frac -anchor nw
	raise $w
	set pos [expr {$pos+$frac}]
    }
    place $w -$wh 0
    while {[incr ll -1]} {
	set h [eval frame [list $p.__h$ll] -bd 2 -relief sunken \
		-cursor sb_${hv}_double_arrow [array get hndconf]]
	eval place [list $h] -rel$owh 1 -rel$xy [expr {$frac*$ll}] \
		-$xy -$hndconf(-$wh) -anchor nw $opt(hpl)
	raise $h
	bind $h <ButtonPress-1> "pane_constrain $p $h \
		[lindex $PANE($p,w) [expr {$ll-1}]] [lindex $PANE($p,w) $ll] \
		$wh $xy $opt(dyn)"
    }
}

;proc pane_constrain {p h w0 w1 wh xy d} {
    global PANE
    regexp -- "\-rel$xy (\[^ \]+)" [place info $w0] junk t0
    regexp -- "\-rel$xy (\[^ \]+).*\-rel$wh (\[^ \]+)" \
	    [place info $w1] junk t1 t2
    set offset [expr {($t1+$t2-$t0)/10.0}]
    array set PANE [list XY [winfo root$xy $p] WH [winfo $wh $p].0 \
	    W0 $w0 W1 $w1 XY0 $t0 XY1 [expr {$t1+$t2}] \
	    C0 [expr {$t0+$offset}] C1 [expr {$t1+$t2-$offset}]]
    bind $h <B1-Motion> "pane_motion %[string toup $xy] $p $h $wh $xy $d"
    if !$d {
	bind $h <ButtonRelease-1> \
		"pane_motion %[string toup $xy] $p $h $wh $xy 1"
    }
}

;proc pane_motion {X p h wh xy d} {
    global PANE
    set f [expr {($X-$PANE(XY))/$PANE(WH)}]
    if {$f<$PANE(C0)} { set f $PANE(C0) }
    if {$f>$PANE(C1)} { set f $PANE(C1) }
    if $d {
	place $PANE(W0) -rel$wh [expr {$f-$PANE(XY0)}]
	place $h -rel$xy $f
	place $PANE(W1) -rel$wh [expr {$PANE(XY1)-$f}] -rel$xy $f
    } else {
	place $h -rel$xy $f
    }
}

##
## EXAMPLES
##
## These auto-generate for the plugin.  Remove these for regular use.
##
if {[info exists embed_args]} {
    ## Hey, super-pane the one toplevel we get!
    pane [frame .0] [frame .1]
    ## Use the line below for a good non-plugin example
    #toplevel .0; toplevel .1
    pane [listbox .0.0] [listbox .0.1] -dynamic 1
    pane [frame .1.0] [frame .1.1] -dyn 1
    pane [listbox .1.0.0] [listbox .1.0.1] [listbox .1.0.2] -orient vertical
    pack [label .1.1.0 -text "Text widget:"] -fill x
    pack [text .1.1.1] -fill both -expand 1
    set i [info procs]
    foreach w {.0.0 .0.1 .1.0.0 .1.0.1 .1.0.2 .1.1.1} { eval $w insert end $i }
}
##
## END EXAMPLES
##
## EOF
Added 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
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
# 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
}   }   }]

## Not ready yet
package ifneeded Calculator 1.0 [list tclPkgSetup $dir Calculator 1.0 {
    {calculator.tcl source {
	Calculator
}}}]

package ifneeded Combobox 2.0 [list tclPkgSetup $dir Combobox 2.0 {
    {combobox.tcl source {
	Combobox combobox
}   }   }]

package ifneeded Console 2.0 [list tclPkgSetup $dir Console 2.0 {
    {console.tcl source {
	Console ConsoleDialog console consoledialog
}   }   }]

package ifneeded Hierarchy 2.0 [list tclPkgSetup $dir Hierarchy 2.0 {
    {hierarchy.tcl source {
	Hierarchy hierarchy hierarchy_dir hierarchy_widget
}   }   }]

package ifneeded Megalist 1.0 [list tclPkgSetup $dir Megalist 1.0 {
    {megalist.tcl source {
	megalist
}   }   }]

package ifneeded Pane 1.0 [list tclPkgSetup $dir Pane 1.0 {
    {pane.tcl source {
	pane
}   }   }]

package ifneeded Progressbar 2.0 [list tclPkgSetup $dir Progressbar 2.0 {
    {progressbar.tcl source {
	Progressbar progressbar
}   }   }]

package ifneeded Tabnotebook 2.0 [list tclPkgSetup $dir Tabnotebook 2.0 {
    {tabnotebook.tcl source {
	Tabnotebook tabnotebook
}   }   }]

package ifneeded Ventry 2.0 [list tclPkgSetup $dir Ventry 2.0 {
    {ventry.tcl source {
	Ventry ventry
}   }   }]

package ifneeded Widget 2.0 [list tclPkgSetup $dir Widget 2.0 {
    {widget.tcl source {
	widget scrolledtext ScrolledText
}   }   }]

package ifneeded ::Utility 1.0 [subst {
    source [file join $dir util.tcl]
}]
#	get_opts get_opts2 randrng best_match grep
#	lremove lrandomize lunique luniqueo
#	line_append echo alias which ls dir validate fit_format

package ifneeded ::Utility::dump 1.0 [subst {
    source [file join $dir util-dump.tcl]
}]
#	dump

package ifneeded ::Utility::string 1.0 [subst {
    source [file join $dir util-string.tcl]
}]
#	string_reverse obfuscate untabify tabify wrap_lines

package ifneeded ::Utility::number 1.0 [subst {
    source [file join $dir util-number.tcl]
}]
#	get_square_size roman2dec bin2hex hex2bin

package ifneeded ::Utility::tk 1.0 [subst {
    source [file join $dir util-tk.tcl]
}]
#	warn place_window canvas_center canvas_see

package ifneeded ::Utility::expand 1.0 [subst {
    source [file join $dir util-expand.tcl]
}]
#	expand

package ifneeded ::Utility::tools 1.0 [subst {
    source [file join $dir util-tools.tcl]
}]
#	expand
Added library/progressbar.tcl.














































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
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
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
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
614
615
##
## Copyright 1996-1997 Jeffrey Hobbs, [email protected]
## Some Enhancements done by Steve Ball
##
package require Widget 2.0
package provide Progressbar 2.0

##------------------------------------------------------------------------
## PROCEDURE
##	progressbar
##
## DESCRIPTION
##	Implements a Progressbar mega-widget
##
## ARGUMENTS
##	progressbar <window pathname> <options>
##
## OPTIONS
##	(Any canvas widget option may be used in addition to these)
##
## -indicatorcolor			DEFAULT: #5ae6fe
##	The color of the progressbar.  Must be in #rgb format.
##	This is also the default item start foreground color.
##
## -itembackground			DEFAULT: {}
##	Default item background color.  {} means transparent.
##
## -itemfgfinished			DEFAULT: #00ff00 (green)
##	Default item finished foreground color.  Must be in #rgb format.
##
## -itemtype				DEFAULT: document
##	Default item type (currently 'document' and 'image' are supported).
##
## -labelanchor anchor			DEFAULT: c
##	Anchor for the label.  Reasonable values are c, w and e.
##
## -labeltext string			DEFAULT: {}
##	Text for the label
##
## -labelwidth #			DEFAULT: 0 (self-sizing)
##	Width for the label
##
## -maxvalue #				DEFAULT: 0 (percentage-based)
##	This represents what the representative max value of the progress
##	bar is.  If it is 0, the progress bar interprets the -value option
##	like a percentage (with an implicit 100 value for -maxvalue),
##	otherwise it is representative of what -value would have to reach
##	for the progress to be at 100%.
##
## -orientation horizontal|vertical	DEFAULT: horizontal
##	Orientation of the progressbar
##
## -showvalue TCL_BOOLEAN		DEFAULT: 1
##	Whether or not to show the exact value beside the bar (it is
##	displayed as a percentage of the possible max value).
##
## -showerror TCL_BOOLEAN		DEFAULT: 1
##	Whether to raise an error in the trace on the -variable if the
##	appropriate range is exceeded.
##
## -value #				DEFAULT: 0
##	The value of the progress bar.  This will be used to calculate the
##	overall progress percentage in conjunction with the -maxvalue option.
##
## -variable varname			DEFAULT: {}
##	A variable from which to get the value for the bar.  This variable
##	will have a trace set upon it that forces a postive value.  It cannot
##	be unset until the widget is destroyed or you change this option.
##
## METHODS
##	These are the methods that this megawidget recognizes.  Aside from
##	those listed here, it accepts what is valid for canvas widgets.
##
## create ?item? ?-option value ...?
##	Start displaying the progress of an item.  "item" is the
##	name to associate with the item.  If no name is supplied, a unique
##	name is generated.  If an item of the same name already exists, then
##	a new unique name is generated.  Returns the name of the created item.
##
## delete item
##	Remove the given item from the list of items being displayed.
##	Total progress is updated appropriately.
##
## itemconfigure item ?-option value?
##	Sets option(s) for an item.
##
##	VALID ITEM OPTIONS
##
##	-background color	Background color of icon associated with item.
##	-fgstart #rgb		Initial foreground color of item's icon.
##	-fgfinished #rgb	Final foreground color of item's icon.
##				The progressbar changes the shade of the icon
##				from the initial to the final color in
##				conjunction with the %age of maxvalue.
##	-maxvalue #	max value that represents 100% of possible value
##	-type type	item type (document and image currently supported)
##			This can only be set at creation.
##	-value #	current progress toward full value of maxvalue
##
## itemcget item -option
##	Returns the current value of the option for the given item
##
## names ?pattern?
##	Returns the names of the progressbar's constituent items.
##	An optional pattern can limit the return result.
##
## recalculate
##	Recalculates the value and maxvalue of the progressbar based
##	on the values of the consituent items, if any.  This is only
##	necessary when changing from using the progressbar without items
##	to using it with items.
##
## subwidget widget
##	Returns the true widget path of the specified widget.  Valid
##	widgets are label, canvas.
##
## BINDINGS
##
## NAMESPACE & STATE
##	The megawidget creates a global array with the classname, and a
## global array which is the name of each megawidget is created.  The latter
## array is deleted when the megawidget is destroyed.
##	Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used.
## Other procs that begin with $CLASSNAME are private.  For each widget,
## commands named .$widgetname and $CLASSNAME$widgetname are created.
##
## EXAMPLE USAGE:
##
## pack [progressbar .p -labeltext "Usage:" -variable usage] -fill x -exp 1
## for {set i 0} {$i <= 10} {incr i} { set usage ${i}0; update; after 1000 }
##
##
##------------------------------------------------------------------------

# Create this to make sure there are registered in auto_mkindex
# these must come before the [widget create ...]
proc Progressbar args {}
proc progressbar args {}
widget create Progressbar -type frame -base canvas -components {
    label
    {base canvas canvas {-highlightthickness 0 \
	    -bd 1 -relief ridge -width 100 -height 25}}
} -options {
    {-bd		-borderwidth}
    {-borderwidth	borderWidth	BorderWidth	0}
    {-font		ALIAS label -font}
    {-fg		-foreground}
    {-foreground	ALIAS label -foreground}
    {-indicatorcolor	indicatorColor	Color		#5ae6fe}
    {-indicatorcolour	-indicatorcolor}
    {-itembackground	itemBackground	Background	{}}
    {-itemfgfinished	itemForegroundFinished Foreground #00ff00}
    {-itemtype		itemType	ItemType	document}
    {-labelanchor	labelAnchor	Anchor		c}
    {-labeltext		labelText	Text		{}}
    {-labelwidth	labelWidth	Width		0}
    {-maxvalue		maxValue	Value		0}
    {-orientation	orientation	Orientation	horizontal}
    {-relief		relief		Relief		flat}
    {-showvalue		showValue	ShowValue	1}
    {-showerror		showError	ShowError	1}
    {-value		value		Value		0}
    {-variable		variable	Variable	{}}
}

namespace eval ::Widget::Progressbar {;

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

    ## Private variables
    array set data {
	counter		0
    }
    set data(items) $data(class)${w}ITEMS

    grid $data(label) $data(canvas) -in $w -sticky ns
    grid configure $data(canvas) -sticky news
    grid columnconfig $w 1 -weight 1
    grid rowconfig $w 0 -weight 1
    grid remove $data(label)

    bind $data(canvas) <Configure> [namespace code [list resize $w %w %h]]
}

;proc init {w} {
    upvar \#0 [namespace current]::$w data
    $data(basecmd) create rect -1 0 0 25 -fill $data(-indicatorcolor) \
	    -tags bar -outline {}
    $data(basecmd) create text 25 12 -fill $data(-foreground) \
	    -tags text -anchor c
    $data(basecmd) xview moveto 0
    $data(basecmd) yview moveto 0
}

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

    set truth {^(1|yes|true|on)$}
    set resize 0
    set force  0
    foreach {key val} $args {
	switch -- $key {
	    -borderwidth - -relief { .$w configure $key $val }
	    -font	{
		$data(label) configure -font $val
		$data(basecmd) itemconfigure text -font $val
	    }
	    -foreground		{
		$data(label) configure -foreground $val
		$data(basecmd) itemconfigure text -fill $val
	    }
	    -indicatorcolor	{
		$data(basecmd) itemconfigure bar -fill $val
	    }
	    -labelanchor	{ $data(label) configure -anchor $val }
	    -labeltext		{
		$data(label) configure -text $val
		if {[string compare {} $val]} {
		    grid $data(label)
		} else {
		    grid remove $data(label)
		}
	    }
	    -labelwidth		{ $data(label) configure -width $val }
	    -maxvalue		{
		if {![regexp {^[0-9]+$} $val] || $val<0} {
		    return -code error "$key must be a positive integer"
		}
		set force 1
	    }
	    -orientation	{
		if {[string match h* $val]} {
		    set val horizontal
		} elseif {[string match v* $val]} {
		    set val vertical
		} else {
		    return -code error \
			    "orientation must be horizontal or vertical"
		}
		if {[string compare $data($key) $val]} {
		    set W [$data(basecmd) cget -width]
		    set H [$data(basecmd) cget -height]
		    $data(basecmd) configure -height $W -width $H
		    set resize 1
		}
	    }
	    -showvalue	{
		set val [regexp -nocase $truth $val]
		set resize 1
	    }
	    -showerror	{ set val [regexp -nocase $truth $val] }
	    -value	{
		if {[catch {barset $w $val} err] && \
			$data(-showerror)} {
		    return -code error $err
		}
		if {$resize} { set resize 0 }
		if {$force} { set force 0 }
		continue
	    }
	    -variable	{
		if {![string compare $val $data(-variable)]} return
		if {[string compare {} $data(-variable)]} {
		    uplevel \#0 [list trace vdelete $data(-variable) wu \
			    [namespace code [list bartrace $w]]]
		    set data(-variable) {}
		}
		if {[string compare {} $val]} {
		    set data(-variable) $val
		    upvar \#0 $val var
		    if {![info exists var] || \
			    [catch {barset $w $var} err]} {
			set var $data(-value)
		    }
		    uplevel \#0 [list trace var $val wu \
			    [namespace code [list bartrace $w]]]
		}
		## avoid the set data($key)
		continue
	    }
	}
	set data($key) $val
    }
    if {$force || ($resize && [winfo ismapped $data(canvas)])} {
	resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
    }
}

;proc destruct w {
    upvar \#0 [namespace current]::$w data
    catch {configure $w -variable {}}
}

;proc bartrace {w name el op} {
    upvar \#0 [namespace current]::$w data
    upvar \#0 $data(-variable) var
    if {[string match u $op]} {
	set var $data(-value)
	uplevel \#0 [list trace var $data(-variable) wu \
		[namespace code [list bartrace $w]]]
    } elseif {[catch {barset $w $var} err]} {
	set var $data(-value)
	if $data(-showerror) { return -code error $err }
    }
}

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

    ## Assume a maxvalue of 100 if maxvalue is 0 (works like %age)
    if {$data(-maxvalue)} {
	set pcnt [expr {$data(-value)/double($data(-maxvalue))}]
    } else {
	set pcnt [expr {$data(-value)/100.0}]
    }
    if {[string match h* $data(-orientation)]} {
	$data(basecmd) coords bar -1 0 [expr {$pcnt*$W}] $H
    } else {
	## Vertical orientation needs testing
	## it is upside down
	$data(basecmd) coords bar -1 $H $W [expr {$pcnt*$H}]
    }
    if $data(-showvalue) {
	$data(basecmd) coords text [expr {$W/2}] [expr {$H/2-2}]
	$data(basecmd) itemconfigure text -text \
		[format {%5.1f%%} [expr {$pcnt*100.0}]]
    } else {
	$data(basecmd) coords text $W $H
    }
}

;proc barset {w val} {
    upvar \#0 [namespace current]::$w data
    if {![regexp {^[0-9]+$} $val] || $val<0} {
	return -code error "value must be an integer greater than 0"
    }
    if {[string comp {} $data(-variable)]} {
	upvar \#0 $data(-variable) var
	if {[catch {set var $val} err]} {
	    return -code error $err
	}
    }
    set data(-value) $val
    resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
}

# Manage progress items.  These may be documents or images.
# (There needs to be an extensible system to allow other types, eg. Tclets)
# Each item may have a max value and a current value.
# The total download progress is calculated from the sums of item sizes.

;proc _create {w args} {
    set namesp [namespace current]
    upvar \#0 ${namesp}::$w data

    set cnt [incr data(counter)] 
    if {[string match -* [lindex $args 0]]} {
	# Invent a name
	set item progress$cnt
    } else {
	set item [lindex $args 0]
	set args [lrange $args 1 end]
	if {[info exists data(I:$item)]} {
	    # Ensure name doesn't already exist
	    return -code error "item \"$item\" already exists"
	}
    }

    array set config [list \
	    -background $data(-itembackground) \
	    -fgstart	$data(-indicatorcolor) \
	    -fgfinished	$data(-itemfgfinished) \
	    -maxvalue	100 \
	    -type	$data(-itemtype) \
	    -value	0 \
	    ]
    array set configargs $args
    if {[info exists configargs(-type)]} {
	if {[string match {} \
		[info commands ${namesp}::icon_$configargs(-type)]]} {
	    return -code error "invalid item type $configargs(-type)"
	}
	set config(-type) $configargs(-type)
	unset configargs(-type)
    }
    incr data(-maxvalue) $config(-maxvalue)
    incr data(-value) $config(-value)
    # Add to display
    set config(image) [image create bitmap $w:$item \
	    -data [${namesp}::icon_$config(-type) cget -data] \
	    -foreground $config(-fgstart) \
	    -background $config(-background)]
    set config(w) [label $w.item$cnt -image $config(image)]
    foreach {ncols nrows} [grid size $w] break
    if {[string match h* $data(-orientation)]} {
	grid $config(w) -row 0 -column $ncols
    } else {
	grid $config(w) -row $nrows -column 0
    }

    set data(I:$item) [array get config]

    if {[string compare {} $args]} {
	eval _itemconfigure [list $w] [list $item] [array get configargs]
    } else {
	barset $w $data(-value)
    }

    return $item
}

# Turns #rgb into 3 elem list of decimal vals.
;proc parse_color c {
    set c [string tolower $c]
    if {[regexp {^\#([0-9a-f])([0-9a-f])([0-9a-f])$} $c x r g b]} {
	# appending "0" right-shifts 4 bits
	scan "${r}0 ${g}0 ${b}0" "%x %x %x" r g b
    } else {
	if {![regexp {^\#([0-9a-f]+)$} $c junk hex] || \
		[set len [string length $hex]]>12 || $len%3 != 0} {
	    return -code error "bad color value \"$c\""
	}
	set len [expr {$len/3}]
    	scan $hex "%${len}x%${len}x%${len}x" r g b
    }
    return [list $r $g $b]
}

## Returns a shade between two colors based on the frac (0.0-1.0)
;proc shade {orig dest frac} {
    if {$frac >= 1.0} { return $dest } elseif {$frac <= 0.0} { return $orig }
    foreach {origR origG origB} [parse_color $orig] \
	    {destR destG destB} [parse_color $dest] {
	set shade [format "\#%02x%02x%02x" \
		[expr {int($origR+double($destR-$origR)*$frac)}] \
		[expr {int($origG+double($destG-$origG)*$frac)}] \
		[expr {int($origB+double($destB-$origB)*$frac)}]]
	return $shade
    }
}

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

    foreach item $args {
	## Don't complain about unknown items when deleting
	if {![info exists data(I:$item)]} continue

	array set config $data(I:$item)

	incr data(-value) -$config(-value)
	incr data(-maxvalue) -$config(-maxvalue)
	if {$data(-value) < 0} { set data(-value) 0 }
	if {$data(-maxvalue) < 0} { set data(-maxvalue) 0 }

	destroy $config(w)
	image delete $config(image)
	unset data(I:$item)
    }
    barset $w $data(-value)
}

## _itemconfigure
## configure a progressar constituent item
##
;proc _itemconfigure {w item args} {
    upvar \#0 [namespace current]::$w data

    if {![info exists data(I:$item)]} {
	return -code error "unknown item \"$item\""
    }

    array set config $data(I:$item)
    if {[string match {} $args]} { return [array get config -*] }

    set valChanged 0
    foreach {key val} $args {
	if {[string match {} [set arg [array names config $key]]]} {
	    set arg [array names config ${key}*]
	}
	set num [llength $arg]
	if {$num==0} {
	    return -code error "unknown option \"$key\", must be:\
		    [join [array names config -*] {, }]"
	} elseif {$num>1} {
	    return -code error "ambiguous option \"$args\",\
		    must be one of: [join $arg {, }]"
	} else {
	    set key $arg
	}
	switch -- $key {
	    -maxvalue	{
		if {![regexp {^[0-9]+$} $val] || $val<=0} {
		    return -code error "$key must be an integer greater than 0"
		}
		incr data(-maxvalue) [expr {$val-$config(-maxvalue)}]
		if {$data(-maxvalue) < 0} { set data(-maxvalue) 0 }
		set valChanged 1
	    }
	    -value	{
		if {![regexp {^[0-9]+$} $val] || $val<0} {
		    return -code error "$key must be a postive integer"
		}
		incr data(-value) [expr {$val-$config(-value)}]
		if {$data(-value) < 0} { set data(-value) 0 }
		set valChanged 1
	    }
	    -type	{
		## Should we allow this to be changed?
		return -code error "-type cannot be changed after creation"
	    }
	    -fgstart	{
		if {![regexp {^\#([0-9a-f]+)$} $val]} {
		    return -code error "color value must be in \#rgb format"
		}
	    }
	    -fgfinished	{
		if {![regexp {^\#([0-9a-f]+)$} $val]} {
		    return -code error "color value must be in \#rgb format"
		}
	    }
	}
	set config($key) $val
    }
    set data(I:$item) [array get config]

    if {$config(-maxvalue)} {
	$config(image) configure -background $config(-background) \
		-foreground [shade $config(-fgstart) $config(-fgfinished) \
		[expr {double($config(-value))/$config(-maxvalue)}]]
    }
    if {$valChanged} { barset $w $data(-value) }
}

## _itemcget
## Returns a single item option
##
;proc _itemcget {w item opt} {
    upvar \#0 [namespace current]::$w data

    if {![info exists data(I:$item)]} {
	return -code error "unknown item \"$item\""
    }
    array set config $data(I:$item)
    ## Ensure that we are getting a -'ed value
    if {![info exists config(-[string range $opt 1 end])]} {
	return -code error "unknown option \"$opt\""
    }
    return $config($opt)
}

## _names
## Return a list of item names
##
;proc _names {w {pattern *}} {
    upvar \#0 [namespace current]::$w data

    set items {}
    foreach name [array names data I:$pattern] {
	lappend items [string range $name 2 end]
    }
    return $items
}

## _recalculate
## recalculates the percentage based purely on the constituent items
## If there are no items, it just ensures that -(max)value is >= 0
##
;proc _recalculate {w} {
    upvar \#0 [namespace current]::$w data

    set items [array names data I:*]
    if {[string compare {} $items]} {
	set data(-maxvalue) 0
	set data(-value) 0
	foreach item $items {
	    array set config $data($item)
	    if {$config(-value) < 0} {set config(-value) 0}
	    if {$config(-maxvalue) < 0} {set config(-maxvalue) 0}
	    incr data(-value) $config(-value)
	    incr data(-maxvalue) $config(-maxvalue)
	    set data($item) [array get config]
	}
    } else {
	if {$data(-value) < 0} {set data(-value) 0}
	if {$data(-maxvalue) < 0} {set data(-maxvalue) 0}
    }
    barset $w $data(-value)
    return
}

image create bitmap [namespace current]::icon_document -data {#define document_width 20
#define document_height 23
static char document_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0xfc, 0x1f, 0x00, 0x04, 0x30, 0x00, 0x04, 0x50, 0x00, 0x04, 0x90, 0x00,
   0x04, 0x10, 0x01, 0x04, 0xf0, 0x03, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02,
   0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02,
   0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0x04, 0x00, 0x02,
   0x04, 0x00, 0x02, 0x04, 0x00, 0x02, 0xfc, 0xff, 0x03};
}

image create bitmap [namespace current]::icon_image -data {#define image_width 20
#define image_height 23
static char image_bits[] = {
   0xe0, 0xff, 0xff, 0x20, 0xe0, 0xff, 0xe0, 0xff, 0xff, 0x30, 0xff, 0xff,
   0xe8, 0xf8, 0xff, 0xdf, 0xf7, 0xff, 0xbb, 0xff, 0xff, 0x7b, 0xff, 0xff,
   0xfb, 0xfe, 0xff, 0xfb, 0xfd, 0xff, 0xff, 0xff, 0xff, 0xff, 0x7f, 0xff,
   0xcf, 0x1f, 0xfc, 0x03, 0x0e, 0xf8, 0x20, 0x70, 0xf0, 0x18, 0x80, 0xf1,
   0x07, 0x00, 0xf0, 0x00, 0x1e, 0xf0, 0xf8, 0x01, 0xf0, 0x00, 0x00, 0xf0,
   0xc0, 0x7f, 0xf3, 0x00, 0x80, 0xf0, 0x40, 0x00, 0xf0};
}

}; #end namespace ::Widget::Progressbar
Added library/tabnotebook.tcl.
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
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
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
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
##
## Copyright 1997-8 Jeffrey Hobbs, [email protected], 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

##------------------------------------------------------------------------
## PROCEDURE
##	tabnotebook
##
## DESCRIPTION
##	Implements a Tabbed Notebook megawidget
##
## ARGUMENTS
##	tabnote <window pathname> <options>
##
## OPTIONS
##	(Any entry widget option may be used in addition to these)
##
## -activebackground color		DEFAULT: {}
##	The background color given to the active tab.  A value of {}
##	means these items will pick up the widget's background color.
##
## -background color			DEFAULT: DEFAULT
##	The background color for the container subwidgets.
##
## -browsecmd script			DEFAULT: {}
##	A script that is evaluated each time a tab changes.  It appends
##	the old tab and the new tab to the script.  An empty string ({})
##	represents the blank (empty) tab.  This is eval'ed before the
##	tab actually changes, allowing tab transitions to be aborted by
##	returning an error value in this script.
##
## -disabledbackground color		DEFAULT: #c0c0c0 (dark gray)
##	The background color given to disabled tabs.
##
## -font				DEFAULT: {Helvetica -12}
##	The font for the tab text.  All tabs use the same font.
##
## -justify justification		DEFAULT: center
##	The justification applied to the text in multi-line tabs.
##	Must be one of: left, right, center.
##
## -linewidth pixels			DEFAULT: 2
##	The width of the line surrounding the tabs.  Must be at least 1.
##
## -linecolor color			DEFAULT: black
##	The color of the line surrounding the tabs.
##
## -normalbackground			DEFAULT: {}
##	The background color of items with normal state.  A value of {}
##	means these items will pick up the widget's background color.
##
## -padx pixels				DEFAULT: 8
##	The X padding for folder tabs around the items.
##
## -pady pixels				DEFAULT: 6
##	The Y padding for folder tabs around the items.
##
## RETURNS: the window pathname
##
## BINDINGS (in addition to default widget bindings)
##
## <1> in a tabs activates that tab.
##
## METHODS
##	These are the methods that the Tabnote widget recognizes.  Aside from
##	these, it accepts methods that are valid for entry widgets.
##
## activate id
##	Activates the tab specified by id.  id may either by the unique id
##	returned by the add command or the string used in the add command.
##
## add string ?options?
##	Adds a tab to the tab notebook with the specified string, unless
##	the string is the name of an image, in which case the image is used.
##	Each string must be unique.  See ITEM OPTIONS for the options.
##	A unique tab id is returned.
##
## delete id
##	Deletes the tab specified by id.  id may either by the unique id
##	returned by the add command or the string used in the add command.
##
## itemconfigure ?option? ?value option value ...?
## itemcget option
##	Configure or retrieve the option of a tab notebook item.
##
## name tabId
##	Returns the text name for a given tabId.
##
## subwidget widget
##	Returns the true widget path of the specified widget.  Valid
##	widgets are hold (a frame), tabs (a canvas), blank (a frame).
##
## ITEM OPTIONS
##	These are options for the items (tabs) of the notebook
##
## -window widget				DEFAULT: {}
##	Specifies the widget to show when the tab is pressed.  It must be
##	a child of the tab notebook (required for grid management) and exist
##	prior to this command.
##
## -state normal|disabled|active		DEFAULT: normal
##	The optional state can be normal, active or disabled.
##	If active, then this tab becomes the active (displayed) tab.
##
## NAMESPACE & STATE
##	The megawidget creates a global array with the classname, and a
## global array which is the name of each megawidget is created.  The latter
## array is deleted when the megawidget is destroyed.
##	Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used.
## Other procs that begin with $CLASSNAME are private.  For each widget,
## commands named .$widgetname and $CLASSNAME$widgetname are created.
##
## EXAMPLE USAGE:
##
## pack [tabnotebook .t] -fill both -expand 1
## text .t.t -height 10 -width 20
## .t add "Text Widget" -window .t.t
##------------------------------------------------------------------------

# Create this to make sure there are registered in auto_mkindex
# these must come before the [widget create ...]
proc Tabnotebook args {}
proc tabnotebook args {}

widget create Tabnotebook -type frame -base frame -components {
    {frame hold hold {-relief raised -bd 1}}
    {frame blank}
    {frame hide hide {-background $data(-background) -height 1 -width 40}}
    {canvas tabs tabs {-bg $data(-background) -highlightthick 0 -takefocus 0}}
} -options {
    {-activebackground	activeBackground ActiveBackground {}}
    {-bg		-background}
    {-background	ALIAS frame -background}
    {-bd		-borderwidth}
    {-borderwidth	ALIAS frame -borderwidth}
    {-browsecmd		browseCmd	BrowseCommand	{}}
    {-disabledbackground	disabledBackground DisabledBackground #a3a3a3}
    {-normalbackground	normalBackground normalBackground #c3c3c3}
    {-font		font		Font		{Helvetica -12}}
    {-justify		justify		Justify		center}
    {-minwidth		minWidth	Width		-1}
    {-minheight		minHeight	Height		-1}
    {-padx		padX		PadX		8}
    {-pady		padY		PadY		6}
    {-relief		ALIAS frame -relief}
    {-linewidth		lineWidth	LineWidth	2}
    {-linecolor		lineColor	LineColor	black}
}

namespace eval ::Widget::Tabnotebook {;

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

    ## Private variables
    array set data {
	curtab	{}
	numtabs	0
	width	0
	height	0
	ids	{}
    }

    $data(tabs) itemconfigure TEXT -font $data(-font)

    $data(tabs) yview moveto 0
    $data(tabs) xview moveto 0

    grid $data(tabs) -sticky ew
    grid $data(hold) -sticky news
    grid $data(blank) -in $data(hold) -row 0 -column 0 -sticky nsew
    grid columnconfig $w 0 -weight 1
    grid rowconfigure $w 1 -weight 1
    grid columnconfig $data(hold) 0 -weight 1
    grid rowconfigure $data(hold) 0 -weight 1

    bind $data(tabs) <Configure> [namespace code \
	    "if {!\[string compare $data(tabs) %W\]} { resize [list $w] %w }"]
    bind $data(tabs) <2>		{ %W scan mark %x 0 }
    bind $data(tabs) <B2-Motion>	[namespace code {
	%W scan dragto %x 0
	resize [winfo parent %W] [winfo width %W]
    }
    ]
}

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

    set truth {^(1|yes|true|on)$}
    set post {}
    foreach {key val} $args {
	switch -- $key {
	    -activebackground {
		if {[string compare $data(curtab) {}]} {
		    $data(tabs) itemconfig POLY:$data(curtab) -fill $val
		}
		if {[string compare $val {}]} {
		    $data(hide) config -bg $val
		} else {
		    lappend post \
			    [list $data(hide) config -bg $data(-background)]
		}
	    }
	    -background	{
		$data(tabs) config -bg $val
		$data(hold) config -bg $val
		$data(blank) config -bg $val
	    }
	    -borderwidth {
		$data(hold) config -bd $val
		$data(hide) config -height $val
	    }
	    -disabledbackground {
		foreach i $data(ids) {
		    if {[string match disabled $data(:$i:-state)]} {
			$data(tabs) itemconfig POLY:$i -fill $val
		    }
		}
	    }
	    -font	{
		$data(tabs) itemconfigure TEXT -font $val
		recalculate $w
	    }
	    -justify	{ $data(tabs) itemconfigure TEXT -justify $val }
	    -linewidth	{ $data(tabs) itemconfigure LINE -width $val }
	    -linecolor	{ $data(tabs) itemconfigure LINE -fill $val }
	    -minwidth	{
		if {$val < 0} { set val 0 }
		grid columnconfig $w 0 -minsize $val
	    }
	    -minheight	{
		if {$val < 0} { set val 0 }
		grid rowconfigure $w 1 -minsize $val
	    }
	    -normalbackground {
		foreach i $data(ids) {
		    if {[string match normal $data(:$i:-state)]} {
			$data(tabs) itemconfig POLY:$i -fill $val
		    }
		}
	    }
	    -padx - -pady {
		if {$val < 1} { set val 1 }
	    }
	    -relief	{
		$data(hold) config -relief $val
	    }
	}
	set data($key) $val
    }
    if {[string compare $post {}]} {
	eval [join $post \n]
    }
}

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

    set c $data(tabs)
    if {[string match {} $text]} {
	return -code error "non-empty text required for noteboook label"
    } elseif {[string compare {} [$c find withtag ID:$text]]} {
	return -code error "tab \"$text\" already exists"
    }
    array set s {
	-window	{}
	-state	normal
    }
    foreach {key val} $args {
	switch -glob -- $key {
	    -w*	{
		if {[string compare $val {}]} {
		    if {![winfo exist $val]} {
			return -code error "window \"$val\" does not exist"
		    } elseif {[string comp $w [winfo parent $val]] && \
			    [string comp $data(hold) [winfo parent $val]]} {
			return -code error "window \"$val\" must be a\
				child of the tab notebook ($w)"
		    }
		}
		set s(-window) $val
	    }
	    -s* {
		if {![regexp {^(normal|disabled|active)$} $val]} {
		    return -code error "unknown state \"$val\", must be:\
			    normal, disabled or active"
		}
		set s(-state) $val
	    }
	    default {
		return -code error "unknown option '$key', must be:\
			[join [array names s] {, }]"
	    }
	}
    }
    set tab [incr data(numtabs)]
    set px [expr {int(ceil($data(-padx)/2))}]
    set py [expr {int(ceil($data(-pady)/2))}]
    if {[lsearch -exact [image names] $text] != -1} {
	set i [$c create image $px $py -image $text -anchor nw \
		-tags [list IMG M:$tab ID:$text TAB:$tab]]
    } else {
	set i [$c create text [expr {$px+1}] $py -text $text -anchor nw \
		-tags [list TEXT M:$tab ID:$text TAB:$tab] \
		-justify $data(-justify) -font $data(-font)]
    }
    foreach {x1 y1 x2 y2} [$c bbox $i] {
	set W  [expr {$x2-$x1+$px}]
	set FW [expr {$W+$px}]
	set FH [expr {$y2-$y1+3*$py}]
    }
    set diff [expr {$FH-$data(height)}]
    if {$diff > 0} {
	$c move all 0 $diff
	$c move $i 0 -$diff
	set data(height) $FH
    }
    $c create poly 0 $FH $px $py $W $py $FW $FH -fill {} \
	    -tags [list POLY POLY:$tab TAB:$tab]
    $c create line 0 $FH $px $py $W $py $FW $FH -joinstyle round \
	    -tags [list LINE LINE:$tab TAB:$tab] \
	    -width $data(-linewidth) -fill $data(-linecolor)
    $c move TAB:$tab $data(width) [expr {($diff<0)?-$diff:0}]
    $c raise $i
    $c raise LINE:$tab
    incr data(width) $FW
    $c configure -width $data(width) -height $data(height) \
	    -scrollregion "0 0 $data(width) $data(height)"
    $c bind TAB:$tab <1> [namespace code [list _activate $w $tab]]
    array set data [list :$tab:-window $s(-window) :$tab:-state $s(-state)]
    if {[string compare $s(-window) {}]} {
	grid $s(-window) -in $data(hold) -row 0 -column 0 -sticky nsew
	lower $s(-window)
    }
    switch $s(-state) {
	active	{_activate $w $tab}
	disabled {$c itemconfig POLY:$tab -fill $data(-disabledbackground)}
	normal	{$c itemconfig POLY:$tab -fill $data(-normalbackground)}
    }
    lappend data(ids) $tab
    return $tab
}

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

    if {[string compare $id {}]} {
	set tab [verify $w $id]
	if {[string match disabled $data(:$tab:-state)]} return
    } else {
	set tab {}
    }
    if {[string compare $data(-browsecmd) {}] && \
	    [catch {uplevel \#0 $data(-browsecmd) \
	    [list [_name $w $data(curtab)] [_name $w $tab]]}]} {
	return
    }
    if {[string match $data(curtab) $tab]} return
    set c $data(tabs)
    set oldtab $data(curtab)
    if {[string compare $oldtab {}]} {
	$c itemconfig POLY:$oldtab -fill $data(-normalbackground)
	$c move TAB:$oldtab 0 2
	set data(:$oldtab:-state) normal
    }
    set data(curtab) $tab
    if {[string compare $tab {}]} {
	set data(:$tab:-state) active
	$c itemconfig POLY:$tab -fill $data(-activebackground)
	$c move TAB:$tab 0 -2
    }
    if {[info exists data(:$tab:-window)] && \
	    [winfo exists $data(:$tab:-window)]} {
	raise $data(:$tab:-window)
    } else {
	raise $data(blank)
    }
    resize $w [winfo width $w]
}

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

    set tab [verify $w $id]
    set c $data(tabs)
    foreach {x1 y1 x2 y2} [$c bbox TAB:$tab] { set W [expr {$x2-$x1-3}] }
    $c delete TAB:$tab
    for { set i [expr {$tab+1}] } { $i <= $data(numtabs) } { incr i } {
	$c move TAB:$i -$W 0
    }
    foreach {x1 y1 x2 y2} [$c bbox all] { set H [expr {$y2-$y1-3}] }
    if {$H<$data(height)} {
	$c move all 0 [expr {$H-$data(height)}]
	set data(height) $H
    }
    incr data(width) -$W
    $c config -width $data(width) -height $data(height) \
	    -scrollregion "0 0 $data(width) $data(height)"
    set i [lsearch $data(ids) $tab]
    set data(ids) [lreplace $data(ids) $i $i]
    catch {grid forget $data(:$tab:-window)}
    unset data(:$tab:-state) data(:$tab:-window)
    if {[string match $tab $data(curtab)]} {
	set data(curtab) {}
	raise $data(blank)
    }
}

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

    set tab [verify $w $id]
    set opt [array names data :$tab:$key*]
    set len [llength $opt]
    if {$len == 1} {
	return $data($opt)
    } elseif {$len == 0} {
	set all [array names data :$tab:-*]
	foreach o $all { lappend opts [lindex [split $o :] end] }
	return -code error "unknown option \"$key\", must be one of:\
		[join $opts {, }]"
    } else {
	foreach o $opt { lappend opts [lindex [split $o :] end] }
	return -code error "ambiguous option \"$key\", must be one of:\
		[join $opts {, }]"
    }
}

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

    set tab [verify $w $id]
    set len [llength $args]
    if {$len == 1} {
	return [uplevel 1 _itemcget $w $tab $args]
    } elseif {$len&1} {
	return -code error "uneven set of key/value pairs in \"$args\""
    }
    if {[string match {} $args]} {
	set all [array names data :$tab:-*]
	foreach o $all { lappend res [lindex [split $o :] end] $data($o) }
	return $res
    }
    foreach {key val} $args {
	switch -glob -- $key {
	    -w*	{
		if {[string comp $val {}]} {
		    if {![winfo exist $val]} {
			return -code error "window \"$val\" does not exist"
		    } elseif {[string comp $w [winfo parent $val]] && \
			    [string comp $data(hold) [winfo parent $val]]} {
			return -code error "window \"$val\" must be a\
				child of the tab notebook ($w)"
		    }
		}
		set old $data(:$tab:-window)
		if {[winfo exists $old]} { grid forget $old }
		set data(:$tab:-window) $val
		if {[string comp $val {}]} {
		    grid $val -in $data(hold) -row 0 -column 0 \
			    -sticky nsew
		    lower $val
		}
		if {[string match active $data(:$tab:-state)]} {
		    if {[string comp $val {}]} {
			raise $val
		    } else {
			raise $data(blank)
		    }
		}
	    }
	    -s* {
		if {![regexp {^(normal|disabled|active)$} $val]} {
		    return -code error "unknown state \"$val\", must be:\
			    normal, disabled or active"
		}
		if {[string match $val $data(:$tab:-state)]} return
		set old $data(:$tab:-state)
		switch $val {
		    active		{
			set data(:$tab:-state) $val
			_activate $w $tab
		    }
		    disabled	{
			if {[string match active $old]} { _activate $w {} }
			$data(tabs) itemconfig POLY:$tab \
				-fill $data(-disabledbackground)
			set data(:$tab:-state) $val
		    }
		    normal		{
			if {[string match active $old]} { _activate $w {} }
			$data(tabs) itemconfig POLY:$tab -fill {}
			set data(:$tab:-state) $val
		    }
		}
	    }
	    default {
		return -code error "unknown option '$key', must be:\
			[join [array names s] {, }]"
	    }
	}
    }
}

## given a tab number, return the text
;proc _name { w id } {
    upvar \#0 [namespace current]::$w data

    if {[string match {} $id]} return
    set text {}
    foreach item [$data(tabs) find withtag TAB:$id] {
	set tags [$data(tabs) gettags $item]
	if {[set i [lsearch -glob $tags {ID:*}]] != -1} {
	    set text [string range [lindex $tags $i] 3 end]
	    break
	}
    }
    return $text
}

#;proc _order {w args} {
#    upvar \#0 [namespace current]::$w data
#
#    foreach i $data(ids) {
#    }
#}

## Take all the tabs and reculate space requirements
;proc recalculate {w} {
    upvar \#0 [namespace current]::$w data

    set c $data(tabs)
    set px [expr {int(ceil($data(-padx)/2))}]
    set py [expr {int(ceil($data(-pady)/2))}]
    set data(width) 0
    set data(height) 0
    foreach i $data(ids) {
	$c coords M:$i [expr \
		{[string match text [$c type M:$i]]?$px+1:$px}] $py
	foreach {x1 y1 x2 y2} [$c bbox M:$i] {
	    set W  [expr {$x2-$x1+$px}]
	    set FW [expr {$W+$px}]
	    set FH [expr {$y2-$y1+3*$py}]
	}
	set diff [expr {$FH-$data(height)}]
	if {$diff > 0} {
	    $c move all 0 $diff
	    $c move M:$i 0 -$diff
	    set data(height) $FH
	}
	$c coords POLY:$i 0 $FH $px $py $W $py $FW $FH
	$c coords LINE:$i 0 $FH $px $py $W $py $FW $FH
	$c move TAB:$i $data(width) [expr {($diff<0)?-$diff:0}]
	incr data(width) $FW
    }
    $c configure -width $data(width) -height $data(height) \
	    -scrollregion "0 0 $data(width) $data(height)"
}

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

    if {[string compare $data(curtab) {}]} {
	set x [expr {round(-[$data(tabs) canvasx 0])}]
	foreach {x1 y1 x2 y2} [$data(tabs) bbox TAB:$data(curtab)] {
	    place $data(hide) -y [winfo y $data(hold)] -x [expr {$x1+$x+3}]
	    $data(hide) config -width [expr {$x2-$x1-5}]
	}
    } else {
	place forget $data(hide)
    }
}

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

    set c $data(tabs)
    set box [$c bbox $id]
    if {[string match {} $box]} return
    foreach {x y x1 y1} $box {left right} [$c xview] \
	    {p q xmax ymax} [$c cget -scrollregion] {
	set xpos [expr {(($x1+$x)/2.0)/$xmax - ($right-$left)/2.0}]
    }
    $c xview moveto $xpos
}

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

    set c $data(tabs)
    if {[string compare [set i [$c find withtag ID:$id]] {}]} {
	if {[regexp {TAB:([0-9]+)} [$c gettags [lindex $i 0]] junk id]} {
	    return $id
	}
    } elseif {[string compare [$c find withtag TAB:$id] {}]} {
	return $id
    }
    return -code error "unrecognized tab \"$id\""
}

}; #end of namespace ::Widget::Tabnotebook
Added library/util-color.tcl.


































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
192
193
# util-color.tcl --
#
#	This file implements package ::Utility::color, which  ...
#
# Copyright (c) 1998 Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#

#package require NAME VERSION
package require Tk
package provide ::Utility::color 1.0; # SET VERSION

namespace eval ::Utility::color {;

namespace export -clear *

# rgb2dec --
#
#   Turns #rgb into 3 elem list of decimal vals.
#
# Arguments:
#   c		The #rgb hex of the color to translate
# Results:
#   Returns a #RRGGBB or #RRRRGGGGBBBB color
#
proc rgb2dec c {
    set c [string tolower $c]
    if {[regexp {^\#([0-9a-f])([0-9a-f])([0-9a-f])$} $c x r g b]} {
	# double'ing the value make #9fc == #99ffcc
	scan "$r$r $g$g $b$b" "%x %x %x" r g b
    } else {
	if {![regexp {^\#([0-9a-f]+)$} $c junk hex] || \
		[set len [string length $hex]]>12 || $len%3 != 0} {
	    return -code error "bad color value \"$c\""
	}
	set len [expr {$len/3}]
    	scan $hex "%${len}x%${len}x%${len}x" r g b
    }
    return [list $r $g $b]
}

# dec2rgb --
#
#   Takes a color name or dec triplet and returns a #RRGGBB color.
#   If any of the incoming values are greater than 255,
#   then 16 bit value are assumed, and #RRRRGGGGBBBB is
#   returned, unless $clip is set.
#
# Arguments:
#   r		red dec value, or list of {r g b} dec value or color name
#   g		green dec value, or the clip value, if $r is a list
#   b		blue dec value
#   clip	Whether to force clipping to 2 char hex
# Results:
#   Returns a #RRGGBB or #RRRRGGGGBBBB color
#
proc dec2rgb {r {g 0} {b UNSET} {clip 0}} {
    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
	    set len 4
	}
    }
    return [format "#%.${len}X%.${len}X%.${len}X" \
	    [expr {($r>$max)?$max:(($r<0)?0:$r)}] \
	    [expr {($g>$max)?$max:(($g<0)?0:$g)}] \
	    [expr {($b>$max)?$max:(($b<0)?0:$b)}]]
}

# shade --
#
#   Returns a shade between two colors
#
# Arguments:
#   orig	start #rgb color
#   dest	#rgb color to shade towards
#   frac	fraction (0.0-1.0) to move $orig towards $dest
# Results:
#   Returns a shade between two colors based on the
# 
proc shade {orig dest frac} {
    if {$frac >= 1.0} { return $dest } elseif {$frac <= 0.0} { return $orig }
    foreach {origR origG origB} [rgb2dec $orig] \
	    {destR destG destB} [rgb2dec $dest] {
	set shade [format "\#%02x%02x%02x" \
		[expr {int($origR+double($destR-$origR)*$frac)}] \
		[expr {int($origG+double($destG-$origG)*$frac)}] \
		[expr {int($origB+double($destB-$origB)*$frac)}]]
	return $shade
    }
}

# complement --
#
#   Returns a complementary color
#   Does some magic to avoid bad complements of grays
#
# Arguments:
#   orig	start #rgb color
# Results:
#   Returns a complement of a color
# 
proc complement {orig {grays 1}} {
    foreach {r g b} [rgb2dec $orig] {break}
    set R [expr {(~$r)%256}]
    set G [expr {(~$g)%256}]
    set B [expr {(~$b)%256}]
    if {$grays && abs($R-$r) < 32 && abs($G-$g) < 32 && abs($B-$b) < 32} {
	set R [expr {($r+128)%256}]
	set G [expr {($g+128)%256}]
	set B [expr {($b+128)%256}]
    }
    return [format "\#%02x%02x%02x" $R $G $B]
}

# hsv2rgb --
#
#   Convert hsv to rgb
#
# Arguments:
#   h		hue
#   s		saturation
#   v		value
# Results:
#   Returns an rgb triple from hsv
# 
proc hsv2rgb {h s v} {
    if {$s <= 0.0} {
	# achromatic
	set v [expr int($v)]
	return "$v $v $v"
    } else {
	set v [expr double($v)]
        if {$h >= 1.0} { set h 0.0 }
        set h [expr 6.0 * $h]
        set f [expr double($h) - int($h)]
        set p [expr int(256 * $v * (1.0 - $s))]
        set q [expr int(256 * $v * (1.0 - ($s * $f)))]
        set t [expr int(256 * $v * (1.0 - ($s * (1.0 - $f))))]
	set v [expr int(256 * $v)]
        switch [expr int($h)] {
            0 { return "$v $t $p" }
            1 { return "$q $v $p" }
	    2 { return "$p $v $t" }
	    3 { return "$p $q $v" }
	    4 { return "$t $p $v" }
	    5 { return "$v $p $q" }
        }
    }
}

proc hls2rgb {h l s} {
    # Posted by [email protected]
    # h, l and s are floats between 0.0 and 1.0, ditto for r, g and b
    # h = 0   => red
    # h = 1/3 => green
    # h = 2/3 => blue

    set h6 [expr {($h-floor($h))*6}]
    set r [expr {  $h6 <= 3 ? 2-$h6
                            : $h6-4}]
    set g [expr {  $h6 <= 2 ? $h6
                            : $h6 <= 5 ? 4-$h6
                            : $h6-6}]
    set b [expr {  $h6 <= 1 ? -$h6
                            : $h6 <= 4 ? $h6-2
                            : 6-$h6}]
    set r [expr {$r < 0.0 ? 0.0 : $r > 1.0 ? 1.0 : double($r)}]
    set g [expr {$g < 0.0 ? 0.0 : $g > 1.0 ? 1.0 : double($g)}]
    set b [expr {$b < 0.0 ? 0.0 : $b > 1.0 ? 1.0 : double($b)}]

    set r [expr {(($r-1)*$s+1)*$l}]
    set g [expr {(($g-1)*$s+1)*$l}]
    set b [expr {(($b-1)*$s+1)*$l}]
    return [list $r $g $b]
}

}; # end of namespace ::Utility::color
Added library/util-dump.tcl.




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
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
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
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
614
615
616
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
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
# util-dump.tcl --
#
#	This file implements package ::Utility::dump, which  ...
#
# Copyright (c) 1997-8 Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require ::Utility
package provide ::Utility::dump 1.0

namespace eval ::Utility::dump {;

namespace export -clear dump*
namespace import -force ::Utility::get_opts*

# dump --
#   outputs recognized item info in source'able form.
#   Accepts glob style pattern matching for the names
# Arguments:
#   type	type of item to dump
#   -nocomplain	
#   -filter	pattern
#		specifies a glob filter pattern to be used by the variable
#		method as an array filter pattern (it filters down for
#		nested elements) and in the widget method as a config
#		option filter pattern
#   -procs	
#   -vars	
#   -recursive	
#   -imports	
#   --		forcibly ends options recognition
# Results:
#	the values of the requested items in a 'source'able form
;proc dump {type args} {
    if {![llength $args]} {
	## If no args, assume they gave us something to dump and
	## we'll try anything
	set args [list $type]
	set type multi
    }
    ## Args are handled individually by the routines because of the
    ## variable parameters for each type
    set prefix [namespace current]::dump_
    if {[string match {} [set arg [info commands $prefix$type]]]} {
	set arg [info commands $prefix$type*]
    }
    set result {}
    set code ok
    switch [llength $arg] {
	1 { set code [catch {uplevel $arg $args} result] }
	0 {
	    set arg [info commands $prefix*]
	    regsub -all $prefix $arg {} arg
	    return -code error "unknown [lindex [info level 0] 0] type\
		    \"$type\", must be one of: [join [lsort $arg] {, }]"
	}
	default {
	    regsub -all $prefix $arg {} arg
	    return -code error "ambiguous type \"$type\",\
		    could be one of: [join [lsort $arg] {, }]"
	}
    }
    return -code $code $result
}

# dump_multi --
#
#   Tries to work the args into one of the main dump types:
#   variable, command, widget, namespace
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
proc dump_multi {args} {
    array set opts {
	-nocomplain 0
    }
    set namesp [namespace current]
    set args [get_opts opts $args {-nocomplain 0} {} 1]
    set code ok
    if {
	[catch {uplevel ${namesp}::dump var $args} err] &&
	[catch {uplevel ${namesp}::dump com $args} err] &&
	[catch {uplevel ${namesp}::dump wid $args} err] &&
	[catch {uplevel ${namesp}::dump nam $args} err]
    } {
	set result "# unable to resolve type for \"$args\"\n"
	if {!$opts(-nocomplain)} {
	    set code error
	}
    } else {
	set result $err
    }
    return -code $code [string trimright $result \n]
}

# dump_command --
#
# outputs commands by figuring out, as well as possible,
# it does not attempt to auto-load anything
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
proc dump_command {args} {
    array set opts {
	-nocomplain 0 -origin 0
    }
    set args [get_opts opts $args {-nocomplain 0 -origin 0}]
    if {[string match {} $args]} {
	if {$opts(-nocomplain)} {
	    return
	} else {
	    return -code error "wrong \# args: dump command ?-nocomplain?"
	}
    }
    set code ok
    set result {}
    set namesp [namespace current]
    foreach arg $args {
	if {[string compare {} [set cmds \
		[uplevel info command [list $arg]]]]} {
	    foreach cmd [lsort $cmds] {
		if {[lsearch -exact [interp aliases] $cmd] > -1} {
		    append result "\#\# ALIAS:   $cmd =>\
			    [interp alias {} $cmd]\n"
		} elseif {![catch {uplevel ${namesp}::dump_proc \
			[expr {$opts(-origin)?{-origin}:{}}] \
			-- [list $cmd]} msg]} {
		    append result $msg\n
		} else {
		    if {$opts(-origin) || [string compare $namesp \
			    [uplevel namespace current]]} {
			set cmd [uplevel namespace origin [list $cmd]]
		    }
		    append result "\#\# COMMAND: $cmd\n"
		}
	    }
	} elseif {!$opts(-nocomplain)} {
	    append result "\#\# No known command $arg\n"
	    set code error
	}
    }
    return -code $code [string trimright $result \n]
}

# dump_proc --
#
#   ADD COMMENTS HERE
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
proc dump_proc {args} {
    array set opts {
	-nocomplain 0 -origin 0
    }
    set args [get_opts opts $args {-nocomplain 0 -origin 0}]
    if {[string match {} $args]} {
	if {$opts(-nocomplain)} {
	    return
	} else {
	    return -code error "wrong \# args: dump proc ?-nocomplain?"
	}
    }
    set code ok
    set result {}
    foreach arg $args {
	set procs [uplevel info command [list $arg]]
	set count 0
	if {[string compare $procs {}]} {
	    foreach p [lsort $procs] {
		set cmd [uplevel namespace origin [list $p]]
		set namesp [namespace qualifiers $cmd]
		if {[string match {} $namesp]} { set namesp :: }
		if {[string compare [namespace eval $namesp \
			info procs [list [namespace tail $cmd]]] {}]} {
		    incr count
		} else {
		    continue
		}
		set pargs {}
		foreach a [info args $cmd] {
		    if {[info default $cmd $a tmp]} {
			lappend pargs [list $a $tmp]
		    } else {
			lappend pargs $a
		    }
		}
		if {$opts(-origin) || [string compare $namesp \
			[uplevel namespace current]]} {
		    ## This is ideal, but list can really screw with the
		    ## format of the body for some procs with odd whitespacing
		    ## (everything comes out backslashed)
		    #append result [list proc $cmd $pargs [info body $cmd]]
		    append result [list proc $cmd $pargs]
		} else {
		    ## We don't include the full namespace qualifiers
		    ## if we are in the namespace of origin
		    #append result [list proc $p $pargs [info body $cmd]]
		    append result [list proc $p $pargs]
		}
		append result " \{[info body $cmd]\}\n\n"
	    }
	}
	if {!$count && !$opts(-nocomplain)} {
	    append result "\#\# No known proc $arg\n"
	    set code error
	}
    }
    return -code $code [string trimright $result \n]
}

# dump_variable --
#
# outputs variable value(s), whether array or simple, namespaced or otherwise
#
# Arguments:
#	-nocomplain
#		don't complain if no vars match something
#	-filter pattern
#		specifies a glob filter pattern to be used by the variable
#		method as an array filter pattern (it filters down for
#		nested elements) and in the widget method as a config
#		option filter pattern
#	-compact
#		makes a more compact output format to save bytes for large
#		files that are only to be sourced in
#	-append
#		user 'append' rather than set for simple vars
#	-lappend
#		user 'lappend' rather than set for simple vars
#	--	forcibly ends options recognition
# Returns:
#	the values of the requested items in a 'source'able form
#
proc dump_variable {args} {
    set whine 1
    set code  ok
    set compact {    }
    set SET "set"
    while {[string match -* $args]} {
	switch -glob -- [lindex $args 0] {
	    -n* { set whine 0; set args [lreplace $args 0 0] }
	    -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] }
	    -c* { set compact {}; set args [lreplace $args 0 0] }
	    -l* { set SET lappend; set args [lreplace $args 0 0] }
	    -a* { set SET append; set args [lreplace $args 0 0] }
	    --  { set args [lreplace $args 0 0]; break }
	    default {return -code error "unknown option \"[lindex $args 0]\""}
	}
    }
    if {$whine && [string match {} $args]} {
	return -code error "wrong \# args: [lindex [info level 0] 0] type\
		?-append? ?-compact? ?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?"
    }
    # variable
    # outputs variables value(s), whether array or simple.
    if {![info exists fltr]} { set fltr * }
    foreach arg $args {
	if {[string match {} [set vars [uplevel info vars [list $arg]]]]} {
	    if {[uplevel info exists $arg]} {
		set vars $arg
	    } elseif {$whine} {
		append res "\#\# No known variable $arg\n"
		set code error
		continue
	    } else { continue }
	}
	foreach var [lsort -dictionary $vars] {
	    set var [uplevel [list namespace which -variable $var]]
	    upvar $var v
	    if {[array exists v] || [catch {string length $v}]} {
		append res "array set [list $var] \{\n"
		foreach i [lsort -dictionary [array names v $fltr]] {
		    append res "${compact}[list $i]\t[list $v($i)]\n"
		}
		append res "\}\n"
	    } elseif {[string compare set $SET]} {
		append res [list $SET $var] { } $v\n
	    } else {
		append res [list set $var $v]\n
	    }
	}
    }
    return -code $code [string trimright $res \n]
}

# dump_namespace --
#
#   ADD COMMENTS HERE
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
proc dump_namespace {args} {
    array set opts {
	-nocomplain 0 -filter *	-procs 1 -vars 1 -recursive 0 -imports 1
    }
    set args [get_opts opts $args {-nocomplain 0 -procs 1 -vars 1 \
	    -recursive 0 -imports 1} {-procs boolean -vars boolean \
	    -imports boolean}]
    if {[string match {} $args]} {
	if {$opts(-nocomplain)} {
	    return
	} else {
	    return -code error "wrong \# args: dump namespace ?-nocomplain?\
		    ?-procs 0/1? ?-vars 0/1? ?-recursive? ?-imports 0/1?\
		    ?--? pattern ?pattern ...?"
	}
    }
    set code ok
    set result {}
    foreach arg $args {
	set cur [uplevel namespace current]
	# Namespace search order:
	# If it starts with ::, try and break it apart and see if we find
	# children matching the pattern
	# Then do the same in $cur if it has :: anywhere in it
	# Then look in the calling namespace for children matching $arg
	# Then look in the global namespace for children matching $arg
	if {
	    ([string match ::* $arg] &&
	    [catch [list namespace children [namespace qualifiers $arg] \
		    [namespace tail $arg]] names]) &&
	    ([string match *::* $arg] &&
	    [catch [list namespace eval $cur [list namespace children \
		    [namespace qualifiers $arg] \
		    [namespace tail $arg]] names]]) &&
	    [catch [list namespace children $cur $arg] names] && 
	    [catch [list namespace children :: $arg] names]
	} {
	    if {!$opts(-nocomplain)} {
		append result "\#\# No known namespace $arg\n"
		set code error
	    }
	}
	if {[string compare $names {}]} {
	    set count 0
	    foreach name [lsort $names] {
		append result "namespace eval $name \{;\n\n"
		if {$opts(-vars)} {
		    set vars [lremove [namespace eval $name info vars] \
			    [info globals]]
		    append result [namespace eval $name \
			    [namespace current]::dump_variable [lsort $vars]]\n
		}
		set procs [namespace eval $name info procs]
		if {$opts(-procs)} {
		    set export [namespace eval $name namespace export]
		    if {[string compare $export {}]} {
			append result "namespace export -clear $export\n\n"
		    }
		    append result [namespace eval $name \
			    [namespace current]::dump_proc [lsort $procs]]
		}
		if {$opts(-imports)} {
		    set cmds [info commands ${name}::*]
		    regsub -all ${name}:: $cmds {} cmds
		    set cmds [lremove $cmds $procs]
		    foreach cmd [lsort $cmds] {
			set cmd [namespace eval $name \
				[list namespace origin $cmd]]
			if {[string compare $name \
				[namespace qualifiers $cmd]]} {
			    ## Yup, it comes from somewhere else
			    append result [list namespace import -force $cmd]
			} else {
			    ## It is probably an alias
			    set alt [interp alias {} $cmd]
			    if {[string compare $alt {}]} {
				append result "interp alias {} $cmd {} $alt"
			    } else {
				append result "# CANNOT HANDLE $cmd"
			    }
			}
			append result \n
		    }
		    append result \n
		}
		if {$opts(-recursive)} {
		    append result [uplevel [namespace current]::dump_namespace\
			    [namespace children $name]]
		}
		append result "\}; # end of namespace $name\n\n"
	    }
	} elseif {!$opts(-nocomplain)} {
	    append result "\#\# No known namespace $arg\n"
	    set code error
	}
    }
    return -code $code [string trimright $result \n]
}

# dump_widget --
#   Outputs a widget configuration in source'able but human readable form.
# Arguments:
#   args	comments
# Results:
#   Returns widget configuration in "source"able form.
#
proc dump_widget {args} {
    if {[string match {} [info command winfo]]} {
	return -code error "winfo not present, cannot dump widgets"
    }
    array set opts {
	-nocomplain 0 -filter .* -default 0
    }
    set args [get_opts opts $args {-nocomplain 0 -filter 1 -default 0} \
	    {-filter regexp}]
    if {[string match {} $args]} {
	if {$opts(-nocomplain)} {
	    return
	} else {
	    return -code error "wrong \# args: dump widget ?-nocomplain?\
		    ?-default? ?-filter regexp? ?--? pattern ?pattern ...?"
	}
    }
    set code ok
    set result {}
    foreach arg $args {
	if {[string compare {} [set ws [info command $arg]]]} {
	    foreach w [lsort $ws] {
		if {[winfo exists $w]} {
		    if {[catch {$w configure} cfg]} {
			append result "\#\# Widget $w\
				does not support configure method"
			if {!$opts(-nocomplain)} {
			    set code error
			}
		    } else {
			append result "\#\# [winfo class $w] $w\n$w configure"
			foreach c $cfg {
			    if {[llength $c] != 5} continue
			    ## Filter options according to user provided
			    ## filter, and then check to see that they
			    ## are a default
			    if {[regexp -nocase -- $opts(-filter) $c] && \
				    ($opts(-default) || [string compare \
				    [lindex $c 3] [lindex $c 4]])} {
				append result " \\\n\t[list [lindex $c 0]\
					[lindex $c 4]]"
			    }
			}
			append result \n
		    }
		}
	    }
	} elseif {!$opts(-nocomplain)} {
	    append result "\#\# No known widget $arg\n"
	    set code error
	}
    }
    return -code $code [string trimright $result \n]
}

# dump_canvas --
#
#   ADD COMMENTS HERE
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
proc dump_canvas {args} {
    if {[string match {} [info command winfo]]} {
	return -code error "winfo not present, cannot dump widgets"
    }
    array set opts {
	-nocomplain 0 -default 0 -configure 0 -filter .*
    }
    set args [get_opts opts $args {-nocomplain 0 -filter 1 -default 0 \
	    -configure 0} {-filter regexp}]
    if {[string match {} $args]} {
	if {$opts(-nocomplain)} {
	    return
	} else {
	    return -code error "wrong \# args: dump canvas ?-nocomplain?\
		    ?-configure? ?-default? ?-filter regexp? ?--? pattern\
		    ?pattern ...?"
	}
    }
    set code ok
    set result {}
    foreach arg $args {
	if {[string compare {} [set ws [info command $arg]]]} {
	    foreach w [lsort $ws] {
		if {[winfo exists $w]} {
		    if {[string compare Canvas [winfo class $w]]} {
			append result "\#\# Widget $w is not a canvas widget"
			if {!$opts(-nocomplain)} {
			    set code error
			}
		    } else {
			if {$opts(-configure)} {
			    append result [dump_widget -filter $opts(-filter) \
				    [expr {$opts(-default)?{-default}:{-no}}] \
				    $w]
			    append result \n
			} else {
			    append result "\#\# Canvas $w items\n"
			}
			## Output canvas items in numerical order
			foreach i [lsort -integer [$w find all]] {
			    append result "\#\# Canvas item $i\n" \
				    "$w create [$w type $i] [$w coords $i]"
			    foreach c [$w itemconfigure $i] {
				if {[llength $c] != 5} continue
				if {$opts(-default) || [string compare \
					[lindex $c 3] [lindex $c 4]]} {
				    append result " \\\n\t[list [lindex $c 0]\
					    [lindex $c 4]]"
				}
			    }
			    append result \n
			}
		    }
		}
	    }
	} elseif {!$opts(-nocomplain)} {
	    append result "\#\# No known widget $arg\n"
	    set code error
	}
    }
    return -code $code [string trimright $result \n]
}

# dump_text --
#
#   ADD COMMENTS HERE
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
proc dump_text {args} {
    if {[string match {} [info command winfo]]} {
	return -code error "winfo not present, cannot dump widgets"
    }
    array set opts {
	-nocomplain 0 -default 0 -configure 0 -start 1.0 -end end
    }
    set args [get_opts opts $args {-nocomplain 0 -default 0 \
	    -configure 0 -start 1 -end 1}]
    if {[string match {} $args]} {
	if {$opts(-nocomplain)} {
	    return
	} else {
	    return -code error "wrong \# args: dump text ?-nocomplain?\
		    ?-configure? ?-default? ?-filter regexp? ?--? pattern\
		    ?pattern ...?"
	}
    }
    set code ok
    set result {}
    foreach arg $args {
	if {[string compare {} [set ws [info command $arg]]]} {
	    foreach w [lsort $ws] {
		if {[winfo exists $w]} {
		    if {[string compare Text [winfo class $w]]} {
			append result "\#\# Widget $w is not a text widget"
			if {!$opts(-nocomplain)} {
			    set code error
			}
		    } else {
			if {$opts(-configure)} {
			    append result [dump_widget -filter $opts(-filter) \
				    [expr {$opts(-default)?{-default}:{-no}}] \
				    $w]
			    append result \n
			} else {
			    append result "\#\# Text $w dump\n"
			}
			catch {unset tags}
			catch {unset marks}
			set text {}
			foreach {k v i} [$w dump $opts(-start) $opts(-end)] {
			    switch -exact $k {
				text {
				    append text $v
				}
				window {
				    # must do something with windows
				    # will require extra options to determine
				    # whether to rebuild the window or to
				    # just reference it
				    append result "#[list $w] window create\
					    $i [$w window configure $i]\n"
				}
				mark {set marks($v) $i}
				tagon {lappend tags($v) $i}
				tagoff {lappend tags($v) $i}
				default {
				    error "[info level 0]:\
					    should not be in this switch arm"
				}
			    }
			}
			append result "[list $w insert $opts(-start) $text]\n"
			foreach i [$w tag names] {
			    append result "[list $w tag configure $i]\
				    [$w tag configure $i]\n"
			    if {[info exists tags($i)]} {
				append result "[list $w tag add $i]\
					$tags($i)\n"
			    }
			    foreach seq [$w tag bind $i] {
				append result "[list $w tag bind $i $seq \
					[$w tag bind $i $seq]]\n"
			    }
			}
			foreach i [array names marks] {
			    append result "[list $w mark set $i $marks($i)]\n"
			}
		    }
		}
	    }
	} elseif {!$opts(-nocomplain)} {
	    append result "\#\# No known widget $arg\n"
	    set code error
	}
    }
    return -code $code [string trimright $result \n]
}

# dump_interface -- NOT FUNCTIONAL
#
#   the end-all-be-all of Tk dump commands.  This should dump the widgets
#   of an interface with all the geometry management.
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
proc dump_interface {args} {

}

# dump_state --
#
#   This dumps the state of an interpreter.  This is primarily a wrapper
#   around other dump commands with special options.
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
proc dump_state {args} {

}


## Force the parent namespace to include the exported commands
##
catch {namespace eval ::Utility namespace import -force ::Utility::dump::*}

}; # end of namespace ::Utility::dump

return
Added library/util-expand.tcl.
































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
# util-expand.tcl --
#
#	This file implements package ::Utility::expand, which  ...
#
# Copyright (c) 1997-8 Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require ::Utility
package provide ::Utility::expand 1.0

namespace eval ::Utility::expand {;

namespace export -clear expand*
namespace import -force ::Utility::*

##
## NOTE: In places where uplevel is used, it is highly likely that
## a further eval redirect is otherwise necessary for foreign interps
##

# expand --
#
#	The string to match is expanded to the longest possible match.
#	If data(-showmultiple) is non-zero and the user longest match
#	equaled the string to expand, then all possible matches are
#	output to stdout.  Triggers bell if no matches are found.
#
# Arguments:
#    type	type of expansion (path / proc / variable)
#
# Returns:
#	number of matches found
#
proc expand {args} {
    array set opts {
	-type any -widget {}
    }
    set args [get_opts opts $args {-type 1 -widget 1} {-widget widget}]
    if {[string match {} $opts(-widget)] && [llength $args]!=1} {
	return -code error "wrong # args: should be\
		\"[lindex [info level 0] 0] ?-type type?\
		?-widget widget || str?"
    }
    set prefix [namespace current]::expand_
    if {[string match {} [set arg [info commands $prefix$opts(-type)]]]} {
	set arg [info commands $prefix$opts(-type)*]
    }
    set result {}
    set code ok
    if 0 {
	set exp "\[^\\]\[ \t\n\r\[\{\"\$]"
	set tmp [$w search -backwards -regexp $exp insert-1c limit-1c]
	if {[string compare {} $tmp]} {append tmp +2c} else {set tmp limit}
	if {[$w compare $tmp >= insert]} return
	set str [$w get $tmp insert]
    }
    switch [llength $arg] {
	1 { set code [catch {uplevel $arg $args} result] }
	0 {
	    set arg [info commands $prefix*]
	    regsub -all $prefix $arg {} arg
	    return -code error "unknown [lindex [info level 0] 0] type\
		    \"$opts(-type)\", must be one of: [join [lsort $arg] {, }]"
	}
	default {
	    regsub -all $prefix $arg {} arg
	    return -code error "ambiguous type \"$opts(-type)\",\
		    could be one of: [join [lsort $arg] {, }]"
	}
    }
    if 0 {
	set len [llength $res]
	if {$len} {
	    $w delete $tmp insert
	    $w insert $tmp [lindex $res 0]
	    if {$len > 1} {
		upvar \#0 [namespace current]::[winfo parent $w] data
		if {$data(-showmultiple) && \
			![string compare [lindex $res 0] $str]} {
		    puts stdout [lsort [lreplace $res 0 0]]
		}
	    }
	} else { bell }
	return [incr len -1]
    }
    return -code $code [string trimright $result \n]
}

# expand_pathname --
#
#    expand a file pathname based on $str
#    This is based on UNIX file name conventions
#
# Arguments:
#   str		partial file pathname to expand
# Results:
#   Returns list containing longest unique match followed by all the
#   possible further matches
#
proc expand_pathname {str} {
    #reval pwd, cd, glob and final cd
    set pwd [pwd]
    if {[catch {cd [file dirname $str]} err]} {
	return -code error $err
    }
    if {[catch {glob [file tail $str]*} m]} {
	set match {}
    } else {
	if {[llength $m] > 1} {
	    global tcl_platform
	    if {[string match windows $tcl_platform(platform)] \
		    && [string compare "Windows NT" $tcl_platform(os)]} {
		## Windows is screwy because it can be case insensitive
		set tmp [best_match [string tolower [lsort $m]] \
			[string tolower [file tail $str]]]
	    } else {
		set tmp [best_match [lsort $m] [file tail $str]]
	    }
	    if {[string match ?*/* $str]} {
		set tmp [file dirname $str]/$tmp
	    } elseif {[string match /* $str]} {
		set tmp /$tmp
	    }
	    regsub -all { } $tmp {\\ } tmp
	    set match [linsert $m 0 $tmp]
	} else {
	    ## This may look goofy, but it handles spaces in path names
	    eval append match $m
	    if {[file isdir $match]} {append match /}
	    if {[string match ?*/* $str]} {
		set match [file dirname $str]/$match
	    } elseif {[string match /* $str]} {
		set match /$match
	    }
	    regsub -all { } $match {\\ } match
	    ## Why is this one needed and the ones below aren't!!
	    set match [list $match]
	}
    }
    cd $pwd
    return $match
}

# expand_proc --
#
## ExpandProcname - expand a tcl proc name based on $str
# ARGS:	str	- partial proc name to expand
# Calls:	best_match
# Returns:	list containing longest unique match followed by all the
#		possible further matches
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
proc expand_proc {str} {
    #reval info
    set match [uplevel info commands [list $str]*]
    if {[llength $match] > 1} {
	regsub -all { } [best_match $match $str] {\\ } str
	set match [linsert $match 0 $str]
    } else {
	regsub -all { } $match {\\ } match
    }
    return $match
}

# expand_variable --
#
## ExpandVariable - expand a tcl variable name based on $str
# ARGS:	str	- partial tcl var name to expand
# Calls:	best_match
# Returns:	list containing longest unique match followed by all the
#		possible further matches
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
proc expand_variable {str} {
    #reval "array names", "info vars"
    if {[regexp {([^\(]*)\((.*)} $str junk ary str]} {
	## Looks like they're trying to expand an array.
	set match [array names $ary $str*]
	if {[llength $match] > 1} {
	    set vars $ary\([best_match $match $str]
	    foreach var $match {lappend vars $ary\($var\)}
	    return $vars
	} else {set match $ary\($match\)}
	## Space transformation avoided for array names.
    } else {
	set match [info vars $str*]
	if {[llength $match] > 1} {
	    regsub -all { } [best_match $match $str] {\\ } str
	    set match [linsert $match 0 $str]
	} else {
	    regsub -all { } $match {\\ } match
	}
    }
    return $match
}

}; # end of namespace ::Utility::expand
Added library/util-find.tcl.










































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
The following operands are supported:

path           a path name of a starting point in the directory hierarchy.

The first argument that starts with a -, or is a ! or  a  (,
and  all  subsequent  arguments  will  be  interpreted as an
expression made up of the following primaries and operators.
In  the  descriptions, wherever n is used as a primary argu-
ment, it will be interpreted as a decimal integer optionally
preceded by a plus (+) or minus (-) sign, as follows:

+n             more than n
n              exactly n
-n             less than n.

Valid expressions are:

-atime n	True if the file was  accessed	n  days	 ago.
		The  access  time  of  directories in path is
		changed by find itself.

-ctime n	True if the file's status was changed n	 days
		ago.

-eval command	True if the executed command returns  a	 zero
		value  as  exit	 status.   The end of command
		must be punctuated by an  escaped  semicolon.
		A  command  argument  {}  is  replaced by the
		current path name.

-follow		Always	True; causes symbolic links to be fol-
		lowed.	 When  following symbolic links, find
		keeps track of	the  directories  visited  so
		that  it can detect infinite loops; for exam-
		ple, such a loop would occur  if  a  symbolic
		link pointed to an ancestor.  This expression
		should not be used with the -type  l  expres-
		sion.

-group gname	True if the file belongs to the group  gname.
		If  gname  is  numeric and does not appear in
		the /etc/group file, it is taken as  a	group
		ID.

-inum n		True if the file has inode number n.

-links n	True if the file has n links.

-ls		Always	true;  prints	current	 path	name
		together   with	 its  associated  statistics.
		These include (respectively):

		 inode number
		 size in kilobytes (1024 bytes)
		 protection mode
		 number of hard links
		 user
		 group
		 size in bytes
		 modification time.

		If the file is a special file the size	field
		will  instead  contain	the  major  and minor
		device numbers.

		If the file is a symbolic link	the  pathname
		of  the linked-to file is printed preceded by
		`->'.  The format is identical to that of  ls
		-gilds (see ls(1)).

		Note: Formatting is done internally,  without
		executing the ls program.

-mtime n	True if the file's data was modified  n	 days
		ago.

-name pattern	True if	 pattern  matches  the	current	 file
		name.	Normal	shell  file  name  generation
		characters  (see  sh(1))  may  be  used.    A
		backslash  (\) is used as an escape character
		within the pattern.  The  pattern  should  be
		escaped	 or  quoted when find is invoked from
		the shell.

-newer file	True if the current file  has  been  modified
		more recently than the argument file.

-perm [-]mode	The mode argument is used to  represent	file
		mode bits.  It will be identical in format to
		the  <symbolicmode>  operand   described   in
		chmod(1), and will be interpreted as follows.
		To start, a template will be assumed with all
		file mode bits cleared.	 An op symbol of:

		+    will set the appropriate  mode  bits  in
			the template;

		-    will clear the appropriate bits;

		=    will  set	the  appropriate  mode	bits,
			without	 regard	 to the contents of pro-
			cess' file mode creation mask.

		The op symbol of - cannot be the first	char-
		acter of mode; this avoids ambiguity with the
		optional leading hyphen.  Since	 the  initial
		mode  is all bits off, there are not any sym-
		bolic modes that need to use - as  the	first
		character.

		If the hyphen is omitted,  the	primary	 will
		evaluate  as  true  when  the file permission
		bits exactly match the value of the resulting
		template.

		Otherwise, if mode is prefixed by  a  hyphen,
		the primary will evaluate as true if at least
		all the bits in the  resulting	template  are
		set in the file permission bits.

-perm [-]onum	True if the  file  permission  flags  exactly
		match  the  octal number onum (see chmod(1)).
		If onum is prefixed by a minus sign (-), only
		the  bits  that	 are set in onum are compared
		with  the  file	 permission  flags,  and  the
		expression evaluates true if they match.

-print		Always true; causes the current path name  to
		be printed.

-prune		Always	yields	true.	Do  not	examine	 any
		directories  or files in the directory struc-
		ture below the pattern just matched.  See the
		examples, below.

-puts

-size n[c]	True if the file is n blocks long (512	bytes
		per  block).   If  n  is followed by a c, the
		size is in bytes.

-type c		True if the type of the file is c, where c is
		b,  c,	d, l, p, or f for block special file,
		character special file,	 directory,  symbolic
		link,  fifo  (named  pipe),  or	 plain	file,
		respectively.

-user uname	True if the file belongs to the	 user  uname.
		If  uname is numeric and does not appear as a
		login name in the  /etc/passwd	file,  it  is
		taken as a user ID.

proc find {dir args} {
}

    proc rglob {{pat *}} {
	set result [glob -nocomplain $pat]
	foreach f $result {
	    if {[file isdirectory $f]} {
		lappend result [rglob [file join $f $pat]]
	    }
	}
	return $result
    }

Added library/util-list.tcl.


































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337

   * AT   = AsserTcl    /''done''/
   * EL   = ExtraL      /''done''/
   * JS   = jstools     /''done''/
   * JT   = jultaf      /''done''/
   * PB   = Pool_Base   /''done''/
   * TclX = TclX        /''done''/

----
(EL)    oneof element list 
(TclX)  lcontain list element
        Determine if the element is a list element of list. If the
        element is contained in the list, 1 is returned, otherwise,
        0 is returned. 

(EL)    lunion list list ... 
        returns the union of the lists 

(TclX)  union lista listb
        Procedure to return the logical union of the two specified lists.
        Any duplicate elements are removed.

(EL)    lcommon list list ... 
        returns the common elements of the lists.

(TclX)  intersect lista listb
        Procedure to return the logical intersection of two lists.
        The returned list will be sorted. 

(EL)    leor list1 list2 
        returns the elements that are not shared between both lists 

(TclX)  intersect3 lista listb
        Procedure to intersects two lists, returning a list containing
        three lists: The first list returned is everything in lista that
        wasn't in listb. The second list contains the intersection of
        the two lists, and the third list contains all the elements
        that were in listb but weren't in lista. The returned lists
        will be sorted. 

(TclX)  lempty list
        Determine if the specified list is empty. If empty, 1 is
        returned, otherwise, 0 is returned. This command is an
        alternative to comparing a list to an empty string, however
        it checks for a string of all whitespaces, which is an empty
        list. 
----
(JT)    Juf::Sequence::assign LIST ?NAME ...?
        Sets value of the variables specified by the NAME arguments to
        that of the existing elements of LIST. Returns remaining list
        elements. If the number of variables exceeds the list length,
        the remaining variables will be removed.

(PB)    ::pool::list::assign varList list
        By Brent Welch. Assigns a set of variables from a list of values.
        If there are more values than variables, they are ignored. If
        there are fewer values than variables, the variables get the empty
        string. 

(TclX)  lassign list var ?var...?
        Assign successive elements of a list to specified variables.
        If there are more variable names than fields, the remaining
        variables are set to the empty string. If there are more
        elements than variables, a list of the unassigned elements
        is returned. 

        For example, 

                lassign {dave 100 200 {Dave Foo}} name uid gid longName 

        Assigns name to ``dave'', uid to ``100'', gid to ``200'', and
        longName to ``Dave Foo''. 
----
(EL)    lfind mode list pattern 
(TclX)  lmatch ?mode? list pattern
        Search the elements of list, returning a list of all elements
        matching pattern. If none match, an empty list is returned. 

        The mode argument indicates how the elements of the list are
        to be matched against pattern and it must have one of the
        following values: 

        -exact  The list element must contain exactly the same string
                as pattern. 

        -glob   Pattern is a glob-style pattern which is matched against
                each list element using the same rules as the string
                match command. 

        -regexp Pattern is treated as a regular expression and matched
                against each list element using the same rules as the
                regexp command. 

        If mode is omitted then it defaults to -glob. 

(JT)    Juf::Sequence::match PATTERN LIST
        Returns a new list with all elements of LIST matching PATTERN
        as with string match. == glob '''!'''

(PB)    ::pool::list::match list pattern
        All words not contained in list pattern are removed from list.
        In set-notation: result = intersect (list, pattern). This is
        not completely true, duplicate entries in 'list' remain in the
        result, given that they appear at all. 

(PB)    ::pool::list::filter list pattern
        All words contained in the list pattern are removed from list.
        In set-notation: result = list - pattern. Returns the set
        difference of list and pattern. '''Negative match'''.

----
(EL)    lremdup ?-sorted? list ?var?
        returns a list in which all duplactes are removed. with the
        -sorted option the command will usually be a lot faster,
        but $list must be sorted with lsort; The optional $var gives
        the name of a variable in which the removed items will be stored. 

(TclX)  lrmdups list
        Procedure to remove duplicate elements from a list. The returned
        list will be sorted. 

(PB)    ::pool::list::uniq list
        Removes duplicate entries from list. Returns the modified list. 

----
(EL)    laddnew listName ?item? ... 
        adds the items to the list if not already there 

(JT)    Juf::Sequence::append ?OPTION ...? NAME ?VALUE ...?
        Works like the Tcl builtin lappend, but considers these options: 

        -nonempty       Append only non-empty values.
        --              Marks the end of the options. The argument
                        following this one will be treated as NAME
                        even if it starts with a -. 

(TclX)  lvarcat var string ?string...?
        This command treats each string argument as a list and concatenates
        them to the end of the contents of var, forming a a single list.
        The list is stored back into var and also returned as the result.
        if var does not exist, it is created. 
----
(PB)    ::pool::list::pop listVar
        Removes the last element of the list contained in variable listVar. 
        Returns the last element of the list, or {} in case of an empty list. 

(JT)    Juf::Sequence::pop NAME ?COUNT?
        Removes COUNT element from the end of the list stored in the
        variable NAME and returns the last element removed. COUNT
        defaults to 1. 

(EL)    lpop listName ?pos? 
        returns the last element from a list, thereby removing it from
        the list. If pos is given it will return the pos element of the
        list. 

(JT)    Juf::Sequence::shift NAME ?COUNT?
        Removes COUNT element from the list stored in the variable NAME
        and returns the last element removed. COUNT defaults to 1.

(EL)    lshift listName 
        returns the first element from a list, thereby removing it from
        the list. 

(PB)    ::pool::list::shift listVar
        The list stored in the variable listVar is shifted down by one. 
        Returns the first element of the list stored in listVar, or {}
        for an empty list. The latter is not a sure signal, as the list
        may contain empty elements. 

(PB)    ::pool::list::remove listVar position
        Removes the item at position from the list stored in variable
        listVar. 

(PB)    ::pool::list::exchange listVar position newItem
        Removes the item at position from the list stored in variable
        listVar and inserts newItem in its place. Returns the changed list. 

(TclX)  lvarpop var ?indexExpr? ?string?
        The lvarpop command pops (deletes) the element indexed by the
        expression indexExpr from the list contained in the variable var.
        If index is omitted, then 0 is assumed. If string, is specified,
        then the deleted element is replaced by string. The replaced or
        deleted element is returned. Thus ``lvarpop argv 0'' returns the
        first element of argv, setting argv to contain the remainder of the
        string. 

        If the expression indexExpr starts with the string end, then end
        is replaced with the index of the last element in the list. If the
        expression starts with len, then len is replaced with the length
        of the list. 
----
(PB)    ::pool::list::push listvar args
        The same as 'lappend', provided for symmetry only. 

(EL)    lpush listName ?item? ?position? 
        opposite of lpop. 

(EL)    lunshift listName ?item? 
        opposite of lshift: prepends ?item? to the list. 

(PB)    ::pool::list::prepend listVar newElement
(PB)    ::pool::list::unshift listVar newElement
        The list stored in the variable listVar is shifted up by one.
        newElement is inserted afterward into the now open head position. 

(TclX)  lvarpush var string ?indexExpr?
        The lvarpush command pushes (inserts) string as an element in the
        list contained in the variable var. The element is inserted before
        position indexExpr in the list. If index is omitted, then 0 is
        assumed. If var does not exists, it is created. 

        If the expression indexExpr starts with the string end, then end
        is replaced with the index of the last element in the list. If
        the expression starts with len, then len is replaced with the
        length of the list. Note the a value of end means insert the
        string before the last element. 
----
(PB)    ::pool::list::head list
        Returns the first element of list. 

(PB)    ::pool::list::last list
        Returns the last element of list. 

(PB)    ::pool::list::prev list
        Returns everything before the last element of list. 

(PB)    ::pool::list::tail list
        Returns everything behind the first element of list. 

----
(EL)    remove listName ?item? ... 
        removes the items from the list 

(PB)    ::pool::list::delete listVar value
        By Brent Welch. Deletes an item from the list stored in
        listVar, by value. Returns 1 if the item was present, else 0. 

----
(EL)    lsub list ?-exclude? index_list
        create a sublist from a set of indices. When -exclude is specified,
        the elements of which the indexes are not in the list will be given. 
        eg.:

        % lsub {Ape Ball Field {Antwerp city} Egg} {0 3}
        Ape {Antwerp city}
        % lsub {Ape Ball Field {Antwerp city} Egg} -exclude {0 3}
        Ball Field Egg

(PB)    ::pool::list::select list indices
        Idea from a thread in c.l.t.
        General permutation / selection of list elements. Takes the elements
        of list whose indices were given to the command and returns a new list
        containing them, in the specified order. 

----

(EL)    lcor 
        gives the positions of the elements in list in the reference list.
        If an element is not found in the reference list, it returns -1.
        Elements are matched only once. eg.:

        % lcor {a b c d e f} {d b}
        3 1
        % lcor {a b c d e f} {b d d}
        1 3 -1

(EL)    llremove ?-sorted? list1 list2 ?var?
        returns a list with all items in list1 that are not in list2. with
        the -sorted option the command will usually be a lot faster, but
        both given lists must be sorted with lsort; The optional $var give
        the name of a variable in which the removed items will be stored. 

(EL)    lmerge ?list1? ?list2? ??spacing?? 
        merges two lists into one eg.:

        % lmerge {a b c} {1 2 3}
        a 1 b 2 c 3
        % lmerge {a b c d} {1 2} 2
        a b 1 c d 2

(EL)    lunmerge ?list? ?spacing? ?var?
        unmerges items from a list to the result; the remaining items are
        stored in the given variable ?var? eg.:

        % lunmerge {a 1 b 2 c 3}
        a b c
        % lunmerge {a b 1 c d 2} 2 var
        a b c d
        % set var
        1 2

(EL)    lset listName ?item? ?indexlist? 
        sets all elements of the list at the given indices to value ?item? 

(EL)    larrayset array varlist valuelist 
        sets the values of valuelist to the respective elements in varlist
        for the given array.

(EL)    lregsub ?switches? exp list subSpec 
        does a regsub for each element in the list, and returns the resulting
        list. eg.:

        % lregsub {c$} {afdsg asdc sfgh {dfgh shgfc} dfhg} {!}
        afdsg asd! sfgh {dfgh shgf!} dfhg
        % lregsub {^([^.]+)\.([^.]+)$} {start.sh help.ps h.sh} {\2 \1}
        {sh start} {ps help} {sh h}

(PB)    ::pool::list::reverse list
        Returns the reversed list. 

(PB)    ::pool::list::projection list column
        Treats list as list of lists and extracts the column'th element of
        each list item. If list is seen as matrix, then the procedure
        returns the data of the specified column. 

(PB)    ::pool::list::apply cmd list
        Applies cmd to all entries of list and concatenates the
        individual results into a single list. The cmd must accept exactly
        one argument, which will be the current element.

(PB)    ::pool::list::lengthOfLongestEntry (list)
        Determines the length of the longest entry contained in the list.

(AT)    lall item_list list expr
        List universal quantifier: evaluates expr for all items or
        item sequences, and returns 1 if the expresson is true over
        the whole list, and 0 otherwise

(AT)    lexit item_list list expr
        List existential quantifier: evaluates expr for all items or
        item sequences, and returns 1 if the expresson is true for any
        item in the list, and 0 otherwise

(JS)    j:longest_match
        find the longest common initial string in a list

Added library/util-mail.tcl.
























































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
# util-mail.tcl --
#
#	This file implements package ::Utility::mail, which  ...
#
# Copyright (c) 1998-1999 Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

#package require NAME VERSION
package provide ::Utility::mail 1.0

namespace eval ::Utility::mail {;

namespace export -clear *

;proc sendmail {args} {
    # cheap getopts, no error handling
    array set opts [list -to {} -from {} -body {} \
	    -fields {} -subject {} -attach {}]
    foreach {key val} $args {
	if {[info exists opts($key)]} { set opts($key) $val }
    }
    if {[string match {} $opts(-to)] || [string match {} $opts(-from)]} {
	cgi_die "Error: -to and -from must be specified to sendmail\
		\n[info level 0]"
    }
    if {[string length $opts(-attach)] && \
	    [catch {open $opts(-attach) r} atfid]} {
	cgi_die "Error: couldn't find file to attach \"$opts(-attach)\""
    }
    set mailprog "/usr/lib/sendmail -t -oi"
    if {[catch {open "|$mailprog" r+} mailfid]} {
	cgi_die "Error: couldn't execute \"$mailprog\"" $mailfid
    }
    puts $mailfid "From: $opts(-from)"
    puts $mailfid "To: $opts(-to)"
    puts $mailfid "Subject: AutoSSI $opts(-subject)"
    if {[string length $opts(-fields)]} {
	puts $mailfid $opts(-fields)
    }
    if {[string length $opts(-attach)] && [info exists atfid]} {
	set bound "----NEXT_PART_[clock seconds].[pid]"
	puts $mailfid "Content-Type: multipart/mixed;\n\tboundary=\"$bound\""

	append pre "This message is in MIME format. " \
		"Since your mail reader does not understand this format," \
		"\nsome or all of this message may not be legible.\n\n"
	append body "Content-Type: text/plain;\n" \
		"\tcharset=\"iso-8859-1\"\n" \
		"Content-Transfer-Encoding: quoted-printable\n\n"
	set data [read $atfid]
	close $atfid
	if {[info tclversion]<8.1 || [string first \0 $data]>=0} {
	    append attach "Content-Type: application/octet-stream;\n" \
		    "\tname=\"$opts(-attach)\"\n" \
		    "Content-Disposition: attachment;\n" \
		    "\tfilename=\"$opts(-attach)\"\n\n"
	} else {
	    append attach "Content-Type: text-plain;\n" \
		    "\tcharset=\"iso-8859-1\"\n" \
		    "\tname=\"$opts(-attach)\"\n" \
		    "Content-Transfer-Encoding: quoted-printable\n" \
		    "Content-Disposition: attachment;\n" \
		    "\tfilename=\"$opts(-attach)\"\n\n"
	}
	set len [string length "$pre--$bound\n$body$opts(-body)\n--$bound\n$attach$data\n--$bound--"]
	puts $mailfid "Content-Length: $len\n"
	puts $mailfid "$pre--$bound\n$body$opts(-body)\n--$bound\n$attach$data\n--$bound--"
    } else {
	puts $mailfid "\n$opts(-body)"
    }

    if {[catch {close $mailfid} err]} { puts stderr $err }

}

variable SMTP
array set SMTP [list socket 25]

proc smtpmail {host to from subject text} {
    # Send a Mail with the following command :
    # send_SMTP_mail <SMTP_HOST> <Recipient> <From> <Subject> <Text>

    variable SMTP

    set socket [socket $host $SMTP(socket)]
    fconfigure $socket -buffering line
    puts $socket "MAIL From:<$from>"
    gets $socket
    foreach addr $to {
	puts $socket "RCPT To:<$addr>"
    }
    gets $socket
    puts $socket DATA
    gets $socket
    puts $socket "From: <$from>\nTo: <$recipients>Subject: $subject\n"

    foreach line [split $text \n] {
	puts $socket [join $line]
    }
    puts $socket .\nQUIT
    gets $socket
    close $socket
}

}; # end namespace
Added library/util-number.tcl.






























































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
# util-number.tcl --
#
#	This file implements package ::Utility::number, which  ...
#
# Copyright (c) 1997-1999 Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

#package require NAME VERSION
package provide ::Utility::number 1.0

namespace eval ::Utility::number {;

namespace export -clear *

# largest_int --
#   Finds the largest recognized int in Tcl for the platform
# Arguments:
#   none
# Results:
#   Returns the largest allowed value for an int (for exprs and stuff)
#
;proc largest_int {} {
    set int 1
    set exp 7; # assume we get at least 8 bits
    while {$int > 0} { set int [expr {1 << [incr exp]}] }
    expr {$int-1}
}

# int_bits --
#   Finds the number of bits in an int
# Arguments:
#   none
# Results:
#   Returns the numbers of bits in an int
#
;proc int_bits {} {
    set int 1
    set exp 7; # assume we get at least 8 bits
    while {$int > 0} { set int [expr {1 << [incr exp]}] }
    # pop up one more, since we start at 0
    incr exp
}

# get_square_size --
#   gets the minimum square size for an input
# Arguments:
#   num		number
# Returns:
#   returns smallest square size that would fit number
#
;proc get_square_size num {
    set i 1
    while {($i*$i) < $num} { incr i }
    return $i
}


# dec2roman --
#   converts a decimal to roman numeral
# Arguments:
#   x		number in decimal format
# Returns:
#   roman numeral
#
;proc dec2roman {x} {
    set result ""
    foreach [list val roman] [list 1000 M 900 CM 500 D 400 CD 100 C 90 XC \
	    50 L 40 XL 10 X 9 IX 5 V 4 IV 1 I] {
	while {$x >= $val} {
	    append result $roman
	    incr x -$val
	}
    }
    return $result
}

# bin2hex --
#   converts binary to hex number
# Arguments:
#   bin		number in binary format
# Returns:
#   hexadecimal number
#
;proc bin2hex bin {
    ## No sanity checking is done
    array set t {
	0000 0 0001 1 0010 2 0011 3 0100 4
	0101 5 0110 6 0111 7 1000 8 1001 9
	1010 a 1011 b 1100 c 1101 d 1110 e 1111 f
    }
    set diff [expr {4-[string length $bin]%4}]
    if {$diff != 4} {
        set bin [format %0${diff}d$bin 0]
    }
    regsub -all .... $bin {$t(&)} hex
    return [subst $hex]
}


# hex2bin --
#   converts hex number to bin
# Arguments:
#   hex		number in hex format
# Returns:
#   binary number (in chars, not binary format)
#
;proc hex2bin hex {
    set t [list 0 0000 1 0001 2 0010 3 0011 4 0100 \
	    5 0101 6 0110 7 0111 8 1000 9 1001 \
	    a 1010 b 1011 c 1100 d 1101 e 1110 f 1111]
    regsub {^0[xX]} $hex {} hex
    return [string map -nocase $t $hex]
}

# commify --
#   puts commas into a decimal number
# Arguments:
#   num		number in acceptable decimal format
#   sep		separator char (defaults to English format ",")
# Returns:
#   number with commas in the appropriate place
#
proc commify {num {sep ,}} {
    while {[regsub {^([-+]?\d+)(\d\d\d)} $num "\\1$sep\\2" num]} {}
    return $num
}

# isluhn --
#   Checks whether a given number is a valid credit card number
# Mod 10 Rules					  
# The rules for a Mod 10 check: 			  
# The credit card number must be between 13 and 16 digits. 
#   The credit card number must start with: 	  
# 	  4 for Visa Cards 			  
# 	  37 for American Express Cards 		  
# 	  5 for MasterCards 			  
# 	  6 for Discover Cards 			  
#   If the credit card number is less then 16 digits add zeros to
#   the beginning to make it 16 digits.		  
#   Multiply each digit of the credit card number by the
#   corresponding digit of the mask, and sum the results together.
#   Once all the results are summed divide by 10, if there is no
#   remainder then the credit card number is valid.
# For a card with an even number of digits, double every odd numbered digit
# and substract 9 if the product is greater than 9. Add up all the even
# digits as well as the doubled odd digits, and the result must be a
# multiple of 10 or it's not a valid card. If a card has an odd number of
# digits, perform the same addition, doubling the even numbered digits
# instead...
# Arguments:
#   num		card num to check
# Results:
#   Returns 0/1
#
proc isluhn {cardnum} {
    regsub -all {[^0-9]} $cardnum {} cardnum
    #set cardnum [format %.16d $cardnum]
    set len [string length $cardnum]
    if {$len < 13 || $len > 16} { return 0 }
    set i -1
    set double [expr {!($len%2)}]
    set chksum 0
    while {[incr i]<$len} {
	set c [string index $cardnum $i]
	if {$double} {if {[incr c $c] >= 10} {incr c -9}}
	incr chksum $c
	set double [expr {!$double}]
    }
    return [expr {($chksum%10)==0}]
}

variable symbols 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ
variable baserng 0123456789abcdefghijklmnopqrstuvwxyz
variable baseary
array set baseary {
    0  0 1  1 2  2 3  3 4  4 5  5 6  6 7  7 8  8 9  9
    a 10 b 11 c 12 d 13 e 14 f 15 g 16 h 17 i 18 j 19
    10 a 11 b 12 c 13 d 14 e 15 f 16 g 17 h 18 i 19 j
    k 20 l 21 m 22 n 23 o 24 p 25 q 26 r 27 s 28 t 29
    20 k 21 l 22 m 23 n 24 o 25 p 26 q 27 r 28 s 29 t
    u 30 v 31 w 32 x 33 y 34 z 35
    30 u 31 v 32 w 33 x 34 y 35 z
}

proc base2base {num srcbase destbase} {
    return [dec2base [base2dec $num $srcbase] $destbase]
}

proc dec2base {num base} {
    # convert a decimal num to any base (2..36)
    # supports fractions
    # this actually accepts any valid Tcl int
    variable baserng
    variable baseary

    if {$base < 2 || $base > 36} {
	return -code error "base must be between 2 and 36"
    }
    set rng {^([0-9]+)(.[0-9]+)?$}
    if {![regexp $rng $num junk int frac]} {
	return -code error "invalid decimal number \"$num\""
    }
    if {int($int) < $base} {
	# use the int() above to ensure it is numeric
	set value $baseary($int)
    } elseif {$base == 8} {
	# format will be faster
	set value [format %o $int]
    } elseif {$base == 16} {
	# format will be faster
	set value [format %x $int]
    } else {
	set rad 0
	set val 1
	while {$int > $val} { set val [expr {pow($base,[incr rad])}] }
	set result ""
	while {$int > 0} {
	    set pow [expr {int(pow($base,$rad))}]
	    set red [expr {int($int/$pow)}]
	    set int [expr {$int-($pow*$red)}]
	    append result $baseary($red)
	    incr rad -1
	}
	incr rad
	while {$rad} {
	    append result 0
	    incr rad -1
	}
	set value [string trimleft $result 0]
    }
    if {[string compare {} $frac] && ($frac != 0.0)} {
	set rad -1
	set rest ""
	# This is limited to a certain granularity
	while {$frac > 1.0e-12} {
	    set pow [expr {(pow($base,$rad))}]
	    set red [expr {int($frac/$pow)}]
	    set frac [expr {$frac-($pow*$red)}]
	    append rest $baseary($red)
	    incr rad -1
	}
	return $value.$rest
    }
    return $value
}

proc base2dec {num base} {
    # convert any base number (2..36) to decimal
    # supports fractions
    variable baserng
    variable baseary

    if {$base < 2 || $base > 36} {
	return -code error "base must be between 2 and 36"
    }
    set rng [string range $baserng 0 [expr {$base-1}]]
    if {![regexp "^(\[$rng\]+).?(\[$rng\]+)?\$" \
	    [string tolower $num] junk int frac]} {
	return -code error "number may only contain chars \"\[$rng\]\""
    }
    if {$base == 16} {
	# format will be faster
	set value [format %d 0x$int]
    } elseif {$base == 8} {
	# format will be faster
	set value [format %d 0$int]
    } else {
	set rad [string length $int]
	set value 0
	foreach c [split $int {}] {
	    incr rad -1
	    set value [expr {$value+(int(pow($base,$rad))*$baseary($c))}]
	}
    }
    if {[string compare {} [string trimright $frac 0]]} {
	set rad 0
	set rest 0.0
	foreach c [split $frac {}] {
	    incr rad
	    set rest [expr {$rest+($baseary($c)/pow($base,$rad))}]
	}
	return [expr {$value+$rest}]
    }
    return $value
}

proc add_baseX {numA numB} {
    # add two numbers in any base that can be expressed as a string of 
    # unique symbols
    #
    # John Ellson <[email protected]>

    variable symbols
    set base [string length $symbols]
    set idxA [string length $numA]
    set idxB [string length $numB]
    set carry 0
    set result ""
    while {$idxA || $idxB || $carry} {
	if {$idxA} {
	    set digA [string index $numA [incr idxA -1]]
	    set decA [string first $digA $symbols]
	    if {$decA < 0} {
		puts stderr "invalid digit \"$digA\""
		return -1
	    }
	} else {
	    set decA 0
	}
	if {$idxB} {
	    set digB [string index $numB [incr idxB -1]]
	    set decB [string first $digB $symbols]
	    if {$decB < 0} {
		puts stderr "invalid digit \"$digB\""
		return -1
	    }
	} else {
	    set decB 0
	}
	set sumdec [expr {$decA + $decB + $carry}]
	if {$sumdec >= $base} {
	    set carry 1
	    incr sumdec -$base
	} else {
	    set carry 0
	}
	set result [string index $symbols $sumdec]$result
    }
    return $result
}  

}
Added library/util-string.tcl.








































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
192
193
194
195
196
# util-string.tcl --
#
#	This file implements package ::Utility::string, which  ...
#
# Copyright (c) 1997-1999 Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#

#package require NAME VERSION
package provide ::Utility::string 1.0; # SET VERSION

namespace eval ::Utility::string {;

namespace export -clear *

# string_ord --
#   ordinals of a string, returns list comprised of chars ordinalized
#	 ctype ord character
#		 Convert a character into its decimal numeric value
#	 ctype char number
#		 Converts the numeric value, string, to an ASCII character

# split - split by multi-char string

#	 translit inrange outrange string (mesh with ord AND char)
#		 Translate characters in string, changing characters
#		 occurring in inrange to the corresponding character in
#		 outrange. Inrange and outrange may be list of characters
#		 or a range in the form `A-M'.

# string_reverse --
#   reverses input string
# Arguments:
#   s		input string to reverse
# Returns:
#   string with chars reversed
#
;proc string_reverse s {
    if {[set i [string len $s]]} {
	while {$i} {append r [string index $s [incr i -1]]}
	return $r
    }
}
proc reverse s {
    set t ""
    set len [string len $s]
    for {} {$len >= 0} {} {
	append t [string index $s [incr len -1]]
    }
    return $t
}

# obfuscate --
#   If I describe it, it ruins it...
# Arguments:
#   s		input string
# Returns:
#   output
#
;proc obfuscate s {
    if {[set len [string len $s]]} {
	set i -1
	while {[incr i]<$len} {
	    set c [string index $s $i]
	    if {[regexp "\[\]\\\[ \{\}\t\n\"\]" $c]} {
		append r $c
	    } else {
		scan $c %c c
		append r \\[format %0.3o $c]
	    }
	}
	return $r
    }
}

# untabify --
#   removes tabs from a string, replacing with appropriate number of spaces
#   There should be no newlines in the string (do a split $str \n and pass
#   each line to this proc).
# Arguments:
#   str		input string
#   tablen	tab length, defaults to 8
# Returns:
#   string sans tabs
#
;proc untabify {str {tablen 8}} {
    set out {}
    while {[set i [string first "\t" $str]] != -1} {
	set j [expr {$tablen - ($i % $tablen)}]
	append out [string range $str 0 [incr i -1]][format %*s $j { }]
	set str [string range $str [incr i 2] end]
    }
    return $out$str
}

# tabify --
#   converts excess spaces to tab chars
# Arguments:
#   str		input string
#   tablen	tab length, defaults to 8
# Returns:
#   string with tabs replacing excess space where appropriate
#
;proc tabify {str {tablen 8}} {
    ## We must first untabify so that \t is not interpreted to be one char
    set str [untabify $str]
    set out {}
    while {[set i [string first { } $str]] != -1} {
	## Align i to the upper tablen boundary
	set i [expr {$i+$tablen-($i%$tablen)-1}]
	set s [string range $str 0 $i]
	if {[string match {* } $s]} {
	    append out [string trimright $s { }]\t
	} else {
	    append out $s
	}
	set str [string range $str [incr i] end]
    }
    return $out$str
}

# wrap_lines --
#   wraps text to a specific max line length
# Arguments:
#   txt		input text
#   len		desired max line length+1, defaults to 75
#   P		paragraph boundary chars, defaults to \n\n
#   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 <[email protected]>
    #
    # @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.
    # @a P:	Paragraph boundary chars, defaults to \n\n
    # @a P2:	Substitute for $P while processing, defaults to \254
    #		this char must not be in the input text
    #
    # @r Basically <a text>, but with changed newlines to
    # @r restrict the length of individual lines to at most
    # @r <a len> characters.

    # @n This procedure is not checked by the testsuite.

    # @i wrap, word wrap

    # Convert all instances of paragraph separator $P into $P2
    # Convert all newlines into spaces and initialize the result

    regsub -all $P $txt $P2 txt
    regsub -all "\n" $txt { } txt
    incr len -1
    set out {}

    # As long as the string is longer than the intended length of
    # lines in the result:

    while {[string len $txt]>$len} {
	# - Find position of last space in the part of the text
	#   which could a line in the result.

	# - We jump out of the loop if there is none and the whole
	#   text does not contain spaces anymore. In the latter case
	#   the rest of the text is one word longer than an intended
	#   line, we cannot avoid the longer line.

	set i [string last { } [string range $txt 0 $len]]
	if {$i == -1 && [set i [string first { } $txt]] == -1} { break }

	# Get the just fitting part of the text, remove any heading
	# and trailing spaces, then append it to the result string,
	# don't close it with a newline!

	append out [string trim [string range $txt 0 [incr i -1]]]\n

	# Shorten the text by the length of the processed part and
	# the space used to split it, then iterate.

	set txt [string range $txt [incr i 2] end]
    }
    regsub -all $P2 $out$txt $P txt
    return $txt
}

}; # end of namespace ::Utility::string
Added library/util-tk.tcl.














































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
# util-tk.tcl --
#
#	This file implements package ::Utility::tk, which  ...
#
# Copyright (c) 1997-8 Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require Tk
package require ::Utility
package provide ::Utility::tk 1.0

namespace eval ::Utility::tk {;

proc highlight args {}
proc highlight_dialog args {}

namespace export -clear *

## PROBLEM HERE
## 
## Only uncomment one of the following namespace import lines
##

## This is what I theoretically need, but it causes the Abort in
## regular wish.  This works for wish with TCL_MEM_DEBUG.
#namespace import -force ::Utility::get_opts ::Utility::highlight

## This works, but is essentially useless in my situation
#namespace import -force ::Utility::expand::* ::Utility::dump::*

## This works too, but is silly
#after idle [namespace code [list namespace import -force \
	::Utility::highlight ::Utility::get_opts]]

## This causes constant Bus Error on startup with regular wish
## but the Abort with debugging wish.
#namespace import -force ::Utility::*

## The abort message mentioned above is:

#DeleteImportedCmd: did not find cmd in real cmd's list of import references
#Abort

## If I try loading the above interactively as opposed to the tour at
## command line, I get a seg fault instead of a bus error.

##
## YOU CAN IGNORE THE REST
##

# warn --
#
#   Simple warning alias to ease programming
#
# Arguments:
#   msg		The warning message to display
# Results:
#   Returns nothing important.
#
proc warn {msg} {
    bell
    tk_dialog .__warning Warning $msg warning 0 OK
}

## Centers the canvas around points x & y
##
## Unoptimized, this looks like:
##    set xtenth [expr .10 * [winfo width $w]]
##    set ytenth [expr .10 * [winfo height $w]]
##    set X [expr [winfo width $w] / 2]
##    set Y [expr [winfo height $w] / 2]
##    set x1 [expr round(($x-$X)/$xtenth)]
##    set y1 [expr round(($y-$Y)/$ytenth)]
##    $w xview scroll $x1 units
##    $w yview scroll $y1 units
##
proc canvas_center {w x y} {
    $w xview scroll [expr {round(10.0*$x/[winfo width $w]-5)}] units
    $w yview scroll [expr {round(10.0*$y/[winfo height $w]-5)}] units
}

## "see" method alternative for canvas
## Aligns the named item as best it can in the middle of the screen
## Behavior depends on whether -scrollregion is set
##
## c    - a canvas widget
## item - a canvas tagOrId
proc canvas_see {c item} {
    set box [$c bbox $item]
    if {[string match {} $box]} return
    if {[string match {} [$c cget -scrollregion]]} {
	## People really should set -scrollregion you know...
	foreach {x y x1 y1} $box {
	    set x [expr {round(2.5*($x1+$x)/[winfo width $c])}]
	    set y [expr {round(2.5*($y1+$y)/[winfo height $c])}]
	}
	$c xview moveto 0
	$c yview moveto 0
	$c xview scroll $x units
	$c yview scroll $y units
    } else {
	## If -scrollregion is set properly, use this
	foreach {x y x1 y1} $box {top btm} [$c yview] {left right} [$c xview] \
		{p q xmax ymax} [$c cget -scrollregion] {
	    set xpos [expr {(($x1+$x)/2.0)/$xmax - ($right-$left)/2.0}]
	    set ypos [expr {(($y1+$y)/2.0)/$ymax - ($btm-$top)/2.0}]
	}
	$c xview moveto $xpos
	$c yview moveto $ypos
    }
}

## Set cursor of widget $w and its descendants to $cursor
## Ignores {} cursors
proc cursor_set {w cursor} {
    variable CURSOR
    if {[string compare {} [set CURSOR($w) [$w cget -cursor]]]} {
	$w config -cursor $cursor
    } else {
	unset CURSOR($w)
    }
    foreach child [winfo children $w] { cursor_set $child $cursor }
}

## Restore cursor based on CURSOR($w) for $w and its descendants
## $cursor is the default cursor (if none was cached)
proc cursor_restore {w {cursor {}}} {
    variable CURSOR
    if {[info exists CURSOR($w)]} {
	$w config -cursor $CURSOR($w)
    } else {
	$w config -cursor $cursor
    }
    foreach child [winfo children $w] { cursor_restore $child $cursor }
}

# highlight --
#    searches in text widget for $str and highlights it
#    If $str is empty, it just deletes any highlighting
#    This really belongs in ::Utility::tk
# Arguments:
#   w			text widget
#   str			string to search for
#   -nocase		specifies to be case insensitive
#   -regexp		specifies that $str is a pattern
#   -tag   tagId	name of tag in text widget
#   -color color	color of tag in text widget
# Results:
#   Returns ...
#
;proc highlight {w str args} {
    $w tag remove __highlight 1.0 end
    array set opts {
	-nocase	0
	-regexp	0
	-tag	__highlight
	-color	yellow
    }
    set args [::Utility::get_opts opts $args {-nocase 0 -regexp 0 -tag 1 -color 1}]
    if {[string match {} $str]} return
    set pass {}
    if {$opts(-nocase)} { append pass "-nocase " }
    if {$opts(-regexp)} { append pass "-regexp " }
    $w tag configure $opts(-tag) -background $opts(-color)
    $w mark set $opts(-tag) 1.0
    while {[string compare {} [set ix [eval $w search $pass -count numc -- \
	    [list $str] $opts(-tag) end]]]} {
	$w tag add $opts(-tag) $ix ${ix}+${numc}c
	$w mark set $opts(-tag) ${ix}+1c
    }
    catch {$w see $opts(-tag).first}
    return [expr {[llength [$w tag ranges $opts(-tag)]]/2}]
}

# highlight_dialog --
#
#   creates minimal dialog interface to highlight
#
# Arguments:
#   w	text widget
#   str	optional seed string for HIGHLIGHT(string)
# Results:
#   Returns null.
#
proc highlight_dialog {w {str {}}} {
    variable HIGHLIGHT

    set namesp [namespace current]
    set var ${namesp}::HIGHLIGHT
    set base $w.__highlight
    if {![winfo exists $base]} {
	toplevel $base
	wm withdraw $base
	wm title $base "Find String"

	pack [frame $base.f] -fill x -expand 1
	label $base.f.l -text "Find:"
	entry $base.f.e -textvariable ${var}($w,string)
	pack [frame $base.opt] -fill x
	checkbutton $base.opt.c -text "Case Sensitive" \
		-variable ${var}($w,nocase)
	checkbutton $base.opt.r -text "Use Regexp" -variable ${var}($w,regexp)
	pack $base.f.l -side left
	pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
	pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
	pack [frame $base.btn] -fill both
	button $base.btn.fnd -text "Find" -width 6
	button $base.btn.clr -text "Clear" -width 6
	button $base.btn.dis -text "Dismiss" -width 6
	eval pack [winfo children $base.btn] -padx 4 -pady 2 \
		-side left -fill both

	focus $base.f.e

	bind $base.f.e <Return> [list $base.btn.fnd invoke]
	bind $base.f.e <Escape> [list $base.btn.dis invoke]
    }
    ## FIX namespace
    $base.btn.fnd config -command [namespace code \
	    "highlight [list $w] \[set ${var}($w,string)\] \
	    \[expr {\[set ${var}($w,nocase)\]?{}:{-nocase}}] \
	    \[expr {\[set ${var}($w,regexp)\]?{-regexp}:{}}] \
	    -tag __highlight -color [list yellow]"]
    $base.btn.clr config -command \
	    "[list $w] tag remove __highlight 1.0 end;\
	    set [list ${var}($w,string)] {}"
    $base.btn.dis config -command \
	    "[list $w] tag remove __highlight 1.0 end;\
	    wm withdraw [list $base]"
    if {[string compare {} $str]} {
	set ${var}($w,string) $str
	$base.btn.fnd invoke
    }

    if {[string compare normal [wm state $base]]} {
	wm deiconify $base
    } else {
	raise $base
    }
    $base.f.e select range 0 end
}


}; # end namespace ::Utility::Tk
Added library/util-tools.tcl.














































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
112
113
114
115
116
117
118
119
# util-tools.tcl --
#
#	This file implements package ::Utility::tools, which
#	contain Unix tools type commands in Tcl
#
# Copyright (c) 1998 Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require ::Utility
package provide ::Utility::tools 1.0

namespace eval ::Utility::tools {;

namespace export -clear tools*
namespace import -force ::Utility::*

proc tools {cmd args} {
    set prefix [namespace current]::tools_
    if {[string match {} [set arg [info commands $prefix$cmd]]]} {
	set arg [info commands $prefix$cmd*]
    }
    set result {}
    set code ok
    switch [llength $arg] {
	1 { set code [catch {uplevel $arg $args} result] }
	0 {
	    set arg [info commands $prefix*]
	    regsub -all $prefix $arg {} arg
	    return -code error "unknown [lindex [info level 0] 0] type\
		    \"$cmd\", must be one of: [join [lsort $arg] {, }]"
	}
	default {
	    regsub -all $prefix $arg {} arg
	    return -code error "ambiguous type \"$cmd\",\
		    could be one of: [join [lsort $arg] {, }]"
	}
    }
    return -code $code [string trimright $result \n]
}

# tools_grep --
#   cheap grep routine
# Arguments:
#   exp		regular expression to look for
#   args	files to search in
# Returns:
#   list of lines that in files that matched $exp
#
;proc tools_grep {exp args} {
    if 0 {
	## To be implemented
	-count -nocase -number -names -reverse -exact
    }
    if {[string match {} $args]} return
    set output {}
    foreach file [eval glob $args] {
	set fid [open $file]
	foreach line [split [read $fid] \n] {
	    if {[regexp $exp $line]} { lappend output $line }
	}
	close $fid
    }
    return $output
}

# tools_touch --
#   touch command in Tcl, only sets to the current time
# Arguments:
#   args	the files to touch
# Results:
#   Returns ...
#
;proc tools_touch args {
    foreach f $args {
	if {[file exists $f]} {
	    # use lstat in case it is a link
	    # otherwise it is the same as stat
	    file lstat $f fstat
	    if {$fstat(size) == 0} {
		set fid [open $f w+]
	    } else {
		set fid [open $f a+]
		fconfigure $fid -translation binary
		# read and rewrite the last byte only
		seek $fid -1 end
		set c [read $fid 1]
		seek $fid -1 current
		puts -nonewline $fid $c
	    }
	} else {
	    set fid [open $f w+]
	}
	close $fid
    }
}

proc file_uniq {infile {outfile stdout}} {
    set ifid [open $infile]
    if {![regexp {std(out|err)} $outfile]} {
	set ofid [open $outfile w]
    } else {
	set ofid $outfile
    }
    while {[gets $ifid line] != -1} {
	if {![info exists array($line)]} {
	    set array($line) {}
	    puts $ofid $line
	}
    }
    close $ifid
    if {[string compare $ofid $outfile]} {
	close $ofid
    }
}

}; # end of namespace ::Utility::tools
Added library/util.tcl.










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
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
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
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
614
615
616
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
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
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
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
# util.tcl --
#
#	This file implements package ::Utility, which  ...
#
# Copyright (c) 1997-1999 Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

## The provide goes first to prevent the recursive provide/require
## loop for subpackages
package provide ::Utility 1.0

## This assumes that all util-*.tcl files are in the same directory
if {[lsearch -exact $auto_path [file dirname [info script]]]==-1} {
    lappend auto_path [file dirname [info script]]
}

namespace eval ::Utility {;

## Protos
namespace export -clear *

proc get_opts args {}
proc get_opts2 args {}
proc lremove args {}
proc lrandomize args {}
proc lunique args {}
proc luniqueo args {}
proc line_append args {}
proc echo args {}
proc alias args {}
proc which args {}
proc ls args {}
proc dir args {}
proc fit_format args {}
proc validate args {}
proc allow_null_elements args {}
proc deny_null_elements args {}

}; # end of ::Utility namespace prototype headers

package require ::Utility::number
package require ::Utility::string
package require ::Utility::dump
package require ::Utility::expand
package require ::Utility::tools
package require ::Utility::tk

namespace eval ::Utility {;

foreach namesp [namespace children [namespace current]] {
    namespace import -force ${namesp}::*
}
# Vitus Wagner
proc xsplit [list str [list regexp "\[\t \r\n\]+"]] {
    set list  {}
    while {[regexp -indices -- $regexp $str match submatch]} {
        lappend list [string range $str 0 [expr [lindex $match 0] -1]]
        if {[lindex $submatch 0]>=0} {
            lappend list [string range $str [lindex $submatch 0]\
                    [lindex $submatch 1]] 
        }       
        set str [string range $str [expr [lindex $match 1]+1] end] 
    }
    lappend list $str
    return $list
}
# psource --
#
#   ADD COMMENTS HERE
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
;proc psource {file namesp {import *}} {
    uplevel \#0 [subst {
	source $file
	namespace import -force ${namesp}::$import
    }
    ]
}

# get_opts --
#
#   Processes -* named options, with or w/o possible associated value
#   and returns remaining args
#
# Arguments:
#   var		variable into which option values should be stored
#   arglist	argument list to parse
#   optlist	list of valid options with default value
#   typelist	optional list of option types that can be used to
#		validate incoming options
#   nocomplain	whether to complain about unknown -switches (0 - default)
#		or not (1)
# Results:
#   Returns unprocessed arguments.
#
;proc get_opts {var arglist optlist {typelist {}} {nocomplain 0}} {
    upvar 1 $var data

    if {![llength $optlist] || ![llength $arglist]} { return $arglist }
    array set opts $optlist
    array set types $typelist
    set i 0
    while {[llength $arglist]} {
	set key [lindex $arglist $i]
	if {[string match -- $key]} {
	    set arglist [lreplace $arglist $i $i]
	    break
	} elseif {![string match -* $key]} {
	    break
	} elseif {[string match {} [set akey [array names opts $key]]]} {
	    set akey [array names opts ${key}*]
	}
	switch [llength $akey] {
	    0		{ ## oops, no keys matched
		if {$nocomplain} {
		    incr i
		} else {
		    return -code error "unknown switch '$key', must be:\
			    [join [array names opts] {, }]"
		}
	    }
	    1		{ ## Perfect, found just the right key
		if {$opts($akey)} {
		    set val [lrange $arglist [expr {$i+1}] \
			    [expr {$i+$opts($akey)}]]
		    set arglist [lreplace $arglist $i [expr {$i+$opts($akey)}]]
		    if {[info exists types($akey)] && \
			    ([string compare none $types($akey)] && \
			    ![validate $types($akey) $val])} {
			return -code error "the value for \"$akey\" is not in\
				proper $types($akey) format"
		    }
		    set data($akey) $val
		} else {
		    set arglist [lreplace $arglist $i [expr {$i+$opts($akey)}]]
		    set data($akey) 1
		}
	    }
	    default	{ ## Oops, matches too many possible keys
		return -code error "ambiguous option \"$key\",\
			must be one of: [join $akey {, }]"
	    }
	}
    }
    return $arglist
}

# get_opts2 --
#
#   Process options into an array.  -- short-circuits the processing
#
# Arguments:
#   var		variable into which option values should be stored
#   arglist	argument list to parse
#   optlist	list of valid options with default value
#   typelist	optional list of option types that can be used to
#		validate incoming options
# Results:
#   Returns unprocessed arguments.
#
;proc get_opts2 {var arglist optlist {typelist {}}} {
    upvar 1 $var data

    if {![llength $optlist] || ![llength $arglist]} { return $arglist }
    array set data $optlist
    array set types $typelist
    foreach {key val} $arglist {
	if {[string match -- $key]} {
	    set arglist [lreplace $arglist 0 0]
	    break
	}
	if {[string match {} [set akey [array names data $key]]]} {
	    set akey [array names data ${key}*]
	}
	switch [llength $akey] {
	    0		{ ## oops, no keys matched
		return -code error "unknown switch '$key', must be:\
			[join [array names data] {, }]"
	    }
	    1		{ ## Perfect, found just the right key
		if {[info exists types($akey)] && \
			![validate $types($akey) $val]} {
		    return -code error "the value for \"$akey\" is not in\
			    proper $types($akey) format"
		}
		set data($akey) $val
	    }
	    default	{ ## Oops, matches too many possible keys
		return -code error "ambiguous option \"$key\",\
			must be one of: [join $akey {, }]"
	    }
	}
	set arglist [lreplace $arglist 0 1]
    }
    return $arglist
}

# lintersect --
#   returns list of items that exist only in all lists
# Arguments:
#   args	lists
# Returns:
#   The list of common items, uniq'ed, order independent
#
proc lintersect {args} {
    set len [llength $args]

    if {$len <= 1} {
	return [lindex $args 0]
    }

    array set a {}

    foreach l [lindex $args 0] {
	set a($l) 1
    }

    foreach list [lrange $args 1 end] {
	foreach l $list {
	    if {[info exists a($l)]} {
		incr a($l)
	    }
	}
    }

    set retval {}
    foreach l [array names a] {
	if {$a($l) == $len} {
	    lappend retval $l
	}
    }
    return $retval
}

# lremove --
#   remove items from a list
# Arguments:
#   ?-all?	remove all instances of said item
#   list	list to remove items from
#   args	items to remove
# Returns:
#   The list with items removed
#
;proc lremove {args} {
    set all 0
    if {[string match \-a* [lindex $args 0]]} {
	set all 1
	set args [lreplace $args 0 0]
    }
    set l [lindex $args 0]
    foreach i [join [lreplace $args 0 0]] {
	if {[set ix [lsearch -exact $l $i]] == -1} continue
	set l [lreplace $l $ix $ix]
	if {$all} {
	    while {[set ix [lsearch -exact $l $i]] != -1} {
		set l [lreplace $l $ix $ix]
	    }
	}
    }
    return $l
}

# lrandomize --
#   randomizes a list
# Arguments:
#   ls		list to randomize
# Returns:
#   returns list in with randomized items
#
;proc lrandomize ls {
    set res {}
    while {[string compare $ls {}]} {
	set i [randrng [llength $ls]]
	lappend res [lindex $ls $i]
	set ls [lreplace $ls $i $i]
    }
    return $res
}

# lunique --
#   order independent list unique proc, not most efficient.
# Arguments:
#   ls		list of items to make unique
# Returns:
#   list of only unique items, order not defined
#
;proc lunique ls {
    foreach l $ls {set ($l) x}
    return [array names {}]
}

# lunique --
#   order independent list unique proc.  most efficient, but requires
#   __LIST never be an element of the input list
# Arguments:
#   __LIST	list of items to make unique
# Returns:
#   list of only unique items, order not defined
#
;proc lunique __LIST {
    if {[llength $__LIST]} {
	foreach $__LIST $__LIST break
	unset __LIST
	return [info locals]
    }
}

# luniqueo --
#   order dependent list unique proc
# Arguments:
#   ls		list of items to make unique
# Returns:
#   list of only unique items in same order as input
#
;proc luniqueo ls {
    set rs {}
    foreach l $ls {
	if {[info exist ($l)]} { continue }
	lappend rs $l
	set ($l) {}
    }
    return $rs
}

# lunion --
#   order independent list union proc.  most efficient, but requires
#   ___ never be an element of the input list
# Arguments:
#   args	lists to union
# Returns:
#   list of only unique items among all the lists, order not defined
#
;proc lunion {args} {
    if {[llength $args]} {
	foreach ___ $args {
	    if {[llength $___]} {
		foreach $___ {!} {break}
	    }
	}
	unset ___ args
	return [info locals]
    }
}

# luniono --
#   order dependent list union proc.  most efficient, but requires
#   ___ never be an element of the input list
# Arguments:
#   args	lists to union
# Returns:
#   list of only unique items among all the lists, order not defined
#
;proc luniono {args} {
    if {[llength $args]} {
	set rs {}
	foreach ls $args {
	    foreach l $ls {
		if {[info exists ($l)]} {continue}
		lappend rs $l
		set ($l) {}
	    }
	}
	return $rs
    }
}

# every --
#   Cheap rescheduler
# every <time> cmd;	# cmd is a one arg (cmd as list)
#	schedules $cmd to be run every <time> 1000ths of a sec
#	IOW, [every 1000 "puts hello"] prints hello every sec
# every cancel cmd
#	cancels a cmd if it was specified
# every info ?pattern?
#	returns info about commands in pairs of "time cmd time cmd ..."
#
proc every {time {cmd {}}} {
    global EVERY
    if {[regexp {^[0-9]+$} $time]} {
	# A time was given, so schedule a command to run every $time msecs
	if {[string compare {} $cmd]} {
	    set EVERY(TIME,$cmd) $time
	    set EVERY(CMD,$cmd) [after $time [list every eval $cmd]]
	} else {
	    return -code error "wrong \# args: should be \"[lindex [info level 0] 0] <number> command"
	}
	return
    }
    switch $time {
	eval {
	    if {[info exists EVERY(TIME,$cmd)]} {
		uplevel \#0 $cmd
		set EVERY(CMD,$cmd) [after $EVERY(TIME,$cmd) \
			[list every eval $cmd]]
	    }
	}
	cancel {
	    if {[string match "all" $cmd]} {
		foreach i [array names EVERY CMD,*] {
		    after cancel $EVERY($i)
		    unset EVERY($i) EVERY(TIME,[string range $i 4 end])
		}
	    } elseif {[info exists EVERY(CMD,$cmd)]} {
		after cancel $EVERY(CMD,$cmd)
		unset EVERY(CMD,$cmd) EVERY(TIME,$cmd)
	    }
	}
	info {
	    set result {}
	    foreach i [array names EVERY TIME,$cmd*] {
		set cmd [string range $i 5 end]
		lappend result $EVERY($i) $cmd
	    }
	    return $result
	}
	default {
	    return -code error "bad option \"$time\": must be cancel, info or a number"
	}
    }
    return
}

# best_match --
#   finds the best unique match in a list of names
#   The extra $e in this argument allows us to limit the innermost loop a
#   little further.
# Arguments:
#   l		list to find best unique match in
#   e		currently best known unique match
# Returns:
#   longest unique match in the list
#
;proc best_match {l {e {}}} {
    set ec [lindex $l 0]
    if {[llength $l]>1} {
	set e  [string length $e]; incr e -1
	set ei [string length $ec]; incr ei -1
	foreach l $l {
	    while {$ei>=$e && [string first $ec $l]} {
		set ec [string range $ec 0 [incr ei -1]]
	    }
	}
    }
    return $ec
}

# randline --
#   returns a random line from a file.  not good on large files
#   because it sucks the entire file into memory.
# Arguments:
#   file	filename to get line from
# Results:
#   Returns a line as a string
#
;proc randline {file} {
    set fid [open $file]
    set data [split [read $fid] \n]
    close $fid
    return [lindex $data [randrng [llength $data]]]
}

# randrng --
#   gets random number within input range
# Arguments:
#   rng		range to limit output to
# Returns:
#   returns random number within range 0..$rng
;proc randrng {rng} {
    return [expr {int($rng * rand())}]
}

# line_append --
#   appends a string to the end of every line of data from a file
# Arguments:
#   file	file to get data from
#   stuff	stuff to append to each line
# Returns:
#   file data with stuff appended to each line
#
;proc line_append {file stuff} {
    set fid [open $file]
    set data [read $fid]
    catch {close $fid}
    return [join [split $data \n] $stuff\n]
}


# alias --
#   akin to the csh alias command
# Arguments:
#   newcmd	(optional) command to bind alias to
#   args	command and args being aliased
# Returns:
#   If called with no args, then it dumps out all current aliases
#   If called with one arg, returns the alias of that arg (or {} if none)
#
;proc alias {{newcmd {}} args} {
    if {[string match {} $newcmd]} {
	set res {}
	foreach a [interp aliases] {
	    lappend res [list $a -> [interp alias {} $a]]
	}
	return [join $res \n]
    } elseif {[string match {} $args]} {
	interp alias {} $newcmd
    } else {
	eval interp alias [list {} $newcmd {}] $args
    }
}

# echo --
#   Relaxes the one string restriction of 'puts'
# Arguments:
#   args	any number of strings to output to stdout
# Returns:
#   Outputs all input to stdout
#
;proc echo args { puts [concat $args] }

# which --
#   tells you where a command is found
# Arguments:
#   cmd		command name
# Returns:
#   where command is found (internal / external / unknown)
#
;proc which cmd {
    ## FIX - make namespace friendly
    set lcmd [list $cmd]
    if {
	[string compare {} [uplevel info commands $lcmd]] ||
	([uplevel auto_load $lcmd] &&
	[string compare {} [uplevel info commands $lcmd]])
    } {
	set ocmd [uplevel namespace origin $lcmd]
	# First check to see if it is an alias
	# This requires two checks because interp aliases doesn't
	# canonically return fully (un)qualified names
	set aliases [interp aliases]
	if {[lsearch -exact $aliases $ocmd] > -1} {
	    set result "$cmd: aliased to \"[alias $ocmd]\""
	} elseif {[lsearch -exact $aliases $cmd] > -1} {
	    set result "$cmd: aliased to \"[alias $cmd]\""
	} elseif {[string compare {} [uplevel info procs $lcmd]] || \
		([string match ?*::* $ocmd] && \
		[string compare {} [namespace eval \
		[namespace qualifiers $ocmd] \
		[list info procs [namespace tail $ocmd]]]])} {
	    # Here we checked if the proc that has been imported before
	    # deciding it is a regular command
	    set result "$cmd: procedure $ocmd"
	} else {
	    set result "$cmd: command"
	}
	global auto_index
	if {[info exists auto_index($cmd)]} {
	    # This tells you where the command MIGHT have come from -
	    # not true if the command was redefined interactively or
	    # existed before it had to be auto_loaded.  This is just
	    # provided as a hint at where it MAY have come from
	    append result " ($auto_index($cmd))"
	}
	return $result
    } elseif {[string compare {} [auto_execok $cmd]]} {
	return [auto_execok $cmd]
    } else {
	return -code error "$cmd: command not found"
    }
}

# ls --
#   mini-ls equivalent (directory lister)
# Arguments:
#   ?-all?	list hidden files as well (Unix dot files)
#   ?-long?	list in full format "permissions size date filename"
#   ?-full?	displays / after directories and link paths for links
#   args	names/glob patterns of directories to list
# Returns:
#   a directory listing
#
interp alias {} ::Utility::dir {} namespace inscope ::Utility ls
;proc ls {args} {
    array set s {
	-all 0 -full 0 -long 0
	0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx
    }
    set args [get_opts s $args [array get s -*]]
    set sep [string trim [file join . .] .]
    if {[string match {} $args]} { set args . }
    foreach arg $args {
	if {[file isdir $arg]} {
	    set arg [string trimr $arg $sep]$sep
	    if {$s(-all)} {
		lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]]
	    } else {
		lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]]
	    }
	} else {
	    lappend out [list [file dirname $arg]$sep \
		    [lsort [glob -nocomplain -- $arg]]]
	}
    }
    if {$s(-long)} {
	global tcl_platform
	set old [clock scan {1 year ago}]
	switch -exact -- $tcl_platform(os) {
	    windows	{ set fmt "%-5s %8d %s %s\n" }
	    default	{ set fmt "%s %-8s %-8s %8d %s %s\n" }
	}
	foreach o $out {
	    set d [lindex $o 0]
	    if {[llength $out]>1} { append res $d:\n }
	    foreach f [lindex $o 1] {
		file lstat $f st
		array set st [file attrib $f]
		set f [file tail $f]
		if {$s(-full)} {
		    switch -glob $st(type) {
			dir* { append f $sep }
			link { append f " -> [file readlink $d$sep$f]" }
			fifo { append f | }
			default { if {[file exec $d$sep$f]} { append f * } }
		    }
		}
		switch -exact -- $st(type) {
		    file	{ set mode - }
		    fifo	{ set mode p }
		    default	{ set mode [string index $st(type) 0] }
		}
		set cfmt [expr {$st(mtime)>$old?{%b %d %H:%M}:{%b %d  %Y}}]
		switch -exact -- $tcl_platform(os) {
		    windows	{
			# RHSA
			append mode $st(-readonly) $st(-hidden) \
				$st(-system) $st(-archive)
			append res [format $fmt $mode $st(size) \
				[clock format $st(mtime) -format $cfmt] $f]
		    }
		    macintosh	{
			append mode $st(-readonly) $st(-hidden)
			append res [format $fmt $mode $st(-creator) \
				$st(-type) $st(size) \
				[clock format $st(mtime) -format $cfmt] $f]
		    }
		    default	{ ## Unix is our default platform type
			foreach j [split [format %o \
				[expr {$st(mode)&0777}]] {}] {
			    append mode $s($j)
			}
			append res [format $fmt $mode $st(-owner) $st(-group) \
				$st(size) \
				[clock format $st(mtime) -format $cfmt] $f]
		    }
		}
	    }
	    append res \n
	}
    } else {
	foreach o $out {
	    set d [lindex $o 0]
	    if {[llength $out]>1} { append res $d:\n }
	    set i 0
	    foreach f [lindex $o 1] {
		if {[string len [file tail $f]] > $i} {
		    set i [string len [file tail $f]]
		}
	    }
	    set i [expr {$i+2+$s(-full)}]
	    ## Assume we have at least 70 char cols
	    set j [expr {70/$i}]
	    set k 0
	    foreach f [lindex $o 1] {
		set f [file tail $f]
		if {$s(-full)} {
		    switch -glob [file type $d$sep$f] {
			d* { append f $sep }
			l* { append f @ }
			default { if {[file exec $d$sep$f]} { append f * } }
		    }
		}
		append res [format "%-${i}s" $f]
		if {[incr k]%$j == 0} {set res [string trimr $res]\n}
	    }
	    append res \n\n
	}
    }
    return [string trimr $res]
}

# fit_format --
# This procedure attempts to format a value into a particular format string.
#
# Arguments:
# format	- The format to fit
# val		- The value to be validated
#
# Returns:	0 or 1 (whether it fits the format or not)
#
# Switches:
# -fill ?var?	- Default values will be placed to fill format to spec
#		  and the resulting value will be placed in variable 'var'.
#		  It will equal {} if the match invalid
#		  (doesn't work all that great currently)
# -best ?var?	- 'Fixes' value to fit format, placing best correct value
#		  in variable 'var'.  If current value is ok, the 'var'
#		  will equal it, otherwise it removes chars from the end
#		  until it fits the format, then adds any fixed format
#		  chars to value.  Can be slow (recursive tkFormat op).
# -strict	- Value must be an exact match for format (format && length)
# --		- End of switches

;proc fit_format {args} {
    set fill {}; set strict 0; set best {}; set result 1;
    set name [lindex [info level 0] 0]
    while {[string match {-*} [lindex $args 0]]} {
	switch -- [string index [lindex $args 0] 1] {
	    b {
		set best [lindex $args 1]
		set args [lreplace $args 0 1]
	    }
	    f {
		set fill [lindex $args 1]
		set args [lreplace $args 0 1]
	    }
	    s {
		set strict 1
		set args [lreplace $args 0 0]
	    }
	    - {
		set args [lreplace $args 0 0]
		break
	    }
	    default {
		return -code error "bad $name option \"[lindex $args 0]\",\
			must be: -best, -fill, -strict, or --"
	    }
	}
    }

    if {[llength $args] != 2} {
	return -code error "wrong \# args: should be \"$name ?-best varname?\
		?-fill varname? ?-strict? ?--? format value\""
    }
    set format [lindex $args 0]
    set val    [lindex $args 1]

    set flen [string length $format]
    set slen [string length $val]
    if {$slen > $flen} {set result 0}
    if {$strict} { if {$slen != $flen} {set result 0} }

    if {$result} {
	set regform {}
	foreach c [split $format {}] {
	    set special 0
	    if {[string match {[0AaWzZ]} $c]} {
		set special 1
		switch $c {
		    0	{set fmt {[0-9]}}
		    A	{set fmt {[A-Z]}}
		    a	{set fmt {[a-z]}}
		    W	{set fmt "\[ \t\r\n\]"}
		    z	{set fmt {[A-Za-z]}}
		    Z	{set fmt {[A-Za-z0-9]}}
		}
	    } else {
		set fmt $c
	    }
	    
	}
	echo $regform $format $val
	set result [string match $regform $val]
    }

    if [string compare $fill {}] {
	upvar $fill fvar
	if {$result} {
	    set fvar $val[string range $format $i end]
	} else {
	    set fvar {}
	}
    }

    if [string compare $best {}] {
	upvar $best bvar
	set bvar $val
	set len [string length $bvar]
	if {!$result} {
	    incr len -2
	    set bvar [string range $bvar 0 $len]
	    # Remove characters until it's in valid format
	    while {$len > 0 && ![tkFormat $format $bvar]} {
		set bvar [string range $bvar 0 [incr len -1]]
	    }
	    # Add back characters that are fixed
	    while {($len<$flen) && ![string match \
		    {[0AaWzZ]} [string index $format [incr len]]]} {
		append bvar [string index $format $len]
	    }
	} else {
	    # If it's already valid, at least we can add fixed characters
	    while {($len<$flen) && ![string match \
		    {[0AaWzZ]} [string index $format $len]]} {
		append bvar [string index $format $len]
		incr len
	    }
	}
    }

    return $result
}


# validate --
# This procedure validates particular types of numbers/formats
#
# Arguments:
# type		- The type of validation (alphabetic, alphanumeric, date,
#		hex, integer, numeric, real).  Date is always strict.
# val		- The value to be validated
#
# Returns:	0 or 1 (whether or not it resembles the type)
#
# Switches:
# -incomplete	enable less precise (strict) pattern matching on number
#		useful for when the number might be half-entered
#
# Example use:	validate real 55e-5
#		validate -incomplete integer -505
#

;proc validate {args} {
    if {[string match [lindex $args 0]* "-incomplete"]} {
	set strict 0
	set opt *
	set args [lreplace $args 0 0]
    } else {
	set strict 1
	set opt +
    }

    if {[llength $args] != 2} {
	return -code error "wrong \# args: should be\
		\"[lindex [info level 0] 0] ?-incomplete? type value\""
    } else {
	set type [lindex $args 0]
	set val  [lindex $args 1]
    }

    ## This is a big switch for speed reasons
    switch -glob -- $type {
	alphab*	{ # alphabetic
	    return [regexp -nocase "^\[a-z\]$opt\$" $val]
	}
	alphan* { # alphanumeric
	    return [regexp -nocase "^\[a-z0-9\]$opt\$" $val]
	}
	b*	{ # boolean - would be nice if it were more than 0/1
	    return [regexp "^\[01\]$opt\$" $val]
	}
	d*	{ # date - always strict
	    return [expr {![catch {clock scan $val}]}]
	}
	h*	{ # hexadecimal
	    return [regexp -nocase "^(0x)?\[0-9a-f\]$opt\$" $val]
	}
	i*	{ # integer
	    return [regexp "^\[-+\]?\[0-9\]$opt\$" $val]
	}
	n*	{ # numeric
	    return [regexp "^\[0-9\]$opt\$" $val]
	}
	rea*	{ # real
	    return [regexp -nocase [expr {$strict
	    ?{^[-+]?([0-9]+\.?[0-9]*|[0-9]*\.?[0-9]+)(e[-+]?[0-9]+)?$}
	    :{^[-+]?[0-9]*\.?[0-9]*([0-9]\.?e[-+]?[0-9]*)?$}}] $val]
	}
	reg*	{ # regexp
	    return [expr {![catch {regexp $val {}}]}]
	}
	val*	{ # value, any valid number type
	    return [expr {![catch {expr {0+$val}}]}]
	}
	l*	{ # list
	    return [expr {![catch {llength $val}]}]
	}
	w*	{ # widget
	    return [winfo exists $val]
	}
	default {
	    return -code error "bad [lindex [info level 0] 0] type \"$type\":\
		    \nmust be [join [lsort {alphabetic alphanumeric date \
		    hexadecimal integer numeric real value \
		    list boolean}] {, }]"
	}
    }
    return
}

# allow_null_elements --
#
#   Sets up a read trace on an array to allow reading any value
#   and ensure that some default exists
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
;proc allow_null_elements {array {default {}}} {
    uplevel 1 [list trace variable $array r [list \
	    [namespace code ensure_default] $default]]
}

;proc ensure_default {val array idx op} {
    upvar $array var
    if {[array exists var]} {
	if {![info exists var($idx)]} {
	    set var($idx) $val
	}
    } elseif {![info exists var]} {
	set var $val
    }
}

# deny_null_elements --
#
#   ADD COMMENTS HERE
#
# Arguments:
#   args	comments
# Results:
#   Returns ...
#
;proc deny_null_elements {array {default {}}} {
    ## FIX: should use vinfo and remove any *ensure_default* read traces
    uplevel 1 [list trace vdelete $array r [list \
	    [namespace code ensure_default] $default]]
}


}; # end namespace ::Utility
Added library/ventry.tcl.
























































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
## self-validating entry widget
##
## Copyright 1997-8 Jeffrey Hobbs, [email protected], CADIX International
##
package require Widget 2.0
package provide Ventry 2.0

##------------------------------------------------------------------------
## PROCEDURE
##	ventry
##
## DESCRIPTION
##	Implements a self-validating entry widget
##
## ARGUMENTS
##	ventry <widget> ?options?
##
## OPTIONS
##
## -invalidcmd
##
##
## -validatecmd (-vcmd)
##
##
## -validate
##
##
## SUBSTITUTIONS
##
## %d	the type of validation (delete, insert, ...)
## %i	the index of the insert or delete
## %P	the potential new string value
## %s	the current value of the entry
## %S	the chars to be inserted or deleted
## %v	the value of -validate
## %W	the widget name
##
## METHODS
##
## validate
##
## BINDINGS
##	This works entirely off the textvariable, so no extra bindings
##	are required.
##
## NAMESPACE & STATE
##	The megawidget creates a global array with the classname, and a
## global array which is the name of each megawidget is created.  The latter
## array is deleted when the megawidget is destroyed.
##	Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used.
## Other procs that begin with $CLASSNAME are private.  For each widget,
## commands named .$widgetname and $CLASSNAME$widgetname are created.
##
##------------------------------------------------------------------------
## EXAMPLES:
## # A number only entry widget
## ventry .v -vcmd {regexp {^[-+]?[0-9]*$} %P} -validate key -invalidcmd bell
## # An entry widget limited to 8 chars
## ventry .l -vcmd {expr {[string length %P]<=8}} -validate key
##

# Create this to make sure there are registered in auto_mkindex
# these must come before the [widget create ...]
proc Ventry args {}
proc ventry args {}
widget create Ventry -type frame -base entry -components {
    label
} -options {
    {-bd		-borderwidth}
    {-borderwidth	borderWidth	BorderWidth	0}
    {-invalidcmd	invalidCmd	InvalidCmd	bell}
    {-labeltext		labelText	LabelText	{}}
    {-labelwidth	labelWidth	Width		0}
    {-labelanchor	ALIAS label -anchor labelAnchor Anchor}
    {-labelfont		ALIAS label -font labelFont Font}
    {-labelforeground	ALIAS label -foreground labelForeground Foreground}
    {-relief		relief		Relief		flat}
    {-validatecmd	-vcmd}
    {-vcmd		validateCmd	ValidateCmd	{}}
    {-validate		validate	Validate	none}
    {-textvariable	textVariable	TextVariable	{}}
}

namespace eval ::Widget::Ventry {;

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

    set data(flags) {}

    grid $data(label) $data(entry) -in $w -sticky ns
    grid configure $data(entry) -sticky news
    grid columnconfig $w 1 -weight 1
    grid rowconfig $w 0 -weight 1
    grid remove $data(label)

    bind $data(entry) <FocusIn>  [namespace code [list focus $w in]]
    bind $data(entry) <FocusOut> [namespace code [list focus $w out]]
}

;proc configure {w args} {
    upvar \#0 [namespace current]::$w data
    set truth {^(1|yes|true|on)$}
    foreach {key val} $args {
	switch -- $key {
	    -borderwidth - -relief { .$w configure $key $val }
	    -labelanchor	{ $data(label) configure -anchor $val }
	    -labelfont		{ $data(label) configure -font $val }
	    -labelforeground	{ $data(label) configure -foreground $val }
	    -labeltext		{
		$data(label) configure -text $val
		if {[string compare {} $val]} {
		    grid $data(label)
		} else {
		    grid remove $data(label)
		}
	    }
	    -labelwidth		{ $data(label) configure -width $val }
	    -validate {
		if {![regexp {^(focus|focusin|focusout|all|none|key)$} $val]} {
		    return -code error "Invalid validation type \"$val\""
		}
	    }
	    -textvariable	{ $data(basecmd) configure -textvariable $val }
	}
	set data($key) $val
    }
}

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

    if {[regexp {^(all|key)$} $data(-validate)]} {
	set index [$data(basecmd) index $index]
	set cur [$data(basecmd) get]
	set new [string range $cur 0 [expr $index-1]]$string[string range $cur $index end]
	if {[catch {validate $w $string $new $index insert} err]} {
	    return
	}
    }
    return [uplevel [list $data(basecmd) insert $index $string]]
}

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

    if {[regexp {^(all|key)$} $data(-validate)]} {
	set first [$data(basecmd) index $first]
	if {[string match {} $last]} {
	    set last [expr $first+1]
	} else {
	    set last [$data(basecmd) index $last]
	}
	set cur [$data(basecmd) get]
	set new [string range $cur 0 [expr $first-1]][string range $cur $last end]
	if {[catch {validate $w [string range $cur $first \
		[expr $last-1]] $new $first delete} err]} {
	    return
	}
    }
    return [uplevel [list $data(basecmd) delete $first] $last]
}

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

    set old $data(-validate)
    set data(-validate) all
    set code [catch {validate $w {} [$data(basecmd) get] \
	    [$data(basecmd) index insert] validate} err]
    set data(-validate) $old
    return [expr {$code?0:1}]
}

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

    if {[regexp "^(all|focus($which)?)\$" $data(-validate)]} {
	catch {validate $w {} [$data(basecmd) get] \
		[$data(basecmd) index insert] focus$which}
    }
}

;proc validate {w str new index type} {
    upvar \#0 [namespace current]::$w data

    if {[string match {} $data(-vcmd)] || \
	    [string match none $data(-validate)] || \
	    [string match VALIDATING $data(flags)]} {
	return
    }
    set data(flags) VALIDATING

    set cmd [substitute $w $data(-vcmd) $str $new $index $type]

    set code [catch {uplevel \#0 $cmd} result]
    if {$code != 0 && $code != 2} {
	global errorInfo
	append errorInfo "\n\t(in $w validation command)"
	bgerror $result
	set code 1
    } else {
	set val [regexp {^(1|yes|true|on)$} $result]
	if $val { set code 0 } else { set code 3 }
	set result {}
    }

    # If e->validate has become VALIDATE_NONE during the validation,
    # it means that a loop condition almost occured.  Do not allow
    # this validation result to finish.
    if {[string match none $data(-validate)] || \
	    [string match VALIDATE_VAR $data(flags)]} {
	set code 1
    }
    # If validate will return ERROR, then disallow further validations
    # Otherwise, if it didn't accept the new string (returned TCL_BREAK)
    # then eval the invalidCmd (if it's set)
    if {$code} {
	if {$code == 3} {
	    ## TCL_BREAK
	    if {[string compare {} $data(-invalidcmd)]} {
		set cmd [substitute $w $data(-invalidcmd) \
			$str $new $index $type]
		if {[catch {uplevel \#0 $cmd} result]} {
		    global errorInfo
		    append errorInfo "\n\t(in $w validation command)"
		    bgerror $result
		    set code 1
		    set data(-validate) none
		}
	    }
	} else {
	    set data(-validate) none
	}
    }
    set data(flags) {}
    return -code $code $result
}

;proc substitute {w cmd change newstr index type} {
    upvar \#0 [namespace current]::$w data

    set old $cmd
    set i [string first % $cmd]
    if {$i < 0} { return $old }
    set new [string range $cmd 0 [incr i -1]]
    while 1 {
	set c [string index $cmd [incr i 2]]
	switch $c {
	    d		{ append new $type }
	    i		{ append new $index }
	    P		{ append new [list $newstr] }
	    s		{ append new [list [$data(basecmd) get]] }
	    S		{ append new [list $change] }
	    v		{ append new $data(-validate) }
	    W		{ append new [list $w] }
	    {}		{ append new %; return $new }
	    default	{ append new [list $c] }
	}
	set cmd [string range $cmd [incr i] end]
	set i [string first % $cmd]
	if {$i < 0} { return $new$cmd }
	append new [string range $cmd 0 [incr i -1]]
    }
}

}; #end namespace ::Widget::Ventry
Added library/widget.tcl.






















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
109
110
111
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
186
187
188
189
190
191
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
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
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
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
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
614
615
616
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
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
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
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
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
## Barebones requirements for creating and querying megawidgets
##
## Copyright 1997-9 Jeffrey Hobbs, [email protected]
##
## Initiated: 5 June 1997
## Last Update: 1999

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

package require Tk 8
package require ::Utility
package provide Widget 2.0

##------------------------------------------------------------------------
## PROCEDURE
##	widget
##
## DESCRIPTION
##	Implements and modifies megawidgets
##
## ARGUMENTS
##	widget <subcommand> ?<args>?
##
## <classname> specifies a global array which is the name of a class and
## contains options database information.
##
## add classname option ?args?
##	adds ...
##
## create classname
##	creates the widget class $classname based on the specifications
##	in the global array of the same name
##
## classes ?pattern?
##	returns the classes created with this command.
##
## delete classname option ?args?
##	deletes ...
##
## value classname key
##	returns the value of a key from the special class variable.
##
## OPTIONS
##	none
##
## RETURNS
##	the namespace for the widget class (::Widget::$CLASS)
##
## NAMESPACE & STATE
##	The namespace Widget is used, with public procedure "widget".
##
##------------------------------------------------------------------------
##
## For a well-commented example for creating a megawidget using this method,
## see the ScrolledText example at the end of the file.
##
## SHORT LIST OF IMPORTANT THINGS TO KNOW:
##
## Specify the "type", "base", & "components" keys of the $CLASS global array
##
## In the $w global array that is created for each instance of a megawidget,
## the following keys are set by the "widget create $CLASS" procedure:
##   "base", "basecmd", "container", "class", any option specified in the
##   $CLASS array, each component will have a named key
##
## The following public methods are created for you in the namespace:
##   cget	::Widget::$CLASS::_cget
##   configure	::Widget::$CLASS::_configure
##   destruct	::Widget::$CLASS::_destruct
##   subwidget	::Widget::$CLASS::_subwidget
## The following additional submethods are required (you write them):
##   construct	::Widget::$CLASS::construct
##   configure	::Widget::$CLASS::configure
## You may want the following that will be called when appropriate:
##   init	::Widget::$CLASS::init
##	(after initial configuration)
##   destruct	::Widget::$CLASS::destruct
##	(called first thing when widget is being destroyed)
##
## All ::Widget::$CLASS::_* commands are considered public methods.  The
## megawidget routine will match your options and methods on a unique
## substring basis.
##
## 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
	    return -code error "unknown [lindex [info level 0] 0] method\
		    \"$cmd\", must be one of: [join [lsort $arg] {, }]"
	}
	default {
	    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
	return -code error "ambiguous method \"$subcmd\",\
		could be one of: [join $arg {, }]"
    } elseif {[catch {uplevel [list $data(basecmd) $subcmd] $args} err]} {
	return -code error $err
    } else {
	return $err
    }
}

## 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
	array set data \[list $dataArrayVals\]
	## Create all the base and component widgets
	$baseConstruction

	## Allow for an initialization proc to be eval'ed
	## The user must create one
	if {\[catch {construct \$w} err\]} {
	    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 -code error \"megawidget initialization error: \$err\"
	}

	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
    ## 2. -optname dbname dbcname value
    ## 3. -optname ALIAS componenttype option
    ## 4. -optname ALIAS componenttype option dbname dbcname
    foreach optdef $optlist {
	foreach {optname alias type opt dbname dbcname} $optdef break
	set len [llength $optdef]
	switch -glob -- $alias {
	    -*	{
		if {$len != 2} {
		    return -code error "wrong \# args for option alias,\
			    must be: {-aliasoptioname -realoptionname}"
		}
		set options($optname) $alias
		continue
	    }
	    ALIAS - alias {
		if {$len != 4 && $len != 6} {
		    return -code error "wrong \# args for ALIAS, must be:\
			    {-optionname ALIAS componenttype option\
			    ?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\""
			}
			catch {destroy $w}
		    } else {
			set config($type) [. configure]
		    }
		}
		set i [lsearch -glob $config($type) "$opt\[ \t\]*"]
		if {$i == -1} {
		    return -code error "cannot create alias \"$o\" to $CLASS\
			    component type \"$type\" option \"$opt\":\
			    option does not exist"
		}
		if {$len==4} {
		    foreach {opt dbname dbcname def} \
			    [lindex $config($type) $i] break
		} elseif {$len==6} {
		    set def [lindex [lindex $config($type) $i] 3]
		}
	    }
	    default {
		if {$len != 4} {
		    return -code error "wrong \# args for option \"$optdef\",\
			    must be:\
			    {-optioname databasename databaseclass defaultval}"
		}
		foreach {optname dbname dbcname def} $optdef break
	    }
	}
	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
    namespace eval $namesp {
	variable class
	variable options
	variable components
	variable widgets
	catch {unset class}
	catch {unset options}
	catch {unset components}
	catch {unset widgets}
    }
    upvar \#0 ${namesp}::class class \
	    ${namesp}::options options \
	    ${namesp}::components components \
	    ${namesp}::widgets widgets

    get_opts2 classopts $args {
	-type		frame
	-base		frame
	-components	{}
	-options	{}
    } {
	-type		list
	-base		list
	-components	list
	-options	list
    }

    ## First check to see that their container type is valid
    ## I'd like to include canvas and text, but they don't accept the
    ## -class option yet, which would thus require some voodoo on the
    ## part of the constructor to make it think it was the proper class
    if {![regexp ^([join $CONTAINERS |])\$ $classopts(-type)]} {
	return -code error "invalid class container type\
		\"$classopts(-type)\", must be one of:\
		[join $CONTAINERS {, }]"
    }

    ## 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)
    }

    ## Ensure that the class is set correctly
    array set class [list class $CLASS \
	    base $classopts(-base) \
	    type $classopts(-type)]

    set widgets($class(type)) 0

    if {![info exists classopts(-components)]} {
	set classopts(-components) {}
    }
    foreach compdef $classopts(-components) {
	set opts {}
	switch [llength $compdef] {
	    0 continue
	    1 { set name [set type [set wid $compdef]] }
	    2 {
		set type [lindex $compdef 0]
		set name [set wid [lindex $compdef 1]]
	    }
	    default {
		foreach {type name wid opts} $compdef break
		set opts [string trim $opts]
	    }
	}
	if {[info exists components($name)]} {
	    return -code error "component name \"$name\" occurs twice\
		    in $CLASS class"
	}
	if {[info exists widnames($wid)]} {
	    return -code error "widget name \"$wid\" occurs twice\
		    in $CLASS class"
	}
	if {[regexp {(^[\.A-Z]| |\.$)} $wid]} {
	    return -code error "invalid $CLASS class component widget\
		    name \"$wid\": it cannot begin with a capital letter,\
		    contain spaces or start or end with a \".\""
	}
	if {[string match *.* $wid] && \
		![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) {}]
	# What should we really do here?
	#set components($class(base)) $components(base)
	set widgets($class(base)) 0
	if {![regexp ^([join $CONTAINERS |])\$ $class(base)] && \
		![info exists components($class(base))]} {
	    set components($class(base)) $components(base)
	}
    }

    ## Process options
    add_options $namesp $CLASS $classopts(-options)

    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

    ## Both $CLASS and [string tolower $CLASS] commands will be created
    ## in the global namespace
    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 {
		if {\[llength \$args\]} {
		    foreach sub [list $comps] {
			catch {uplevel 1 \[list \$data(\$sub)\] \$args}
		    }
		} else {
		    return [list $comps]
		}
	    }
	    [join $comps { - }] {
		if {\[llength \$args\]} {
		    return \[uplevel 1 \[list \$data(\$widget)\] \$args\]
		} else {
		    return \$data(\$widget)
		}
	    }
	    default {
		return -code error \"No \$data(class) subwidget \\\"\$widget\\\",\
			must be one of: [join $comps {, }]\"
	    }
	}
    }]

    ## 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\",\
		    must be one of: [join $arg {, }]"
	} elseif {[catch {$data(basecmd) cget $args} err]} {
	    return -code error $err
	} 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} {
		return -code error "ambiguous option \"$args\",\
			must be one of: [join $arg {, }]"
	    } elseif {[catch {$data(basecmd) configure $args} err]} {
		return -code error $err
	    } else {
		return $err
	    }
	} elseif {$num} {
	    ## Request for several config options to be set
	    ## Group the {key val} pairs to be distributed
	    if {$num&1} {
		set last [lindex $args end]
		set args [lrange $args 0 [incr num -2]]
	    }
	    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]
		    break
		} else {
		    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
#	    }
	    if {[llength $cmdargs] && [catch \
		    {uplevel [list $data(basecmd)] configure $cmdargs} err]} {
		return -code error $err
	    }
	    if {[info exists ambarg]} {
		return -code error "ambiguous option \"[lindex $ambarg 0]\",\
			must be one of: [join [lindex $ambarg 1] {, }]"
	    }
	    if {[info exists last]} {
		return -code error "value for \"$last\" missing"
	    }
	} else {
	    ## Request for all config options to be printed out
	    foreach opt [$data(basecmd) configure] {
		set opts([lindex $opt 0]) [lrange $opt 1 end]
	    }
	    foreach opt [array names options] {
		if {[string match -* $options($opt)]} {
		    set opts($opt) [string range $options($opt) 1 end]
		} else {
		    set opts($opt) "$options($opt) [list $data($opt)]"
		}
	    }
	    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} {
	    return 0
	} elseif {$value == 1} {
	    return [winfo viewable $w]
	} else {
	    set value [uplevel #0 $value $w]
	    if {$value != ""} {
		return $value
	    }
	}
    }
    if {![winfo viewable $w]} {
	return 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
    catch {tkFocusOK .}; # we want this auto-loaded
    interp alias {} tkFocusOK {} widget tkFocusOK
}

########################################################################
########################## EXAMPLES ####################################
########################################################################

########################################################################
########################## ScrolledText ################################
########################################################################

##------------------------------------------------------------------------
## PROCEDURE
##	scrolledtext
##
## DESCRIPTION
##	Implements a ScrolledText mega-widget
##
## ARGUMENTS
##	scrolledtext <window pathname> <options>
##
## OPTIONS
##	(Any text widget option may be used in addition to these)
##
## -autoscrollbar TCL_BOOLEAN			DEFAULT: 1
##	Whether to have dynamic or static scrollbars.
##
## RETURNS: the window pathname
##
## METHODS/SUBCOMMANDS
##	These are the subcmds that an instance of this megawidget recognizes.
##	Aside from those listed here, it accepts subcmds that are valid for
##	text widgets.
##
## subwidget widget
##	Returns the true widget path of the specified widget.  Valid
##	widgets are text, xscrollbar, yscrollbar.
##
## BINDINGS (in addition to default widget bindings)
##
## NAMESPACE & STATE
##	The megawidget creates a global array with the classname, and a
## global array which is the name of each megawidget is created.  The latter
## array is deleted when the megawidget is destroyed.
##	Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used.
## Other procs that begin with $CLASSNAME are private.  For each widget,
## commands named .$widgetname and $CLASSNAME$widgetname are created.
##
## EXAMPLE USAGE:
##
## pack [scrolledtext .st -width 40 -height 10] -fill both -exp 1
##
##------------------------------------------------------------------------

## Each widget created will also have a global array created by the
## instantiation procedure that is the name of the widget (represented
## as $w below).  There three special key names in the $CLASS array:
##
## -type
##    the type of base container we want to use (frame or toplevel).
##    This would default to frame.  This widget will be created for us
##    by the constructor function.  The $w array will have a "container"
##    key that will point to the exact widget name.
##
## -base
##   the base widget type for this class.  This key is optional and
##   represents what kind of widget will be the base for the class. This
##   way we know what default methods/options you'll have.  If not
##   specified, it defaults to the container type.  
##   To the global $w array, the key "basecmd" will be added by the widget
##   instantiation function to point to a new proc that will be the direct
##   accessor command for the base widget ("text" in the case of the
##   ScrolledText megawidget).  The $w "base" key will be the valid widget
##   name (for passing to [winfo] and such), but "basecmd" will be the
##   valid direct accessor function
##
## -components
##   the component widgets of the megawidget.  This is a list of tuples
##   (ie: {{listbox listbox} {scrollbar yscrollbar} {scrollbar xscrollbar}})
##   where each item is in the form {widgettype name}.  These components
##   will be created before the $CLASS::construct proc is called and the $w
##   array will have keys with each name pointing to the appropriate
##   widget in it.  Use these keys to access your subwidgets.  It is from
##   this component list and the base and type about that the subwidget
##   method is created.
##  
## -options
##   A list of lists, this specifies the
##   options that this megawidget handles.  The value can either be a
##   3-tuple list of the form {databaseName databaseClass defaultValue}, or
##   it can be one element matching -*, which means this key (say -bd) is
##   an alias for the option specified in the value (say -borderwidth)
##   which must be specified fully somewhere else in the class array.
##
## If the value is a list beginning with "ALIAS", then the option is derived
## from a component of the megawidget.  The form of the value must be a list
## with the elements:
##	{ALIAS componenttype option ?databasename databaseclass?}
## An example of this would be inheriting a label components anchor:
##	{ALIAS label -anchor labelAnchor Anchor}
## If the databasename is not specified, it determines the final options
## database info from the component and uses the components default value.
## Otherwise, just the components default value is used.
##
## The $w array will be populated by the instantiation procedure with the
## default values for all the specified $CLASS options.
##

# Create this to make sure there are registered in auto_mkindex
# these must come before the [widget create ...]
proc ScrolledText args {}
proc scrolledtext args {}
widget create ScrolledText -type frame -base text -components {
    {base text text {-xscrollcommand [list $data(xscrollbar) set] \
	    -yscrollcommand [list $data(yscrollbar) set]}}
    {scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1 \
	    -command [list $w xview]}}
    {scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1 \
	    -command [list $w yview]}}
} -options {
    {-autoscrollbar autoScrollbar AutoScrollbar 1}
}

## Then we "create" the widget.  This makes all the necessary default widget
## routines.  It creates the public accessor functions ($CLASSNAME and
## [string tolower $CLASSNAME]) as well as the public cget, configure, destroy
## and subwidget methods.  The cget and configure commands work like the
## regular Tk ones.  The destroy method is superfluous, as megawidgets will
## respond properly to [destroy $widget] (the Tk destroy command).
## The subwidget method has the following form:
##
##   $widget subwidget name
##	name	- the component widget name
##   Returns the widget patch to the component widget name.
##   Allows the user direct access to your subwidgets.
##
## THE USER SHOULD PROVIDE AT LEAST THE FOLLOWING:
##
## $NAMESPACE::construct {w}		=> return value ignored
##	w	- the widget name, also the name of the global data array
## This procedure is called by the public accessor (instantiation) proc
## right after creating all component widgets and populating the global $w
## array with all the default option values, the "base" key and the key
## names for any other components.  The user should then grid/pack all
## subwidgets into $w.  At this point, the initial configure has not
## occured, so the widget options are all the default.  If this proc
## errors, so does the main creation routine, returning your error.
##
## $NAMESPACE::configure {w args}	=> return ignored (should be empty)
##	w	- the widget name, also the name of the global data array
##	args	- a list of key/vals (already verified to exist)
## The user should process the key/vals however they require  If this
## proc errors, so does the main creation routine, returning your error.
##
## THE FOLLOWING IS OPTIONAL:
##
## $NAMESPACE::init {w}			=> return value ignored
##	w	- the widget name, also the name of the global data array
## This procedure is called after the public configure routine and after
## the "basecmd" key has been added to the $w array.  Ideally, this proc
## would be used to do any widget specific one-time initialization.
##
## $NAMESPACE::destruct {w}		=> return ignored (should be empty)
##	w	- the widget name, also the name of the global data array
## A default destroy handler is provided that cleans up after the megawidget
## (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