File Coverage

blib/lib/Tk/GridColumns.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1             package Tk::GridColumns;
2              
3 1     1   13778 use strict;
  1         2  
  1         34  
4 1     1   6 use warnings;
  1         1  
  1         32  
5 1     1   5 use base qw( Tk::Pane );
  1         14  
  1         1869  
6             use vars qw( $VERSION );
7             use Tk;
8              
9             $VERSION = '0.15';
10              
11             Tk::Widget->Construct( 'GridColumns' );
12              
13             sub ClassInit {
14             my( $class, $mw ) = @_;
15            
16             $class->SUPER::ClassInit( $mw );
17             } # ClassInit
18              
19             sub Populate {
20             my( $self, $args ) = @_;
21              
22             $self->{'_gridded'} = [0,0]; # number of rows/cols grid()ed
23             $self->{'_selected'} = [];
24             $self->{'_select_mode'} = delete $args->{-selectmode} || 'single row';
25             $self->{'_data'} = delete $args->{-data} || [];
26             $self->{'_columns'} = delete $args->{-columns} || [];
27             $self->{'_col_attr'} = delete $args->{-colattr} || {};
28             $self->{'_col_grid'} = delete $args->{-colgrid} || {};
29             $self->{'_item_attr'} = delete $args->{-itemattr} || {};
30             $self->{'_item_grid'} = delete $args->{-itemgrid} || {};
31             $self->{'_item_draw_cmd'} = delete $args->{-item_draw_cmd} || \&_item_draw_cmd;
32             $self->{'_select_cmd'} = delete $args->{-select_cmd} || \&_select_cmd;
33             $self->{'_deselect_cmd'} = delete $args->{-deselect_cmd} || \&_deselect_cmd;
34             $self->{'_item_bindings'} = {
35             '' => \&_button_press,
36             '' => \&_ctrl_button_press,
37             '' => \&_shift_button_press,
38             #TODO: move with the arrow keys
39             %{ delete $args->{-item_bindings} || {} },
40             };
41            
42             $args->{'-gridded'} = 'xy';
43             $args->{'-sticky'} = 'nsew';
44             $args->{'-takefocus'} = 1;
45             $self->SUPER::Populate( $args );
46            
47             $self->ConfigSpecs(
48             -selectmode => ['METHOD'],
49             -data => ['METHOD'],
50             -columns => ['METHOD'],
51             -colattr => ['METHOD'],
52             -colgrid => ['METHOD'],
53             -itemattr => ['METHOD'],
54             -itemgrid => ['METHOD'],
55             -item_bindings => ['METHOD'],
56             -item_draw_cmd => ['METHOD'],
57             -select_cmd => ['METHOD'],
58             -deselect_cmd => ['METHOD'],
59             'DEFAULT' => ['SELF'],
60             );
61            
62             $self->refresh;
63              
64             return $self;
65             } # Populate
66              
67             sub _button_press {
68             my( $self, $w, $row, $col ) = @_;
69              
70             $w->focus;
71            
72             my @mode = $self->selectmode;
73             return if $mode[0] eq 'none';
74            
75             $self->clear_selection;
76            
77             if ( $mode[1] eq 'row' ) {
78             $self->select( $row, $_ ) for 0 .. $#{ $self->columns };
79             } # if
80             else {
81             $self->select( $row, $col );
82             } # else
83             } # _button_press
84              
85             sub _ctrl_button_press {
86             my( $self, $w, $row, $col ) = @_;
87              
88             $w->focus;
89              
90             my @mode = $self->selectmode;
91             return if $mode[0] eq 'none';
92            
93             my $method = $self->selected->[$row]->[$col] ? 'deselect' : 'select';
94              
95             $self->clear_selection if $mode[0] eq 'single';
96              
97             if ( $mode[1] eq 'row' ) {
98             $self->$method( $row, $_ ) for 0 .. $#{ $self->columns };
99             } # if
100             else {
101             $self->$method( $row, $col );
102             } # else
103             } # _ctrl_button_press
104              
105             sub _shift_button_press {
106             my( $self, $w, $row, $col ) = @_;
107              
108             $w->focus;
109              
110             my @mode = $self->selectmode;
111             return if $mode[0] eq 'none';
112            
113             my @cur_sel = @{ $self->curselection };
114            
115             if ( $mode[0] eq 'single' or ! @cur_sel ) {
116             $self->item_bindings->{''}->(@_);
117             } # if
118             else {
119             my $fst_sel = $cur_sel[ 0]->[0];
120             my $lst_sel = $cur_sel[-1]->[0];
121            
122             my $orient = $row < $fst_sel ? $fst_sel
123             : $row > $lst_sel ? $lst_sel : -1;
124            
125             if ( $orient != -1 ) {
126             for my $y ( $row > $orient ? ( $orient+1 .. $row ) : ( $row .. $orient-1 ) ) {
127             for my $x ( $mode[1] eq 'row' ? ( 0 .. $#{ $self->columns } ) : $col ) {
128             $self->select( $y, $x );
129             } # for
130             } # for
131             } # if
132             else {
133             $orient = abs($row - $lst_sel) > abs($row - $fst_sel) ? $fst_sel : $lst_sel;
134            
135             for my $y ( $row > $orient ? ( $orient .. $row ) : ( $row .. $orient ) ) {
136             for my $x ( $mode[1] eq 'row' ? ( 0 .. $#{ $self->columns } ) : $col ) {
137             $self->deselect( $y, $x );
138             } # for
139             } # for
140             } # else
141             } # else
142             } # _shift_button_press
143              
144             sub _item_draw_cmd {
145             my( $self, $text, $attr, $row, $col ) = @_;
146            
147             my $w = $self->Label( -bg => $self->cget(-bg) );
148             $w->configure( %$attr );
149             $w->configure( -text => $text );
150            
151             return $w;
152             } # _item_draw_cmd
153              
154             sub _select_cmd {
155             my( $self, $w, $row, $col ) = @_;
156            
157             $w->configure(
158             -background => 'blue',
159             -foreground => 'white',
160             );
161             } # _select_cmd
162              
163             sub _deselect_cmd {
164             my( $self, $w, $row, $col ) = @_;
165            
166             $w->configure(
167             -background => $self->cget(-background),
168             -foreground => 'black',
169             );
170             $w->configure( %{ $self->itemattr } );
171             } # _deselect_cmd
172              
173             sub selectmode {
174             my( $self, $value ) = @_;
175            
176             if ( @_ > 1 ) {
177             $self->{'_select_mode'} = $value;
178             return $self;
179             } # if
180            
181             return wantarray ? split( ' ', $self->{'_select_mode'} )
182             : $self->{'_select_mode'};
183             } # selectmode
184              
185             sub data {
186             my( $self, $value ) = @_;
187            
188             if ( @_ > 1 ) {
189             $self->{'_data'} = $value;
190             return $self;
191             } # if
192            
193             return $self->{'_data'};
194             } # data
195              
196             sub columns {
197             my( $self, $value ) = @_;
198            
199             if ( @_ > 1 ) {
200             $self->{'_columns'} = $value;
201             return $self;
202             } # if
203            
204             return $self->{'_columns'};
205             } # columns
206              
207             sub colattr {
208             my( $self, $value ) = @_;
209            
210             if ( @_ > 1 ) {
211             $self->{'_col_attr'} = $value;
212             return $self;
213             } # if
214            
215             return $self->{'_col_attr'};
216             } # colattr
217              
218             sub colgrid {
219             my( $self, $value ) = @_;
220            
221             if ( @_ > 1 ) {
222             $self->{'_col_grid'} = $value;
223             return $self;
224             } # if
225            
226             return $self->{'_col_grid'};
227             } # colgrid
228              
229             sub itemattr {
230             my( $self, $value ) = @_;
231            
232             if ( @_ > 1 ) {
233             $self->{'_item_attr'} = $value;
234             return $self;
235             } # if
236            
237             return $self->{'_item_attr'};
238             } # itemattr
239              
240             sub itemgrid {
241             my( $self, $value ) = @_;
242            
243             if ( @_ > 1 ) {
244             $self->{'_item_grid'} = $value;
245             return $self;
246             } # if
247            
248             return $self->{'_item_grid'};
249             } # itemgrid
250              
251             sub selected {
252             my( $self, $value ) = @_;
253            
254             if ( @_ > 1 ) {
255             $self->{'_selected'} = $value;
256             return $self;
257             } # if
258            
259             return $self->{'_selected'};
260             } # selected
261              
262             sub item_draw_cmd {
263             my( $self, $value ) = @_;
264            
265             if ( @_ > 1 ) {
266             $self->{'_item_draw_cmd'} = $value;
267             return $self;
268             } # if
269            
270             return $self->{'_item_draw_cmd'};
271             } # item_draw_cmd
272              
273             sub select_cmd {
274             my( $self, $value ) = @_;
275            
276             if ( @_ > 1 ) {
277             $self->{'_select_cmd'} = $value;
278             return $self;
279             } # if
280            
281             return $self->{'_select_cmd'};
282             } # select_cmd
283              
284             sub deselect_cmd {
285             my( $self, $value ) = @_;
286            
287             if ( @_ > 1 ) {
288             $self->{'_deselect_cmd'} = $value;
289             return $self;
290             } # if
291            
292             return $self->{'_deselect_cmd'};
293             } # deselect_cmd
294              
295             sub item_bindings {
296             my( $self, $value ) = @_;
297            
298             if ( @_ > 1 ) {
299             $self->{'_item_bindings'} = $value;
300             return $self;
301             } # if
302            
303             return $self->{'_item_bindings'};
304             } # item_bindings
305              
306             sub select {
307             my( $self, $row, $col ) = @_;
308            
309             $self->{'_selected'}->[$row]->[$col] = 1;
310             $self->{'_select_cmd'}->( $self, $self->gridSlaves(-row=>$row+1,-column=>$col), $row, $col );
311            
312             return $self;
313             } # select
314              
315             sub deselect {
316             my( $self, $row, $col ) = @_;
317            
318             $self->{'_selected'}->[$row]->[$col] = 0;
319             $self->{'_deselect_cmd'}->( $self, $self->gridSlaves(-row=>$row+1,-column=>$col), $row, $col );
320            
321             return $self;
322             } # deselect
323              
324             sub curselection {
325             my( $self ) = @_;
326            
327             my @selection;
328            
329             for my $row ( 0 .. $#{ $self->{'_data'} } ) {
330             for my $col ( 0 .. $#{ $self->{'_data'}->[$row] } ) {
331             push @selection, [ $row, $col ] if $self->{'_selected'}->[$row]->[$col];
332             } # for
333             } # for
334            
335             splice( @{ $self->{'_selected'} }, 1 + $#{ $self->{'_data'} } );
336            
337             #MAYBE: return different things depending on the -selectmode
338             return \@selection;
339             } # curselection
340              
341             sub clear_selection {
342             my( $self ) = @_;
343            
344             $self->deselect( @$_ ) for @{ $self->curselection };
345            
346             return $self;
347             } # clear_selection
348              
349             sub refresh_selection {
350             my( $self ) = @_;
351            
352             $self->select( @$_ ) for @{ $self->curselection };
353            
354             return $self;
355             } # refresh_selection
356              
357             sub add_column {
358             my( $self, %attr ) = @_;
359            
360             push @{ $self->{'_columns'} }, \%attr;
361            
362             return $self;
363             } # add_column
364              
365             sub add_row {
366             my( $self, @row ) = @_;
367            
368             push @{ $self->{'_data'} }, \@row;
369            
370             return $self;
371             } # add_row
372              
373             sub sort_col {
374             my( $self, $col, $sort, $rev ) = @_;
375            
376             my @sorted = sort {
377             $sort->(
378             $rev ? ( $self->{'_data'}->[$b]->[$col],
379             $self->{'_data'}->[$a]->[$col], )
380             : ( $self->{'_data'}->[$a]->[$col],
381             $self->{'_data'}->[$b]->[$col], )
382             );
383             } 0 .. $#{ $self->{'_data'} };
384            
385             @{ $self->{'_data'} } = map { $self->{'_data'}->[$_] } @sorted;
386             @{ $self->{'_selected'} } = map { $self->{'_selected'}->[$_] } @sorted;
387            
388             return $self;
389             } # sort_col
390              
391             sub sort_cmd {
392             my( $self, $col, $sort ) = @_;
393            
394             my $rev = 0;
395             return sub {
396             $self->sort_col(
397             $col,
398             ref $sort ? $sort
399             : $sort eq 'num' ? sub { $_[0] <=> $_[1] }
400             : sub { lc($_[0]) cmp lc($_[1]) },
401             $rev,
402             )->refresh_items;
403            
404             $rev = !$rev;
405             };
406             } # sort_cmd
407              
408             sub draw_header {
409             my( $self ) = @_;
410            
411             $self->{'_gridded'}->[1] = $#{ $self->{'_columns'} };
412            
413             my @weight = map {
414             exists $self->{'_columns'}->[$_]->{'-weight'}
415             ? [ $_, delete $self->{'_columns'}->[$_]->{'-weight'} ]
416             : ()
417             } 0 .. $#{ $self->{'_columns'} };
418            
419             for my $col ( 0 .. $#{ $self->{'_columns'} } ) {
420             my $w = $self->Button( %{ $self->{'_col_attr'} } )->grid(
421             %{ $self->{'_col_grid'} },
422             -row => 0,
423             -column => $col,
424             -sticky => 'ew',
425             );
426             $w->configure( %{ $self->{'_columns'}->[$col] } );
427             } # for
428            
429             for my $w ( @weight ) {
430             $self->gridColumnconfigure( $w->[0], -weight => $w->[1] );
431             $self->{'_columns'}->[$w->[0]]->{-weight} = $w->[1];
432             } # for
433            
434             return $self;
435             } # draw_header
436              
437             sub draw_items {
438             my( $self ) = @_;
439            
440             $self->{'_gridded'}->[0] = @{ $self->{'_data'} };
441            
442             for my $row ( 0 .. $#{ $self->{'_data'} } ) {
443             for my $col ( 0 .. $#{ $self->{'_columns'} } ) {
444             my $w = $self->{'_item_draw_cmd'}->(
445             $self,
446             $self->{'_data'}->[$row]->[$col],
447             $self->{'_item_attr'},
448             $row, $col,
449             )->grid(
450             %{ $self->{'_item_grid'} },
451             -row => $row+1,
452             -column => $col,
453             -sticky => 'nsew',
454             );
455            
456             for my $seq ( keys %{ $self->{'_item_bindings'} } ) {
457             $w->bind( $seq, sub { $self->{'_item_bindings'}->{$seq}->( $self, $w, $row, $col ) } );
458             } # for
459             } # for
460             } # for
461            
462             return $self;
463             } # draw_items
464              
465             sub set_filler {
466             my( $self ) = @_;
467            
468             $self->gridRowconfigure( 1 + $self->{'_gridded'}->[0], -weight => 1 );
469            
470             return $self;
471             } # set_filler
472              
473             sub remove_filler {
474             my( $self ) = @_;
475              
476             $self->gridRowconfigure( 1 + $self->{'_gridded'}->[0], -weight => 0 );
477            
478             return $self;
479             } # remove_filler
480              
481             sub destroy_all {
482             my( $self ) = @_;
483              
484             $_->destroy for $self->gridSlaves;
485             $self->remove_filler;
486             $self->gridColumnconfigure( $_, -weight => 0 ) for 0 .. $self->{'_gridded'}->[1];
487            
488             return $self;
489             } # destroy_all
490              
491             sub refresh {
492             my( $self ) = @_;
493              
494             $self->destroy_all->draw_header->draw_items->set_filler->refresh_selection;
495            
496             return $self;
497             } # refresh
498              
499             sub refresh_header {
500             my( $self ) = @_;
501            
502             $_->destroy for $self->gridSlaves( -row => 0 );
503             $self->gridColumnconfigure( $_, -weight => 0 ) for 0 .. $self->{'_gridded'}->[1];
504             $self->draw_header;
505            
506             return $self;
507             } # refresh_header
508              
509             sub refresh_items {
510             my( $self ) = @_;
511            
512             for my $row ( 1 .. $self->{'_gridded'}->[0] ) {
513             $_->destroy for $self->gridSlaves( -row => $row );
514             } # for
515             $self->remove_filler->draw_items->set_filler->refresh_selection;
516            
517             return $self;
518             } # refresh_items
519              
520             1;
521              
522             #TODO: select() and deselect() that react on the -selectmode
523             #TODO: delete_row()
524             #TODO: select_row(), select_col() and the deselect() ones
525             #TODO: refresh_row(), refresh_col()
526             #TODO: ROText example
527             #TODO: easier code for the _button_press() and so on...
528              
529             __END__