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