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 1     1   4 use Pegex::Base;
  1         1  
  1         4  
3              
4             has parser => (required => 1);
5             has grammar => (required => 1);
6             has receiver => (required => 1);
7              
8             sub optimize_grammar {
9 2     2 0 4 my ($self, $start) = @_;
10 2         6 my $tree = $self->grammar->{tree};
11 2 100       11 return if $tree->{'+optimized'};
12 1 50       7 $self->set_max_parse if $self->parser->{maxparse};
13 1         4 $self->{extra} = {};
14 1         5 while (my ($name, $node) = each %$tree) {
15 60 100       123 next unless ref($node);
16 56         70 $self->optimize_node($node);
17             }
18 1         72 $self->optimize_node({'.ref' => $start});
19 1         4 my $extra = delete $self->{extra};
20 1         5 for my $key (%$extra) {
21 0         0 $tree->{$key} = $extra->{$key};
22             }
23 1         5 $tree->{'+optimized'} = 1;
24             }
25              
26             sub optimize_node {
27 149     149 0 143 my ($self, $node) = @_;
28              
29 149         113 my ($min, $max) = @{$node}{'+min', '+max'};
  149         206  
30 149 100       396 $node->{'+min'} = defined($max) ? 0 : 1
    100          
31             unless defined $node->{'+min'};
32 149 100       296 $node->{'+max'} = defined($min) ? 0 : 1
    100          
33             unless defined $node->{'+max'};
34 149 100       244 $node->{'+asr'} = 0
35             unless defined $node->{'+asr'};
36              
37 149         176 for my $kind (qw(ref rgx all any err code xxx)) {
38 266 50       364 return if $kind eq 'xxx';
39 266 100       586 if ($node->{rule} = $node->{".$kind"}) {
40 149         196 delete $node->{".$kind"};
41 149         145 $node->{kind} = $kind;
42 149 100       230 if ($kind eq 'ref') {
43 76 50       115 my $rule = $node->{rule} or die;
44 76 50       153 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 149 50 33     446 $node->{method} ||= $self->parser->can("match_$kind") or die;
61 149         212 last;
62             }
63             }
64              
65 149 100       554 if ($node->{kind} =~ /^(?:all|any)$/) {
    100          
    50          
66 33         25 $self->optimize_node($_) for @{$node->{rule}};
  33         107  
67             }
68             elsif ($node->{kind} eq 'ref') {
69 76         83 my $ref = $node->{rule};
70 76         151 my $rule = $self->grammar->{tree}{$ref};
71 76   33     114 $rule ||= $self->{extra}{$ref} = {};
72 76 100       109 if (my $action = $self->receiver->can("got_$ref")) {
    50          
73 28         36 $rule->{action} = $action;
74             }
75             elsif (my $gotrule = $self->receiver->can("gotrule")) {
76 48         58 $rule->{action} = $gotrule;
77             }
78 76 50       135 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 1     1   6 no warnings 'redefine';
  1         2  
  1         115  
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;