File Coverage

blib/lib/Pegex/Optimizer.pm
Criterion Covered Total %
statement 63 76 82.8
branch 40 52 76.9
condition 4 6 66.6
subroutine 8 10 80.0
pod 0 5 0.0
total 115 149 77.1


line stmt bran cond sub pod time code
1             package Pegex::Optimizer;
2 11     11   72 use Pegex::Base;
  11         20  
  11         62  
3              
4             has parser => (required => 1);
5             has grammar => (required => 1);
6             has receiver => (required => 1);
7              
8             sub optimize_grammar {
9 19     19 0 55 my ($self, $start) = @_;
10 19         76 my $tree = $self->grammar->{tree};
11 19 100       68 return if $tree->{'+optimized'};
12 18 50       67 $self->set_max_parse if $self->parser->{maxparse};
13 18         58 $self->{extra} = {};
14 18         102 while (my ($name, $node) = each %$tree) {
15 471 100       994 next unless ref($node);
16 423         756 $self->optimize_node($node);
17             }
18 18         76 $self->optimize_node({'.ref' => $start});
19 18         89 my $extra = delete $self->{extra};
20 18         66 for my $key (%$extra) {
21 4         9 $tree->{$key} = $extra->{$key};
22             }
23 18         60 $tree->{'+optimized'} = 1;
24             }
25              
26             sub optimize_node {
27 1584     1584 0 2552 my ($self, $node) = @_;
28              
29 1584         1918 my ($min, $max) = @{$node}{'+min', '+max'};
  1584         2678  
30             $node->{'+min'} = defined($max) ? 0 : 1
31 1584 100       3831 unless defined $node->{'+min'};
    100          
32             $node->{'+max'} = defined($min) ? 0 : 1
33 1584 100       3355 unless defined $node->{'+max'};
    100          
34             $node->{'+asr'} = 0
35 1584 100       2851 unless defined $node->{'+asr'};
36              
37 1584         2441 for my $kind (qw(ref rgx all any err code xxx)) {
38 3568 50       5374 return if $kind eq 'xxx';
39 3568 100       7592 if ($node->{rule} = $node->{".$kind"}) {
40 1584         2634 delete $node->{".$kind"};
41 1584         2536 $node->{kind} = $kind;
42 1584 100       2537 if ($kind eq 'ref') {
43 593 50       1073 my $rule = $node->{rule} or die;
44 593 100       1207 if (my $method = $self->grammar->can("rule_$rule")) {
    50          
45 2         5 $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 1584 50 66     4449 $node->{method} ||= $self->parser->can("match_$kind") or die;
61 1584         2756 last;
62             }
63             }
64              
65 1584 100       5507 if ($node->{kind} =~ /^(?:all|any)$/) {
    100          
    100          
66 441         555 $self->optimize_node($_) for @{$node->{rule}};
  441         1245  
67             }
68             elsif ($node->{kind} eq 'ref') {
69 593         853 my $ref = $node->{rule};
70 593         1141 my $rule = $self->grammar->{tree}{$ref};
71 593   66     1092 $rule ||= $self->{extra}{$ref} = {};
72 593 100       1090 if (my $action = $self->receiver->can("got_$ref")) {
    100          
73 194         431 $rule->{action} = $action;
74             }
75             elsif (my $gotrule = $self->receiver->can("gotrule")) {
76 375         700 $rule->{action} = $gotrule;
77             }
78 593 100       1150 if ($self->parser->{debug}) {
79 23         44 $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 2     2 0 5 my ($self, $method) = @_;
89             return sub {
90 2     2   4 my ($parser, $ref, $parent) = @_;
91 2         4 @{$parser}{'rule', 'parent'} = ($ref, $parent);
  2         4  
92             $method->(
93             $parser->{grammar},
94             $parser,
95             $parser->{buffer},
96             $parser->{position},
97 2         8 );
98             }
99 2         10 }
100              
101             sub make_trace_wrapper {
102 24     24 0 41 my ($self, $method) = @_;
103             return sub {
104 23     23   54 my ($self, $ref, $parent) = @_;
105 23         33 my $asr = $parent->{'+asr'};
106 23 50       57 my $note =
    50          
107             $asr == -1 ? '(!)' :
108             $asr == 1 ? '(=)' :
109             '';
110 23         133 $self->trace("try_$ref$note");
111 23         55 my $result;
112 23 50       75 if ($result = $self->$method($ref, $parent)) {
113 23         77 $self->trace("got_$ref$note");
114             }
115             else {
116 0         0 $self->trace("not_$ref$note");
117             }
118 23         106 return $result;
119             }
120 24         175 }
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 11     11   92 no warnings 'redefine';
  11         27  
  11         1478  
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;