diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm | 221 |
1 files changed, 221 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm b/Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm new file mode 100644 index 00000000000..d984b648897 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm @@ -0,0 +1,221 @@ +package Tk::Panedwindow; +use strict; + +use vars qw/$VERSION/; +$VERSION = sprintf '4.%03d', q$Revision: #3 $ =~ /#(\d+)/; + +# A Panedwindow widget (similar to Adjuster). + +use Tk qw/Ev/; +use base qw/Tk::Widget/; + +Construct Tk::Widget 'Panedwindow'; + +sub Tk_cmd { \&Tk::panedwindow } + +Tk::Methods('add', 'forget', 'identify', 'proxy', 'sash', 'panes'); + +use Tk::Submethods ( + 'proxy' => [qw/coord forget place/], + 'sash' => [qw/coord mark place/], +); + +sub ClassInit { + + my ($class,$mw) = @_; + + $class->SUPER::ClassInit($mw); + + $mw->bind($class, '<Button-1>' => ['MarkSash' => Ev('x'), Ev('y'), 1]); + $mw->bind($class, '<Button-2>' => ['MarkSash' => Ev('x'), Ev('y'), 0]); + $mw->bind($class, '<B1-Motion>' => ['DragSash' => Ev('x'), Ev('y'), 1]); + $mw->bind($class, '<B2-Motion>' => ['DragSash' => Ev('x'), Ev('y'), 0]); + $mw->bind($class, '<ButtonRelease-1>' => ['ReleaseSash' => 1]); + $mw->bind($class, '<ButtonRelease-2>' => ['ReleaseSash' => 0]); + $mw->bind($class, '<Motion>' => ['Motion' => Ev('x'), Ev('y')]); + $mw->bind($class, '<Leave>' => ['Leave']); + + return $class; + +} # end ClassInit + +sub MarkSash { + + # MarkSash + # + # Handle marking the correct sash for possible dragging + # + # Arguments: + # w the widget + # x widget local x coord + # y widget local y coord + # proxy whether this should be a proxy sash + # Results: + # None + + my ($w, $x, $y, $proxy) = @_; + + my @what = $w->identify($x, $y); + if ( @what == 2 ) { + my ($index, $which) = @what[0 .. 1]; + if (not $Tk::strictMotif or $which eq 'handle') { + $w->sashMark($index, $x, $y) if not $proxy; + $w->{_sash} = $index; + my ($sx, $sy) = $w->sashCoord($index); + $w->{_dx} = $sx - $x; + $w->{_dy} = $sy - $y; + } + } + +} # end MarkSash + +sub DragSash { + + # DragSash + # + # Handle dragging of the correct sash + # + # Arguments: + # w the widget + # x widget local x coord + # y widget local y coord + # proxy whether this should be a proxy sash + # Results: + # Moves sash + + my ($w, $x, $y, $proxy) = @_; + + if ( exists $w->{_sash} ) { + if ($proxy) { + $w->proxyPlace($x + $w->{_dx}, $y + $w->{_dy}); + } else { + $w->sashPlace($w->{_sash}, $x + $w->{_dx}, $y + $w->{_dy}); + } + } + +} # end DragSash + +sub ReleaseSash { + + # ReleaseSash + # + # Handle releasing of the sash + # + # Arguments: + # w the widget + # proxy whether this should be a proxy sash + # Results: + # Returns ... + + my ($w, $proxy) = @_; + + if ( exists $w->{_sash} ) { + if ($proxy) { + my ($x, $y) = $w->proxyCoord; + $w->sashPlace($w->{_sash}, $x, $y); + $w->proxyForget; + } + delete $w->{'_sash', '_dx', '_dy'}; + } + +} # end ReleaseSash + +sub Motion { + + # Motion + # + # Handle motion on the widget. This is used to change the cursor + # when the user moves over the sash area. + # + # Arguments: + # w the widget + # x widget local x coord + # y widget local y coord + # Results: + # May change the cursor. Sets up a timer to verify that we are still + # over the widget. + + my ($w, $x, $y) = @_; + + my @id = $w->identify($x, $y); + if ( (@id == 2) and + (not $Tk::strictMotif or $id[1] eq 'handle') ) { + if ( not exists $w->{_panecursor} ) { + $w->{_panecursor} = $w->cget(-cursor); + if ( not defined $w->cget(-sashcursor) ) { + if ( $w->cget(-orient) eq 'horizontal' ) { + $w->configure(-cursor => 'sb_h_double_arrow'); + } else { + $w->configure(-cursor => 'sb_v_double_arrow'); + } + } else { + $w->configure(-cursor => $w->cget(-sashcursor)); + } + if ( exists $w->{_pwAfterId} ) { + $w->afterCancel($w->{_pwAfterId}); + } + $w->{_pwAfterId} = $w->after(150 => ['Cursor' => $w]); + } + return + } + if ( exists $w->{_panecursor} ) { + $w->configure(-cursor => $w->{_panecursor}); + delete $w->{_panecursor}; + } + +} # end Motion + +sub Cursor { + + # Cursor + # + # Handles returning the normal cursor when we are no longer over the + # sash area. This needs to be done this way, because the panedwindow + # won't see Leave events when the mouse moves from the sash to a + # paned child, although the child does receive an Enter event. + # + # Arguments: + # w the widget + # Results: + # May restore the default cursor, or schedule a timer to do it. + + my ($w) = @_; + + if ( exists $w->{_panecursor} ) { + if ( $w->containing($w->pointerx, $w->pointery) == $w ) { + $w->{_pwAfterId} = $w->after(150 => ['Cursor' => $w]); + } else { + $w->configure(-cursor => $w->{_panecursor}); + delete $w->{_panecursor}; + if ( exists $w->{_pwAfterId} ) { + $w->afterCancel($w->{_pwAfterId}); + delete $w->{_pwAfterId}; + } + } + } + +} # end Cursor + +sub Leave { + + # Leave + # + # Return to default cursor when leaving the pw widget. + # + # Arguments: + # w the widget + # Results: + # Restores the default cursor + + my ($w) = @_; + + if ( exists $w->{_panecursor} ) { + $w->configure(-cursor => $w->{_panecursor}); + delete $w->{_panecursor}; + } + +} # end Leave + + +1; +__END__ |