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 / TixGrid.pm
CommitLineData
86530b38
AT		 1
2# TODO:
3#
4# o How to get into state 's0' 'b0' so cursor keys start
5# working (compare with Tk/Widget XYscrollBind
6# o the options -browsecmd and -command callback are not
7# not implemented (as in Tix)
8# o privateData 'state' used only once (check again Grid.tcl)
9# o FloatEntry 'sometimes not activeted immediately on selection
10# o check also Leave Binding. Looks like entry does get unpost'ed
11
12package Tk::TixGrid;
13
14BEGIN
15 {
16 use vars '$DEBUG';
17 $DEBUG = (defined($ENV{USER}) and $ENV{USER} eq 'ach') ? 1 : 0;
18 print STDERR "tixGrid: debug = $DEBUG\n" if $DEBUG;
19 }
20
21use strict;
22use vars qw($VERSION);
23$VERSION = '3.023'; # $Id: //depot/Tk8/TixGrid/TixGrid.pm#23 $
24
25use Tk qw(Ev $XS_VERSION);
26use Tk::Widget;
27use Carp;
28
29carp "\n".__PACKAGE__.' is deprecated' unless defined($Test::ntest);
30
31use base 'Tk::Widget';
32
33Construct Tk::Widget 'TixGrid';
34
35bootstrap Tk::TixGrid;
36
37sub Tk_cmd { \&Tk::tixGrid }
38
39sub Tk::Widget::SrclTixGrid { shift->Scrolled('TixGrid' => @_) }
40
41Tk::Methods qw(anchor bdtype delete entrycget entryconfigure format index
42 move set size unset xview yview
43 to_list_commands dragsite dropsite geometryinfo info
44 nearest selection sort );
45
46# edit subcommand is special. It justs invokes tcl code:
47#
48# edit set x y -> tixGrid:EditCell $w, x, y
49# edit apply -> tixGrid:EditApply
50
51# xxx Create an edit sub?
52# sub edit { .... }
53
54sub editSet
55 {
56 die "wrong args. Should be \$w->editSet(x,y)\n" unless @_ == 3;
57 my ($w, $x, $y) = @_;
58 $w->EditCell($x, $y);
59 }
60
61sub editApply
62 {
63 die "wrong args. Should be \$w->editApply()\n" unless @_ == 1;
64 my ($w) = @_;
65 $w->EditApply()
66 }
67
68use Tk::Submethods
69 (
70 'anchor' => [ qw(get set) ],
71 'delete' => [ qw(column row) ],
72 'info' => [ qw(bbox exists anchor) ],
73 'move' => [ qw(column row) ],
74 'selection' => [ qw(adjust clear includes set) ],
75 'size' => [ qw(column row) ],
76 'format' => [ qw(grid border) ],
77 );
78
79####################################################
80##
81## For button 2 scrolling. So TixGrid has 'standard'
82## standard scrolling interface
83##
84
85#sub scanMark
86# {
87# die "wrong # args: \$w->scanMark(x,y)\n" unless @_ == 3;
88# my ($w) = @_;
89# $w->{__scanMarkXY__} = [ @_[1,2] ];
90# return "";
91# }
92#
93#sub scanDragto
94# {
95# die "wrong # args: \$w->scanDragto(x,y)\n" unless @_ == 3;
96# my ($w, $x, $y) = @_;
97# my ($ox, $oy) = @{ $w->{__scanMarkXY__} };
98#
99# #...
100#
101# return "";
102# }
103
104### end button 2 scrolling stuff ####################
105
106
107# Grid.tcl --
108#
109# This file defines the default bindings for Tix Grid widgets.
110#
111# Copyright (c) 1996, Expert Interface Technologies
112#
113# See the file "license.terms" for information on usage and redistribution
114# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
115#
116# Bindings translated to perl/Tk by Achim Bohnet <ach@mpe.mpg.de>
117
118sub ClassInit
119 {
120 my ($class, $mw) = @_;
121 $class->SUPER::ClassInit($mw);
122
123 $mw->XYscrollBind($class);
124
125 ##
126 ## Button bindings
127 ##
128
129 $mw->bind($class, '<ButtonPress-1>', ['Button_1', Ev('x'), Ev('y')]);
130 $mw->bind($class, '<Shift-ButtonPress-1>', ['Shift_Button_1', Ev('x'), Ev('y')]);
131 $mw->bind($class, '<Control-ButtonPress-1>',['Control_Button_1', Ev('x'), Ev('y')]);
132 $mw->bind($class, '<ButtonRelease-1>', ['ButtonRelease_1', Ev('x'), Ev('y')]);
133 $mw->bind($class, '<Double-ButtonPress-1>', ['Double_1', Ev('x'), Ev('y')]);
134 $mw->bind($class, '<B1-Motion>','Button_Motion');
135 $mw->bind($class, '<Control-B1-Motion>','Control_Button_Motion');
136 $mw->bind($class, '<B1-Leave>','Button_Leave');
137 $mw->bind($class, '<Double-ButtonPress-1>', ['Double_1', Ev('x'), Ev('y')]);
138 $mw->bind($class, '<B1-Enter>', ['B1_Enter', Ev('x'), Ev('y')]);
139 $mw->bind($class, '<Control-B1-Leave>','Control_Button_Leave');
140 $mw->bind($class, '<Control-B1-Enter>', ['Control_B1_Enter', Ev('x'), Ev('y')]);
141
142 ##
143 ## Keyboard bindings
144 ##
145
146 $mw->bind($class, '<Up>', ['DirKey', 'up' ]);
147 $mw->bind($class, '<Down>', ['DirKey', 'down' ]);
148 $mw->bind($class, '<Left>', ['DirKey', 'left' ]);
149 $mw->bind($class, '<Right>', ['DirKey', 'right' ]);
150
151 $mw->PriorNextBind($class);
152
153 $mw->bind($class, '<Return>', 'Return');
154 $mw->bind($class, '<space>', 'Space' );
155
156 return $class;
157 }
158
159#----------------------------------------------------------------------
160#
161#
162# Mouse bindings
163#
164#
165#----------------------------------------------------------------------
166
167sub Button_1
168 {
169 my $w = shift;
170
171 return if $w->cget('-state') eq 'disabled';
172 $w->SetFocus;
173 $w->ChgState(@_,
174 [
175 '0'=>'1',
176 ]
177 );
178 }
179
180sub Shift_Button_1
181 {
182 my $w = shift;
183
184 return if $w->cget('-state') eq 'disabled';
185 $w->SetFocus;
186
187# $w->ChgState(@_,
188# [
189# ]
190# );
191 }
192
193sub Control_Button_1
194 {
195 my $w = shift;
196
197 return if $w->cget('-state') eq 'disabled';
198 $w->SetFocus;
199
200 $w->ChgState(@_,
201 [
202 's0' => 's1',
203 'b0' => 'b1',
204 'm0' => 'm1',
205 'e0' => 'e10',
206 ]
207 );
208 }
209
210sub ButtonRelease_1
211 {
212 shift->ChgState(@_,
213 [
214 '2' => '5',
215 '4' => '3',
216 ]
217 );
218 }
219
220sub B1_Motion
221 {
222 shift->ChgState(@_,
223 [
224 '2' => '4',
225 '4' => '4',
226 ]
227 );
228 }
229
230
231sub Control_B1_Motion
232 {
233 shift->ChgState(@_,
234 [
235 's2' => 's4',
236 's4' => 's4',
237 'b2' => 'b4',
238 'b4' => 'b4',
239 'm2' => 'm4',
240 'm5' => 'm4',
241 ]
242 );
243 }
244
245
246sub Double_1
247 {
248 shift->ChgState(@_,
249 [
250 's0' => 's7',
251 'b0' => 'b7',
252 ]
253 );
254 }
255
256
257sub B1_Leave
258 {
259 shift->ChgState(@_,
260 [
261 's2' => 's5',
262 's4' => 's5',
263 'b2' => 'b5',
264 'b4' => 'b5',
265 'm2' => 'm8',
266 'm5' => 'm8',
267 'e2' => 'e8',
268 'e5' => 'e8',
269 ]
270 );
271 }
272
273
274sub B1_Enter
275 {
276 shift->ChgState(@_,
277 [
278 's5' => 's4',
279 's6' => 's4',
280 'b5' => 'b4',
281 'b6' => 'b4',
282 'm8' => 'm4',
283 'm9' => 'm4',
284 'e8' => 'e4',
285 'e9' => 'e4',
286 ]
287 );
288 }
289
290
291sub Control_B1_Leave
292 {
293 shift->ChgState(@_,
294 [
295 's2' => 's5',
296 's4' => 's5',
297 'b2' => 'b5',
298 'b4' => 'b5',
299 'm2' => 'm8',
300 'm5' => 'm8',
301 ]
302 );
303 }
304
305
306sub Control_B1_Enter
307 {
308 shift->ChgState(@_,
309 [
310 's5' => 's4',
311 's6' => 's4',
312 'b5' => 'b4',
313 'b6' => 'b4',
314 'm8' => 'm4',
315 'm9' => 'm4',
316 ]
317 );
318 }
319
320
321sub AutoScan
322 {
323 shift->ChgState(@_,
324 [
325 's5' => 's9',
326 's6' => 's9',
327 'b5' => 'b9',
328 'b6' => 'b9',
329 'm8' => 'm9',
330 'm9' => 'm9',
331 'e8' => 'm9',
332 'e9' => 'm9',
333 ]
334 );
335 }
336
337#----------------------------------------------------------------------
338#
339#
340# Key bindings
341#
342#
343#----------------------------------------------------------------------
344
345sub DirKey
346 {
347 my ($w, $key) = @_;
348
349 return if $w->cget('-state') eq 'disabled';
350
351print STDERR "$w->DirKey($key)\n" if $DEBUG;
352 $w->ChgState($key,
353 [
354 's0' => 's8',
355 'b0' => 'b8',
356 ]
357 );
358 }
359
360
361sub Return
362 {
363 my ($w) = @_;
364
365 return if $w->cget('-state') eq 'disabled';
366
367 $w->ChgState(
368 [
369 's0' => 's9',
370 'b0' => 'b9',
371 ]
372 );
373 }
374
375
376sub Space
377 {
378 my ($w) = @_;
379
380 return if $w->cget('-state') eq 'disabled';
381
382 $w->ChgState(
383 [
384 's0' => 's10',
385 'b0' => 'b10',
386 ]
387 );
388 }
389
390
391#----------------------------------------------------------------------
392#
393# STATE MANIPULATION
394#
395#
396#----------------------------------------------------------------------
397
398sub GetState
399 {
400 my ($w) = @_;
401 my $data = $w->privateData();
402 $data->{state} = 0 unless exists $data->{state};
403 return $data->{state};
404}
405
406sub Button_Motion
407{
408 my $w = shift;
409 my $Ev = $w->XEvent;
410 $Tk::x = $Ev->x;
411 $Tk::y = $Ev->y;
412 $Tk::X = $Ev->X;
413 $Tk::Y = $Ev->Y;
414 $w->B1_Motion($Tk::x, $Tk::y);
415}
416
417
418sub Control_Button_Motion
419{
420 my $w = shift;
421 my $Ev = $w->XEvent;
422 $Tk::x = $Ev->x;
423 $Tk::y = $Ev->y;
424 $Tk::X = $Ev->X;
425 $Tk::Y = $Ev->Y;
426 $w->Control_B1_Motion($Tk::x, $Tk::y);
427}
428
429
430sub Button_Leave
431{
432 my $w = shift;
433 my $Ev = $w->XEvent;
434 $Tk::x = $Ev->x;
435 $Tk::y = $Ev->y;
436 $Tk::X = $Ev->X;
437 $Tk::Y = $Ev->Y;
438 $w->B1_Leave();
439}
440
441
442sub Control_Button_Leave
443{
444 my $w = shift;
445 my $Ev = $w->XEvent;
446 $Tk::x = $Ev->x;
447 $Tk::y = $Ev->y;
448 $Tk::X = $Ev->X;
449 $Tk::Y = $Ev->Y;
450 $w->Control_B1_Leave();
451}
452
453
454sub SetState
455 {
456 my ($w, $state) = @_;
457 $w->privateData()->{state} = $state;
458 }
459
460sub GoState
461 {
462 my ($w, $state) = (shift, shift);
463 print STDERR 'Gostate: ', $w->GetState, " --> $state, " if $DEBUG;
464 $w->SetState($state);
465 my $method = "GoState_$state";
466
467 print STDERR 'args=(', join(',',@_), ')'.
468 "\t(",$w->cget('-selectmode').
469 ',',$w->cget('-selectunit').")\n" if $DEBUG;
470
471 if (0)
472 {
473 $@ = '';
474 %@ = (); # Workaround to prevent spurious loss of $@
475 eval { $w->$method(@_) };
476 print STDERR "Error Gostate: '$state': ", $@ if $@;
477 return undef;
478 }
479
480 $w->$method(@_);
481 return undef
482 }
483
484##
485## ChgState is a fancy case statement
486##
487
488sub ChgState
489 {
490 my $w = shift;
491 my $map = pop;
492 print STDERR 'ChgState(', join(',',@_,'['), join(',',@$map,),']) ' if $DEBUG;
493 my $state = $w->GetState;
494
495 my ($match, $to);
496 while (@$map)
497 {
498 $match = shift @$map;
499 $to = shift @$map;
500 if ($match eq $state)
501 {
502 print STDERR "$state --> $to \n" if $DEBUG;
503 $w->GoState($to, @_);
504 return;
505 }
506 }
507 print STDERR "*no* chg for $state\n" if $DEBUG;
508 }
509
510
511#----------------------------------------------------------------------
512# SELECTION ROUTINES
513#----------------------------------------------------------------------
514
515#proc tixGrid:SelectSingle {w ent} {
516# $w selection set [lindex $ent 0] [lindex $ent 1]
517# tixGrid:CallBrowseCmd $w $ent
518#}
519
520sub SelectSingle
521 {
522 my ($w, $n1, $n2) = @_;
523 $w->selection('set', $n1, $n2);
524 #FIX: -options -browsecmd not implemented jet
525 #$w->Callback('-browsecmd' => $n1, $n2);
526 }
527
528#----------------------------------------------------------------------
529# SINGLE SELECTION
530#----------------------------------------------------------------------
531
532sub GoState_0
533 {
534 my ($w) = @_;
535 my $list = $w->privateData()->{list};
536 return unless defined $list;
537
538 foreach my $cmd (@$list)
539 {
540 # XXX should do more something like $w->Callback'('__pending_cmds__');
541 eval $cmd; # XXX why in tcl in global context (binding?)
542 }
543 undef(@$list); # XXX should really delete? Maybe on needed in TCL
544 }
545
546# XXXX how to translate global context
547# what does unset
548#proc tixGrid:GoState-0 {w} {
549# set list $w:_list
550# global $list
551#
552# if [info exists $list] {
553# foreach cmd [set $list] {
554# uplevel #0 $cmd
555# }
556# if [info exists $list] {
557# unset $list
558# }
559# }
560#}
561
562sub GoState_1
563 {
564 my ($w, $x, $y) = @_;
565
566 my @ent = $w->mynearest($x,$y);
567 if (@ent)
568 {
569 $w->SetAnchor(@ent);
570 }
571 $w->CheckEdit;
572 $w->selection('clear', 0, 0, 'max', 'max');
573
574 if ($w->cget('-selectmode') ne 'single')
575 {
576 $w->SelectSingle(@ent);
577 }
578 $w->GoState(2);
579 }
580
581sub GoState_2
582 {
583 my ($w) = @_;
584 }
585
586sub GoState_3
587 {
588 my ($w, $x, $y) = @_;
589
590 my @ent = $w->mynearest($x,$y);
591 if (@ent)
592 {
593 $w->SelectSingle(@ent);
594 }
595 $w->GoState(0);
596
597 }
598
599sub GoState_4
600 {
601 my ($w, $x, $y) = @_;
602
603 my (@ent) = $w->mynearest($x,$y);
604 my $mode = $w->cget('-selectmode');
605
606 if ($mode eq 'single')
607 {
608 $w->SetAnchor(@ent);
609 }
610 elsif ($mode eq 'browse')
611 {
612 $w->SetAnchor(@ent);
613 $w->selection('clear', 0, 0, 'max', 'max');
614 $w->SelectSingle(@ent);
615 }
616 elsif ($mode eq 'multiple' ||
617 $mode eq 'extended')
618 {
619 my (@anchor) = $w->anchor('get');
620 $w->selection('adjust', @anchor[0,1], @ent[0,1]);
621 }
622 }
623
624sub GoState_5
625 {
626 my ($w, $x, $y) = @_;
627
628 my @ent = $w->mynearest($x,$y);
629 if (@ent)
630 {
631 $w->SelectSingle(@ent);
632 $w->SetEdit(@ent);
633 }
634 $w->GoState(0);
635
636 }
637
638##############################################
639# BUG xxx
640# return scalar instead of errors
641
642sub mynearest { shift->split_s2a('nearest', @_); }
643sub myanchorGet { shift->split_s2a('anchor', 'get', @_); }
644
645sub split_s2a
646 {
647 my $w = shift;
648 my $method = shift;
649 my @ent = $w->$method(@_);
650 if (@ent == 1)
651 {
652my $tmp = $ent[0];
653 @ent = split(/ /, $ent[0]) if @ent == 1;
654print STDERR join('|',"$method splitted '$tmp' =>",@ent,"\n") if $DEBUG;
655 }
656 else
657 {
658#print STDERR join("|","$method splitted is okay :",@ent,"\n") if $DEBUG;
659 }
660 return @ent;
661 }
662
663##############################################
664
665
666sub GoState_s5
667 {
668 shift->StartScan();
669 }
670
671
672sub GoState_s6
673 {
674 shift->DoScan();
675 }
676
677
678sub GoState_s7
679 {
680 my ($w, $x, $y) = @_;
681
682 my @ent = $w->mynearest($x, $y);
683 if (@ent)
684 {
685 $w->selection('clear');
686 $w->selection('set', @ent);
687 $w->Callback('-command' => @ent);
688 }
689 $w->GoState('s0');
690 }
691
692
693sub GoState_s8
694 {
695 my ($w, $key) = @_;
696
697 ## BUGS ....
698 ## - anchor is bad, only bbox, exists8
699 ## - looks like anchor is 1-dim: set anchor 0
700 ## - method see unknown (even when defined with Tk::Method)
701
702 my (@anchor) = $w->info('anchor');
703 if (@anchor)
704 {
705 @anchor = ();
706 }
707 else
708 {
709 @anchor = $w->info($key, @anchor);
710 }
711
712 $w->anchor('set', @anchor);
713 $w->see(@anchor);
714
715 $w->GoState('s0');
716 }
717
718#proc tixGrid:GoState-s8 {w key} {
719# set anchor [$w info anchor]
720#
721# if {$anchor == ""} {
722# set anchor 0
723# } else {
724# set anchor [$w info $key $anchor]
725# }
726#
727# $w anchor set $anchor
728# $w see $anchor
729# tixGrid:GoState s0 $w
730#}
731
732
733sub GoState_s9
734 {
735 my ($w, $key) = @_;
736
737#print STDERR "GoState_s9 is not implemented\n";
738
739 my (@anchor) = $w->info('anchor');
740 unless (@anchor)
741 {
742 @anchor = ();
743 $w->anchor('set', @anchor);
744 $w->see(@anchor);
745 }
746
747 unless ($w->info('anchor'))
748 {
749 # ! may not have any elements
750 #
751 $w->Callback('-command' => $w->info('anchor'));
752 $w->selection('clear');
753 $w->selection('set', @anchor);
754 }
755
756 $w->GoState('s0');
757 }
758
759
760sub GoState_s10
761 {
762 my ($w, $key) = @_;
763
764 my (@anchor) = $w->info('anchor');
765 if (@anchor)
766 {
767 @anchor = ();
768 $w->anchor('set', @anchor);
769 $w->see(@anchor);
770 }
771
772 unless ($w->info('anchor'))
773 {
774 # ! may not have any elements
775 #
776 $w->Callback('-browsecmd' => $w->info('anchor'));
777 $w->selection('clear');
778 $w->selection('set', @anchor);
779 }
780
781 $w->GoState('s0');
782 }
783
784
785#----------------------------------------------------------------------
786# BROWSE SELECTION
787#----------------------------------------------------------------------
788
789sub GoState_b0
790 {
791 my ($w) = @_;
792 }
793
794sub GoState_b1
795 {
796 my ($w, $x, $y) = @_;
797
798 my (@ent) = $w->mynearest($x, $y);
799 if (@ent)
800 {
801 $w->anchor('set', @ent);
802 $w->selection('clear');
803 $w->selection('set', @ent);
804 $w->Callback('-browsecmd' => @ent);
805 }
806
807 $w->GoState('b2');
808 }
809
810sub GoState_b2
811 {
812 my ($w) = @_;
813 }
814
815sub GoState_b3
816 {
817 my ($w) = @_;
818
819 my (@ent) = $w->info('anchor');
820 if (@ent)
821 {
822 $w->selection('clear');
823 $w->selection('set', @ent);
824 $w->selection('set', @ent);
825 $w->Callback('-browsecmd' => @ent);
826 }
827
828 $w->GoState('b0');
829 }
830
831
832sub GoState_b4
833 {
834 my ($w, $x, $y) = @_;
835
836 my (@ent) = $w->mynearest($x, $y);
837 if (@ent)
838 {
839 $w->anchor('set', @ent);
840 $w->selection('clear');
841 $w->selection('set', @ent);
842 $w->Callback('-browsecmd' => @ent);
843 }
844 }
845
846
847sub GoState_b5 { shift->StartScan(); }
848
849
850sub GoState_b6 { shift->DoScan(); }
851
852
853sub GoState_b7
854 {
855 my ($w, $x, $y) = @_;
856
857 my (@ent) = $w->mynearest($x, $y);
858 if (@ent)
859 {
860 $w->selection('clear');
861 $w->selection('set', @ent);
862 $w->Callback('-command' => @ent);
863 }
864 $w->GoState('b0');
865 }
866
867
868sub GoState_b8
869 {
870 my ($w, $key) = @_;
871
872 my (@anchor) = $w->info('anchor');
873 if (@anchor)
874 {
875 @anchor = $w->info('key', @anchor);
876 }
877 else
878 {
879 @anchor = (0,0); # ?????
880 }
881
882 $w->anchor('set', @anchor);
883 $w->selection('clear');
884 $w->selection('set', @anchor);
885 $w->see(@anchor);
886
887 $w->Callback('-browsecmd' => @anchor);
888 $w->GoState('b0');
889 }
890
891
892sub GoState_b9
893 {
894 my ($w) = @_;
895
896 my (@anchor) = $w->info('anchor');
897 unless (@anchor)
898 {
899 @anchor = (0,0);
900 $w->anchor('set', @anchor);
901 $w->see(@anchor);
902 }
903
904 if ($w->info('anchor'))
905 {
906 # ! may not have any elements
907 #
908 $w->Callback('-command' => $w->info('anchor'));
909 $w->selection('clear');
910 $w->selection('set', @anchor);
911 }
912
913 $w->GoState('b0');
914 }
915
916
917sub GoState_b10
918 {
919 my ($w) = @_;
920
921 my (@anchor) = $w->info('anchor');
922 unless (@anchor)
923 {
924 @anchor = (0,0);
925 $w->anchor('set', @anchor);
926 $w->see(@anchor);
927 }
928
929 if ($w->info('anchor'))
930 {
931 # ! may not have any elements
932 #
933 $w->Callback('-browsecmd' => $w->info('anchor'));
934 $w->selection('clear');
935 $w->selection('set', @anchor);
936 }
937
938 $w->GoState('b0');
939 }
940
941#----------------------------------------------------------------------
942# MULTIPLE SELECTION
943#----------------------------------------------------------------------
944
945
946sub GoState_m0
947 {
948 my ($w) = @_;
949 }
950
951sub GoState_m1
952 {
953 my ($w, $x, $y) = @_;
954
955 my (@ent) = $w->mynearest($x,$y);
956 if (@ent)
957 {
958 $w->anchor('set', @ent);
959 $w->selection('clear');
960 $w->selection('set', @ent);
961 $w->Callback('-browsecmd' => @ent);
962 }
963
964 $w->GoState('m2');
965 }
966
967sub GoState_m2
968 {
969 my ($w) = @_;
970 }
971
972sub GoState_m3
973 {
974 my ($w) = @_;
975
976 my (@ent) = $w->info('anchor');
977 if (@ent)
978 {
979 $w->Callback('-browsecmd' => @ent);
980 }
981
982 $w->GoState('m0');
983 }
984
985
986sub GoState_m4
987 {
988 my ($w, $x, $y) = @_;
989
990 my (@from) = $w->info('anchor');
991 my (@to) = $w->mynearest($x, $y);
992 if (@to)
993 {
994 $w->selection('clear');
995 $w->selection('set', @from, @to);
996 $w->Callback('-browsecmd' => @to);
997 }
998 $w->GoState('m5');
999 }
1000
1001sub GoState_m5
1002 {
1003 my ($w) = @_;
1004 }
1005
1006sub GoState_m6
1007 {
1008 my ($w, $x, $y) = @_;
1009
1010 my (@ent) = $w->mynearest($x, $y);
1011 if (@ent)
1012 {
1013 $w->Callback('-browsecmd' => @ent);
1014 }
1015 $w->GoState('m0');
1016 }
1017
1018sub GoState_m7
1019 {
1020 my ($w, $x, $y) = @_;
1021
1022 my (@from) = $w->info('anchor');
1023 my (@to) = $w->mynearest($x, $y);
1024 unless (@from)
1025 {
1026 @from = @to;
1027 $w->anchor('set', @from);
1028 }
1029 if (@to)
1030 {
1031 $w->selection('clear');
1032 $w->selection('set', @from, @to);
1033 $w->Callback('-browsecmd' => @to);
1034 }
1035 $w->GoState('m5');
1036 }
1037
1038
1039sub GoState_m8 { shift->StartScan() }
1040
1041
1042sub GoState_m9 { shift->DoScan() }
1043
1044
1045sub GoState_xm7
1046 {
1047 my ($w, $x, $y) = @_;
1048
1049 my (@ent) = $w->mynearest($x, $y);
1050 if (@ent)
1051 {
1052 $w->selection('clear');
1053 $w->selection('set', @ent);
1054 $w->Callback('-browsecmd' => @ent);
1055 }
1056 $w->GoState('m0');
1057 }
1058
1059#----------------------------------------------------------------------
1060# EXTENDED SELECTION
1061#----------------------------------------------------------------------
1062
1063sub GoState_e0
1064 {
1065 my ($w) = @_;
1066 }
1067
1068sub GoState_e1
1069 {
1070 my ($w, $x, $y) = @_;
1071 my (@ent) = $w->mynearest($x, $y);
1072 if (@ent)
1073 {
1074 $w->anchor('set', @ent);
1075 $w->selection('clear');
1076 $w->selection('set', @ent);
1077 $w->Callback('-browsecmd' => @ent);
1078 }
1079 $w->GoState('e2');
1080 }
1081
1082
1083sub GoState_e2
1084 {
1085 my ($w) = @_;
1086 }
1087
1088sub GoState_e3
1089 {
1090 my ($w) = @_;
1091
1092 my (@ent) = $w->info('anchor');
1093 if (@ent)
1094 {
1095 $w->Callback('-browsecmd' => @ent);
1096 }
1097 $w->GoState('e0');
1098 }
1099
1100sub GoState_e4
1101 {
1102 my ($w, $x, $y) = @_;
1103
1104 my (@from) = $w->info('anchor');
1105 my (@to) = $w->mynearest($x, $y);
1106 if (@to)
1107 {
1108 $w->selection('clear');
1109 $w->selection('set', @from, @to);
1110 $w->Callback('-browsecmd' => @to);
1111 }
1112 $w->GoState('e5');
1113 }
1114
1115sub GoState_e5
1116 {
1117 my ($w) = @_;
1118 }
1119
1120sub GoState_e6
1121 {
1122 my ($w, $x, $y) = @_;
1123
1124 my (@ent) = $w->mynearest($x, $y);
1125 if (@ent)
1126 {
1127 $w->Callback('-browsecmd' => @ent);
1128 }
1129 $w->GoState('e0');
1130 }
1131
1132sub GoState_e7
1133 {
1134 my ($w, $x, $y) = @_;
1135
1136 my (@from) = $w->info('anchor');
1137 my (@to) = $w->mynearest($x, $y);
1138 unless (@from)
1139 {
1140 @from = @to;
1141 $w->anchor('set', @from);
1142 }
1143 if (@to)
1144 {
1145 $w->selection('clear');
1146 $w->selection('set', @from, @to);
1147 $w->Callback('-browsecmd' => @to);
1148 }
1149 $w->GoState('e5');
1150 }
1151
1152sub GoState_e8 { shift->StartScan(); }
1153
1154sub GoState_e9 { shift->DoScan(); }
1155
1156sub GoState_e10
1157 {
1158 my ($w, $x, $y) = @_;
1159
1160 my (@ent) = $w->mynearest($x, $y);
1161 if (@ent)
1162 {
1163 if ($w->info('anchor'))
1164 {
1165 $w->anchor('set', @ent);
1166 }
1167 if ($w->selection('includes', @ent))
1168 {
1169 $w->selection('clear', @ent);
1170 }
1171 else
1172 {
1173 $w->selection('set', @ent);
1174 }
1175 $w->Callback('-browsecmd' => @ent);
1176 }
1177 $w->GoState('e2');
1178 }
1179
1180sub GoState_xe7
1181 {
1182 my ($w, $x, $y) = @_;
1183
1184 my (@ent) = $w->mynearest($x, $y);
1185 if (@ent)
1186 {
1187 $w->selection('clear');
1188 $w->selection('set', @ent);
1189 $w->Callback('-command' => @ent);
1190 }
1191 $w->GoState('e0');
1192 }
1193
1194
1195#----------------------------------------------------------------------
1196# HODGE PODGE
1197#----------------------------------------------------------------------
1198
1199sub GoState_12
1200 {
1201 my ($w, $x, $y) = @_;
1202
1203 $w->CancelRepeat; # xxx will not work
1204 $w->GoState(5, $x, $y);
1205 }
1206#proc tixGrid:GoState-12 {w x y} {
1207# tkCancelRepeat
1208# tixGrid:GoState 5 $w $x $y
1209#}
1210
1211sub GoState_13
1212 {
1213 # FIX: a) $ent or @ent, b) 13 is never called!!? same in Grid.tcl
1214 my ($w, @ent, @oldEnt) = @_;
1215
1216 my $data = $w->MainWindow->privateData('Tix');
1217 $data->{indicator} = \@ent;
1218 $data->{oldEntry} = \@oldEnt;
1219 $w->IndicatorCmd('<Arm>', @ent);
1220 }
1221# set tkPriv(tix,oldEnt) $oldEnt
1222# tixGrid:IndicatorCmd $w <Arm> $ent
1223#}
1224
1225sub GoState_14
1226 {
1227 my ($w, $x, $y) = @_;
1228
1229 my $data = $w->MainWindow->privateData('Tix');
1230 if ($w->InsideArmedIndicator($x, $y))
1231 {
1232 $w->anchor('set', @{ $data->{indicator} });
1233 $w->selection('clear');
1234 $w->selection('set', @{ $data->{indicator} });
1235 $w->IndicatorCmd('<Activate>', @{ $data->{indicator} });
1236 }
1237 else
1238 {
1239 $w->IndicatorCmd('<Disarm>', @{ $data->{indicator} });
1240 }
1241 delete($data->{indicator});
1242 $w->GoState(0);
1243 }
1244
1245sub GoState_16
1246 {
1247 my ($w, @ent) = @_;
1248
1249 return unless (@ent);
1250 if ($w->cget('-selectmode') ne 'single')
1251 {
1252 $w->Select(@ent);
1253 $w->Browse(@ent);
1254 }
1255 }
1256
1257sub GoState_18
1258 {
1259 my ($w) = @_;
1260
1261 $w->CancelRepeat; ## xxx
1262 $w->GoState(6, $Tk::x, $Tk::y);
1263 }
1264
1265sub GoState_20
1266 {
1267 my ($w, $x, $y) = @_;
1268
1269 my $data = $w->MainWindow->privateData('Tix');
1270 if ($w->InsideArmedIndicator($x, $y))
1271 {
1272 $w->IndicatorCmd('<Arm>', $data->{'indicator'});
1273 }
1274 else
1275 {
1276 $w->GoState(21, $x, $y);
1277 }
1278 }
1279
1280sub GoState_21
1281 {
1282 my ($w, $x, $y) = @_;
1283
1284 my $data = $w->MainWindow->privateData('Tix');
1285 unless ($w->InsideArmedIndicator($x, $y))
1286 {
1287 $w->IndicatorCmd('<Disarm>', $data->{'indicator'});
1288 }
1289 else
1290 {
1291 $w->GoState(20, $x, $y);
1292 }
1293 }
1294
1295sub GoState_22
1296 {
1297 my ($w) = @_;
1298 my $data = $w->MainWindow->privateData('Tix');
1299 if (@{ $data->{oldEntry} })
1300 {
1301 $w->anchor('set', @{ $data->{oldEntry} });
1302 }
1303 else
1304 {
1305 $w->anchor('clear');
1306 }
1307 $w->GoState(0);
1308 }
1309
1310
1311#----------------------------------------------------------------------
1312# callback actions
1313#----------------------------------------------------------------------
1314
1315sub SetAnchor
1316 {
1317 my ($w, @ent) = @_;
1318
1319 if (@ent)
1320 {
1321 $w->anchor('set', @ent);
1322# $w->see(@ent);
1323 }
1324 }
1325
1326# xxx check @ent of @$ent
1327sub Select
1328 {
1329 my ($w, @ent) = @_;
1330 $w->selection('clear');
1331 $w->selection('set', @ent)
1332 }
1333
1334# xxx check new After handling
1335sub StartScan
1336 {
1337 my ($w) = @_;
1338 $Tk::afterId = $w->after(50, [AutoScan, $w]);
1339 }
1340
1341sub DoScan
1342 {
1343 my ($w) = @_;
1344 my $x = $Tk::x;
1345 my $y = $Tk::y;
1346 my $X = $Tk::X;
1347 my $Y = $Tk::Y;
1348
1349 my $out = 0;
1350 if ($y >= $w->height)
1351 {
1352 $w->yview('scroll', 1, 'units');
1353 $out = 1;
1354 }
1355 if ($y < 0)
1356 {
1357 $w->yview('scroll', -1, 'units');
1358 $out = 1;
1359 }
1360 if ($x >= $w->width)
1361 {
1362 $w->xview('scroll', 2, 'units');
1363 $out = 1;
1364 }
1365 if ($x < 0)
1366 {
1367 $w->xview('scroll', -2, 'units');
1368 $out = 1;
1369 }
1370 if ($out)
1371 {
1372 $Tk::afterId = $w->after(50, ['AutoScan', $w]);
1373 }
1374 }
1375
1376
1377#proc tixGrid:CallBrowseCmd {w ent} {
1378# return
1379#
1380# set browsecmd [$w cget -browsecmd]
1381# if {$browsecmd != ""} {
1382# set bind(specs) {%V}
1383# set bind(%V) $ent
1384#
1385# tixEvalCmdBinding $w $browsecmd bind $ent
1386# }
1387#}
1388
1389#proc tixGrid:CallCommand {w ent} {
1390# set command [$w cget -command]
1391# if {$command != ""} {
1392# set bind(specs) {%V}
1393# set bind(%V) $ent
1394#
1395# tixEvalCmdBinding $w $command bind $ent
1396# }
1397#}
1398
1399# tixGrid:EditCell --
1400#
1401# This command is called when "$w edit set $x $y" is called. It causes
1402# an SetEdit call when the grid's state is 0.
1403#
1404
1405sub EditCell
1406 {
1407 my ($w, $x, $y) = @_;
1408 my $list = $w->privateData()->{'list'};
1409 if ($w->GetState == 0)
1410 {
1411 $w->SetEdit($x, $y); # xxx really correct ? once 2, once 4 args?
1412 }
1413 else
1414 {
1415 push(@$list, [ $w, 'SetEdit', $x, $y]);
1416 }
1417 }
1418#proc tixGrid:EditCell {w x y} {
1419# set list $w:_list
1420# global $list
1421#
1422# case [tixGrid:GetState $w] {
1423# {0} {
1424# tixGrid:SetEdit $w [list $x $y]
1425# }
1426# default {
1427# lappend $list [list tixGrid:SetEdit $w [list $x $y]]
1428# }
1429# }
1430#}
1431
1432
1433# tixGrid:EditApply --
1434#
1435# This command is called when "$w edit apply $x $y" is called. It causes
1436# an CheckEdit call when the grid's state is 0.
1437#
1438
1439sub EditApply
1440 {
1441 my ($w) = @_;
1442 my $list = $w->privateData()->{'list'};
1443 if ($w->GetState eq 0)
1444 {
1445 $w->CheckEdit; # xxx really correct ? once 2, once 4 args?
1446 }
1447 else
1448 {
1449 push(@$list, $w->CheckEdit);
1450 }
1451 }
1452#proc tixGrid:EditApply {w} {
1453# set list $w:_list
1454# global $list
1455#
1456# case [tixGrid:GetState $w] {
1457# {0} {
1458# tixGrid:CheckEdit $w
1459# }
1460# default {
1461# lappend $list [list tixGrid:CheckEdit $w]
1462# }
1463# }
1464#}
1465
1466# tixGrid:CheckEdit --
1467#
1468# This procedure is called when the user sets the focus on a cell.
1469# If another cell is being edited, apply the changes of that cell.
1470#
1471
1472sub CheckEdit
1473 {
1474 my ($w) = @_;
1475 my $edit = $w->privateData->{editentry};
1476 if (Tk::Exists($edit))
1477 {
1478 # If it -command is not empty, it is being used for another cell.
1479 # Invoke it so that the other cell can be updated.
1480 #
1481 if (defined $edit->cget('-command'))
1482 {
1483 $edit->invoke; # xxx no args??
1484 }
1485 }
1486 }
1487
1488sub SetFocus
1489 {
1490 my ($w) = @_;
1491 if ($w->cget('-takefocus'))
1492 {
1493$w->focus;
1494# # xxx translation of if ![string match $w.* [focus -displayof $w]] {
1495# my $hasfocus = $w->focus(-displayof => $w)->pathname;
1496# my $pathname = $w->pathname;
1497# if ($hasfocus =~ /\Q$pathname\E.*/)
1498# {
1499# $w->focus
1500# }
1501 }
1502 }
1503
1504
1505# tixGrid:SetEdit --
1506#
1507# Puts a floatentry on top of an editable entry.
1508#
1509
1510sub SetEdit
1511 {
1512 my ($w, $px, $py) = @_;
1513
1514 $w->CheckEdit;
1515
1516 my $efc = $w->cget('-editnotifycmd');
1517 return unless ( defined($efc) && length($efc) );
1518
1519 unless ($w->Callback('-editnotifycmd' => $px, $py))
1520 {
1521 print STDERR "editnotifycmd not defined or returned false\n";
1522 return;
1523 }
1524
1525 my $oldvalue;
1526 if ($w->info('exists', $px, $py))
1527 {
1528 # if entry doesn't support -text option. Can't edit it.
1529 #
1530 # If the application wants to force editing of an entry, it could
1531 # delete or replace the entry in the editnotifyCmd procedure.
1532 #
1533 Tk::catch { $oldvalue = $w->entrycget($px, $py, '-text'); };
1534 if ($@)
1535 {
1536 return;
1537 }
1538 }
1539 else
1540 {
1541 $oldvalue = '';
1542 }
1543
1544 my @bbox = $w->info('bbox', $px, $py);
1545
1546 my $edit = $w->privateData()->{__EDIT__};
1547 unless (Tk::Exists($edit))
1548 {
1549 require Tk::FloatEntry;
1550 $edit = $w->FloatEntry();
1551 $w->privateData()->{__EDIT__} = $edit;
1552 }
1553 $edit->configure(-command=>[\&DoneEdit, $w, $px, $py]);
1554 $edit->post(@bbox);
1555 $edit->configure(-value=>$oldvalue);
1556}
1557
1558
1559sub DoneEdit
1560 {
1561 my ($w, $x, $y, @args) = @_;
1562
1563 my $edit = $w->privateData()->{__EDIT__};
1564 $edit->configure(-command=>undef);
1565 $edit->unpost;
1566
1567 # FIX xxx
1568 # set value [tixEvent value]
1569 my $value = $edit->get;
1570 if ($w->info('exists', $x, $y))
1571 {
1572 Tk::catch { $w->entryconfigure($x, $y, -text=>$value) };
1573 if ($@)
1574 {
1575 return
1576 }
1577 }
1578 elsif ( length($value) )
1579 {
1580 # This needs to be catch'ed because the default itemtype may
1581 # not support the -text option
1582 #
1583 Tk::catch { $w->set($x,$y,-text $value); };
1584 if ($@)
1585 {
1586 return;
1587 }
1588 }
1589 else
1590 {
1591 return;
1592 }
1593 $w->Callback('-editdonecmd' => $x, $y);
1594 }
1595
15961;
1597__END__
Full OpenSPARC design & verification tarball including full HDL.