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


line stmt bran cond sub pod time code
1 18     18   59709 use strict;
  18         37  
  18         753  
2 18     18   101 use warnings FATAL => 'all';
  18         38  
  18         3036  
3              
4             package MarpaX::Database::Terminfo;
5 18     18   18126 use MarpaX::Database::Terminfo::Grammar;
  18         62  
  18         667  
6 18     18   167 use MarpaX::Database::Terminfo::Grammar::Regexp qw/@TOKENSRE/;
  18         42  
  18         2722  
7 18     18   18680 use Marpa::R2;
  18         16536017  
  18         1018  
8              
9             # ABSTRACT: Parse a terminfo data base using Marpa
10              
11 18     18   200 use Log::Any qw/$log/;
  18         40  
  18         240  
12 18     18   1701 use Carp qw/croak/;
  18         41  
  18         18258  
13              
14             our $VERSION = '0.010'; # VERSION
15              
16              
17             my %events = (
18             'MAXMATCH' => sub {
19             my ($recce, $bufferp, $tokensrep, $string, $start, $length) = @_;
20              
21             my @expected = @{$recce->terminals_expected()};
22             my $prev = pos(${$bufferp});
23             pos(${$bufferp}) = $start;
24             my $ok = 0;
25             if ($log->is_trace) {
26             $log->tracef('Expected terminals: %s', \@expected);
27             }
28             foreach (@{$tokensrep}) {
29             my ($token, $re) = @{$_};
30             if ((grep {$_ eq $token} @expected)) {
31             if (${$bufferp} =~ $re) {
32             $length = $+[1] - $-[1];
33             $string = substr(${$bufferp}, $start, $length);
34             if ($log->is_debug && $token eq 'LONGNAME') {
35             $log->debugf('%s "%s")', $token, $string);
36             } elsif ($log->is_trace) {
37             $log->tracef('lexeme_read(token=%s, start=%d, length=%d, string="%s")', $token, $start, $length, $string);
38             }
39             $recce->lexeme_read($token, $start, $length, $string);
40             $ok = 1;
41             last;
42             } else {
43             if ($log->is_trace) {
44             $log->tracef('\"%s\"... does not match %s', substr(${$bufferp}, $start, 20), $re);
45             }
46             }
47             }
48             }
49             die "Unmatched token in @expected, current portion of string is \"$string\"" if (! $ok);
50             pos(${$bufferp}) = $prev;
51             },
52             );
53              
54              
55             # ----------------------------------------------------------------------------------------
56              
57             sub new {
58 2     2 1 28 my $class = shift;
59              
60 2         6 my $self = {};
61              
62 2         26 my $grammarObj = MarpaX::Database::Terminfo::Grammar->new(@_);
63 2         15 my $grammar_option = $grammarObj->grammar_option();
64 2         8 $grammar_option->{bless_package} = __PACKAGE__;
65 2         30 $self->{_G} = Marpa::R2::Scanless::G->new($grammar_option);
66              
67 2         5700 my $recce_option = $grammarObj->recce_option();
68 2         11 $recce_option->{grammar} = $self->{_G};
69 2         20 $self->{_R} = Marpa::R2::Scanless::R->new($recce_option);
70              
71 2         738 bless($self, $class);
72              
73 2         28 return $self;
74             }
75             # ----------------------------------------------------------------------------------------
76              
77             sub _parse {
78 4     4   11 my ($self, $bufferp, $tokensrep) = @_;
79              
80 4         9 my $max = length(${$bufferp});
  4         14  
81 4         46 for (
82             my $pos = $self->{_R}->read($bufferp);
83             $pos < $max;
84             $pos = $self->{_R}->resume()
85             ) {
86 370         87252 my ($start, $length) = $self->{_R}->pause_span();
87 370         2082 my $str = substr(${$bufferp}, $start, $length);
  370         846  
88 370         453 for my $event_data (@{$self->{_R}->events}) {
  370         1066  
89 370         1624 my ($name) = @{$event_data};
  370         613  
90 370   50     1066 my $code = $events{$name} // die "no code for event $name";
91 370         843 $self->{_R}->$code($bufferp, $tokensrep, $str, $start, $length);
92             }
93             }
94              
95 4         8644 return $self;
96             }
97              
98             sub parse {
99 2     2 1 121 my ($self, $bufferp) = @_;
100              
101 2         16 return $self->_parse($bufferp, \@TOKENSRE);
102             }
103             # ----------------------------------------------------------------------------------------
104              
105             sub value {
106 4     4 1 13 my ($self) = @_;
107              
108 4         32 my $rc = $self->{_R}->value();
109              
110             #
111             # Another parse tree value ?
112             #
113 4 50       281 if (defined($self->{_R}->value())) {
114 0         0 my $msg = 'Ambigous parse tree detected';
115 0 0       0 if ($log->is_fatal) {
116 0         0 $log->fatalf('%s', $msg);
117             }
118 0         0 croak $msg;
119             }
120 4 50       327 if (! defined($rc)) {
121 0         0 my $msg = 'Parse tree failure';
122 0 0       0 if ($log->is_fatal) {
123 0         0 $log->fatalf('%s', $msg);
124             }
125 0         0 croak $msg;
126             }
127 4         30 return $rc
128             }
129              
130              
131             1;
132              
133             __END__