projects / OpenSPARC-T2-DV / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial commit of OpenSPARC T2 design and verification files.
[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / TextList.pm
CommitLineData
86530b38
AT		 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 = '3.002'; # $Id: //depot/Tk8/TextList/TextList.pm#2 $
29
30use Tk::Reindex qw(Tk::ROText ReindexedROText);
31
32use base qw(Tk::Derived Tk::ReindexedROText );
33
34use Tk qw (Ev);
35
36use base qw(Tk::ReindexedROText);
37
38Construct Tk::Widget 'TextList';
39
40#######################################################################
41# the following line causes Populate to get called
42# @ISA = qw(Tk::Derived ... );
43#######################################################################
44sub Populate
45{
46 my ($w,$args)=@_;
47 my $option=delete $args->{'-selectmode'};
48 $w->SUPER::Populate($args);
49 $w->ConfigSpecs( -selectmode => ['PASSIVE','selectMode','SelectMode','browse'] );
50 $w->ConfigSpecs( -takefocus => ['PASSIVE','takeFocus','TakeFocus','browse'] );
51
52}
53
54#######################################################################
55#######################################################################
56sub ClassInit
57{
58 my ($class,$mw) = @_;
59
60 # Standard Motif bindings:
61 $mw->bind($class,'<1>',['BeginSelect',Ev('index',Ev('@'))]);
62 $mw->bind($class,'<B1-Motion>',['Motion',Ev('index',Ev('@'))]);
63 $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
64
65 $mw->bind($class,'<Shift-1>',['BeginExtend',Ev('index',Ev('@'))]);
66 $mw->bind($class,'<Control-1>',['BeginToggle',Ev('index',Ev('@'))]);
67
68 $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x'),Ev('y')]);
69 $mw->bind($class,'<B1-Enter>','CancelRepeat');
70 $mw->bind($class,'<Up>',['UpDown',-1]);
71 $mw->bind($class,'<Shift-Up>',['ExtendUpDown',-1]);
72 $mw->bind($class,'<Down>',['UpDown',1]);
73 $mw->bind($class,'<Shift-Down>',['ExtendUpDown',1]);
74
75 $mw->XscrollBind($class);
76 $mw->PriorNextBind($class);
77
78 $mw->bind($class,'<Control-Home>','Cntrl_Home');
79
80 $mw->bind($class,'<Shift-Control-Home>',['DataExtend',0]);
81 $mw->bind($class,'<Control-End>','Cntrl_End');
82
83 $mw->bind($class,'<Shift-Control-End>',['DataExtend','end']);
84 $class->clipboardOperations($mw,'Copy');
85 $mw->bind($class,'<space>',['BeginSelect',Ev('index','active')]);
86 $mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]);
87 $mw->bind($class,'<Control-Shift-space>',['BeginExtend',Ev('index','active')]);
88 $mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]);
89 $mw->bind($class,'<Escape>','Cancel');
90 $mw->bind($class,'<Control-slash>','SelectAll');
91 $mw->bind($class,'<Control-backslash>','Cntrl_backslash');
92 ;
93 # Additional Tk bindings that aren't part of the Motif look and feel:
94 $mw->bind($class,'<2>',['scan','mark',Ev('x'),Ev('y')]);
95 $mw->bind($class,'<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]);
96
97 $mw->bind($class,'<FocusIn>' , ['tagConfigure','_ACTIVE_TAG', -underline=>1]);
98 $mw->bind($class,'<FocusOut>', ['tagConfigure','_ACTIVE_TAG', -underline=>0]);
99
100 return $class;
101}
102
103#######################################################################
104# set the active element to index
105# "active" is a text "mark" which underlines the marked text.
106#######################################################################
107sub activate
108{
109 my($w,$element)=@_;
110 $element=$w->index($element).'.0';
111 $w->SUPER::tagRemove('_ACTIVE_TAG', '1.0','end');
112 $w->SUPER::tagAdd('_ACTIVE_TAG',
113 $element.' linestart', $element.' lineend');
114 $w->SUPER::markSet('active', $element);
115}
116
117
118#######################################################################
119# bbox returns a list (x,y,width,height) giving an approximate
120# bounding box of character given by index
121#######################################################################
122sub bbox
123{
124 my($w,$element)=@_;
125 $element=$w->index($element).'.0' unless ($element=~/./);
126 return $w->SUPER::bbox($element);
127}
128
129#######################################################################
130# returns a list of indices of all elements currently selected
131#######################################################################
132sub curselection
133{
134 my ($w)=@_;
135 my @ranges = $w->SUPER::tagRanges('sel');
136 my @selection_list;
137 while (@ranges)
138 {
139 my ($first,$firstcol) = split(/\./,shift(@ranges));
140 my ($last,$lastcol) = split(/\./,shift(@ranges));
141
142 #########################################################################
143 # if previous selection ended on the same line that this selection starts,
144 # then fiddle the numbers so that this line number isnt included twice.
145 #########################################################################
146 if (defined($selection_list[-1]) and ($first == $selection_list[-1]))
147 {
148 $first++; # count this selection starting from the next line.
149 }
150
151 if ($lastcol==0)
152 {
153 $last-=1;
154 }
155
156 #########################################################################
157 # if incrementing $first causes it to be greater than $last,
158 # then do nothing,
159 # else add (first .. last) to list
160 #########################################################################
161 unless ($first>$last)
162 {
163 push(@selection_list, $first .. $last);
164 }
165 }
166 return @selection_list;
167}
168
169
170#######################################################################
171# deletes range of elements from element1 to element2
172# defaults to element1
173#######################################################################
174sub delete
175{
176 my ($w, $element1, $element2)=@_;
177 $element1=$w->index($element1);
178 $element2=$element1 unless(defined($element2));
179 $element2=$w->index($element2);
180 $w->SUPER::delete($element1.'.0' , $element2.'.0 lineend');
181}
182
183#######################################################################
184# deletes range of characters from index1 to index2
185# defaults to index1+1c
186# index is line.char notation.
187#######################################################################
188sub deleteChar
189{
190 my ($w, $index1, $index2)=@_;
191 $index1=$w->index($index1);
192 $index2=$index1.' +1c' unless(defined($index2));
193 $index2=$w->index($index2);
194 $w->SUPER::delete($index1, $index2);
195}
196
197#######################################################################
198# returns as a list contents of elements from $element1 to $element2
199# defaults to element1.
200#######################################################################
201sub get
202{
203 my ($w, $element1, $element2)=@_;
204 $element1=$w->index($element1);
205 $element2=$element1 unless(defined($element2));
206 $element2=$w->index($element2);
207 my @getlist;
208 for(my $i=$element1; $i<=$element2; $i++)
209 {
210 push(@getlist, $w->SUPER::get($i.'.0 linestart', $i.'.0 lineend'));
211 }
212
213 return @getlist;
214}
215
216#######################################################################
217# return text between index1 and index2 which are line.char notation.
218# return value is a single string. index2 defaults to index1+1c
219# index is line.char notation.
220######################################################################
221sub getChar
222{
223 my $w=shift;
224 return $w->SUPER::get(@_);
225}
226
227#######################################################################
228# returns index in number notation
229# this method returns an element number, ie the 5th element.
230#######################################################################
231sub index
232{
233 my ($w,$element)=@_;
234 return undef unless(defined($element));
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::markSet('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::tagRemove('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::tagAdd('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::tagAdd($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::tagAdd(@_);
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::tagRemove('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::tagRemove(@_);
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::tagNextrange('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::tagNextrange(@_);
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::tagPrevrange('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::tagPrevrange(@_);
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::markSet($element1,$mark);
499}
500
501#######################################################################
502# perform markSet based on line.char indexes
503#######################################################################
504sub markSetChar
505{
506 my $w=shift;
507 $w->SUPER::markSet(@_);
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::markNext($element1);
519}
520
521#######################################################################
522# perform markNext based on line.char indexes
523#######################################################################
524sub markNextChar
525{
526 my $w=shift;
527 $w->SUPER::markNext(@_);
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::markPrevious($element1);
540}
541
542#######################################################################
543# perform markPrevious based on line.char indexes
544#######################################################################
545sub markPreviousChar
546{
547 my $w=shift;
548 $w->SUPER::markPrevious(@_);
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;
Full OpenSPARC design & verification tarball including full HDL.