File Coverage

blib/lib/Curses/Toolkit/Theme.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

#
# 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::Theme;
{
  $Curses::Toolkit::Theme::VERSION = '0.211';
}

# ABSTRACT: base class for widgets themes

use Params::Validate qw(SCALAR ARRAYREF HASHREF CODEREF GLOB GLOBREF SCALARREF HANDLE BOOLEAN UNDEF validate validate_pos);
use Curses;


# service color initialization;
my $color_initialized = 0;

sub new {
    my $class = shift;
    my ($widget) = validate_pos( @_, { isa => 'Curses::Toolkit::Widget' } );
    $class eq __PACKAGE__ and die "abstract class";
    my $self = bless { widget => $widget }, $class;
    $self->set_property( ref $widget, $self->_get_default_properties( ref $widget ) );
    $color_initialized or $class->_init_themes_colors();
    return $self;
}

sub default_fgcolor { 'white' }
sub default_bgcolor { 'black' }

my %colors_to_pair;

sub _init_themes_colors {
    my ($class) = @_;
    if ( has_colors() ) {

        # default color 0, can't be changed.
        $colors_to_pair{'white'}{'black'} = 0;

        # define all posisble color
        my $counter                 = 1;
        my %colors_to_curses_colors = (
            black   => COLOR_BLACK,
            red     => COLOR_RED,
            green   => COLOR_GREEN,
            yellow  => COLOR_YELLOW,
            blue    => COLOR_BLUE,
            magenta => COLOR_MAGENTA,
            cyan    => COLOR_CYAN,
            white   => COLOR_WHITE,
        );
        my @color = keys %colors_to_curses_colors;
        foreach my $fgcolor (@color) {
            foreach my $bgcolor (@color) {
                $fgcolor eq 'white' && $bgcolor eq 'black'
                    and next;
                init_pair( $counter, $colors_to_curses_colors{$fgcolor}, $colors_to_curses_colors{$bgcolor} );
                $colors_to_pair{$fgcolor}{$bgcolor} = COLOR_PAIR($counter);
                $counter++;
            }
        }
        $color_initialized = 1;
    }
}

sub _set_fgcolor {
    my ( $self, $fgcolor ) = @_;
    $self->{_fgcolor} = $fgcolor;
    return $self;
}

sub _set_bgcolor {
    my ( $self, $bgcolor ) = @_;
    $self->{_bgcolor} = $bgcolor;
    my ( $package, $filename, $line ) = caller;
    return $self;
}

sub _set_colors {
    my ( $self, $fgcolor, $bgcolor ) = @_;
    $self->_set_bgcolor($bgcolor);
    $self->_set_fgcolor($fgcolor);
    return $self;
}

sub _get_fg_color { shift->{_fgcolor}; }

sub _get_bg_color { shift->{_bgcolor}; }

sub _get_color_pair {
    my ($self) = @_;
    has_colors()
        or die "Color is not supported by your terminal";
    return $colors_to_pair{ $self->_get_fg_color() }{ $self->_get_bg_color() };
}



sub set_property {
    my $self       = shift;
    my $class_name = shift;
    my $definition = $class_name->_get_theme_properties_definition();
    my ( $property_name, $value ) = @_;
    my $parameters = {};
    if ( ref $property_name eq 'HASH' && !defined $value ) {
        $parameters = $property_name;
    } elsif ( !ref $property_name ) {
        $parameters = { $property_name => $value };
    }

    my @parameters = %$parameters;
    my %params = validate( @parameters, $definition );

    @{ $self->{property}{$class_name} }{ keys %params } = values %params;
    return $self;
}


sub get_property {
    my $self = shift;
    my ( $class_name, $property_name ) = validate_pos( @_, 1, 0 );
    my $properties = $self->{property}{$class_name};
    defined $properties or $properties = {};
    if ( defined $property_name ) {
        return $properties->{$property_name};
    }
    return ( {%$properties} );
}


sub get_widget {
    my ($self) = @_;
    defined $self->{widget} or return;
    return $self->{widget};
}


sub get_window {
    my ($self) = @_;
    my $widget = $self->get_widget()
        or return;
    my $window = $widget->get_window()
        or return;
    return $window;
}


sub get_root_window {
    my ($self) = @_;
    my $window = $self->get_window()
        or return;
    my $root_window = $window->get_root_window()
        or return;
    return $root_window;
}


sub get_shape {
    my ($self) = @_;
    my $shape = $self->get_widget->get_visible_shape();

    #	my $root_window = $self->get_root_window()
    #	  or return;
    #	my $shape = $root_window->get_shape()
    #	  or return;

    return $shape;
}


