File Coverage

blib/lib/Tickit/Widget/Tabbed.pm

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

#  You may distribute under the terms of the Artistic License (the same terms
#  as Perl itself)
#
#  (C) Tom Molesworth 2011,
#      Paul Evans, 2011-2015 -- [e-mail]

package Tickit::Widget::Tabbed;

use strict;
use warnings;
use parent qw(Tickit::ContainerWidget);
BEGIN {
        Tickit::Widget->VERSION("0.12");
        Tickit::Window->VERSION("0.23");
}
use Tickit::Style;

use Carp;
use Tickit::Pen;
use List::Util qw(max);

use Tickit::Widget::Tabbed::Ribbon;

our $VERSION = '0.020';

=head1 NAME

Tickit::Widget::Tabbed - provide tabbed window support

=head1 SYNOPSIS

 use Tickit::Widget::Tabbed;
 my $tabbed = Tickit::Widget::Tabbed->new;
 $tabbed->add_tab(Tickit::Widget::Static->new(text => 'some text'), label => 'First tab');
 $tabbed->add_tab(Tickit::Widget::Static->new(text => 'some text'), label => 'Second tab');

=head1 DESCRIPTION

Provides a container that operates as a tabbed window.

Subclass of L.

=cut

=head1 STYLE

The default style pen is used as the widget pen. The following style pen
prefixes are also used:

=over 4

=item ribbon => PEN

The pen used for the ribbon

=item active => PEN

The pen attributes used for the active tab on the ribbon

=item more => PEN

The pen used for "more" ribbon scroll markers

=back

The following style keys are used:

=over 4

=item more_left => STRING

=item more_right => STRING

The text used to indicate that there is more content scrolled to the left or
right, respectively, in the ribbon

=back

=cut

style_definition base =>
        ribbon_fg => 7,
        ribbon_bg => 4,
        active_fg => 14,
        more_fg => "cyan",
        more_left => "<..",
        more_right => "..>";

use constant WIDGET_PEN_FROM_STYLE => 1;

=head1 METHODS

=cut

sub TAB_CLASS { shift->{tab_class} || "Tickit::Widget::Tabbed::Tab" }
sub RIBBON_CLASS { shift->{ribbon_class} || "Tickit::Widget::Tabbed::Ribbon" }

=head2 new

Instantiate a new tabbed window.

Takes the following named parameters:

=over 4

=item * tab_position - (optional) location of the tabs, should be one of left, top, right, bottom.

=back

=cut

sub new {
        my $class = shift;
        my %args = @_;
        my $self = $class->SUPER::new(%args);

        $self->{tab_class}  = delete($args{tab_class});
        $self->{ribbon_class} = delete($args{ribbon_class});

        $self->tab_position(delete($args{tab_position}) || 'top');

        my $ribbon = $self->{ribbon};

        $ribbon->set_style( $self->get_style_pen("ribbon")->getattrs );

        return $self;
}

# Positions for the four screen edges - these will return appropriate sizes
# for the tab and child subwindows
sub _window_position_left {
        my $self = shift;
        my $ribbon = $self->{ribbon};
        my $label_width = $ribbon->cols;
        return 0, 0, $self->window->lines, $label_width,
               0, $label_width, $self->window->lines, $self->window->cols - $label_width;
}

sub _window_position_right {
        my $self = shift;
        my $ribbon = $self->{ribbon};
        my $label_width = $ribbon->cols;
        return 0, $self->window->cols - $label_width, $self->window->lines, $label_width,
               0, 0, $self->window->lines, $self->window->cols - $label_width;
}

sub _window_position_top {
        my $self = shift;
        my $ribbon = $self->{ribbon};
        my $label_height = $ribbon->lines;
        $label_height = 1 unless $self->window->lines > $label_height;
        return 0, 0, $label_height, $self->window->cols,
               $label_height, 0, max(1, $self->window->lines - $label_height), $self->window->cols;
}

sub _window_position_bottom {
        my $self = shift;
        my $ribbon = $self->{ribbon};
        my $label_height = $ribbon->lines;
        $label_height = 1 unless $self->window->lines > $label_height;
        return $self->window->lines - $label_height, 0, $label_height, $self->window->cols,
               0, 0, max(1, $self->window->lines - $label_height), $self->window->cols;
}

sub on_style_changed_values {
        my $self = shift;
        my %values = @_;

        if( grep { $_ =~ m/^ribbon_/ } keys %values ) {
                $self->{ribbon}->set_style( $self->get_style_pen("ribbon")->getattrs );
        }
}

