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