2001-06-25  Jeff Hobbs  <[email protected]>

	* initial import of widget code into tcllib repository

		   * 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.

#!/bin/sh
# The next line is executed by /bin/sh, but not tcl \
exec wish $0 ${1+"[email protected]"}

# 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

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

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

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

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

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

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

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

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

# 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

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

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

# 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

# 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

# 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

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
    }