sub reshape {
        my $self = shift;
        my $window = $self->window or return;
        my $tab_position = $self->tab_position;
        my @positions = $self->${\"_window_position_$tab_position"}();
        if( my $ribbon_window = $self->{ribbon}->window ) {
                $ribbon_window->change_geometry( @positions[0..3] );
        }
        else {
                my $ribbon_window = $window->make_sub( @positions[0..3] );
                $self->{ribbon}->set_window( $ribbon_window );
        }
        $self->{child_window_geometry} = [ @positions[4..7] ];
        foreach my $tab ( $self->{ribbon}->tabs ) {
                my $child = $tab->widget;
                if( my $child_window = $child->window ) {
                        $child_window->change_geometry( @positions[4..7] );
                }
                else {
                        $child_window = $self->_new_child_window( $child == $self->active_tab->widget );
                        $child->set_window($child_window);
                }
        }
}

sub _max_child_lines
{
        my $self = shift;
        my $ribbon = $self->{ribbon};
        return max( 1, map { $_->widget->requested_lines } $ribbon->tabs );
}

sub _max_child_cols
{
        my $self = shift;
        my $ribbon = $self->{ribbon};
        return max( 1, map { $_->widget->requested_cols } $ribbon->tabs );
}

sub lines
{
        my $self = shift;
        my $ribbon = $self->{ribbon};

        if( $ribbon->orientation eq "horizontal" ) {
                return $ribbon->lines + $self->_max_child_lines;
        }
        else {
                return max( $ribbon->lines, $self->_max_child_lines );
        }
}

sub cols
{
        my $self = shift;
        my $ribbon = $self->{ribbon};

        if( $ribbon->orientation eq "horizontal" ) {
                return max( $ribbon->cols, $self->_max_child_cols );
        }
        else {
                return $ribbon->cols + $self->_max_child_cols;
        }
}

# All the child widgets
sub children {
        my $self = shift;
        my $ribbon = $self->{ribbon};
        return $ribbon, map { $_->widget } $ribbon->tabs;
}

# The only focusable child widget is the active one
sub children_for_focus {
        my $self = shift;
        return $self->active_tab_widget;
}

sub _new_child_window
{
        my $self = shift;
        my ( $visible ) = @_;

        my $window = $self->window or return undef;

        my $child_window = $window->make_hidden_sub( @{ $self->{child_window_geometry} } );
        $child_window->show if $visible;

        return $child_window;
}

sub window_lost {
        my $self = shift;
        $self->SUPER::window_lost(@_);
        $_->widget->set_window(undef) for $self->{ribbon}->tabs;

        undef $self->{child_window_geometry};

        $self->{ribbon}->set_window(undef);
}

=head2 tab_position

Accessor for the tab position (top, left, right, bottom).

=cut

sub tab_position {
        my $self = shift;
        if(@_) {
                my $pos = shift;
                my $orientation = ( $pos eq "top" or $pos eq "bottom" ) ? "horizontal" :
                                  ( $pos eq "left" or $pos eq "right" ) ? "vertical" :
                                  croak "Unrecognised value for ->tab_position: $pos";

                if( !$self->{ribbon} or $self->{ribbon}->orientation ne $orientation ) {
                        my %args = (
                                tabbed => $self,
                                tab_position => $pos,
                        );
                        if( my $old_ribbon = $self->{ribbon} ) {
                                $old_ribbon->set_window( undef );
                                $args{tabs} = [ $old_ribbon->tabs ];
                                $args{active_tab_index} = $old_ribbon->active_tab_index;
                                $args{pen}  = $old_ribbon->pen;
                                $args{active_pen} = $old_ribbon->active_pen;
                                undef $self->{ribbon};
                        }
                        $self->{ribbon} = $self->RIBBON_CLASS->new_for_orientation(
                                $orientation, %args
                        );
                        $self->{ribbon}->set_style( $args{pen}->getattrs ) if $args{pen};
                }

                $self->{tab_position} = $pos;
                undef $self->{child_window_geometry};

                $self->reshape if $self->window;
                $self->redraw;
        }
        return $self->{tab_position};
}

sub _tabs_changed {
        my $self = shift;
        $self->reshape if $self->window;
        $self->{ribbon}->redraw if $self->{ribbon}->window;
}

=head2 active_tab_index

Returns the 0-based index of the currently-active tab.

=cut

sub active_tab_index { shift->{ribbon}->active_tab_index }

=head2 active_tab

Returns the currently-active tab as a tab object. See below.

=cut

sub active_tab { shift->{ribbon}->active_tab }

=head2 active_tab_widget

Returns the widget in the currently active tab.

=cut

# Old name
*tab = \&active_tab_widget;
sub active_tab_widget {
        my $self = shift; $self->active_tab && $self->active_tab->widget
}

=head2 add_tab

Add a new tab to this tabbed widget. Returns an object representing the tab;
see L below.

First parameter is the widget to use.

Remaining form a hash:

=over 4

=item label - label to show on the new tab

=back

=cut

