summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm429
1 files changed, 0 insertions, 429 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm b/Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm
deleted file mode 100644
index 6b416e04b30..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/Scrollbar.pm
+++ /dev/null
@@ -1,429 +0,0 @@
-# Conversion from Tk4.0 scrollbar.tcl competed.
-package Tk::Scrollbar;
-
-use vars qw($VERSION);
-$VERSION = '4.010'; # $Id: //depot/Tkutf8/Scrollbar/Scrollbar.pm#10 $
-
-use Tk qw($XS_VERSION Ev);
-use AutoLoader;
-
-use base qw(Tk::Widget);
-
-#use strict;
-#use vars qw($pressX $pressY @initValues $initPos $activeBg);
-
-Construct Tk::Widget 'Scrollbar';
-
-bootstrap Tk::Scrollbar;
-
-sub Tk_cmd { \&Tk::scrollbar }
-
-Tk::Methods('activate','delta','fraction','get','identify','set');
-
-sub Needed
-{
- my ($sb) = @_;
- my @val = $sb->get;
- return 1 unless (@val == 2);
- return 1 if $val[0] != 0.0;
- return 1 if $val[1] != 1.0;
- return 0;
-}
-
-
-sub ClassInit
-{
- my ($class,$mw) = @_;
- $mw->bind($class, '<Enter>', 'Enter');
- $mw->bind($class, '<Motion>', 'Motion');
- $mw->bind($class, '<Leave>', 'Leave');
-
- $mw->bind($class, '<1>', 'ButtonDown');
- $mw->bind($class, '<B1-Motion>', ['Drag', Ev('x'), Ev('y')]);
- $mw->bind($class, '<ButtonRelease-1>', 'ButtonUp');
- $mw->bind($class, '<B1-Leave>', 'NoOp'); # prevent generic <Leave>
- $mw->bind($class, '<B1-Enter>', 'NoOp'); # prevent generic <Enter>
- $mw->bind($class, '<Control-1>', 'ScrlTopBottom');
-
- $mw->bind($class, '<2>', 'ButtonDown');
- $mw->bind($class, '<B2-Motion>', ['Drag', Ev('x'), Ev('y')]);
- $mw->bind($class, '<ButtonRelease-2>', 'ButtonUp');
- $mw->bind($class, '<B2-Leave>', 'NoOp'); # prevent generic <Leave>
- $mw->bind($class, '<B2-Enter>', 'NoOp'); # prevent generic <Enter>
- $mw->bind($class, '<Control-2>', 'ScrlTopBottom');
-
- $mw->bind($class, '<Up>', ['ScrlByUnits','v',-1]);
- $mw->bind($class, '<Down>', ['ScrlByUnits','v', 1]);
- $mw->bind($class, '<Control-Up>', ['ScrlByPages','v',-1]);
- $mw->bind($class, '<Control-Down>', ['ScrlByPages','v', 1]);
-
- $mw->bind($class, '<Left>', ['ScrlByUnits','h',-1]);
- $mw->bind($class, '<Right>', ['ScrlByUnits','h', 1]);
- $mw->bind($class, '<Control-Left>', ['ScrlByPages','h',-1]);
- $mw->bind($class, '<Control-Right>', ['ScrlByPages','h', 1]);
-
- $mw->bind($class, '<Prior>', ['ScrlByPages','hv',-1]);
- $mw->bind($class, '<Next>', ['ScrlByPages','hv', 1]);
-
- # X11 mousewheel - honour for horizontal too.
- $mw->bind($class, '<4>', ['ScrlByUnits','hv',-5]);
- $mw->bind($class, '<5>', ['ScrlByUnits','hv', 5]);
-
- $mw->bind($class, '<Home>', ['ScrlToPos', 0]);
- $mw->bind($class, '<End>', ['ScrlToPos', 1]);
-
- $mw->bind($class, '<4>', ['ScrlByUnits','v',-3]);
- $mw->bind($class, '<5>', ['ScrlByUnits','v', 3]);
-
- return $class;
-
-}
-
-1;
-
-__END__
-
-sub Enter
-{
- my $w = shift;
- my $e = $w->XEvent;
- if ($Tk::strictMotif)
- {
- my $bg = $w->cget('-background');
- $activeBg = $w->cget('-activebackground');
- $w->configure('-activebackground' => $bg);
- }
- $w->activate($w->identify($e->x,$e->y));
-}
-
-sub Leave
-{
- my $w = shift;
- if ($Tk::strictMotif)
- {
- $w->configure('-activebackground' => $activeBg) if (defined $activeBg) ;
- }
- $w->activate('');
-}
-
-sub Motion
-{
- my $w = shift;
- my $e = $w->XEvent;
- $w->activate($w->identify($e->x,$e->y));
-}
-
-# tkScrollButtonDown --
-# This procedure is invoked when a button is pressed in a scrollbar.
-# It changes the way the scrollbar is displayed and takes actions
-# depending on where the mouse is.
-#
-# Arguments:
-# w - The scrollbar widget.
-# x, y - Mouse coordinates.
-
-sub ButtonDown
-{my $w = shift;
- my $e = $w->XEvent;
- my $element = $w->identify($e->x,$e->y);
- $w->configure('-activerelief' => 'sunken');
- if ($e->b == 1 and
- (defined($element) && $element eq 'slider'))
- {
- $w->StartDrag($e->x,$e->y);
- }
- elsif ($e->b == 2 and
- (defined($element) && $element =~ /^(trough[12]|slider)$/o))
- {
- my $pos = $w->fraction($e->x, $e->y);
- my($head, $tail) = $w->get;
- my $len = $tail - $head;
-
- $head = $pos - $len/2;
- $tail = $pos + $len/2;
- if ($head < 0) {
- $head = 0;
- $tail = $len;
- }
- elsif ($tail > 1) {
- $head = 1 - $len;
- $tail = 1;
- }
- $w->ScrlToPos($head);
- $w->set($head, $tail);
-
- $w->StartDrag($e->x,$e->y);
- }
- else
- {
- $w->Select($element,'initial');
- }
-}
-
-# tkScrollButtonUp --
-# This procedure is invoked when a button is released in a scrollbar.
-# It cancels scans and auto-repeats that were in progress, and restores
-# the way the active element is displayed.
-#
-# Arguments:
-# w - The scrollbar widget.
-# x, y - Mouse coordinates.
-
-sub ButtonUp
-{my $w = shift;
- my $e = $w->XEvent;
- $w->CancelRepeat;
- $w->configure('-activerelief' => 'raised');
- $w->EndDrag($e->x,$e->y);
- $w->activate($w->identify($e->x,$e->y));
-}
-
-# tkScrollSelect --
-# This procedure is invoked when button 1 is pressed over the scrollbar.
-# It invokes one of several scrolling actions depending on where in
-# the scrollbar the button was pressed.
-#
-# Arguments:
-# w - The scrollbar widget.
-# element - The element of the scrollbar that was selected, such
-# as "arrow1" or "trough2". Shouldn't be "slider".
-# repeat - Whether and how to auto-repeat the action: "noRepeat"
-# means don't auto-repeat, "initial" means this is the
-# first action in an auto-repeat sequence, and "again"
-# means this is the second repetition or later.
-
-sub Select
-{
- my $w = shift;
- my $element = shift;
- my $repeat = shift;
- return unless defined ($element);
- if ($element eq 'arrow1')
- {
- $w->ScrlByUnits('hv',-1);
- }
- elsif ($element eq 'trough1')
- {
- $w->ScrlByPages('hv',-1);
- }
- elsif ($element eq 'trough2')
- {
- $w->ScrlByPages('hv', 1);
- }
- elsif ($element eq 'arrow2')
- {
- $w->ScrlByUnits('hv', 1);
- }
- else
- {
- return;
- }
-
- if ($repeat eq 'again')
- {
- $w->RepeatId($w->after($w->cget('-repeatinterval'),['Select',$w,$element,'again']));
- }
- elsif ($repeat eq 'initial')
- {
- $w->RepeatId($w->after($w->cget('-repeatdelay'),['Select',$w,$element,'again']));
- }
-}
-
-# tkScrollStartDrag --
-# This procedure is called to initiate a drag of the slider. It just
-# remembers the starting position of the slider.
-#
-# Arguments:
-# w - The scrollbar widget.
-# x, y - The mouse position at the start of the drag operation.
-
-sub StartDrag
-{
- my($w,$x,$y) = @_;
- return unless (defined ($w->cget('-command')));
- $pressX = $x;
- $pressY = $y;
- @initValues = $w->get;
- my $iv0 = $initValues[0];
- if (@initValues == 2)
- {
- $initPos = $iv0;
- }
- elsif ($iv0 == 0)
- {
- $initPos = 0;
- }
- else
- {
- $initPos = $initValues[2]/$initValues[0];
- }
-}
-
-# tkScrollDrag --
-# This procedure is called for each mouse motion even when the slider
-# is being dragged. It notifies the associated widget if we're not
-# jump scrolling, and it just updates the scrollbar if we are jump
-# scrolling.
-#
-# Arguments:
-# w - The scrollbar widget.
-# x, y - The current mouse position.
-
-sub Drag
-{
- my($w,$x,$y) = @_;
- return if !defined $initPos;
- my $delta = $w->delta($x-$pressX, $y-$pressY);
- if ($w->cget('-jump'))
- {
- if (@initValues == 2)
- {
- $w->set($initValues[0]+$delta, $initValues[1]+$delta);
- }
- else
- {
- $delta = sprintf "%d", $delta * $initValues[0]; # round()
- $initValues[2] += $delta;
- $initValues[3] += $delta;
- $w->set(@initValues[2,3]);
- }
- }
- else
- {
- $w->ScrlToPos($initPos+$delta);
- }
-}
-
-# tkScrollEndDrag --
-# This procedure is called to end an interactive drag of the slider.
-# It scrolls the window if we're in jump mode, otherwise it does nothing.
-#
-# Arguments:
-# w - The scrollbar widget.
-# x, y - The mouse position at the end of the drag operation.
-
-sub EndDrag
-{
- my($w,$x,$y) = @_;
- return if (!defined $initPos);
- if ($w->cget('-jump'))
- {
- my $delta = $w->delta($x-$pressX, $y-$pressY);
- $w->ScrlToPos($initPos+$delta);
- }
- undef $initPos;
-}
-
-# tkScrlByUnits --
-# This procedure tells the scrollbar's associated widget to scroll up
-# or down by a given number of units. It notifies the associated widget
-# in different ways for old and new command syntaxes.
-#
-# Arguments:
-# w - The scrollbar widget.
-# orient - Which kinds of scrollbars this applies to: "h" for
-# horizontal, "v" for vertical, "hv" for both.
-# amount - How many units to scroll: typically 1 or -1.
-
-sub ScrlByUnits
-{my $w = shift;
- my $orient = shift;
- my $amount = shift;
- my $cmd = $w->cget('-command');
- return unless (defined $cmd);
- return if (index($orient,substr($w->cget('-orient'),0,1)) < 0);
- my @info = $w->get;
- if (@info == 2)
- {
- $cmd->Call('scroll',$amount,'units');
- }
- else
- {
- $cmd->Call($info[2]+$amount);
- }
-}
-
-# tkScrlByPages --
-# This procedure tells the scrollbar's associated widget to scroll up
-# or down by a given number of screenfuls. It notifies the associated
-# widget in different ways for old and new command syntaxes.
-#
-# Arguments:
-# w - The scrollbar widget.
-# orient - Which kinds of scrollbars this applies to: "h" for
-# horizontal, "v" for vertical, "hv" for both.
-# amount - How many screens to scroll: typically 1 or -1.
-
-sub ScrlByPages
-{
- my $w = shift;
- my $orient = shift;
- my $amount = shift;
- my $cmd = $w->cget('-command');
- return unless (defined $cmd);
- return if (index($orient,substr($w->cget('-orient'),0,1)) < 0);
- my @info = $w->get;
- if (@info == 2)
- {
- $cmd->Call('scroll',$amount,'pages');
- }
- else
- {
- $cmd->Call($info[2]+$amount*($info[1]-1));
- }
-}
-
-# tkScrlToPos --
-# This procedure tells the scrollbar's associated widget to scroll to
-# a particular location, given by a fraction between 0 and 1. It notifies
-# the associated widget in different ways for old and new command syntaxes.
-#
-# Arguments:
-# w - The scrollbar widget.
-# pos - A fraction between 0 and 1 indicating a desired position
-# in the document.
-
-sub ScrlToPos
-{
- my $w = shift;
- my $pos = shift;
- my $cmd = $w->cget('-command');
- return unless (defined $cmd);
- my @info = $w->get;
- if (@info == 2)
- {
- $cmd->Call('moveto',$pos);
- }
- else
- {
- $cmd->Call(int($info[0]*$pos));
- }
-}
-
-# tkScrlTopBottom
-# Scroll to the top or bottom of the document, depending on the mouse
-# position.
-#
-# Arguments:
-# w - The scrollbar widget.
-# x, y - Mouse coordinates within the widget.
-
-sub ScrlTopBottom
-{
- my $w = shift;
- my $e = $w->XEvent;
- my $element = $w->identify($e->x,$e->y);
- return unless ($element);
- if ($element =~ /1$/)
- {
- $w->ScrlToPos(0);
- }
- elsif ($element =~ /2$/)
- {
- $w->ScrlToPos(1);
- }
-}
-
-
-
-