File Coverage

blib/lib/Syntax/Highlight/Engine/Simple.pm

Criterion	Covered	Total	%
statement	138	148	93.2
branch	33	42	78.5
condition	6	7	85.7
subroutine	19	20	95.0
pod	8	8	100.0
total	204	225	90.6

package Syntax::Highlight::Engine::Simple;
use warnings;
use strict;
use Carp;
our $VERSION = '0.101';

    ### ---
    ### constructor
    ### ---
    sub new {

        my $class = shift;
        my $self = bless {type => undef, syntax  => undef, @_}, $class;

        $self->setParams(@_);

        if ($self->{type}) {

            my $class = "Syntax::Highlight::Engine::Simple::". $self->{type};

            require $class;
            $class->setSyntax();

            return $self;
        }

        $self->setSyntax();

        return $self;
    }

    ### ---
    ### set params
    ### ---
    sub setParams {

        my $self = shift;

        my %args = (
            html_escape_code_ref => \&_html_escape,
            @_);

        $self->{html_escape_code_ref} = $args{html_escape_code_ref};
    }

    ### ---
    ### set syntax
    ### ---
    sub setSyntax {

        my $self = shift;
        my %args = (syntax => [], @_);

        $self->{syntax} = $args{syntax};
    }

    ### ---
    ### append syntax
    ### ---
    sub appendSyntax {

        my $self = shift;
        my %args = (
            syntax => {
                regexp      => '',
                class       => '',
                container   => undef,
            }, @_);

        push(@{$self->{syntax}}, $args{syntax});
    }

    ### ---
    ### Highlight multi Line
    ### ---
    sub doStr{

        my $self = shift;
        my %args = (str => '', tab_width => -1, @_);

        defined $args{str} or croak 'doStr method got undefined value';

        if ($args{tab_width} > 0) {

            my $tabed = '';

            foreach my $line (split(/\r\n|\r|\n/, $args{str})) {

                $tabed .=
                    &_tab2space($line, $args{tab_width}). "\n";
            }

            $args{str} = $tabed;
        }

        return $self->_doLine($args{str});
    }

    ### ---
    ### Highlight file
    ### ---
    sub doFile {

        my $self = shift;
        my %args = (
            file => '',
            tab_width => -1,
            encode => 'utf8',
            @_);

        my $str = '';

        require 5.005;

        open(my $filehandle, '<'. $args{file}) or croak 'File open failed';
        binmode($filehandle, ":encoding($args{encode})");

        while (my $line = <$filehandle>) {
            if ($args{tab_width} > 0) {
                $line = &_tab2space($line, $args{tab_width});
            }
            $str .= $line;
        }

        close($filehandle);

        return $self->_doLine($str);
    }

    ### ---
    ### Highlight single line
    ### ---
    sub _doLine {

        my ($self, $str) = @_;

        $str =~ s/\r\n|\r/\n/g;

        $self->{_markup_map} = [];

        ### make markup map
        foreach my $i (0 .. $#{$self->{syntax}}) {
            $self->_makeAllowHash($i);
            $self->_make_map($str, $i);
        }

        my $outstr = '';
        my $last_pos = 0;

        ### Apply the map to string
        foreach my $pos ($self->_restracture_map()) {

            my $str_left = substr($str, $last_pos, $$pos[0] - $last_pos);

            $outstr .= $self->{html_escape_code_ref}->($str_left);

            if (defined $$pos[1]) {
                $outstr .= sprintf("", $$pos[1]->{class});
            } else {
                $outstr .= '';
            }
            $last_pos = $$pos[0];
        }

        return $outstr. $self->{html_escape_code_ref}->(substr($str, $last_pos));
    }

    ### ---
    ### Prepare hash for container matching
    ### ---
    sub _makeAllowHash {

        my $self = shift;

        if (! exists $self->{syntax}->[$_[0]]->{container} ) {
            return;
        }

        my $allowed = $self->{syntax}->[$_[0]]->{container};

        if (ref $allowed eq 'ARRAY') {
            foreach my $class ( @$allowed ) {
                $self->{syntax}->[$_[0]]->{_cont_hash}->{$class} = 0;
            }
        } elsif ($allowed) {
            $self->{syntax}->[$_[0]]->{_cont_hash}->{$allowed} = 0;
        }
    }

    ### ---
    ### Make markup map
    ### ---------------------------------------
    ### | open_pos  | close_pos | syntax index
    ### | open_pos  | close_pos | syntax index
    ### | open_pos  | close_pos | syntax index
    ### ---------------------------------------
    ### ---
    sub _make_map {

        no warnings; ### Avoid Deep Recursion warning

        my ($self, $str, $index, $pos) = @_;
        $pos ||= 0;

        my $map_ref = $self->{_markup_map};

        my @scraps =
            split(/$self->{syntax}->[$index]->{regexp}/, $str, 2);

        if ((scalar @scraps) >= 2) {

            my $rest = pop(@scraps);
            my $ins_pos0 = $pos + length($scraps[0]);
            my $ins_pos1 = $pos + (length($str) - length($rest));

            ### Add markup position
            push(@$map_ref, [
                    $ins_pos0,
                    $ins_pos1,
                    $index,
                ]
            );

            ### Recurseion for rest
            $self->_make_map($rest, $index, $ins_pos1);
        }

        ### Follow up process
        elsif (@$map_ref) {

            @$map_ref = sort {
                    $$a[0] <=> $$b[0] or
                    $$b[1] <=> $$a[1] or
                    $$a[2] <=> $$b[2]
                } @$map_ref;
        }

        return;
    }

    ### ---
    ### restracture the map data into following format
    ### ------------------------
    ### | open_pos  | syntax ref
    ### | close_pos |
    ### | open_pos  | syntax ref
    ### | close_pos |
    ### ------------------------
    ### ---
    sub _restracture_map {

        my $self = shift;
        my $map_ref = $self->{_markup_map};
        my @out_array;
        my @root = ();

        REGLOOP: for (my $i = 0; $i < scalar @$map_ref; $i++) {

            ### vacuum @root
            for (my $j = 0; $j < scalar @root; $j++) {
                if ($root[$j]->[1] <= $$map_ref[$i]->[0]) {
                    splice(@root, $j--, 1);
                }
            }

            my $syntax_ref = $self->{syntax}->[$$map_ref[$i]->[2]];
            my $ok = 0;

            ### no container restriction
            if (! exists $$syntax_ref{container}) {
                if (!scalar @root) {
                    $ok = 1;
                }
            } else {

                ### Search for container
                BACKWARD: for (my $j = scalar @root - 1;  $j >= 0; $j--) {

                    ### overlap?
                    if ($root[$j]->[1] > $$map_ref[$i]->[0]) {

                        ### contained?
                        if ($root[$j]->[1] >= $$map_ref[$i]->[1]) {

                            my $root_class =
                                $self->{syntax}->[$root[$j]->[2]]->{class};

                            if (exists $$syntax_ref{_cont_hash}->{$root_class}) {
                                $ok = 1; last BACKWARD; # allowed
                            }
                            last BACKWARD; # container not allowed
                        }
                        last BACKWARD; # illigal overlap
                    }
                    splice(@root, $j, 1);
                }
            }

            if (! $ok) {
                splice(@$map_ref, $i--, 1);
                next REGLOOP;
            }

            push(@root, $$map_ref[$i]);

            push(
                @out_array,
                [$$map_ref[$i]->[0], $syntax_ref],
                [$$map_ref[$i]->[1]]
            );
        }
        @out_array = sort {$$a[0] <=> $$b[0]} @out_array;
        return @out_array;
    }

    ### ---
    ### replace tabs to spaces
    ### ---
    sub _tab2space {

        no warnings 'recursion';

        my ($str, $width) = @_;
        $str ||= '';
        $width = defined $width ? $width : 4;
        my @scraps = split(/\t/, $str, 2);

        if (scalar @scraps == 2) {

            my $num = $width - (length($scraps[0]) % $width);
            my $right_str = &_tab2space($scraps[1], $width);

            return ($scraps[0]. ' ' x $num. $right_str);
        }

        return $str;
    }

    ### ---
    ### convert array to regexp
    ### ---
    sub array2regexp {

        my $self = shift;

        return sprintf('\\b(?:%s)\\b', join('|', @_));
    }

    ### ---
    ### Return Class names
    ### ---
    sub getClassNames {

        return map {${$_}{class}} @{shift->{syntax}}
    }

    ### ---
    ### HTML escape
    ### ---
    sub _html_escape {

        my ($str) = @_;

        $str =~ s/&/&/g;
        $str =~ s/
        $str =~ s/>/>/g;

        return $str;
    }

1;

__END__