Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # Converted from listbox.tcl -- |
2 | # | |
3 | # This file defines the default bindings for Tk listbox widgets. | |
4 | # | |
5 | # @(#) listbox.tcl 1.7 94/12/17 16:05:18 | |
6 | # | |
7 | # Copyright (c) 1994 The Regents of the University of California. | |
8 | # Copyright (c) 1994 Sun Microsystems, Inc. | |
9 | # | |
10 | # See the file "license.terms" for information on usage and redistribution | |
11 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
12 | ||
13 | package Tk::Listbox; | |
14 | ||
15 | use vars qw($VERSION); | |
16 | $VERSION = '3.031'; # $Id: //depot/Tk8/Listbox/Listbox.pm#31 $ | |
17 | ||
18 | use Tk qw(Ev $XS_VERSION); | |
19 | use Tk::Clipboard (); | |
20 | use AutoLoader; | |
21 | ||
22 | use base qw(Tk::Clipboard Tk::Widget); | |
23 | ||
24 | Construct Tk::Widget 'Listbox'; | |
25 | ||
26 | bootstrap Tk::Listbox; | |
27 | ||
28 | sub Tk_cmd { \&Tk::listbox } | |
29 | ||
30 | Tk::Methods('activate','bbox','curselection','delete','get','index', | |
31 | 'insert','nearest','scan','see','selection','size', | |
32 | 'xview','yview'); | |
33 | ||
34 | use Tk::Submethods ( 'selection' => [qw(anchor clear includes set)], | |
35 | 'scan' => [qw(mark dragto)], | |
36 | 'xview' => [qw(moveto scroll)], | |
37 | 'yview' => [qw(moveto scroll)], | |
38 | ); | |
39 | ||
40 | *Getselected = \&getSelected; | |
41 | ||
42 | sub clipEvents | |
43 | { | |
44 | return qw[Copy]; | |
45 | } | |
46 | ||
47 | sub BalloonInfo | |
48 | { | |
49 | my ($listbox,$balloon,$X,$Y,@opt) = @_; | |
50 | my $e = $listbox->XEvent; | |
51 | my $index = $listbox->index('@' . $e->x . ',' . $e->y); | |
52 | foreach my $opt (@opt) | |
53 | { | |
54 | my $info = $balloon->GetOption($opt,$listbox); | |
55 | if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY')) | |
56 | { | |
57 | $balloon->Subclient($index); | |
58 | if (defined $info->[$index]) | |
59 | { | |
60 | return $info->[$index]; | |
61 | } | |
62 | return ''; | |
63 | } | |
64 | return $info; | |
65 | } | |
66 | } | |
67 | ||
68 | sub ClassInit | |
69 | { | |
70 | my ($class,$mw) = @_; | |
71 | $class->SUPER::ClassInit($mw); | |
72 | # Standard Motif bindings: | |
73 | $mw->bind($class,'<1>',['BeginSelect',Ev('index',Ev('@'))]); | |
74 | $mw->bind($class,'<B1-Motion>',['Motion',Ev('index',Ev('@'))]); | |
75 | $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1'); | |
76 | ; | |
77 | $mw->bind($class,'<Shift-1>',['BeginExtend',Ev('index',Ev('@'))]); | |
78 | $mw->bind($class,'<Control-1>',['BeginToggle',Ev('index',Ev('@'))]); | |
79 | ||
80 | $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x'),Ev('y')]); | |
81 | $mw->bind($class,'<B1-Enter>','CancelRepeat'); | |
82 | $mw->bind($class,'<Up>',['UpDown',-1]); | |
83 | $mw->bind($class,'<Shift-Up>',['ExtendUpDown',-1]); | |
84 | $mw->bind($class,'<Down>',['UpDown',1]); | |
85 | $mw->bind($class,'<Shift-Down>',['ExtendUpDown',1]); | |
86 | ||
87 | $mw->XscrollBind($class); | |
88 | $mw->PriorNextBind($class); | |
89 | ||
90 | $mw->bind($class,'<Control-Home>','Cntrl_Home'); | |
91 | ; | |
92 | $mw->bind($class,'<Shift-Control-Home>',['DataExtend',0]); | |
93 | $mw->bind($class,'<Control-End>','Cntrl_End'); | |
94 | ; | |
95 | $mw->bind($class,'<Shift-Control-End>',['DataExtend','end']); | |
96 | # $class->clipboardOperations($mw,'Copy'); | |
97 | $mw->bind($class,'<space>',['BeginSelect',Ev('index','active')]); | |
98 | $mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]); | |
99 | $mw->bind($class,'<Control-Shift-space>',['BeginExtend',Ev('index','active')]); | |
100 | $mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]); | |
101 | $mw->bind($class,'<Escape>','Cancel'); | |
102 | $mw->bind($class,'<Control-slash>','SelectAll'); | |
103 | $mw->bind($class,'<Control-backslash>','Cntrl_backslash'); | |
104 | ; | |
105 | # Additional Tk bindings that aren't part of the Motif look and feel: | |
106 | $mw->bind($class,'<2>',['scan','mark',Ev('x'),Ev('y')]); | |
107 | $mw->bind($class,'<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]); | |
108 | return $class; | |
109 | } | |
110 | ||
111 | 1; | |
112 | __END__ | |
113 | ||
114 | # | |
115 | # Bind -- | |
116 | # This procedure is invoked the first time the mouse enters a listbox | |
117 | # widget or a listbox widget receives the input focus. It creates | |
118 | # all of the class bindings for listboxes. | |
119 | # | |
120 | # Arguments: | |
121 | # event - Indicates which event caused the procedure to be invoked | |
122 | # (Enter or FocusIn). It is used so that we can carry out | |
123 | # the functions of that event in addition to setting up | |
124 | # bindings. | |
125 | ||
126 | sub xyIndex | |
127 | { | |
128 | my $w = shift; | |
129 | my $Ev = $w->XEvent; | |
130 | return $w->index($Ev->xy); | |
131 | } | |
132 | ||
133 | sub ButtonRelease_1 | |
134 | { | |
135 | my $w = shift; | |
136 | my $Ev = $w->XEvent; | |
137 | $w->CancelRepeat; | |
138 | $w->activate($Ev->xy); | |
139 | } | |
140 | ||
141 | ||
142 | sub Cntrl_Home | |
143 | { | |
144 | my $w = shift; | |
145 | my $Ev = $w->XEvent; | |
146 | $w->activate(0); | |
147 | $w->see(0); | |
148 | $w->selectionClear(0,'end'); | |
149 | $w->selectionSet(0) | |
150 | } | |
151 | ||
152 | ||
153 | sub Cntrl_End | |
154 | { | |
155 | my $w = shift; | |
156 | my $Ev = $w->XEvent; | |
157 | $w->activate('end'); | |
158 | $w->see('end'); | |
159 | $w->selectionClear(0,'end'); | |
160 | $w->selectionSet('end') | |
161 | } | |
162 | ||
163 | ||
164 | sub Cntrl_backslash | |
165 | { | |
166 | my $w = shift; | |
167 | my $Ev = $w->XEvent; | |
168 | if ($w->cget('-selectmode') ne 'browse') | |
169 | { | |
170 | $w->selectionClear(0,'end'); | |
171 | } | |
172 | } | |
173 | ||
174 | # BeginSelect -- | |
175 | # | |
176 | # This procedure is typically invoked on button-1 presses. It begins | |
177 | # the process of making a selection in the listbox. Its exact behavior | |
178 | # depends on the selection mode currently in effect for the listbox; | |
179 | # see the Motif documentation for details. | |
180 | # | |
181 | # Arguments: | |
182 | # w - The listbox widget. | |
183 | # el - The element for the selection operation (typically the | |
184 | # one under the pointer). Must be in numerical form. | |
185 | sub BeginSelect | |
186 | { | |
187 | my $w = shift; | |
188 | my $el = shift; | |
189 | if ($w->cget('-selectmode') eq 'multiple') | |
190 | { | |
191 | if ($w->selectionIncludes($el)) | |
192 | { | |
193 | $w->selectionClear($el) | |
194 | } | |
195 | else | |
196 | { | |
197 | $w->selectionSet($el) | |
198 | } | |
199 | } | |
200 | else | |
201 | { | |
202 | $w->selectionClear(0,'end'); | |
203 | $w->selectionSet($el); | |
204 | $w->selectionAnchor($el); | |
205 | @Selection = (); | |
206 | $Prev = $el | |
207 | } | |
208 | $w->focus if ($w->cget('-takefocus')); | |
209 | } | |
210 | # Motion -- | |
211 | # | |
212 | # This procedure is called to process mouse motion events while | |
213 | # button 1 is down. It may move or extend the selection, depending | |
214 | # on the listbox's selection mode. | |
215 | # | |
216 | # Arguments: | |
217 | # w - The listbox widget. | |
218 | # el - The element under the pointer (must be a number). | |
219 | sub Motion | |
220 | { | |
221 | my $w = shift; | |
222 | my $el = shift; | |
223 | if (defined($Prev) && $el == $Prev) | |
224 | { | |
225 | return; | |
226 | } | |
227 | $anchor = $w->index('anchor'); | |
228 | my $mode = $w->cget('-selectmode'); | |
229 | if ($mode eq 'browse') | |
230 | { | |
231 | $w->selectionClear(0,'end'); | |
232 | $w->selectionSet($el); | |
233 | $Prev = $el; | |
234 | } | |
235 | elsif ($mode eq 'extended') | |
236 | { | |
237 | $i = $Prev; | |
238 | if ($w->selectionIncludes('anchor')) | |
239 | { | |
240 | $w->selectionClear($i,$el); | |
241 | $w->selectionSet('anchor',$el) | |
242 | } | |
243 | else | |
244 | { | |
245 | $w->selectionClear($i,$el); | |
246 | $w->selectionClear('anchor',$el) | |
247 | } | |
248 | while ($i < $el && $i < $anchor) | |
249 | { | |
250 | if (Tk::lsearch(\@Selection,$i) >= 0) | |
251 | { | |
252 | $w->selectionSet($i) | |
253 | } | |
254 | $i += 1 | |
255 | } | |
256 | while ($i > $el && $i > $anchor) | |
257 | { | |
258 | if (Tk::lsearch(\@Selection,$i) >= 0) | |
259 | { | |
260 | $w->selectionSet($i) | |
261 | } | |
262 | $i += -1 | |
263 | } | |
264 | $Prev = $el | |
265 | } | |
266 | } | |
267 | # BeginExtend -- | |
268 | # | |
269 | # This procedure is typically invoked on shift-button-1 presses. It | |
270 | # begins the process of extending a selection in the listbox. Its | |
271 | # exact behavior depends on the selection mode currently in effect | |
272 | # for the listbox; see the Motif documentation for details. | |
273 | # | |
274 | # Arguments: | |
275 | # w - The listbox widget. | |
276 | # el - The element for the selection operation (typically the | |
277 | # one under the pointer). Must be in numerical form. | |
278 | sub BeginExtend | |
279 | { | |
280 | my $w = shift; | |
281 | my $el = shift; | |
282 | if ($w->cget('-selectmode') eq 'extended' && $w->selectionIncludes('anchor')) | |
283 | { | |
284 | $w->Motion($el) | |
285 | } | |
286 | } | |
287 | # BeginToggle -- | |
288 | # | |
289 | # This procedure is typically invoked on control-button-1 presses. It | |
290 | # begins the process of toggling a selection in the listbox. Its | |
291 | # exact behavior depends on the selection mode currently in effect | |
292 | # for the listbox; see the Motif documentation for details. | |
293 | # | |
294 | # Arguments: | |
295 | # w - The listbox widget. | |
296 | # el - The element for the selection operation (typically the | |
297 | # one under the pointer). Must be in numerical form. | |
298 | sub BeginToggle | |
299 | { | |
300 | my $w = shift; | |
301 | my $el = shift; | |
302 | if ($w->cget('-selectmode') eq 'extended') | |
303 | { | |
304 | @Selection = $w->curselection(); | |
305 | $Prev = $el; | |
306 | $w->selectionAnchor($el); | |
307 | if ($w->selectionIncludes($el)) | |
308 | { | |
309 | $w->selectionClear($el) | |
310 | } | |
311 | else | |
312 | { | |
313 | $w->selectionSet($el) | |
314 | } | |
315 | } | |
316 | } | |
317 | # AutoScan -- | |
318 | # This procedure is invoked when the mouse leaves an entry window | |
319 | # with button 1 down. It scrolls the window up, down, left, or | |
320 | # right, depending on where the mouse left the window, and reschedules | |
321 | # itself as an "after" command so that the window continues to scroll until | |
322 | # the mouse moves back into the window or the mouse button is released. | |
323 | # | |
324 | # Arguments: | |
325 | # w - The entry window. | |
326 | # x - The x-coordinate of the mouse when it left the window. | |
327 | # y - The y-coordinate of the mouse when it left the window. | |
328 | sub AutoScan | |
329 | { | |
330 | my $w = shift; | |
331 | my $x = shift; | |
332 | my $y = shift; | |
333 | if ($y >= $w->height) | |
334 | { | |
335 | $w->yview('scroll',1,'units') | |
336 | } | |
337 | elsif ($y < 0) | |
338 | { | |
339 | $w->yview('scroll',-1,'units') | |
340 | } | |
341 | elsif ($x >= $w->width) | |
342 | { | |
343 | $w->xview('scroll',2,'units') | |
344 | } | |
345 | elsif ($x < 0) | |
346 | { | |
347 | $w->xview('scroll',-2,'units') | |
348 | } | |
349 | else | |
350 | { | |
351 | return; | |
352 | } | |
353 | $w->Motion($w->index("@" . $x . ',' . $y)); | |
354 | $w->RepeatId($w->after(50,'AutoScan',$w,$x,$y)); | |
355 | } | |
356 | # UpDown -- | |
357 | # | |
358 | # Moves the location cursor (active element) up or down by one element, | |
359 | # and changes the selection if we're in browse or extended selection | |
360 | # mode. | |
361 | # | |
362 | # Arguments: | |
363 | # w - The listbox widget. | |
364 | # amount - +1 to move down one item, -1 to move back one item. | |
365 | sub UpDown | |
366 | { | |
367 | my $w = shift; | |
368 | my $amount = shift; | |
369 | $w->activate($w->index('active')+$amount); | |
370 | $w->see('active'); | |
371 | $LNet__0 = $w->cget('-selectmode'); | |
372 | if ($LNet__0 eq 'browse') | |
373 | { | |
374 | $w->selectionClear(0,'end'); | |
375 | $w->selectionSet('active') | |
376 | } | |
377 | elsif ($LNet__0 eq 'extended') | |
378 | { | |
379 | $w->selectionClear(0,'end'); | |
380 | $w->selectionSet('active'); | |
381 | $w->selectionAnchor('active'); | |
382 | $Prev = $w->index('active'); | |
383 | @Selection = (); | |
384 | } | |
385 | } | |
386 | # ExtendUpDown -- | |
387 | # | |
388 | # Does nothing unless we're in extended selection mode; in this | |
389 | # case it moves the location cursor (active element) up or down by | |
390 | # one element, and extends the selection to that point. | |
391 | # | |
392 | # Arguments: | |
393 | # w - The listbox widget. | |
394 | # amount - +1 to move down one item, -1 to move back one item. | |
395 | sub ExtendUpDown | |
396 | { | |
397 | my $w = shift; | |
398 | my $amount = shift; | |
399 | if ($w->cget('-selectmode') ne 'extended') | |
400 | { | |
401 | return; | |
402 | } | |
403 | $w->activate($w->index('active')+$amount); | |
404 | $w->see('active'); | |
405 | $w->Motion($w->index('active')) | |
406 | } | |
407 | # DataExtend | |
408 | # | |
409 | # This procedure is called for key-presses such as Shift-KEndData. | |
410 | # If the selection mode isn't multiple or extend then it does nothing. | |
411 | # Otherwise it moves the active element to el and, if we're in | |
412 | # extended mode, extends the selection to that point. | |
413 | # | |
414 | # Arguments: | |
415 | # w - The listbox widget. | |
416 | # el - An integer element number. | |
417 | sub DataExtend | |
418 | { | |
419 | my $w = shift; | |
420 | my $el = shift; | |
421 | $mode = $w->cget('-selectmode'); | |
422 | if ($mode eq 'extended') | |
423 | { | |
424 | $w->activate($el); | |
425 | $w->see($el); | |
426 | if ($w->selectionIncludes('anchor')) | |
427 | { | |
428 | $w->Motion($el) | |
429 | } | |
430 | } | |
431 | elsif ($mode eq 'multiple') | |
432 | { | |
433 | $w->activate($el); | |
434 | $w->see($el) | |
435 | } | |
436 | } | |
437 | # Cancel | |
438 | # | |
439 | # This procedure is invoked to cancel an extended selection in | |
440 | # progress. If there is an extended selection in progress, it | |
441 | # restores all of the items between the active one and the anchor | |
442 | # to their previous selection state. | |
443 | # | |
444 | # Arguments: | |
445 | # w - The listbox widget. | |
446 | sub Cancel | |
447 | { | |
448 | my $w = shift; | |
449 | if ($w->cget('-selectmode') ne 'extended' || !defined $Prev) | |
450 | { | |
451 | return; | |
452 | } | |
453 | $first = $w->index('anchor'); | |
454 | $last = $Prev; | |
455 | if ($first > $last) | |
456 | { | |
457 | $tmp = $first; | |
458 | $first = $last; | |
459 | $last = $tmp | |
460 | } | |
461 | $w->selectionClear($first,$last); | |
462 | while ($first <= $last) | |
463 | { | |
464 | if (Tk::lsearch(\@Selection,$first) >= 0) | |
465 | { | |
466 | $w->selectionSet($first) | |
467 | } | |
468 | $first += 1 | |
469 | } | |
470 | } | |
471 | # SelectAll | |
472 | # | |
473 | # This procedure is invoked to handle the "select all" operation. | |
474 | # For single and browse mode, it just selects the active element. | |
475 | # Otherwise it selects everything in the widget. | |
476 | # | |
477 | # Arguments: | |
478 | # w - The listbox widget. | |
479 | sub SelectAll | |
480 | { | |
481 | my $w = shift; | |
482 | my $mode = $w->cget('-selectmode'); | |
483 | if ($mode eq 'single' || $mode eq 'browse') | |
484 | { | |
485 | $w->selectionClear(0,'end'); | |
486 | $w->selectionSet('active') | |
487 | } | |
488 | else | |
489 | { | |
490 | $w->selectionSet(0,'end') | |
491 | } | |
492 | } | |
493 | ||
494 | sub SetList | |
495 | { | |
496 | my $w = shift; | |
497 | $w->delete(0,'end'); | |
498 | $w->insert('end',@_); | |
499 | } | |
500 | ||
501 | sub deleteSelected | |
502 | { | |
503 | my $w = shift; | |
504 | my $i; | |
505 | foreach $i (reverse $w->curselection) | |
506 | { | |
507 | $w->delete($i); | |
508 | } | |
509 | } | |
510 | ||
511 | sub clipboardPaste | |
512 | { | |
513 | my $w = shift; | |
514 | my $index = $w->index('active') || $w->index($w->XEvent->xy); | |
515 | my $str; | |
516 | eval {local $SIG{__DIE__}; $str = $w->clipboardGet }; | |
517 | return if $@; | |
518 | foreach (split("\n",$str)) | |
519 | { | |
520 | $w->insert($index++,$_); | |
521 | } | |
522 | } | |
523 | ||
524 | sub getSelected | |
525 | { | |
526 | my ($w) = @_; | |
527 | my $i; | |
528 | my (@result) = (); | |
529 | foreach $i ($w->curselection) | |
530 | { | |
531 | push(@result,$w->get($i)); | |
532 | } | |
533 | return (wantarray) ? @result : $result[0]; | |
534 | } | |
535 | ||
536 | ||
537 | ||
538 | 1; | |
539 | __END__ |