home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _784aaea48b75eb74d28cc86624735816 < prev    next >
Encoding:
Text File  |  2004-06-01  |  10.4 KB  |  430 lines
  1. # Conversion from Tk4.0 scrollbar.tcl competed.
  2. package Tk::Scrollbar;
  3.  
  4. use vars qw($VERSION);
  5. $VERSION = '4.010'; # $Id: //depot/Tkutf8/Scrollbar/Scrollbar.pm#10 $
  6.  
  7. use Tk qw($XS_VERSION Ev);
  8. use AutoLoader;
  9.  
  10. use base  qw(Tk::Widget);
  11.  
  12. #use strict;
  13. #use vars qw($pressX $pressY @initValues $initPos $activeBg);
  14.  
  15. Construct Tk::Widget 'Scrollbar';
  16.  
  17. bootstrap Tk::Scrollbar;
  18.  
  19. sub Tk_cmd { \&Tk::scrollbar }
  20.  
  21. Tk::Methods('activate','delta','fraction','get','identify','set');
  22.  
  23. sub Needed
  24. {
  25.  my ($sb) = @_;
  26.  my @val = $sb->get;
  27.  return 1 unless (@val == 2);
  28.  return 1 if $val[0] != 0.0;
  29.  return 1 if $val[1] != 1.0;
  30.  return 0;
  31. }
  32.  
  33.  
  34. sub ClassInit
  35. {
  36.  my ($class,$mw) = @_;
  37.  $mw->bind($class, '<Enter>', 'Enter');
  38.  $mw->bind($class, '<Motion>', 'Motion');
  39.  $mw->bind($class, '<Leave>', 'Leave');
  40.  
  41.  $mw->bind($class, '<1>', 'ButtonDown');
  42.  $mw->bind($class, '<B1-Motion>', ['Drag', Ev('x'), Ev('y')]);
  43.  $mw->bind($class, '<ButtonRelease-1>', 'ButtonUp');
  44.  $mw->bind($class, '<B1-Leave>', 'NoOp'); # prevent generic <Leave>
  45.  $mw->bind($class, '<B1-Enter>', 'NoOp'); # prevent generic <Enter>
  46.  $mw->bind($class, '<Control-1>', 'ScrlTopBottom');
  47.  
  48.  $mw->bind($class, '<2>', 'ButtonDown');
  49.  $mw->bind($class, '<B2-Motion>', ['Drag', Ev('x'), Ev('y')]);
  50.  $mw->bind($class, '<ButtonRelease-2>', 'ButtonUp');
  51.  $mw->bind($class, '<B2-Leave>', 'NoOp'); # prevent generic <Leave>
  52.  $mw->bind($class, '<B2-Enter>', 'NoOp'); # prevent generic <Enter>
  53.  $mw->bind($class, '<Control-2>', 'ScrlTopBottom');
  54.  
  55.  $mw->bind($class, '<Up>',            ['ScrlByUnits','v',-1]);
  56.  $mw->bind($class, '<Down>',          ['ScrlByUnits','v', 1]);
  57.  $mw->bind($class, '<Control-Up>',    ['ScrlByPages','v',-1]);
  58.  $mw->bind($class, '<Control-Down>',  ['ScrlByPages','v', 1]);
  59.  
  60.  $mw->bind($class, '<Left>',          ['ScrlByUnits','h',-1]);
  61.  $mw->bind($class, '<Right>',         ['ScrlByUnits','h', 1]);
  62.  $mw->bind($class, '<Control-Left>',  ['ScrlByPages','h',-1]);
  63.  $mw->bind($class, '<Control-Right>', ['ScrlByPages','h', 1]);
  64.  
  65.  $mw->bind($class, '<Prior>',         ['ScrlByPages','hv',-1]);
  66.  $mw->bind($class, '<Next>',          ['ScrlByPages','hv', 1]);
  67.  
  68.  # X11 mousewheel - honour for horizontal too.
  69.  $mw->bind($class, '<4>',             ['ScrlByUnits','hv',-5]);
  70.  $mw->bind($class, '<5>',             ['ScrlByUnits','hv', 5]);
  71.  
  72.  $mw->bind($class, '<Home>',          ['ScrlToPos', 0]);
  73.  $mw->bind($class, '<End>',           ['ScrlToPos', 1]);
  74.  
  75.  $mw->bind($class, '<4>',             ['ScrlByUnits','v',-3]);
  76.  $mw->bind($class, '<5>',             ['ScrlByUnits','v', 3]);
  77.  
  78.  return $class;
  79.  
  80. }
  81.  
  82. 1;
  83.  
  84. __END__
  85.  
  86. sub Enter
  87. {
  88.  my $w = shift;
  89.  my $e = $w->XEvent;
  90.  if ($Tk::strictMotif)
  91.   {
  92.    my $bg = $w->cget('-background');
  93.    $activeBg = $w->cget('-activebackground');
  94.    $w->configure('-activebackground' => $bg);
  95.   }
  96.  $w->activate($w->identify($e->x,$e->y));
  97. }
  98.  
  99. sub Leave
  100. {
  101.  my $w = shift;
  102.  if ($Tk::strictMotif)
  103.   {
  104.    $w->configure('-activebackground' => $activeBg) if (defined $activeBg) ;
  105.   }
  106.  $w->activate('');
  107. }
  108.  
  109. sub Motion
  110. {
  111.  my $w = shift;
  112.  my $e = $w->XEvent;
  113.  $w->activate($w->identify($e->x,$e->y));
  114. }
  115.  
  116. # tkScrollButtonDown --
  117. # This procedure is invoked when a button is pressed in a scrollbar.
  118. # It changes the way the scrollbar is displayed and takes actions
  119. # depending on where the mouse is.
  120. #
  121. # Arguments:
  122. # w -        The scrollbar widget.
  123. # x, y -    Mouse coordinates.
  124.  
  125. sub ButtonDown
  126. {my $w = shift;
  127.  my $e = $w->XEvent;
  128.  my $element = $w->identify($e->x,$e->y);
  129.  $w->configure('-activerelief' => 'sunken');
  130.  if ($e->b == 1 and
  131.      (defined($element) && $element eq 'slider'))
  132.   {
  133.    $w->StartDrag($e->x,$e->y);
  134.   }
  135.  elsif ($e->b == 2 and
  136.     (defined($element) && $element =~ /^(trough[12]|slider)$/o))
  137.   {
  138.     my $pos = $w->fraction($e->x, $e->y);
  139.     my($head, $tail) = $w->get;
  140.     my $len = $tail - $head;
  141.  
  142.     $head = $pos - $len/2;
  143.     $tail = $pos + $len/2;
  144.     if ($head < 0) {
  145.         $head = 0;
  146.         $tail = $len;
  147.     }
  148.     elsif ($tail > 1) {
  149.         $head = 1 - $len;
  150.         $tail = 1;
  151.     }
  152.     $w->ScrlToPos($head);
  153.     $w->set($head, $tail);
  154.  
  155.     $w->StartDrag($e->x,$e->y);
  156.    }
  157.  else
  158.   {
  159.    $w->Select($element,'initial');
  160.   }
  161. }
  162.  
  163. # tkScrollButtonUp --
  164. # This procedure is invoked when a button is released in a scrollbar.
  165. # It cancels scans and auto-repeats that were in progress, and restores
  166. # the way the active element is displayed.
  167. #
  168. # Arguments:
  169. # w -        The scrollbar widget.
  170. # x, y -    Mouse coordinates.
  171.  
  172. sub ButtonUp
  173. {my $w = shift;
  174.  my $e = $w->XEvent;
  175.  $w->CancelRepeat;
  176.  $w->configure('-activerelief' => 'raised');
  177.  $w->EndDrag($e->x,$e->y);
  178.  $w->activate($w->identify($e->x,$e->y));
  179. }
  180.  
  181. # tkScrollSelect --
  182. # This procedure is invoked when button 1 is pressed over the scrollbar.
  183. # It invokes one of several scrolling actions depending on where in
  184. # the scrollbar the button was pressed.
  185. #
  186. # Arguments:
  187. # w -        The scrollbar widget.
  188. # element -    The element of the scrollbar that was selected, such
  189. #        as "arrow1" or "trough2".  Shouldn't be "slider".
  190. # repeat -    Whether and how to auto-repeat the action:  "noRepeat"
  191. #        means don't auto-repeat, "initial" means this is the
  192. #        first action in an auto-repeat sequence, and "again"
  193. #        means this is the second repetition or later.
  194.  
  195. sub Select
  196. {
  197.  my $w = shift;
  198.  my $element = shift;
  199.  my $repeat  = shift;
  200.  return unless defined ($element);
  201.  if ($element eq 'arrow1')
  202.   {
  203.    $w->ScrlByUnits('hv',-1);
  204.   }
  205.  elsif ($element eq 'trough1')
  206.   {
  207.    $w->ScrlByPages('hv',-1);
  208.   }
  209.  elsif ($element eq 'trough2')
  210.   {
  211.    $w->ScrlByPages('hv', 1);
  212.   }
  213.  elsif ($element eq 'arrow2')
  214.   {
  215.    $w->ScrlByUnits('hv', 1);
  216.   }
  217.  else
  218.   {
  219.    return;
  220.   }
  221.  
  222.  if ($repeat eq 'again')
  223.   {
  224.    $w->RepeatId($w->after($w->cget('-repeatinterval'),['Select',$w,$element,'again']));
  225.   }
  226.  elsif ($repeat eq 'initial')
  227.   {
  228.    $w->RepeatId($w->after($w->cget('-repeatdelay'),['Select',$w,$element,'again']));
  229.   }
  230. }
  231.  
  232. # tkScrollStartDrag --
  233. # This procedure is called to initiate a drag of the slider.  It just
  234. # remembers the starting position of the slider.
  235. #
  236. # Arguments:
  237. # w -        The scrollbar widget.
  238. # x, y -    The mouse position at the start of the drag operation.
  239.  
  240. sub StartDrag
  241. {
  242.  my($w,$x,$y) = @_;
  243.  return unless (defined ($w->cget('-command')));
  244.  $pressX = $x;
  245.  $pressY = $y;
  246.  @initValues = $w->get;
  247.  my $iv0 = $initValues[0];
  248.  if (@initValues == 2)
  249.   {
  250.    $initPos = $iv0;
  251.   }
  252.  elsif ($iv0 == 0)
  253.   {
  254.    $initPos = 0;
  255.   }
  256.  else
  257.   {
  258.    $initPos = $initValues[2]/$initValues[0];
  259.   }
  260. }
  261.  
  262. # tkScrollDrag --
  263. # This procedure is called for each mouse motion even when the slider
  264. # is being dragged.  It notifies the associated widget if we're not
  265. # jump scrolling, and it just updates the scrollbar if we are jump
  266. # scrolling.
  267. #
  268. # Arguments:
  269. # w -        The scrollbar widget.
  270. # x, y -    The current mouse position.
  271.  
  272. sub Drag
  273. {
  274.  my($w,$x,$y) = @_;
  275.  return if !defined $initPos;
  276.  my $delta = $w->delta($x-$pressX, $y-$pressY);
  277.  if ($w->cget('-jump'))
  278.   {
  279.    if (@initValues == 2)
  280.     {
  281.      $w->set($initValues[0]+$delta, $initValues[1]+$delta);
  282.     }
  283.    else
  284.     {
  285.      $delta = sprintf "%d", $delta * $initValues[0]; # round()
  286.      $initValues[2] += $delta;
  287.      $initValues[3] += $delta;
  288.      $w->set(@initValues[2,3]);
  289.     }
  290.   }
  291.  else
  292.   {
  293.    $w->ScrlToPos($initPos+$delta);
  294.   }
  295. }
  296.  
  297. # tkScrollEndDrag --
  298. # This procedure is called to end an interactive drag of the slider.
  299. # It scrolls the window if we're in jump mode, otherwise it does nothing.
  300. #
  301. # Arguments:
  302. # w -        The scrollbar widget.
  303. # x, y -    The mouse position at the end of the drag operation.
  304.  
  305. sub EndDrag
  306. {
  307.  my($w,$x,$y) = @_;
  308.  return if (!defined $initPos);
  309.  if ($w->cget('-jump'))
  310.   {
  311.    my $delta = $w->delta($x-$pressX, $y-$pressY);
  312.    $w->ScrlToPos($initPos+$delta);
  313.   }
  314.  undef $initPos;
  315. }
  316.  
  317. # tkScrlByUnits --
  318. # This procedure tells the scrollbar's associated widget to scroll up
  319. # or down by a given number of units.  It notifies the associated widget
  320. # in different ways for old and new command syntaxes.
  321. #
  322. # Arguments:
  323. # w -        The scrollbar widget.
  324. # orient -    Which kinds of scrollbars this applies to:  "h" for
  325. #        horizontal, "v" for vertical, "hv" for both.
  326. # amount -    How many units to scroll:  typically 1 or -1.
  327.  
  328. sub ScrlByUnits
  329. {my $w = shift;
  330.  my $orient = shift;
  331.  my $amount = shift;
  332.  my $cmd    = $w->cget('-command');
  333.  return unless (defined $cmd);
  334.  return if (index($orient,substr($w->cget('-orient'),0,1)) < 0);
  335.  my @info = $w->get;
  336.  if (@info == 2)
  337.   {
  338.    $cmd->Call('scroll',$amount,'units');
  339.   }
  340.  else
  341.   {
  342.    $cmd->Call($info[2]+$amount);
  343.   }
  344. }
  345.  
  346. # tkScrlByPages --
  347. # This procedure tells the scrollbar's associated widget to scroll up
  348. # or down by a given number of screenfuls.  It notifies the associated
  349. # widget in different ways for old and new command syntaxes.
  350. #
  351. # Arguments:
  352. # w -        The scrollbar widget.
  353. # orient -    Which kinds of scrollbars this applies to:  "h" for
  354. #        horizontal, "v" for vertical, "hv" for both.
  355. # amount -    How many screens to scroll:  typically 1 or -1.
  356.  
  357. sub ScrlByPages
  358. {
  359.  my $w = shift;
  360.  my $orient = shift;
  361.  my $amount = shift;
  362.  my $cmd    = $w->cget('-command');
  363.  return unless (defined $cmd);
  364.  return if (index($orient,substr($w->cget('-orient'),0,1)) < 0);
  365.  my @info = $w->get;
  366.  if (@info == 2)
  367.   {
  368.    $cmd->Call('scroll',$amount,'pages');
  369.   }
  370.  else
  371.   {
  372.    $cmd->Call($info[2]+$amount*($info[1]-1));
  373.   }
  374. }
  375.  
  376. # tkScrlToPos --
  377. # This procedure tells the scrollbar's associated widget to scroll to
  378. # a particular location, given by a fraction between 0 and 1.  It notifies
  379. # the associated widget in different ways for old and new command syntaxes.
  380. #
  381. # Arguments:
  382. # w -        The scrollbar widget.
  383. # pos -        A fraction between 0 and 1 indicating a desired position
  384. #        in the document.
  385.  
  386. sub ScrlToPos
  387. {
  388.  my $w = shift;
  389.  my $pos = shift;
  390.  my $cmd = $w->cget('-command');
  391.  return unless (defined $cmd);
  392.  my @info = $w->get;
  393.  if (@info == 2)
  394.   {
  395.    $cmd->Call('moveto',$pos);
  396.   }
  397.  else
  398.   {
  399.    $cmd->Call(int($info[0]*$pos));
  400.   }
  401. }
  402.  
  403. # tkScrlTopBottom
  404. # Scroll to the top or bottom of the document, depending on the mouse
  405. # position.
  406. #
  407. # Arguments:
  408. # w -        The scrollbar widget.
  409. # x, y -    Mouse coordinates within the widget.
  410.  
  411. sub ScrlTopBottom
  412. {
  413.  my $w = shift;
  414.  my $e = $w->XEvent;
  415.  my $element = $w->identify($e->x,$e->y);
  416.  return unless ($element);
  417.  if ($element =~ /1$/)
  418.   {
  419.    $w->ScrlToPos(0);
  420.   }
  421.  elsif ($element =~ /2$/)
  422.   {
  423.    $w->ScrlToPos(1);
  424.   }
  425. }
  426.  
  427.  
  428.  
  429.  
  430.