Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved. |
2 | # This program is free software; you can redistribute it and/or | |
3 | # modify it under the same terms as Perl itself. | |
4 | package Tk::Table; | |
5 | use strict; | |
6 | ||
7 | use vars qw($VERSION); | |
8 | $VERSION = '3.020'; # $Id: //depot/Tk8/Tk/Table.pm#20 $ | |
9 | ||
10 | use Tk::Pretty; | |
11 | use AutoLoader; | |
12 | use base qw(Tk::Frame); | |
13 | ||
14 | Construct Tk::Widget 'Table'; | |
15 | ||
16 | sub ClassInit | |
17 | { | |
18 | my ($class,$mw) = @_; | |
19 | $mw->bind($class,'<Configure>',['QueueLayout',8]); | |
20 | $mw->bind($class,'<FocusIn>', 'NoOp'); | |
21 | $mw->XYscrollBind($class); | |
22 | return $class; | |
23 | } | |
24 | ||
25 | sub _view | |
26 | { | |
27 | my ($t,$s,$page,$a,$op,$num,$type) = @_; | |
28 | if ($op eq 'moveto') | |
29 | { | |
30 | $$s = int(@$a*$num); | |
31 | } | |
32 | else | |
33 | { | |
34 | $num *= ($page/2) if ($type eq 'pages'); | |
35 | $$s += $num; | |
36 | } | |
37 | $$s = 0 if ($$s < 0); | |
38 | $t->QueueLayout(4); | |
39 | } | |
40 | ||
41 | sub xview | |
42 | { | |
43 | my $t = shift; | |
44 | $t->_view(\$t->{Left},$t->cget('-columns'),$t->{Width},@_); | |
45 | } | |
46 | ||
47 | sub yview | |
48 | { | |
49 | my $t = shift; | |
50 | $t->_view(\$t->{Top},$t->cget('-rows'),$t->{Height},@_); | |
51 | } | |
52 | ||
53 | sub FocusChildren | |
54 | { | |
55 | my $t = shift; | |
56 | return () if ($t->cget('-takefocus')); | |
57 | return $t->SUPER::FocusChildren; | |
58 | } | |
59 | ||
60 | sub Populate | |
61 | { | |
62 | my ($t,$args) = @_; | |
63 | $t->SUPER::Populate($args); | |
64 | $t->ConfigSpecs('-scrollbars' => [METHOD => 'scrollbars','Scrollbars','nw'], | |
65 | '-takefocus' => [SELF => 'takeFocus','TakeFocus',1], | |
66 | '-rows' => [METHOD => 'rows','Rows',10], | |
67 | '-fixedrows' => [METHOD => 'fixedRows','FixedRows',0], | |
68 | '-columns' => [METHOD => 'columns','Columns',10], | |
69 | '-fixedcolumns' => [METHOD => 'fixedColumn','FixedColumns',0], | |
70 | '-highlightthickness' => [SELF => 'highlightThickness','HighlightThickness',2] | |
71 | ); | |
72 | $t->{'Width'} = []; | |
73 | $t->{'Height'} = []; | |
74 | $t->{'Row'} = []; | |
75 | $t->{'Slave'} = {}; | |
76 | $t->{'Top'} = 0; | |
77 | $t->{'Left'} = 0; | |
78 | $t->{'Bottom'} = 0; | |
79 | $t->{'Right'} = 0; | |
80 | $t->{LayoutPending} = 0; | |
81 | } | |
82 | ||
83 | sub sizeN | |
84 | { | |
85 | my ($n,$a) = @_; | |
86 | my $max = 0; | |
87 | my $i = 0; | |
88 | my $sum = 0; | |
89 | while ($i < @$a && $i < $n) | |
90 | { | |
91 | my $n = $a->[$i++]; | |
92 | $a->[$i-1] = $n = 0 unless (defined $n); | |
93 | $sum += $n; | |
94 | } | |
95 | $max = $sum if ($sum > $max); | |
96 | while ($i < @$a) | |
97 | { | |
98 | $sum = $sum-$a->[$i-$n]+$a->[$i]; | |
99 | $max = $sum if ($sum > $max); | |
100 | $i++; | |
101 | } | |
102 | return $max; | |
103 | } | |
104 | ||
105 | sub total | |
106 | { | |
107 | my ($a) = @_; | |
108 | my $total = 0; | |
109 | my $x; | |
110 | foreach $x (@{$a}) | |
111 | { | |
112 | $total += $x; | |
113 | } | |
114 | return $total; | |
115 | } | |
116 | ||
117 | sub constrain | |
118 | { | |
119 | my ($sb,$a,$pixels,$fixed) = @_; | |
120 | my $n = $$sb+$fixed; | |
121 | my $total = 0; | |
122 | my $i; | |
123 | $n = @$a if ($n > @$a); | |
124 | $n = $fixed if ($n < $fixed); | |
125 | for ($i= 0; $i < $fixed; $i++) | |
126 | { | |
127 | (defined($a->[$i])) && ($total += $a->[$i]); | |
128 | } | |
129 | for ($i=$n; $total < $pixels && $i < @$a; $i++) | |
130 | { | |
131 | $total += $a->[$i]; | |
132 | } | |
133 | while ($n > $fixed) | |
134 | { | |
135 | if (($total += $a->[--$n]) > $pixels) | |
136 | { | |
137 | $n++; | |
138 | last; | |
139 | } | |
140 | } | |
141 | $$sb = $n-$fixed; | |
142 | } | |
143 | ||
144 | sub Layout | |
145 | { | |
146 | my ($t) = @_; | |
147 | return unless Tk::Exists($t); | |
148 | my $rows = @{$t->{Row}}; | |
149 | my $bw = $t->cget(-highlightthickness); | |
150 | my $frows = $t->cget(-fixedrows); | |
151 | my $fcols = $t->cget(-fixedcolumns); | |
152 | my $sb = $t->cget(-scrollbars); | |
153 | my $H = $t->Height; | |
154 | my $W = $t->Width; | |
155 | my $tadj = $bw; | |
156 | my $badj = $bw; | |
157 | my $ladj = $bw; | |
158 | my $radj = $bw; | |
159 | my @xs = ($W,0,0,0); | |
160 | my @ys = (0,$H,0,0); | |
161 | my $xsb; | |
162 | my $ysb; | |
163 | ||
164 | my $why = $t->{LayoutPending}; | |
165 | $t->{LayoutPending} = 0; | |
166 | ||
167 | if ($sb =~ /^[ns]/) | |
168 | { | |
169 | $t->{xsb} = $t->Scrollbar(-orient => 'horizontal', -command => ['xview' => $t]) unless (defined $t->{xsb}); | |
170 | $xsb = $t->{xsb}; | |
171 | $xs[3] = $xsb->ReqHeight; | |
172 | if ($sb =~ /^n/) | |
173 | { | |
174 | $xs[1] = $tadj; | |
175 | $tadj += $xs[3]; | |
176 | } | |
177 | else | |
178 | { | |
179 | $badj += $xs[3]; | |
180 | $xs[1] = $H-$badj; | |
181 | } | |
182 | } | |
183 | else | |
184 | { | |
185 | $t->{xsb}->UnmapWindow if (defined $t->{xsb}); | |
186 | } | |
187 | ||
188 | if ($sb =~ /[ew]$/) | |
189 | { | |
190 | $t->{ysb} = $t->Scrollbar(-orient => 'vertical', -command => ['yview' => $t]) unless (defined $t->{ysb}); | |
191 | $ysb = $t->{ysb}; | |
192 | $ys[2] = $ysb->ReqWidth; | |
193 | if ($sb =~ /w$/) | |
194 | { | |
195 | $ys[0] = $ladj; | |
196 | $ladj += $ys[2]; | |
197 | } | |
198 | else | |
199 | { | |
200 | $radj += $ys[2]; | |
201 | $ys[0] = $W-$radj; | |
202 | } | |
203 | } | |
204 | else | |
205 | { | |
206 | $t->{ysb}->UnmapWindow if (defined $t->{ysb}); | |
207 | } | |
208 | ||
209 | constrain(\$t->{Top}, $t->{Height},$H-($tadj+$badj),$frows); | |
210 | constrain(\$t->{Left},$t->{Width}, $W-($ladj+$radj),$fcols); | |
211 | ||
212 | my $top = $t->{Top}+$frows; | |
213 | my $left = $t->{Left}+$fcols; | |
214 | ||
215 | if ($why & 49) | |
216 | { | |
217 | # Width and/or Height of element or | |
218 | # number of rows and/or columns or | |
219 | # scrollbar presence has changed | |
220 | my $w = sizeN($t->cget('-columns'),$t->{Width})+$radj+$ladj; | |
221 | my $h = sizeN($t->cget('-rows'),$t->{Height})+$tadj+$badj; | |
222 | $t->GeometryRequest($w,$h); | |
223 | } | |
224 | ||
225 | if ($rows) | |
226 | { | |
227 | my $cols = @{$t->{Width}}; | |
228 | my $yhwm = $top-$frows; | |
229 | my $xhwm = $left-$fcols; | |
230 | my $y = $tadj; | |
231 | my $r; | |
232 | for ($r = 0; $r < $rows; $r++) | |
233 | { | |
234 | my $h = $t->{Height}[$r]; | |
235 | if (($r < $top && $r >= $frows) || ($y+$h > $H-$badj)) | |
236 | { | |
237 | if (defined $t->{Row}[$r]) | |
238 | { | |
239 | my $c; | |
240 | for ($c = 0; $c < @{$t->{Row}[$r]}; $c++) | |
241 | { | |
242 | my $s = $t->{Row}[$r][$c]; | |
243 | if (defined $s) | |
244 | { | |
245 | $s->UnmapWindow; | |
246 | if ($why & 1) | |
247 | { | |
248 | my $w = $t->{Width}[$c]; | |
249 | $s->ResizeWindow($w,$h); | |
250 | } | |
251 | } | |
252 | } | |
253 | } | |
254 | } | |
255 | else | |
256 | { | |
257 | my $hwm = $left-$fcols; | |
258 | my $sh = 0; | |
259 | my $x = $ladj; | |
260 | my $c; | |
261 | $ys[1] = $y if ($y < $ys[1] && $r >= $frows); | |
262 | for ($c = 0; $c <$cols; $c++) | |
263 | { | |
264 | my $s = $t->{Row}[$r][$c]; | |
265 | my $w = $t->{Width}[$c]; | |
266 | if (($c < $left && $c >= $fcols) || ($x+$w > $W-$radj) ) | |
267 | { | |
268 | if (defined $s) | |
269 | { | |
270 | $s->UnmapWindow; | |
271 | $s->ResizeWindow($w,$h) if ($why & 1); | |
272 | } | |
273 | } | |
274 | else | |
275 | { | |
276 | $xs[0] = $x if ($x < $xs[0] && $c >= $fcols); | |
277 | if (defined $s) | |
278 | { | |
279 | if ($why & 1) | |
280 | { | |
281 | $s->MoveResizeWindow($x,$y,$w,$h); | |
282 | } | |
283 | else | |
284 | { | |
285 | $s->MoveWindow($x,$y); | |
286 | } | |
287 | $s->MapWindow; | |
288 | } | |
289 | $x += $w; | |
290 | if ($c >= $fcols) | |
291 | { | |
292 | $hwm++; | |
293 | $sh += $w | |
294 | } | |
295 | } | |
296 | } | |
297 | $xhwm = $hwm if ($hwm > $xhwm); | |
298 | $xs[2] = $sh if ($sh > $xs[2]); | |
299 | $y += $h; | |
300 | if ($r >= $frows) | |
301 | { | |
302 | $ys[3] += $h; | |
303 | $yhwm++; | |
304 | } | |
305 | } | |
306 | } | |
307 | $t->{Bottom} = $yhwm; | |
308 | $t->{Right} = $xhwm; | |
309 | if (defined $xsb && $xs[2] > 0) | |
310 | { | |
311 | $xsb->MoveResizeWindow(@xs); | |
312 | $cols -= $fcols; | |
313 | if ($cols > 0) | |
314 | { | |
315 | $xsb->set($t->{Left}/$cols,$t->{Right}/$cols); | |
316 | $xsb->MapWindow; | |
317 | } | |
318 | } | |
319 | if (defined $ysb && $ys[3] > 0) | |
320 | { | |
321 | $ysb->MoveResizeWindow(@ys); | |
322 | $rows -= $frows; | |
323 | if ($rows > 0) | |
324 | { | |
325 | $ysb->set($t->{Top}/$rows,$t->{Bottom}/$rows); | |
326 | $ysb->MapWindow; | |
327 | } | |
328 | } | |
329 | } | |
330 | } | |
331 | ||
332 | sub QueueLayout | |
333 | { | |
334 | my ($m,$why) = @_; | |
335 | $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending}); | |
336 | $m->{LayoutPending} |= $why; | |
337 | } | |
338 | ||
339 | sub SlaveGeometryRequest | |
340 | { | |
341 | my ($m,$s) = @_; | |
342 | my ($row,$col) = @{$m->{Slave}{$s->PathName}}; | |
343 | my $sw = $s->ReqWidth; | |
344 | my $sh = $s->ReqHeight; | |
345 | my $sz = 0; | |
346 | if ($sw > $m->{Width}[$col]) | |
347 | { | |
348 | $m->{Width}[$col] = $sw; | |
349 | $m->QueueLayout(1); | |
350 | $sz++; | |
351 | } | |
352 | if ($sh > $m->{Height}[$row]) | |
353 | { | |
354 | $m->{Height}[$row] = $sh; | |
355 | $m->QueueLayout(1); | |
356 | $sz++; | |
357 | } | |
358 | if (!$sz) | |
359 | { | |
360 | $s->ResizeWindow($m->{Width}[$col],$m->{Height}[$row]); | |
361 | } | |
362 | } | |
363 | ||
364 | sub get | |
365 | { | |
366 | my ($t,$row,$col) = @_; | |
367 | return $t->{Row}[$row][$col]; | |
368 | } | |
369 | ||
370 | sub LostSlave | |
371 | { | |
372 | my ($t,$s) = @_; | |
373 | my $info = delete $t->{Slave}{$s->PathName}; | |
374 | if (defined $info) | |
375 | { | |
376 | my ($row,$col) = @$info; | |
377 | $t->{Row}[$row][$col] = undef; | |
378 | $s->UnmapWindow; | |
379 | } | |
380 | else | |
381 | { | |
382 | $t->BackTrace('Cannot find' . $s->PathName); | |
383 | } | |
384 | $t->QueueLayout(2); | |
385 | } | |
386 | ||
387 | sub put | |
388 | { | |
389 | my ($t,$row,$col,$w) = @_; | |
390 | $w = $t->Label(-text => $w) unless (ref $w); | |
391 | $t->ManageGeometry($w); | |
392 | unless (defined $t->{Row}[$row]) | |
393 | { | |
394 | $t->{Row}[$row] = []; | |
395 | $t->{Height}[$row] = 0; | |
396 | } | |
397 | unless (defined $t->{Width}[$col]) | |
398 | { | |
399 | $t->{Width}[$col] = 0; | |
400 | } | |
401 | my $old = $t->{Row}[$row][$col]; | |
402 | if (defined $old) | |
403 | { | |
404 | $old->UnmanageGeometry; | |
405 | $t->LostSlave($old); | |
406 | } | |
407 | $t->{Row}[$row][$col] = $w; | |
408 | $t->{Slave}{$w->PathName} = [$row,$col]; | |
409 | $t->SlaveGeometryRequest($w); | |
410 | $t->QueueLayout(2); | |
411 | return $old; | |
412 | } | |
413 | ||
414 | # | |
415 | # configure methods | |
416 | # | |
417 | ||
418 | sub scrollbars | |
419 | { | |
420 | my ($t,$v) = @_; | |
421 | if (@_ > 1) | |
422 | { | |
423 | $t->_configure(-scrollbars => $v); | |
424 | $t->QueueLayout(32); | |
425 | } | |
426 | return $t->_cget('-scrollbars'); | |
427 | } | |
428 | ||
429 | sub rows | |
430 | { | |
431 | my ($t,$r) = @_; | |
432 | if (@_ > 1) | |
433 | { | |
434 | $t->_configure(-rows => $r); | |
435 | $t->QueueLayout(16); | |
436 | } | |
437 | return $t->_cget('-rows'); | |
438 | } | |
439 | ||
440 | sub fixedrows | |
441 | { | |
442 | my ($t,$r) = @_; | |
443 | if (@_ > 1) | |
444 | { | |
445 | $t->_configure(-fixedrows => $r); | |
446 | $t->QueueLayout(16); | |
447 | } | |
448 | return $t->_cget('-fixedrows'); | |
449 | } | |
450 | ||
451 | sub columns | |
452 | { | |
453 | my ($t,$r) = @_; | |
454 | if (@_ > 1) | |
455 | { | |
456 | $t->_configure(-columns => $r); | |
457 | $t->QueueLayout(16); | |
458 | } | |
459 | return $t->_cget('-columns'); | |
460 | } | |
461 | ||
462 | sub fixedcolumns | |
463 | { | |
464 | my ($t,$r) = @_; | |
465 | if (@_ > 1) | |
466 | { | |
467 | $t->_configure(-fixedcolumns => $r); | |
468 | $t->QueueLayout(16); | |
469 | } | |
470 | return $t->_cget('-fixedcolumns'); | |
471 | } | |
472 | ||
473 | 1; | |
474 | __END__ | |
475 | sub Create | |
476 | { | |
477 | my $t = shift; | |
478 | my $r = shift; | |
479 | my $c = shift; | |
480 | my $kind = shift; | |
481 | $t->put($r,$c,$t->$kind(@_)); | |
482 | } | |
483 | ||
484 | sub totalColumns | |
485 | { | |
486 | scalar @{shift->{'Width'}}; | |
487 | } | |
488 | ||
489 | sub totalRows | |
490 | { | |
491 | scalar @{shift->{'Height'}}; | |
492 | } | |
493 | ||
494 | sub Posn | |
495 | { | |
496 | my ($t,$s) = @_; | |
497 | my $info = $t->{Slave}{$s->PathName}; | |
498 | return (wantarray) ? @$info : $info; | |
499 | } | |
500 | ||
501 | sub see | |
502 | { | |
503 | my $t = shift; | |
504 | my ($row,$col) = (@_ == 2) ? @_ : @{$t->{Slave}{$_[0]->PathName}}; | |
505 | my $see = 1; | |
506 | if (($row -= $t->cget('-fixedrows')) >= 0) | |
507 | { | |
508 | if ($row < $t->{Top}) | |
509 | { | |
510 | $t->{Top} = $row; | |
511 | $t->QueueLayout(4); | |
512 | $see = 0; | |
513 | } | |
514 | elsif ($row >= $t->{Bottom}) | |
515 | { | |
516 | $t->{Top} += ($row - $t->{Bottom}+1); | |
517 | $t->QueueLayout(4); | |
518 | $see = 0; | |
519 | } | |
520 | } | |
521 | if (($col -= $t->cget('-fixedcolumns')) >= 0) | |
522 | { | |
523 | if ($col < $t->{Left}) | |
524 | { | |
525 | $t->{Left} = $col; | |
526 | $t->QueueLayout(4); | |
527 | $see = 0; | |
528 | } | |
529 | elsif ($col >= $t->{Right}) | |
530 | { | |
531 | $t->{Left} += ($col - $t->{Right}+1); | |
532 | $t->QueueLayout(4); | |
533 | $see = 0; | |
534 | } | |
535 | } | |
536 | return $see; | |
537 | } | |
538 | ||
539 | =cut | |
540 |