File Coverage

blib/lib/Pod/Term.pm

Criterion	Covered	Total	%
statement	223	235	94.8
branch	67	100	67.0
condition	43	77	55.8
subroutine	31	31	100.0
pod	4	4	100.0
total	368	447	82.3

package Pod::Term;

use strict;
use warnings;
use Pod::Simple;
use base 'Pod::Simple';
use Term::ANSIColor 'colored';
use Clone 'clone';
use Carp;
use Hash::Merge;

our $VERSION = 0.02;

sub _default_prop_map{
    return {
        head1 => {
            display => 'block',
            stacking => 'revert',
            indent => 0,
            after_indent => 2,
            color => 'on_blue',
            bottom_spacing => 2
        },

        head2 => {
            display => 'block',
            stacking => 'revert',
            indent => 0,
            after_indent => 2,
            color => 'blue',
            bottom_spacing => 2
        },

        head3 => {
            display => 'block',
            stacking => 'revert',
            indent => 0,
            after_indent => 2,
            color => 'magenta',
            bottom_spacing => 2
        },

        head4 => {
            display => 'block',
            stacking => 'revert',
            indent => 0,
            after_indent => 2,
            color => 'bright_magenta',
            bottom_spacing => 2
        },

        'over-text' => {
            display => 'block',
            stacking => 'nest',
            indent => 2
        },

        'over-number' => {
            display => 'block',
            stacking => 'nest',
            indent => 2
        },

        'over-bullet' => {
            display => 'block',
            stacking => 'nest',
            indent => 2,
            bottom_spacing => 1
        },

        'item-text' => {
            display => 'block',
            stacking => 'spot',
            color => 'yellow',
            indent => 0,
            after_indent => 2,
            bottom_spacing => 2
        },

        'item-number' => {
            display => 'block',
            stacking => 'nest',
            color => 'yellow',
            prepend => {
                text => '@number. ',
                color => 'red'
            },
            bottom_spacing => 2
        },

        'item-bullet' => {
            display => 'block',
            stacking => 'nest',
            color => 'yellow',
            prepend => {
                text => '* ',
                color => 'red'
            },
            bottom_spacing => 1
        },

        'B' => {
            display => 'inline',
            color => 'bright_yellow'
        },

        'C' => {
            display => 'inline',
            color => 'cyan'
        },

        'I' => {
            display => 'inline',
            color => 'bright_white'
        },

        'L' => {
            display => 'inline',
            color => 'bright_green'
        },

        'E' => {
            display => 'inline',
            color => 'white'
        },

        'F' => {
            display => 'inline',
            color => 'bright_white'
        },

        'S' => {
            display => 'inline',
            color => 'cyan',
            wrap => 'verbatim'
        },

        'Para' => {
            display => 'block',
            stacking => 'nest',
            color => 'white',
            bottom_spacing => 2,
        },

        'Verbatim' => {
            display => 'block',
            stacking => 'nest',
            color => 'cyan',
            bottom_spacing => 2,
            wrap => 'verbatim'
        },

        'Document' => {
            display => 'block',
            stacking => 'nest',
            indent => 2
        }
    };
}

sub _default_globals {
    return {
        max_cols => 76,
        base_color => 'white'
    };
}



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

    confess "Expected a hash ref but got $globals" if defined $globals && ref $globals ne ref {};

    if ( $globals ){
        $self->{globals} = $globals;
    }

    $self->{globals} ||= $self->_default_globals;
    return $self->{globals};
}



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

    confess "Expected a hash ref but got $prop_map" if defined $prop_map && ref $prop_map ne ref {};

    if ( $prop_map ){
        $self->{prop_map} = $prop_map;
    }

    $self->{prop_map} ||= $self->_default_prop_map;
    return $self->{prop_map};
}


sub set_props{
    my ($self,$props) = @_;

    confess "Need a hash ref of properties to set" unless $props;
    confess "Expected a hash ref but got $props" if ref $props ne ref {};

    my $merger = Hash::Merge->new('LEFT_PRECEDENT');
    my $prop_map = $merger->merge( $props, $self->prop_map );
    $self->prop_map( $prop_map );
}



