home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _ac76c2c8f5b29931925b131bbb9851dd < prev    next >
Encoding:
Text File  |  2004-06-01  |  6.9 KB  |  279 lines
  1. # Converted from scale.tcl --
  2. #
  3. # This file defines the default bindings for Tk scale widgets.
  4. #
  5. # @(#) scale.tcl 1.3 94/12/17 16:05:23
  6. #
  7. # Copyright (c) 1994 The Regents of the University of California.
  8. # Copyright (c) 1994 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  
  13. package Tk::Scale;
  14.  
  15. use vars qw($VERSION);
  16. $VERSION = '4.004'; # $Id: //depot/Tkutf8/Scale/Scale.pm#4 $
  17.  
  18. use Tk qw($XS_VERSION);
  19. use AutoLoader;
  20.  
  21. use base  qw(Tk::Widget);
  22.  
  23. Construct Tk::Widget 'Scale';
  24.  
  25. bootstrap Tk::Scale;
  26.  
  27. sub Tk_cmd { \&Tk::scale }
  28.  
  29. Tk::Methods('coords','get','identify','set');
  30.  
  31.  
  32. import Tk qw(Ev);
  33.  
  34. #
  35. # Bind --
  36. # This procedure below invoked the first time the mouse enters a
  37. # scale widget or a scale widget receives the input focus. It creates
  38. # all of the class bindings for scales.
  39. #
  40. # Arguments:
  41. # event - Indicates which event caused the procedure to be invoked
  42. # (Enter or FocusIn). It is used so that we can carry out
  43. # the functions of that event in addition to setting up
  44. # bindings.
  45. sub ClassInit
  46. {
  47.  my ($class,$mw) = @_;
  48.  
  49.  $mw->bind($class,'<Enter>',['Enter',Ev('x'),Ev('y')]);
  50.  $mw->bind($class,'<Motion>',['Activate',Ev('x'),Ev('y')]);
  51.  $mw->bind($class,'<Leave>','Leave');
  52.  
  53.  $mw->bind($class,'<1>',['ButtonDown',Ev('x'),Ev('y')]);
  54.  $mw->bind($class,'<B1-Motion>',['Drag',Ev('x'),Ev('y')]);
  55.  $mw->bind($class,'<B1-Leave>','NoOp');
  56.  $mw->bind($class,'<B1-Enter>','NoOp');
  57.  $mw->bind($class,'<ButtonRelease-1>',['ButtonUp',Ev('x'),Ev('y')]);
  58.  
  59.  $mw->bind($class,'<2>',['ButtonDown',Ev('x'),Ev('y')]);
  60.  $mw->bind($class,'<B2-Motion>',['Drag',Ev('x'),Ev('y')]);
  61.  $mw->bind($class,'<B2-Leave>','NoOp');
  62.  $mw->bind($class,'<B2-Enter>','NoOp');
  63.  $mw->bind($class,'<ButtonRelease-2>',['ButtonUp',Ev('x'),Ev('y')]);
  64.  
  65.  $mw->bind($class,'<Control-1>',['ControlPress',Ev('x'),Ev('y')]);
  66.  
  67.  $mw->bind($class,'<Up>',['Increment','up','little','noRepeat']);
  68.  $mw->bind($class,'<Down>',['Increment','down','little','noRepeat']);
  69.  $mw->bind($class,'<Left>',['Increment','up','little','noRepeat']);
  70.  $mw->bind($class,'<Right>',['Increment','down','little','noRepeat']);
  71.  
  72.  $mw->bind($class,'<Control-Up>',['Increment','up','big','noRepeat']);
  73.  $mw->bind($class,'<Control-Down>',['Increment','down','big','noRepeat']);
  74.  $mw->bind($class,'<Control-Left>',['Increment','up','big','noRepeat']);
  75.  $mw->bind($class,'<Control-Right>',['Increment','down','big','noRepeat']);
  76.  
  77.  $mw->bind($class,'<Home>',['set',Ev('cget','-from')]);
  78.  $mw->bind($class,'<End>',['set',Ev('cget','-to')]);
  79.  return $class;
  80. }
  81.  
  82. 1;
  83.  
  84. __END__
  85.  
  86. # Activate --
  87. # This procedure is invoked to check a given x-y position in the
  88. # scale and activate the slider if the x-y position falls within
  89. # the slider.
  90. #
  91. # Arguments:
  92. # w - The scale widget.
  93. # x, y - Mouse coordinates.
  94. sub Activate
  95. {
  96.  my $w = shift;
  97.  my $x = shift;
  98.  my $y = shift;
  99.  return if ($w->cget('-state') eq 'disabled');
  100.  my $ident = $w->identify($x,$y);
  101.  if (defined($ident) && $ident eq 'slider')
  102.   {
  103.    $w->configure(-state => 'active')
  104.   }
  105.  else
  106.   {
  107.    $w->configure(-state => 'normal')
  108.   }
  109. }
  110.  
  111. sub Leave
  112. {
  113.  my ($w) = @_;
  114.  $w->configure('-activebackground',$w->{'activeBg'}) if ($Tk::strictMotif);
  115.  $w->configure('-state','normal')  if ($w->cget('-state') eq 'active');
  116. }
  117.  
  118. sub Enter
  119. {
  120.  my ($w,$x,$y) = @_;
  121.  if ($Tk::strictMotif)
  122.   {
  123.    $w->{'activeBg'} = $w->cget('-activebackground');
  124.    $w->configure('-activebackground',$w->cget('-background'));
  125.   }
  126.  $w->Activate($x,$y);
  127. }
  128.  
  129. sub ButtonUp
  130. {
  131.  my ($w,$x,$y) = @_;
  132.  $w->CancelRepeat();
  133.  $w->EndDrag();
  134.  $w->Activate($x,$y)
  135. }
  136.  
  137.  
  138. # ButtonDown --
  139. # This procedure is invoked when a button is pressed in a scale. It
  140. # takes different actions depending on where the button was pressed.
  141. #
  142. # Arguments:
  143. # w - The scale widget.
  144. # x, y - Mouse coordinates of button press.
  145. sub ButtonDown
  146. {
  147.  my $w = shift;
  148.  my $x = shift;
  149.  my $y = shift;
  150.  $Tk::dragging = 0;
  151.  $el = $w->identify($x,$y);
  152.  return unless ($el);
  153.  if ($el eq 'trough1')
  154.   {
  155.    $w->Increment('up','little','initial')
  156.   }
  157.  elsif ($el eq 'trough2')
  158.   {
  159.    $w->Increment('down','little','initial')
  160.   }
  161.  elsif ($el eq 'slider')
  162.   {
  163.    $Tk::dragging = 1;
  164.    my @coords = $w->coords();
  165.    $Tk::deltaX = $x-$coords[0];
  166.    $Tk::deltaY = $y-$coords[1];
  167.   }
  168. }
  169. # Drag --
  170. # This procedure is called when the mouse is dragged with
  171. # mouse button 1 down. If the drag started inside the slider
  172. # (i.e. the scale is active) then the scale's value is adjusted
  173. # to reflect the mouse's position.
  174. #
  175. # Arguments:
  176. # w - The scale widget.
  177. # x, y - Mouse coordinates.
  178. sub Drag
  179. {
  180.  my $w = shift;
  181.  my $x = shift;
  182.  my $y = shift;
  183.  if (!$Tk::dragging)
  184.   {
  185.    return;
  186.   }
  187.  $w->set($w->get($x-$Tk::deltaX,$y-$Tk::deltaY))
  188. }
  189. # EndDrag --
  190. # This procedure is called to end an interactive drag of the
  191. # slider.  It just marks the drag as over.
  192. # Arguments:
  193. # w - The scale widget.
  194. sub EndDrag
  195. {
  196.  my $w = shift;
  197.  if (!$Tk::dragging)
  198.   {
  199.    return;
  200.   }
  201.  $Tk::dragging = 0;
  202. }
  203. # Increment --
  204. # This procedure is invoked to increment the value of a scale and
  205. # to set up auto-repeating of the action if that is desired. The
  206. # way the value is incremented depends on the "dir" and "big"
  207. # arguments.
  208. #
  209. # Arguments:
  210. # w - The scale widget.
  211. # dir - "up" means move value towards -from, "down" means
  212. # move towards -to.
  213. # big - Size of increments: "big" or "little".
  214. # repeat - Whether and how to auto-repeat the action: "noRepeat"
  215. # means don't auto-repeat, "initial" means this is the
  216. # first action in an auto-repeat sequence, and "again"
  217. # means this is the second repetition or later.
  218. sub Increment
  219. {
  220.  my $w = shift;
  221.  my $dir = shift;
  222.  my $big = shift;
  223.  my $repeat = shift;
  224.  my $inc;
  225.  if ($big eq 'big')
  226.   {
  227.    $inc = $w->cget('-bigincrement');
  228.    if ($inc == 0)
  229.     {
  230.      $inc = abs(($w->cget('-to')-$w->cget('-from')))/10.0
  231.     }
  232.    if ($inc < $w->cget('-resolution'))
  233.     {
  234.      $inc = $w->cget('-resolution')
  235.     }
  236.   }
  237.  else
  238.   {
  239.    $inc = $w->cget('-resolution')
  240.   }
  241.  if (($w->cget('-from') > $w->cget('-to')) ^ ($dir eq 'up'))
  242.   {
  243.    $inc = -$inc
  244.   }
  245.  $w->set($w->get()+$inc);
  246.  if ($repeat eq 'again')
  247.   {
  248.    $w->RepeatId($w->after($w->cget('-repeatinterval'),'Increment',$w,$dir,$big,'again'));
  249.   }
  250.  elsif ($repeat eq 'initial')
  251.   {
  252.    $w->RepeatId($w->after($w->cget('-repeatdelay'),'Increment',$w,$dir,$big,'again'));
  253.   }
  254. }
  255. # ControlPress --
  256. # This procedure handles button presses that are made with the Control
  257. # key down. Depending on the mouse position, it adjusts the scale
  258. # value to one end of the range or the other.
  259. #
  260. # Arguments:
  261. # w - The scale widget.
  262. # x, y - Mouse coordinates where the button was pressed.
  263. sub ControlPress
  264. {
  265.  my ($w,$x,$y) = @_;
  266.  my $el = $w->identify($x,$y);
  267.  return unless ($el);
  268.  if ($el eq 'trough1')
  269.   {
  270.    $w->set($w->cget('-from'))
  271.   }
  272.  elsif ($el eq 'trough2')
  273.   {
  274.    $w->set($w->cget('-to'))
  275.   }
  276. }
  277.  
  278.  
  279.