home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _e0b65c8ec2a562c9f9c23ea375d1f01c < prev    next >
Encoding:
Text File  |  2004-06-01  |  11.2 KB  |  437 lines
  1. package Tk::Adjuster;
  2.  
  3. use vars qw($VERSION);
  4. $VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/Adjuster.pm#7 $
  5.  
  6. use base  qw(Tk::Frame);
  7.  
  8. # We cannot do this :
  9.  
  10. # Construct Tk::Widget 'packAdjust';
  11.  
  12. # because if managed object is Derived (e.g. a Scrolled) then our 'new'
  13. # will be delegated and hierachy gets turned inside-out
  14. # So packAdjust is autoloaded in Widget.pm
  15.  
  16.  
  17. Construct Tk::Widget qw(Adjuster);
  18.  
  19. {package Tk::Adjuster::Item;
  20.  
  21. use strict;
  22. use base  qw(Tk::Frame);
  23.  
  24. sub ClassInit
  25. {
  26.  my ($class,$mw) = @_;
  27.  $mw->bind($class,'<1>',['BDown', 1]);
  28.  $mw->bind($class,'<Shift-1>',['BDown', 0]);
  29.  $mw->bind($class,'<B1-Motion>',['Motion',1]);
  30.  $mw->bind($class,'<Shift-B1-Motion>',['Motion',0]);
  31.  $mw->bind($class,'<ButtonRelease-1>',['Motion',0]);
  32.  return $class;
  33. }
  34.  
  35. sub BDown
  36. {
  37.  my($w, $delay_mask) = @_;
  38.  $w->{'start_x'} = $w->XEvent->x;
  39.  $w->{'start_y'} = $w->XEvent->y;
  40.  my $adj  = $w->Parent;
  41.  delete $adj->{'lin_info'};
  42.  my $delay = $delay_mask && $adj->cget('-delay');
  43.  if ($delay)
  44.   {
  45.     $adj->vert ? $adj->delta_width_bar(0) : $adj->delta_height_bar(0);
  46.   }
  47. }
  48.  
  49. sub Motion
  50. {
  51.  my($w, $delay_mask) = @_;
  52.  my $ev = $w->XEvent;
  53.  my $adj  = $w->Parent;
  54.  
  55.  my $delay = $delay_mask && $adj->cget('-delay');
  56.  if ($adj->vert)
  57.   {
  58.     my $dx = $ev->x - $w->{'start_x'};
  59.     $delay ?  $adj->delta_width_bar($dx) : $adj->delta_width($dx);
  60.   }
  61.  else
  62.   {
  63.     my $dy = $ev->y - $w->{'start_y'};
  64.     $delay ? $adj->delta_height_bar($dy) : $adj->delta_height($dy);
  65.   }
  66. }
  67.  
  68. }
  69.  
  70.  
  71.  
  72. sub packAfter
  73. {
  74.  my ($w,$s,%args) = @_;
  75.  my $side = $args{'-side'} ? $args{'-side'} : 'top';
  76.  $w->configure(-side   => $side, -widget => $s);
  77.  $w->packed($s, %args);
  78. }
  79.  
  80. sub packForget
  81. {
  82.  my ($w,$forget_slave) = @_;
  83.  $w->Tk::Widget::packForget;
  84.  $w->slave->packForget if $forget_slave;
  85. }
  86.  
  87. # Called by Tk::Widget::packAdjust. It was here before packAfter was added
  88. sub packed
  89. {
  90.  my ($w,$s,%args) = @_;
  91.  delete $args{'-before'};
  92.  delete $args{'-in'};
  93.  $args{'-expand'} = 0;
  94.  $args{'-after'} = $s;
  95.  $args{'-fill'} = (($w->vert) ? 'y' : 'x');
  96.  $w->pack(%args);
  97. }
  98.  
  99. sub gridded
  100. {
  101.  my ($w,$s,%args) = @_;
  102.  # delete $args{'-before'};
  103.  # $args{'-expand'} = 0;
  104.  # $args{'-after'} = $s;
  105.  # $args{'-fill'} = (($w->vert) ? 'y' : 'x');
  106.  $w->grid(%args);
  107. }
  108.  
  109. sub ClassInit
  110. {
  111.  my ($class,$mw) = @_;
  112.  $mw->bind($class,'<Configure>','SizeChange');
  113.  $mw->bind($class,'<Unmap>','Restore');
  114.  $mw->bind($class,'<Map>','Mapped');
  115.  return $class;
  116. }
  117.  
  118. sub SizeChange
  119. {
  120.  my $w = shift;
  121.  # reqwidth/height of Adjuster is stored here. If it is partially pushed out
  122.  # of the window, then $w->width/height returns that of the visible part.
  123.  if ($w->vert)
  124.   {
  125.    my $sx = ($w->Width - $w->{'sep'}->Width)/2;
  126.    $w->{'but'}->place('-x' => 0, '-y' => $w->Height-18);
  127.    $w->{'sep'}->place('-x' => $sx, '-y' => 0,  -relheight => 1);
  128.    $w->configure(-width => $w->{'but'}->ReqWidth);
  129.    $w->{'reqwidth'} = $w->reqwidth;
  130.   }
  131.  else
  132.   {
  133.    my $sy = ($w->Height - $w->{'sep'}->Height)/2;
  134.    $w->{'but'}->place('-x' => $w->Width-18, '-y' => 0);
  135.    $w->{'sep'}->place('-x' => 0, '-y' => $sy,  -relwidth => 1);
  136.    $w->configure(-height => $w->{'but'}->ReqHeight);
  137.    $w->{'reqheight'} = $w->reqheight;
  138.   }
  139.  # Turn off geometry propagation in the slave. Do only if necessary, as this
  140.  # causes repacking.
  141.  my $s = $w->slave;
  142.  $s->packPropagate('0') if $s->packSlaves && $s->packPropagate();
  143.  $s->gridPropagate('0') if $s->gridSlaves && $s->gridPropagate();
  144. }
  145.  
  146. sub Mapped
  147. {
  148.  my $w = shift;
  149.  $w->idletasks;
  150.  my $m = $w->manager;
  151.  if ($m =~ /^(?:pack|grid)$/)
  152.   {
  153.    my %info = $w->$m('info');
  154.    my $master = $info{'-in'};
  155.    $master->$m('propagate',0);
  156.    $w->{'master'} = $master;
  157.   }
  158.  $w->slave_expand_off;
  159. }
  160.  
  161. sub Populate
  162. {
  163.  my ($w,$args) = @_;
  164.  $w->SUPER::Populate($args);
  165.  $w->{'sep'} = Tk::Adjuster::Item->new($w,-bd => 1, -relief => 'sunken');
  166.  $w->{'but'} = Tk::Adjuster::Item->new($w,-bd => 1, -width => 8, -height => 8, -relief => 'raised');
  167.  
  168.  # Need to explicitly set frame width to 0 for Win32
  169.  my $l = $w->{'lin'} = $w->toplevel->Frame(-bd => 0);
  170.  
  171.  my $cs = $w->ConfigSpecs(-widget => ['PASSIVE','widget','Widget',$w->Parent],
  172.                  -side       => ['METHOD','side','Side','top'],
  173.                  -delay      => ['PASSIVE','delay','Delay', 1],
  174.                  -background => [['SELF',$w->{'sep'},$w->{'but'}],'background','Background',undef],
  175.                  -foreground => [Tk::Configure->new($w->{'lin'},'-background'),'foreground','Foreground','black'],
  176.          -restore    => ['PASSIVE','restore', 'Restore', 1],
  177.                 );
  178.  $w->_OnDestroy(qw(sep but lin master));
  179. }
  180.  
  181. sub side
  182. {
  183.  my ($w,$val) = @_;
  184.  if (@_ > 1)
  185.   {
  186.    $w->{'side'} = $val;
  187.    my $cursor;
  188.    if ($w->vert)
  189.     {
  190.      $cursor = 'sb_h_double_arrow';
  191.      $w->{'sep'}->configure(-width => 2, -height => 10000);
  192.     }
  193.    else
  194.     {
  195.      $cursor = 'sb_v_double_arrow';
  196.      $w->{'sep'}->configure(-height => 2, -width => 10000);
  197.     }
  198.    my $x;
  199.    foreach $x ($w->{'sep'},$w->{'but'})
  200.     {
  201.      $x->configure(-cursor => $cursor);
  202.     }
  203.   }
  204.  return $w->{'side'};
  205. }
  206.  
  207. sub slave
  208. {
  209.  my $w = shift;
  210.  my $s = $w->cget('-widget');
  211.  return $s;
  212. }
  213.  
  214. sub vert
  215. {
  216.  my $w = shift;
  217.  my $side = $w->cget('-side');
  218.  return  1 if $side eq 'left';
  219.  return -1 if $side eq 'right';
  220.  return  0;
  221. }
  222.  
  223. # If the Adjuster gets unmapped, it attempts to restore itself. If its
  224. # slave is mapped, then it reduces the size of the slave so that there is
  225. # then room in the master for the Adjuster widget.
  226. sub Restore
  227. {
  228.  my $w = shift;
  229.  return if ! $w->toplevel->IsMapped ||
  230.         ! $w->slave->IsMapped ||
  231.        ! $w->cget('-restore');
  232.  $w->vert ? $w->delta_width(0) : $w->delta_height(0);
  233. }
  234.  
  235. sub delta_width_bar
  236. {
  237.  my ($w,$dx) = @_;
  238.  my $l = $w->{'lin'};
  239.  my $r = $w->{'sep'};
  240.  my $t = $w->toplevel;
  241.  my $m = $w->{'master'};
  242.  my $s = $w->slave;
  243.  my ($min_rootx, $max_rootx, $t_border);
  244.  if (! $w->{'lin_info'})
  245.   {
  246.    my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
  247.    $t_border    = $t->cget('-bd') + $t->cget('-highlightthickness');
  248.    if ($w->cget('-side') eq 'right')
  249.     {
  250.      $min_rootx = $m->rootx + $m_border;
  251.      $max_rootx = $s->rootx + $s->width - 1;
  252.     }
  253.    else
  254.     {
  255.      $min_rootx = $s->rootx;
  256.      $max_rootx = $m->rootx + $m->width - $m_border - 1;
  257.     }
  258.    $w->{'lin_info'} = [$min_rootx, $max_rootx, $t_border];
  259.   }
  260.   else
  261.    {
  262.     ($min_rootx, $max_rootx, $t_border) = @{$w->{'lin_info'}};
  263.    }
  264.  $l->configure(-width => 1, -height => $w->height) unless $l->IsMapped;
  265.  
  266.  my $new_rootx = $w->rootx + $w->{'reqwidth'}/2 + $dx;
  267.  $new_rootx = $min_rootx if $new_rootx < $min_rootx;
  268.  $new_rootx = $max_rootx if $new_rootx > $max_rootx;
  269.  my $placex = $new_rootx - $t->rootx - $t_border;
  270.  my $placey = $w->rooty  - $t->rooty - $t_border;
  271.  $l->place(-in => $t, -anchor => 'n', '-x' => $placex, '-y' => $placey);
  272.  my $this = $w->containing($new_rootx, $w->rooty + 1);
  273.  $l->raise($this) if $this && $this ne $t;
  274. }
  275.  
  276. sub delta_width
  277. {
  278.  my ($w,$dx) = @_;
  279.  my $l = $w->{'lin'};
  280.  $l->placeForget;
  281.  my $s = $w->slave;
  282.  if ($s)
  283.   {
  284.    my $m = $w->{'master'};
  285.    my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
  286.    my $w_width = $w->{'reqwidth'};
  287.    my $m_width = $m->width;
  288.    my $s_width = $s->width;
  289.    my $max_width = $m_width - $w_width;
  290.    my $max_s_width;
  291.    if ($w->cget('-side') eq 'right')
  292.     {
  293.      $dx = -$dx;
  294.      $max_s_width = $max_width -
  295.               ($m->rootx + $m_width - ($s->rootx+$s_width)) - $m_border;
  296.     }
  297.    else
  298.     {
  299.      $max_s_width = $max_width - ($s->rootx - $m->rootx) - $m_border;
  300.     }
  301.    my $new_width = $s_width+$dx;
  302.    $new_width = $max_s_width if $new_width > $max_s_width;
  303.    $new_width = 0 if $new_width < 0;
  304.    $s->GeometryRequest($new_width, $s->height);
  305.   }
  306. }
  307.  
  308. sub delta_height_bar
  309. {
  310.  my ($w,$dy) = @_;
  311.  my $l = $w->{'lin'};
  312.  my $r = $w->{'sep'};
  313.  my $t = $w->toplevel;
  314.  my $m = $w->{'master'};
  315.  my $s = $w->slave;
  316.  my ($min_rooty, $max_rooty, $t_border);
  317.  if (! $w->{'lin_info'})
  318.   {
  319.    my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
  320.    $t_border    = $t->cget('-bd') + $t->cget('-highlightthickness');
  321.    if ($w->cget('-side') eq 'bottom')
  322.     {
  323.      $min_rooty = $m->rooty + $m_border;
  324.      $max_rooty = $s->rooty + $s->height - 1;
  325.     }
  326.    else
  327.     {
  328.      $min_rooty = $s->rooty;
  329.      $max_rooty = $m->rooty + $m->height - $m_border - 1;
  330.     }
  331.    $w->{'lin_info'} = [$min_rooty, $max_rooty, $t_border];
  332.   }
  333.  else
  334.   {
  335.    ($min_rooty, $max_rooty, $t_border) = @{$w->{'lin_info'}};
  336.   }
  337.  $l->configure(-height => 1, -width => $w->width) unless $l->IsMapped;
  338.  
  339.  my $new_rooty = $w->rooty + $w->{'reqheight'}/2 + $dy;
  340.  $new_rooty = $min_rooty if $new_rooty < $min_rooty;
  341.  $new_rooty = $max_rooty if $new_rooty > $max_rooty;
  342.  my $placey = $new_rooty - $t->rooty - $t_border;
  343.  my $placex = $w->rootx  - $t->rootx - $t_border;
  344.  $l->place(-in => $t, -anchor => 'w', '-x' => $placex, '-y' => $placey);
  345.  my $this = $w->containing($w->rootx + 1, $new_rooty);
  346.  $l->raise($this) if $this && $this ne $t;
  347. }
  348.  
  349. sub delta_height
  350. {
  351.  my ($w,$dy) = @_;
  352.  my $l = $w->{'lin'};
  353.  $l->placeForget;
  354.  my $s = $w->slave;
  355.  if ($s)
  356.   {
  357.    my $m = $w->{'master'};
  358.    my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
  359.    my $w_height = $w->{'reqheight'};
  360.    my $m_height = $m->height;
  361.    my $s_height = $s->height;
  362.    my $max_height = $m_height - $w_height;
  363.    my $max_s_height;
  364.    if ($w->cget('-side') eq 'bottom')
  365.     {
  366.      $dy = -$dy;
  367.      $max_s_height = $max_height -
  368.             ($m->rooty + $m_height - ($s->rooty+$s_height)) - $m_border;
  369.     }
  370.    else
  371.     {
  372.      $max_s_height = $max_height - ($s->rooty - $m->rooty) - $m_border;
  373.     }
  374.    my $new_height = $s_height+$dy;
  375.  
  376.    $new_height = $max_s_height if $new_height > $max_s_height;
  377.    $new_height = 0 if $new_height < 0;
  378.    $s->GeometryRequest($s->width, $new_height);
  379.   }
  380. }
  381.  
  382. # Turn off expansion in the slave.
  383. # This is done only if necessary, as calls to pack/gridConfigure cause
  384. # repacking.
  385. # Before call to pack/gridConfigure, the reqwidth/reqheight is set to the
  386. # current width/height. This is because the geometry managers use
  387. # the requested values, not the actual, to calculate the new geometry.
  388. sub slave_expand_off
  389. {
  390.  my $w = shift;
  391.  my $s = $w->slave;
  392.  return if ! $s;
  393.  
  394.  my $manager = $s->manager;
  395.  if ($manager eq 'pack')
  396.   {
  397.    my %info = $s->packInfo;
  398.    my $expand = $info{'-expand'};
  399.    if ($expand)
  400.     {
  401.      $s->GeometryRequest($s->width, $s->height);
  402.      $s->packConfigure(-expand => 0);
  403.     }
  404.   }
  405.  elsif ($manager eq 'grid')
  406.   {
  407.    my %info = $s->gridInfo;
  408.    my $master = $info{'-in'};
  409.    if ($w->vert)
  410.     {
  411.      my $col = $info{'-column'};
  412.      my $expand = $master->gridColumnconfigure($col, '-weight');
  413.      if ($expand)
  414.       {
  415.        $s->GeometryRequest($s->width, $s->height);
  416.        $master->gridColumnconfigure($col, -weight => 0);
  417.       }
  418.     }
  419.    else
  420.     {
  421.      my $row = $info{'-row'};
  422.      my $expand = $master->gridRowconfigure($row, '-weight');
  423.      if ($expand)
  424.       {
  425.        $s->GeometryRequest($s->width, $s->height);
  426.        $master->gridRowconfigure($row, -weight => 0);
  427.       }
  428.     }
  429.   }
  430. }
  431.  
  432. 1;
  433.  
  434. __END__
  435.  
  436. =cut #' emacs hilighting...
  437.