sub set_prop{
    my ($self,$element_name,$prop_name,$value) = @_;

    confess "set_prop needs: element_name, prop_name, value" unless $element_name && $prop_name && $value;
    $self->prop_map->{$element_name}{$prop_name} = $value;

}


sub _stack{
    my ($self,$stack) = @_;

    confess "Expected an array ref but got $stack" if defined $stack && ref $stack ne ref [];

    if ( $stack ){
        $self->{stack} = $stack;
    }

    $self->{stack} ||= [];
    return $self->{stack};
}

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

    confess "Expected a string but got $color" if defined $color && ref $color ne ref '';

    if ( $color ){
        $self->{color} = $color
    }
    $self->{color} ||= $self->globals->{base_color};

    return $self->{color};
}

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

    confess "Expected a string but got $color" if defined $color && ref $color ne ref '';

    if ( $color ){
        $self->{last_color} = $color;
    }

    $self->{last_color} ||= $self->_color;
    return $self->{last_color};
}


sub _blocks{
    my ($self,$blocks) = @_;

    confess "Expected an array ref but got $blocks" if defined $blocks && ref $blocks ne ref [];

    if ( $blocks ){
        $self->{blocks} = $blocks;
    }

    $self->{blocks} ||= [];
    return $self->{blocks};
}




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

    my $stacking = $self->_get_prop($element,'stacking');

    if ( $stacking eq 'nest' ){

        push @{$self->_stack}, $element;

    } elsif ( $stacking eq 'spot' ){

        my @stack = @{$self->_stack};
        push @{$self->_stack}, $element unless $stack[$#stack] eq $element;

    } elsif ( $stacking eq 'revert' ){

        my @stack = @{$self->_stack};
        my ($i) = grep{ $self->_stack->[$_] eq $element } 0..$#stack;

        if ( defined $i ){

            my @new_stack = @stack[0..$i];
            $self->_stack( \@new_stack );

        } else {

            push @{$self->_stack}, $element;

        }
    }
}



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

    my $stacking = $self->prop_map->{ $element }->{ stacking };

    if ( $stacking eq 'nest' ){

        pop @{$self->_stack};

    }
}





sub _calc_indent{
    my $self = shift;

    my $indent = 0;

    my @stack = @{$self->_stack};

    for my $i (0..$#stack){

        my $prop_set = $self->prop_map->{ $stack[$i] };
        $indent += $prop_set->{ indent } if $prop_set->{ indent };
        $indent += $prop_set->{ after_indent } if $prop_set->{after_indent} && $i != $#stack;

    }

    return $indent;
}




sub _insert{
    my ($self,$ins,$block) = @_;

    my $text = $ins->{text};
    $block ||= $self->_blocks->[0];

    if ( $block->{attr} ){

        my @frags = split( /\\\\/, $ins->{text} );
        for my $i (0..$#frags){

            $frags[$i] =~ s/(?{attr}{$1}}/g;

        }
        $text = join('\\',@frags);
    }

    my $item = { text => $text };
    my $color = $ins->{color} || $self->_color;
    $item->{color} = $color if $color;
    push @{$block->{items}}, $item;

}



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

    my $att_set = $self->prop_map->{$element};

    $self->_last_color( $self->_color );
    if ( $att_set->{color} ){
        $self->_color( $att_set->{color} );
    }
}




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

    my $color_cp = $self->_color;
    $self->_color( $self->_last_color );
    $self->_last_color( $color_cp );

}



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

    my $prop;

    my $prop_set = $self->prop_map->{ $element };

    if ( $prop_set ){

        $prop = $prop_set->{$prop_name};

    }
    return $prop;
}




