home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Tiler.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  3.9 KB  |  199 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. # An example of a geometry manager "widget" in perl
  5. package Tk::Tiler;
  6. require Tk;
  7. require Tk::Frame;
  8. @ISA = qw(Tk::Frame);
  9.  
  10. Construct Tk::Widget 'Tiler';
  11. sub Tk::Widget::ScrlTiler { shift->Scrolled('Tiler' => @_) }
  12.  
  13. use Tk::Pretty;
  14.  
  15. sub FocusChildren
  16. {
  17.  return (wantarray) ? () : 0;
  18. }
  19.  
  20. sub Populate
  21. {
  22.  my ($obj,$args) = @_;
  23.  $obj->SUPER::Populate($args);
  24.  $obj->{Slaves} = [];
  25.  $obj->{LayoutPending} = 0;
  26.  $obj->{Start} = 0;
  27.  $obj->{Sw}    = 0;
  28.  $obj->{Sh}    = 0;
  29.  $obj->ConfigSpecs('-takefocus'      => [SELF, 'takeFocus','TakeFocus',1],
  30.                    '-highlightthickness' => [SELF, 'highlightThickness','HighlightThickness',2],
  31.                    '-yscrollcommand' => [CALLBACK,undef,undef,undef],
  32.                    '-columns'        => [PASSIVE,'columns','Columns',5],
  33.                    '-rows'           => [PASSIVE,'rows','Rows',10]
  34.                   );
  35.  return $obj;
  36. }
  37.  
  38. sub change_size
  39. {
  40.  my ($w) = shift;
  41.  my $r  = $w->cget('-rows');
  42.  my $c  = $w->cget('-columns');
  43.  my $bw = $w->cget(-highlightthickness);
  44.  if (defined $r && defined $c)
  45.   {
  46.    $w->GeometryRequest($c*$w->{Sw}+2*$bw,$r*$w->{Sh}+2*$bw);
  47.   }
  48. }
  49.  
  50. sub Layout
  51. {
  52.  my $m = shift;
  53.  my $bw = $m->cget(-highlightthickness);
  54.  my $why = $m->{LayoutPending};
  55.  $m->{LayoutPending} = 0;
  56.  my $W = $m->Width;
  57.  my $H = $m->Height;
  58.  my $w = $m->{Sw};  # max width of slave
  59.  my $h = $m->{Sh};  # max height of slave
  60.  my $x = $bw; 
  61.  my $y = $bw; 
  62.  my $start = 0;
  63.  # Set size and position of slaves
  64.  my $rows = $m->{Rows} = ($H-2*$bw)/$h;
  65.  my $cols = $m->{Cols} = ($W-2*$bw)/$w;
  66.  my $need = $m->{Need} = int( (@{$m->{Slaves}}+$cols-1)/$cols );
  67.  $m->{Start} = ($need - $rows) if ($m->{Start} + $rows > $need);
  68.  $m->{Start} = 0               if ($m->{Start} < 0);
  69.  my $row = 0;
  70.  my @posn  = ();
  71.  my $s;
  72.  foreach $s (@{$m->{Slaves}})
  73.   {
  74.    if ($row < $m->{Start})
  75.     {
  76.      $s->UnmapWindow;
  77.      $x += $w;
  78.      if ($x+$w+$bw > $W)
  79.       {
  80.        $x = $bw;
  81.        $row++;
  82.       }
  83.     }
  84.    elsif ($y+$h+$bw > $H)
  85.     {
  86.      $s->UnmapWindow;
  87.      $s->ResizeWindow($w,$h) if ($why & 1);
  88.     }
  89.    else
  90.     {
  91.      push(@posn,[$s,$x,$y]);
  92.      $x += $w;
  93.      if ($x+$w+$bw > $W)
  94.       {
  95.        $x = $bw;
  96.        $y += $h;
  97.        $row++;
  98.       }
  99.     }
  100.    $s->ResizeWindow($w,$h) if ($why & 1);
  101.   }
  102.  $row++ if ($x);
  103.  if (defined $m->{Prev} && $m->{Prev} > $m->{Start})
  104.   {
  105.    @posn = reverse(@posn);
  106.   }
  107.  while (@posn)
  108.   {
  109.    my $posn = shift(@posn);
  110.    my ($s,$x,$y) = (@$posn);
  111.    $s->MoveWindow($x,$y);
  112.    $s->MapWindow;
  113.   }
  114.  $m->{Prev} = $m->{Start};
  115.  $m->Callback(-yscrollcommand => $m->{Start}/$need,$row/$need);
  116. }
  117.  
  118. sub QueueLayout
  119. {
  120.  my ($m,$why) = @_;
  121.  $m->DoWhenIdle(['Layout',$m]) unless ($m->{LayoutPending});
  122.  $m->{LayoutPending} |= $why;
  123. }
  124.  
  125. sub SlaveGeometryRequest
  126. {
  127.  my ($m,$s) = @_;
  128.  my $sw = $s->ReqWidth;
  129.  my $sh = $s->ReqHeight;
  130.  my $sz = 0;
  131.  if ($sw > $m->{Sw})
  132.   {
  133.    $m->{Sw} = $sw;
  134.    $m->QueueLayout(1);
  135.    $sz++;
  136.   }
  137.  if ($sh > $m->{Sh})
  138.   {
  139.    $m->{Sh} = $sh;
  140.    $m->QueueLayout(1);
  141.    $sz++;
  142.   }
  143.  $m->change_size if ($sz);
  144. }
  145.  
  146. sub LostSlave
  147. {
  148.  my ($m,$s) = @_;
  149.  @{$m->{Slaves}} = grep($_ != $s,@{$m->{Slaves}});
  150.  $m->QueueLayout(2);
  151. }
  152.  
  153. sub Manage
  154. {
  155.  my $m = shift;
  156.  my $s;
  157.  foreach $s (@_)
  158.   {
  159.    $m->ManageGeometry($s);      
  160.    push(@{$m->{Slaves}},$s);    
  161.    $m->SlaveGeometryRequest($s);
  162.   }
  163.  $m->QueueLayout(2);
  164. }
  165.  
  166. sub moveto
  167.  {
  168.   my ($m,$frac) = (@_);
  169.   $m->{Start} = int($m->{Need} * $frac);
  170.   $m->QueueLayout(4);
  171.  }
  172.  
  173. sub scroll
  174.  {
  175.   my ($m,$delta,$type) = @_;
  176.   $delta *= $m->{Rows}/2 if ($type eq 'pages');
  177.   $m->{Start} += $delta;
  178.   $m->QueueLayout(4);
  179.  }
  180.  
  181. sub yview { my $w = shift; my $c = shift; $w->$c(@_) }
  182.  
  183. sub FocusIn
  184. {
  185.  my ($w) = @_;
  186.  print "Focus ",$w->PathName,"\n";
  187. }
  188.  
  189. sub ClassInit
  190. {
  191.  my ($class,$mw) = @_;
  192.  $mw->bind($class,'<Configure>',['QueueLayout',8]);
  193.  $mw->bind($class,'<FocusIn>',  'NoOp');
  194.  $mw->YscrollBind($class);
  195.  return $class;
  196. }
  197.  
  198. 1;
  199.