home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _6c566bca11f11b89061595cd2788a0f1 < prev    next >
Encoding:
Text File  |  2004-06-01  |  5.2 KB  |  222 lines
  1. package Tk::Panedwindow;
  2. use strict;
  3.  
  4. use vars qw/$VERSION/;
  5. $VERSION = sprintf '4.%03d', q$Revision: #3 $ =~ /#(\d+)/;
  6.  
  7. # A Panedwindow widget (similar to Adjuster).
  8.  
  9. use Tk qw/Ev/;
  10. use base qw/Tk::Widget/;
  11.  
  12. Construct Tk::Widget 'Panedwindow';
  13.  
  14. sub Tk_cmd { \&Tk::panedwindow }
  15.  
  16. Tk::Methods('add', 'forget', 'identify', 'proxy', 'sash', 'panes');
  17.  
  18. use Tk::Submethods (
  19.     'proxy' => [qw/coord forget place/],
  20.     'sash'  => [qw/coord mark place/],
  21. );
  22.  
  23. sub ClassInit {
  24.  
  25.     my ($class,$mw) = @_;
  26.  
  27.     $class->SUPER::ClassInit($mw);
  28.  
  29.     $mw->bind($class, '<Button-1>' => ['MarkSash' => Ev('x'), Ev('y'), 1]);
  30.     $mw->bind($class, '<Button-2>' => ['MarkSash' => Ev('x'), Ev('y'), 0]);
  31.     $mw->bind($class, '<B1-Motion>' => ['DragSash' => Ev('x'), Ev('y'), 1]);
  32.     $mw->bind($class, '<B2-Motion>' => ['DragSash' => Ev('x'), Ev('y'), 0]);
  33.     $mw->bind($class, '<ButtonRelease-1>' => ['ReleaseSash' => 1]);
  34.     $mw->bind($class, '<ButtonRelease-2>' => ['ReleaseSash' => 0]);
  35.     $mw->bind($class, '<Motion>' => ['Motion' => Ev('x'), Ev('y')]);
  36.     $mw->bind($class, '<Leave>' => ['Leave']);
  37.  
  38.     return $class;
  39.  
  40. } # end ClassInit
  41.  
  42. sub MarkSash {
  43.  
  44.     # MarkSash
  45.     #
  46.     # Handle marking the correct sash for possible dragging
  47.     #
  48.     # Arguments:
  49.     #   w    the widget
  50.     #   x    widget local x coord
  51.     #   y    widget local y coord
  52.     #   proxy    whether this should be a proxy sash
  53.     # Results:
  54.     #   None
  55.  
  56.     my ($w, $x, $y, $proxy) = @_;
  57.  
  58.     my @what = $w->identify($x, $y);
  59.     if ( @what == 2 ) {
  60.     my ($index, $which) = @what[0 .. 1];
  61.     if (not $Tk::strictMotif or $which eq 'handle') {
  62.         $w->sashMark($index, $x, $y) if not $proxy;
  63.         $w->{_sash} = $index;
  64.         my ($sx, $sy) = $w->sashCoord($index);
  65.         $w->{_dx} = $sx - $x;
  66.         $w->{_dy} = $sy - $y;
  67.     }
  68.     }
  69.  
  70. } # end MarkSash
  71.  
  72. sub DragSash {
  73.  
  74.     # DragSash
  75.     #
  76.     # Handle dragging of the correct sash
  77.     #
  78.     # Arguments:
  79.     #   w    the widget
  80.     #   x    widget local x coord
  81.     #   y    widget local y coord
  82.     #   proxy    whether this should be a proxy sash
  83.     # Results:
  84.     #   Moves sash
  85.  
  86.     my ($w, $x, $y, $proxy) = @_;
  87.  
  88.     if ( exists $w->{_sash} ) {
  89.     if ($proxy) {
  90.         $w->proxyPlace($x + $w->{_dx}, $y + $w->{_dy});
  91.     } else {
  92.         $w->sashPlace($w->{_sash}, $x + $w->{_dx}, $y + $w->{_dy});
  93.     }
  94.     }
  95.  
  96. } # end DragSash
  97.  
  98. sub ReleaseSash {
  99.  
  100.     # ReleaseSash
  101.     #
  102.     # Handle releasing of the sash
  103.     #
  104.     # Arguments:
  105.     #   w    the widget
  106.     #   proxy    whether this should be a proxy sash
  107.     # Results:
  108.     #   Returns ...
  109.  
  110.     my ($w, $proxy) = @_;
  111.  
  112.     if ( exists $w->{_sash} ) {
  113.     if ($proxy) {
  114.         my ($x, $y) = $w->proxyCoord;
  115.         $w->sashPlace($w->{_sash}, $x, $y);
  116.         $w->proxyForget;
  117.     }
  118.     delete $w->{'_sash', '_dx', '_dy'};
  119.     }
  120.  
  121. } # end ReleaseSash
  122.  
  123. sub Motion {
  124.  
  125.     # Motion
  126.     #
  127.     # Handle motion on the widget. This is used to change the cursor
  128.     # when the user moves over the sash area.
  129.     #
  130.     # Arguments:
  131.     #   w    the widget
  132.     #   x    widget local x coord
  133.     #   y    widget local y coord
  134.     # Results:
  135.     #   May change the cursor. Sets up a timer to verify that we are still
  136.     #   over the widget.
  137.  
  138.     my ($w, $x, $y) = @_;
  139.  
  140.     my @id = $w->identify($x, $y);
  141.     if ( (@id == 2) and
  142.      (not $Tk::strictMotif or $id[1] eq 'handle') ) {
  143.     if ( not exists $w->{_panecursor} ) {
  144.         $w->{_panecursor} = $w->cget(-cursor);
  145.         if ( not defined $w->cget(-sashcursor) ) {
  146.         if ( $w->cget(-orient) eq 'horizontal' ) {
  147.             $w->configure(-cursor => 'sb_h_double_arrow');
  148.         } else {
  149.             $w->configure(-cursor => 'sb_v_double_arrow');
  150.         }
  151.         } else {
  152.         $w->configure(-cursor => $w->cget(-sashcursor));
  153.         }
  154.         if ( exists $w->{_pwAfterId} ) {
  155.         $w->afterCancel($w->{_pwAfterId});
  156.         }
  157.         $w->{_pwAfterId} = $w->after(150 => ['Cursor' => $w]);
  158.     }
  159.     return
  160.     }
  161.     if ( exists $w->{_panecursor} ) {
  162.     $w->configure(-cursor => $w->{_panecursor});
  163.     delete $w->{_panecursor};
  164.     }
  165.  
  166. } # end Motion
  167.  
  168. sub  Cursor {
  169.  
  170.     # Cursor
  171.     #
  172.     # Handles returning the normal cursor when we are no longer over the
  173.     # sash area.  This needs to be done this way, because the panedwindow
  174.     # won't see Leave events when the mouse moves from the sash to a
  175.     # paned child, although the child does receive an Enter event.
  176.     #
  177.     # Arguments:
  178.     #   w    the widget
  179.     # Results:
  180.     #   May restore the default cursor, or schedule a timer to do it.
  181.  
  182.     my ($w) = @_;
  183.  
  184.     if ( exists $w->{_panecursor} ) {
  185.     if ( $w->containing($w->pointerx, $w->pointery) == $w ) {
  186.         $w->{_pwAfterId} = $w->after(150 => ['Cursor' => $w]);
  187.     } else {
  188.         $w->configure(-cursor => $w->{_panecursor});
  189.         delete $w->{_panecursor};
  190.         if ( exists $w->{_pwAfterId} ) {
  191.         $w->afterCancel($w->{_pwAfterId});
  192.         delete $w->{_pwAfterId};
  193.         }
  194.     }
  195.     }
  196.  
  197. } # end Cursor
  198.  
  199. sub Leave {
  200.  
  201.     # Leave
  202.     #
  203.     # Return to default cursor when leaving the pw widget.
  204.     #
  205.     # Arguments:
  206.     #   w    the widget
  207.     # Results:
  208.     #   Restores the default cursor
  209.  
  210.     my ($w) = @_;
  211.  
  212.     if ( exists $w->{_panecursor} ) {
  213.         $w->configure(-cursor => $w->{_panecursor});
  214.         delete $w->{_panecursor};
  215.     }
  216.  
  217. } # end Leave
  218.  
  219.  
  220. 1;
  221. __END__
  222.