File Coverage

blib/lib/MarpaX/Database/Terminfo.pm

Criterion	Covered	Total	%
statement	53	61	86.8
branch	2	8	25.0
condition	1	2	50.0
subroutine	11	11	100.0
pod	3	3	100.0
total	70	85	82.3

use strict;
use warnings FATAL => 'all';

package MarpaX::Database::Terminfo;
use MarpaX::Database::Terminfo::Grammar;
use MarpaX::Database::Terminfo::Grammar::Regexp qw/@TOKENSRE/;
use Marpa::R2;

# ABSTRACT: Parse a terminfo data base using Marpa

use Log::Any qw/$log/;
use Carp qw/croak/;

our $VERSION = '0.011'; # VERSION


my %events = (
    'MAXMATCH' => sub {
        my ($recce, $bufferp, $tokensrep, $string, $start, $length) = @_;

        my @expected = @{$recce->terminals_expected()};
        my $prev = pos(${$bufferp});
        pos(${$bufferp}) = $start;
        my $ok = 0;
        if ($log->is_trace) {
            $log->tracef('Expected terminals: %s', \@expected);
        }
        foreach (@{$tokensrep}) {
            my ($token, $re) = @{$_};
            if ((grep {$_ eq $token} @expected)) {
                if (${$bufferp} =~ $re) {
                    $length = $+[1] - $-[1];
                    $string = substr(${$bufferp}, $start, $length);
                    if ($log->is_debug && $token eq 'LONGNAME') {
                        $log->debugf('%s "%s")', $token, $string);
                    } elsif ($log->is_trace) {
                        $log->tracef('lexeme_read(token=%s, start=%d, length=%d, string="%s")', $token, $start, $length, $string);
                    }
                    $recce->lexeme_read($token, $start, $length, $string);
                    $ok = 1;
                    last;
                } else {
                    if ($log->is_trace) {
                        $log->tracef('\"%s\"... does not match %s', substr(${$bufferp}, $start, 20), $re);
                    }
                }
            }
        }
        die "Unmatched token in @expected, current portion of string is \"$string\"" if (! $ok);
        pos(${$bufferp}) = $prev;
    },
);


# ----------------------------------------------------------------------------------------

sub new {
  my $class = shift;

  my $self = {};

  my $grammarObj = MarpaX::Database::Terminfo::Grammar->new(@_);
  my $grammar_option = $grammarObj->grammar_option();
  $grammar_option->{bless_package} = __PACKAGE__;
  $self->{_G} = Marpa::R2::Scanless::G->new($grammar_option);

  my $recce_option = $grammarObj->recce_option();
  $recce_option->{grammar} = $self->{_G};
  $self->{_R} = Marpa::R2::Scanless::R->new($recce_option);

  bless($self, $class);

  return $self;
}
# ----------------------------------------------------------------------------------------

sub _parse {
    my ($self, $bufferp, $tokensrep) = @_;

    my $max = length(${$bufferp});
    for (
        my $pos = $self->{_R}->read($bufferp);
        $pos < $max;
        $pos = $self->{_R}->resume()
    ) {
        my ($start, $length) = $self->{_R}->pause_span();
        my $str = substr(${$bufferp}, $start, $length);
        for my $event_data (@{$self->{_R}->events}) {
            my ($name) = @{$event_data};
            my $code = $events{$name} // die "no code for event $name";
            $self->{_R}->$code($bufferp, $tokensrep, $str, $start, $length);
        }
    }

    return $self;
}

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

    return $self->_parse($bufferp, \@TOKENSRE);
}
# ----------------------------------------------------------------------------------------

sub value {
    my ($self) = @_;

    my $rc = $self->{_R}->value();

    #
    # Another parse tree value ?
    #
    if (defined($self->{_R}->value())) {
        my $msg = 'Ambigous parse tree detected';
        if ($log->is_fatal) {
            $log->fatalf('%s', $msg);
        }
        croak $msg;
    }
    if (! defined($rc)) {
        my $msg = 'Parse tree failure';
        if ($log->is_fatal) {
            $log->fatalf('%s', $msg);
        }
        croak $msg;
    }
    return $rc
}


1;

__END__