sub _handle_element_start{

    my ($self, $element, $attr) = @_;

    $self->_color_start( $element );

    my $display = $self->_get_prop( $element, 'display' );

    if ( $display && $display eq 'block' ){

        my $top_spacing = $self->_get_prop( $element, 'top_spacing' ) || 0;
        print "\n" x $top_spacing if $top_spacing;


        my $indent = $self->_calc_indent;

        $self->_stack_start( $element );

        my $block = { items => [], indent => $indent, name => $element };
        $block->{attr} = clone $attr if $attr;
        $block->{wrap} = $self->_get_prop( $element, 'wrap' ) || 'normal';
        $block->{top_spacing} = $self->_get_prop( $element, 'top_spacing' ) || 0;
        $block->{bottom_spacing} = $self->_get_prop( $element, 'bottom_spacing' ) || 0;
        unshift @{$self->_blocks}, $block;

    }

    my $prepend = $self->_get_prop( $element, 'prepend' );
    $self->_insert( $prepend ) if $prepend;

}






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

    $self->_color_end( $element );

    my $append = $self->_get_prop( $element, 'append' );
    $self->_insert( $append ) if $append;

    my $display = $self->_get_prop( $element, 'display' );

    if ( $display && $display eq 'block' ){
        my $block = shift @{$self->_blocks};

        $block->{indent} = $self->_calc_indent;

        if ( $block->{wrap} && $block->{wrap} eq 'verbatim'){
            $self->_print_verbatim( $block );
        } else {
            $self->_print_block( $block );
        }
        print "\n" x $block->{bottom_spacing} if $block->{bottom_spacing};

        $self->_stack_end( $element );
    }
}



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

    my $item = {
        text => $text
    };

    $item->{color} = $self->_color if $self->_color;

    push @{$self->_blocks->[0]->{items}},$item;

}





sub _print_block{
    my ($self,$block) = @_;

    my $items = clone $block->{items};
    my $in_body = 0;

    while (@$items){

        my $line = [];
        my $max_chars = $self->globals->{max_cols} - $block->{indent};
        my $chars_left = $max_chars;

        confess "Attempt to print block with an indent >= the maximum number of columns" if $chars_left < 1;

        my $item;

        do {

            $item = shift @$items;

            if ( $item ){

                if ( length( $item->{text} ) <= $chars_left ) {

                    push @$line, $item;
                    $chars_left -= length( $item->{text} );

                } else {

                    my $q_item;
                    ($item,$q_item) = $self->_break_item( $item, $chars_left, $max_chars );

                    if ( $item ){
                        push @$line, $item;
                        $chars_left -= length( $item->{text} );
                    }
                    unshift @$items, $q_item;

                }

            }

        } while ( $item );

        my $margin = ' ' x $block->{indent};
        my $line_str = '';

        foreach my $li ( @$line ){

            if ( $li->{text} !~ /^\s*$/s && $li->{color} ){
                $line_str .= colored( $li->{text}, $li->{color} );
            } else {
                $line_str .= $li->{text};
            }
        }


        $line_str = $margin.$line_str;
        $line_str = "\n".$line_str if $in_body;
        print $line_str;

        $in_body = 1;

    }

}



sub _print_verbatim{
    my ($self,$block) = @_;

    my $text = '';

    my $color;
    foreach my $item ( @{$block->{items}} ){

        $color ||= $item->{color};
        $text .= $item->{text};

    }

    return if $text =~ /^\s*$/;

    my $indent = $block->{indent} || 0;
    my $margin = ' ' x $indent;

    my @lines = split( /\n/,$text );
    push @lines,"" if $text =~ /\n$/;

    $text = '';
    for my $i (0..$#lines){

        my $line = $lines[$i];

        if ( $line =~ /^\s*$/ ){
            $line = '';
        } else {
            $line =~ s/^(.*)$/$margin$1/;
        }

        $text .= $line;
        $text .= "\n" unless $i == $#lines;
    }

    $text = colored( $text, $color ) if $color;
    print $text;

}





sub _break_item{
    my ($self,$item,$chars_left, $max_chars) = @_;

    my $text = $item->{text};
    my $start_length = length( $text );

    my $clipped;

    if ( $chars_left > 1 ){

        $text =~ s/^(.{0,$chars_left})\s+//s;

        $clipped = $1;

    }

    if (! $clipped && $chars_left == $max_chars ){
        $text =~ s/^(.{$chars_left})//s;
        $clipped = $1;
    }

    my $inc_item = undef;
    if ( $clipped ){

        $inc_item = {
            text => $clipped.' ',
            color => $item->{color}
        }

    }

    return ($inc_item,{
        text => $text,
        color => $item->{color},

    });

}

1;
__END__