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