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