"Fossies" - the Fresh Open Source Software Archive

Member "Tk-804.036/Tk/Adjuster.pm" (15 Nov 2013, 11173 Bytes) of package /linux/misc/Tk-804.036.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Adjuster.pm" see the Fossies "Dox" file reference documentation.

    1 package Tk::Adjuster;
    2 
    3 use vars qw($VERSION);
    4 $VERSION = '4.008'; # $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  # Force creation of Frame in widget's Toplevel. This makes a difference
  169  # where the widget's Toplevel has Delegates('Construct') set.
  170  # Need to explicitly set frame width to 0 for Win32
  171  my $l = $w->{'lin'} = Tk::Frame->new($w->toplevel, -bd => 0);
  172  # my $l = $w->{'lin'} = $w->toplevel->Frame(-bd => 0);
  173 
  174  my $cs = $w->ConfigSpecs(-widget => ['PASSIVE','widget','Widget',$w->Parent],
  175                  -side       => ['METHOD','side','Side','top'],
  176                  -delay      => ['PASSIVE','delay','Delay', 1],
  177                  -background => [['SELF',$w->{'sep'},$w->{'but'}],'background','Background',undef],
  178                  -foreground => [Tk::Configure->new($w->{'lin'},'-background'),'foreground','Foreground','black'],
  179          -restore    => ['PASSIVE','restore', 'Restore', 1],
  180                 );
  181  $w->_OnDestroy(qw(sep but lin master));
  182 }
  183 
  184 sub side
  185 {
  186  my ($w,$val) = @_;
  187  if (@_ > 1)
  188   {
  189    $w->{'side'} = $val;
  190    my $cursor;
  191    if ($w->vert)
  192     {
  193      $cursor = 'sb_h_double_arrow';
  194      $w->{'sep'}->configure(-width => 2, -height => 10000);
  195     }
  196    else
  197     {
  198      $cursor = 'sb_v_double_arrow';
  199      $w->{'sep'}->configure(-height => 2, -width => 10000);
  200     }
  201    my $x;
  202    foreach $x ($w->{'sep'},$w->{'but'})
  203     {
  204      $x->configure(-cursor => $cursor);
  205     }
  206   }
  207  return $w->{'side'};
  208 }
  209 
  210 sub slave
  211 {
  212  my $w = shift;
  213  my $s = $w->cget('-widget');
  214  return $s;
  215 }
  216 
  217 sub vert
  218 {
  219  my $w = shift;
  220  my $side = $w->cget('-side');
  221  return  1 if $side eq 'left';
  222  return -1 if $side eq 'right';
  223  return  0;
  224 }
  225 
  226 # If the Adjuster gets unmapped, it attempts to restore itself. If its
  227 # slave is mapped, then it reduces the size of the slave so that there is
  228 # then room in the master for the Adjuster widget.
  229 sub Restore
  230 {
  231  my $w = shift;
  232  return if ! $w->toplevel->IsMapped ||
  233        ! $w->slave->IsMapped ||
  234        ! $w->cget('-restore');
  235  $w->vert ? $w->delta_width(0) : $w->delta_height(0);
  236 }
  237 
  238 sub delta_width_bar
  239 {
  240  my ($w,$dx) = @_;
  241  my $l = $w->{'lin'};
  242  my $r = $w->{'sep'};
  243  my $t = $w->toplevel;
  244  my $m = $w->{'master'};
  245  my $s = $w->slave;
  246  my ($min_rootx, $max_rootx, $t_border);
  247  if (! $w->{'lin_info'})
  248   {
  249    my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
  250    $t_border    = $t->cget('-bd') + $t->cget('-highlightthickness');
  251    if ($w->cget('-side') eq 'right')
  252     {
  253      $min_rootx = $m->rootx + $m_border;
  254      $max_rootx = $s->rootx + $s->width - 1;
  255     }
  256    else
  257     {
  258      $min_rootx = $s->rootx;
  259      $max_rootx = $m->rootx + $m->width - $m_border - 1;
  260     }
  261    $w->{'lin_info'} = [$min_rootx, $max_rootx, $t_border];
  262   }
  263   else
  264    {
  265     ($min_rootx, $max_rootx, $t_border) = @{$w->{'lin_info'}};
  266    }
  267  $l->configure(-width => 1, -height => $w->height) unless $l->IsMapped;
  268 
  269  my $new_rootx = $w->rootx + $w->{'reqwidth'}/2 + $dx;
  270  $new_rootx = $min_rootx if $new_rootx < $min_rootx;
  271  $new_rootx = $max_rootx if $new_rootx > $max_rootx;
  272  my $placex = $new_rootx - $t->rootx - $t_border;
  273  my $placey = $w->rooty  - $t->rooty - $t_border;
  274  $l->place(-in => $t, -anchor => 'n', '-x' => $placex, '-y' => $placey);
  275  my $this = $w->containing($new_rootx, $w->rooty + 1);
  276  $l->raise($this) if $this && $this ne $t;
  277 }
  278 
  279 sub delta_width
  280 {
  281  my ($w,$dx) = @_;
  282  my $l = $w->{'lin'};
  283  $l->placeForget;
  284  my $s = $w->slave;
  285  if ($s)
  286   {
  287    my $m = $w->{'master'};
  288    my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
  289    my $w_width = $w->{'reqwidth'};
  290    my $m_width = $m->width;
  291    my $s_width = $s->width;
  292    my $max_width = $m_width - $w_width;
  293    my $max_s_width;
  294    if ($w->cget('-side') eq 'right')
  295     {
  296      $dx = -$dx;
  297      $max_s_width = $max_width -
  298               ($m->rootx + $m_width - ($s->rootx+$s_width)) - $m_border;
  299     }
  300    else
  301     {
  302      $max_s_width = $max_width - ($s->rootx - $m->rootx) - $m_border;
  303     }
  304    my $new_width = $s_width+$dx;
  305    $new_width = $max_s_width if $new_width > $max_s_width;
  306    $new_width = 0 if $new_width < 0;
  307    $s->GeometryRequest($new_width, $s->height);
  308   }
  309 }
  310 
  311 sub delta_height_bar
  312 {
  313  my ($w,$dy) = @_;
  314  my $l = $w->{'lin'};
  315  my $r = $w->{'sep'};
  316  my $t = $w->toplevel;
  317  my $m = $w->{'master'};
  318  my $s = $w->slave;
  319  my ($min_rooty, $max_rooty, $t_border);
  320  if (! $w->{'lin_info'})
  321   {
  322    my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
  323    $t_border    = $t->cget('-bd') + $t->cget('-highlightthickness');
  324    if ($w->cget('-side') eq 'bottom')
  325     {
  326      $min_rooty = $m->rooty + $m_border;
  327      $max_rooty = $s->rooty + $s->height - 1;
  328     }
  329    else
  330     {
  331      $min_rooty = $s->rooty;
  332      $max_rooty = $m->rooty + $m->height - $m_border - 1;
  333     }
  334    $w->{'lin_info'} = [$min_rooty, $max_rooty, $t_border];
  335   }
  336  else
  337   {
  338    ($min_rooty, $max_rooty, $t_border) = @{$w->{'lin_info'}};
  339   }
  340  $l->configure(-height => 1, -width => $w->width) unless $l->IsMapped;
  341 
  342  my $new_rooty = $w->rooty + $w->{'reqheight'}/2 + $dy;
  343  $new_rooty = $min_rooty if $new_rooty < $min_rooty;
  344  $new_rooty = $max_rooty if $new_rooty > $max_rooty;
  345  my $placey = $new_rooty - $t->rooty - $t_border;
  346  my $placex = $w->rootx  - $t->rootx - $t_border;
  347  $l->place(-in => $t, -anchor => 'w', '-x' => $placex, '-y' => $placey);
  348  my $this = $w->containing($w->rootx + 1, $new_rooty);
  349  $l->raise($this) if $this && $this ne $t;
  350 }
  351 
  352 sub delta_height
  353 {
  354  my ($w,$dy) = @_;
  355  my $l = $w->{'lin'};
  356  $l->placeForget;
  357  my $s = $w->slave;
  358  if ($s)
  359   {
  360    my $m = $w->{'master'};
  361    my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
  362    my $w_height = $w->{'reqheight'};
  363    my $m_height = $m->height;
  364    my $s_height = $s->height;
  365    my $max_height = $m_height - $w_height;
  366    my $max_s_height;
  367    if ($w->cget('-side') eq 'bottom')
  368     {
  369      $dy = -$dy;
  370      $max_s_height = $max_height -
  371             ($m->rooty + $m_height - ($s->rooty+$s_height)) - $m_border;
  372     }
  373    else
  374     {
  375      $max_s_height = $max_height - ($s->rooty - $m->rooty) - $m_border;
  376     }
  377    my $new_height = $s_height+$dy;
  378 
  379    $new_height = $max_s_height if $new_height > $max_s_height;
  380    $new_height = 0 if $new_height < 0;
  381    $s->GeometryRequest($s->width, $new_height);
  382   }
  383 }
  384 
  385 # Turn off expansion in the slave.
  386 # This is done only if necessary, as calls to pack/gridConfigure cause
  387 # repacking.
  388 # Before call to pack/gridConfigure, the reqwidth/reqheight is set to the
  389 # current width/height. This is because the geometry managers use
  390 # the requested values, not the actual, to calculate the new geometry.
  391 sub slave_expand_off
  392 {
  393  my $w = shift;
  394  my $s = $w->slave;
  395  return if ! $s;
  396 
  397  my $manager = $s->manager;
  398  if ($manager eq 'pack')
  399   {
  400    my %info = $s->packInfo;
  401    my $expand = $info{'-expand'};
  402    if ($expand)
  403     {
  404      $s->GeometryRequest($s->width, $s->height);
  405      $s->packConfigure(-expand => 0);
  406     }
  407   }
  408  elsif ($manager eq 'grid')
  409   {
  410    my %info = $s->gridInfo;
  411    my $master = $info{'-in'};
  412    if ($w->vert)
  413     {
  414      my $col = $info{'-column'};
  415      my $expand = $master->gridColumnconfigure($col, '-weight');
  416      if ($expand)
  417       {
  418        $s->GeometryRequest($s->width, $s->height);
  419        $master->gridColumnconfigure($col, -weight => 0);
  420       }
  421     }
  422    else
  423     {
  424      my $row = $info{'-row'};
  425      my $expand = $master->gridRowconfigure($row, '-weight');
  426      if ($expand)
  427       {
  428        $s->GeometryRequest($s->width, $s->height);
  429        $master->gridRowconfigure($row, -weight => 0);
  430       }
  431     }
  432   }
  433 }
  434 
  435 1;
  436 
  437 __END__
  438