summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Adjuster.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Adjuster.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Adjuster.pm436
1 files changed, 0 insertions, 436 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Adjuster.pm b/Master/tlpkg/tlperl/lib/Tk/Adjuster.pm
deleted file mode 100644
index 382ec6db6f9..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/Adjuster.pm
+++ /dev/null
@@ -1,436 +0,0 @@
-package Tk::Adjuster;
-
-use vars qw($VERSION);
-$VERSION = '4.007'; # $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');
-
- # Need to explicitly set frame width to 0 for Win32
- 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__
-
-=cut #' emacs hilighting...