tlperl 5.22.1 from siep

git-svn-id: svn://tug.org/texlive/trunk@40252 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 0 insertions, 438 deletions

diff --git a/Master/tlpkg/tlperl/lib/Tk/Adjuster.pm b/Master/tlpkg/tlperl/lib/Tk/Adjuster.pm
deleted file mode 100644
index bbe44f33dc8..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/Adjuster.pm
+++ /dev/null
@@ -1,438 +0,0 @@
-package Tk::Adjuster;
-
-use vars qw($VERSION);
-$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Adjuster.pm#7 $
-
-use base  qw(Tk::Frame);
-
-# We cannot do this :
-
-# Construct Tk::Widget 'packAdjust';
-
-# because if managed object is Derived (e.g. a Scrolled) then our 'new'
-# will be delegated and hierachy gets turned inside-out
-# So packAdjust is autoloaded in Widget.pm
-
-
-Construct Tk::Widget qw(Adjuster);
-
-{package Tk::Adjuster::Item;
-
-use strict;
-use base  qw(Tk::Frame);
-
-sub ClassInit
-{
- my ($class,$mw) = @_;
- $mw->bind($class,'<1>',['BDown', 1]);
- $mw->bind($class,'<Shift-1>',['BDown', 0]);
- $mw->bind($class,'<B1-Motion>',['Motion',1]);
- $mw->bind($class,'<Shift-B1-Motion>',['Motion',0]);
- $mw->bind($class,'<ButtonRelease-1>',['Motion',0]);
- return $class;
-}
-
-sub BDown
-{
- my($w, $delay_mask) = @_;
- $w->{'start_x'} = $w->XEvent->x;
- $w->{'start_y'} = $w->XEvent->y;
- my $adj  = $w->Parent;
- delete $adj->{'lin_info'};
- my $delay = $delay_mask && $adj->cget('-delay');
- if ($delay)
-  {
-    $adj->vert ? $adj->delta_width_bar(0) : $adj->delta_height_bar(0);
-  }
-}
-
-sub Motion
-{
- my($w, $delay_mask) = @_;
- my $ev = $w->XEvent;
- my $adj  = $w->Parent;
-
- my $delay = $delay_mask && $adj->cget('-delay');
- if ($adj->vert)
-  {
-    my $dx = $ev->x - $w->{'start_x'};
-    $delay ?  $adj->delta_width_bar($dx) : $adj->delta_width($dx);
-  }
- else
-  {
-    my $dy = $ev->y - $w->{'start_y'};
-    $delay ? $adj->delta_height_bar($dy) : $adj->delta_height($dy);
-  }
-}
-
-}
-
-
-
-sub packAfter
-{
- my ($w,$s,%args) = @_;
- my $side = $args{'-side'} ? $args{'-side'} : 'top';
- $w->configure(-side   => $side, -widget => $s);
- $w->packed($s, %args);
-}
-
-sub packForget
-{
- my ($w,$forget_slave) = @_;
- $w->Tk::Widget::packForget;
- $w->slave->packForget if $forget_slave;
-}
-
-# Called by Tk::Widget::packAdjust. It was here before packAfter was added
-sub packed
-{
- my ($w,$s,%args) = @_;
- delete $args{'-before'};
- delete $args{'-in'};
- $args{'-expand'} = 0;
- $args{'-after'} = $s;
- $args{'-fill'} = (($w->vert) ? 'y' : 'x');
- $w->pack(%args);
-}
-
-sub gridded
-{
- my ($w,$s,%args) = @_;
- # delete $args{'-before'};
- # $args{'-expand'} = 0;
- # $args{'-after'} = $s;
- # $args{'-fill'} = (($w->vert) ? 'y' : 'x');
- $w->grid(%args);
-}
-
-sub ClassInit
-{
- my ($class,$mw) = @_;
- $mw->bind($class,'<Configure>','SizeChange');
- $mw->bind($class,'<Unmap>','Restore');
- $mw->bind($class,'<Map>','Mapped');
- return $class;
-}
-
-sub SizeChange
-{
- my $w = shift;
- # reqwidth/height of Adjuster is stored here. If it is partially pushed out
- # of the window, then $w->width/height returns that of the visible part.
- if ($w->vert)
-  {
-   my $sx = ($w->Width - $w->{'sep'}->Width)/2;
-   $w->{'but'}->place('-x' => 0, '-y' => $w->Height-18);
-   $w->{'sep'}->place('-x' => $sx, '-y' => 0,  -relheight => 1);
-   $w->configure(-width => $w->{'but'}->ReqWidth);
-   $w->{'reqwidth'} = $w->reqwidth;
-  }
- else
-  {
-   my $sy = ($w->Height - $w->{'sep'}->Height)/2;
-   $w->{'but'}->place('-x' => $w->Width-18, '-y' => 0);
-   $w->{'sep'}->place('-x' => 0, '-y' => $sy,  -relwidth => 1);
-   $w->configure(-height => $w->{'but'}->ReqHeight);
-   $w->{'reqheight'} = $w->reqheight;
-  }
- # Turn off geometry propagation in the slave. Do only if necessary, as this
- # causes repacking.
- my $s = $w->slave;
- $s->packPropagate('0') if $s->packSlaves && $s->packPropagate();
- $s->gridPropagate('0') if $s->gridSlaves && $s->gridPropagate();
-}
-
-sub Mapped
-{
- my $w = shift;
- $w->idletasks;
- my $m = $w->manager;
- if ($m =~ /^(?:pack|grid)$/)
-  {
-   my %info = $w->$m('info');
-   my $master = $info{'-in'};
-   $master->$m('propagate',0);
-   $w->{'master'} = $master;
-  }
- $w->slave_expand_off;
-}
-
-sub Populate
-{
- my ($w,$args) = @_;
- $w->SUPER::Populate($args);
- $w->{'sep'} = Tk::Adjuster::Item->new($w,-bd => 1, -relief => 'sunken');
- $w->{'but'} = Tk::Adjuster::Item->new($w,-bd => 1, -width => 8, -height => 8, -relief => 'raised');
-
- # Force creation of Frame in widget's Toplevel. This makes a difference
- # where the widget's Toplevel has Delegates('Construct') set.
- # Need to explicitly set frame width to 0 for Win32
- my $l = $w->{'lin'} = Tk::Frame->new($w->toplevel, -bd => 0);
- # my $l = $w->{'lin'} = $w->toplevel->Frame(-bd => 0);
-
- my $cs = $w->ConfigSpecs(-widget => ['PASSIVE','widget','Widget',$w->Parent],
-                 -side       => ['METHOD','side','Side','top'],
-                 -delay      => ['PASSIVE','delay','Delay', 1],
-                 -background => [['SELF',$w->{'sep'},$w->{'but'}],'background','Background',undef],
-                 -foreground => [Tk::Configure->new($w->{'lin'},'-background'),'foreground','Foreground','black'],
-		 -restore    => ['PASSIVE','restore', 'Restore', 1],
-                );
- $w->_OnDestroy(qw(sep but lin master));
-}
-
-sub side
-{
- my ($w,$val) = @_;
- if (@_ > 1)
-  {
-   $w->{'side'} = $val;
-   my $cursor;
-   if ($w->vert)
-    {
-     $cursor = 'sb_h_double_arrow';
-     $w->{'sep'}->configure(-width => 2, -height => 10000);
-    }
-   else
-    {
-     $cursor = 'sb_v_double_arrow';
-     $w->{'sep'}->configure(-height => 2, -width => 10000);
-    }
-   my $x;
-   foreach $x ($w->{'sep'},$w->{'but'})
-    {
-     $x->configure(-cursor => $cursor);
-    }
-  }
- return $w->{'side'};
-}
-
-sub slave
-{
- my $w = shift;
- my $s = $w->cget('-widget');
- return $s;
-}
-
-sub vert
-{
- my $w = shift;
- my $side = $w->cget('-side');
- return  1 if $side eq 'left';
- return -1 if $side eq 'right';
- return  0;
-}
-
-# If the Adjuster gets unmapped, it attempts to restore itself. If its
-# slave is mapped, then it reduces the size of the slave so that there is
-# then room in the master for the Adjuster widget.
-sub Restore
-{
- my $w = shift;
- return if ! $w->toplevel->IsMapped ||
- 	   ! $w->slave->IsMapped ||
-	   ! $w->cget('-restore');
- $w->vert ? $w->delta_width(0) : $w->delta_height(0);
-}
-
-sub delta_width_bar
-{
- my ($w,$dx) = @_;
- my $l = $w->{'lin'};
- my $r = $w->{'sep'};
- my $t = $w->toplevel;
- my $m = $w->{'master'};
- my $s = $w->slave;
- my ($min_rootx, $max_rootx, $t_border);
- if (! $w->{'lin_info'})
-  {
-   my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
-   $t_border    = $t->cget('-bd') + $t->cget('-highlightthickness');
-   if ($w->cget('-side') eq 'right')
-    {
-     $min_rootx = $m->rootx + $m_border;
-     $max_rootx = $s->rootx + $s->width - 1;
-    }
-   else
-    {
-     $min_rootx = $s->rootx;
-     $max_rootx = $m->rootx + $m->width - $m_border - 1;
-    }
-   $w->{'lin_info'} = [$min_rootx, $max_rootx, $t_border];
-  }
-  else
-   {
-    ($min_rootx, $max_rootx, $t_border) = @{$w->{'lin_info'}};
-   }
- $l->configure(-width => 1, -height => $w->height) unless $l->IsMapped;
-
- my $new_rootx = $w->rootx + $w->{'reqwidth'}/2 + $dx;
- $new_rootx = $min_rootx if $new_rootx < $min_rootx;
- $new_rootx = $max_rootx if $new_rootx > $max_rootx;
- my $placex = $new_rootx - $t->rootx - $t_border;
- my $placey = $w->rooty  - $t->rooty - $t_border;
- $l->place(-in => $t, -anchor => 'n', '-x' => $placex, '-y' => $placey);
- my $this = $w->containing($new_rootx, $w->rooty + 1);
- $l->raise($this) if $this && $this ne $t;
-}
-
-sub delta_width
-{
- my ($w,$dx) = @_;
- my $l = $w->{'lin'};
- $l->placeForget;
- my $s = $w->slave;
- if ($s)
-  {
-   my $m = $w->{'master'};
-   my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
-   my $w_width = $w->{'reqwidth'};
-   my $m_width = $m->width;
-   my $s_width = $s->width;
-   my $max_width = $m_width - $w_width;
-   my $max_s_width;
-   if ($w->cget('-side') eq 'right')
-    {
-     $dx = -$dx;
-     $max_s_width = $max_width -
-		      ($m->rootx + $m_width - ($s->rootx+$s_width)) - $m_border;
-    }
-   else
-    {
-     $max_s_width = $max_width - ($s->rootx - $m->rootx) - $m_border;
-    }
-   my $new_width = $s_width+$dx;
-   $new_width = $max_s_width if $new_width > $max_s_width;
-   $new_width = 0 if $new_width < 0;
-   $s->GeometryRequest($new_width, $s->height);
-  }
-}
-
-sub delta_height_bar
-{
- my ($w,$dy) = @_;
- my $l = $w->{'lin'};
- my $r = $w->{'sep'};
- my $t = $w->toplevel;
- my $m = $w->{'master'};
- my $s = $w->slave;
- my ($min_rooty, $max_rooty, $t_border);
- if (! $w->{'lin_info'})
-  {
-   my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
-   $t_border    = $t->cget('-bd') + $t->cget('-highlightthickness');
-   if ($w->cget('-side') eq 'bottom')
-    {
-     $min_rooty = $m->rooty + $m_border;
-     $max_rooty = $s->rooty + $s->height - 1;
-    }
-   else
-    {
-     $min_rooty = $s->rooty;
-     $max_rooty = $m->rooty + $m->height - $m_border - 1;
-    }
-   $w->{'lin_info'} = [$min_rooty, $max_rooty, $t_border];
-  }
- else
-  {
-   ($min_rooty, $max_rooty, $t_border) = @{$w->{'lin_info'}};
-  }
- $l->configure(-height => 1, -width => $w->width) unless $l->IsMapped;
-
- my $new_rooty = $w->rooty + $w->{'reqheight'}/2 + $dy;
- $new_rooty = $min_rooty if $new_rooty < $min_rooty;
- $new_rooty = $max_rooty if $new_rooty > $max_rooty;
- my $placey = $new_rooty - $t->rooty - $t_border;
- my $placex = $w->rootx  - $t->rootx - $t_border;
- $l->place(-in => $t, -anchor => 'w', '-x' => $placex, '-y' => $placey);
- my $this = $w->containing($w->rootx + 1, $new_rooty);
- $l->raise($this) if $this && $this ne $t;
-}
-
-sub delta_height
-{
- my ($w,$dy) = @_;
- my $l = $w->{'lin'};
- $l->placeForget;
- my $s = $w->slave;
- if ($s)
-  {
-   my $m = $w->{'master'};
-   my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness');
-   my $w_height = $w->{'reqheight'};
-   my $m_height = $m->height;
-   my $s_height = $s->height;
-   my $max_height = $m_height - $w_height;
-   my $max_s_height;
-   if ($w->cget('-side') eq 'bottom')
-    {
-     $dy = -$dy;
-     $max_s_height = $max_height -
-		    ($m->rooty + $m_height - ($s->rooty+$s_height)) - $m_border;
-    }
-   else
-    {
-     $max_s_height = $max_height - ($s->rooty - $m->rooty) - $m_border;
-    }
-   my $new_height = $s_height+$dy;
-
-   $new_height = $max_s_height if $new_height > $max_s_height;
-   $new_height = 0 if $new_height < 0;
-   $s->GeometryRequest($s->width, $new_height);
-  }
-}
-
-# Turn off expansion in the slave.
-# This is done only if necessary, as calls to pack/gridConfigure cause
-# repacking.
-# Before call to pack/gridConfigure, the reqwidth/reqheight is set to the
-# current width/height. This is because the geometry managers use
-# the requested values, not the actual, to calculate the new geometry.
-sub slave_expand_off
-{
- my $w = shift;
- my $s = $w->slave;
- return if ! $s;
-
- my $manager = $s->manager;
- if ($manager eq 'pack')
-  {
-   my %info = $s->packInfo;
-   my $expand = $info{'-expand'};
-   if ($expand)
-    {
-     $s->GeometryRequest($s->width, $s->height);
-     $s->packConfigure(-expand => 0);
-    }
-  }
- elsif ($manager eq 'grid')
-  {
-   my %info = $s->gridInfo;
-   my $master = $info{'-in'};
-   if ($w->vert)
-    {
-     my $col = $info{'-column'};
-     my $expand = $master->gridColumnconfigure($col, '-weight');
-     if ($expand)
-      {
-       $s->GeometryRequest($s->width, $s->height);
-       $master->gridColumnconfigure($col, -weight => 0);
-      }
-    }
-   else
-    {
-     my $row = $info{'-row'};
-     my $expand = $master->gridRowconfigure($row, '-weight');
-     if ($expand)
-      {
-       $s->GeometryRequest($s->width, $s->height);
-       $master->gridRowconfigure($row, -weight => 0);
-      }
-    }
-  }
-}
-
-1;
-
-__END__
-