File Coverage

blib/lib/Pod/Text/Color/Delight.pm

Criterion	Covered	Total	%
statement	108	112	96.4
branch	16	18	88.8
condition	9	11	81.8
subroutine	24	24	100.0
pod	1	12	8.3
total	158	177	89.2

package Pod::Text::Color::Delight;
use 5.008005;
use strict;
use warnings;
use Term::ANSIColor ();
use File::Spec::Functions qw(catfile);
use Syntax::Highlight::Perl::Improved;
use parent 'Pod::Text::Color';

our $VERSION = '0.07';

use constant COLOR_TABLE => {
    head1  => 'bright_cyan',
    head2  => 'reset bold',
    head3  => '',
    head4  => '',
    bold   => 'reset bold',
    file   => 'bright_green',
    italic => 'reset italic',
    link   => 'rgb045',
    code   => {
        Character         => 'cyan',
        String            => 'rgb542',
        Quote             => 'rgb542',
        Label             => 'rgb542',

        Builtin_Function  => 'bright_red',
        Builtin_Operator  => 'bright_red',

        Keyword           => 'bright_red',
        Package           => 'rgb345',

        Subroutine        => 'rgb454',
        Bareword          => 'white',
        Symbol            => 'white',
        Operator          => 'white',
        Number            => 'white',

        Variable_Hash     => 'rgb520',
        Variable_Array    => 'rgb520',
        Variable_Scalar   => 'rgb520',
        Variable_Typeglob => 'rgb520',

        Comment_Normal    => 'grey10',
        Comment_POD       => 'grey10',
        DATA              => 'grey10',
        Directive         => 'bright_green',
    },
};

sub new {
    my $class = shift;

    my $self = $class->SUPER::new;

    my $color_table_file = catfile($ENV{HOME}, '.pod_text_color_delight');
    my $color_table = COLOR_TABLE;
    if (!$ENV{POD_TEXT_COLOR_DELIGHT_DEFAULT} && -f $color_table_file) {
        $color_table = do $color_table_file;
    }

    $self->{color_table} = $color_table;
    return $self;
}

sub cmd_head1 {
    my ($self, $attrs, $text) = @_;
    $self->SUPER::cmd_head1($attrs, $self->_colored($text, $self->_select_color('head1')));
}

sub cmd_head2 {
    my ($self, $attrs, $text) = @_;
    $self->SUPER::cmd_head2($attrs, $self->_colored($text, $self->_select_color('head2')));
}

sub cmd_head3 {
    my ($self, $attrs, $text) = @_;
    $self->SUPER::cmd_head3($attrs, $self->_colored($text, $self->_select_color('head3')));
}

sub cmd_head4 {
    my ($self, $attrs, $text) = @_;
    $self->SUPER::cmd_head4($attrs, $self->_colored($text, $self->_select_color('head4')));
}

sub cmd_b {
    my ($self, $attrs, $text) = @_;

    if ($self->{PENDING}->[2]) {
        return "B<$text>";
    }

    $text = $self->_highlight_raw_format($attrs, $text);
    $self->SUPER::cmd_b($attrs, $self->_colored($text, $self->_select_color('bold')));
}

sub cmd_f {
    my ($self, $attrs, $text) = @_;

    if ($self->{PENDING}->[2]) {
        return "F<$text>";
    }

    $text = $self->_highlight_raw_format($attrs, $text);
    $self->SUPER::cmd_f($attrs, $self->_colored($text, $self->_select_color('file')));
}

