File Coverage

inc/Pegex/Optimizer.pm
Criterion Covered Total %
statement 44 76 57.8
branch 33 52 63.4
condition 2 6 33.3
subroutine 4 10 40.0
pod 0 5 0.0
total 83 149 55.7


line stmt bran cond sub pod time code
1             package Pegex::Optimizer;
2 4     4   24 use Pegex::Base;
  4         8  
  4         24  
3              
4             has parser => (required => 1);
5             has grammar => (required => 1);
6             has receiver => (required => 1);
7              
8             sub optimize_grammar {
9 8     8 0 18 my ($self, $start) = @_;
10 8         27 my $tree = $self->grammar->{tree};
11 8 100       37 return if $tree->{'+optimized'};
12 4 50       21 $self->set_max_parse if $self->parser->{maxparse};
13 4         11 $self->{extra} = {};
14 4         24 while (my ($name, $node) = each %$tree) {
15 240 100       477 next unless ref($node);
16 224         380 $self->optimize_node($node);
17             }
18 4         25 $self->optimize_node({'.ref' => $start});
19 4         18 my $extra = delete $self->{extra};
20 4         19 for my $key (%$extra) {
21 0         0 $tree->{$key} = $extra->{$key};
22             }
23 4         23 $tree->{'+optimized'} = 1;
24             }
25              
26             sub optimize_node {
27 596     596 0 699 my ($self, $node) = @_;
28              
29 596         590 my ($min, $max) = @{$node}{'+min', '+max'};
  596         1031  
30 596 100       1763 $node->{'+min'} = defined($max) ? 0 : 1
    100          
31             unless defined $node->{'+min'};
32 596 100       1471 $node->{'+max'} = defined($min) ? 0 : 1
    100          
33             unless defined $node->{'+max'};
34 596 100       1308 $node->{'+asr'} = 0
35             unless defined $node->{'+asr'};
36              
37 596         811 for my $kind (qw(ref rgx all any err code xxx)) {
38 1064 50       1741 return if $kind eq 'xxx';
39 1064 100       2632 if ($node->{rule} = $node->{".$kind"}) {
40 596         885 delete $node->{".$kind"};
41 596         791 $node->{kind} = $kind;
42 596 100       1025 if ($kind eq 'ref') {
43 304 50       631 my $rule = $node->{rule} or die;
44 304 50       631 if (my $method = $self->grammar->can("rule_$rule")) {
    50          
45 0         0 $node->{method} = $self->make_method_wrapper($method);
46             }
47             elsif (not $self->grammar->{tree}{$rule}) {
48 0 0       0 if (my $method = $self->grammar->can("$rule")) {
49 0         0 warn <<"...";
50             Warning:
51              
52             You have a method called '$rule' in your grammar.
53             It should probably be called 'rule_$rule'.
54              
55             ...
56             }
57 0         0 die "No rule '$rule' defined in grammar";
58             }
59             }
60 596 50 33     2190 $node->{method} ||= $self->parser->can("match_$kind") or die;
61 596         941 last;
62             }
63             }
64              
65 596 100       2404 if ($node->{kind} =~ /^(?:all|any)$/) {
    100          
    50          
66 132         131 $self->optimize_node($_) for @{$node->{rule}};
  132         463  
67             }
68             elsif ($node->{kind} eq 'ref') {
69 304         376 my $ref = $node->{rule};
70 304         644 my $rule = $self->grammar->{tree}{$ref};
71 304   33     814 $rule ||= $self->{extra}{$ref} = {};
72 304 100       593 if (my $action = $self->receiver->can("got_$ref")) {
    50          
73 112         210 $rule->{action} = $action;
74             }
75             elsif (my $gotrule = $self->receiver->can("gotrule")) {
76 192         313 $rule->{action} = $gotrule;
77             }
78 304 50       695 if ($self->parser->{debug}) {
79 0           $node->{method} = $self->make_trace_wrapper($node->{method});
80             }
81             }
82             elsif ($node->{kind} eq 'rgx') {
83             # XXX $node;
84             }
85             }
86              
87             sub make_method_wrapper {
88 0     0 0   my ($self, $method) = @_;
89             return sub {
90 0     0     my ($parser, $ref, $parent) = @_;
91 0           @{$parser}{'rule', 'parent'} = ($ref, $parent);
  0            
92 0           $method->(
93             $parser->{grammar},
94             $parser,
95             $parser->{buffer},
96             $parser->{position},
97             );
98             }
99 0           }
100              
101             sub make_trace_wrapper {
102 0     0 0   my ($self, $method) = @_;
103             return sub {
104 0     0     my ($self, $ref, $parent) = @_;
105 0           my $asr = $parent->{'+asr'};
106 0 0         my $note =
    0          
107             $asr == -1 ? '(!)' :
108             $asr == 1 ? '(=)' :
109             '';
110 0           $self->trace("try_$ref$note");
111 0           my $result;
112 0 0         if ($result = $self->$method($ref, $parent)) {
113 0           $self->trace("got_$ref$note");
114             }
115             else {
116 0           $self->trace("not_$ref$note");
117             }
118 0           return $result;
119             }
120 0           }
121              
122             sub set_max_parse {
123 0     0 0   require Pegex::Parser;
124 0           my ($self) = @_;
125 0           my $maxparse = $self->parser->{maxparse};
126 4     4   25 no warnings 'redefine';
  4         9  
  4         569  
127 0           my $method = \&Pegex::Parser::match_ref;
128 0           my $counter = 0;
129             *Pegex::Parser::match_ref = sub {
130 0 0   0     die "Maximum parsing rules reached ($maxparse)\n"
131             if $counter++ >= $maxparse;
132 0           my $self = shift;
133 0           $self->$method(@_);
134 0           };
135             }
136              
137             1;