summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/TextList.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/TextList.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/TextList.pm985
1 files changed, 0 insertions, 985 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/TextList.pm b/Master/tlpkg/tlperl/lib/Tk/TextList.pm
deleted file mode 100644
index 77a48fdf8ce..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/TextList.pm
+++ /dev/null
@@ -1,985 +0,0 @@
-# Copyright (c) 1999 Greg London. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-# code for bindings taken from Listbox.pm
-
-# comments specifying method functionality taken from
-# "Perl/Tk Pocket Reference" by Stephen Lidie.
-
-#######################################################################
-# this module uses a text module as its base class to create a list box.
-# this will allow list box functionality to also have all the functionality
-# of the Text widget.
-#
-# note that most methods use an element number to indicate which
-# element in the list to work on.
-# the exception to this is the tag and mark methods which
-# are dual natured. These methods may accept either the
-# normal element number, or they will also take a element.char index,
-# which would be useful for applying tags to part of a line in the list.
-#
-#######################################################################
-
-package Tk::TextList;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '4.005'; # $Id: //depot/Tkutf8/TextList/TextList.pm#5 $
-
-#XXXdel: use Tk::Reindex qw(Tk::ROText); #XXXdel: ReindexedROText);
-
-use base qw(Tk::Derived Tk::ReindexedROText );
-
-use Tk qw (Ev);
-
-#XXX del: use base qw(Tk::ReindexedROText);
-
-Construct Tk::Widget 'TextList';
-
-#######################################################################
-# the following line causes Populate to get called
-# @ISA = qw(Tk::Derived ... );
-#######################################################################
-sub Populate
-{
- my ($w,$args)=@_;
- my $option=delete $args->{'-selectmode'};
- $w->SUPER::Populate($args);
- $w->ConfigSpecs( -selectmode => ['PASSIVE','selectMode','SelectMode','browse'],
- -takefocus => ['PASSIVE','takeFocus','TakeFocus',1],
- -spacing3 => ['SELF', undef, undef, 3],
- -insertwidth => ['SELF', undef, undef, 0],
- );
-
-}
-
-#######################################################################
-#######################################################################
-sub ClassInit
-{
- my ($class,$mw) = @_;
-
- # Standard Motif bindings:
- $mw->bind($class,'<1>',['BeginSelect',Ev('index',Ev('@'))]);
- $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->PriorNextBind($class);
-
- $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']);
- $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->bind($class,'<FocusIn>' , ['tagConfigure','_ACTIVE_TAG', -underline=>1]);
- $mw->bind($class,'<FocusOut>', ['tagConfigure','_ACTIVE_TAG', -underline=>0]);
-
- return $class;
-}
-
-#######################################################################
-# set the active element to index
-# "active" is a text "mark" which underlines the marked text.
-#######################################################################
-sub activate
-{
- my($w,$element)=@_;
- $element= $w->index($element).'.0';
- $w->SUPER::tag('remove', '_ACTIVE_TAG', '1.0','end');
- $w->SUPER::tag('add', '_ACTIVE_TAG',
- $element.' linestart', $element.' lineend');
- $w->SUPER::mark('set', 'active', $element);
-}
-
-
-#######################################################################
-# bbox returns a list (x,y,width,height) giving an approximate
-# bounding box of character given by index
-#######################################################################
-sub bbox
-{
- my($w,$element)=@_;
- $element=$w->index($element).'.0' unless ($element=~/./);
- return $w->SUPER::bbox($element);
-}
-
-#######################################################################
-# returns a list of indices of all elements currently selected
-#######################################################################
-sub curselection
-{
- my ($w)=@_;
- my @ranges = $w->SUPER::tag('ranges', 'sel');
- my @selection_list;
- while (@ranges)
- {
- my ($first,$firstcol) = split(/\./,shift(@ranges));
- my ($last,$lastcol) = split(/\./,shift(@ranges));
-
- #########################################################################
- # if previous selection ended on the same line that this selection starts,
- # then fiddle the numbers so that this line number isnt included twice.
- #########################################################################
- if (defined($selection_list[-1]) and ($first == $selection_list[-1]))
- {
- $first++; # count this selection starting from the next line.
- }
-
- if ($lastcol==0)
- {
- $last-=1;
- }
-
- #########################################################################
- # if incrementing $first causes it to be greater than $last,
- # then do nothing,
- # else add (first .. last) to list
- #########################################################################
- unless ($first>$last)
- {
- push(@selection_list, $first .. $last);
- }
- }
- return @selection_list;
-}
-
-
-#######################################################################
-# deletes range of elements from element1 to element2
-# defaults to element1
-#######################################################################
-sub delete
-{
- my ($w, $element1, $element2)=@_;
- $element1=$w->index($element1);
- $element2=$element1 unless(defined($element2));
- $element2=$w->index($element2);
- $w->SUPER::delete($element1.'.0' , $element2.'.0 lineend');
-}
-
-#######################################################################
-# deletes range of characters from index1 to index2
-# defaults to index1+1c
-# index is line.char notation.
-#######################################################################
-sub deleteChar
-{
- my ($w, $index1, $index2)=@_;
- $index1=$w->index($index1);
- $index2=$index1.' +1c' unless(defined($index2));
- $index2=$w->index($index2);
- $w->SUPER::delete($index1, $index2);
-}
-
-#######################################################################
-# returns as a list contents of elements from $element1 to $element2
-# defaults to element1.
-#######################################################################
-sub get
-{
- my ($w, $element1, $element2)=@_;
- $element1=$w->index($element1);
- $element2=$element1 unless(defined($element2));
- $element2=$w->index($element2);
- my @getlist;
- for(my $i=$element1; $i<=$element2; $i++)
- {
- push(@getlist, $w->SUPER::get($i.'.0 linestart', $i.'.0 lineend'));
- }
-
- return @getlist;
-}
-
-#######################################################################
-# return text between index1 and index2 which are line.char notation.
-# return value is a single string. index2 defaults to index1+1c
-# index is line.char notation.
-######################################################################
-sub getChar
-{
- my $w=shift;
- return $w->SUPER::get(@_);
-}
-
-#######################################################################
-# returns index in number notation
-# this method returns an element number, ie the 5th element.
-#######################################################################
-sub index
-{
- my ($w,$element)=@_;
- return undef unless(defined($element));
- $element .= '.0' unless $element=~/\D/;
- $element = $w->SUPER::index($element);
- my($line,$col)=split(/\./,$element);
- return $line;
-}
-
-#######################################################################
-# returns index in line.char notation
-# this method returns an index specific to a character within an element
-#######################################################################
-sub indexChar
-{
- my $w=shift;
- return $w->SUPER::index(@_);
-}
-
-
-#######################################################################
-# inserts specified elements just before element at index
-#######################################################################
-sub insert
-{
- my $w=shift;
- my $element=shift;
- $element=$w->index($element);
- my $item;
- while (@_)
- {
- $item = shift(@_);
- $item .= "\n";
- $w->SUPER::insert($element++.'.0', $item);
- }
-}
-
-#######################################################################
-# inserts string just before character at index.
-# index is line.char notation.
-#######################################################################
-sub insertChar
-{
- my $w=shift;
- $w->SUPER::insert(@_);
-}
-
-
-
-#######################################################################
-# returns index of element nearest to y-coordinate
-#
-# currently not defined
-#######################################################################
-#sub nearest
-#{
-# return undef;
-#}
-
-#######################################################################
-# Sets the selection anchor to element at index
-#######################################################################
-sub selectionAnchor
-{
- my ($w, $element)=@_;
- $element=$w->index($element);
- $w->SUPER::mark('set', 'anchor', $element.'.0');
-}
-
-#######################################################################
-# deselects elements between index1 and index2, inclusive
-#######################################################################
-sub selectionClear
-{
- my ($w, $element1, $element2)=@_;
- $element1=$w->index($element1);
- $element2=$element1 unless(defined($element2));
- $element2=$w->index($element2);
- $w->SUPER::tag('remove', 'sel', $element1.'.0', $element2.'.0 lineend +1c');
-}
-
-#######################################################################
-# returns 1 if element at index is selected, 0 otherwise.
-#######################################################################
-sub selectionIncludes
-{
- my ($w, $element)=@_;
- $element=$w->index($element);
- my @list = $w->curselection;
- my $line;
- foreach $line (@list)
- {
- if ($line == $element) {return 1;}
- }
- return 0;
-}
-
-#######################################################################
-# adds all elements between element1 and element2 inclusive to selection
-#######################################################################
-sub selectionSet
-{
- my ($w, $element1, $element2)=@_;
- $element1=$w->index($element1);
- $element2=$element1 unless(defined($element2));
- $element2=$w->index($element2);
- $w->SUPER::tag('add', 'sel', $element1.'.0', $element2.'.0 lineend +1c');
-}
-
-#######################################################################
-# for ->selection(option,args) calling convention
-#######################################################################
-sub selection
-{
-# my ($w,$sub)=(shift,"selection".ucfirst(shift));
-# no strict 'refs';
-# # can't use $w->$sub, since it might call overridden method-- bleh
-# &($sub)($w,@_);
-}
-
-
-#######################################################################
-# adjusts the view in window so element at index is completely visible
-#######################################################################
-sub see
-{
- my ($w, $element)=@_;
- $element=$w->index($element);
- $w->SUPER::see($element.'.0');
-}
-
-#######################################################################
-# returns number of elements in listbox
-#######################################################################
-sub size
-{
- my ($w)=@_;
- my $element = $w->index('end');
- # theres a weird thing with the 'end' mark sometimes being on a line
- # with text, and sometimes being on a line all by itself
- my ($text) = $w->get($element);
- if (length($text) == 0)
- {$element -= 1;}
- return $element;
-}
-
-
-
-#######################################################################
-# add a tag based on element numbers
-#######################################################################
-sub tagAdd
-{
- my ($w, $tagName, $element1, $element2)=@_;
- $element1=$w->index($element1);
- $element1.='.0';
-
- $element2=$element1.' lineend' unless(defined($element2));
- $element2=$w->index($element2);
- $element2.='.0 lineend +1c';
-
- $w->SUPER::tag('add', $tagName, $element1, $element2);
-}
-
-#######################################################################
-# add a tag based on line.char indexes
-#######################################################################
-sub tagAddChar
-{
- my $w=shift;
- $w->SUPER::tag('add',@_);
-}
-
-
-#######################################################################
-# remove a tag based on element numbers
-#######################################################################
-sub tagRemove
-{
- my ($w, $tagName, $element1, $element2)=@_;
- $element1=$w->index($element1);
- $element1.='.0';
-
- $element2=$element1.' lineend' unless(defined($element2));
- $element2=$w->index($element2);
- $element2.='.0 lineend +1c';
-
- $w->SUPER::tag('remove', 'sel', $element1, $element2);
-}
-
-#######################################################################
-# remove a tag based on line.char indexes
-#######################################################################
-sub tagRemoveChar
-{
- my $w=shift;
- $w->SUPER::tag('remove', @_);
-}
-
-
-
-
-#######################################################################
-# perform tagNextRange based on element numbers
-#######################################################################
-sub tagNextRange
-{
- my ($w, $tagName, $element1, $element2)=@_;
- $element1=$w->index($element1);
- $element1.='.0';
-
- $element2=$element1 unless(defined($element2));
- $element2=$w->index($element2);
- $element2.='.0 lineend +1c';
-
- my $index = $w->SUPER::tag('nextrange', 'sel', $element1, $element2);
- my ($line,$col)=split(/\./,$index);
- return $line;
-}
-
-#######################################################################
-# perform tagNextRange based on line.char indexes
-#######################################################################
-sub tagNextRangeChar
-{
- my $w=shift;
- $w->SUPER::tag('nextrange', @_);
-}
-
-#######################################################################
-# perform tagPrevRange based on element numbers
-#######################################################################
-sub tagPrevRange
-{
- my ($w, $tagName, $element1, $element2)=@_;
- $element1=$w->index($element1);
- $element1.='.0';
-
- $element2=$element1 unless(defined($element2));
- $element2=$w->index($element2);
- $element2.='.0 lineend +1c';
-
- my $index = $w->SUPER::tag('prevrange', 'sel', $element1, $element2);
- my ($line,$col)=split(/\./,$index);
- return $line;
-}
-
-#######################################################################
-# perform tagPrevRange based on line.char indexes
-#######################################################################
-sub tagPrevRangeChar
-{
- my $w=shift;
- $w->SUPER::tag('prevrange', @_);
-}
-
-
-
-#######################################################################
-# perform markSet based on element numbers
-#######################################################################
-sub markSet
-{
- my ($w,$mark,$element1)=@_;
- $element1=$w->index($element1);
- $element1.='.0';
- $w->SUPER::mark('set', $element1,$mark);
-}
-
-#######################################################################
-# perform markSet based on line.char indexes
-#######################################################################
-sub markSetChar
-{
- my $w=shift;
- $w->SUPER::mark('set', @_);
-}
-
-#######################################################################
-# perform markNext based on element numbers
-#######################################################################
-sub markNext
-{
- my ($w,$element1)=@_;
- $element1=$w->index($element1);
- $element1.='.0';
- return $w->SUPER::mark('next', $element1);
-}
-
-#######################################################################
-# perform markNext based on line.char indexes
-#######################################################################
-sub markNextChar
-{
- my $w=shift;
- $w->SUPER::mark('next', @_);
-}
-
-
-#######################################################################
-# perform markPrevious based on element numbers
-#######################################################################
-sub markPrevious
-{
- my ($w,$element1)=@_;
- $element1=$w->index($element1);
- $element1.='.0';
- return $w->SUPER::mark('previous', $element1);
-}
-
-#######################################################################
-# perform markPrevious based on line.char indexes
-#######################################################################
-sub markPreviousChar
-{
- my $w=shift;
- $w->SUPER::mark('previous', @_);
-}
-
-
-
-
-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)
-}
-
-
-sub Cntrl_End
-{
- my $w = shift;
- my $Ev = $w->XEvent;
- $w->activate('end');
- $w->see('end');
- $w->selectionClear(0,'end');
- $w->selectionSet('end')
-}
-
-
-sub Cntrl_backslash
-{
- my $w = shift;
- my $Ev = $w->XEvent;
- if ($w->cget('-selectmode') ne 'browse')
- {
- $w->selectionClear(0,'end');
- }
-}
-
-# 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);
- my @list = ();
- $w->{'SELECTION_LIST_REF'} = \@list;
- $w->{'PREVIOUS_ELEMENT'} = $el
- }
- $w->focus if ($w->cget('-takefocus'));
-}
-# 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($w->{'PREVIOUS_ELEMENT'}) && $el == $w->{'PREVIOUS_ELEMENT'})
- {
- return;
- }
-
- # if no selections, select current
- if($w->curselection==0)
- {
- $w->activate($el);
- $w->selectionSet($el);
- $w->selectionAnchor($el);
- $w->{'PREVIOUS_ELEMENT'}=$el;
- return;
- }
-
- my $anchor = $w->index('anchor');
- my $mode = $w->cget('-selectmode');
- if ($mode eq 'browse')
- {
- $w->selectionClear(0,'end');
- $w->selectionSet($el);
- $w->{'PREVIOUS_ELEMENT'} = $el;
- }
- elsif ($mode eq 'extended')
- {
- my $i = $w->{'PREVIOUS_ELEMENT'};
- if ($w->selectionIncludes('anchor'))
- {
- $w->selectionClear($i,$el);
- $w->selectionSet('anchor',$el)
- }
- else
- {
- $w->selectionClear($i,$el);
- $w->selectionClear('anchor',$el)
- }
- while ($i < $el && $i < $anchor)
- {
- if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$i) >= 0)
- {
- $w->selectionSet($i)
- }
- $i += 1
- }
- while ($i > $el && $i > $anchor)
- {
- if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$i) >= 0)
- {
- $w->selectionSet($i)
- }
- $i += -1
- }
- $w->{'PREVIOUS_ELEMENT'} = $el
- }
-}
-# 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 no selections, select current
- if($w->curselection==0)
- {
- $w->activate($el);
- $w->selectionSet($el);
- $w->selectionAnchor($el);
- $w->{'PREVIOUS_ELEMENT'}=$el;
- return;
- }
-
- if ($w->cget('-selectmode') eq 'extended' && $w->selectionIncludes('anchor'))
- {
- $w->Motion($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')
- {
- my @list = $w->curselection();
- $w->{'SELECTION_LIST_REF'} = \@list;
- $w->{'PREVIOUS_ELEMENT'} = $el;
- $w->selectionAnchor($el);
- if ($w->selectionIncludes($el))
- {
- $w->selectionClear($el)
- }
- else
- {
- $w->selectionSet($el)
- }
- }
-}
-# AutoScan --
-# This procedure is invoked when the mouse leaves an entry window
-# with button 1 down. It scrolls the window up, down, left, or
-# right, depending on where the mouse left the window, and reschedules
-# itself as an "after" command so that the window continues to scroll until
-# the mouse moves back into the window or the mouse button is released.
-#
-# Arguments:
-# w - The 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;
- 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 $selectmode = $w->cget('-selectmode');
- if ($selectmode eq 'browse')
- {
- $w->selectionClear(0,'end');
- $w->selectionSet('active')
- }
- elsif ($selectmode eq 'extended')
- {
- $w->selectionClear(0,'end');
- $w->selectionSet('active');
- $w->selectionAnchor('active');
- $w->{'PREVIOUS_ELEMENT'} = $w->index('active');
- my @list = ();
- $w->{'SELECTION_LIST_REF'}=\@list;
- }
-}
-# 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;
- }
- $w->activate($w->index('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 $w->{'PREVIOUS_ELEMENT'})
- {
- return;
- }
- my $first = $w->index('anchor');
- my $last = $w->{'PREVIOUS_ELEMENT'};
- if ($first > $last)
- {
- ($first,$last)=($last,$first);
- }
- $w->selectionClear($first,$last);
- while ($first <= $last)
- {
- if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$first) >= 0)
- {
- $w->selectionSet($first)
- }
- $first += 1
- }
-}
-# 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')
- }
-}
-
-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 $element = $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($element++,$_);
- }
-}
-
-sub getSelected
-{
- my ($w) = @_;
- my $i;
- my (@result) = ();
- foreach $i ($w->curselection)
- {
- push(@result,$w->get($i));
- }
- return (wantarray) ? @result : $result[0];
-}
-
-
-
-1;