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