diff options
Diffstat (limited to 'modules/tclsci/tcl/utils')
| -rwxr-xr-x | modules/tclsci/tcl/utils/Balloon.tcl | 87 | ||||
| -rwxr-xr-x | modules/tclsci/tcl/utils/Combobox.tcl | 2203 | ||||
| -rwxr-xr-x | modules/tclsci/tcl/utils/Notebook.tcl | 279 |
3 files changed, 2569 insertions, 0 deletions
diff --git a/modules/tclsci/tcl/utils/Balloon.tcl b/modules/tclsci/tcl/utils/Balloon.tcl new file mode 100755 index 000000000..c941f181d --- /dev/null +++ b/modules/tclsci/tcl/utils/Balloon.tcl @@ -0,0 +1,87 @@ +############################################################################## +# $Id: Balloon.tcl,v 1.1 2004/06/28 15:01:00 leray Exp $ +# +# balloon.tcl - procedures used by balloon help +# +# Copyright (C) 1996-1997 Stewart Allen +# +# This is part of vtcl source code Adapted for +# general purpose by Daniel Roche <dan@lectra.com> +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +############################################################################## +# + +bind Bulle <Enter> { + set Bulle(set) 0 + set Bulle(first) 1 + set Bulle(id) [after 500 {balloon %W $Bulle(%W) %X %Y}] +} + +bind Bulle <Button> { + set Bulle(first) 0 + kill_balloon +} + +bind Bulle <Leave> { + set Bulle(first) 0 + kill_balloon +} + +bind Bulle <Motion> { + if {$Bulle(set) == 0} { + after cancel $Bulle(id) + set Bulle(id) [after 500 {balloon %W $Bulle(%W) %X %Y}] + } +} + +proc set_balloon {target message} { + global Bulle + set Bulle($target) $message + bindtags $target "[bindtags $target] Bulle" +} + +proc kill_balloon {} { + global Bulle + after cancel $Bulle(id) + if {[winfo exists .balloon] == 1} { + destroy .balloon + } + set Bulle(set) 0 +} + +proc balloon {target message {cx 0} {cy 0} } { + global Bulle + if {$Bulle(first) == 1 } { + set Bulle(first) 2 + if { $cx == 0 && $cy == 0 } { + set x [expr [winfo rootx $target] + ([winfo width $target]/2)] + set y [expr [winfo rooty $target] + [winfo height $target] + 4] + } else { + set x [expr $cx + 4] + set y [expr $cy + 4] + } + toplevel .balloon -bg black + wm overrideredirect .balloon 1 + label .balloon.l \ + -text $message -relief flat \ + -bg #ffffaa -fg black -padx 2 -pady 0 -anchor w + pack .balloon.l -side left -padx 1 -pady 1 + wm geometry .balloon +${x}+${y} + set Bulle(set) 1 + } +} + diff --git a/modules/tclsci/tcl/utils/Combobox.tcl b/modules/tclsci/tcl/utils/Combobox.tcl new file mode 100755 index 000000000..cd52b9f7b --- /dev/null +++ b/modules/tclsci/tcl/utils/Combobox.tcl @@ -0,0 +1,2203 @@ +# Copyright (c) 1998-2003, Bryan Oakley +# All Rights Reservered +# +# Bryan Oakley +# oakley@bardo.clearlight.com +# +# combobox v2.3 August 16, 2003 +# +# a combobox / dropdown listbox (pick your favorite name) widget +# written in pure tcl +# +# this code is freely distributable without restriction, but is +# provided as-is with no warranty expressed or implied. +# +# thanks to the following people who provided beta test support or +# patches to the code (in no particular order): +# +# Scott Beasley Alexandre Ferrieux Todd Helfter +# Matt Gushee Laurent Duperval John Jackson +# Fred Rapp Christopher Nelson +# Eric Galluzzo Jean-Francois Moine Oliver Bienert +# +# A special thanks to Martin M. Hunt who provided several good ideas, +# and always with a patch to implement them. Jean-Francois Moine, +# Todd Helfter and John Jackson were also kind enough to send in some +# code patches. +# +# ... and many others over the years. + +package require Tk 8.0 +package provide combobox 2.3 + +namespace eval ::combobox { + + # this is the public interface + namespace export combobox + + # these contain references to available options + variable widgetOptions + + # these contain references to available commands and subcommands + variable widgetCommands + variable scanCommands + variable listCommands +} + +# ::combobox::combobox -- +# +# This is the command that gets exported. It creates a new +# combobox widget. +# +# Arguments: +# +# w path of new widget to create +# args additional option/value pairs (eg: -background white, etc.) +# +# Results: +# +# It creates the widget and sets up all of the default bindings +# +# Returns: +# +# The name of the newly create widget + +proc ::combobox::combobox {w args} { + variable widgetOptions + variable widgetCommands + variable scanCommands + variable listCommands + + # perform a one time initialization + if {![info exists widgetOptions]} { + Init + } + + # build it... + eval Build $w $args + + # set some bindings... + SetBindings $w + + # and we are done! + return $w +} + + +# ::combobox::Init -- +# +# Initialize the namespace variables. This should only be called +# once, immediately prior to creating the first instance of the +# widget +# +# Arguments: +# +# none +# +# Results: +# +# All state variables are set to their default values; all of +# the option database entries will exist. +# +# Returns: +# +# empty string + +proc ::combobox::Init {} { + variable widgetOptions + variable widgetCommands + variable scanCommands + variable listCommands + variable defaultEntryCursor + + array set widgetOptions [list \ + -background {background Background} \ + -bd -borderwidth \ + -bg -background \ + -borderwidth {borderWidth BorderWidth} \ + -buttonbackground {buttonBackground Background} \ + -command {command Command} \ + -commandstate {commandState State} \ + -cursor {cursor Cursor} \ + -disabledbackground {disabledBackground DisabledBackground} \ + -disabledforeground {disabledForeground DisabledForeground} \ + -dropdownwidth {dropdownWidth DropdownWidth} \ + -editable {editable Editable} \ + -elementborderwidth {elementBorderWidth BorderWidth} \ + -fg -foreground \ + -font {font Font} \ + -foreground {foreground Foreground} \ + -height {height Height} \ + -highlightbackground {highlightBackground HighlightBackground} \ + -highlightcolor {highlightColor HighlightColor} \ + -highlightthickness {highlightThickness HighlightThickness} \ + -image {image Image} \ + -listvar {listVariable Variable} \ + -maxheight {maxHeight Height} \ + -opencommand {opencommand Command} \ + -relief {relief Relief} \ + -selectbackground {selectBackground Foreground} \ + -selectborderwidth {selectBorderWidth BorderWidth} \ + -selectforeground {selectForeground Background} \ + -state {state State} \ + -takefocus {takeFocus TakeFocus} \ + -textvariable {textVariable Variable} \ + -value {value Value} \ + -width {width Width} \ + -xscrollcommand {xScrollCommand ScrollCommand} \ + ] + + + set widgetCommands [list \ + bbox cget configure curselection \ + delete get icursor index \ + insert list scan selection \ + xview select toggle open \ + close subwidget \ + ] + + set listCommands [list \ + delete get \ + index insert size \ + ] + + set scanCommands [list mark dragto] + + # why check for the Tk package? This lets us be sourced into + # an interpreter that doesn't have Tk loaded, such as the slave + # interpreter used by pkg_mkIndex. In theory it should have no + # side effects when run + if {[lsearch -exact [package names] "Tk"] != -1} { + + ################################################################## + #- this initializes the option database. Kinda gross, but it works + #- (I think). + ################################################################## + + # the image used for the button... + if {$::tcl_platform(platform) == "windows"} { + image create bitmap ::combobox::bimage -data { + #define down_arrow_width 12 + #define down_arrow_height 12 + static char down_arrow_bits[] = { + 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, + 0xfc,0xf1,0xf8,0xf0,0x70,0xf0,0x20,0xf0, + 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00; + } + } + } else { + image create bitmap ::combobox::bimage -data { + #define down_arrow_width 15 + #define down_arrow_height 15 + static char down_arrow_bits[] = { + 0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80, + 0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0,0x83, + 0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80, + 0x00,0x80,0x00,0x80,0x00,0x80 + } + } + } + + # compute a widget name we can use to create a temporary widget + set tmpWidget ".__tmp__" + set count 0 + while {[winfo exists $tmpWidget] == 1} { + set tmpWidget ".__tmp__$count" + incr count + } + + # get the scrollbar width. Because we try to be clever and draw our + # own button instead of using a tk widget, we need to know what size + # button to create. This little hack tells us the width of a scroll + # bar. + # + # NB: we need to be sure and pick a window that doesn't already + # exist... + scrollbar $tmpWidget + set sb_width [winfo reqwidth $tmpWidget] + set bbg [$tmpWidget cget -background] + destroy $tmpWidget + + # steal options from the entry widget + # we want darn near all options, so we'll go ahead and do + # them all. No harm done in adding the one or two that we + # don't use. + entry $tmpWidget + foreach foo [$tmpWidget configure] { + # the cursor option is special, so we'll save it in + # a special way + if {[lindex $foo 0] == "-cursor"} { + set defaultEntryCursor [lindex $foo 4] + } + if {[llength $foo] == 5} { + set option [lindex $foo 1] + set value [lindex $foo 4] + option add *Combobox.$option $value widgetDefault + + # these options also apply to the dropdown listbox + if {[string compare $option "foreground"] == 0 \ + || [string compare $option "background"] == 0 \ + || [string compare $option "font"] == 0} { + option add *Combobox*ComboboxListbox.$option $value \ + widgetDefault + } + } + } + destroy $tmpWidget + + # these are unique to us... + option add *Combobox.elementBorderWidth 1 widgetDefault + option add *Combobox.buttonBackground $bbg widgetDefault + option add *Combobox.dropdownWidth {} widgetDefault + option add *Combobox.openCommand {} widgetDefault + option add *Combobox.cursor {} widgetDefault + option add *Combobox.commandState normal widgetDefault + option add *Combobox.editable 1 widgetDefault + option add *Combobox.maxHeight 10 widgetDefault + option add *Combobox.height 0 + } + + # set class bindings + SetClassBindings +} + +# ::combobox::SetClassBindings -- +# +# Sets up the default bindings for the widget class +# +# this proc exists since it's The Right Thing To Do, but +# I haven't had the time to figure out how to do all the +# binding stuff on a class level. The main problem is that +# the entry widget must have focus for the insertion cursor +# to be visible. So, I either have to have the entry widget +# have the Combobox bindtag, or do some fancy juggling of +# events or some such. What a pain. +# +# Arguments: +# +# none +# +# Returns: +# +# empty string + +proc ::combobox::SetClassBindings {} { + + # make sure we clean up after ourselves... + bind Combobox <Destroy> [list ::combobox::DestroyHandler %W] + + # this will (hopefully) close (and lose the grab on) the + # listbox if the user clicks anywhere outside of it. Note + # that on Windows, you can click on some other app and + # the listbox will still be there, because tcl won't see + # that button click + set this {[::combobox::convert %W -W]} + bind Combobox <Any-ButtonPress> "$this close" + bind Combobox <Any-ButtonRelease> "$this close" + + # this helps (but doesn't fully solve) focus issues. The general + # idea is, whenever the frame gets focus it gets passed on to + # the entry widget + bind Combobox <FocusIn> {::combobox::tkTabToWindow \ + [::combobox::convert %W -W].entry} + + # this closes the listbox if we get hidden + bind Combobox <Unmap> {[::combobox::convert %W -W] close} + + return "" +} + +# ::combobox::SetBindings -- +# +# here's where we do most of the binding foo. I think there's probably +# a few bindings I ought to add that I just haven't thought +# about... +# +# I'm not convinced these are the proper bindings. Ideally all +# bindings should be on "Combobox", but because of my juggling of +# bindtags I'm not convinced thats what I want to do. But, it all +# seems to work, its just not as robust as it could be. +# +# Arguments: +# +# w widget pathname +# +# Returns: +# +# empty string + +proc ::combobox::SetBindings {w} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + # juggle the bindtags. The basic idea here is to associate the + # widget name with the entry widget, so if a user does a bind + # on the combobox it will get handled properly since it is + # the entry widget that has keyboard focus. + bindtags $widgets(entry) \ + [concat $widgets(this) [bindtags $widgets(entry)]] + + bindtags $widgets(button) \ + [concat $widgets(this) [bindtags $widgets(button)]] + + # override the default bindings for tab and shift-tab. The + # focus procs take a widget as their only parameter and we + # want to make sure the right window gets used (for shift- + # tab we want it to appear as if the event was generated + # on the frame rather than the entry. + bind $widgets(entry) <Tab> \ + "::combobox::tkTabToWindow \[tk_focusNext $widgets(entry)\]; break" + bind $widgets(entry) <Shift-Tab> \ + "::combobox::tkTabToWindow \[tk_focusPrev $widgets(this)\]; break" + + # this makes our "button" (which is actually a label) + # do the right thing + bind $widgets(button) <ButtonPress-1> [list $widgets(this) toggle] + + # this lets the autoscan of the listbox work, even if they + # move the cursor over the entry widget. + bind $widgets(entry) <B1-Enter> "break" + + bind $widgets(listbox) <ButtonRelease-1> \ + "::combobox::Select [list $widgets(this)] \ + \[$widgets(listbox) nearest %y\]; break" + + bind $widgets(vsb) <ButtonPress-1> {continue} + bind $widgets(vsb) <ButtonRelease-1> {continue} + + bind $widgets(listbox) <Any-Motion> { + %W selection clear 0 end + %W activate @%x,%y + %W selection anchor @%x,%y + %W selection set @%x,%y @%x,%y + # need to do a yview if the cursor goes off the top + # or bottom of the window... (or do we?) + } + + # these events need to be passed from the entry widget + # to the listbox, or otherwise need some sort of special + # handling. + foreach event [list <Up> <Down> <Tab> <Return> <KP_Enter> <Escape> \ + <Next> <Prior> <Double-1> <1> <Any-KeyPress> \ + <FocusIn> <FocusOut>] { + bind $widgets(entry) $event \ + [list ::combobox::HandleEvent $widgets(this) $event] + } + + # like the other events, <MouseWheel> needs to be passed from + # the entry widget to the listbox. However, in this case we + # need to add an additional parameter + catch { + bind $widgets(entry) <MouseWheel> \ + [list ::combobox::HandleEvent $widgets(this) <MouseWheel> %D] + } +} + +# ::combobox::Build -- +# +# This does all of the work necessary to create the basic +# combobox. +# +# Arguments: +# +# w widget name +# args additional option/value pairs +# +# Results: +# +# Creates a new widget with the given name. Also creates a new +# namespace patterened after the widget name, as a child namespace +# to ::combobox +# +# Returns: +# +# the name of the widget + +proc ::combobox::Build {w args } { + variable widgetOptions + + if {[winfo exists $w]} { + error "window name \"$w\" already exists" + } + + # create the namespace for this instance, and define a few + # variables + namespace eval ::combobox::$w { + + variable ignoreTrace 0 + variable oldFocus {} + variable oldGrab {} + variable oldValue {} + variable options + variable this + variable widgets + + set widgets(foo) foo ;# coerce into an array + set options(foo) foo ;# coerce into an array + + unset widgets(foo) + unset options(foo) + } + + # import the widgets and options arrays into this proc so + # we don't have to use fully qualified names, which is a + # pain. + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + # this is our widget -- a frame of class Combobox. Naturally, + # it will contain other widgets. We create it here because + # we need it in order to set some default options. + set widgets(this) [frame $w -class Combobox -takefocus 0] + set widgets(entry) [entry $w.entry -takefocus 1] + set widgets(button) [label $w.button -takefocus 0] + + # this defines all of the default options. We get the + # values from the option database. Note that if an array + # value is a list of length one it is an alias to another + # option, so we just ignore it + foreach name [array names widgetOptions] { + if {[llength $widgetOptions($name)] == 1} continue + + set optName [lindex $widgetOptions($name) 0] + set optClass [lindex $widgetOptions($name) 1] + + set value [option get $w $optName $optClass] + set options($name) $value + } + + # a couple options aren't available in earlier versions of + # tcl, so we'll set them to sane values. For that matter, if + # they exist but are empty, set them to sane values. + if {[string length $options(-disabledforeground)] == 0} { + set options(-disabledforeground) $options(-foreground) + } + if {[string length $options(-disabledbackground)] == 0} { + set options(-disabledbackground) $options(-background) + } + + # if -value is set to null, we'll remove it from our + # local array. The assumption is, if the user sets it from + # the option database, they will set it to something other + # than null (since it's impossible to determine the difference + # between a null value and no value at all). + if {[info exists options(-value)] \ + && [string length $options(-value)] == 0} { + unset options(-value) + } + + # we will later rename the frame's widget proc to be our + # own custom widget proc. We need to keep track of this + # new name, so we'll define and store it here... + set widgets(frame) ::combobox::${w}::$w + + # gotta do this sooner or later. Might as well do it now + pack $widgets(button) -side right -fill y -expand no + pack $widgets(entry) -side left -fill both -expand yes + + # I should probably do this in a catch, but for now it's + # good enough... What it does, obviously, is put all of + # the option/values pairs into an array. Make them easier + # to handle later on... + array set options $args + + # now, the dropdown list... the same renaming nonsense + # must go on here as well... + set widgets(dropdown) [toplevel $w.top] + set widgets(listbox) [listbox $w.top.list] + set widgets(vsb) [scrollbar $w.top.vsb] + + pack $widgets(listbox) -side left -fill both -expand y + + # fine tune the widgets based on the options (and a few + # arbitrary values...) + + # NB: we are going to use the frame to handle the relief + # of the widget as a whole, so the entry widget will be + # flat. This makes the button which drops down the list + # to appear "inside" the entry widget. + + $widgets(vsb) configure \ + -borderwidth 1 \ + -command "$widgets(listbox) yview" \ + -highlightthickness 0 + + $widgets(button) configure \ + -background $options(-buttonbackground) \ + -highlightthickness 0 \ + -borderwidth $options(-elementborderwidth) \ + -relief raised \ + -width [expr {[winfo reqwidth $widgets(vsb)] - 2}] + + $widgets(entry) configure \ + -borderwidth 0 \ + -relief flat \ + -highlightthickness 0 + + $widgets(dropdown) configure \ + -borderwidth $options(-elementborderwidth) \ + -relief sunken + + $widgets(listbox) configure \ + -selectmode browse \ + -background [$widgets(entry) cget -bg] \ + -yscrollcommand "$widgets(vsb) set" \ + -exportselection false \ + -borderwidth 0 + + +# trace variable ::combobox::${w}::entryTextVariable w \ +# [list ::combobox::EntryTrace $w] + + # do some window management foo on the dropdown window + wm overrideredirect $widgets(dropdown) 1 + wm transient $widgets(dropdown) [winfo toplevel $w] + wm group $widgets(dropdown) [winfo parent $w] + wm resizable $widgets(dropdown) 0 0 + wm withdraw $widgets(dropdown) + + # this moves the original frame widget proc into our + # namespace and gives it a handy name + rename ::$w $widgets(frame) + + # now, create our widget proc. Obviously (?) it goes in + # the global namespace. All combobox widgets will actually + # share the same widget proc to cut down on the amount of + # bloat. + proc ::$w {command args} \ + "eval ::combobox::WidgetProc $w \$command \$args" + + + # ok, the thing exists... let's do a bit more configuration. + if {[catch "::combobox::Configure [list $widgets(this)] [array get options]" error]} { + catch {destroy $w} + error "internal error: $error" + } + + return "" + +} + +# ::combobox::HandleEvent -- +# +# this proc handles events from the entry widget that we want +# handled specially (typically, to allow navigation of the list +# even though the focus is in the entry widget) +# +# Arguments: +# +# w widget pathname +# event a string representing the event (not necessarily an +# actual event) +# args additional arguments required by particular events + +proc ::combobox::HandleEvent {w event args} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + upvar ::combobox::${w}::oldValue oldValue + + # for all of these events, if we have a special action we'll + # do that and do a "return -code break" to keep additional + # bindings from firing. Otherwise we'll let the event fall + # on through. + switch $event { + + "<MouseWheel>" { + if {[winfo ismapped $widgets(dropdown)]} { + set D [lindex $args 0] + # the '120' number in the following expression has + # it's genesis in the tk bind manpage, which suggests + # that the smallest value of %D for mousewheel events + # will be 120. The intent is to scroll one line at a time. + $widgets(listbox) yview scroll [expr {-($D/120)}] units + } + } + + "<Any-KeyPress>" { + # if the widget is editable, clear the selection. + # this makes it more obvious what will happen if the + # user presses <Return> (and helps our code know what + # to do if the user presses return) + if {$options(-editable)} { + $widgets(listbox) see 0 + $widgets(listbox) selection clear 0 end + $widgets(listbox) selection anchor 0 + $widgets(listbox) activate 0 + } + } + + "<FocusIn>" { + set oldValue [$widgets(entry) get] + } + + "<FocusOut>" { + if {![winfo ismapped $widgets(dropdown)]} { + # did the value change? + set newValue [$widgets(entry) get] + if {$oldValue != $newValue} { + CallCommand $widgets(this) $newValue + } + } + } + + "<1>" { + set editable [::combobox::GetBoolean $options(-editable)] + if {!$editable} { + if {[winfo ismapped $widgets(dropdown)]} { + $widgets(this) close + return -code break; + + } else { + if {$options(-state) != "disabled"} { + $widgets(this) open + return -code break; + } + } + } + } + + "<Double-1>" { + if {$options(-state) != "disabled"} { + $widgets(this) toggle + return -code break; + } + } + + "<Tab>" { + if {[winfo ismapped $widgets(dropdown)]} { + ::combobox::Find $widgets(this) 0 + return -code break; + } else { + ::combobox::SetValue $widgets(this) [$widgets(this) get] + } + } + + "<Escape>" { +# $widgets(entry) delete 0 end +# $widgets(entry) insert 0 $oldValue + if {[winfo ismapped $widgets(dropdown)]} { + $widgets(this) close + return -code break; + } + } + + "<Return>" { + # did the value change? + set newValue [$widgets(entry) get] + if {$oldValue != $newValue} { + CallCommand $widgets(this) $newValue + } + + if {[winfo ismapped $widgets(dropdown)]} { + ::combobox::Select $widgets(this) \ + [$widgets(listbox) curselection] + return -code break; + } + + } + + "<KP_Enter>" { + # did the value change? + set newValue [$widgets(entry) get] + if {$oldValue != $newValue} { + CallCommand $widgets(this) $newValue + } + + if {[winfo ismapped $widgets(dropdown)]} { + ::combobox::Select $widgets(this) \ + [$widgets(listbox) curselection] + return -code break; + } + + } + + "<Next>" { + $widgets(listbox) yview scroll 1 pages + set index [$widgets(listbox) index @0,0] + $widgets(listbox) see $index + $widgets(listbox) activate $index + $widgets(listbox) selection clear 0 end + $widgets(listbox) selection anchor $index + $widgets(listbox) selection set $index + + } + + "<Prior>" { + $widgets(listbox) yview scroll -1 pages + set index [$widgets(listbox) index @0,0] + $widgets(listbox) activate $index + $widgets(listbox) see $index + $widgets(listbox) selection clear 0 end + $widgets(listbox) selection anchor $index + $widgets(listbox) selection set $index + } + + "<Down>" { + if {[winfo ismapped $widgets(dropdown)]} { + ::combobox::tkListboxUpDown $widgets(listbox) 1 + return -code break; + + } else { + if {$options(-state) != "disabled"} { + $widgets(this) open + return -code break; + } + } + } + "<Up>" { + if {[winfo ismapped $widgets(dropdown)]} { + ::combobox::tkListboxUpDown $widgets(listbox) -1 + return -code break; + + } else { + if {$options(-state) != "disabled"} { + $widgets(this) open + return -code break; + } + } + } + } + + return "" +} + +# ::combobox::DestroyHandler {w} -- +# +# Cleans up after a combobox widget is destroyed +# +# Arguments: +# +# w widget pathname +# +# Results: +# +# The namespace that was created for the widget is deleted, +# and the widget proc is removed. + +proc ::combobox::DestroyHandler {w} { + + catch { + # if the widget actually being destroyed is of class Combobox, + # remove the namespace and associated proc. + if {[string compare [winfo class $w] "Combobox"] == 0} { + # delete the namespace and the proc which represents + # our widget + namespace delete ::combobox::$w + rename $w {} + } + } + return "" +} + +# ::combobox::Find +# +# finds something in the listbox that matches the pattern in the +# entry widget and selects it +# +# N.B. I'm not convinced this is working the way it ought to. It +# works, but is the behavior what is expected? I've also got a gut +# feeling that there's a better way to do this, but I'm too lazy to +# figure it out... +# +# Arguments: +# +# w widget pathname +# exact boolean; if true an exact match is desired +# +# Returns: +# +# Empty string + +proc ::combobox::Find {w {exact 0}} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + ## *sigh* this logic is rather gross and convoluted. Surely + ## there is a more simple, straight-forward way to implement + ## all this. As the saying goes, I lack the time to make it + ## shorter... + + # use what is already in the entry widget as a pattern + set pattern [$widgets(entry) get] + + if {[string length $pattern] == 0} { + # clear the current selection + $widgets(listbox) see 0 + $widgets(listbox) selection clear 0 end + $widgets(listbox) selection anchor 0 + $widgets(listbox) activate 0 + return + } + + # we're going to be searching this list... + set list [$widgets(listbox) get 0 end] + + # if we are doing an exact match, try to find, + # well, an exact match + set exactMatch -1 + if {$exact} { + set exactMatch [lsearch -exact $list $pattern] + } + + # search for it. We'll try to be clever and not only + # search for a match for what they typed, but a match for + # something close to what they typed. We'll keep removing one + # character at a time from the pattern until we find a match + # of some sort. + set index -1 + while {$index == -1 && [string length $pattern]} { + set index [lsearch -glob $list "$pattern*"] + if {$index == -1} { + regsub {.$} $pattern {} pattern + } + } + + # this is the item that most closely matches... + set thisItem [lindex $list $index] + + # did we find a match? If so, do some additional munging... + if {$index != -1} { + + # we need to find the part of the first item that is + # unique WRT the second... I know there's probably a + # simpler way to do this... + + set nextIndex [expr {$index + 1}] + set nextItem [lindex $list $nextIndex] + + # we don't really need to do much if the next + # item doesn't match our pattern... + if {[string match $pattern* $nextItem]} { + # ok, the next item matches our pattern, too + # now the trick is to find the first character + # where they *don't* match... + set marker [string length $pattern] + while {$marker <= [string length $pattern]} { + set a [string index $thisItem $marker] + set b [string index $nextItem $marker] + if {[string compare $a $b] == 0} { + append pattern $a + incr marker + } else { + break + } + } + } else { + set marker [string length $pattern] + } + + } else { + set marker end + set index 0 + } + + # ok, we know the pattern and what part is unique; + # update the entry widget and listbox appropriately + if {$exact && $exactMatch == -1} { + # this means we didn't find an exact match + $widgets(listbox) selection clear 0 end + $widgets(listbox) see $index + + } elseif {!$exact} { + # this means we found something, but it isn't an exact + # match. If we find something that *is* an exact match we + # don't need to do the following, since it would merely + # be replacing the data in the entry widget with itself + set oldstate [$widgets(entry) cget -state] + $widgets(entry) configure -state normal + $widgets(entry) delete 0 end + $widgets(entry) insert end $thisItem + $widgets(entry) selection clear + $widgets(entry) selection range $marker end + $widgets(listbox) activate $index + $widgets(listbox) selection clear 0 end + $widgets(listbox) selection anchor $index + $widgets(listbox) selection set $index + $widgets(listbox) see $index + $widgets(entry) configure -state $oldstate + } +} + +# ::combobox::Select -- +# +# selects an item from the list and sets the value of the combobox +# to that value +# +# Arguments: +# +# w widget pathname +# index listbox index of item to be selected +# +# Returns: +# +# empty string + +proc ::combobox::Select {w index} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + # the catch is because I'm sloppy -- presumably, the only time + # an error will be caught is if there is no selection. + if {![catch {set data [$widgets(listbox) get [lindex $index 0]]}]} { + ::combobox::SetValue $widgets(this) $data + + $widgets(listbox) selection clear 0 end + $widgets(listbox) selection anchor $index + $widgets(listbox) selection set $index + + } + $widgets(entry) selection range 0 end + $widgets(entry) icursor end + + $widgets(this) close + + return "" +} + +# ::combobox::HandleScrollbar -- +# +# causes the scrollbar of the dropdown list to appear or disappear +# based on the contents of the dropdown listbox +# +# Arguments: +# +# w widget pathname +# action the action to perform on the scrollbar +# +# Returns: +# +# an empty string + +proc ::combobox::HandleScrollbar {w {action "unknown"}} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + if {$options(-height) == 0} { + set hlimit $options(-maxheight) + } else { + set hlimit $options(-height) + } + + switch $action { + "grow" { + if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} { + pack forget $widgets(listbox) + pack $widgets(vsb) -side right -fill y -expand n + pack $widgets(listbox) -side left -fill both -expand y + } + } + + "shrink" { + if {$hlimit > 0 && [$widgets(listbox) size] <= $hlimit} { + pack forget $widgets(vsb) + } + } + + "crop" { + # this means the window was cropped and we definitely + # need a scrollbar no matter what the user wants + pack forget $widgets(listbox) + pack $widgets(vsb) -side right -fill y -expand n + pack $widgets(listbox) -side left -fill both -expand y + } + + default { + if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} { + pack forget $widgets(listbox) + pack $widgets(vsb) -side right -fill y -expand n + pack $widgets(listbox) -side left -fill both -expand y + } else { + pack forget $widgets(vsb) + } + } + } + + return "" +} + +# ::combobox::ComputeGeometry -- +# +# computes the geometry of the dropdown list based on the size of the +# combobox... +# +# Arguments: +# +# w widget pathname +# +# Returns: +# +# the desired geometry of the listbox + +proc ::combobox::ComputeGeometry {w} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + if {$options(-height) == 0 && $options(-maxheight) != "0"} { + # if this is the case, count the items and see if + # it exceeds our maxheight. If so, set the listbox + # size to maxheight... + set nitems [$widgets(listbox) size] + if {$nitems > $options(-maxheight)} { + # tweak the height of the listbox + $widgets(listbox) configure -height $options(-maxheight) + } else { + # un-tweak the height of the listbox + $widgets(listbox) configure -height 0 + } + update idletasks + } + + # compute height and width of the dropdown list + set bd [$widgets(dropdown) cget -borderwidth] + set height [expr {[winfo reqheight $widgets(dropdown)] + $bd + $bd}] + if {[string length $options(-dropdownwidth)] == 0 || + $options(-dropdownwidth) == 0} { + set width [winfo width $widgets(this)] + } else { + set m [font measure [$widgets(listbox) cget -font] "m"] + set width [expr {$options(-dropdownwidth) * $m}] + } + + # figure out where to place it on the screen, trying to take into + # account we may be running under some virtual window manager + set screenWidth [winfo screenwidth $widgets(this)] + set screenHeight [winfo screenheight $widgets(this)] + set rootx [winfo rootx $widgets(this)] + set rooty [winfo rooty $widgets(this)] + set vrootx [winfo vrootx $widgets(this)] + set vrooty [winfo vrooty $widgets(this)] + + # the x coordinate is simply the rootx of our widget, adjusted for + # the virtual window. We won't worry about whether the window will + # be offscreen to the left or right -- we want the illusion that it + # is part of the entry widget, so if part of the entry widget is off- + # screen, so will the list. If you want to change the behavior, + # simply change the if statement... (and be sure to update this + # comment!) + set x [expr {$rootx + $vrootx}] + if {0} { + set rightEdge [expr {$x + $width}] + if {$rightEdge > $screenWidth} { + set x [expr {$screenWidth - $width}] + } + if {$x < 0} {set x 0} + } + + # the y coordinate is the rooty plus vrooty offset plus + # the height of the static part of the widget plus 1 for a + # tiny bit of visual separation... + set y [expr {$rooty + $vrooty + [winfo reqheight $widgets(this)] + 1}] + set bottomEdge [expr {$y + $height}] + + if {$bottomEdge >= $screenHeight} { + # ok. Fine. Pop it up above the entry widget isntead of + # below. + set y [expr {($rooty - $height - 1) + $vrooty}] + + if {$y < 0} { + # this means it extends beyond our screen. How annoying. + # Now we'll try to be real clever and either pop it up or + # down, depending on which way gives us the biggest list. + # then, we'll trim the list to fit and force the use of + # a scrollbar + + # (sadly, for windows users this measurement doesn't + # take into consideration the height of the taskbar, + # but don't blame me -- there isn't any way to detect + # it or figure out its dimensions. The same probably + # applies to any window manager with some magic windows + # glued to the top or bottom of the screen) + + if {$rooty > [expr {$screenHeight / 2}]} { + # we are in the lower half of the screen -- + # pop it up. Y is zero; that parts easy. The height + # is simply the y coordinate of our widget, minus + # a pixel for some visual separation. The y coordinate + # will be the topof the screen. + set y 1 + set height [expr {$rooty - 1 - $y}] + + } else { + # we are in the upper half of the screen -- + # pop it down + set y [expr {$rooty + $vrooty + \ + [winfo reqheight $widgets(this)] + 1}] + set height [expr {$screenHeight - $y}] + + } + + # force a scrollbar + HandleScrollbar $widgets(this) crop + } + } + + if {$y < 0} { + # hmmm. Bummer. + set y 0 + set height $screenheight + } + + set geometry [format "=%dx%d+%d+%d" $width $height $x $y] + + return $geometry +} + +# ::combobox::DoInternalWidgetCommand -- +# +# perform an internal widget command, then mung any error results +# to look like it came from our megawidget. A lot of work just to +# give the illusion that our megawidget is an atomic widget +# +# Arguments: +# +# w widget pathname +# subwidget pathname of the subwidget +# command subwidget command to be executed +# args arguments to the command +# +# Returns: +# +# The result of the subwidget command, or an error + +proc ::combobox::DoInternalWidgetCommand {w subwidget command args} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + set subcommand $command + set command [concat $widgets($subwidget) $command $args] + if {[catch $command result]} { + # replace the subwidget name with the megawidget name + regsub $widgets($subwidget) $result $widgets(this) result + + # replace specific instances of the subwidget command + # with our megawidget command + switch $subwidget,$subcommand { + listbox,index {regsub "index" $result "list index" result} + listbox,insert {regsub "insert" $result "list insert" result} + listbox,delete {regsub "delete" $result "list delete" result} + listbox,get {regsub "get" $result "list get" result} + listbox,size {regsub "size" $result "list size" result} + } + error $result + + } else { + return $result + } +} + + +# ::combobox::WidgetProc -- +# +# This gets uses as the widgetproc for an combobox widget. +# Notice where the widget is created and you'll see that the +# actual widget proc merely evals this proc with all of the +# arguments intact. +# +# Note that some widget commands are defined "inline" (ie: +# within this proc), and some do most of their work in +# separate procs. This is merely because sometimes it was +# easier to do it one way or the other. +# +# Arguments: +# +# w widget pathname +# command widget subcommand +# args additional arguments; varies with the subcommand +# +# Results: +# +# Performs the requested widget command + +proc ::combobox::WidgetProc {w command args} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + upvar ::combobox::${w}::oldFocus oldFocus + upvar ::combobox::${w}::oldFocus oldGrab + + set command [::combobox::Canonize $w command $command] + + # this is just shorthand notation... + set doWidgetCommand \ + [list ::combobox::DoInternalWidgetCommand $widgets(this)] + + if {$command == "list"} { + # ok, the next argument is a list command; we'll + # rip it from args and append it to command to + # create a unique internal command + # + # NB: because of the sloppy way we are doing this, + # we'll also let the user enter our secret command + # directly (eg: listinsert, listdelete), but we + # won't document that fact + set command "list-[lindex $args 0]" + set args [lrange $args 1 end] + } + + set result "" + + # many of these commands are just synonyms for specific + # commands in one of the subwidgets. We'll get them out + # of the way first, then do the custom commands. + switch $command { + bbox - + delete - + get - + icursor - + index - + insert - + scan - + selection - + xview { + set result [eval $doWidgetCommand entry $command $args] + } + list-get {set result [eval $doWidgetCommand listbox get $args]} + list-index {set result [eval $doWidgetCommand listbox index $args]} + list-size {set result [eval $doWidgetCommand listbox size $args]} + + select { + if {[llength $args] == 1} { + set index [lindex $args 0] + set result [Select $widgets(this) $index] + } else { + error "usage: $w select index" + } + } + + subwidget { + set knownWidgets [list button entry listbox dropdown vsb] + if {[llength $args] == 0} { + return $knownWidgets + } + + set name [lindex $args 0] + if {[lsearch $knownWidgets $name] != -1} { + set result $widgets($name) + } else { + error "unknown subwidget $name" + } + } + + curselection { + set result [eval $doWidgetCommand listbox curselection] + } + + list-insert { + eval $doWidgetCommand listbox insert $args + set result [HandleScrollbar $w "grow"] + } + + list-delete { + eval $doWidgetCommand listbox delete $args + set result [HandleScrollbar $w "shrink"] + } + + toggle { + # ignore this command if the widget is disabled... + if {$options(-state) == "disabled"} return + + # pops down the list if it is not, hides it + # if it is... + if {[winfo ismapped $widgets(dropdown)]} { + set result [$widgets(this) close] + } else { + set result [$widgets(this) open] + } + } + + open { + + # if this is an editable combobox, the focus should + # be set to the entry widget + if {$options(-editable)} { + focus $widgets(entry) + $widgets(entry) select range 0 end + $widgets(entry) icursor end + } + + # if we are disabled, we won't allow this to happen + if {$options(-state) == "disabled"} { + return 0 + } + + # if there is a -opencommand, execute it now + if {[string length $options(-opencommand)] > 0} { + # hmmm... should I do a catch, or just let the normal + # error handling handle any errors? For now, the latter... + uplevel \#0 $options(-opencommand) + } + + # compute the geometry of the window to pop up, and set + # it, and force the window manager to take notice + # (even if it is not presently visible). + # + # this isn't strictly necessary if the window is already + # mapped, but we'll go ahead and set the geometry here + # since its harmless and *may* actually reset the geometry + # to something better in some weird case. + set geometry [::combobox::ComputeGeometry $widgets(this)] + wm geometry $widgets(dropdown) $geometry + update idletasks + + # if we are already open, there's nothing else to do + if {[winfo ismapped $widgets(dropdown)]} { + return 0 + } + + # save the widget that currently has the focus; we'll restore + # the focus there when we're done + set oldFocus [focus] + + # ok, tweak the visual appearance of things and + # make the list pop up + $widgets(button) configure -relief sunken + wm deiconify $widgets(dropdown) + update idletasks + raise $widgets(dropdown) + + # force focus to the entry widget so we can handle keypress + # events for traversal + focus -force $widgets(entry) + + # select something by default, but only if its an + # exact match... + ::combobox::Find $widgets(this) 1 + + # save the current grab state for the display containing + # this widget. We'll restore it when we close the dropdown + # list + set status "none" + set grab [grab current $widgets(this)] + if {$grab != ""} {set status [grab status $grab]} + set oldGrab [list $grab $status] + unset grab status + + # *gasp* do a global grab!!! Mom always told me not to + # do things like this, but sometimes a man's gotta do + # what a man's gotta do. + grab -global $widgets(this) + + # fake the listbox into thinking it has focus. This is + # necessary to get scanning initialized properly in the + # listbox. + event generate $widgets(listbox) <B1-Enter> + + return 1 + } + + close { + # if we are already closed, don't do anything... + if {![winfo ismapped $widgets(dropdown)]} { + return 0 + } + + # restore the focus and grab, but ignore any errors... + # we're going to be paranoid and release the grab before + # trying to set any other grab because we really really + # really want to make sure the grab is released. + catch {focus $oldFocus} result + catch {grab release $widgets(this)} + catch { + set status [lindex $oldGrab 1] + if {$status == "global"} { + grab -global [lindex $oldGrab 0] + } elseif {$status == "local"} { + grab [lindex $oldGrab 0] + } + unset status + } + + # hides the listbox + $widgets(button) configure -relief raised + wm withdraw $widgets(dropdown) + + # select the data in the entry widget. Not sure + # why, other than observation seems to suggest that's + # what windows widgets do. + set editable [::combobox::GetBoolean $options(-editable)] + if {$editable} { + $widgets(entry) selection range 0 end + $widgets(button) configure -relief raised + } + + + # magic tcl stuff (see tk.tcl in the distribution + # lib directory) + ::combobox::tkCancelRepeat + + return 1 + } + + cget { + if {[llength $args] != 1} { + error "wrong # args: should be $w cget option" + } + set opt [::combobox::Canonize $w option [lindex $args 0]] + + if {$opt == "-value"} { + set result [$widgets(entry) get] + } else { + set result $options($opt) + } + } + + configure { + set result [eval ::combobox::Configure {$w} $args] + } + + default { + error "bad option \"$command\"" + } + } + + return $result +} + +# ::combobox::Configure -- +# +# Implements the "configure" widget subcommand +# +# Arguments: +# +# w widget pathname +# args zero or more option/value pairs (or a single option) +# +# Results: +# +# Performs typcial "configure" type requests on the widget + +proc ::combobox::Configure {w args} { + variable widgetOptions + variable defaultEntryCursor + + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + if {[llength $args] == 0} { + # hmmm. User must be wanting all configuration information + # note that if the value of an array element is of length + # one it is an alias, which needs to be handled slightly + # differently + set results {} + foreach opt [lsort [array names widgetOptions]] { + if {[llength $widgetOptions($opt)] == 1} { + set alias $widgetOptions($opt) + set optName $widgetOptions($alias) + lappend results [list $opt $optName] + } else { + set optName [lindex $widgetOptions($opt) 0] + set optClass [lindex $widgetOptions($opt) 1] + set default [option get $w $optName $optClass] + if {[info exists options($opt)]} { + lappend results [list $opt $optName $optClass \ + $default $options($opt)] + } else { + lappend results [list $opt $optName $optClass \ + $default ""] + } + } + } + + return $results + } + + # one argument means we are looking for configuration + # information on a single option + if {[llength $args] == 1} { + set opt [::combobox::Canonize $w option [lindex $args 0]] + + set optName [lindex $widgetOptions($opt) 0] + set optClass [lindex $widgetOptions($opt) 1] + set default [option get $w $optName $optClass] + set results [list $opt $optName $optClass \ + $default $options($opt)] + return $results + } + + # if we have an odd number of values, bail. + if {[expr {[llength $args]%2}] == 1} { + # hmmm. An odd number of elements in args + error "value for \"[lindex $args end]\" missing" + } + + # Great. An even number of options. Let's make sure they + # are all valid before we do anything. Note that Canonize + # will generate an error if it finds a bogus option; otherwise + # it returns the canonical option name + foreach {name value} $args { + set name [::combobox::Canonize $w option $name] + set opts($name) $value + } + + # process all of the configuration options + # some (actually, most) options require us to + # do something, like change the attributes of + # a widget or two. Here's where we do that... + # + # note that the handling of disabledforeground and + # disabledbackground is a little wonky. First, we have + # to deal with backwards compatibility (ie: tk 8.3 and below + # didn't have such options for the entry widget), and + # we have to deal with the fact we might want to disable + # the entry widget but use the normal foreground/background + # for when the combobox is not disabled, but not editable either. + + set updateVisual 0 + foreach option [array names opts] { + set newValue $opts($option) + if {[info exists options($option)]} { + set oldValue $options($option) + } + + switch -- $option { + -buttonbackground { + $widgets(button) configure -background $newValue + } + -background { + set updateVisual 1 + set options($option) $newValue + } + + -borderwidth { + $widgets(frame) configure -borderwidth $newValue + set options($option) $newValue + } + + -command { + # nothing else to do... + set options($option) $newValue + } + + -commandstate { + # do some value checking... + if {$newValue != "normal" && $newValue != "disabled"} { + set options($option) $oldValue + set message "bad state value \"$newValue\";" + append message " must be normal or disabled" + error $message + } + set options($option) $newValue + } + + -cursor { + $widgets(frame) configure -cursor $newValue + $widgets(entry) configure -cursor $newValue + $widgets(listbox) configure -cursor $newValue + set options($option) $newValue + } + + -disabledforeground { + set updateVisual 1 + set options($option) $newValue + } + + -disabledbackground { + set updateVisual 1 + set options($option) $newValue + } + + -dropdownwidth { + set options($option) $newValue + } + + -editable { + set updateVisual 1 + if {$newValue} { + # it's editable... + $widgets(entry) configure \ + -state normal \ + -cursor $defaultEntryCursor + } else { + $widgets(entry) configure \ + -state disabled \ + -cursor $options(-cursor) + } + set options($option) $newValue + } + + -elementborderwidth { + $widgets(button) configure -borderwidth $newValue + $widgets(vsb) configure -borderwidth $newValue + $widgets(dropdown) configure -borderwidth $newValue + set options($option) $newValue + } + + -font { + $widgets(entry) configure -font $newValue + $widgets(listbox) configure -font $newValue + set options($option) $newValue + } + + -foreground { + set updateVisual 1 + set options($option) $newValue + } + + -height { + $widgets(listbox) configure -height $newValue + HandleScrollbar $w + set options($option) $newValue + } + + -highlightbackground { + $widgets(frame) configure -highlightbackground $newValue + set options($option) $newValue + } + + -highlightcolor { + $widgets(frame) configure -highlightcolor $newValue + set options($option) $newValue + } + + -highlightthickness { + $widgets(frame) configure -highlightthickness $newValue + set options($option) $newValue + } + + -image { + if {[string length $newValue] > 0} { + puts "old button width: [$widgets(button) cget -width]" + $widgets(button) configure \ + -image $newValue \ + -width [expr {[image width $newValue] + 2}] + puts "new button width: [$widgets(button) cget -width]" + + } else { + $widgets(button) configure -image ::combobox::bimage + } + set options($option) $newValue + } + + -listvar { + if {[catch {$widgets(listbox) cget -listvar}]} { + return -code error \ + "-listvar not supported with this version of tk" + } + $widgets(listbox) configure -listvar $newValue + set options($option) $newValue + } + + -maxheight { + # ComputeGeometry may dork with the actual height + # of the listbox, so let's undork it + $widgets(listbox) configure -height $options(-height) + HandleScrollbar $w + set options($option) $newValue + } + + -opencommand { + # nothing else to do... + set options($option) $newValue + } + + -relief { + $widgets(frame) configure -relief $newValue + set options($option) $newValue + } + + -selectbackground { + $widgets(entry) configure -selectbackground $newValue + $widgets(listbox) configure -selectbackground $newValue + set options($option) $newValue + } + + -selectborderwidth { + $widgets(entry) configure -selectborderwidth $newValue + $widgets(listbox) configure -selectborderwidth $newValue + set options($option) $newValue + } + + -selectforeground { + $widgets(entry) configure -selectforeground $newValue + $widgets(listbox) configure -selectforeground $newValue + set options($option) $newValue + } + + -state { + if {$newValue == "normal"} { + set updateVisual 1 + # it's enabled + + set editable [::combobox::GetBoolean \ + $options(-editable)] + if {$editable} { + $widgets(entry) configure -state normal + $widgets(entry) configure -takefocus 1 + } + + # note that $widgets(button) is actually a label, + # not a button. And being able to disable labels + # wasn't possible until tk 8.3. (makes me wonder + # why I chose to use a label, but that answer is + # lost to antiquity) + if {[info patchlevel] >= 8.3} { + $widgets(button) configure -state normal + } + + } elseif {$newValue == "disabled"} { + set updateVisual 1 + # it's disabled + $widgets(entry) configure -state disabled + $widgets(entry) configure -takefocus 0 + # note that $widgets(button) is actually a label, + # not a button. And being able to disable labels + # wasn't possible until tk 8.3. (makes me wonder + # why I chose to use a label, but that answer is + # lost to antiquity) + if {$::tcl_version >= 8.3} { + $widgets(button) configure -state disabled + } + + } else { + set options($option) $oldValue + set message "bad state value \"$newValue\";" + append message " must be normal or disabled" + error $message + } + + set options($option) $newValue + } + + -takefocus { + $widgets(entry) configure -takefocus $newValue + set options($option) $newValue + } + + -textvariable { + $widgets(entry) configure -textvariable $newValue + set options($option) $newValue + } + + -value { + ::combobox::SetValue $widgets(this) $newValue + set options($option) $newValue + } + + -width { + $widgets(entry) configure -width $newValue + $widgets(listbox) configure -width $newValue + set options($option) $newValue + } + + -xscrollcommand { + $widgets(entry) configure -xscrollcommand $newValue + set options($option) $newValue + } + } + + if {$updateVisual} {UpdateVisualAttributes $w} + } +} + +# ::combobox::UpdateVisualAttributes -- +# +# sets the visual attributes (foreground, background mostly) +# based on the current state of the widget (normal/disabled, +# editable/non-editable) +# +# why a proc for such a simple thing? Well, in addition to the +# various states of the widget, we also have to consider the +# version of tk being used -- versions from 8.4 and beyond have +# the notion of disabled foreground/background options for various +# widgets. All of the permutations can get nasty, so we encapsulate +# it all in one spot. +# +# note also that we don't handle all visual attributes here; just +# the ones that depend on the state of the widget. The rest are +# handled on a case by case basis +# +# Arguments: +# w widget pathname +# +# Returns: +# empty string + +proc ::combobox::UpdateVisualAttributes {w} { + + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + if {$options(-state) == "normal"} { + + set foreground $options(-foreground) + set background $options(-background) + + } elseif {$options(-state) == "disabled"} { + + set foreground $options(-disabledforeground) + set background $options(-disabledbackground) + } + + $widgets(entry) configure -foreground $foreground -background $background + $widgets(listbox) configure -foreground $foreground -background $background + $widgets(button) configure -foreground $foreground + $widgets(vsb) configure -background $background -troughcolor $background + $widgets(frame) configure -background $background + + # we need to set the disabled colors in case our widget is disabled. + # We could actually check for disabled-ness, but we also need to + # check whether we're enabled but not editable, in which case the + # entry widget is disabled but we still want the enabled colors. It's + # easier just to set everything and be done with it. + + if {$::tcl_version >= 8.4} { + $widgets(entry) configure \ + -disabledforeground $foreground \ + -disabledbackground $background + $widgets(button) configure -disabledforeground $foreground + $widgets(listbox) configure -disabledforeground $foreground + } +} + +# ::combobox::SetValue -- +# +# sets the value of the combobox and calls the -command, +# if defined +# +# Arguments: +# +# w widget pathname +# newValue the new value of the combobox +# +# Returns +# +# Empty string + +proc ::combobox::SetValue {w newValue} { + + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + upvar ::combobox::${w}::ignoreTrace ignoreTrace + upvar ::combobox::${w}::oldValue oldValue + + if {[info exists options(-textvariable)] \ + && [string length $options(-textvariable)] > 0} { + set variable ::$options(-textvariable) + set $variable $newValue + } else { + set oldstate [$widgets(entry) cget -state] + $widgets(entry) configure -state normal + $widgets(entry) delete 0 end + $widgets(entry) insert 0 $newValue + $widgets(entry) configure -state $oldstate + } + + # set our internal textvariable; this will cause any public + # textvariable (ie: defined by the user) to be updated as + # well +# set ::combobox::${w}::entryTextVariable $newValue + + # redefine our concept of the "old value". Do it before running + # any associated command so we can be sure it happens even + # if the command somehow fails. + set oldValue $newValue + + + # call the associated command. The proc will handle whether or + # not to actually call it, and with what args + CallCommand $w $newValue + + return "" +} + +# ::combobox::CallCommand -- +# +# calls the associated command, if any, appending the new +# value to the command to be called. +# +# Arguments: +# +# w widget pathname +# newValue the new value of the combobox +# +# Returns +# +# empty string + +proc ::combobox::CallCommand {w newValue} { + upvar ::combobox::${w}::widgets widgets + upvar ::combobox::${w}::options options + + # call the associated command, if defined and -commandstate is + # set to "normal" + if {$options(-commandstate) == "normal" && \ + [string length $options(-command)] > 0} { + set args [list $widgets(this) $newValue] + uplevel \#0 $options(-command) $args + } +} + + +# ::combobox::GetBoolean -- +# +# returns the value of a (presumably) boolean string (ie: it should +# do the right thing if the string is "yes", "no", "true", 1, etc +# +# Arguments: +# +# value value to be converted +# errorValue a default value to be returned in case of an error +# +# Returns: +# +# a 1 or zero, or the value of errorValue if the string isn't +# a proper boolean value + +proc ::combobox::GetBoolean {value {errorValue 1}} { + if {[catch {expr {([string trim $value])?1:0}} res]} { + return $errorValue + } else { + return $res + } +} + +# ::combobox::convert -- +# +# public routine to convert %x, %y and %W binding substitutions. +# Given an x, y and or %W value relative to a given widget, this +# routine will convert the values to be relative to the combobox +# widget. For example, it could be used in a binding like this: +# +# bind .combobox <blah> {doSomething [::combobox::convert %W -x %x]} +# +# Note that this procedure is *not* exported, but is intended for +# public use. It is not exported because the name could easily +# clash with existing commands. +# +# Arguments: +# +# w a widget path; typically the actual result of a %W +# substitution in a binding. It should be either a +# combobox widget or one of its subwidgets +# +# args should one or more of the following arguments or +# pairs of arguments: +# +# -x <x> will convert the value <x>; typically <x> will +# be the result of a %x substitution +# -y <y> will convert the value <y>; typically <y> will +# be the result of a %y substitution +# -W (or -w) will return the name of the combobox widget +# which is the parent of $w +# +# Returns: +# +# a list of the requested values. For example, a single -w will +# result in a list of one items, the name of the combobox widget. +# Supplying "-x 10 -y 20 -W" (in any order) will return a list of +# three values: the converted x and y values, and the name of +# the combobox widget. + +proc ::combobox::convert {w args} { + set result {} + if {![winfo exists $w]} { + error "window \"$w\" doesn't exist" + } + + while {[llength $args] > 0} { + set option [lindex $args 0] + set args [lrange $args 1 end] + + switch -exact -- $option { + -x { + set value [lindex $args 0] + set args [lrange $args 1 end] + set win $w + while {[winfo class $win] != "Combobox"} { + incr value [winfo x $win] + set win [winfo parent $win] + if {$win == "."} break + } + lappend result $value + } + + -y { + set value [lindex $args 0] + set args [lrange $args 1 end] + set win $w + while {[winfo class $win] != "Combobox"} { + incr value [winfo y $win] + set win [winfo parent $win] + if {$win == "."} break + } + lappend result $value + } + + -w - + -W { + set win $w + while {[winfo class $win] != "Combobox"} { + set win [winfo parent $win] + if {$win == "."} break; + } + lappend result $win + } + } + } + return $result +} + +# ::combobox::Canonize -- +# +# takes a (possibly abbreviated) option or command name and either +# returns the canonical name or an error +# +# Arguments: +# +# w widget pathname +# object type of object to canonize; must be one of "command", +# "option", "scan command" or "list command" +# opt the option (or command) to be canonized +# +# Returns: +# +# Returns either the canonical form of an option or command, +# or raises an error if the option or command is unknown or +# ambiguous. + +proc ::combobox::Canonize {w object opt} { + variable widgetOptions + variable columnOptions + variable widgetCommands + variable listCommands + variable scanCommands + + switch $object { + command { + if {[lsearch -exact $widgetCommands $opt] >= 0} { + return $opt + } + + # command names aren't stored in an array, and there + # isn't a way to get all the matches in a list, so + # we'll stuff the commands in a temporary array so + # we can use [array names] + set list $widgetCommands + foreach element $list { + set tmp($element) "" + } + set matches [array names tmp ${opt}*] + } + + {list command} { + if {[lsearch -exact $listCommands $opt] >= 0} { + return $opt + } + + # command names aren't stored in an array, and there + # isn't a way to get all the matches in a list, so + # we'll stuff the commands in a temporary array so + # we can use [array names] + set list $listCommands + foreach element $list { + set tmp($element) "" + } + set matches [array names tmp ${opt}*] + } + + {scan command} { + if {[lsearch -exact $scanCommands $opt] >= 0} { + return $opt + } + + # command names aren't stored in an array, and there + # isn't a way to get all the matches in a list, so + # we'll stuff the commands in a temporary array so + # we can use [array names] + set list $scanCommands + foreach element $list { + set tmp($element) "" + } + set matches [array names tmp ${opt}*] + } + + option { + if {[info exists widgetOptions($opt)] \ + && [llength $widgetOptions($opt)] == 2} { + return $opt + } + set list [array names widgetOptions] + set matches [array names widgetOptions ${opt}*] + } + + } + + if {[llength $matches] == 0} { + set choices [HumanizeList $list] + error "unknown $object \"$opt\"; must be one of $choices" + + } elseif {[llength $matches] == 1} { + set opt [lindex $matches 0] + + # deal with option aliases + switch $object { + option { + set opt [lindex $matches 0] + if {[llength $widgetOptions($opt)] == 1} { + set opt $widgetOptions($opt) + } + } + } + + return $opt + + } else { + set choices [HumanizeList $list] + error "ambiguous $object \"$opt\"; must be one of $choices" + } +} + +# ::combobox::HumanizeList -- +# +# Returns a human-readable form of a list by separating items +# by columns, but separating the last two elements with "or" +# (eg: foo, bar or baz) +# +# Arguments: +# +# list a valid tcl list +# +# Results: +# +# A string which as all of the elements joined with ", " or +# the word " or " + +proc ::combobox::HumanizeList {list} { + + if {[llength $list] == 1} { + return [lindex $list 0] + } else { + set list [lsort $list] + set secondToLast [expr {[llength $list] -2}] + set most [lrange $list 0 $secondToLast] + set last [lindex $list end] + + return "[join $most {, }] or $last" + } +} + +# This is some backwards-compatibility code to handle TIP 44 +# (http://purl.org/tcl/tip/44.html). For all private tk commands +# used by this widget, we'll make duplicates of the procs in the +# combobox namespace. +# +# I'm not entirely convinced this is the right thing to do. I probably +# shouldn't even be using the private commands. Then again, maybe the +# private commands really should be public. Oh well; it works so it +# must be OK... +foreach command {TabToWindow CancelRepeat ListboxUpDown} { + if {[llength [info commands ::combobox::tk$command]] == 1} break; + + set tmp [info commands tk$command] + set proc ::combobox::tk$command + if {[llength [info commands tk$command]] == 1} { + set command [namespace which [lindex $tmp 0]] + proc $proc {args} "uplevel $command \$args" + } else { + if {[llength [info commands ::tk::$command]] == 1} { + proc $proc {args} "uplevel ::tk::$command \$args" + } + } +} + +# end of combobox.tcl + diff --git a/modules/tclsci/tcl/utils/Notebook.tcl b/modules/tclsci/tcl/utils/Notebook.tcl new file mode 100755 index 000000000..72444b296 --- /dev/null +++ b/modules/tclsci/tcl/utils/Notebook.tcl @@ -0,0 +1,279 @@ +# A Notebook widget for Tcl/Tk +# +# Copyright (C) 1996,1997,1998 D. Richard Hipp +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Library General Public +# License as published by the Free Software Foundation; either +# version 2 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Library General Public License for more details. +# +# You should have received a copy of the GNU Library General Public +# License along with this library; if not, write to the +# Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. +# +# Author contact information: +# drh@acm.org +# http://www.hwaci.com/drh/ + +# +# jb Silvy. To know the current page +# + +proc Notebook:getCurrentPage { w } { + global Notebook + return $Notebook($w,top) +} + +# +# Create a new notebook widget +# + +package provide Notebook + +proc Notebook:create {w args} { + global Notebook + set Notebook($w,width) 400 + set Notebook($w,height) 300 + set Notebook($w,pages) {} + set Notebook($w,top) 0 + set Notebook($w,pad) 5 + set Notebook($w,fg,on) black + set Notebook($w,fg,off) grey50 + canvas $w -bd 0 -highlightthickness 0 -takefocus 0 + set Notebook($w,bg) [$w cget -bg] + bind $w <1> "Notebook:click $w %x %y" + bind $w <Configure> "Notebook:scheduleExpand $w" + eval Notebook:config $w $args +} + +# +# Change configuration options for the notebook widget +# +proc Notebook:config {w args} { + global Notebook + foreach {tag value} $args { + switch -- $tag { + -width { + set Notebook($w,width) $value + } + -height { + set Notebook($w,height) $value + } + -pages { + set Notebook($w,pages) $value + } + -pad { + set Notebook($w,pad) $value + } + -bg { + set Notebook($w,bg) $value + } + -fg { + set Notebook($w,fg,on) $value + } + -disabledforeground { + set Notebook($w,fg,off) $value + } + } + } + + # + # After getting new configuration values, reconstruct the widget + # + $w delete all + set Notebook($w,x1) $Notebook($w,pad) + set Notebook($w,x2) [expr $Notebook($w,x1)+2] + set Notebook($w,x3) [expr $Notebook($w,x2)+$Notebook($w,width)] + set Notebook($w,x4) [expr $Notebook($w,x3)+2] + set Notebook($w,y1) [expr $Notebook($w,pad)+2] + set Notebook($w,y2) [expr $Notebook($w,y1)+2] + set Notebook($w,y5) [expr $Notebook($w,y1)+30] + set Notebook($w,y6) [expr $Notebook($w,y5)+2] + set Notebook($w,y3) [expr $Notebook($w,y6)+$Notebook($w,height)] + set Notebook($w,y4) [expr $Notebook($w,y3)+2] + set x $Notebook($w,x1) + set cnt 0 + set y7 [expr $Notebook($w,y1)+10] + foreach p $Notebook($w,pages) { + set Notebook($w,p$cnt,x5) $x + set id [$w create text 0 0 -text $p -anchor nw -tags "p$cnt t$cnt" -font {Arial -15} -fill $Notebook($w,fg,off)] + set bbox [$w bbox $id] + set width [lindex $bbox 2] + $w move $id [expr $x+10] $y7 + $w create line \ + $x $Notebook($w,y5)\ + $x $Notebook($w,y2) \ + [expr $x+2] $Notebook($w,y1) \ + [expr $x+$width+16] $Notebook($w,y1) \ + -width 2 -fill white -tags p$cnt + $w create line \ + [expr $x+$width+16] $Notebook($w,y1) \ + [expr $x+$width+18] $Notebook($w,y2) \ + [expr $x+$width+18] $Notebook($w,y5) \ + -width 2 -fill black -tags p$cnt + set x [expr $x+$width+20] + set Notebook($w,p$cnt,x6) [expr $x-2] + if {![winfo exists $w.f$cnt]} { + frame $w.f$cnt -bd 0 + } + $w.f$cnt config -bg $Notebook($w,bg) + place $w.f$cnt -x $Notebook($w,x2) -y $Notebook($w,y6) \ + -width $Notebook($w,width) -height $Notebook($w,height) + incr cnt + } + $w create line \ + $Notebook($w,x1) [expr $Notebook($w,y5)-2] \ + $Notebook($w,x1) $Notebook($w,y3) \ + -width 2 -fill white + $w create line \ + $Notebook($w,x1) $Notebook($w,y3) \ + $Notebook($w,x2) $Notebook($w,y4) \ + $Notebook($w,x3) $Notebook($w,y4) \ + $Notebook($w,x4) $Notebook($w,y3) \ + $Notebook($w,x4) $Notebook($w,y6) \ + $Notebook($w,x3) $Notebook($w,y5) \ + -width 2 -fill black + $w config -width [expr $Notebook($w,x4)+$Notebook($w,pad)] \ + -height [expr $Notebook($w,y4)+$Notebook($w,pad)] \ + -bg $Notebook($w,bg) + set top $Notebook($w,top) + set Notebook($w,top) -1 + Notebook:raise.page $w $top +} + +# +# This routine is called whenever the mouse-button is pressed over +# the notebook. It determines if any page should be raised and raises +# that page. +# +proc Notebook:click {w x y} { + global Notebook + if {$y<$Notebook($w,y1) || $y>$Notebook($w,y6)} return + set N [llength $Notebook($w,pages)] + for {set i 0} {$i<$N} {incr i} { + $w itemconfigure t$i -fill $Notebook($w,fg,off) + if {$x>=$Notebook($w,p$i,x5) && $x<=$Notebook($w,p$i,x6)} { + Notebook:raise.page $w $i + #break + } + } +} + +# +# For internal use only. This procedure raised the n-th page of +# the notebook +# +proc Notebook:raise.page {w n} { + global Notebook + if {$n<0 || $n>=[llength $Notebook($w,pages)]} return + set top $Notebook($w,top) + if {$top>=0 && $top<[llength $Notebook($w,pages)]} { + $w move p$top 0 2 + + } + $w move p$n 0 -2 + #$w itemconfigure t$n -font {Arial 12} + $w itemconfigure t$n -fill $Notebook($w,fg,on) + $w delete topline + if {$n>0} { + $w create line \ + $Notebook($w,x1) $Notebook($w,y6) \ + $Notebook($w,x2) $Notebook($w,y5) \ + $Notebook($w,p$n,x5) $Notebook($w,y5) \ + $Notebook($w,p$n,x5) [expr $Notebook($w,y5)-2] \ + -width 2 -fill white -tags topline + } + $w create line \ + $Notebook($w,p$n,x6) [expr $Notebook($w,y5)-2] \ + $Notebook($w,p$n,x6) $Notebook($w,y5) \ + -width 2 -fill white -tags topline + $w create line \ + $Notebook($w,p$n,x6) $Notebook($w,y5) \ + $Notebook($w,x3) $Notebook($w,y5) \ + -width 2 -fill white -tags topline + set Notebook($w,top) $n + raise $w.f$n +} + +# +# Change the page-specific configuration options for the notebook +# +proc Notebook:pageconfig {w name args} { + global Notebook + set i [lsearch $Notebook($w,pages) $name] + if {$i<0} return + foreach {tag value} $args { + switch -- $tag { + -state { + if {"$value"=="disabled"} { + $w itemconfig t$i -fg $Notebook($w,fg,off) + } else { + $w itemconfig t$i -fg $Notebook($w,fg,on) + } + } + -onexit { + set Notebook($w,p$i,onexit) $value + } + } + } +} + +# +# This procedure raises a notebook page given its name. But first +# we check the "onexit" procedure for the current page (if any) and +# if it returns false, we don't allow the raise to proceed. +# +proc Notebook:raise {w name} { + global Notebook + set i [lsearch $Notebook($w,pages) $name] + if {$i<0} return + if {[info exists Notebook($w,p$i,onexit)]} { + set onexit $Notebook($w,p$i,onexit) + if {"$onexit"!="" && [eval uplevel #0 $onexit]!=0} { + Notebook:raise.page $w $i + } + } else { + Notebook:raise.page $w $i + } +} + +# +# Return the frame associated with a given page of the notebook. +# +proc Notebook:frame {w name} { + global Notebook + set i [lsearch $Notebook($w,pages) $name] + if {$i>=0} { + return $w.f$i + } else { + return {} + } +} + +# +# Try to resize the notebook to the next time we become idle. +# +proc Notebook:scheduleExpand w { + global Notebook + if {[info exists Notebook($w,expand)]} return + set Notebook($w,expand) 1 + after idle "Notebook:expand $w" +} + +# +# Resize the notebook to fit inside its containing widget. +# +proc Notebook:expand w { + global Notebook + set wi [expr [winfo width $w]-($Notebook($w,pad)*2+4)] + set hi [expr [winfo height $w]-($Notebook($w,pad)*2+36)] + Notebook:config $w -width $wi -height $hi + catch {unset Notebook($w,expand)} +} + |