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__