#
# This file is part of Curses-Toolkit
#
# This software is copyright (c) 2011 by Damien "dams" Krotkine.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use warnings;
use strict;
package Curses::Toolkit::Widget::Paned;
BEGIN {
$Curses::Toolkit::Widget::Paned::VERSION = '0.207';
}
# ABSTRACT: generic paned widget
use parent qw(Curses::Toolkit::Widget::Container);
use Params::Validate qw(SCALAR ARRAYREF HASHREF CODEREF GLOB GLOBREF SCALARREF HANDLE BOOLEAN UNDEF validate validate_pos);
use Curses::Toolkit::Object::Coordinates;
sub new {
my $class = shift;
# TODO : use Exception;
$class eq __PACKAGE__
and die
"This is an abstract class, please see Curses::Toolkit::Widget::HPaned and Curses::Toolkit::Widget::VPaned";
my $self = $class->SUPER::new(@_);
# default position
$self->set_gutter_position(0);
# listen to the Mouse for moving the gutter
$self->add_event_listener(
Curses::Toolkit::EventListener->new(
accepted_events => {
'Curses::Toolkit::Event::Mouse::Click' => sub {
my ($event) = @_;
$event->{button} eq 'button1' or return 0;
$self->{_gutter_move_pressed} && $event->{type} eq 'released'
and return 1;
my $ec = $event->{coordinates};
my $wc = $self->get_coordinates();
my $gp = $self->get_gutter_position();
# my $gw = $self->get_theme_property('gutter_width');
my $gw = 1;
!$self->{_gutter_move_pressed}
&& $event->{type} eq 'pressed'
&& $self->_p1($ec) >= $self->_p1($wc) + $gp
&& $self->_p1($ec) < $self->_p1($wc) + $gp + $gw
&& $self->_p2($ec) < $self->_p2($wc)
and return 1;
return 0;
},
},
code => sub {
my ( $event, $widget ) = @_;
if ( $self->{_gutter_move_pressed} ) {
# means we released it
$self->unset_modal();
my $ec = $event->{coordinates};
my $wc = $self->get_coordinates();
$self->set_gutter_position( $self->_p1($ec) - $self->_p1($wc) );
# changing the gutter position might change the space of
# the gutter itself, so rebuild starting from the start
$self->rebuild_all_coordinates();
$self->needs_redraw();
$self->{_gutter_move_pressed} = 0;
} else {
# means we pressed it
$self->set_modal();
$self->needs_redraw();
$self->{_gutter_move_pressed} = 1;
}
return;
},
)
);
return $self;
}
sub add1 {
my $self = shift;
my ($child_widget) = validate_pos(
@_,
{ isa => 'Curses::Toolkit::Widget' },
);
defined $self->{child1} and die "there is already a child 1";
$self->_add_child_at_beginning($child_widget);
$self->{child1} = $child_widget;
$child_widget->_set_parent($self);
$self->rebuild_all_coordinates();
return $self;
}
sub add2 {
my $self = shift;
my ($child_widget) = validate_pos(
@_,
{ isa => 'Curses::Toolkit::Widget' },
);
defined $self->{child2} and die "there is already a child 2";
$self->_add_child_at_end($child_widget);
$self->{child2} = $child_widget;
$child_widget->_set_parent($self);
$self->rebuild_all_coordinates();
return $self;
}
sub set_gutter_position {
my $self = shift;
my ($position) = validate_pos(
@_,
{ type => SCALAR,
},
);
$position < 0 and $position = 0;
$self->_del_actual_gutter_position();
$self->{position} = $position;
return $self;
}
# sets the gutter position, which can be different from the one desired
sub _set_actual_gutter_position {
my ( $self, $position ) = @_;
$position < 0 and $position = 0;
$self->{actual_position} = $position;
return $self;
}
# deletes the actual gutter position
sub _del_actual_gutter_position {
my ($self) = @_;
$self->{actual_position} = undef;
return $self;
}
sub get_gutter_position {
my ($self) = @_;
defined $self->{actual_position}
and return $self->{actual_position};
return $self->{position};
}
sub _get_original_gutter_position {
my ($self) = @_;
return $self->{position};
}
# =head2 set_gutter_size
# Set the width of the gutter
# input : the width (an integer)
# output : the current widget (not the child widget)
# =cut
# sub set_gutter_size {
# my $self = shift;
# my ($size) = validate_pos( @_,
# { type => SCALAR,
# callbacks => { positive_integer => { shift() >= 0 } }
# },
# );
# }
sub _rebuild_children_coordinates {
my ($self) = @_;
my $available_space = $self->_get_available_space();
my ( $child1, $child2 ) = $self->get_children();
# my $gw = $self->get_theme_property('gutter_width');
my $gw = 1;
my $gp = $self->_get_original_gutter_position();
if ( $gp > ( $self->_p3($available_space) - $gw ) ) {
$gp = $self->_p3($available_space) - $gw;
$self->_set_actual_gutter_position($gp);
} else {
$self->_del_actual_gutter_position();
}
if ( defined $child1 ) {
my $child1_space = $available_space->clone();
$child1_space->set( $self->_p4( $child1_space, $gp ) );
$child1->_set_relatives_coordinates($child1_space);
$child1->can('_rebuild_children_coordinates')
and $child1->_rebuild_children_coordinates();
}
if ( defined $child2 ) {
my $child2_space = $available_space->clone();
$child2_space->set( $self->_p5( $child2_space, $gp, $gw ) );
$child2->_set_relatives_coordinates($child2_space);
$child2->can('_rebuild_children_coordinates')
and $child2->_rebuild_children_coordinates();
}
return $self;
}
sub get_desired_space {
my ( $self, $available_space ) = @_;
defined $available_space
or return $self->get_minimum_space();
my ( $child1, $child2 ) = $self->get_children();
# my $gw = $self->get_theme_property('gutter_width');
my $gw = 1;
my $gp = $self->get_gutter_position();
# if the gutter is placed over the edge of the space
if ( $gp > ( $self->_p3($available_space) - $gw ) ) {
$gp = $self->_p3($available_space) - $gw;
}
my $desired_space1 = $available_space->clone();
$desired_space1->set( $self->_p8( $desired_space1, $gp, $gw ) );
$desired_space1->set( $self->_p9($available_space) );
if ( defined $child2 ) {
my $desired_space2 = $available_space->clone();
$desired_space2->set( $self->_p5( $available_space, $gp, $gw ) );
$desired_space2 = $child2->get_desired_space($desired_space2);
$desired_space2->set( $self->_p10($desired_space1) );
$desired_space2->set( $self->_p11( $desired_space1, $desired_space2 ) );
$desired_space2->set( $self->_p9($available_space) );
return $desired_space2;
}
return $desired_space1;
}
sub get_minimum_space {
my ( $self, $available_space ) = @_;
my ( $child1, $child2 ) = $self->get_children();
my $available_space_is_undef = ! defined $available_space;
defined $available_space
or $available_space = Curses::Toolkit::Object::Coordinates->new_zero();
# my $gw = $self->get_theme_property('gutter_width');
my $gw = 1;
my $gp = $self->get_gutter_position();
# if the gutter is placed over the edge of the space
if ( $gp > ( $self->_p3($available_space) - $gw ) ) {
$gp = $self->_p3($available_space) - $gw;
}
my $minimum_space1 = $available_space->clone();
$minimum_space1->set( $self->_p8( $minimum_space1, $gp, $gw ) );
if ( !defined $child1 ) {
$minimum_space1->set( $self->_p12($minimum_space1) );
} else {
$minimum_space1 = $child1->get_minimum_space($available_space_is_undef ? () : $minimum_space1);
$minimum_space1->set( $self->_p8( $minimum_space1, $gp, $gw ) );
}
if ( defined $child2 ) {
my $minimum_space2 = $available_space->clone();
$minimum_space2->set( $self->_p5( $available_space, $gp, $gw ) );
$minimum_space2 = $child2->get_minimum_space($available_space_is_undef ? () : $minimum_space2);
my $return_space = $minimum_space2->clone();
$return_space->set( $self->_p10($minimum_space1) );
$return_space->set( $self->_p11( $minimum_space1, $minimum_space2 ) );
$return_space->set( $self->_p13( $minimum_space1, $minimum_space2 ) );
return $return_space;
}
return $minimum_space1;
}
sub draw {
my ($self) = @_;
my $theme = $self->get_theme();
my $attr = {};
$self->{_gutter_move_pressed} and $attr->{clicked} = 1;
my $c = $self->get_coordinates();
my $gp = $self->get_gutter_position();
my $gw = 1;
$gw > 0 or return;
for my $i ( 0 .. $gw - 1 ) {
$self->_p7( $theme, $c, $i, $gp, $attr );
}
return;
}
1;
=pod
=head1 NAME
Curses::Toolkit::Widget::Paned - generic paned widget
=head1 VERSION
version 0.207
=head1 SYNOPSIS
# don't use this widget directly
=head1 DESCRIPTION
A paned widget is a widget containing 2 other widgets. It is used to
stack them horizontally or vertically.
Don't use this widget directly. Please see
L<Curses::Toolkit::Widget::HPaned> and
L<Curses::Toolkit::Widget::VPaned>.
=head1 AUTHOR
Damien "dams" Krotkine
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011 by Damien "dams" Krotkine.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__