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__ |