home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Adjuster.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  8.2 KB  |  319 lines
  1. package Tk::Adjuster::Item;
  2. @ISA = qw(Tk::Frame);
  3.  
  4. sub ClassInit
  5. {
  6.  my ($class,$mw) = @_;
  7.  $mw->bind($class,'<B1-Motion>',['Motion',1]);
  8.  $mw->bind($class,'<Shift-B1-Motion>',['Motion',0]);
  9.  $mw->bind($class,'<ButtonRelease-1>',['Motion',0]);
  10.  return $class;
  11. }
  12.  
  13. sub dx
  14. {
  15.  my $w = shift;
  16.  my $ev = $w->XEvent;
  17.  my $x = $ev->x;                                   
  18.  if ($x > 0)                                       
  19.   {                                                
  20.    $x -= $w->Width;                                
  21.    return 0 if $x < 0;                               
  22.   }                                                
  23.  return $x;
  24. }
  25.  
  26. sub dy
  27. {
  28.  my $w = shift;
  29.  my $ev = $w->XEvent;
  30.  my $y = $ev->y;                                   
  31.  if ($y > 0)                                       
  32.   {                                                
  33.    $y -= $w->Height;                                
  34.    return 0 if $y < 0;                               
  35.   }                                                
  36.  return $y;
  37. }
  38.  
  39. sub right
  40. {
  41.  my $w = shift;
  42.  my $dx = $w->dx;
  43.  $w->Parent->dWidth(-$dx,$dx,@_) if $dx;
  44. }
  45.  
  46. sub left
  47. {
  48.  my $w = shift;
  49.  my $dx = $w->dx;
  50.  $w->Parent->dWidth($dx,$dx,@_) if $dx;
  51. }
  52.  
  53. sub bottom
  54. {
  55.  my $w = shift;
  56.  my $dy = $w->dy;
  57.  $w->Parent->dHeight(-$dy,$dy,@_) if $dy;
  58. }
  59.  
  60. sub top
  61. {
  62.  my $w = shift;
  63.  my $dy = $w->dy;
  64.  $w->Parent->dHeight($dy,$dy,@_) if $dy;
  65. }
  66.  
  67. sub Motion
  68. {
  69.  my $w = shift;
  70.  my $p  = $w->Parent;
  71.  my $side = $p->cget('-side');
  72.  $w->$side(@_);
  73. }
  74.  
  75. package Tk::Adjuster;
  76. use AutoLoader;
  77. require Tk::Frame;
  78. @ISA = qw(Tk::Frame);
  79.  
  80. Construct Tk::Widget qw(Adjuster);
  81.  
  82. # We cannot do this :
  83.  
  84. # Construct Tk::Widget 'packAdjust';
  85.  
  86. # because if managed object is Derived (e.g. a Scrolled) then our 'new'
  87. # will be delegated and hierachy gets turned inside-out
  88. # So packAdjust is autoloaded in Widget.pm
  89.  
  90. sub packed
  91. {
  92.  my ($w,$s,%args) = @_;
  93.  delete $args{'-before'};
  94.  $args{'-expand'} = 0;
  95.  $args{'-after'} = $s;
  96.  $args{'-fill'} = (($w->vert) ? 'y' : 'x');
  97.  $w->pack(%args);
  98. }
  99.  
  100. sub gridded
  101. {
  102.  my ($w,$s,%args) = @_;
  103.  # delete $args{'-before'};
  104.  # $args{'-expand'} = 0;
  105.  # $args{'-after'} = $s;
  106.  # $args{'-fill'} = (($w->vert) ? 'y' : 'x');
  107.  $w->grid(%args);
  108. }
  109.  
  110. sub ClassInit
  111. {
  112.  my ($class,$mw) = @_;
  113.  $mw->bind($class,'<Configure>','SizeChange');
  114.  $mw->bind($class,'<Unmap>','Restore');
  115.  $mw->bind($class,'<Map>','Mapped');
  116.  return $class;
  117. }
  118.  
  119. sub SizeChange
  120. {
  121.  my $w = shift;
  122.  if ($w->vert)
  123.   {
  124.    my $sx = ($w->Width - $w->{'sep'}->Width)/2;
  125.    $w->{'but'}->place('-x' => 0, '-y' => $w->Height-18);
  126.    $w->{'sep'}->place('-x' => $sx, '-y' => 0,  -relheight => 1);
  127.    $w->configure(-width => $w->{'but'}->ReqWidth);
  128.   }
  129.  else
  130.   {
  131.    my $sy = ($w->Height - $w->{'sep'}->Height)/2;
  132.    $w->{'but'}->place('-x' => $w->Width-18, '-y' => 0);
  133.    $w->{'sep'}->place('-x' => 0, '-y' => $sy,  -relwidth => 1);
  134.    $w->configure(-height => $w->{'but'}->ReqHeight);
  135.   }
  136. }
  137.  
  138. sub Mapped
  139. {
  140.  my $w = shift;
  141.  my $m = $w->manager;
  142.  if ($m =~ /^(pack|grid)$/)
  143.   {
  144.    my %info = $w->$m('info');
  145.    $info{'-in'}->$m('propagate',0);
  146.   }
  147. }
  148.  
  149. sub Populate
  150. {
  151.  my ($w,$args) = @_;
  152.  $w->SUPER::Populate($args);
  153.  $w->{'sep'} = Tk::Adjuster::Item->new($w,-bd => 1, -relief => 'sunken');
  154.  $w->{'but'} = Tk::Adjuster::Item->new($w,-bd => 1, -width => 8, -height => 8, -relief => 'raised');
  155.  # Use a Menu as a "token"
  156.  # Toplevel needs these, Menu implies them
  157.  # $l->UnmapWindow;
  158.  # $l->overrideredirect(1);
  159.  my $l = $w->{'lin'} = $w->Menu;
  160.  my $cs = $w->ConfigSpecs(-widget => ['PASSIVE','widget','Widget',$w->Parent],
  161.                  -side       => ['METHOD','side','Side','top'],
  162.                  -delay      => ['PASSIVE','delay','Delay', 1],
  163.                  -background => [[SELF,$w->{'sep'},$w->{'but'}],'background','Background',undef], 
  164.                  -foreground => [Tk::Configure->new($w->{'lin'},'-background'),'foreground','Foreground','black'] 
  165.                 );
  166. }
  167.  
  168. sub side
  169. {
  170.  my ($w,$val) = @_; 
  171.  if (@_ > 1)
  172.   {
  173.    $w->{'side'} = $val;
  174.    my $cursor;                                                                           
  175.    if ($w->vert)                                                                         
  176.     {                                                                                    
  177.      $cursor = 'sb_h_double_arrow';                                                      
  178.      $w->{'sep'}->configure(-width => 2, -height => 10000);                              
  179.     }                                                                                    
  180.    else                                                                                  
  181.     {                                                                                    
  182.      $cursor = 'sb_v_double_arrow';                                                      
  183.      $w->{'sep'}->configure(-height => 2, -width => 10000);                              
  184.     }                                                                                    
  185.    my $x;                                                                                
  186.    foreach $x ($w->{'sep'},$w->{'but'})                                                  
  187.     {                                                                                    
  188.      $x->configure(-cursor => $cursor);                                                  
  189.     }                                                                                    
  190.   }
  191.  return $w->{'side'};
  192. }
  193.  
  194. sub slave 
  195. { 
  196.  my $w = shift;
  197.  my $s = $w->cget('-widget');
  198.  return $s;
  199. }
  200.  
  201. sub vert
  202. {
  203.  my $w = shift;
  204.  my $side = $w->cget('-side');
  205.  return  1 if $side eq 'left';
  206.  return -1 if $side eq 'right';
  207.  return  0;
  208. }
  209.  
  210. 1;
  211. __END__
  212.  
  213. =head1 NAME
  214.  
  215. Tk::Adjuster, packAdjust - Allow size of packed widgets to be adjusted by user
  216.  
  217. =head1 SYNOPSIS
  218.  
  219.   use Tk;
  220.   use Tk::Adjuster;
  221.  
  222.   $widget->packAdjust([pack options]);
  223.  
  224. =head1 DESCRIPTION
  225.  
  226. C<packAdjust> calls pack on the widget and then creates an instance of 
  227. Tk::Adjuster and packs that "after" the widget. Tk::Adjust is a Frame
  228. containing a "line" and a blob. 
  229.  
  230. Dragging either with Mouse Button-1 results in a line being dragged 
  231. to indicate new size. Releasing Button submits GeometryRequests 
  232. on behalf of the widget which will cause the packer to change widget's size. 
  233.  
  234. If Drag is done with Shift button down, then GeometryRequests are made
  235. in "real time" so that text-flow effects can be seen, but as a lot more
  236. work is done behaviour may be sluggish.
  237.  
  238.  
  239. If widget is packed with -side => left or -side => right then width is 
  240. adjusted. If packed -side => top or -side => bottom then height is adjusted.
  241.  
  242. C<packPropagate> is turned off for the master window to prevent adjustment
  243. changing overall window size. Similarly C<packPropagate> is turned off
  244. for the managed widget if it has things packed inside it. This is so that 
  245. the GeometryRequests that Tk::Adjuster are not overriden by pack.
  246.  
  247. =head1 NOTES
  248.  
  249. The 'line' which is used to feedback position is in fact a 'Menu' widget
  250. set to an unorthodox shape, and with a black background.
  251.  
  252. =head1 BUGS
  253.  
  254. If the size of adjustable widget is increased to the limit there is no longer
  255. room for the Tk::Ajuster widget. As a work-round it forcibly makes room for 
  256. itself if it is unmapped. However the "grab" it held will have been lost 
  257. and button-motion events may be sent to other widgets which are not expecting 
  258. them, which can result in error messages. 
  259.  
  260. =cut 
  261.  
  262. sub Restore
  263. {
  264.  my $w = shift;
  265.  if ($w->vert)
  266.   {
  267.    $w->dWidth(-$w->ReqWidth);
  268.   }
  269.  else
  270.   {
  271.    $w->dHeight(-$w->ReqHeight);
  272.   }
  273. }
  274.  
  275. sub dWidth
  276. {
  277.  my ($w,$dx,$sdx,$down) = @_;
  278.  my $l = $w->{'lin'};
  279.  if ($down && $w->cget('-delay'))
  280.   {
  281.    my $r = $w->{'sep'};
  282.    $l->GeometryRequest(1,$r->Height) unless $l->IsMapped;
  283.    $l->MoveToplevelWindow($sdx+$r->rootx,$r->rooty);
  284.    $l->MapWindow unless ($l->IsMapped);
  285.    $l->XRaiseWindow;
  286.   }
  287.  else
  288.   {
  289.    $l->UnmapWindow;
  290.    my $s = $w->slave;
  291.    $s->GeometryRequest($s->Width+$dx,$s->Height) if (defined $s);
  292.   }
  293.  $w->idletasks;
  294. }
  295.  
  296. sub dHeight
  297. {
  298.  my ($w,$dy,$sdy,$down) = @_;
  299.  my $l = $w->{'lin'};
  300.  if ($down && $w->cget('-delay'))
  301.   {
  302.    my $r = $w->{'sep'};
  303.    $l->GeometryRequest($r->Width,1) unless $l->IsMapped;
  304.    $l->MoveToplevelWindow($r->rootx,$r->rooty+$sdy);
  305.    $l->MapWindow unless $l->IsMapped;
  306.    $l->XRaiseWindow;
  307.   }
  308.  else
  309.   {
  310.    $l->UnmapWindow;
  311.    my $s = $w->slave;
  312.    $s->GeometryRequest($s->Width,$s->Height+$dy) if (defined $s);
  313.   }
  314.  $w->idletasks;
  315. }
  316.  
  317.  
  318.  
  319.