sub add_tab {
        my $self = shift;
        my ($child, %opts) = @_;

        my $ribbon = $self->{ribbon};

        my $tab = $self->TAB_CLASS->new( $self, widget => $child, %opts );

        $ribbon->append_tab( $tab );

        return $tab;
}

=head2 remove_tab

Remove tab given by 0-based index or tab object.

=cut

sub remove_tab { shift->{ribbon}->remove_tab( @_ ) }

=head2 move_tab

Move tab given by 0-based index or tab object forward the given number of
positions.

=cut

sub move_tab { shift->{ribbon}->move_tab( @_ ) }

=head2 activate_tab

Switch to the given tab; by 0-based index, or object.

=cut

sub activate_tab { shift->{ribbon}->activate_tab( @_ ) }

=head2 next_tab

Switch to the next tab.

=cut

sub next_tab { shift->{ribbon}->next_tab }

=head2 prev_tab

Switch to the previous tab.

=cut

sub prev_tab { shift->{ribbon}->prev_tab }

sub child_resized {
        my $self = shift;
        $self->reshape;
}

sub on_key {
        my $self = shift;
        my ($ev) = @_;

        return 1 if $self->{ribbon}->on_key(@_);

        return 0 unless $ev->type eq "key";

        my $str = $ev->str;
        if($str eq 'C-PageUp') {
                $self->prev_tab;
                return 1;
        }
        if($str eq 'C-PageDown') {
                $self->next_tab;
                return 1;
        }
        if($str =~ m/^M-(\d)$/ ) {
                my $index = $1 - 1;
                $self->activate_tab( $index ) if $index < $self->{ribbon}->tabs;
                return 1;
        }
        return 0;
}

sub render_to_rb {
        my $self = shift;
        my ( $rb, $rect ) = @_;

        # Just clear the child area if we have nothing better to do
        $rb->eraserect( $rect );
}

package Tickit::Widget::Tabbed::Tab;

use 5.010; # for //= operator
use Scalar::Util qw( weaken );
use Tickit::Utils qw( textwidth );

=head1 METHODS ON TAB OBJECTS

The following methods may be called on the objects returned by C or
C.

=cut

sub new {
        my $class = shift;
        my ( $tabbed, %args ) = @_;
        my $self = bless {
                tabbed => $tabbed,
                widget => $args{widget},
                label  => $args{label},
                active => 0,
        }, $class;
        weaken( $self->{tabbed} );
        return $self;
}

=head2 index

Returns the 0-based index of this tab

=cut

sub index {
        my $self = shift;
        return $self->{tabbed}->{ribbon}->_tab2index( $self );
}

=head2 widget

Returns the C contained by this tab

=cut

sub widget { shift->{widget} }

=head2 label

Returns the current label text

=cut

sub label_width {
        my $self = shift;
        return $self->{label_width} //= textwidth( $self->{label} );
}

sub label { shift->{label} }

=head2 set_label

Set new label text for the tab

=cut

sub set_label {
        my $self = shift;
        ( $self->{label} ) = @_;
        undef $self->{label_width};
        $self->{tabbed}->_tabs_changed if $self->{tabbed};
}

=head2 is_active

Returns true if this tab is the currently active one

=cut

sub is_active {
        my $self = shift;
        return $self->{tabbed}->active_tab == $self;
}

=head2 activate

Activate this tab

=cut

sub activate {
        my $self = shift;
        $self->{tabbed}->activate_tab( $self );
}

sub _activate {
        my $self = shift;
        $self->widget->window->show if $self->widget->window;
        $self->${\$self->{on_activated}}() if $self->{on_activated};
}

sub _deactivate {
        my $self = shift;
        $self->${\$self->{on_deactivated}}() if $self->{on_deactivated};
        $self->widget->window->hide if $self->widget->window;
}

=head2 set_on_activated

Set a callback or method name to invoke when the tab is activated

=cut

sub set_on_activated
{
        my $self = shift;
        ( $self->{on_activated} ) = @_;
}

=head2 set_on_deactivated

Set a callback or method name to invoke when the tab is deactivated

=cut

sub set_on_deactivated
{
        my $self = shift;
        ( $self->{on_deactivated} ) = @_;
}

=head2 pen

Returns the C used to draw the label.

Pen observers are no longer registered on the return value; to set a different
pen on the tab, use the C method instead.

=cut

sub _has_pen { defined shift->{pen} }

sub pen {
        my $self = shift;
        return $self->{pen};
}

sub set_pen {
        my $self = shift;
        ( $self->{pen} ) = @_;
        $self->{tabbed}->_tabs_changed if $self->{tabbed};
}

sub on_mouse {
        my $self = shift;
        my ( $type, $button, $line, $col ) = @_;

        return 0 unless $type eq "press" && $button == 1;
        $self->{tabbed}->activate_tab( $self );
        return 1;
}

1;

__END__