summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm221
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..ae279f20012
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Panedwindow.pm
@@ -0,0 +1,221 @@
+package Tk::Panedwindow;
+use strict;
+
+use vars qw/$VERSION/;
+$VERSION = '4.004'; # 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__