# Converted from listbox.tcl --
#
# This file defines the default bindings for Tk listbox widgets.
#
# @(#) listbox.tcl 1.7 94/12/17 16:05:18
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Modifications from standard Listbox.pm
# --------------------------------------
# 27-JAN-2001 Alasdair Allan
# Modified for local use by adding tied scalar and arrays
# Implemented TIESCALAR, TIEARRAY, FETCH, FETCHSIZE, STORE, CLEAR & EXTEND
# 31-JAN-2001 Alasdair Allan
# Made changes suggested by Tim Jenness
# 03-FEB-2001 Alasdair Allan
# Modified STORE for tied scalars to clear and select elements
# 06-FEB-2001 Alasdair Allan
# Added POD documentation for tied listbox
# 13-FEB-2001 Alasdair Allan
# Implemented EXISTS, DELETE, PUSH, POP, SHIFT & UNSHIFT for tied arrays
# 14-FEB-2001 Alasdair Allan
# Implemented SPLICE for tied arrays, all tied functionality in place
# 16-FEB-2001 Alasdair Allan
# Tweak to STORE interface for tied scalars
# 23-FEB-2001 Alasdair Allan
# Added flag to FETCH for tied scalars, modified to return hashes
# 24-FEB-2001 Alasdair Allan
# Updated Pod documentation
#
package Tk::Listbox;
use vars qw($VERSION @Selection $Prev);
use strict;
$VERSION = '4.015'; # sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
use Tk qw(Ev $XS_VERSION);
use Tk::Clipboard ();
use AutoLoader;
use base qw(Tk::Clipboard Tk::Widget);
Construct Tk::Widget 'Listbox';
bootstrap Tk::Listbox;
sub Tk_cmd { \&Tk::listbox }
Tk::Methods('activate','bbox','curselection','delete','get','index',
'insert','itemcget','itemconfigure','nearest','scan','see',
'selection','size','xview','yview');
use Tk::Submethods ( 'selection' => [qw(anchor clear includes set)],
'scan' => [qw(mark dragto)],
'xview' => [qw(moveto scroll)],
'yview' => [qw(moveto scroll)],
);
*Getselected = \&getSelected;
sub clipEvents
{
return qw[Copy];
}
sub BalloonInfo
{
my ($listbox,$balloon,$X,$Y,@opt) = @_;
my $e = $listbox->XEvent;
return if !$e;
my $index = $listbox->index('@' . $e->x . ',' . $e->y);
foreach my $opt (@opt)
{
my $info = $balloon->GetOption($opt,$listbox);
if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY'))
{
$balloon->Subclient($index);
if (defined $info->[$index])
{
return $info->[$index];
}
return '';
}
return $info;
}
}
sub ClassInit
{
my ($class,$mw) = @_;
$class->SUPER::ClassInit($mw);
# Standard Motif bindings:
$mw->bind($class,'<1>',[sub {
my $w = shift;
if (Tk::Exists($w)) {
$w->BeginSelect(@_);
}
}, Ev('index',Ev('@'))]);
$mw->bind($class, '<Double-1>' => \&Tk::NoOp);
$mw->bind($class,'<B1-Motion>',['Motion',Ev('index',Ev('@'))]);
$mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
;
$mw->bind($class,'<Shift-1>',['BeginExtend',Ev('index',Ev('@'))]);
$mw->bind($class,'<Control-1>',['BeginToggle',Ev('index',Ev('@'))]);
$mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x'),Ev('y')]);
$mw->bind($class,'<B1-Enter>','CancelRepeat');
$mw->bind($class,'<Up>',['UpDown',-1]);
$mw->bind($class,'<Shift-Up>',['ExtendUpDown',-1]);
$mw->bind($class,'<Down>',['UpDown',1]);
$mw->bind($class,'<Shift-Down>',['ExtendUpDown',1]);
$mw->XscrollBind($class);
$mw->bind($class,'<Prior>', sub {
my $w = shift;
$w->yview('scroll',-1,'pages');
$w->activate('@0,0');
});
$mw->bind($class,'<Next>', sub {
my $w = shift;
$w->yview('scroll',1,'pages');
$w->activate('@0,0');
});
$mw->bind($class,'<Control-Prior>', ['xview', 'scroll', -1, 'pages']);
$mw->bind($class,'<Control-Next>', ['xview', 'scroll', 1, 'pages']);
# <Home> and <End> defined in XscrollBind
$mw->bind($class,'<Control-Home>','Cntrl_Home');
;
$mw->bind($class,'<Shift-Control-Home>',['DataExtend',0]);
$mw->bind($class,'<Control-End>','Cntrl_End');
;
$mw->bind($class,'<Shift-Control-End>',['DataExtend','end']);
# XXX What about <<Copy>>? Already handled in Tk::Clipboard?
# $class->clipboardOperations($mw,'Copy');
$mw->bind($class,'<space>',['BeginSelect',Ev('index','active')]);
$mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]);
$mw->bind($class,'<Control-Shift-space>',['BeginExtend',Ev('index','active')]);
$mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]);
$mw->bind($class,'<Escape>','Cancel');
$mw->bind($class,'<Control-slash>','SelectAll');
$mw->bind($class,'<Control-backslash>','Cntrl_backslash');
;
# Additional Tk bindings that aren't part of the Motif look and feel:
$mw->bind($class,'<2>',['scan','mark',Ev('x'),Ev('y')]);
$mw->bind($class,'<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]);
$mw->MouseWheelBind($class); # XXX Both needed?
$mw->YMouseWheelBind($class);
return $class;
}
1;
__END__
sub TIEARRAY {
my ( $class, $obj, %options ) = @_;
return bless {
OBJECT => \$obj,
OPTION => \%options }, $class;
}
sub TIESCALAR {
my ( $class, $obj, %options ) = @_;
return bless {
OBJECT => \$obj,
OPTION => \%options }, $class;
}
# FETCH
# -----
# Return either the full contents or only the selected items in the
# box depending on whether we tied it to an array or scalar respectively
sub FETCH {
my $class = shift;
my $self = ${$class->{OBJECT}};
my %options = %{$class->{OPTION}} if defined $class->{OPTION};;
# Define the return variable
my $result;
# Check whether we are have a tied array or scalar quantity
if ( @_ ) {
my $i = shift;
# The Tk:: Listbox has been tied to an array, we are returning
# an array list of the current items in the Listbox
$result = $self->get($i);
} else {
# The Tk::Listbox has been tied to a scalar, we are returning a
# reference to an array or hash containing the currently selected items
my ( @array, %hash );
if ( defined $options{ReturnType} ) {
# THREE-WAY SWITCH
if ( $options{ReturnType} eq "index" ) {
$result = [$self->curselection];
} elsif ( $options{ReturnType} eq "element" ) {
foreach my $selection ( $self->curselection ) {
push(@array,$self->get($selection)); }
$result = \@array;
} elsif ( $options{ReturnType} eq "both" ) {
foreach my $selection ( $self->curselection ) {
%hash = ( %hash, $selection => $self->get($selection)); }
$result = \%hash;
}
} else {
# return elements (default)
foreach my $selection ( $self->curselection ) {
push(@array,$self->get($selection)); }
$result = \@array;
}
}
return $result;
}
# FETCHSIZE
# ---------
# Return the number of elements in the Listbox when tied to an array
sub FETCHSIZE {
my $class = shift;
return ${$class->{OBJECT}}->size();
}
# STORE
# -----
# If tied to an array we will modify the Listbox contents, while if tied
# to a scalar we will select and clear elements.
sub STORE {
if ( scalar(@_) == 2 ) {
# we have a tied scalar
my ( $class, $selected ) = @_;
my $self = ${$class->{OBJECT}};
my %options = %{$class->{OPTION}} if defined $class->{OPTION};;
# clear currently selected elements
$self->selectionClear(0,'end');
# set selected elements
if ( defined $options{ReturnType} ) {
# THREE-WAY SWITCH
if ( $options{ReturnType} eq "index" ) {
for ( my $i=0; $i < scalar(@$selected) ; $i++ ) {
for ( my $j=0; $j < $self->size() ; $j++ ) {
if( $j == $$selected[$i] ) {
$self->selectionSet($j); last; }
}
}
} elsif ( $options{ReturnType} eq "element" ) {
for ( my $k=0; $k < scalar(@$selected) ; $k++ ) {
for ( my $l=0; $l < $self->size() ; $l++ ) {
if( $self->get($l) eq $$selected[$k] ) {
$self->selectionSet($l); last; }
}
}
} elsif ( $options{ReturnType} eq "both" ) {
foreach my $key ( keys %$selected ) {
$self->selectionSet($key)
if $$selected{$key} eq $self->get($key);
}
}
} else {
# return elements (default)
for ( my $k=0; $k < scalar(@$selected) ; $k++ ) {
for ( my $l=0; $l < $self->size() ; $l++ ) {
if( $self->get($l) eq $$selected[$k] ) {
$self->selectionSet($l); last; }
}
}
}
} else {
# we have a tied array
my ( $class, $index, $value ) = @_;
my $self = ${$class->{OBJECT}};
# check size of current contents list
my $sizeof = $self->size();
if ( $index <= $sizeof ) {
# Change a current listbox entry
$self->delete($index);
$self->insert($index, $value);
} else {
# Add a new value
if ( defined $index ) {
$self->insert($index, $value);
} else {
$self->insert("end", $value);
}
}
}
}
# CLEAR
# -----
# Empty the Listbox of contents if tied to an array
sub CLEAR {
my $class = shift;
${$class->{OBJECT}}->delete(0, 'end');
}
# EXTEND
# ------
# Do nothing and be happy about it
sub EXTEND { }
# PUSH
# ----
# Append elements onto the Listbox contents
sub PUSH {
my ( $class, @list ) = @_;
${$class->{OBJECT}}->insert('end', @list);
}
# POP
# ---
# Remove last element of the array and return it
sub POP {
my $class = shift;
my $value = ${$class->{OBJECT}}->get('end');
${$class->{OBJECT}}->delete('end');
return $value;
}
# SHIFT
# -----
# Removes the first element and returns it
sub SHIFT {
my $class = shift;
my $value = ${$class->{OBJECT}}->get(0);
${$class->{OBJECT}}->delete(0);
return $value
}
# UNSHIFT
# -------
# Insert elements at the beginning of the Listbox
sub UNSHIFT {
my ( $class, @list ) = @_;
${$class->{OBJECT}}->insert(0, @list);
}
# DELETE
# ------
# Delete element at specified index
sub DELETE {
my ( $class, @list ) = @_;
my $value = ${$class->{OBJECT}}->get(@list);
${$class->{OBJECT}}->delete(@list);
return $value;
}
# EXISTS
# ------
# Returns true if the index exist, and undef if not
sub EXISTS {
my ( $class, $index ) = @_;
return undef unless ${$class->{OBJECT}}->get($index);
}
# SPLICE
# ------
# Performs equivalent of splice on the listbox contents
sub SPLICE {
my $class = shift;
my $self = ${$class->{OBJECT}};
# check for arguments
my @elements;
if ( scalar(@_) == 0 ) {
# none
@elements = $self->get(0,'end');
$self->delete(0,'end');
return wantarray ? @elements : $elements[scalar(@elements)-1];;
} elsif ( scalar(@_) == 1 ) {
# $offset
my ( $offset ) = @_;
if ( $offset < 0 ) {
my $start = $self->size() + $offset;
if ( $start > 0 ) {
@elements = $self->get($start,'end');
$self->delete($start,'end');
return wantarray ? @elements : $elements[scalar(@elements)-1];
} else {
return undef;
}
} else {
@elements = $self->get($offset,'end');
$self->delete($offset,'end');
return wantarray ? @elements : $elements[scalar(@elements)-1];
}
} elsif ( scalar(@_) == 2 ) {
# $offset and $length
my ( $offset, $length ) = @_;
if ( $offset < 0 ) {
my $start = $self->size() + $offset;
my $end = $self->size() + $offset + $length - 1;
if ( $start > 0 ) {
@elements = $self->get($start,$end);
$self->delete($start,$end);
return wantarray ? @elements : $elements[scalar(@elements)-1];
} else {
return undef;
}
} else {
@elements = $self->get($offset,$offset+$length-1);
$self->delete($offset,$offset+$length-1);
return wantarray ? @elements : $elements[scalar(@elements)-1];
}
} else {
# $offset, $length and @list
my ( $offset, $length, @list ) = @_;
if ( $offset < 0 ) {
my $start = $self->size() + $offset;
my $end = $self->size() + $offset + $length - 1;
if ( $start > 0 ) {
@elements = $self->get($start,$end);
$self->delete($start,$end);
$self->insert($start,@list);
return wantarray ? @elements : $elements[scalar(@elements)-1];
} else {
return undef;
}
} else {
@elements = $self->get($offset,$offset+$length-1);
$self->delete($offset,$offset+$length-1);
$self->insert($offset,@list);
return wantarray ? @elements : $elements[scalar(@elements)-1];
}
}
}
# ----
#
# Bind --
# This procedure is invoked the first time the mouse enters a listbox
# widget or a listbox widget receives the input focus. It creates
# all of the class bindings for listboxes.
#
# Arguments:
# event - Indicates which event caused the procedure to be invoked
# (Enter or FocusIn). It is used so that we can carry out
# the functions of that event in addition to setting up
# bindings.
sub xyIndex
{
my $w = shift;
my $Ev = $w->XEvent;
return $w->index($Ev->xy);
}
sub ButtonRelease_1
{
my $w = shift;
my $Ev = $w->XEvent;
$w->CancelRepeat;
$w->activate($Ev->xy);
}
sub Cntrl_Home
{
my $w = shift;
my $Ev = $w->XEvent;
$w->activate(0);
$w->see(0);
$w->selectionClear(0,'end');
$w->selectionSet(0);
$w->eventGenerate("<<ListboxSelect>>");
}
sub Cntrl_End
{
my $w = shift;
my $Ev = $w->XEvent;
$w->activate('end');
$w->see('end');
$w->selectionClear(0,'end');
$w->selectionSet('end');
$w->eventGenerate("<<ListboxSelect>>");
}
sub Cntrl_backslash
{
my $w = shift;
my $Ev = $w->XEvent;
if ($w->cget('-selectmode') ne 'browse')
{
$w->selectionClear(0,'end');
$w->eventGenerate("<<ListboxSelect>>");
}
}
# BeginSelect --
#
# This procedure is typically invoked on button-1 presses. It begins
# the process of making a selection in the listbox. Its exact behavior
# depends on the selection mode currently in effect for the listbox;
# see the Motif documentation for details.
#
# Arguments:
# w - The listbox widget.
# el - The element for the selection operation (typically the
# one under the pointer). Must be in numerical form.
sub BeginSelect
{
my $w = shift;
my $el = shift;
if ($w->cget('-selectmode') eq 'multiple')
{
if ($w->selectionIncludes($el))
{
$w->selectionClear($el)
}
else
{
$w->selectionSet($el)
}
}
else
{
$w->selectionClear(0,'end');
$w->selectionSet($el);
$w->selectionAnchor($el);
@Selection = ();
$Prev = $el
}
$w->focus if ($w->cget('-takefocus'));
$w->eventGenerate("<<ListboxSelect>>");
}
# Motion --
#
# This procedure is called to process mouse motion events while
# button 1 is down. It may move or extend the selection, depending
# on the listbox's selection mode.
#
# Arguments:
# w - The listbox widget.
# el - The element under the pointer (must be a number).
sub Motion
{
my $w = shift;
my $el = shift;
if (defined($Prev) && $el == $Prev)
{
return;
}
my $anchor = $w->index('anchor');
my $mode = $w->cget('-selectmode');
if ($mode eq 'browse')
{
$w->selectionClear(0,'end');
$w->selectionSet($el);
$Prev = $el;
$w->eventGenerate("<<ListboxSelect>>");
}
elsif ($mode eq 'extended')
{
my $i = $Prev;
if (!defined $i || $i eq '')
{
$i = $el;
$w->selectionSet($el);
}
if ($w->selectionIncludes('anchor'))
{
$w->selectionClear($i,$el);
$w->selectionSet('anchor',$el)
}
else
{
$w->selectionClear($i,$el);
$w->selectionClear('anchor',$el)
}
if (!@Selection)
{
@Selection = $w->curselection;
}
while ($i < $el && $i < $anchor)
{
if (Tk::lsearch(\@Selection,$i) >= 0)
{
$w->selectionSet($i)
}
$i++
}
while ($i > $el && $i > $anchor)
{
if (Tk::lsearch(\@Selection,$i) >= 0)
{
$w->selectionSet($i)
}
$i--
}
$Prev = $el;
$w->eventGenerate("<<ListboxSelect>>");
}
}
# BeginExtend --
#
# This procedure is typically invoked on shift-button-1 presses. It
# begins the process of extending a selection in the listbox. Its
# exact behavior depends on the selection mode currently in effect
# for the listbox; see the Motif documentation for details.
#
# Arguments:
# w - The listbox widget.
# el - The element for the selection operation (typically the
# one under the pointer). Must be in numerical form.
sub BeginExtend
{
my $w = shift;
my $el = shift;
if ($w->cget('-selectmode') eq 'extended' && $w->selectionIncludes('anchor'))
{
$w->Motion($el)
}
else
{
# No selection yet; simulate the begin-select operation.
$w->BeginSelect($el);
}
}
# BeginToggle --
#
# This procedure is typically invoked on control-button-1 presses. It
# begins the process of toggling a selection in the listbox. Its
# exact behavior depends on the selection mode currently in effect
# for the listbox; see the Motif documentation for details.
#
# Arguments:
# w - The listbox widget.
# el - The element for the selection operation (typically the
# one under the pointer). Must be in numerical form.
sub BeginToggle
{
my $w = shift;
my $el = shift;
if ($w->cget('-selectmode') eq 'extended')
{
@Selection = $w->curselection();
$Prev = $el;
$w->selectionAnchor($el);
if ($w->selectionIncludes($el))
{
$w->selectionClear($el)
}
else
{
$w->selectionSet($el)
}
$w->eventGenerate("<<ListboxSelect>>");
}
}
# AutoScan --
# This procedure is invoked when the mouse leaves an entry window
# with button 1 down. It scrolls the window up, down, left, or
# right, depending on where the mouse left the window, and reschedules
# itself as an "after" command so that the window continues to scroll until
# the mouse moves back into the window or the mouse button is released.
#
# Arguments:
# w - The entry window.
# x - The x-coordinate of the mouse when it left the window.
# y - The y-coordinate of the mouse when it left the window.
sub AutoScan
{
my $w = shift;
return if !Tk::Exists($w);
my $x = shift;
my $y = shift;
if ($y >= $w->height)
{
$w->yview('scroll',1,'units')
}
elsif ($y < 0)
{
$w->yview('scroll',-1,'units')
}
elsif ($x >= $w->width)
{
$w->xview('scroll',2,'units')
}
elsif ($x < 0)
{
$w->xview('scroll',-2,'units')
}
else
{
return;
}
$w->Motion($w->index("@" . $x . ',' . $y));
$w->RepeatId($w->after(50,'AutoScan',$w,$x,$y));
}
# UpDown --
#
# Moves the location cursor (active element) up or down by one element,
# and changes the selection if we're in browse or extended selection
# mode.
#
# Arguments:
# w - The listbox widget.
# amount - +1 to move down one item, -1 to move back one item.
sub UpDown
{
my $w = shift;
my $amount = shift;
$w->activate($w->index('active')+$amount);
$w->see('active');
my $mode = $w->cget('-selectmode');
if ($mode eq 'browse')
{
$w->selectionClear(0,'end');
$w->selectionSet('active');
$w->eventGenerate("<<ListboxSelect>>");
}
elsif ($mode eq 'extended')
{
$w->selectionClear(0,'end');
$w->selectionSet('active');
$w->selectionAnchor('active');
$Prev = $w->index('active');
@Selection = ();
$w->eventGenerate("<<ListboxSelect>>");
}
}
# ExtendUpDown --
#
# Does nothing unless we're in extended selection mode; in this
# case it moves the location cursor (active element) up or down by
# one element, and extends the selection to that point.
#
# Arguments:
# w - The listbox widget.
# amount - +1 to move down one item, -1 to move back one item.
sub ExtendUpDown
{
my $w = shift;
my $amount = shift;
if ($w->cget('-selectmode') ne 'extended')
{
return;
}
my $active = $w->index('active');
if (!@Selection)
{
$w->selectionSet($active);
@Selection = $w->curselection;
}
$w->activate($active + $amount);
$w->see('active');
$w->Motion($w->index('active'))
}
# DataExtend
#
# This procedure is called for key-presses such as Shift-KEndData.
# If the selection mode isn't multiple or extend then it does nothing.
# Otherwise it moves the active element to el and, if we're in
# extended mode, extends the selection to that point.
#
# Arguments:
# w - The listbox widget.
# el - An integer element number.
sub DataExtend
{
my $w = shift;
my $el = shift;
my $mode = $w->cget('-selectmode');
if ($mode eq 'extended')
{
$w->activate($el);
$w->see($el);
if ($w->selectionIncludes('anchor'))
{
$w->Motion($el)
}
}
elsif ($mode eq 'multiple')
{
$w->activate($el);
$w->see($el)
}
}
# Cancel
#
# This procedure is invoked to cancel an extended selection in
# progress. If there is an extended selection in progress, it
# restores all of the items between the active one and the anchor
# to their previous selection state.
#
# Arguments:
# w - The listbox widget.
sub Cancel
{
my $w = shift;
if ($w->cget('-selectmode') ne 'extended' || !defined $Prev)
{
return;
}
my $first = $w->index('anchor');
my $last = $Prev;
if ($first > $last)
{
($first, $last) = ($last, $first);
}
$w->selectionClear($first,$last);
while ($first <= $last)
{
if (Tk::lsearch(\@Selection,$first) >= 0)
{
$w->selectionSet($first)
}
$first++
}
$w->eventGenerate("<<ListboxSelect>>");
}
# SelectAll
#
# This procedure is invoked to handle the "select all" operation.
# For single and browse mode, it just selects the active element.
# Otherwise it selects everything in the widget.
#
# Arguments:
# w - The listbox widget.
sub SelectAll
{
my $w = shift;
my $mode = $w->cget('-selectmode');
if ($mode eq 'single' || $mode eq 'browse')
{
$w->selectionClear(0,'end');
$w->selectionSet('active')
}
else
{
$w->selectionSet(0,'end')
}
$w->eventGenerate("<<ListboxSelect>>");
}
# Perl/Tk extensions:
sub SetList
{
my $w = shift;
$w->delete(0,'end');
$w->insert('end',@_);
}
sub deleteSelected
{
my $w = shift;
my $i;
foreach $i (reverse $w->curselection)
{
$w->delete($i);
}
}
sub clipboardPaste
{
my $w = shift;
my $index = $w->index('active') || $w->index($w->XEvent->xy);
my $str;
eval {local $SIG{__DIE__}; $str = $w->clipboardGet };
return if $@;
foreach (split("\n",$str))
{
$w->insert($index++,$_);
}
}
sub getSelected
{
my ($w) = @_;
my $i;
my (@result) = ();
foreach $i ($w->curselection)
{
push(@result,$w->get($i));
}
return (wantarray) ? @result : $result[0];
}
1;
__END__