File Coverage

blib/lib/Inline/C/Parser/RecDescent.pm
Criterion Covered Total %
statement 18 18 100.0
branch 3 4 75.0
condition n/a
subroutine 6 6 100.0
pod 0 3 0.0
total 27 31 87.1


line stmt bran cond sub pod time code
1 25     25   97419 use strict; use warnings;
  25     25   89  
  25         713  
  25         134  
  25         55  
  25         925  
2             package Inline::C::Parser::RecDescent;
3              
4 25     25   132 use Carp;
  25         45  
  25         8295  
5              
6             sub register {
7             {
8 10     10 0 65884 extends => [qw(C)],
9             overrides => [qw(get_parser)],
10             }
11             }
12              
13             sub get_parser {
14 42     42 0 89 my $o = shift;
15 42 100       406 Inline::C::_parser_test($o->{CONFIG}{DIRECTORY}, "Inline::C::Parser::RecDescent::get_parser called\n") if $o->{CONFIG}{_TESTING};
16 42         103 eval { require Parse::RecDescent };
  42         23200  
17 42 50       847154 croak <
18             This invocation of Inline requires the Parse::RecDescent module.
19             $@
20             END
21 42         105 $main::RD_HINT++;
22 42         200 Parse::RecDescent->new(grammar())
23             }
24              
25             sub grammar {
26 66     66 0 61161 <<'END';
27              
28             code: part(s)
29             {
30             return 1;
31             }
32              
33             part: comment
34             | function_definition
35             {
36             my $function = $item[1][0];
37             $return = 1, last if $thisparser->{data}{done}{$function}++;
38             push @{$thisparser->{data}{functions}}, $function;
39             $thisparser->{data}{function}{$function}{return_type} =
40             $item[1][1];
41             $thisparser->{data}{function}{$function}{arg_types} =
42             [map {ref $_ ? $_->[0] : '...'} @{$item[1][2]}];
43             $thisparser->{data}{function}{$function}{arg_names} =
44             [map {ref $_ ? $_->[1] : '...'} @{$item[1][2]}];
45             }
46             | function_declaration
47             {
48             $return = 1, last unless $thisparser->{data}{AUTOWRAP};
49             my $function = $item[1][0];
50             $return = 1, last if $thisparser->{data}{done}{$function}++;
51             my $dummy = 'arg1';
52             push @{$thisparser->{data}{functions}}, $function;
53             $thisparser->{data}{function}{$function}{return_type} =
54             $item[1][1];
55             $thisparser->{data}{function}{$function}{arg_types} =
56             [map {ref $_ ? $_->[0] : '...'} @{$item[1][2]}];
57             $thisparser->{data}{function}{$function}{arg_names} =
58             [map {ref $_ ? ($_->[1] || $dummy++) : '...'} @{$item[1][2]}];
59             }
60             | anything_else
61              
62             comment:
63             m{\s* // [^\n]* \n }x
64             | m{\s* /\* (?:[^*]+|\*(?!/))* \*/ ([ \t]*)? }x
65              
66             function_definition:
67             rtype IDENTIFIER '(' (s?) ')' '{'
68             {
69             [@item[2,1], $item[4]]
70             }
71              
72             function_declaration:
73             rtype IDENTIFIER '(' (s?) ')' ';'
74             {
75             [@item[2,1], $item[4]]
76             }
77              
78             rtype: rtype1 | rtype2
79              
80             rtype1: modifier(s?) TYPE star(s?)
81             {
82             $return = $item[2];
83             $return = join ' ',@{$item[1]},$return
84             if @{$item[1]} and $item[1][0] ne 'extern';
85             $return .= join '',' ',@{$item[3]} if @{$item[3]};
86             return undef unless (defined $thisparser->{data}{typeconv}
87             {valid_rtypes}{$return});
88             }
89              
90             rtype2: modifier(s) star(s?)
91             {
92             $return = join ' ',@{$item[1]};
93             $return .= join '',' ',@{$item[2]} if @{$item[2]};
94             return undef unless (defined $thisparser->{data}{typeconv}
95             {valid_rtypes}{$return});
96             }
97              
98             arg: type IDENTIFIER {[@item[1,2]]}
99             | '...'
100              
101             arg_decl:
102             type IDENTIFIER(s?) {[$item[1], $item[2][0] || '']}
103             | '...'
104              
105             type: type1 | type2
106              
107             type1: modifier(s?) TYPE star(s?)
108             {
109             $return = $item[2];
110             $return = join ' ',@{$item[1]},$return if @{$item[1]};
111             $return .= join '',' ',@{$item[3]} if @{$item[3]};
112             return undef unless (defined $thisparser->{data}{typeconv}
113             {valid_types}{$return});
114             }
115              
116             type2: modifier(s) star(s?)
117             {
118             $return = join ' ',@{$item[1]};
119             $return .= join '',' ',@{$item[2]} if @{$item[2]};
120             return undef unless (defined $thisparser->{data}{typeconv}
121             {valid_types}{$return});
122             }
123              
124             modifier:
125             'unsigned' | 'long' | 'extern' | 'const'
126              
127             star: '*'
128              
129             IDENTIFIER:
130             /\w+/
131              
132             TYPE: /\w+/
133              
134             anything_else:
135             /.*/
136              
137             END
138             }
139              
140             my $hack = sub { # Appease -w using Inline::Files
141             print Parse::RecDescent::IN '';
142             print Parse::RecDescent::IN '';
143             print Parse::RecDescent::TRACE_FILE '';
144             print Parse::RecDescent::TRACE_FILE '';
145             };
146              
147             1;