Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::HList; |
2 | ||
3 | use vars qw($VERSION); | |
4 | $VERSION = '3.035'; # $Id: //depot/Tk8/HList/HList.pm#35 $ | |
5 | ||
6 | use Tk qw(Ev $XS_VERSION); | |
7 | ||
8 | use base qw(Tk::Widget); | |
9 | ||
10 | Construct Tk::Widget 'HList'; | |
11 | sub Tk::Widget::ScrlHList { shift->Scrolled('HList'=>@_) } | |
12 | ||
13 | bootstrap Tk::HList; | |
14 | ||
15 | sub Tk_cmd { \&Tk::hlist } | |
16 | ||
17 | sub CreateArgs | |
18 | { | |
19 | my ($package,$parent,$args) = @_; | |
20 | my @result = $package->SUPER::CreateArgs($parent,$args); | |
21 | my $columns = delete $args->{-columns}; | |
22 | push(@result, '-columns' => $columns) if (defined $columns); | |
23 | return @result; | |
24 | } | |
25 | ||
26 | Tk::Methods qw(add addchild anchor column | |
27 | delete dragsite dropsite entrycget | |
28 | entryconfigure geometryinfo indicator header hide item info | |
29 | nearest see select selection show xview yview); | |
30 | ||
31 | use Tk::Submethods ( 'delete' => [qw(all entry offsprings siblings)], | |
32 | 'header' => [qw(configure cget create delete exists size)], | |
33 | 'indicator' => [qw(configure cget create delete exists size)], | |
34 | 'info' => [qw(anchor bbox children data dragsite | |
35 | dropsite exists hidden item next parent prev | |
36 | selection)], | |
37 | 'item' => [qw(configure cget create delete exists)], | |
38 | 'selection' => [qw(clear get includes set)], | |
39 | 'anchor' => [qw(clear set)], | |
40 | 'column' => [qw(width)], | |
41 | 'hide' => [qw(entry)], | |
42 | ); | |
43 | ||
44 | ||
45 | sub ClassInit | |
46 | { | |
47 | my ($class,$mw) = @_; | |
48 | ||
49 | $mw->bind($class,'<ButtonPress-1>',[ 'Button1' ] ); | |
50 | $mw->bind($class,'<Shift-ButtonPress-1>',[ 'ShiftButton1' ] ); | |
51 | $mw->bind($class,'<Control-ButtonRelease-1>','Control_ButtonRelease_1'); | |
52 | $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1'); | |
53 | $mw->bind($class,'<Double-ButtonRelease-1>','NoOp'); | |
54 | $mw->bind($class,'<B1-Motion>',[ 'Button1Motion' ] ); | |
55 | $mw->bind($class,'<B1-Leave>',[ 'AutoScan' ] ); | |
56 | ||
57 | $mw->bind($class,'<Double-ButtonPress-1>',['Double1']); | |
58 | ||
59 | $mw->bind($class,'<Control-B1-Motion>','Control_B1_Motion'); | |
60 | $mw->bind($class,'<Control-ButtonPress-1>',['CtrlButton1']); | |
61 | $mw->bind($class,'<Control-Double-ButtonPress-1>',['CtrlButton1']); | |
62 | ||
63 | $mw->bind($class,'<B1-Enter>','B1_Enter'); | |
64 | ||
65 | $mw->bind($class,'<Up>',['UpDown', 'prev']); | |
66 | $mw->bind($class,'<Down>',['UpDown', 'next']); | |
67 | ||
68 | $mw->bind($class,'<Shift-Up>',['ShiftUpDown', 'prev']); | |
69 | $mw->bind($class,'<Shift-Down>',['ShiftUpDown', 'next']); | |
70 | ||
71 | $mw->bind($class,'<Left>', ['LeftRight', 'left']); | |
72 | $mw->bind($class,'<Right>',['LeftRight', 'right']); | |
73 | ||
74 | $mw->PriorNextBind($class); | |
75 | ||
76 | $mw->bind($class,'<Return>', ['KeyboardActivate']); | |
77 | $mw->bind($class,'<space>', ['KeyboardBrowse']); | |
78 | $mw->bind($class,'<Home>', ['KeyboardHome']); | |
79 | $mw->bind($class,'<End>', ['KeyboardEnd']); | |
80 | ||
81 | return $class; | |
82 | } | |
83 | ||
84 | sub Control_ButtonRelease_1 | |
85 | { | |
86 | } | |
87 | ||
88 | sub ButtonRelease_1 | |
89 | { | |
90 | my $w = shift; | |
91 | my $Ev = $w->XEvent; | |
92 | $w->CancelRepeat | |
93 | if($w->cget('-selectmode') ne 'dragdrop'); | |
94 | $w->ButtonRelease1($Ev); | |
95 | } | |
96 | ||
97 | sub Control_B1_Motion | |
98 | { | |
99 | } | |
100 | ||
101 | sub B1_Enter | |
102 | { | |
103 | my $w = shift; | |
104 | my $Ev = $w->XEvent; | |
105 | $w->CancelRepeat | |
106 | if($w->cget('-selectmode') ne 'dragdrop'); | |
107 | } | |
108 | ||
109 | sub Button1 | |
110 | { | |
111 | my $w = shift; | |
112 | my $Ev = $w->XEvent; | |
113 | ||
114 | delete $w->{'shiftanchor'}; | |
115 | delete $w->{tixindicator}; | |
116 | ||
117 | $w->focus() if($w->cget('-takefocus')); | |
118 | ||
119 | my $mode = $w->cget('-selectmode'); | |
120 | ||
121 | if ($mode eq 'dragdrop') | |
122 | { | |
123 | # $w->Send_WaitDrag($Ev->y); | |
124 | return; | |
125 | } | |
126 | ||
127 | my $ent = $w->GetNearest($Ev->y, 1); | |
128 | ||
129 | if (!defined($ent) || !length($ent)) | |
130 | { | |
131 | $w->selectionClear; | |
132 | $w->anchorClear; | |
133 | return; | |
134 | } | |
135 | ||
136 | my @info = $w->info('item',$Ev->x, $Ev->y); | |
137 | if (@info) | |
138 | { | |
139 | die 'Assert' unless $info[0] eq $ent; | |
140 | } | |
141 | else | |
142 | { | |
143 | @info = $ent; | |
144 | } | |
145 | ||
146 | if (defined($info[1]) && $info[1] eq 'indicator') | |
147 | { | |
148 | $w->{tixindicator} = $ent; | |
149 | $w->Callback(-indicatorcmd => $ent, '<Arm>'); | |
150 | } | |
151 | else | |
152 | { | |
153 | my $browse = 0; | |
154 | ||
155 | if ($mode eq 'single') | |
156 | { | |
157 | $w->anchorSet($ent); | |
158 | } | |
159 | elsif ($mode eq 'browse') | |
160 | { | |
161 | $w->anchorSet($ent); | |
162 | $w->selectionClear; | |
163 | $w->selectionSet($ent); | |
164 | $browse = 1; | |
165 | } | |
166 | elsif ($mode eq 'multiple') | |
167 | { | |
168 | $w->selectionClear; | |
169 | $w->anchorSet($ent); | |
170 | $w->selectionSet($ent); | |
171 | $browse = 1; | |
172 | } | |
173 | elsif ($mode eq 'extended') | |
174 | { | |
175 | $w->anchorSet($ent); | |
176 | $w->selectionClear; | |
177 | $w->selectionSet($ent); | |
178 | $browse = 1; | |
179 | } | |
180 | ||
181 | if ($browse) | |
182 | { | |
183 | $w->Callback(-browsecmd => @info); | |
184 | } | |
185 | } | |
186 | } | |
187 | ||
188 | sub ShiftButton1 | |
189 | { | |
190 | my $w = shift; | |
191 | my $Ev = $w->XEvent; | |
192 | ||
193 | my $to = $w->GetNearest($Ev->y, 1); | |
194 | ||
195 | delete $w->{'shiftanchor'}; | |
196 | delete $w->{tixindicator}; | |
197 | ||
198 | return unless (defined($to) and length($to)); | |
199 | ||
200 | my $mode = $w->cget('-selectmode'); | |
201 | ||
202 | if($mode eq 'extended' or $mode eq 'multiple') | |
203 | { | |
204 | my $from = $w->info('anchor'); | |
205 | if(defined $from) | |
206 | { | |
207 | $w->selectionClear; | |
208 | $w->selectionSet($from, $to); | |
209 | } | |
210 | else | |
211 | { | |
212 | $w->anchorSet($to); | |
213 | $w->selectionClear; | |
214 | $w->selectionSet($to); | |
215 | } | |
216 | } | |
217 | } | |
218 | ||
219 | sub GetNearest | |
220 | { | |
221 | my ($w,$y,$undefafterend) = @_; | |
222 | my $ent = $w->nearest($y); | |
223 | if (defined $ent) | |
224 | { | |
225 | if ($undefafterend) | |
226 | { | |
227 | my $borderwidth = $w->cget('-borderwidth'); | |
228 | my $highlightthickness = $w->cget('-highlightthickness'); | |
229 | my $bottomy = ($w->infoBbox($ent))[3]; | |
230 | $bottomy += $borderwidth + $highlightthickness; | |
231 | if ($w->header('exist', 0)){ $bottomy += ($w->header('size', 0))[1]; }; | |
232 | if ($y > $bottomy){ return undef; } | |
233 | } | |
234 | my $state = $w->entrycget($ent, '-state'); | |
235 | return $ent if (!defined($state) || $state ne 'disabled'); | |
236 | } | |
237 | return undef; | |
238 | } | |
239 | ||
240 | sub ButtonRelease1 | |
241 | { | |
242 | my ($w, $Ev) = @_; | |
243 | ||
244 | delete $w->{'shiftanchor'}; | |
245 | ||
246 | my $mode = $w->cget('-selectmode'); | |
247 | ||
248 | if($mode eq 'dragdrop') | |
249 | { | |
250 | # $w->Send_DoneDrag(); | |
251 | return; | |
252 | } | |
253 | ||
254 | my ($x, $y) = ($Ev->x, $Ev->y); | |
255 | my $ent = $w->GetNearest($y, 1); | |
256 | ||
257 | if (!defined($ent) and $mode eq 'single') | |
258 | { | |
259 | my $ent = $w->info('selection'); | |
260 | if (defined $ent) | |
261 | { | |
262 | $w->anchorSet($ent); | |
263 | } | |
264 | } | |
265 | return unless (defined($ent) and length($ent)); | |
266 | ||
267 | if(exists $w->{tixindicator}) | |
268 | { | |
269 | return unless delete($w->{tixindicator}) eq $ent; | |
270 | my @info = $w->info('item',$Ev->x, $Ev->y); | |
271 | if(defined($info[1]) && $info[1] eq 'indicator') | |
272 | { | |
273 | $w->Callback(-indicatorcmd => $ent, '<Activate>'); | |
274 | } | |
275 | return; | |
276 | } | |
277 | ||
278 | if($mode eq 'single' || $mode eq 'browse') | |
279 | { | |
280 | $w->anchorSet($ent); | |
281 | $w->selectionClear; | |
282 | $w->selectionSet($ent); | |
283 | ||
284 | } | |
285 | elsif($mode eq 'multiple') | |
286 | { | |
287 | $w->selectionSet($ent); | |
288 | } | |
289 | elsif($mode eq 'extended') | |
290 | { | |
291 | $w->selectionSet($ent); | |
292 | } | |
293 | ||
294 | $w->Callback(-browsecmd =>$ent); | |
295 | } | |
296 | ||
297 | sub Button1Motion | |
298 | { | |
299 | my $w = shift; | |
300 | my $Ev = $w->XEvent; | |
301 | return unless defined $Ev; | |
302 | ||
303 | delete $w->{'shiftanchor'}; | |
304 | ||
305 | my $mode = $w->cget('-selectmode'); | |
306 | ||
307 | if ($mode eq 'dragdrop') | |
308 | { | |
309 | # $w->Send_StartDrag(); | |
310 | return; | |
311 | } | |
312 | ||
313 | my $ent; | |
314 | if (defined $w->info('anchor')) | |
315 | { | |
316 | $ent = $w->GetNearest($Ev->y); | |
317 | } | |
318 | else | |
319 | { | |
320 | $ent = $w->GetNearest($Ev->y, 1); | |
321 | } | |
322 | return unless (defined($ent) and length($ent)); | |
323 | ||
324 | if(exists $w->{tixindicator}) | |
325 | { | |
326 | my $event_type = $w->{tixindicator} eq $ent ? '<Arm>' : '<Disarm>'; | |
327 | $w->Callback(-indicatorcmd => $w->{tixindicator}, $event_type ); | |
328 | return; | |
329 | } | |
330 | ||
331 | if ($mode eq 'single') | |
332 | { | |
333 | $w->anchorSet($ent); | |
334 | } | |
335 | elsif ($mode eq 'multiple' || $mode eq 'extended') | |
336 | { | |
337 | my $from = $w->info('anchor'); | |
338 | if(defined $from) | |
339 | { | |
340 | $w->selectionClear; | |
341 | $w->selectionSet($from, $ent); | |
342 | } | |
343 | else | |
344 | { | |
345 | $w->anchorSet($ent); | |
346 | $w->selectionClear; | |
347 | $w->selectionSet($ent); | |
348 | } | |
349 | } | |
350 | ||
351 | if ($mode ne 'single') | |
352 | { | |
353 | $w->Callback(-browsecmd =>$ent); | |
354 | } | |
355 | } | |
356 | ||
357 | sub Double1 | |
358 | { | |
359 | my $w = shift; | |
360 | my $Ev = $w->XEvent; | |
361 | ||
362 | delete $w->{'shiftanchor'}; | |
363 | ||
364 | my $ent = $w->GetNearest($Ev->y, 1); | |
365 | ||
366 | return unless (defined($ent) and length($ent)); | |
367 | ||
368 | $w->anchorSet($ent) | |
369 | unless(defined $w->info('anchor')); | |
370 | ||
371 | $w->selectionSet($ent); | |
372 | ||
373 | $w->Callback(-command => $ent); | |
374 | } | |
375 | ||
376 | sub CtrlButton1 | |
377 | { | |
378 | my $w = shift; | |
379 | my $Ev = $w->XEvent; | |
380 | ||
381 | delete $w->{'shiftanchor'}; | |
382 | ||
383 | my $ent = $w->GetNearest($Ev->y, 1); | |
384 | ||
385 | return unless (defined($ent) and length($ent)); | |
386 | ||
387 | my $mode = $w->cget('-selectmode'); | |
388 | ||
389 | if($mode eq 'extended') | |
390 | { | |
391 | $w->anchorSet($ent) unless( defined $w->info('anchor') ); | |
392 | ||
393 | if($w->select('includes', $ent)) | |
394 | { | |
395 | $w->select('clear', $ent); | |
396 | } | |
397 | else | |
398 | { | |
399 | $w->selectionSet($ent); | |
400 | } | |
401 | $w->Callback(-browsecmd =>$ent); | |
402 | } | |
403 | } | |
404 | ||
405 | sub UpDown | |
406 | { | |
407 | my $w = shift; | |
408 | my $spec = shift; | |
409 | ||
410 | my $done = 0; | |
411 | my $anchor = $w->info('anchor'); | |
412 | ||
413 | delete $w->{'shiftanchor'}; | |
414 | ||
415 | unless( defined $anchor ) | |
416 | { | |
417 | $anchor = ($w->info('children'))[0] || ''; | |
418 | ||
419 | return unless (defined($anchor) and length($anchor)); | |
420 | ||
421 | if($w->entrycget($anchor, '-state') ne 'disabled') | |
422 | { | |
423 | # That's a good anchor | |
424 | $done = 1; | |
425 | } | |
426 | else | |
427 | { | |
428 | # We search for the first non-disabled entry (downward) | |
429 | $spec = 'next'; | |
430 | } | |
431 | } | |
432 | ||
433 | my $ent = $anchor; | |
434 | ||
435 | # Find the prev/next non-disabled entry | |
436 | # | |
437 | while(!$done) | |
438 | { | |
439 | $ent = $w->info($spec, $ent); | |
440 | last unless( defined $ent ); | |
441 | next if( $w->entrycget($ent, '-state') eq 'disabled' ); | |
442 | next if( $w->info('hidden', $ent) ); | |
443 | last; | |
444 | } | |
445 | ||
446 | unless( defined $ent ) | |
447 | { | |
448 | $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit'); | |
449 | return; | |
450 | } | |
451 | ||
452 | $w->anchorSet($ent); | |
453 | $w->see($ent); | |
454 | ||
455 | if($w->cget('-selectmode') ne 'single') | |
456 | { | |
457 | $w->selectionClear; | |
458 | $w->selection('set', $ent); | |
459 | $w->Callback(-browsecmd =>$ent); | |
460 | } | |
461 | } | |
462 | ||
463 | sub ShiftUpDown | |
464 | { | |
465 | my $w = shift; | |
466 | my $spec = shift; | |
467 | ||
468 | my $mode = $w->cget('-selectmode'); | |
469 | ||
470 | return $w->UpDown($spec) | |
471 | if($mode eq 'single' || $mode eq 'browse'); | |
472 | ||
473 | my $anchor = $w->info('anchor'); | |
474 | ||
475 | return $w->UpDown($spec) unless (defined($anchor) and length($anchor)); | |
476 | ||
477 | my $done = 0; | |
478 | ||
479 | $w->{'shiftanchor'} = $anchor unless( $w->{'shiftanchor'} ); | |
480 | ||
481 | my $ent = $w->{'shiftanchor'}; | |
482 | ||
483 | while( !$done ) | |
484 | { | |
485 | $ent = $w->info($spec, $ent); | |
486 | last unless( defined $ent ); | |
487 | next if( $w->entrycget($ent, '-state') eq 'disabled' ); | |
488 | next if( $w->info('hidden', $ent) ); | |
489 | last; | |
490 | } | |
491 | ||
492 | unless( $ent ) | |
493 | { | |
494 | $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit'); | |
495 | return; | |
496 | } | |
497 | ||
498 | $w->selectionClear; | |
499 | $w->selection('set', $anchor, $ent); | |
500 | $w->see($ent); | |
501 | ||
502 | $w->{'shiftanchor'} = $ent; | |
503 | ||
504 | $w->Callback(-browsecmd =>$ent); | |
505 | } | |
506 | ||
507 | sub LeftRight | |
508 | { | |
509 | my $w = shift; | |
510 | my $spec = shift; | |
511 | ||
512 | delete $w->{'shiftanchor'}; | |
513 | ||
514 | my $anchor = $w->info('anchor'); | |
515 | ||
516 | unless(defined $anchor) | |
517 | { | |
518 | $anchor = ($w->info('children'))[0] || ''; | |
519 | } | |
520 | ||
521 | my $done = 0; | |
522 | my $ent = $anchor; | |
523 | ||
524 | while(!$done) | |
525 | { | |
526 | my $e = $ent; | |
527 | ||
528 | if($spec eq 'left') | |
529 | { | |
530 | $ent = $w->info('parent', $e); | |
531 | ||
532 | $ent = $w->info('prev', $e) | |
533 | unless(defined $ent && $w->entrycget($ent, '-state') ne 'disabled') | |
534 | } | |
535 | else | |
536 | { | |
537 | $ent = ($w->info('children', $e))[0]; | |
538 | ||
539 | $ent = $w->info('next', $e) | |
540 | unless(defined $ent && $w->entrycget($ent, '-state') ne 'disabled') | |
541 | } | |
542 | ||
543 | last unless( defined $ent ); | |
544 | last if($w->entrycget($ent, '-state') ne 'disabled'); | |
545 | } | |
546 | ||
547 | unless( defined $ent ) | |
548 | { | |
549 | $w->xview('scroll', $spec eq 'left' ? -1 : 1, 'unit'); | |
550 | return; | |
551 | } | |
552 | ||
553 | $w->anchorSet($ent); | |
554 | $w->see($ent); | |
555 | ||
556 | if($w->cget('-selectmode') ne 'single') | |
557 | { | |
558 | $w->selectionClear; | |
559 | $w->selectionSet($ent); | |
560 | ||
561 | $w->Callback(-browsecmd =>$ent); | |
562 | } | |
563 | } | |
564 | ||
565 | sub KeyboardHome | |
566 | { | |
567 | my $w = shift; | |
568 | $w->yview('moveto' => 0); | |
569 | $w->xview('moveto' => 0); | |
570 | } | |
571 | ||
572 | sub KeyboardEnd | |
573 | { | |
574 | my $w = shift; | |
575 | $w->yview('moveto' => 1); | |
576 | $w->xview('moveto' => 0); | |
577 | } | |
578 | ||
579 | sub KeyboardActivate | |
580 | { | |
581 | my $w = shift; | |
582 | ||
583 | my $anchor = $w->info('anchor'); | |
584 | ||
585 | return unless (defined($anchor) and length($anchor)); | |
586 | ||
587 | if($w->cget('-selectmode')) | |
588 | { | |
589 | $w->selectionClear; | |
590 | $w->selectionSet($anchor); | |
591 | } | |
592 | ||
593 | $w->Callback(-command => $anchor); | |
594 | } | |
595 | ||
596 | sub KeyboardBrowse | |
597 | { | |
598 | my $w = shift; | |
599 | ||
600 | my $anchor = $w->info('anchor'); | |
601 | ||
602 | return unless (defined($anchor) and length($anchor)); | |
603 | ||
604 | if ($w->indicatorExists($anchor)) | |
605 | { | |
606 | $w->Callback(-indicatorcmd => $anchor); | |
607 | } | |
608 | ||
609 | if($w->cget('-selectmode')) | |
610 | { | |
611 | $w->selectionClear; | |
612 | $w->selectionSet($anchor); | |
613 | } | |
614 | $w->Callback(-browsecmd =>$anchor); | |
615 | } | |
616 | ||
617 | sub AutoScan | |
618 | { | |
619 | my ($w,$x,$y) = @_; | |
620 | ||
621 | return if ($w->cget('-selectmode') eq 'dragdrop'); | |
622 | if (@_ < 3) | |
623 | { | |
624 | my $Ev = $w->XEvent; | |
625 | return unless defined $Ev; | |
626 | $y = $Ev->y; | |
627 | $x = $Ev->x; | |
628 | } | |
629 | ||
630 | if($y >= $w->height) | |
631 | { | |
632 | $w->yview('scroll', 1, 'units'); | |
633 | } | |
634 | elsif($y < 0) | |
635 | { | |
636 | $w->yview('scroll', -1, 'units'); | |
637 | } | |
638 | elsif($x >= $w->width) | |
639 | { | |
640 | $w->xview('scroll', 2, 'units'); | |
641 | } | |
642 | elsif($x < 0) | |
643 | { | |
644 | $w->xview('scroll', -2, 'units'); | |
645 | } | |
646 | else | |
647 | { | |
648 | return; | |
649 | } | |
650 | $w->RepeatId($w->SUPER::after(50,[ AutoScan => $w, $x, $y ])); | |
651 | $w->Button1Motion; | |
652 | } | |
653 | ||
654 | sub children | |
655 | { | |
656 | # Tix has core-tk window(s) which are not a widget(s) | |
657 | # the generic code returns these as an "undef" | |
658 | my $w = shift; | |
659 | my @info = grep(defined($_),$w->winfo('children')); | |
660 | @info; | |
661 | } | |
662 | ||
663 | 1; | |
664 |