/usr/local/CPAN/Tk-JComboBox/Tk/JComboBox.pm
#######################################################################
## LICENSE:
## This source code, is copyright (c) 2001-2006 of Rob Seegel
## <RobSeegel@comcast.net>, and is free software; you can
## redistribute and/or modify it under the same terms as Perl itself.
##
## ACKNOWLEDGEMENTS:
## Very little comes from nothing, and as the name suggests,
## JComboBox.pm is *superficially* similar to the javax.swing.JComboBox
## class which is owned by Sun Microsystems. At best, this module shares
## some method names, and basic look and feel, but the similarities end
## there. None of this code comes from the Swing class.
##
## JComboBox.pm owes its original structure to Graham Barr's MenuEntry
## (Thanks, Graham - it was a fine base). It also uses various methods
## and options borrowed from BrowseEntry, Optionmenu, and the
## ComboEntry widget (part of Tk-DKW). This was done to make the widget
## seem familiar to users of those widgets, and lessen the pain of
## migration, and because I thought they were *good* features that I
## wanted in one widget. In addition, features that others have asked
## for have been added over time. So this widget represents a combo box
## stew with a few extra spices that I've come up with myself.
##
## Finally, thanks to all those who have contributed bug reports,
## patches, and new ideas over the years. I have attempted to track
## who did what within the Changes file, and in some cases within the
## source when patches were submitted. Your help and feedback has been
## appreciated.
#######################################################################
package Tk::JComboBox;
use strict;
use Carp;
use Tie::Watch;
use Tk;
use Tk::CWidget;
use Tk::CWidget::Util::Boolean qw(:all);
use vars qw($VERSION);
our $VERSION = "1.14";
BEGIN
{
## Setup a series of private accessors used within public/private
## methods. These are all intended for INTERNAL use only. The
## methods act as a way of consolidating the internal hash keys
## that are being used. Using method calls instead of hash keys
## helps ensure consistant usage throughout, and easier on my eyes.
sub CreateGetSet
{
my ($method, $key) = @_;
my $sub = sub {
my ($cw, $value) = @_;
return $cw->{$key} unless defined $value;
$cw->{$key} = $value;
};
no strict 'refs';
*{$method} = $sub;
}
CreateGetSet(IsButtonDown => '__JCB__BTN_DOWN');
CreateGetSet(LastAFIndex => '__JCB__LAST_INDEX');
CreateGetSet(LastAFSearch => '__JCB__LAST_SEARCH');
CreateGetSet(LastSelection => '__JCB__LAST_SELECT');
CreateGetSet(LastSelName => '__JCB__LAST_SNAME');
CreateGetSet(List => '__JCB__LIST');
CreateGetSet(Mode => '__JCB__MODE');
CreateGetSet(LongestEntry => '__JCB__ENTRY_LEN');
CreateGetSet(Selected => '__JCB__SELECTION');
CreateGetSet(TempRelief => '__JCB__RELIEF');
CreateGetSet(WatchVar => '__JCB__WATCH_VAR');
CreateGetSet(WatchList => '__JCB__WATCH');
}
use base qw(Tk::CWidget);
Tk::Widget->Construct('JComboBox');
## this struct below meant to represent the contents displayed in the
## pulldown list. Name is the text which is displayed, value is for
## text which could be offered as an alternative to the displayed
## text. It is slightly overkill having a structure to hold these
## values, but it is intended to hold additional values in the
## future (bitmaps, images, formats, etc).
use Class::Struct;
struct '_JCBListItem' =>
[
name => '$',
value => '$',
];
## The following constants are meant for internal use only. I wanted
## to use hash keys that were not likely to be used by anyone else
## (including classes that I extended), but the longer versions
## seemed clumsy within the code. It is also a convenient means in
## tracking all of the keys that I'm using.
use constant {
MODE_UNEDITABLE => "readonly",
MODE_EDITABLE => "editable",
VAL_MODE_CSMATCH => "cs-match",
VAL_MODE_MATCH => "match",
};
my $BITMAP;
my $SWAP_BG = "__JCB__SWAP_BG";
my $SWAP_FG = "__JCB__SWAP_FG";
sub ClassInit {
my($class,$mw) = @_;
unless(defined($BITMAP)) {
$BITMAP = __PACKAGE__ . "::downarrow";
## A smaller bitmap suits Win32 better I think
if ($Tk::platform =~ /Win32/) {
my $bits = pack("b10"x4,
".11111111.",
"..111111..",
"...1111...",
"....11...."
);
$mw->DefineBitmap($BITMAP => 10,4, $bits);
## Just as this size looks better on other platforms
} else {
my $bits = pack("b12"x5,
".1111111111.",
"..11111111..",
"...111111...",
"....1111....",
".....11....."
);
$mw->DefineBitmap($BITMAP => 12,5, $bits);
}
$mw->bind($class, '<ButtonRelease-1>', 'NonSelect');
$mw->bind($class, '<FocusIn>', 'RedirectFocus');
}
}
sub Populate {
my ($cw ,$args) = @_;
my $choices = delete $args->{-choices} || delete $args->{-options};
$cw->SUPER::Populate($args);
## Initiallize Member variables
$cw->LastAFIndex(-1);
$cw->LastAFSearch("");
$cw->LastSelection(-1);
$cw->LastSelName("");
$cw->List([]);
$cw->LongestEntry(0);
$cw->Selected(-1);
my $frame = $cw->Component(
Frame => 'Frame',
-background => 'white',
-bd => 2,
-highlightthickness => 0
)->pack(qw/ -side right -fill both -expand 1/);
## Mode is set once at construction time, things get overly
## complicated if mode can be switched after construction time,
## and how often is this sort of thing done? Mode determines the
## widget that makes up the Entry, a Button. I used to allow the
## mode to be switched on-the-fly, and may again in the future.
my $mode = delete $args->{'-mode'} || MODE_UNEDITABLE;
$cw->mode(lc($mode), $args);
## Layout ComboBox controls
$cw->LayoutControls();
$cw->CreateListboxPopup();
$cw->BindSubwidgets();
## Get All Advertised Widgets - constructed within Subroutines
## So that they can be used for ConfigSpecs routine
my $entry = $cw->Subwidget('Entry');
my $button = $cw->Subwidget('Button');
my $listbox = $cw->Subwidget('Listbox');
my $popup = $cw->Subwidget('Popup');
## This ConfigSpecs functions as a core set for the entire
## widget, and assumes that the mode is MODE_UNEDITABLE. Some
## specs are overridden if the mode is MODE_EDITABLE.
$cw->ConfigSpecs(
## Basic
-arrowbitmap => [{-bitmap => $button}, undef, undef, $BITMAP],
-arrowimage => [{-image => $button}],
-background => [qw/DESCENDANTS background Background/],
-borderwidth => [qw/Frame borderwidth BorderWidth 2/],
-cursor => [qw/DESCENDANTS cursor Cursor/],
-disabledbackground => [qw/METHOD/, undef, undef, Tk::NORMAL_BG],
-disabledforeground => [qw/METHOD/, undef, undef, Tk::DISABLED],
-entrybackground => [{-background => [$entry, $button, $listbox]}],
-entrywidth => [qw/METHOD entryWidth EntryWidth -1/],
-font => [[$entry, $listbox], qw/font Font/],
-foreground => [[$entry, $listbox], qw/foreground Foreground/],
-gap => [qw/METHOD gap Gap 0/],
-highlightbackground => [qw/METHOD/, undef, undef,
$frame->cget('-highlightbackground')],
-highlightcolor => [qw/METHOD/, undef, undef,
$frame->cget('-highlightcolor')],
-highlightthickness => [$frame, undef, undef, 0],
-pady => [qw/METHOD padY PadY/],
-relief => [qw/Frame relief Relief groove/],
-selectbackground => [$listbox],
-selectforeground => [$listbox],
-selectborderwidth => [$listbox],
-state => [qw/METHOD state State normal/],
-takefocus => [$entry, qw/takeFocus TakeFocus/, TRUE],
-textvariable => [qw/METHOD textVariable Variable/],
## Callbacks
-buttoncommand => [qw/CALLBACK/, undef, undef, \&see],
-keycommand => [qw/CALLBACK/],
-matchcommand => [qw/CALLBACK/],
-popupcreate => [qw/CALLBACK/],
-popupmodify => [qw/CALLBACK/],
-selectcommand => [qw/CALLBACK/],
-validatecommand => [qw/CALLBACK/],
## Functionality
-autofind => [qw/PASSIVE/],
-choices => [qw/METHOD/],
-listhighlight => [qw/PASSIVE lightHighlight ListHighlight/, TRUE],
-listwidth => [qw/PASSIVE listWidth ListWidth -1/],
-maxrows => [qw/METHOD maxRows MaxRows 10/],
-mode => [qw/METHOD mode Mode/],
-updownselect => [qw/PASSIVE updownSelect UpDownSelect/, TRUE],
-validate => [qw/METHOD validate Validate none/],
);
## Override readonly option settings
if ($cw->mode eq MODE_EDITABLE) {
$cw->ConfigSpecs(
-entrybackground => [{-background => [$entry, $listbox]}],
-relief => [$frame, qw/relief Relief sunken/],
-selectbackground => [[$entry, $listbox]],
-selectforeground => [[$entry, $listbox]],
-selectborderwidth => [[$entry, $listbox]],
);
}
$cw->ConfigAlias(
-browsecmd => '-selectcommand',
-listcmd => '-popupcreate',
-options => '-choices',
);
$cw->choices($choices) if $choices;
return $cw;
}
############################################################
## Configuration Methods
############################################################
sub choices
{
my ($cw, $newAR) = @_;
return $cw->WatchList unless defined $newAR;
return if $newAR eq "" && !defined $cw->WatchList;
my $oldAR = $cw->WatchList;
my $tie = Tk::JComboBox::Tie->tie($cw, $newAR, $oldAR);
if (defined($tie)) { $cw->WatchList($newAR); }
else { $cw->WatchList(""); }
}
sub disabled
{
my ($cw, $option, $color) = @_;
return $cw->{Configure}{"-disabled$option"} unless defined $color;
my $entry = $cw->Subwidget('Entry');
if ($cw->mode eq MODE_EDITABLE && $Tk::VERSION >= 804) {
$entry->configure("-disabled$option" => $color);
return;
}
if ($cw->state eq 'disabled') {
$entry->configure("-$option" => $color);
$cw->Subwidget('Button')->configure("-$option" => $color)
if $cw->mode eq MODE_UNEDITABLE;
}
}
sub disabledbackground
{
my ($cw, $color) = @_;
return $cw->disabled("background", $color);
}
sub disabledforeground
{
my ($cw, $color) = @_;
return $cw->disabled("foreground", $color);
}
sub entrybackground
{
my ($cw, $val) = @_;
return $cw->{Configure}{'-entrybackground'} unless defined $val;
$cw->configureSubwidgets([qw/Entry Listbox/] => {-bg => $val});
}
sub entrywidth
{
my ($cw, $width) = @_;
return $cw->{Configure}{'-entrywidth'} unless defined $width;
$cw->gap(0) if !defined($cw->gap);
$cw->UpdateWidth('delete', "");
}
sub gap
{
my ($cw, $gap) = @_;
if (!defined($gap)) {
return $cw->{Configure}{'-gap'} if defined $cw->{Configure}{'-gap'};
return 0;
}
$cw->UpdateWidth('add', "");
}
sub highlightbackground
{
my ($cw, $color) = @_;
return $cw->{Configure}{'-highlightbackground'} unless defined $color;
$cw->Subwidget('Frame')->configure(-highlightbackground => $color);
}
sub highlightcolor
{
my ($cw, $color) = @_;
return $cw->{Configure}{'-highlightcolor'} unless defined $color;
$cw->Subwidget('Frame')->configure(-highlightcolor => $color);
}
sub maxrows
{
my ($cw, $rows) = @_;
return $cw->{Configure}{'-maxrows'} unless defined $rows;
$cw->UpdateListboxHeight;
}
sub mode
{
## Stores the mode within another variable. One problem with how the
## configuration methods currently work is that they current "store"
## the new value before the method is even called. If a method was
## intended to validate prior to changing the value then this complicates
## things, because the original value is no longer available. In this
## case, the variable is only allowed to be set once per instance.
my ($cw, $mode, $args) = @_;
return $cw->Mode unless defined $mode;
return if $cw->Mode;
my $frame = $cw->Subwidget('Frame');
my $entry;
if ($mode eq MODE_EDITABLE) {
$entry = $frame->Entry(
-highlightthickness => 0,
-borderwidth => 1,
-insertwidth => 1,
-relief => 'flat',
-validatecommand => [$cw => 'ValidateCommand']
);
$cw->Advertise(Entry => $entry);
$cw->Advertise(ED_Entry => $entry);
}
elsif ($mode eq MODE_UNEDITABLE) {
$entry = $cw->CreateButton(
-ignoreleave => TRUE,
-anchor => 'w',
-padx => 4,
-borderwidth => 0,
-takefocus => 1
);
$cw->Advertise(Entry => $entry);
$cw->Advertise(RO_Entry => $entry);
}
else {
croak "Invalid JComboBox mode: $mode\n";
return;
}
$cw->Mode($mode);
}
sub pady
{
my ($cw, $pad) = @_;
return $cw->{Configure}{'-pady'} unless defined $pad;
my $button = $cw->Subwidget('Button');
my %gridInfo = $button->gridInfo;
$gridInfo{'-ipady'} = $pad;
$button->gridForget;
$button->grid(%gridInfo);
}
sub state
{
my ($cw, $state) = @_;
return $cw->{Configure}{'-state'} || "normal" unless defined $state;
$state = lc($state);
croak "Invalid value for -state: $state!"
if ($state !~ /normal|disabled/);
my $button = $cw->Subwidget('Button');
my $entry = $cw->Subwidget('Entry');
if ($state eq 'disabled') { $cw->DisableControls; }
elsif ($state eq 'normal') { $cw->EnableControls; }
}
sub textvariable
{
my ($cw, $value) = @_;
my $existing = $cw->{Configure}{'-textvariable'};
return $existing unless defined $value;
croak "Invalid textvariable type! Expected scalar reference"
if defined($value) && ref($value) ne "SCALAR";
$cw->WatchVar->Unwatch if defined($cw->WatchVar);
my $tmpVal = $$value;
untie $value if tied $value;
my $watch = Tie::Watch->new(
-variable => $value,
-store => sub {$cw->TextvarStore(@_);},
-fetch => sub {return $cw->TextvarFetch(@_);}
);
$cw->WatchVar($watch);
$cw->TextvarStore($watch, $tmpVal) if defined($tmpVal);
}
#############################################################################
## For the most part, this option is delegated to the Entry subwidget in
## MODE_EDITABLE, however two additional options: match and cs-match will
## indicate that the entry should use the Listbox entries for validation. If
## either of these two options are set, then a default validatecommand will
## be used.
#############################################################################
sub validate
{
my ($cw, $mode) = @_;
return $cw->{Configure}{'-validate'} unless $mode;
return if $cw->mode eq MODE_UNEDITABLE;
$mode = lc($mode);
croak "Invalid validate value: $mode"
if ($mode !~ /^(none|focus|focusin|focusout|key|match|cs-match)$/);
## validate is only used in editble mode as a way of constraining
## what a user can type in the Entry. If the mode is match or cs-match
## a default -validate callback is provided. Otherwise, the validation
## mode is passed directly to the Entry widget's validate option.
my $entry = $cw->Subwidget('Entry');
if ($mode =~ /match/)
{
$entry->configure(
-validate => 'key',
);
}
else {
$entry->configure(-validate => $mode);
}
}
## ======================================================================== ##
## Public Methods ##
## ======================================================================== ##
sub addItem { shift->insertItemAt('end', @_) };
sub clearSelection
{
my $cw = shift;
$cw->LastAFIndex(-1);
$cw->LastAFSearch("");
$cw->Selected(-1);
$cw->Subwidget('Listbox')->selectionClear(0, 'end');
my $entry = $cw->Subwidget('Entry');
if ($cw->mode eq MODE_EDITABLE) {
my $v = $entry->cget('-validate');
$entry->configure(-validate => 'none');
$entry->delete(0, 'end');
$entry->configure(-validate => $v);
}
elsif ($cw->mode eq MODE_UNEDITABLE) {
$entry->configure(-text => "");
}
}
## Override the following focus methods to ensure the
## correct
sub focus { shift->Subwidget('Entry')->focus; }
sub tabFocus { shift->Subwidget('Entry')->focus; }
sub getItemCount
{
return scalar( @{shift->List} );
}
sub getItemIndex
{
my ($cw, $searchStr, %args) = @_;
## start - which index to start looking. Defaults to 0;
## if the start is out of range, then reset it to 0.
my $start = delete $args{'-start'} || 0;
$start = 0 if $start >= $cw->Subwidget('Listbox')->size || $start < 0;
## wrap - only use when start is not 0, it determines
## whether or not the search should continue at the beginning
## of the list until the start point when at the end of the list
my $wrap = delete $args{'-wrap'} || 0;
## type - which string is being searched - the name, or value.
my $type = lc($args{'-type'}) || "name";
if ($type !~ /^(name|value)$/) {
carp "Invalid value for -type in getItemIndex (valid: name|value)";
return;
}
my $index;
foreach my $i ($start .. ($cw->getItemCount - 1)) {
my $field;
if ($type eq 'name') { $field = $cw->List->[$i]->name }
elsif ($type eq 'value') { $field = $cw->getItemValueAt($i) }
if ($cw->MatchCommand($searchStr, $field, %args)) {
$index = $i; last;
}
}
$index = $cw->getItemIndex($searchStr, %args)
if (!defined($index) && IsTrue($wrap));
return $index;
}
sub getItemNameAt
{
my ($cw, $index) = @_;
$index = $cw->index($index);
return $cw->DisplayedName() if (!defined($index) || $index < 0);
return $cw->List->[$index]->name;
}
sub getItemValueAt
{
my ($cw, $index) = @_;
$index = $cw->index($index);
## If index is out of array bounds or indicated non-selection
## then the value will come from the displayed name.
return $cw->DisplayedName() if (!defined($index) || $index < 0);
my $item = $cw->List->[$index];
return $item->value if defined($item->value) && $item->value ne "";
return $item->name;
}
sub getSelectedIndex { return shift->Selected; }
sub getSelectedValue { return shift->getItemValueAt('selected'); }
sub hidePopup
{
my ($cw) = @_;
my $popup = $cw->Subwidget('Popup');
return unless $popup->ismapped;
$popup->withdraw;
$cw->grabRelease;
## PATCH (submitted by Ken Prows for CPAN bug#12372)
## PATCH Modified to fix CPAN bug#14520
if ($Tk::oldGrab && Exists($Tk::oldGrab) && $Tk::oldGrab->ismapped)
{
if ($Tk::oldGrabStatus) {
$Tk::oldGrab->grab if $Tk::oldGrabStatus eq 'local';
$Tk::oldGrab->grabGlobal if $Tk::oldGrabStatus eq 'global';
}
}
## END PATCH
}
sub index
{
my ($cw, $index) = @_;
return undef unless defined($index);
return 0 if (lc($index) eq 'first');
return $cw->getSelectedIndex if (lc($index) eq 'selected');
return $cw->getItemCount - 1 if (lc($index) eq 'last');
return $cw->getItemCount if (lc($index) eq 'end');
my $listbox = $cw->Subwidget('Listbox');
return $listbox->index($index) if ($index =~ /\D/);
return $index;
}
sub insertItemAt
{
my ($cw, $i, $name, %args) = @_;
if (!defined($name)) {
carp "Insert failed: undefined element";
return;
}
my $index = $cw->index($i);
my $lb = $cw->Subwidget('Listbox');
## Create new ListItem and set name
my $item = _JCBListItem->new;
$item->name($name);
## Set the value if it's given
my $value = $args{'-value'};
$item->value($value) if defined($value);
## Add ListItem to Internal Array and Listbox(append or splice)
my $listAR = $cw->List;
if ($lb->index('end') == $index) {
push @{$listAR}, $item;
} else {
splice(@$listAR, $index, 0, ($item, splice(@$listAR, $index)));
}
$cw->List($listAR);
$cw->ListboxInsert($index, $name);
## Set Entry as selected if option is set
my $selIndex = $cw->Selected;
my $sel = $args{'-selected'};
if ($sel && $sel =~ /yes|true|1/i) {
$cw->setSelectedIndex($index);
}
elsif ($index <= $selIndex)
{
$cw->setSelectedIndex($selIndex + 1);
}
$cw->UpdateWidth('add', $name);
}
sub popupIsVisible { return shift->Subwidget('Popup')->ismapped; }
sub removeAllItems
{
my $cw = shift;
return unless $cw->getItemCount > 0;
$cw->clearSelection;
$cw->List([]);
$cw->ListboxClear;
$cw->LongestEntry(0);
}
sub removeItemAt
{
my ($cw, $index) = @_;
my $count = $cw->getItemCount;
if ($count == 0) {
carp "There are no list elements to remove";
return;
}
my $delIndex = $cw->index($index);
$delIndex-- if (defined($index) && $index eq "end");
return unless defined $delIndex;
if ($delIndex < 0 || $delIndex >= $count) {
carp "Index: $index is out of array bounds!";
return;
}
my $selIndex = $cw->getSelectedIndex;
$cw->clearSelection;
## Delete from List and Listbox
my $listAR = $cw->List;
splice(@$listAR, $delIndex, 1);
$cw->List($listAR);
$cw->ListboxDelete($delIndex);
if ($selIndex != $delIndex) {
$selIndex-- if $delIndex < $selIndex;
$cw->setSelectedIndex($selIndex);
}
$cw->UpdateWidth('delete');
}
sub see
{
my ($cw, $index) = @_;
$index = $cw->index($index);
$cw->showPopup;
$cw->Subwidget('Listbox')->see($index) if defined($index);
}
sub setSelected
{
my ($cw, $str, %args) = @_;
my $index = $cw->getItemIndex($str, %args);
$cw->setSelectedIndex($index) if defined($index);
return 1 if defined($index);
return 0;
}
sub setSelectedIndex
{
my ($cw, $index) = @_;
$index = $cw->index($index) unless $index == -1;
return unless defined($index);
$cw->LastSelection($cw->Selected);
$cw->Selected($index);
## Adjust Listbox selection
my $listbox = $cw->Subwidget('Listbox');
$listbox->selectionClear(0, 'end');
if ($index >= 0) {
$listbox->selectionSet($index);
my $display = $cw->getItemNameAt($index);
$cw->DisplayedName($display);
}
$cw->SelectCommand();
}
sub showPopup
{
my $cw = shift;
$cw->Callback(-popupcreate => $cw)
if (ref($cw->cget('-popupcreate')) eq 'Tk::Callback');
## Set up Popup height/width and positioning, based on various
## configured options.
$cw->PopupCreate;
## Provide a hook for developers to override details taken
## care of within PopupCreate. -popupcreate should be
## encouraged over -popupmodify.
$cw->Callback(-popupmodify => $cw)
if (ref($cw->cget('-popupmodify')) eq 'Tk::Callback');
return if ($cw->popupIsVisible || $cw->getItemCount == 0);
my $popup = $cw->Subwidget('Popup');
$popup->deiconify;
$popup->raise;
$cw->Subwidget('Entry')->focus;
## PATCH (submitted by Ken Prows for CPAN BUG#12372)
if ($cw->grabCurrent)
{
$Tk::oldGrab = $cw->grabCurrent;
$Tk::oldGrabStatus = $Tk::oldGrab->grabStatus;
}
## END PATCH
$cw->grabGlobal;
}
## ===================================================================== ##
## Private Methods - avoid calling these directly - they may change ##
## ===================================================================== ##
sub AddList
{
my ($cw, $listAR, $where) = @_;
$where = "end" unless defined $where;
croak "2nd Parameter may only be 'start' or 'end'\n"
unless $where =~ /end|start|\d+/;
$where = 0 if $where eq "start";
foreach my $el (@{$listAR}) {
if (ref($el) eq 'HASH') {
my $name = $el->{'-name'} ||
croak "Invalid Menu Item. -name must be given when " .
"using a Hash reference";
my $index = $cw->insertItemAt($where, $name, %$el);
}
else {
$cw->insertItemAt($where, $el);
}
$where++ if $where ne "end";
}
}
sub AutoFind
{
my ($cw, $letter, $key) = @_;
## Determine if autofind is enabled/disabled return
## immediately if disabled. No need to continue if AutoFind
## is disabled
my $params = $cw->cget('-autofind') || {};
my $enabledOpt = GetProperty('-enable' , $params, TRUE);
my $casesensOpt = GetProperty('-casesensitive', $params, FALSE);
my $popupOpt = GetProperty('-showpopup', $params, TRUE);
my $completeOpt = GetProperty('-complete', $params, FALSE);
my $selectOpt = GetProperty('-select', $params, FALSE);
return unless IsTrue($enabledOpt);
## select takes priority over complete
$completeOpt = "false"
if (IsTrue($completeOpt) && IsTrue($selectOpt));
my $mode = $cw->cget('-mode');
my $entry = $cw->Subwidget('Entry');
my $listbox = $cw->Subwidget('Listbox');
my $searchStr = $letter;
if ($mode eq MODE_EDITABLE) {
$searchStr = substr($entry->get, 0, $entry->index('insert'));
}
if (! defined($searchStr) || length($searchStr) == 0) {
if ($mode eq MODE_EDITABLE) {
$cw->clearSelection;
$cw->hidePopup if $cw->popupIsVisible;
}
return;
}
## -casesensitive option: if enabled then distinguishes
## between a k and K key press or search string.
my $csVal = "ignorecase";
$csVal = "usecase" if IsTrue($casesensOpt);
my $start = 0;
$start = $cw->LastAFIndex + 1
if $searchStr eq $cw->LastAFSearch && defined $cw->LastAFIndex;
my $index = $cw->getItemIndex($searchStr,
-mode => $csVal,
-start => $start,
-wrap => 1);
$index = -1 if (! defined($index));
$cw->LastAFIndex($index);
$cw->LastAFSearch($searchStr);
## For all Cases, clear the selection from the Listbox
$listbox->selectionClear(0, 'end');
## There is no matching entry: Hide the popup if displayed, and
## Delete any autocompletion characters from the Edit Box, if
## -complete is enabled.
if (!defined($index) || $index < 0) {
$cw->hidePopup;
if ($mode eq MODE_EDITABLE) {
$cw->clearSelection;
$cw->DisplayedName($searchStr);
$entry->icursor(length($searchStr));
}
return;
}
## -select option: if enabled set Box and Listbox selection,
## otherwise only set Listbox selection. -select and -complete
## should never be enabled at the same time.
if (IsTrue($selectOpt)) {
$cw->setSelectedIndex($index);
$entry->icursor(length($searchStr)) if $mode eq MODE_EDITABLE;
} else {
$listbox->selectionSet($index);
}
## -complete option: enables autocompletion for the entry
## autocompletion does nothing in MODE_UNEDITABLE, and is
## ignored if the -select option is enabled.
if (IsTrue($completeOpt) && $mode eq MODE_EDITABLE) {
my $insertIndex = $entry->index('insert');
$insertIndex-- if $key eq "BackSpace";
my $endLetters = substr($cw->getItemNameAt($index), $insertIndex);
my $validateMode = $entry->cget('-validate');
$entry->configure(-validate => 'none');
$entry->selectionClear();
$entry->delete($insertIndex, 'end');
$entry->insert('end', $endLetters);
$entry->icursor($insertIndex);
$entry->selectionRange($insertIndex, 'end');
$entry->configure(-validate => $validateMode);
}
## -showpopup option: Some ComboBox implementations do not
## show a popup when their version of AutoFind is called. This
## option allows that behavior to be configured.
$cw->showPopup if IsTrue($popupOpt);
## BUG FIX (cpan#11707/Ken Prows) As of v1.03/03 Mar 05
$listbox->see($index);
}
sub BindSubwidgets
{
my $cw = shift;
my $e = $cw->Subwidget('Entry');
$e->bind('<Alt-Down>', [$cw => 'AltDown']);
$e->bind('<Alt-Up>', [$cw => 'hidePopup']);
$e->bind('<Down>', [$cw => 'UpDown', '1']);
$e->bind('<Return>', [$cw => 'Return']);
$e->bind('<FocusIn>', [$cw => 'Focus', 'In']);
$e->bind('<FocusOut>', [$cw => 'Focus', 'Out']);
$e->bind('<Escape>', [$cw => 'hidePopup']);
$e->bind('<KeyPress>', [$cw => 'KeyPress', Ev('A'), Ev('K')]);
$e->bind('<Tab>', [$cw => 'Tab']);
$e->bind('<Up>', [$cw => 'UpDown', '-1']);
if ($cw->mode eq MODE_UNEDITABLE) {
my $b = $cw->Subwidget('Button');
$b->bind('<Leave>', [$cw => 'ButtonLeave', $b, [$e]]);
$e->bind('<Leave>', [$cw => 'ButtonLeave', $e, [$b]]);
}
}
##############################################################################
## Creates a "pseudo-Button" which is a Label with some
## simpleButton-like bindings. At last check, a Button has a slightly
## different appearance on Windows than on Unix, and a Label is more
## consistent on the two platforms. On the downside, users expecting a
## Button when extracting the Subwidget are going to be disappointed...
##############################################################################
sub CreateButton {
my ($cw, %args) = @_;
my $ignoreLeave = delete $args{'-ignoreleave'};
my $frame = $cw->Subwidget('Frame');
my $button = $frame->Label(%args);
$button->bind('<ButtonPress-1>', [$cw => 'ButtonDown']);
$button->bind('<ButtonRelease-1>', [$cw => 'ButtonUp']);
$button->bind('<Leave>', [$cw => 'ButtonUp'])
if (IsFalse($ignoreLeave));
return $button;
}
#############################################################################
## Creates and advertises the widgets used for the ComboBox Popup window. The
## Popup consists of a Toplevel widget, advertised as 'Popup', that contains
## a Listbox Widget and Scrollbar. These widgets are gridded, except for the
## Scrollbar which will be gridded only when it needs to be.
#############################################################################
sub CreateListboxPopup {
my $cw = shift;
my $c = $cw->Component(
Toplevel => 'Popup',
-bd => 2,
-relief => 'groove'
);
$c->overrideredirect(1);
$c->withdraw;
my $lb = $c->Listbox(
-takefocus => 0,
-selectmode => "browse",
-exportselection => 0,
-bd => 0,
-width => 0,
-highlightthickness => 0,
)->grid(qw/-row 0 -column 0 -sticky nsew/);
$cw->Advertise(Listbox => $lb);
$cw->ListboxClear;
$c->gridRowconfigure(0, -weight => 1);
$c->gridColumnconfigure(0, -weight => 1);
my $sb = $c->Scrollbar(
-takefocus => 0,
-command => [yview => $lb]);
$lb->configure(-yscrollcommand => [set => $sb]);
$cw->Advertise(Scrollbar => $sb);
$lb->bind('<Motion>', [$cw => 'ListboxMotion', Ev('@')]);
$lb->bind('<Leave>', [$cw => 'ListboxLeave', Ev('x'), Ev('y')]);
$lb->bind('<Enter>', [$cw => 'ListboxEnter']);
$lb->bind('<ButtonRelease-1>',
[$cw => 'ButtonRelease', Ev('index',Ev('@'))]);
}
#############################################################################
## Responsible for handling logic that implements state changes to and from
## a disabled state.
##
## NOTE: Code in this method was updated using a patch submitted by
## Neal, 8 MAY 2006 that corrected a bug. When state was set to disabled
## twice in a row, the foreground color would not be changed back.
#############################################################################
sub DisableControls
{
my $cw = shift;
my $button = $cw->Subwidget('Button');
my $entry = $cw->Subwidget('Entry');
my $bg = $cw->cget('-disabledbackground');
my $fg = $cw->cget('-disabledforeground');
if ($fg ne $button->cget('-foreground')) {
$button->{$SWAP_FG} = $button->cget('-foreground');
$button->configure(-foreground => $fg);
}
$cw->configure(-takefocus => 0);
if ($cw->mode eq MODE_EDITABLE) {
$entry->configure(-state => 'disabled');
return if $Tk::VERSION >= 804;
if ($bg ne $button->cget('-background')) {
$entry->{$SWAP_BG} = $entry->cget('-background');
$entry->configure(-background => $bg);
}
}
if ($fg ne $button->cget('-foreground')) {
$entry->{$SWAP_FG} = $entry->cget('-foreground');
$entry->configure(-foreground => $fg);
}
}
sub EnableControls
{
my $cw = shift;
my $button = $cw->Subwidget('Button');
my $entry = $cw->Subwidget('Entry');
my $fg = $button->{$SWAP_FG};
return unless defined $fg;
$button->{$SWAP_FG} = $button->cget('-foreground');
$button->configure(-foreground => $fg);
if ($cw->mode eq MODE_EDITABLE) {
$entry->configure(-state => 'normal');
return if $Tk::VERSION >= 804;
my $bg = $entry->{SWAP_BG};
$entry->{$SWAP_BG} = $entry->cget('-background');
$entry->configure(-background => $bg);
}
$fg = $entry->{$SWAP_FG};
$entry->{$SWAP_FG} = $entry->cget('-foreground');
$entry->configure(-foreground => $fg);
$cw->configure(-takefocus => 1);
}
#############################################################################
## Displays a value within the Entry Subwidget, and hides the differences
## between the different modes.
#############################################################################
sub DisplayedName
{
my ($cw, $value) = @_;
my $entry = $cw->Subwidget('Entry');
## "Get routine"
if (!defined($value)) {
if ($cw->mode eq MODE_EDITABLE) {
my $val = $entry->get;
my $index = $entry->index('insert');
return substr($val, 0, $index);
}
elsif ($cw->mode eq MODE_UNEDITABLE) {
return $entry->cget('-text') || "";
}
return "";
}
## Mode is readonly, so we're dealing with Label widget.
if ($cw->mode eq MODE_UNEDITABLE) {
$entry->configure(-text => $value);
## If the mode is editable, then we're dealing with an Entry
## Widget which may have validation routines bound to it so
## there's a chance that the selected value will be rejected.
## The main idea of using a ComboBox is that the List should
## contain several values, any of which should already be valid.
## For this reason, validation is temporarily disabled then
## reenabled after Entry has been set.
} elsif ($cw->mode eq MODE_EDITABLE) {
my $validateMode = $cw->cget('-validate');
$cw->configure(-validate => 'none');
$entry->delete(0, 'end');
$entry->insert(0, $value);
$cw->configure(-validate => $validateMode);
}
}
sub GetProperty {
my ($name, $hashRef, $default, $delete) = @_;
croak "Unable to extract property from undefined Hash Reference\n"
if (!defined($hashRef));
my $val = $hashRef->{$name};
$val = $default if (!defined($val) && defined($default));
delete $hashRef->{$name} if IsTrue($delete);
return $val;
}
#############################################################################
## Arranges layout of the Advertised Entry and Button widgets. These subwidgets
## are laid out using the grid manager, which I find tends to scale downwards
## better.
#############################################################################
sub LayoutControls {
my $cw = shift;
my $frame = $cw->Subwidget('Frame');
my $entry = $cw->Subwidget('Entry');
## Editable "Button" is really a Label widget with minimal bindings. There
## were Win32 display issues with the Button widget, so I created a VERY
## basic version using Label. Look at using ImageButton in a future release.
my $button = $cw->CreateButton(
-anchor => 'center',
-bitmap => $BITMAP,
-pady => 0,
);
$button->configure(-relief => 'raised')
if $cw->mode eq MODE_EDITABLE;
$cw->Advertise(Button => $button);
$cw->Advertise(ED_Button => $button) if $cw->mode eq MODE_EDITABLE;
$cw->Advertise(RO_Button => $button) if $cw->mode eq MODE_UNEDITABLE;
my %buttonInfo = (qw/-row 0 -column 2 -sticky nsew -ipadx 2/);
$buttonInfo{"-ipady"} = 5 if $cw->mode eq MODE_UNEDITABLE;
$frame->GeometryRequest($button->ReqWidth + 2,0);
$entry->grid(qw/-row 0 -column 0 -sticky nsew/);
$button->grid(%buttonInfo);
$frame->gridRowconfigure(qw/0 -weight 1/);
$frame->gridColumnconfigure(qw/0 -weight 1/);
}
sub ListboxClear
{
my $cw = shift;
if ($Tk::version >= 8.4) {
$cw->Subwidget('Listbox')->configure(-listvariable => []);
} else {
$cw->Subwidget('Listbox')->delete(0, 'end');
}
}
sub ListboxDelete
{
my ($cw, $index) = @_;
if ($Tk::version >= 8.4) {
my @data = $cw->Subwidget('Listbox')->get(0, 'end');
splice(@data, $index, 1);
$cw->Subwidget('Listbox')->configure(-listvariable => \@data);
} else {
$cw->Subwidget('Listbox')->delete($index);
}
}
sub ListboxInsert
{
my ($cw, $index, $value) = @_;
## There appear to be issues associated with using cget to retrieve
## the array ref from the listbox, and reusing that object. Creating
## a new array seems to work fine... odd.
if ($Tk::version >= 8.4) {
my @data = $cw->Subwidget('Listbox')->get(0, 'end');
if ($cw->Subwidget('Listbox')->index('end') == $index) {
push @data, $value;
} else {
splice(@data, $index, 0, ($value, splice(@data, $index)));
}
$cw->Subwidget('Listbox')->configure(-listvariable => \@data);
} else {
$cw->Subwidget('Listbox')->insert($index, $value);
}
}
sub MatchCommand
{
my ($cw, $searchStr, $field, %args) = @_;
## Check for and use matchcommand if it exists
## Otherwise use default routines
my $retVal = $cw->Callback(-matchcommand => $searchStr, $field, %args)
if (ref($cw->cget('-matchcommand')) eq 'Tk::Callback');
return $retVal if defined $retVal;
## Extract mode (defaults to exact if not set
my $mode = lc($args{'-mode'}) || "exact";
if ($mode !~ /^((use|ignore)case|exact)$/) {
$mode = "exact";
carp "Invalid value $mode for -mode in getItemIndex - " .
"value of 'exact' assumed";
}
return 1 if $mode eq 'exact' && $field eq $searchStr;
return 1 if $mode eq 'usecase' && $field =~ /^\Q$searchStr\E/;
return 1 if $mode eq 'ignorecase' && $field =~ /^\Q$searchStr\E/i;
return 0;
}
#############################################################################
## Takes a list of one or more subwidgets and returns 1
## if the mouse pointer is pointed over any one of them.
## Returns 0 otherwise.
#############################################################################
sub PointerOverWidget {
my ($cw, @widgets) = @_;
my $xPos = $cw->pointerx;
my $yPos = $cw->pointery;
my $overWidget = $cw->containing($xPos, $yPos);
foreach my $w (@widgets) {
return TRUE if defined $overWidget && $w == $overWidget ;
}
return FALSE;
}
#############################################################################
## Notifies a registered SelectCommand that a new item has
## been selected. A selection can occur in a large number
## of ways. The tricky bit is to ensure that it gets called
## when the selection changes, but does not get called
## repeatedly for the same selection. Most of the complication
## has to do with the editable mode.
#############################################################################
sub SelectCommand
{
my $cw = shift;
my $selIndex = $cw->getSelectedIndex;
my $selName = $cw->DisplayedName || "";
## First validate each index
my $newIndex;
$newIndex = $cw->getItemIndex($selName) unless $selName eq "";
$newIndex = -1 unless defined($newIndex);
if ($selIndex != $newIndex) {
$cw->setSelectedIndex($newIndex);
return;
}
## Selected index has been validated - now, check to
## see if there was a difference between it and the
## last selection.
my $notifyObserver = 0;
$notifyObserver = 1 if
($selIndex != $cw->LastSelection || $selName ne $cw->LastSelName);
if ($notifyObserver) {
my $selValue = $cw->getSelectedValue;
$cw->LastSelName($selName);
$cw->LastSelection($selIndex);
$cw->Callback(-selectcommand => $cw, $selIndex, $selName, $selValue)
if (ref($cw->cget('-selectcommand')) eq 'Tk::Callback');
}
}
#############################################################################
## Default Callback for -popupcreate option this method determines the correct
## size and placement of the Popup triggered by the ComboBox Button, and then
## displays it. Just prior to displaying the Popup, the Callback assigned to
## to -popupmodify will be called allowing additional popup configuration to
## be modified prior to being displayed. This would be used if someone wants
## to make minor changes to Popup, but still use the ShowPopup implementation.
#############################################################################
sub PopupCreate {
my $cw = shift;
my $popup = $cw->Subwidget("Popup");
my $listbox = $cw->Subwidget("Listbox");
my $scrollbar = $cw->Subwidget("Scrollbar");
my $entry = $cw->Subwidget("Entry");
$cw->UpdateListboxHeight;
## Scrolled turns propagate off, but I need it on
$listbox->Tk::pack('propagate',1);
my $maxX = $cw->vrootwidth; ## Max X position
my $maxY = $cw->vrootheight; ## Max Y position
## Determine X/Y position of Popup -- Initially, the Popup should be
## displayed directly below the ComboBox, and aligned to the left side.
## This may change depending on placement of the ComboBox on the Screen.
my $popupPosX = $cw->rootx;
my $popupPosY = $cw->rooty + $cw->height;
my $popupWidth = $cw->width; ## Defaults to width of the ComboBox
my $popupHeight = $listbox->ReqHeight + $popup->cget('-borderwidth') * 2;
## Override width if -listwidth is defined
my $listWidth = $cw->cget('-listwidth');
if (defined $listWidth && $listWidth > -1) {
$listbox->configure(-width => $listWidth);
$popupWidth = $listbox->ReqWidth + $popup->cget('-borderwidth') * 2;
$popupWidth = $popupWidth + $scrollbar->ReqWidth if $scrollbar->manager;
}
## X/Y values must be at least 0, to display popup on screen. Typically,
## this will only ever be a problem for the X value.
$popupPosX = 0 if $popupPosX < 0;
$popupPosY = 0 if $popupPosY < 0;
## X/Y values must not allow the popup to be displayed beyond the maximum
## limits allowed for the screen. Again, this will might happen
$popupPosX = $maxX - $popupWidth if (($popupPosX + $popupWidth) > $maxX);
$popupPosY = $maxY - $popupHeight if (($popupPosY + $popupHeight) > $maxY);
## Unfortunately, just moving the Popup will only do so much if the Popup
## is larger than what the screen will support. So, to prevent this from
## occurring the following failsafe should prevent the popup from being
## displayed off screen. A mandatory maximum height is placed on the List.
## Currently, this does not override the maxrows option and will have to be
## calculated each time the popup is displayed. Hopefully, this condition
## will only be needed for exceptional cases.
my $listboxHeight = $listbox->size;
if ($popupHeight > $maxY) {
while ($popupHeight > $maxY) {
$listboxHeight--;
$listbox->configure(-height => $listboxHeight);
$listbox->update;
$popupHeight = $listbox->ReqHeight + $popup->cget('-borderwidth') * 2;
}
$popupPosY = $maxY - $popupHeight;
}
## Position and adjust the width/height of the Popup prior to display.
$popup->geometry(sprintf("%dx%d+%d+%d",
$popupWidth,
$popupHeight,
$popupPosX,
$popupPosY));
}
sub UpdateListboxHeight
{
my $cw = shift;
my $listbox = $cw->Subwidget('Listbox');
my $sb = $cw->Subwidget('Scrollbar');
## Ensure that the Listbox is no larger than the maxrow size
## and at least as large as 1. If maxrow size is set to 0 or
## lower then the Listbox will grow/shrink as large as it needs
## to display all items. The Listbox drives what the height of the
## popup will be.
my $rows = $listbox->size;
my $maxRows = $cw->cget('-maxrows');
if ($maxRows >= 0 && $maxRows < $rows) {
$rows = $maxRows;
$sb->grid(qw/-row 0 -column 1 -sticky ns/) if ! $sb->manager;
}
else {
$sb->gridForget if $sb->manager;
}
$listbox->configure(-height => $rows);
}
##############################################################################
## Updates the width of the widget dynamically based on the longest list
## entry. This is similar to specifying 0 or less for the Listbox widget. If
## -entrywidth is greater than 0
#############################################################################
sub UpdateWidth {
my ($cw, $action, $name) = @_;
my $entry = $cw->Subwidget('Entry');
## updates the width automatically if width has been set to -1, which
## is the default, and anything greater than the default will force the
## width to be static, otherwise it will be as wide as the longest element
## in the List. *Feature request: Bryan Williams (bitbucketz2002@yahoo.com)
## - 2003-06-18
my $w = $cw->cget('-entrywidth');
$w = -1 unless defined $w; ## Assume -1
if ($w >= 0) {
my $gap = $cw->gap;
$w = $w + $gap if $w > 0;
$entry->configure(-width => $w);
return;
}
if ($action eq "add") {
my $len = length($name);
return if ($len <= $cw->LongestEntry);
$cw->LongestEntry($len);
}
elsif ($action eq "delete") {
my $currLen = 0;
foreach my $item (@{$cw->List}) {
$currLen = length($item->name) if $currLen < length($item->name);
}
$cw->LongestEntry($currLen) if $cw->LongestEntry > $currLen;
}
$cw->LongestEntry($cw->gap + $cw->LongestEntry);
$entry->configure(-width => $cw->LongestEntry);
}
#############################################################################
## Callback registered to -validatecommand when the -validate options values
## is "match" or "cs-match".
#############################################################################
sub ValidateCommand
{
my ($cw, $str, $chars, $currval, $i, $action) = @_;
my $mode = $cw->cget('-validate');
if ($mode !~ /match/) {
my $vc = $cw->cget('-validatecommand');
return TRUE unless defined $vc;
return $vc->Call($str, $chars, $currval, $i, $action) if defined($vc);
}
my $index;
if ($mode eq VAL_MODE_MATCH) {
$index = $cw->getItemIndex($str, -mode => 'ignorecase');
}
elsif ($mode eq VAL_MODE_CSMATCH) {
$index = $cw->getItemIndex($str, -mode => 'usecase');
}
return TRUE if (defined($index));
return FALSE;
}
## ========================================================= ##
## JComboBox Event Handler Routines
## ========================================================= ##
sub AltDown
{
my $cw = shift;
return unless $cw->state eq 'normal';
if ($cw->popupIsVisible) { $cw->hidePopup; }
else { $cw->showPopup; }
}
sub ButtonDown
{
my $cw = shift;
return unless ($cw->state eq 'normal');
my $mode = $cw->cget('-mode');
my $button;
$button = $cw->Subwidget('Frame') if $cw->mode eq MODE_UNEDITABLE;
$button = $cw->Subwidget('Button') if $cw->mode eq MODE_EDITABLE;
$cw->IsButtonDown(TRUE);
$cw->TempRelief($button->cget('-relief'));
$button->configure(-relief => 'sunken');
## Call buttoncommand if defined
$cw->Callback(-buttoncommand => $cw, $cw->getSelectedIndex)
if (ref($cw->cget('-buttoncommand')) eq 'Tk::Callback');
}
sub ButtonLeave
{
my ($cw, $trigger, $ignoreLeave) = @_;
return unless $cw->state eq 'normal';
return if (IsFalse($cw->IsButtonDown));
if (defined($ignoreLeave) && ref($ignoreLeave) eq "ARRAY") {
if (IsTrue($cw->PointerOverWidget($ignoreLeave))) {
$trigger->bind('<Motion>',
[$cw => 'ButtonMotion', $trigger, [$trigger, @$ignoreLeave]]);
return;
}
}
$cw->ButtonUp;
}
sub ButtonMotion
{
my ($cw, $trigger, $widgetAR) = @_;
return unless $cw->state eq 'normal';
## If The Button is Up, then we no longer need this binding.
if (IsFalse($cw->IsButtonDown)) {
$trigger->bind('<Motion>', "");
return;
}
if (IsFalse($cw->PointerOverWidget(@{$widgetAR}))) {
$cw->ButtonUp;
}
}
sub ButtonRelease
{
my ($cw, $index) = @_;
return unless $cw->state eq 'normal';
return unless $cw->popupIsVisible;
$cw->hidePopup;
$cw->setSelectedIndex($index) if defined($index);
}
sub ButtonUp {
my $cw = shift;
return unless $cw->state eq 'normal';
## Take care of returning the button relief
my $button;
my $mode = $cw->cget('-mode');
if ($mode eq MODE_UNEDITABLE) { $button = $cw->Subwidget('Frame'); }
elsif ($mode eq MODE_EDITABLE) { $button = $cw->Subwidget('Button'); }
if ($cw->TempRelief) {
$button->configure(-relief => $cw->TempRelief);
$cw->TempRelief(0);
}
$cw->IsButtonDown(FALSE);
}
sub Focus
{
my ($cw, $inOut) = @_;
my $bg = $cw->highlightcolor;
my $color = $cw->highlightbackground;
$cw->highlightcolor($color);
$cw->highlightbackground($bg);
$cw->SelectCommand if (defined($inOut) && $inOut eq "Out");
}
sub KeyPress
{
my ($cw, $uChar, $keySym) = @_;
return unless $cw->state eq 'normal';
my $kc = $cw->cget('-keycommand');
$kc->Call($cw, $uChar, $keySym) if defined $kc;
$cw->AutoFind($uChar, $keySym);
}
sub ListboxEnter
{
my $cw = shift;
return if IsFalse($cw->cget('-listhighlight'));
$cw->Subwidget('Listbox')->CancelRepeat;
}
sub ListboxLeave
{
my ($cw, $x, $y) = @_;
return if IsFalse($cw->cget('-listhighlight'));
$cw->Subwidget('Listbox')->AutoScan($x, $y);
}
sub ListboxMotion
{
my ($cw, $xy) = @_;
return if IsFalse($cw->cget('-listhighlight'));
my $listbox = $cw->Subwidget('Listbox');
my $index = $listbox->index($xy);
$listbox->Motion($index);
}
## TO DO -- I don't think this method is doing the right thing
## it is called NonSelect yet it IS selecting.
sub NonSelect {
my $cw = shift;
return unless $cw->popupIsVisible;
$cw->hidePopup;
my $index = $cw->getSelectedIndex;
$cw->setSelectedIndex($index) if defined($index);
}
sub RedirectFocus { shift->Subwidget('Entry')->focus; }
sub Return
{
my $cw = shift;
return unless $cw->state eq 'normal';
my ($index) = $cw->Subwidget('Listbox')->curselection;
$index = -1 unless defined($index);
$cw->hidePopup if $cw->popupIsVisible;
$cw->Subwidget('Entry')->selectionClear() if $cw->mode eq MODE_EDITABLE;
$cw->setSelectedIndex($index) if defined($index);
}
sub Tab
{
my $cw = shift;
$cw->Return;
$cw->focusNext;
}
sub TextvarFetch
{
return shift->getItemValueAt('selected');
}
sub TextvarStore
{
my ($cw, $watch, $value) = @_;
if (!defined($value) || $value eq "") {
$cw->clearSelection();
return;
}
## If the item value exists within the list, then selected it.
my $index = $cw->getItemIndex($value, -type => 'value');
if (defined($index) && $index != -1) {
$cw->setSelectedIndex($index);
}
## Otherwise, only set it, if the mode is editable (allows
## values that are not in the list.
else {
$cw->DisplayedName($value) if $cw->mode eq MODE_EDITABLE;
}
}
sub UpDown
{
my ($cw, $mod) = @_;
return unless $cw->state eq 'normal';
return unless (defined($mod) && ($mod =~ /^(|-)?\d+$/));
my $lastIndex = $cw->getItemCount() - 1;
my $listbox = $cw->Subwidget('Listbox');
my ($index) = $listbox->curselection;
$index = -1 if !defined($index) || $index eq "";
my $modIndex = $index + $mod;
$modIndex = $lastIndex if $modIndex > $lastIndex;
$modIndex = 0 if $modIndex < 0;
return if $modIndex == $index;
my $selectOpt = $cw->cget('-updownselect');
if (IsTrue($selectOpt)) {
$cw->setSelectedIndex($modIndex);
}
else {
$listbox = $cw->Subwidget('Listbox');
$listbox->selectionClear(0, 'end');
$listbox->selectionSet($modIndex);
}
}
###########################################################################
## The package below is highly experimental and subject to massive change
## and/or deprecation in future versions of JComboBox. Use at your own risk.
###########################################################################
package Tk::JComboBox::Tie;
use strict;
use Carp;
use Tie::Array;
use vars qw($VERSION);
our $VERSION = "0.01";
use base qw(Tie::Array);
sub addWatcher
{
my ($self, $watcher) = @_;
return unless ref($watcher) eq 'Tk::JComboBox';
push @{$self->{LISTENERS}}, $watcher
if $self->FindWatcher($watcher) < 0;
}
sub removeWatcher
{
my ($self, $watcher) = @_;
my $index = $self->FindWatcher($watcher);
splice @{$self->{LISTENERS}}, $index, 1 unless $index < 0;
}
sub tie
{
my ($pkg, $jcb, $newListAR, $oldListAR) = @_;
## 1st Determine if the oldListAR has been tied to. It
## will almost ALWAYS be tied to, except for the first
## time -choices have been configured to a JComboBox.
my $listenerAR;
my $oldTie = tied @$oldListAR
if (defined $oldListAR && ref($oldListAR) eq 'ARRAY');
if (defined($oldTie)) {
## This widget was the master, copy all listeners
## before breaking the tie, so that we can maintain
## existing ties.
if ($jcb == $oldTie->Master) {
$oldTie->CLEAR;
$listenerAR = $oldTie->{LISTENERS};
shift @$listenerAR;
$oldTie = undef;
untie @$oldListAR;
}
## This widget is not the master, the tie is not ours
## to break. Remove this widget as a listener -- it
## will be a master of a it's own tie. Then clear all
## its items.
else {
$oldTie->removeWatcher($jcb);
}
}
$jcb->removeAllItems if $jcb->getItemCount > 0;
## At this point, there should be no tie, or the JCombobox
## has been removed as a listener from an existing one. This
## is to clear the way to either create a new tie or add it
## as a listener to a different tie.
my $newTie;
if (ref($newListAR) eq 'ARRAY') {
$newTie = tied @$newListAR;
my @items = @$newListAR;
## Check to see if the new ListAR already is tied. If it is, and
## and it is tied to a JComboBox, then we will register this
## widget as a listener, and will not recreate the tie.
if (defined($newTie) && ref($newTie) eq 'Tk::JComboBox::Tie') {
$newTie->addWatcher($jcb);
$jcb->AddList(\@items, "end");
}
## The new list has not been tied to anything yet, so we're going
## to create a new Tie with the specified JComboBox as the master.
## If this widget was a previous master, then all of its listeners
## will be swapped to the new tie.
else {
$newTie = tie @$newListAR, 'Tk::JComboBox::Tie', $jcb;
$jcb->AddList(\@items, "end");
foreach my $l (@$listenerAR) {
$l->configure(-choices => \@$newListAR);
}
}
}
return $newTie;
}
## ========================================================= ##
## PRIVATE METHODS ##
## ========================================================= ##
sub CLEAR
{
my $self = shift;
$self->Notify(-method => 'CLEAR_W') if $self->FETCHSIZE > 0;
}
sub CLEAR_W { $_[1]->removeAllItems }
sub DELETE { shift->SPLICE(shift, 1) }
sub DESTROY
{
my $self = shift;
foreach my $listener (@{$self->{LISTENERS}}) {
$listener->configure(-choices => "")
if ref($listener) eq 'Tk::JComboBox' && Tk::Exists($listener);
}
}
sub FETCH
{
my ($self, $index) = @_;
return undef if $index + 1 > $self->FETCHSIZE;
return $self->GetItemValues($self->Master, $index);
}
sub FETCHSIZE { shift->Master->getItemCount }
sub FindWatcher
{
my ($self, $watcher) = @_;
if (ref($watcher)) {
foreach my $i (0 .. (scalar(@{$self->{LISTENERS}})-1)) {
return $i if ($self->{LISTENERS}->[$i] == $watcher);
}
}
return -1;
}
sub GetItemValues
{
my ($self, $w, $index) = @_;
$index = $w->index($index);
my $count = $w->getItemCount;
return if $index >= $w->getItemCount;
my $item = $w->List->[$index];
my $rv = $item->name;
if ($item->value) {
$rv = { -name => $item->name };
$rv->{'-value'} = $item->value if defined($item->value);
}
return $rv;
}
sub Master { return shift->{LISTENERS}->[0] }
sub Notify
{
my ($self, %args) = @_;
## For some reason, the JComboBox sticks around in memory
## after it's been destroyed. Remove any destroyed
## widgets from the list of listeners prior to notification.
my @good;
foreach my $listener (@{$self->{LISTENERS}}) {
if (Tk::Exists($listener)) {
push @good, $listener;
}
else {
undef $listener;
}
}
$self->{LISTENERS} = \@good;
my $method = delete $args{-method};
my $except = delete $args{-except};
my $paramAR = delete $args{-params};
foreach my $listener (@{$self->{LISTENERS}})
{
next if (defined($except) && $listener == $except);
$self->$method($listener, @$paramAR);
}
}
sub POP { shift->SPLICE("last", 1) }
sub PUSH { shift->SPLICE("end", 0, @_) }
sub RemoveItemValues
{
my ($self, $w, $index) = @_;
$index = $w->index($index);
my $rv = $self->GetItemValues($w, $index);
$w->removeItemAt($index);
return $rv;
}
sub RemoveList
{
my ($self, $w, $start, $length) = @_;
my @rv;
return if $start + 1 > $w->getItemCount;
$length = $w->getItemCount - $start if !defined($length);
$length = ($w->getItemCount + $length) - $start if $length < 0;
if ($length > 0) {
foreach (1 .. $length) {
push @rv, $self->RemoveItemValues($w, $start++);
}
}
return @rv;
}
sub SHIFT { shift->SPLICE("first", 1) }
sub SPLICE
{
my $self = shift;
my $master = $self->Master;
return if !defined($master);
$self->Notify(
-method => 'SPLICE_W',
-params => \@_,
-except => $master
);
$self->SPLICE_W($master, @_);
}
sub SPLICE_W
{
my ($self, $w, $offset, $length, @list) = @_;
my $bounds = $w->getItemCount;
$offset = 0 unless defined $offset;
$offset = $w->index($offset);
$offset = $bounds + $offset if $offset < 0;
return if $offset > $bounds;
my @removed = $self->RemoveList($w, $offset, $length);
$w->AddList(\@list, $offset) if @list;
return undef unless @removed;
return wantarray ? @removed : $removed[scalar(@removed)-1];
}
sub STORESIZE {}
sub STORE { shift->SPLICE(shift, 1, shift) }
sub TIEARRAY
{
my ($class, $jcb) = @_;
croak "Widget parameter was not a Tk::JComboBox!"
unless defined($jcb) && ref($jcb) eq 'Tk::JComboBox';
my $state = {
LISTENERS => [$jcb]
};
return bless $state, $class;
}
sub UNSHIFT { shift->SPLICE(0, 0, @_) }
1;