sub is_in_shape {
    my $self  = shift;
    my $shape = $self->get_shape()
        or return;
    return Curses::Toolkit::Object::Coordinates->new(@_)->is_inside($shape);
}


sub restrict_to_shape {
    my $self  = shift;
    my %args = @_;
    my $attr = delete $args{attr} || {};
    my $c = Curses::Toolkit::Object::Coordinates->new(%args);
    $attr->{no_shape_restriction}
      and return $c;
    my $shape = $self->get_shape()
        or return;
    return $c->restrict_to($shape);
}


sub curses {
    my ( $self, $attr ) = @_;
    my $caller = ( caller(1) )[3];
    my $type = uc( ( split( '_', $caller ) )[1] );
    $self->_compute_attributes( $type, $attr );
    return $self->_get_curses_handler();
}

# gets the curses handler of the associated widget
#
#  input  : none
#  output : a Curses object
sub _get_curses_handler {
    my ($self) = @_;
    return $self->get_widget()->_get_curses_handler();
}

sub _compute_attributes {
    my ( $self, $type, $attr ) = @_;

    # reset display attributes
    $self->_get_curses_handler()->attrset(0);
    $attr ||= {};
    $self->_set_fgcolor( $self->default_fgcolor() );
    $self->_set_bgcolor( $self->default_bgcolor() );

    # get the type of attributes we want, and call the method
    my $method = $type . '_NORMAL';
    $self->$method();
    if ( ( $self->get_widget()->isa('Curses::Toolkit::Role::Focusable') && $self->get_widget()->is_focused() )
        || delete $attr->{focused} )
    {
        $method = $type . '_FOCUSED';
        $self->$method();
    }
    if ( delete $attr->{clicked} ) {
        $method = $type . '_CLICKED';
        $self->$method();
    }

    # check if additional attributes need to be applied
    if ( exists $attr->{bold} ) {
        $attr->{bold} and $self->_attron(A_BOLD);
        $attr->{bold} or $self->_attroff(A_BOLD);
    }
    if ( exists $attr->{reverse} ) {
        $attr->{reverse} and $self->_attron(A_REVERSE);
        $attr->{reverse} or $self->_attroff(A_REVERSE);
    }
    if ( exists $attr->{fgcolor} ) {
        $self->_set_fgcolor( $attr->{fgcolor} );
    }
    if ( exists $attr->{bgcolor} ) {
        $self->_set_bgcolor( $attr->{bgcolor} );
    }
    has_colors()
        and $self->_get_curses_handler()->attron( $self->_get_color_pair() );
    return;
}

sub _attron {
    my $self = shift;
    $self->_get_curses_handler()->attron(@_);
    return $self;
}

sub _attroff {
    my $self = shift;
    $self->_get_curses_handler()->attroff(@_);
}

sub _attrset {
    my $self = shift;
    $self->_get_curses_handler()->attrset(@_);
}

sub _addstr_with_tags {
    my ( $self, $initial_attr, $x, $y, $text ) = @_;

    use Curses::Toolkit::Object::MarkupString;
    ref $text
        or $text = Curses::Toolkit::Object::MarkupString->new($text);

    my $struct = $text->get_attr_struct();

    # get the curses handler
    my $curses = $self->_get_curses_handler();

    my $caller = ( caller(1) )[3];
    my $type = uc( ( split( '_', $caller ) )[1] );

    foreach my $element (@$struct) {
        my ( $char, @attrs ) = @$element;
        $self->_compute_attributes( $type, $initial_attr );
        my $value = 0;


        my %weight_to_const = (
            normal    => A_NORMAL,
            standout  => A_STANDOUT,
            underline => A_UNDERLINE,
            reverse   => A_REVERSE,
            blink     => A_BLINK,
            dim       => A_DIM,
            bold      => A_BOLD
        );

        foreach my $attr (@attrs) {
            my $weight = $attr->{weight};
            if ( defined $weight && $weight ) {
                my $v = $weight_to_const{$weight};
                if ( defined $v ) {
                    $value = ( $value | $v );
                } else {
                    warn
                        "WARNING : you used this string as value for the 'weight' attribute in one of the  tags in your strings : '$weight'. However it's not supported. Available 'weight' values are : "
                        . join( ', ', keys %weight_to_const );
                }
                $weight eq 'normal'
                    and $value = 0;
            }

            defined $attr->{fgcolor}
                and $self->_set_fgcolor( $attr->{fgcolor} );
            defined $attr->{bgcolor}
                and $self->_set_bgcolor( $attr->{bgcolor} );
        }
        has_colors()
            and $value = ( $value | $self->_get_color_pair() );
        $curses->attron($value);
        $curses->addstr( $y, $x, $char );
        $x++;
    }
    return $self;
}

1;

__END__