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   6 use Pegex::Base;
  1         2  
  1         8  
3              
4             has parser => (required => 1);
5             has grammar => (required => 1);
6             has receiver => (required => 1);
7              
8             sub optimize_grammar {
9 14     14 0 30 my ($self, $start) = @_;
10 14         45 my $tree = $self->grammar->{tree};
11 14 100       111 return if $tree->{'+optimized'};
12 13 50       49 $self->set_max_parse if $self->parser->{maxparse};
13 13         95 $self->{extra} = {};
14 13         76 while (my ($name, $node) = each %$tree) {
15 612 100       2306 next unless ref($node);
16 572         844 $self->optimize_node($node);
17             }
18 13         105 $self->optimize_node({'.ref' => $start});
19 13         113 my $extra = delete $self->{extra};
20 13         65 for my $key (%$extra) {
21 0         0 $tree->{$key} = $extra->{$key};
22             }
23 13         84 $tree->{'+optimized'} = 1;
24             }
25              
26             sub optimize_node {
27 1421     1421 0 4004 my ($self, $node) = @_;
28              
29 1421         1115 my ($min, $max) = @{$node}{'+min', '+max'};
  1421         2695  
30 1421 100       3836 $node->{'+min'} = defined($max) ? 0 : 1
    100          
31             unless defined $node->{'+min'};
32 1421 100       3114 $node->{'+max'} = defined($min) ? 0 : 1
    100          
33             unless defined $node->{'+max'};
34 1421 100       3250 $node->{'+asr'} = 0
35             unless defined $node->{'+asr'};
36              
37 1421         2163 for my $kind (qw(ref rgx all any err code xxx)) {
38 2354 50       3834 return if $kind eq 'xxx';
39 2354 100       5406 if ($node->{rule} = $node->{".$kind"}) {
40 1421         2008 delete $node->{".$kind"};
41 1421         1560 $node->{kind} = $kind;
42 1421 100       2263 if ($kind eq 'ref') {
43 772 50       1373 my $rule = $node->{rule} or die;
44 772 50       1482 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 1421 50 33     12519 $node->{method} ||= $self->parser->can("match_$kind") or die;
61 1421         9514 last;
62             }
63             }
64              
65 1421 100       5855 if ($node->{kind} =~ /^(?:all|any)$/) {
    100          
    50          
66 201         165 $self->optimize_node($_) for @{$node->{rule}};
  201         641  
67             }
68             elsif ($node->{kind} eq 'ref') {
69 772         798 my $ref = $node->{rule};
70 772         1343 my $rule = $self->grammar->{tree}{$ref};
71 772   33     2860 $rule ||= $self->{extra}{$ref} = {};
72 772 100       1163 if (my $action = $self->receiver->can("got_$ref")) {
    50          
73 436         2823 $rule->{action} = $action;
74             }
75             elsif (my $gotrule = $self->receiver->can("gotrule")) {
76 336         3992 $rule->{action} = $gotrule;
77             }
78 772 50       1430 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   2490 no warnings 'redefine';
  1         2  
  1         131  
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;