Commit d24db8ae authored by Andrej Shadura's avatar Andrej Shadura

Import original source of Tickit-Widget-FloatBox 0.03

parents
use strict;
use warnings;
use Module::Build;
my $build = Module::Build->new(
module_name => 'Tickit::Widget::FloatBox',
requires => {
'Tickit::ContainerWidget' => 0,
},
build_requires => {
'Test::Identity' => 0,
'Test::More' => '0.88', # done_testing
'Tickit::Test' => 0,
},
auto_configure_requires => 0, # Don't add M::B to configure_requires
license => 'perl',
create_makefile_pl => 'traditional',
create_license => 1,
create_readme => 1,
);
$build->create_build_script;
Revision history for Tickit-Widget-FloatBox
0.03 2015/04/08 16:30:39
[CHANGES]
* Added $float->is_visible
* Set WIDGET_PEN_FROM_STYLE to quiet Tickit 0.51 deprecation warning
0.02 2014/08/05 19:57:59
[CHANGES]
* Allow floats to be made hidden
[BUGFIXES]
* Use the ContainerWidget ->add/->remove API properly, ensuring the
->parent is properly set on child widgets
0.01 2014/08/04 23:57:31
First version, released on an unsuspecting world.
This diff is collapsed.
Build.PL
Changes
examples/demo.pl
lib/Tickit/Widget/FloatBox.pm
LICENSE
Makefile.PL
MANIFEST This list of files
META.json
META.yml
README
t/00use.t
t/01base-child.t
t/02float.t
t/03hide-show.t
t/99pod.t
{
"abstract" : "manage a collection of floating widgets",
"author" : [
"Paul Evans <leonerd@leonerd.org.uk>"
],
"dynamic_config" : 1,
"generated_by" : "Module::Build version 0.421",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "Tickit-Widget-FloatBox",
"prereqs" : {
"build" : {
"requires" : {
"Test::Identity" : "0",
"Test::More" : "0.88",
"Tickit::Test" : "0"
}
},
"runtime" : {
"requires" : {
"Tickit::ContainerWidget" : "0"
}
}
},
"provides" : {
"Tickit::Widget::FloatBox" : {
"file" : "lib/Tickit/Widget/FloatBox.pm",
"version" : "0.03"
}
},
"release_status" : "stable",
"resources" : {
"license" : [
"http://dev.perl.org/licenses/"
]
},
"version" : "0.03"
}
---
abstract: 'manage a collection of floating widgets'
author:
- 'Paul Evans <leonerd@leonerd.org.uk>'
build_requires:
Test::Identity: '0'
Test::More: '0.88'
Tickit::Test: '0'
dynamic_config: 1
generated_by: 'Module::Build version 0.421, CPAN::Meta::Converter version 2.142690'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: '1.4'
name: Tickit-Widget-FloatBox
provides:
Tickit::Widget::FloatBox:
file: lib/Tickit/Widget/FloatBox.pm
version: '0.03'
requires:
Tickit::ContainerWidget: '0'
resources:
license: http://dev.perl.org/licenses/
version: '0.03'
# Note: this file was auto-generated by Module::Build::Compat version 0.4210
use ExtUtils::MakeMaker;
WriteMakefile
(
'NAME' => 'Tickit::Widget::FloatBox',
'VERSION_FROM' => 'lib/Tickit/Widget/FloatBox.pm',
'PREREQ_PM' => {
'Test::Identity' => 0,
'Test::More' => '0.88',
'Tickit::ContainerWidget' => 0,
'Tickit::Test' => 0
},
'INSTALLDIRS' => 'site',
'EXE_FILES' => [],
'PL_FILES' => {}
)
;
NAME
`Tickit::Widget::FloatBox' - manage a collection of floating widgets
SYNOPSIS
TODO
DESCRIPTION
This container widget maintains a collection of floating widgets that
can be displayed over the top of a single base widget. The box itself is
entirely occupied by the base widget, and by default when no floats are
created or displayed it will behave essentially invisibly, as though the
box were not there and the base widget was an immediate child of the
container the floatbox is inside.
CONSTRUCTOR
$floatbox = Tickit::Widget::FloatBox->new( %args )
Constructs a new `Tickit::Widget::FloatBox' object.
Takes the following named arguments in addition to those taken by the
base Tickit::ContainerWidget constructor.
base_child => Tickit::Widget
The main Tickit::Widget instance to use as the base.
ACCESSORS
$base_child = $floatbox->base_child
$floatbox->set_base_child( $base_child )
Returns or sets the base widget to use.
$float = $floatbox->add_float( %args )
Adds a widget as a floating child and returns a new `Float' object.
Takes the following arguments:
child => Tickit::Widget
The child widget
top, bottom, left, right => INT
The initial geometry of the floating area. These follow the same
behaviour as the `move' method on the Float object.
hidden => BOOL
Optional. If true, the float starts off hidden initally, and
must be shown by the `show' method before it becomes visible.
FLOATS
The following objects represent a floating region as returned by the
`add_float' method.
$child = $float->child
Returns the child widget in the region.
$float->move( %args )
Redefines the area geometry of the region. Takes arguments named `top',
`bottom', `left' and `right', each of which should either be a numeric
value, or `undef'.
The region must have at least one of `top' or `bottom' and at least one
of `left' or `right' defined, which will then fix the position of one
corner of the region. If the size is not otherwise determined by the
geometry, it will use the preferred size of the child widget. Any
geometry argument may be negative to count backwards from the limits of
the parent.
For example,
# top-left corner
$float->move( top => 0, left => 0 )
# top-right corner
$float->move( top => 0, right => -1 )
# bottom 3 lines, flush left
$float->move( left => 0, top => -3, bottom => -1 )
Any arguments not passed will be left unchanged; to specifically clear
the current value pass a value of `undef'.
$float->remove
Removes the float from the FloatBox.
$float->hide
Hide the float by hiding the window of its child widget.
$float->show
Show the float by showing the window of its child widget. Undoes the
effect of `hide'.
$visible = $float->is_visible
Return true if the float is currently visible.
TODO
* Support adjusting stacking order of floats.
AUTHOR
Paul Evans <leonerd@leonerd.org.uk>
#!/usr/bin/perl
use strict;
use warnings;
use Tickit;
use Tickit::Widgets qw( Placegrid Box FloatBox );
my $tickit = Tickit->new(
root => my $fb = Tickit::Widget::FloatBox->new(
base_child => Tickit::Widget::Placegrid->new,
)
);
my $float = $fb->add_float(
child => Tickit::Widget::Box->new(
child => Tickit::Widget::Placegrid->new( grid_fg => "red" ),
child_lines => 5, child_cols => 20,
),
top => 1, left => 1,
);
$tickit->bind_key( Up => sub { $float->move( top => 1, bottom => undef ) } );
$tickit->bind_key( Down => sub { $float->move( top => undef, bottom => -2 ) } );
$tickit->bind_key( Left => sub { $float->move( left => 1, right => undef ) } );
$tickit->bind_key( Right => sub { $float->move( left => undef, right => -2 ) } );
$tickit->run;
# You may distribute under the terms of either the GNU General Public License
# or the Artistic License (the same terms as Perl itself)
#
# (C) Paul Evans, 2014-2015 -- leonerd@leonerd.org.uk
package Tickit::Widget::FloatBox;
use strict;
use warnings;
use base qw( Tickit::ContainerWidget );
our $VERSION = '0.03';
use Carp;
# We don't actually have a pen, but then we don't actually have any style
# either. This keeps deprecation warnings happy
use constant WIDGET_PEN_FROM_STYLE => 1;
=head1 NAME
C<Tickit::Widget::FloatBox> - manage a collection of floating widgets
=head1 SYNOPSIS
TODO
=head1 DESCRIPTION
This container widget maintains a collection of floating widgets that can be
displayed over the top of a single base widget. The box itself is entirely
occupied by the base widget, and by default when no floats are created or
displayed it will behave essentially invisibly, as though the box were not
there and the base widget was an immediate child of the container the floatbox
is inside.
=cut
=head1 CONSTRUCTOR
=cut
=head2 $floatbox = Tickit::Widget::FloatBox->new( %args )
Constructs a new C<Tickit::Widget::FloatBox> object.
Takes the following named arguments in addition to those taken by the base
L<Tickit::ContainerWidget> constructor.
=over 8
=item base_child => Tickit::Widget
The main L<Tickit::Widget> instance to use as the base.
=back
=cut
sub new
{
my $class = shift;
my %args = @_;
my $self = $class->SUPER::new( %args );
$self->set_base_child( $args{base_child} ) if $args{base_child};
$self->{floats} = [];
return $self;
}
=head1 ACCESSORS
=cut
sub children
{
my $self = shift;
my @children;
push @children, $self->base_child if $self->base_child;
push @children, $_->child for @{ $self->{floats} };
return @children;
}
sub lines
{
my $self = shift;
return $self->base_child ? $self->base_child->requested_lines : 1;
}
sub cols
{
my $self = shift;
return $self->base_child ? $self->base_child->requested_cols : 1;
}
=head2 $base_child = $floatbox->base_child
=head2 $floatbox->set_base_child( $base_child )
Returns or sets the base widget to use.
=cut
sub base_child
{
my $self = shift;
return $self->{base_child};
}
sub set_base_child
{
my $self = shift;
my ( $new ) = @_;
if( my $old = $self->{base_child} ) {
$self->remove( $old );
}
$self->{base_child} = $new;
$self->add( $new );
if( my $win = $self->window ) {
$new->set_window( $win->make_sub( 0, 0, $win->lines, $win->cols ) );
}
}
sub reshape
{
my $self = shift;
return unless my $win = $self->window;
if( my $child = $self->base_child ) {
if( $child->window ) {
$child->window->resize( $win->lines, $win->cols );
}
else {
$child->set_window( $win->make_sub( 0, 0, $win->lines, $win->cols ) );
}
}
$self->_reshape_float( $_, $win ) for @{ $self->{floats} };
$self->redraw;
}
sub _reshape_float
{
my $self = shift;
my ( $float, $win ) = @_;
my $child = $float->child;
my @geom = $float->_get_geom( $win->lines, $win->cols );
if( my $childwin = $child->window ) {
$childwin->expose;
$childwin->change_geometry( @geom );
$childwin->expose;
}
else {
# TODO: Ordering?
# TODO: I want a ->make_hidden_float
$child->set_window( $win->make_float( @geom ) );
$child->window->hide if $float->{hidden};
}
}
sub render_to_rb
{
my $self = shift;
my ( $rb, $rect ) = @_;
return if $self->base_child;
$rb->eraserect( $rect );
}
=head2 $float = $floatbox->add_float( %args )
Adds a widget as a floating child and returns a new C<Float> object. Takes the
following arguments:
=over 8
=item child => Tickit::Widget
The child widget
=item top, bottom, left, right => INT
The initial geometry of the floating area. These follow the same behaviour as
the C<move> method on the Float object.
=item hidden => BOOL
Optional. If true, the float starts off hidden initally, and must be shown by
the C<show> method before it becomes visible.
=back
=cut
sub add_float
{
my $self = shift;
my %args = @_;
my $float = Tickit::Widget::FloatBox::Float->new(
$self, delete $args{child}, %args
);
push @{ $self->{floats} }, $float;
$self->add( $float->child );
if( my $win = $self->window ) {
$self->_reshape_float( $float, $win );
}
return $float;
}
sub _remove_float
{
my $self = shift;
my ( $float ) = @_;
my $idx;
$self->{floats}[$_] == $float and $idx = $_, last for 0 .. $#{ $self->{floats} };
defined $idx or croak "Cannot remove float - not a member of the FloatBox";
splice @{ $self->{floats} }, $idx, 1, ();
$self->remove( $float->child );
}
=head1 FLOATS
The following objects represent a floating region as returned by the
C<add_float> method.
=cut
package # hide
Tickit::Widget::FloatBox::Float;
use Carp;
sub new
{
my $class = shift;
my ( $fb, $child, %args ) = @_;
my $self = bless {
fb => $fb,
child => $child,
hidden => delete $args{hidden} || 0,
}, $class;
$self->move( %args );
return $self;
}
=head2 $child = $float->child
Returns the child widget in the region.
=cut
sub child { shift->{child} }
=head2 $float->move( %args )
Redefines the area geometry of the region. Takes arguments named C<top>,
C<bottom>, C<left> and C<right>, each of which should either be a numeric
value, or C<undef>.
The region must have at least one of C<top> or C<bottom> and at least one of
C<left> or C<right> defined, which will then fix the position of one corner of
the region. If the size is not otherwise determined by the geometry, it will
use the preferred size of the child widget. Any geometry argument may be
negative to count backwards from the limits of the parent.
For example,
# top-left corner
$float->move( top => 0, left => 0 )
# top-right corner
$float->move( top => 0, right => -1 )
# bottom 3 lines, flush left
$float->move( left => 0, top => -3, bottom => -1 )
Any arguments not passed will be left unchanged; to specifically clear the
current value pass a value of C<undef>.
=cut
sub move
{
my $self = shift;
my %args = @_;
exists $args{$_} and $self->{$_} = $args{$_} for qw( top bottom left right );
defined $self->{top} or defined $self->{bottom} or
croak "A Float needs at least one of 'top' or 'bottom'";
defined $self->{left} or defined $self->{right} or
croak "A Float needs at least one of 'left' or 'right'";
if( my $win = $self->{fb}->window ) {
$self->{fb}->_reshape_float( $self, $win );
}
}
sub _get_geom
{
my $self = shift;
my ( $lines, $cols ) = @_;
my $clines = $self->child->requested_lines;
my $ccols = $self->child->requested_cols;
my ( $top, $bottom ) = _alloc_dimension( $self->{top}, $self->{bottom}, $lines, $clines );
my ( $left, $right ) = _alloc_dimension( $self->{left}, $self->{right}, $cols, $ccols );
return ( $top, $left, $bottom-$top, $right-$left );
}
sub _alloc_dimension
{
my ( $start, $end, $parentsz, $childsz ) = @_;
# Need to off-by-one to allow -1 == right, etc..
defined and $_ < 0 and $_ += $parentsz+1 for $start, $end;
$end = $start + $childsz if !defined $end;
$start = $end - $childsz if !defined $start;
return ( $start, $end );
}
=head2 $float->remove
Removes the float from the FloatBox.
=cut
sub remove
{
my $self = shift;
$self->{fb}->_remove_float( $self );
}
=head2 $float->hide
Hide the float by hiding the window of its child widget.
=cut
sub hide
{
my $self = shift;
$self->{hidden} = 1;
$self->child->window->hide if $self->child->window;
}
=head2 $float->show
Show the float by showing the window of its child widget. Undoes the effect
of C<hide>.
=cut
sub show
{
my $self = shift;
$self->{hidden} = 0;
$self->child->window->show if $self->child->window;
}
=head2 $visible = $float->is_visible
Return true if the float is currently visible.
=cut
sub is_visible
{
my $self = shift;
return !$self->{hidden};
}
=head1 TODO
=over 4
=item *
Support adjusting stacking order of floats.
=back
=cut
=head1 AUTHOR
Paul Evans <leonerd@leonerd.org.uk>
=cut
0x55AA
#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use_ok( 'Tickit::Widget::FloatBox' );
done_testing;
#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use Test::Identity;
use Tickit::Test;
use Tickit::Widget::FloatBox;
my $win = mk_window;
my ( $child_lines, $child_cols );
my $child_render_rect;
my $widget = Tickit::Widget::FloatBox->new(
base_child => TestWidget->new,
);
ok( defined $widget, 'defined $widget' );
is( scalar $widget->children, 1, 'scalar $widget->children' );
identical( ( $widget->children )[0], $widget->base_child, '$widget->children[0]' );
identical( ( $widget->children )[0]->parent, $widget, '$widget->children[0]->parent' );
$child_lines = 3; $child_cols = 10;
is( $widget->lines, 3, '$widget->lines with no bounds' );
is( $widget->cols, 10, '$widget->cols with no bounds' );
$widget->set_window( $win );
flush_tickit;
is( $child_render_rect, Tickit::Rect->new( top => 0, left => 0, lines => 25, cols => 80 ),
'child render rect' );
resize_term( 30, 100 );
flush_tickit;
is( $child_render_rect, Tickit::Rect->new( top => 0, left => 0, lines => 30, cols => 100 ),
'child render rect after term resize' );
done_testing;
package TestWidget;