sub cmd_c {
    my ($self, $attrs, $text) = @_;

    my $highlighted = $self->SUPER::cmd_c($attrs, $self->_highlight_code($attrs, $text));
    $self->{raw} = $text; # for C<...> that is in `=item`

    # XXX for file format
    $highlighted =~ s/\e\[37mF\e\[0m\e\[37m<\e\[0m(.*?)\e\[37m>\e\[0m
                     /$self->cmd_f(Term::ANSIColor::colorstrip($attrs, $1))
                     /gex;

    # XXX for italic format
    $highlighted =~ s/\e\[37mI\e\[0m\e\[37m<\e\[0m(.*?)\e\[37m>\e\[0m
                     /$self->cmd_i(Term::ANSIColor::colorstrip($attrs, $1))
                     /gex;

    # XXX for bold format
    $highlighted =~ s/\e\[37mB\e\[0m\e\[37m<\e\[0m(.*?)\e\[37m>\e\[0m
                     /$self->cmd_b(Term::ANSIColor::colorstrip($attrs, $1))
                     /gex;

    # XXX for link format
    $highlighted =~ s/\e\[37mL\e\[0m\e\[37m<\e\[0m(.*?)\e\[37m>\e\[0m
                     /$self->cmd_l(Term::ANSIColor::colorstrip({type => 'pod'}, $1))
                     /gex;

    return $highlighted;
}

sub cmd_item_text {
    my ($self, $attrs, $text) = @_;

    my $raw = $self->{raw};
    my ($_text) = Term::ANSIColor::colorstrip($text) =~ m/^"(.*)"$/;

    if ($raw && $_text && $_text eq $raw) {
        $text = $self->{raw};
        $text = '"' . $text . '"';
    }
    $self->SUPER::cmd_item_text($attrs, $text);

    undef $self->{raw};
}

sub cmd_i {
    my ($self, $attrs, $text) = @_;

    if ($self->{PENDING}->[2]) {
        return "I<$text>";
    }

    $text = $self->_highlight_raw_format($attrs, $text);
    $self->SUPER::cmd_i($attrs, $self->_colored($text, $self->_select_color('italic')));
}

sub cmd_l {
    my ($self, $attrs, $text) = @_;

    # to fix the issues that are displayed on the double
    if ($attrs->{type} eq 'url') {
        $attrs->{type} = 'pod';
    }

    if ($self->{PENDING}->[2]) {
        return "L<$text>";
    }

    $text = $self->_highlight_raw_format($attrs, $text);
    $self->SUPER::cmd_l($attrs, $self->_colored($text, $self->_select_color('link')));
}

sub cmd_verbatim {
    my ($self, $attrs, $text) = @_;
    $self->SUPER::cmd_verbatim($attrs, $self->_highlight_code($attrs, $text));
}

sub _highlight_code {
    my ($self, $attrs, $text) = @_;

    my $formatter = Syntax::Highlight::Perl::Improved->new;

    while (my ($type, $style) = each %{$self->_select_color('code')}) {
        Term::ANSIColor::colored('dummy', $style);
        if ($@) {
            $style = 'reset';
        }
        $formatter->set_format($type, [Term::ANSIColor::color($style), Term::ANSIColor::color('reset')]);
    }

    return $formatter->format_string($text);
}

sub _select_color {
    my ($self, $element) = @_;

    return $self->{color_table}->{$element} || COLOR_TABLE->{$element} || 'reset';
}

sub _colored {
    my ($self, $text, $color) = @_;

    my $colored_text = '';
    eval { $colored_text = Term::ANSIColor::colored($text, $color) };

    if ($@) {
        $colored_text = Term::ANSIColor::colored($text, 'reset');
    }

    return $colored_text;
}

sub _highlight_raw_format {
    my ($self, $attrs, $text) = @_;

    # XXX for file format
    $text =~ s/F<(.*?)>
              /$self->cmd_f(Term::ANSIColor::colorstrip($attrs, $1))
              /ex;

    # XXX for italic format
    $text =~ s/I<(.*?)>
              /$self->cmd_i(Term::ANSIColor::colorstrip($attrs, $1))
              /ex;

    # XXX for bold format
    $text =~ s/B<(.*?)>
              /$self->cmd_b(Term::ANSIColor::colorstrip($attrs, $1))
              /ex;

    # XXX for link format
    $text =~ s/L<(.*?)>
              /$self->cmd_l(Term::ANSIColor::colorstrip({type => 'pod'}, $1))
              /ex;

    return $text;
}
1;
__END__