diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Table.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/Table.pm | 597 |
1 files changed, 597 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Table.pm b/Master/tlpkg/tlperl/lib/Tk/Table.pm new file mode 100644 index 00000000000..2eae67fbd97 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Table.pm @@ -0,0 +1,597 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::Table; +use strict; + +use vars qw($VERSION); +$VERSION = '4.015'; # was: sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/; + +use AutoLoader; +use base qw(Tk::Frame); + +Construct Tk::Widget 'Table'; + +# Constants for QueueLayout flags +sub _SlaveSize () { 1 } # Slave has asked for change of width or height +sub _SlaveChange () { 2 } # We lost or gained a slave +sub _ViewChange () { 4 } # xview or yview called +sub _ConfigEvent () { 8 } # Table has changed size +sub _ScrollBars () { 32 } # Scrollabrs came or went +sub _RowColCount () { 16 } # rows or columns configured + + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<Configure>',['QueueLayout',_ConfigEvent]); + $mw->bind($class,'<FocusIn>', 'NoOp'); + $mw->XYscrollBind($class); + return $class; +} + +sub _view +{ + my ($t,$s,$page,$a,$op,$num,$type) = @_; + if ($op eq 'moveto') + { + $$s = int(@$a*$num); + } + else + { + $num *= ($page/2) if ($type eq 'pages'); + $$s += $num; + } + $$s = 0 if ($$s < 0); + $t->QueueLayout(_ViewChange); +} + +sub xview +{ + my $t = shift; + $t->_view(\$t->{Left},$t->cget('-columns'),$t->{Width},@_); +} + +sub yview +{ + my $t = shift; + $t->_view(\$t->{Top},$t->cget('-rows'),$t->{Height},@_); +} + +sub FocusChildren +{ + my $t = shift; + return () if ($t->cget('-takefocus')); + return $t->SUPER::FocusChildren; +} + +sub Populate +{ + my ($t,$args) = @_; + $t->SUPER::Populate($args); + $t->ConfigSpecs('-scrollbars' => [METHOD => 'scrollbars','Scrollbars','nw'], + '-takefocus' => [SELF => 'takeFocus','TakeFocus',1], + '-rows' => [METHOD => 'rows','Rows',10], + '-fixedrows' => [METHOD => 'fixedRows','FixedRows',0], + '-columns' => [METHOD => 'columns','Columns',10], + '-fixedcolumns' => [METHOD => 'fixedColumn','FixedColumns',0], + '-highlightthickness' => [SELF => 'highlightThickness','HighlightThickness',2] + ); + $t->_init; +} + +sub sizeN +{ + my ($n,$a) = @_; + my $max = 0; + my $i = 0; + my $sum = 0; + while ($i < @$a && $i < $n) + { + my $n = $a->[$i++]; + $a->[$i-1] = $n = 0 unless (defined $n); + $sum += $n; + } + $max = $sum if ($sum > $max); + while ($i < @$a) + { + $sum = $sum-$a->[$i-$n]+$a->[$i]; + $max = $sum if ($sum > $max); + $i++; + } + return $max; +} + +sub total +{ + my ($a) = @_; + my $total = 0; + my $x; + foreach $x (@{$a}) + { + $total += $x; + } + return $total; +} + +sub constrain +{ + my ($sb,$a,$pixels,$fixed) = @_; + my $n = $$sb+$fixed; + my $total = 0; + my $i; + $n = @$a if ($n > @$a); + $n = $fixed if ($n < $fixed); + for ($i= 0; $i < $fixed; $i++) + { + (defined($a->[$i])) && ($total += $a->[$i]); + } + for ($i=$n; $total < $pixels && $i < @$a; $i++) + { + $a->[$i] ||= 0; + $total += $a->[$i]; + } + while ($n > $fixed) + { + if (($total += $a->[--$n]) > $pixels) + { + $n++; + last; + } + } + $$sb = $n-$fixed; +} + +sub Layout +{ + my ($t) = @_; + return unless Tk::Exists($t); + my $rows = @{$t->{Row}}; + my $bw = $t->cget(-highlightthickness); + my $frows = $t->cget(-fixedrows); + my $fcols = $t->cget(-fixedcolumns); + my $sb = $t->cget(-scrollbars); + my $H = $t->Height; + my $W = $t->Width; + my $tadj = $bw; + my $badj = $bw; + my $ladj = $bw; + my $radj = $bw; + my @xs = ($W,0,0,0); + my @ys = (0,$H,0,0); + my $xsb; + my $ysb; + + my $why = $t->{LayoutPending}; + $t->{LayoutPending} = 0; + + if ($sb =~ /[ns]/) + { + $t->{xsb} = $t->Scrollbar(-orient => 'horizontal', -command => ['xview' => $t]) unless (defined $t->{xsb}); + $xsb = $t->{xsb}; + $t->Advertise('xscrollbar' => $xsb); + $xs[3] = $xsb->ReqHeight; + if ($sb =~ /n/) + { + $xs[1] = $tadj; + $tadj += $xs[3]; + } + else + { + $badj += $xs[3]; + $xs[1] = $H-$badj; + } + } + else + { + $t->{xsb}->UnmapWindow if (defined $t->{xsb}); + } + + if ($sb =~ /[ew]/) + { + $t->{ysb} = $t->Scrollbar(-orient => 'vertical', -command => ['yview' => $t]) unless (defined $t->{ysb}); + $ysb = $t->{ysb}; + $t->Advertise('yscrollbar' => $ysb); + $ys[2] = $ysb->ReqWidth; + if ($sb =~ /w/) + { + $ys[0] = $ladj; + $ladj += $ys[2]; + } + else + { + $radj += $ys[2]; + $ys[0] = $W-$radj; + } + } + else + { + $t->{ysb}->UnmapWindow if (defined $t->{ysb}); + } + + constrain(\$t->{Top}, $t->{Height},$H-($tadj+$badj),$frows); + constrain(\$t->{Left},$t->{Width}, $W-($ladj+$radj),$fcols); + + my $top = $t->{Top}+$frows; + my $left = $t->{Left}+$fcols; + + if ($why & (_ScrollBars|_RowColCount|_SlaveSize)) + { + # Width and/or Height of element or + # number of rows and/or columns or + # scrollbar presence has changed + my $w = sizeN($t->cget('-columns'),$t->{Width})+$radj+$ladj; + my $h = sizeN($t->cget('-rows'),$t->{Height})+$tadj+$badj; + $t->GeometryRequest($w,$h); + } + + if ($rows) + { + my $cols = @{$t->{Width}}; + my $yhwm = $top-$frows; + my $xhwm = $left-$fcols; + my $y = $tadj; + my $r; + for ($r = 0; $r < $rows; $r++) + { + my $h = $t->{Height}[$r]; + next unless defined $h; + if (($r < $top && $r >= $frows) || ($y+$h > $H-$badj)) + { + if (defined $t->{Row}[$r]) + { + my $c; + for ($c = 0; $c < @{$t->{Row}[$r]}; $c++) + { + my $s = $t->{Row}[$r][$c]; + if (defined $s) + { + $s->UnmapWindow; + if ($why & 1) + { + my $w = $t->{Width}[$c]; + $s->ResizeWindow($w,$h); + } + } + } + } + } + else + { + my $hwm = $left-$fcols; + my $sh = 0; + my $x = $ladj; + my $c; + $ys[1] = $y if ($y < $ys[1] && $r >= $frows); + for ($c = 0; $c <$cols; $c++) + { + my $s = $t->{Row}[$r][$c]; + my $w = $t->{Width}[$c]; + if (($c < $left && $c >= $fcols) || ($x+$w > $W-$radj) ) + { + if (defined $s) + { + $s->UnmapWindow; + $s->ResizeWindow($w,$h) if ($why & 1); + } + } + else + { + $xs[0] = $x if ($x < $xs[0] && $c >= $fcols); + if (defined $s) + { + if ($why & 1) + { + $s->MoveResizeWindow($x,$y,$w,$h); + } + else + { + $s->MoveWindow($x,$y); + } + $s->MapWindow; + } + $x += $w; + if ($c >= $fcols) + { + $hwm++; + $sh += $w + } + } + } + $xhwm = $hwm if ($hwm > $xhwm); + $xs[2] = $sh if ($sh > $xs[2]); + $y += $h; + if ($r >= $frows) + { + $ys[3] += $h; + $yhwm++; + } + } + } + $t->{Bottom} = $yhwm; + $t->{Right} = $xhwm; + if (defined $xsb && $xs[2] > 0) + { + $xsb->MoveResizeWindow(@xs); + $cols -= $fcols; + if ($cols > 0) + { + $xsb->set($t->{Left}/$cols,$t->{Right}/$cols); + $xsb->MapWindow; + } + } + if (defined $ysb && $ys[3] > 0) + { + $ysb->MoveResizeWindow(@ys); + $rows -= $frows; + if ($rows > 0) + { + $ysb->set($t->{Top}/$rows,$t->{Bottom}/$rows); + $ysb->MapWindow; + } + } + } +} + +sub QueueLayout +{ + my ($m,$why) = @_; + $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending}); + $m->{LayoutPending} |= $why; +} + +sub SlaveGeometryRequest +{ + my ($m,$s) = @_; + my ($row,$col) = @{$m->{Slave}{$s->PathName}}; + my $sw = $s->ReqWidth; + my $sh = $s->ReqHeight; + my $sz = 0; + if ($sw > $m->{Width}[$col]) + { + $m->{Width}[$col] = $sw; + $m->QueueLayout(_SlaveSize); + $sz++; + } + if ( (not defined ($m->{Height}[$row])) or $sh > $m->{Height}[$row]) + { + $m->{Height}[$row] = $sh; + $m->QueueLayout(_SlaveSize); + $sz++; + } + if (!$sz) + { + $s->ResizeWindow($m->{Width}[$col],$m->{Height}[$row]); + } +} + +sub get +{ + my ($t,$row,$col) = @_; + return $t->{Row}[$row][$col]; +} + +sub LostSlave +{ + my ($t,$s) = @_; + my $info = delete $t->{Slave}{$s->PathName}; + if (defined $info) + { + my ($row,$col) = @$info; + $t->{Row}[$row][$col] = undef; + $s->UnmapWindow; + } + else + { + $t->BackTrace('Cannot find' . $s->PathName); + } + $t->QueueLayout(_SlaveChange); +} + +sub clear { + my $self = shift; + my $rows = $self->cget(-rows); + my $cols = $self->cget(-columns); + foreach my $r (1 .. $rows) { + foreach my $c (1 .. $cols) { + my $old = $self->get( $r, $c ); + next unless $old; + $self->LostSlave($old); + $old->destroy; + } + } + $self->_init; + $self->QueueLayout(_SlaveSize); +} + +sub _init { + my $self = shift; + $self->{'Width'} = []; + $self->{'Height'} = []; + $self->{'Row'} = []; + $self->{'Slave'} = {}; + $self->{'Top'} = 0; + $self->{'Left'} = 0; + $self->{'Bottom'} = 0; + $self->{'Right'} = 0; + $self->{LayoutPending} = 0; +} + +sub put +{ + my ($t,$row,$col,$w) = @_; + $w = $t->Label(-text => $w) unless (ref $w); + $t->ManageGeometry($w); + unless (defined $t->{Row}[$row]) + { + $t->{Row}[$row] = []; + $t->{Height}[$row] = 0; + } + unless (defined $t->{Width}[$col]) + { + $t->{Width}[$col] = 0; + } + my $old = $t->{Row}[$row][$col]; + if (defined $old) + { + $old->UnmanageGeometry; + $t->LostSlave($old); + } + $t->{Row}[$row][$col] = $w; + $t->{Slave}{$w->PathName} = [$row,$col]; + $t->SlaveGeometryRequest($w); + $t->QueueLayout(_SlaveChange); + return $old; +} + +# +# configure methods +# + +sub scrollbars +{ + my ($t,$v) = @_; + if (@_ > 1) + { + $t->_configure(-scrollbars => $v); + $t->QueueLayout(_ScrollBars); + } + return $t->_cget('-scrollbars'); +} + +sub rows +{ + my ($t,$r) = @_; + if (@_ > 1) + { + $t->_configure(-rows => $r); + if ($t->{Row} && @{$t->{Row}} > $r) + { + for my $y ($r .. $#{$t->{Row}}) + { + for my $s (@{$t->{Row}[$y]}) + { + $s->destroy if $s; + } + } + splice @{ $t->{Row} }, $r; + } + $t->QueueLayout(_RowColCount); + } + return $t->_cget('-rows'); +} + +sub fixedrows +{ + my ($t,$r) = @_; + if (@_ > 1) + { + $t->_configure(-fixedrows => $r); + $t->QueueLayout(_RowColCount); + } + return $t->_cget('-fixedrows'); +} + +sub columns +{ + my ($t,$r) = @_; + if (@_ > 1) + { + $t->_configure(-columns => $r); + if ($t->{Row}) + { + for my $row (@{$t->{Row}}) + { + for my $s (@$row[$r .. $#$row]) + { + $s->destroy if $s; + } + { # FIXME? - Steve was getting warnings : + # splice() offset past end of array + local $^W = 0; + splice @$row, $r; + } + } + } + $t->QueueLayout(_RowColCount); + } + return $t->_cget('-columns'); +} + +sub fixedcolumns +{ + my ($t,$r) = @_; + if (@_ > 1) + { + $t->_configure(-fixedcolumns => $r); + $t->QueueLayout(_RowColCount); + } + return $t->_cget('-fixedcolumns'); +} + +1; +__END__ +sub Create +{ + my $t = shift; + my $r = shift; + my $c = shift; + my $kind = shift; + $t->put($r,$c,$t->$kind(@_)); +} + +sub totalColumns +{ + scalar @{shift->{'Width'}}; +} + +sub totalRows +{ + scalar @{shift->{'Height'}}; +} + +sub Posn +{ + my ($t,$s) = @_; + my $info = $t->{Slave}{$s->PathName}; + return (wantarray) ? @$info : $info; +} + +sub see +{ + my $t = shift; + my ($row,$col) = (@_ == 2) ? @_ : @{$t->{Slave}{$_[0]->PathName}}; + my $see = 1; + if (($row -= $t->cget('-fixedrows')) >= 0) + { + if ($row < $t->{Top}) + { + $t->{Top} = $row; + $t->QueueLayout(_ViewChange); + $see = 0; + } + elsif ($row >= $t->{Bottom}) + { + $t->{Top} += ($row - $t->{Bottom}+1); + $t->QueueLayout(_ViewChange); + $see = 0; + } + } + if (($col -= $t->cget('-fixedcolumns')) >= 0) + { + if ($col < $t->{Left}) + { + $t->{Left} = $col; + $t->QueueLayout(_ViewChange); + $see = 0; + } + elsif ($col >= $t->{Right}) + { + $t->{Left} += ($col - $t->{Right}+1); + $t->QueueLayout(_ViewChange); + $see = 0; + } + } + return $see; +} + |