1# Copyright (c) 1999 Greg London. All rights reserved. 2# This program is free software; you can redistribute it and/or 3# modify it under the same terms as Perl itself. 4 5# code for bindings taken from Listbox.pm 6 7# comments specifying method functionality taken from 8# "Perl/Tk Pocket Reference" by Stephen Lidie. 9 10####################################################################### 11# this module uses a text module as its base class to create a list box. 12# this will allow list box functionality to also have all the functionality 13# of the Text widget. 14# 15# note that most methods use an element number to indicate which 16# element in the list to work on. 17# the exception to this is the tag and mark methods which 18# are dual natured. These methods may accept either the 19# normal element number, or they will also take a element.char index, 20# which would be useful for applying tags to part of a line in the list. 21# 22####################################################################### 23 24package Tk::TextList; 25 26use strict; 27use vars qw($VERSION); 28$VERSION = '4.006'; # $Id: //depot/Tkutf8/TextList/TextList.pm#5 $ 29 30use base qw(Tk::Derived Tk::ReindexedROText ); 31 32use Tk qw (Ev); 33 34Construct Tk::Widget 'TextList'; 35 36####################################################################### 37# the following line causes Populate to get called 38# @ISA = qw(Tk::Derived ... ); 39####################################################################### 40sub Populate 41{ 42 my ($w,$args)=@_; 43 my $option=delete $args->{'-selectmode'}; 44 $w->SUPER::Populate($args); 45 $w->ConfigSpecs( -selectmode => ['PASSIVE','selectMode','SelectMode','browse'], 46 -takefocus => ['PASSIVE','takeFocus','TakeFocus',1], 47 -spacing3 => ['SELF', undef, undef, 3], 48 -insertwidth => ['SELF', undef, undef, 0], 49 ); 50 51} 52 53####################################################################### 54####################################################################### 55sub ClassInit 56{ 57 my ($class,$mw) = @_; 58 59 # Standard Motif bindings: 60 $mw->bind($class,'<1>',['BeginSelect',Ev('index',Ev('@'))]); 61 $mw->bind($class,'<B1-Motion>',['Motion',Ev('index',Ev('@'))]); 62 $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1'); 63 64 $mw->bind($class,'<Shift-1>',['BeginExtend',Ev('index',Ev('@'))]); 65 $mw->bind($class,'<Control-1>',['BeginToggle',Ev('index',Ev('@'))]); 66 67 $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x'),Ev('y')]); 68 $mw->bind($class,'<B1-Enter>','CancelRepeat'); 69 $mw->bind($class,'<Up>',['UpDown',-1]); 70 $mw->bind($class,'<Shift-Up>',['ExtendUpDown',-1]); 71 $mw->bind($class,'<Down>',['UpDown',1]); 72 $mw->bind($class,'<Shift-Down>',['ExtendUpDown',1]); 73 74 $mw->XscrollBind($class); 75 $mw->PriorNextBind($class); 76 77 $mw->bind($class,'<Control-Home>','Cntrl_Home'); 78 79 $mw->bind($class,'<Shift-Control-Home>',['DataExtend',0]); 80 $mw->bind($class,'<Control-End>','Cntrl_End'); 81 82 $mw->bind($class,'<Shift-Control-End>',['DataExtend','end']); 83 $class->clipboardOperations($mw,'Copy'); 84 $mw->bind($class,'<space>',['BeginSelect',Ev('index','active')]); 85 $mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]); 86 $mw->bind($class,'<Control-Shift-space>',['BeginExtend',Ev('index','active')]); 87 $mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]); 88 $mw->bind($class,'<Escape>','Cancel'); 89 $mw->bind($class,'<Control-slash>','SelectAll'); 90 $mw->bind($class,'<Control-backslash>','Cntrl_backslash'); 91 ; 92 # Additional Tk bindings that aren't part of the Motif look and feel: 93 $mw->bind($class,'<2>',['scan','mark',Ev('x'),Ev('y')]); 94 $mw->bind($class,'<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]); 95 96 $mw->bind($class,'<FocusIn>' , ['tagConfigure','_ACTIVE_TAG', -underline=>1]); 97 $mw->bind($class,'<FocusOut>', ['tagConfigure','_ACTIVE_TAG', -underline=>0]); 98 99 return $class; 100} 101 102####################################################################### 103# set the active element to index 104# "active" is a text "mark" which underlines the marked text. 105####################################################################### 106sub activate 107{ 108 my($w,$element)=@_; 109 $element= $w->index($element).'.0'; 110 $w->SUPER::tag('remove', '_ACTIVE_TAG', '1.0','end'); 111 $w->SUPER::tag('add', '_ACTIVE_TAG', 112 $element.' linestart', $element.' lineend'); 113 $w->SUPER::mark('set', 'active', $element); 114} 115 116 117####################################################################### 118# bbox returns a list (x,y,width,height) giving an approximate 119# bounding box of character given by index 120####################################################################### 121sub bbox 122{ 123 my($w,$element)=@_; 124 $element=$w->index($element).'.0' unless ($element=~/\./); 125 return $w->SUPER::bbox($element); 126} 127 128####################################################################### 129# returns a list of indices of all elements currently selected 130####################################################################### 131sub curselection 132{ 133 my ($w)=@_; 134 my @ranges = $w->SUPER::tag('ranges', 'sel'); 135 my @selection_list; 136 while (@ranges) 137 { 138 my ($first,$firstcol) = split(/\./,shift(@ranges)); 139 my ($last,$lastcol) = split(/\./,shift(@ranges)); 140 141 ######################################################################### 142 # if previous selection ended on the same line that this selection starts, 143 # then fiddle the numbers so that this line number isnt included twice. 144 ######################################################################### 145 if (defined($selection_list[-1]) and ($first == $selection_list[-1])) 146 { 147 $first++; # count this selection starting from the next line. 148 } 149 150 if ($lastcol==0) 151 { 152 $last-=1; 153 } 154 155 ######################################################################### 156 # if incrementing $first causes it to be greater than $last, 157 # then do nothing, 158 # else add (first .. last) to list 159 ######################################################################### 160 unless ($first>$last) 161 { 162 push(@selection_list, $first .. $last); 163 } 164 } 165 return @selection_list; 166} 167 168 169####################################################################### 170# deletes range of elements from element1 to element2 171# defaults to element1 172####################################################################### 173sub delete 174{ 175 my ($w, $element1, $element2)=@_; 176 $element1=$w->index($element1); 177 $element2=$element1 unless(defined($element2)); 178 $element2=$w->index($element2); 179 $w->SUPER::delete($element1.'.0' , $element2.'.0 lineend'); 180} 181 182####################################################################### 183# deletes range of characters from index1 to index2 184# defaults to index1+1c 185# index is line.char notation. 186####################################################################### 187sub deleteChar 188{ 189 my ($w, $index1, $index2)=@_; 190 $index1=$w->index($index1); 191 $index2=$index1.' +1c' unless(defined($index2)); 192 $index2=$w->index($index2); 193 $w->SUPER::delete($index1, $index2); 194} 195 196####################################################################### 197# returns as a list contents of elements from $element1 to $element2 198# defaults to element1. 199####################################################################### 200sub get 201{ 202 my ($w, $element1, $element2)=@_; 203 $element1=$w->index($element1); 204 $element2=$element1 unless(defined($element2)); 205 $element2=$w->index($element2); 206 my @getlist; 207 for(my $i=$element1; $i<=$element2; $i++) 208 { 209 push(@getlist, $w->SUPER::get($i.'.0 linestart', $i.'.0 lineend')); 210 } 211 212 return @getlist; 213} 214 215####################################################################### 216# return text between index1 and index2 which are line.char notation. 217# return value is a single string. index2 defaults to index1+1c 218# index is line.char notation. 219###################################################################### 220sub getChar 221{ 222 my $w=shift; 223 return $w->SUPER::get(@_); 224} 225 226####################################################################### 227# returns index in number notation 228# this method returns an element number, ie the 5th element. 229####################################################################### 230sub index 231{ 232 my ($w,$element)=@_; 233 return undef unless(defined($element)); 234 $element=0 if $element<0; 235 $element .= '.0' unless $element=~/\D/; 236 $element = $w->SUPER::index($element); 237 my($line,$col)=split(/\./,$element); 238 return $line; 239} 240 241####################################################################### 242# returns index in line.char notation 243# this method returns an index specific to a character within an element 244####################################################################### 245sub indexChar 246{ 247 my $w=shift; 248 return $w->SUPER::index(@_); 249} 250 251 252####################################################################### 253# inserts specified elements just before element at index 254####################################################################### 255sub insert 256{ 257 my $w=shift; 258 my $element=shift; 259 $element=$w->index($element); 260 my $item; 261 while (@_) 262 { 263 $item = shift(@_); 264 $item .= "\n"; 265 $w->SUPER::insert($element++.'.0', $item); 266 } 267} 268 269####################################################################### 270# inserts string just before character at index. 271# index is line.char notation. 272####################################################################### 273sub insertChar 274{ 275 my $w=shift; 276 $w->SUPER::insert(@_); 277} 278 279 280 281####################################################################### 282# returns index of element nearest to y-coordinate 283# 284# currently not defined 285####################################################################### 286#sub nearest 287#{ 288# return undef; 289#} 290 291####################################################################### 292# Sets the selection anchor to element at index 293####################################################################### 294sub selectionAnchor 295{ 296 my ($w, $element)=@_; 297 $element=$w->index($element); 298 $w->SUPER::mark('set', 'anchor', $element.'.0'); 299} 300 301####################################################################### 302# deselects elements between index1 and index2, inclusive 303####################################################################### 304sub selectionClear 305{ 306 my ($w, $element1, $element2)=@_; 307 $element1=$w->index($element1); 308 $element2=$element1 unless(defined($element2)); 309 $element2=$w->index($element2); 310 $w->SUPER::tag('remove', 'sel', $element1.'.0', $element2.'.0 lineend +1c'); 311} 312 313####################################################################### 314# returns 1 if element at index is selected, 0 otherwise. 315####################################################################### 316sub selectionIncludes 317{ 318 my ($w, $element)=@_; 319 $element=$w->index($element); 320 my @list = $w->curselection; 321 my $line; 322 foreach $line (@list) 323 { 324 if ($line == $element) {return 1;} 325 } 326 return 0; 327} 328 329####################################################################### 330# adds all elements between element1 and element2 inclusive to selection 331####################################################################### 332sub selectionSet 333{ 334 my ($w, $element1, $element2)=@_; 335 $element1=$w->index($element1); 336 $element2=$element1 unless(defined($element2)); 337 $element2=$w->index($element2); 338 $w->SUPER::tag('add', 'sel', $element1.'.0', $element2.'.0 lineend +1c'); 339} 340 341####################################################################### 342# for ->selection(option,args) calling convention 343####################################################################### 344sub selection 345{ 346# my ($w,$sub)=(shift,"selection".ucfirst(shift)); 347# no strict 'refs'; 348# # can't use $w->$sub, since it might call overridden method-- bleh 349# &($sub)($w,@_); 350} 351 352 353####################################################################### 354# adjusts the view in window so element at index is completely visible 355####################################################################### 356sub see 357{ 358 my ($w, $element)=@_; 359 $element=$w->index($element); 360 $w->SUPER::see($element.'.0'); 361} 362 363####################################################################### 364# returns number of elements in listbox 365####################################################################### 366sub size 367{ 368 my ($w)=@_; 369 my $element = $w->index('end'); 370 # theres a weird thing with the 'end' mark sometimes being on a line 371 # with text, and sometimes being on a line all by itself 372 my ($text) = $w->get($element); 373 if (length($text) == 0) 374 {$element -= 1;} 375 return $element; 376} 377 378 379 380####################################################################### 381# add a tag based on element numbers 382####################################################################### 383sub tagAdd 384{ 385 my ($w, $tagName, $element1, $element2)=@_; 386 $element1=$w->index($element1); 387 $element1.='.0'; 388 389 $element2=$element1.' lineend' unless(defined($element2)); 390 $element2=$w->index($element2); 391 $element2.='.0 lineend +1c'; 392 393 $w->SUPER::tag('add', $tagName, $element1, $element2); 394} 395 396####################################################################### 397# add a tag based on line.char indexes 398####################################################################### 399sub tagAddChar 400{ 401 my $w=shift; 402 $w->SUPER::tag('add',@_); 403} 404 405 406####################################################################### 407# remove a tag based on element numbers 408####################################################################### 409sub tagRemove 410{ 411 my ($w, $tagName, $element1, $element2)=@_; 412 $element1=$w->index($element1); 413 $element1.='.0'; 414 415 $element2=$element1.' lineend' unless(defined($element2)); 416 $element2=$w->index($element2); 417 $element2.='.0 lineend +1c'; 418 419 $w->SUPER::tag('remove', 'sel', $element1, $element2); 420} 421 422####################################################################### 423# remove a tag based on line.char indexes 424####################################################################### 425sub tagRemoveChar 426{ 427 my $w=shift; 428 $w->SUPER::tag('remove', @_); 429} 430 431 432 433 434####################################################################### 435# perform tagNextRange based on element numbers 436####################################################################### 437sub tagNextRange 438{ 439 my ($w, $tagName, $element1, $element2)=@_; 440 $element1=$w->index($element1); 441 $element1.='.0'; 442 443 $element2=$element1 unless(defined($element2)); 444 $element2=$w->index($element2); 445 $element2.='.0 lineend +1c'; 446 447 my $index = $w->SUPER::tag('nextrange', 'sel', $element1, $element2); 448 my ($line,$col)=split(/\./,$index); 449 return $line; 450} 451 452####################################################################### 453# perform tagNextRange based on line.char indexes 454####################################################################### 455sub tagNextRangeChar 456{ 457 my $w=shift; 458 $w->SUPER::tag('nextrange', @_); 459} 460 461####################################################################### 462# perform tagPrevRange based on element numbers 463####################################################################### 464sub tagPrevRange 465{ 466 my ($w, $tagName, $element1, $element2)=@_; 467 $element1=$w->index($element1); 468 $element1.='.0'; 469 470 $element2=$element1 unless(defined($element2)); 471 $element2=$w->index($element2); 472 $element2.='.0 lineend +1c'; 473 474 my $index = $w->SUPER::tag('prevrange', 'sel', $element1, $element2); 475 my ($line,$col)=split(/\./,$index); 476 return $line; 477} 478 479####################################################################### 480# perform tagPrevRange based on line.char indexes 481####################################################################### 482sub tagPrevRangeChar 483{ 484 my $w=shift; 485 $w->SUPER::tag('prevrange', @_); 486} 487 488 489 490####################################################################### 491# perform markSet based on element numbers 492####################################################################### 493sub markSet 494{ 495 my ($w,$mark,$element1)=@_; 496 $element1=$w->index($element1); 497 $element1.='.0'; 498 $w->SUPER::mark('set', $element1,$mark); 499} 500 501####################################################################### 502# perform markSet based on line.char indexes 503####################################################################### 504sub markSetChar 505{ 506 my $w=shift; 507 $w->SUPER::mark('set', @_); 508} 509 510####################################################################### 511# perform markNext based on element numbers 512####################################################################### 513sub markNext 514{ 515 my ($w,$element1)=@_; 516 $element1=$w->index($element1); 517 $element1.='.0'; 518 return $w->SUPER::mark('next', $element1); 519} 520 521####################################################################### 522# perform markNext based on line.char indexes 523####################################################################### 524sub markNextChar 525{ 526 my $w=shift; 527 $w->SUPER::mark('next', @_); 528} 529 530 531####################################################################### 532# perform markPrevious based on element numbers 533####################################################################### 534sub markPrevious 535{ 536 my ($w,$element1)=@_; 537 $element1=$w->index($element1); 538 $element1.='.0'; 539 return $w->SUPER::mark('previous', $element1); 540} 541 542####################################################################### 543# perform markPrevious based on line.char indexes 544####################################################################### 545sub markPreviousChar 546{ 547 my $w=shift; 548 $w->SUPER::mark('previous', @_); 549} 550 551 552 553 554sub ButtonRelease_1 555{ 556 my $w = shift; 557 my $Ev = $w->XEvent; 558 $w->CancelRepeat; 559 $w->activate($Ev->xy); 560} 561 562 563sub Cntrl_Home 564{ 565 my $w = shift; 566 my $Ev = $w->XEvent; 567 $w->activate(0); 568 $w->see(0); 569 $w->selectionClear(0,'end'); 570 $w->selectionSet(0) 571} 572 573 574sub Cntrl_End 575{ 576 my $w = shift; 577 my $Ev = $w->XEvent; 578 $w->activate('end'); 579 $w->see('end'); 580 $w->selectionClear(0,'end'); 581 $w->selectionSet('end') 582} 583 584 585sub Cntrl_backslash 586{ 587 my $w = shift; 588 my $Ev = $w->XEvent; 589 if ($w->cget('-selectmode') ne 'browse') 590 { 591 $w->selectionClear(0,'end'); 592 } 593} 594 595# BeginSelect -- 596# 597# This procedure is typically invoked on button-1 presses. It begins 598# the process of making a selection in the listbox. Its exact behavior 599# depends on the selection mode currently in effect for the listbox; 600# see the Motif documentation for details. 601# 602# Arguments: 603# w - The listbox widget. 604# el - The element for the selection operation (typically the 605# one under the pointer). Must be in numerical form. 606sub BeginSelect 607{ 608 my $w = shift; 609 my $el = shift; 610 if ($w->cget('-selectmode') eq 'multiple') 611 { 612 if ($w->selectionIncludes($el)) 613 { 614 $w->selectionClear($el) 615 } 616 else 617 { 618 $w->selectionSet($el) 619 } 620 } 621 else 622 { 623 $w->selectionClear(0,'end'); 624 $w->selectionSet($el); 625 $w->selectionAnchor($el); 626 my @list = (); 627 $w->{'SELECTION_LIST_REF'} = \@list; 628 $w->{'PREVIOUS_ELEMENT'} = $el 629 } 630 $w->focus if ($w->cget('-takefocus')); 631} 632# Motion -- 633# 634# This procedure is called to process mouse motion events while 635# button 1 is down. It may move or extend the selection, depending 636# on the listbox's selection mode. 637# 638# Arguments: 639# w - The listbox widget. 640# el - The element under the pointer (must be a number). 641sub Motion 642{ 643 my $w = shift; 644 my $el = shift; 645 if (defined($w->{'PREVIOUS_ELEMENT'}) && $el == $w->{'PREVIOUS_ELEMENT'}) 646 { 647 return; 648 } 649 650 # if no selections, select current 651 if($w->curselection==0) 652 { 653 $w->activate($el); 654 $w->selectionSet($el); 655 $w->selectionAnchor($el); 656 $w->{'PREVIOUS_ELEMENT'}=$el; 657 return; 658 } 659 660 my $anchor = $w->index('anchor'); 661 my $mode = $w->cget('-selectmode'); 662 if ($mode eq 'browse') 663 { 664 $w->selectionClear(0,'end'); 665 $w->selectionSet($el); 666 $w->{'PREVIOUS_ELEMENT'} = $el; 667 } 668 elsif ($mode eq 'extended') 669 { 670 my $i = $w->{'PREVIOUS_ELEMENT'}; 671 if ($w->selectionIncludes('anchor')) 672 { 673 $w->selectionClear($i,$el); 674 $w->selectionSet('anchor',$el) 675 } 676 else 677 { 678 $w->selectionClear($i,$el); 679 $w->selectionClear('anchor',$el) 680 } 681 while ($i < $el && $i < $anchor) 682 { 683 if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$i) >= 0) 684 { 685 $w->selectionSet($i) 686 } 687 $i += 1 688 } 689 while ($i > $el && $i > $anchor) 690 { 691 if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$i) >= 0) 692 { 693 $w->selectionSet($i) 694 } 695 $i += -1 696 } 697 $w->{'PREVIOUS_ELEMENT'} = $el 698 } 699} 700# BeginExtend -- 701# 702# This procedure is typically invoked on shift-button-1 presses. It 703# begins the process of extending a selection in the listbox. Its 704# exact behavior depends on the selection mode currently in effect 705# for the listbox; see the Motif documentation for details. 706# 707# Arguments: 708# w - The listbox widget. 709# el - The element for the selection operation (typically the 710# one under the pointer). Must be in numerical form. 711sub BeginExtend 712{ 713 my $w = shift; 714 my $el = shift; 715 716 # if no selections, select current 717 if($w->curselection==0) 718 { 719 $w->activate($el); 720 $w->selectionSet($el); 721 $w->selectionAnchor($el); 722 $w->{'PREVIOUS_ELEMENT'}=$el; 723 return; 724 } 725 726 if ($w->cget('-selectmode') eq 'extended' && $w->selectionIncludes('anchor')) 727 { 728 $w->Motion($el) 729 } 730} 731# BeginToggle -- 732# 733# This procedure is typically invoked on control-button-1 presses. It 734# begins the process of toggling a selection in the listbox. Its 735# exact behavior depends on the selection mode currently in effect 736# for the listbox; see the Motif documentation for details. 737# 738# Arguments: 739# w - The listbox widget. 740# el - The element for the selection operation (typically the 741# one under the pointer). Must be in numerical form. 742sub BeginToggle 743{ 744 my $w = shift; 745 my $el = shift; 746 if ($w->cget('-selectmode') eq 'extended') 747 { 748 my @list = $w->curselection(); 749 $w->{'SELECTION_LIST_REF'} = \@list; 750 $w->{'PREVIOUS_ELEMENT'} = $el; 751 $w->selectionAnchor($el); 752 if ($w->selectionIncludes($el)) 753 { 754 $w->selectionClear($el) 755 } 756 else 757 { 758 $w->selectionSet($el) 759 } 760 } 761} 762# AutoScan -- 763# This procedure is invoked when the mouse leaves an entry window 764# with button 1 down. It scrolls the window up, down, left, or 765# right, depending on where the mouse left the window, and reschedules 766# itself as an "after" command so that the window continues to scroll until 767# the mouse moves back into the window or the mouse button is released. 768# 769# Arguments: 770# w - The entry window. 771# x - The x-coordinate of the mouse when it left the window. 772# y - The y-coordinate of the mouse when it left the window. 773sub AutoScan 774{ 775 my $w = shift; 776 my $x = shift; 777 my $y = shift; 778 if ($y >= $w->height) 779 { 780 $w->yview('scroll',1,'units') 781 } 782 elsif ($y < 0) 783 { 784 $w->yview('scroll',-1,'units') 785 } 786 elsif ($x >= $w->width) 787 { 788 $w->xview('scroll',2,'units') 789 } 790 elsif ($x < 0) 791 { 792 $w->xview('scroll',-2,'units') 793 } 794 else 795 { 796 return; 797 } 798 $w->Motion($w->index("@" . $x . ',' . $y)); 799 $w->RepeatId($w->after(50,'AutoScan',$w,$x,$y)); 800} 801# UpDown -- 802# 803# Moves the location cursor (active element) up or down by one element, 804# and changes the selection if we're in browse or extended selection 805# mode. 806# 807# Arguments: 808# w - The listbox widget. 809# amount - +1 to move down one item, -1 to move back one item. 810sub UpDown 811{ 812 my $w = shift; 813 my $amount = shift; 814 $w->activate($w->index('active')+$amount); 815 $w->see('active'); 816 my $selectmode = $w->cget('-selectmode'); 817 if ($selectmode eq 'browse') 818 { 819 $w->selectionClear(0,'end'); 820 $w->selectionSet('active') 821 } 822 elsif ($selectmode eq 'extended') 823 { 824 $w->selectionClear(0,'end'); 825 $w->selectionSet('active'); 826 $w->selectionAnchor('active'); 827 $w->{'PREVIOUS_ELEMENT'} = $w->index('active'); 828 my @list = (); 829 $w->{'SELECTION_LIST_REF'}=\@list; 830 } 831} 832# ExtendUpDown -- 833# 834# Does nothing unless we're in extended selection mode; in this 835# case it moves the location cursor (active element) up or down by 836# one element, and extends the selection to that point. 837# 838# Arguments: 839# w - The listbox widget. 840# amount - +1 to move down one item, -1 to move back one item. 841sub ExtendUpDown 842{ 843 my $w = shift; 844 my $amount = shift; 845 if ($w->cget('-selectmode') ne 'extended') 846 { 847 return; 848 } 849 $w->activate($w->index('active')+$amount); 850 $w->see('active'); 851 $w->Motion($w->index('active')) 852} 853# DataExtend 854# 855# This procedure is called for key-presses such as Shift-KEndData. 856# If the selection mode isn't multiple or extend then it does nothing. 857# Otherwise it moves the active element to el and, if we're in 858# extended mode, extends the selection to that point. 859# 860# Arguments: 861# w - The listbox widget. 862# el - An integer element number. 863sub DataExtend 864{ 865 my $w = shift; 866 my $el = shift; 867 my $mode = $w->cget('-selectmode'); 868 if ($mode eq 'extended') 869 { 870 $w->activate($el); 871 $w->see($el); 872 if ($w->selectionIncludes('anchor')) 873 { 874 $w->Motion($el) 875 } 876 } 877 elsif ($mode eq 'multiple') 878 { 879 $w->activate($el); 880 $w->see($el) 881 } 882} 883# Cancel 884# 885# This procedure is invoked to cancel an extended selection in 886# progress. If there is an extended selection in progress, it 887# restores all of the items between the active one and the anchor 888# to their previous selection state. 889# 890# Arguments: 891# w - The listbox widget. 892sub Cancel 893{ 894 my $w = shift; 895 if ($w->cget('-selectmode') ne 'extended' || !defined $w->{'PREVIOUS_ELEMENT'}) 896 { 897 return; 898 } 899 my $first = $w->index('anchor'); 900 my $last = $w->{'PREVIOUS_ELEMENT'}; 901 if ($first > $last) 902 { 903 ($first,$last)=($last,$first); 904 } 905 $w->selectionClear($first,$last); 906 while ($first <= $last) 907 { 908 if (Tk::lsearch($w->{'SELECTION_LIST_REF'},$first) >= 0) 909 { 910 $w->selectionSet($first) 911 } 912 $first += 1 913 } 914} 915# SelectAll 916# 917# This procedure is invoked to handle the "select all" operation. 918# For single and browse mode, it just selects the active element. 919# Otherwise it selects everything in the widget. 920# 921# Arguments: 922# w - The listbox widget. 923sub SelectAll 924{ 925 my $w = shift; 926 my $mode = $w->cget('-selectmode'); 927 if ($mode eq 'single' || $mode eq 'browse') 928 { 929 $w->selectionClear(0,'end'); 930 $w->selectionSet('active') 931 } 932 else 933 { 934 $w->selectionSet(0,'end') 935 } 936} 937 938sub SetList 939{ 940 my $w = shift; 941 $w->delete(0,'end'); 942 $w->insert('end',@_); 943} 944 945sub deleteSelected 946{ 947 my $w = shift; 948 my $i; 949 foreach $i (reverse $w->curselection) 950 { 951 $w->delete($i); 952 } 953} 954 955sub clipboardPaste 956{ 957 my $w = shift; 958 my $element = $w->index('active') || $w->index($w->XEvent->xy); 959 my $str; 960 eval {local $SIG{__DIE__}; $str = $w->clipboardGet }; 961 return if $@; 962 foreach (split("\n",$str)) 963 { 964 $w->insert($element++,$_); 965 } 966} 967 968sub getSelected 969{ 970 my ($w) = @_; 971 my $i; 972 my (@result) = (); 973 foreach $i ($w->curselection) 974 { 975 push(@result,$w->get($i)); 976 } 977 return (wantarray) ? @result : $result[0]; 978} 979 980 981 9821; 983