File Coverage

blib/lib/MDOM/Document/Gmake.pm
Criterion Covered Total %
statement 255 279 91.4
branch 132 152 86.8
condition 52 66 78.7
subroutine 22 24 91.6
pod 0 1 0.0
total 461 522 88.3


line stmt bran cond sub pod time code
1             package MDOM::Document::Gmake;
2              
3 15     15   8667 use strict;
  15         25  
  15         435  
4 15     15   52 use warnings;
  15         16  
  15         378  
5              
6             #use Smart::Comments;
7             #use Smart::Comments '###', '####';
8              
9 15     15   9859 use Text::Balanced qw( gen_extract_tagged );
  15         209027  
  15         1323  
10 15     15   6314 use Makefile::DOM;
  15         42  
  15         413  
11             #use Data::Dump::Streamer;
12 15     15   72 use base 'MDOM::Node';
  15         17  
  15         48  
13 15     15   62 use List::MoreUtils qw( before all any );
  15         25  
  15         1266  
14 15     15   67 use List::Util qw( first );
  15         18  
  15         1364  
15              
16             my %_map;
17             BEGIN {
18 15     15   328 %_map = (
19             COMMENT => 1, # context for parsing multi-line comments
20             COMMAND => 2, # context for parsing multi-line commands
21             RULE => 3, # context for parsing rules
22             VOID => 4, # void context
23             UNKNOWN => 5, # context for parsing unexpected constructs
24             );
25             }
26              
27 15     15   70 use constant \%_map;
  15         25  
  15         46055  
28              
29             my %_rev_map = reverse %_map;
30              
31             my @keywords = qw(
32             vpath include sinclude
33             ifdef ifndef else endif
34             define endef export unexport
35             );
36              
37             my $extract_interp_1 = gen_extract_tagged('\$[(]', '[)]', '');
38             my $extract_interp_2 = gen_extract_tagged('\$[{]', '[}]', '');
39              
40             sub _extract_interp {
41 1523     1523   2971 my ($res) = $extract_interp_1->($_[0]);
42 1523 100       62661 if (!$res) {
43 1501         2628 ($res) = $extract_interp_2->($_[0]);
44             }
45 1523         57076 $res;
46             }
47              
48             my ($context, $saved_context);
49              
50             sub new {
51 75 50   75 0 429 my $class = ref $_[0] ? ref shift : shift;
52 75         88 my $input = shift;
53 75 50       150 return undef if !defined $input;
54 75         153 my $in;
55 75 50       158 if (ref $input) {
56 15 50   15   122 open $in, '<', $input or die;
  15         18  
  15         103  
  75         1252  
57             } else {
58 0 0       0 open $in, $input or
59             die "Can't open $input for reading: $!";
60             }
61 75         13602 my $self = $class->SUPER::new;
62 75         208 $self->_tokenize($in);
63 75         385 $self;
64             }
65              
66             sub _tokenize {
67 75     75   102 my ($self, $fh) = @_;
68 75         91 $context = VOID;
69 75         72 my @tokens;
70 75         338 while (<$fh>) {
71             ### Tokenizing : $_
72             ### ...with context : $_rev_map{$context}
73 165         282 s/\r\n/\n/g;
74 165 50       628 $_ .= "\n" if !/\n$/s;
75 165 100 100     595 if ($context == VOID || $context == RULE) {
    100          
    100          
    50          
76 131 100 100     867 if ($context == VOID && s/(?x) ^ (\t\s*) (?= \# ) //) {
    100 100        
77             ### Found comment in VOID context...
78 4         21 @tokens = (
79             MDOM::Token::Whitespace->new($1),
80             _tokenize_comment($_)
81             );
82 4 100       24 if ($tokens[-1]->isa('MDOM::Token::Continuation')) {
83             ### Switching context to COMMENT...
84 1         2 $saved_context = $context;
85 1         2 $context = COMMENT;
86 1         3 $tokens[-2]->add_content("\\\n");
87 1         2 pop @tokens;
88             }
89 4         12 $self->__add_elements( @tokens );
90             }
91             elsif ($context == RULE and s/^\t//) {
92             ### Found a command in RULE context...
93 33         68 @tokens = _tokenize_command($_);
94             #warn "*@tokens*";
95             ### Tokens for the command: @tokens
96 33         98 unshift @tokens, MDOM::Token::Separator->new("\t");
97 33 100       178 if ($tokens[-1]->isa('MDOM::Token::Continuation')) {
98             ### Switching context to COMMAND...
99 4         4 $saved_context = $context;
100 4         6 $context = COMMAND;
101 4         8 pop @tokens;
102 4 100       12 if ($tokens[-1]->class =~ /Bare$/) {
103 3         13 $tokens[-1]->add_content("\\\n");
104             } else {
105 1         4 push @tokens, MDOM::Token::Bare->new("\\\n");
106             }
107             }
108 33         131 my $cmd = MDOM::Command->new;
109 33         87 $cmd->__add_elements(@tokens);
110 33         80 $self->__add_element($cmd);
111             ### command (post): $cmd
112 33         155 next;
113             } else {
114 94         208 @tokens = _tokenize_normal($_);
115 94 100 100     1295 if (@tokens >= 2 &&
    100 100        
116             $tokens[-1]->isa('MDOM::Token::Continuation') &&
117             $tokens[-2]->isa('MDOM::Token::Comment')) {
118             ### Found a trailing comment...
119             ### Switching conext to COMMENT...
120 2         2 $saved_context = $context;
121 2         3 $context = COMMENT;
122 2         10 $tokens[-2]->add_content("\\\n");
123 2         3 pop @tokens;
124 2         13 $self->__add_elements( _parse_normal(@tokens) );
125             } elsif ($tokens[-1]->isa('MDOM::Token::Continuation')) {
126             ### Found a line continuation...
127             ### Switching context to UNKNOWN...
128 12         17 $saved_context = $context;
129 12         55 $context = UNKNOWN;
130             } else {
131             ### Parsing it as a normal line...
132 80         194 $self->__add_elements( _parse_normal(@tokens) );
133             }
134             }
135             } elsif ($context == COMMENT) {
136 6         11 @tokens = _tokenize_comment($_);
137 6 100       26 if ($tokens[-1]->isa('MDOM::Token::Continuation')) {
138             ### Slurping one more continued comment line...
139 3         8 $tokens[-2]->add_content("\\\n");
140 3         3 pop @tokens;
141 3         8 $self->last_token->add_content(join '', @tokens);
142             } else {
143             ### Completing comment slurping...
144             ### Switching back to context: _state_str($saved_context)
145 3         5 $context = $saved_context;
146 3         5 my $last = pop @tokens;
147 3         8 $self->last_token->add_content(join '', @tokens);
148 3         6 $self->last_token->parent->__add_element($last);
149             }
150             } elsif ($context == COMMAND) {
151 8         14 @tokens = _tokenize_command($_);
152             ### more tokens for the cmd: @tokens
153 8 100       39 if ($tokens[-1]->isa('MDOM::Token::Continuation')) {
154             ### Slurping one more continued command line...
155 4         13 $tokens[-2]->add_content("\\\n");
156 4         4 pop @tokens;
157 4         10 for my $token (@tokens) {
158 12 100 100     40 if ($token->class =~ /Interpolation/ or
159             $self->last_token->class =~ /Interpolation/) {
160 6         12 $self->last_token->parent->__add_element($token);
161             } else {
162 6         12 $self->last_token->add_content($token);
163             }
164             }
165             } else {
166             ### Completing command slurping: @tokens
167             ### Switching back to context: _state_str($saved_context)
168 4         5 $context = RULE;
169 4         6 my $last = pop @tokens;
170             ### last_token: $self->last_token
171 4         7 for my $token (@tokens) {
172 6 100 66     15 if ($token->class =~ /Interpolation/ or
173             $self->last_token->class =~ /Interpolation/) {
174 2         6 $self->last_token->parent->__add_element($token);
175             } else {
176 4         9 $self->last_token->add_content($token);
177             }
178             }
179 4         10 $self->last_token->parent->__add_element($last);
180             }
181             } elsif ($context == UNKNOWN) {
182 20         42 push @tokens, _tokenize_normal($_);
183 20 50 66     305 if (@tokens >= 2 && $tokens[-1]->isa('MDOM::Token::Continuation') &&
    100 66        
184             $tokens[-2]->isa('MDOM::Token::Comment')) {
185 0         0 $context = COMMENT;
186 0         0 $tokens[-2]->add_content("\\\n");
187 0         0 pop @tokens;
188 0         0 $self->__add_elements( _parse_normal(@tokens) );
189             } elsif ($tokens[-1]->isa('MDOM::Token::Continuation')) {
190             ### Do nothing here...stay in the UNKNOWN context...
191             } else {
192 12         41 $self->__add_elements( _parse_normal(@tokens) );
193 12         74 $context = $saved_context;
194             }
195             } else {
196 0         0 die "Unkown state: $context";
197             }
198             }
199 75 50 66     382 if ($context != RULE && $context != VOID) {
200 0         0 warn "unexpected end of input at line $.";
201             }
202             }
203              
204             sub _tokenize_normal {
205 114     114   155 local $_ = shift;
206 114         107 my @tokens;
207 114         151 my $pending_token = '';
208 114         104 my $next_token;
209             ### TOKENIZING: $_
210 114         106 while (1) {
211             # "token = $pending_token";
212             #warn pos;
213             #warn '@tokens = ', _dump_tokens2(@tokens);
214 1327 100       4737 if (/(?x) \G [\s\n]+ /gc) {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
215 286         909 $next_token = MDOM::Token::Whitespace->new($&);
216             #push @tokens, $next_token;
217             }
218             elsif (/(?x) \G (?: :: | := | \?= | \+= | [=:;] )/gc) {
219 77         370 $next_token = MDOM::Token::Separator->new($&);
220             }
221             elsif (/(?x) \G \| /gc) {
222             # XXX This should be a separator...
223 3         7 $next_token = MDOM::Token::Bare->new($&);
224             }
225             elsif (my $res = _extract_interp($_)) {
226 15         88 $next_token = MDOM::Token::Interpolation->new($res);
227             }
228             elsif (/(?x) \G \$. /gc) {
229 7         46 $next_token = MDOM::Token::Interpolation->new($&);
230             }
231             elsif (/(?x) \G \\ ([\#\\\n:]) /gcs) {
232 24         53 my $c = $1;
233 24 100       58 if ($c eq "\n") {
234 20 100       68 push @tokens, MDOM::Token::Bare->new($pending_token)
235             if $pending_token ne '';
236 20         109 push @tokens, MDOM::Token::Continuation->new("\\\n");
237 20         73 return @tokens;
238             } else {
239 4         7 $pending_token .= "\\$c";
240             }
241             }
242             elsif (/(?x) \G (\# [^\n]*) \\ \n/sgc) {
243 2         5 my $s = $1;
244 2 50       6 push @tokens, MDOM::Token::Bare->new($pending_token) if $pending_token ne '';
245 2         10 push @tokens, MDOM::Token::Comment->new($s);
246 2         13 push @tokens, MDOM::Token::Continuation->new("\\\n");
247 2         7 return @tokens;
248             } elsif (/(?x) \G \# [^\n]* /gc) {
249 12         75 $next_token = MDOM::Token::Comment->new($&);
250             } elsif (/(?x) \G . /gc) {
251 809         1285 $pending_token .= $&;
252             } else {
253 92         153 last;
254             }
255 1213 100       5247 if ($next_token) {
256 400 100       701 if ($pending_token ne '') {
257 204         561 push @tokens, MDOM::Token::Bare->new($pending_token);
258 204         240 $pending_token = '';
259             }
260 400         362 push @tokens, $next_token;
261 400         392 $next_token = undef;
262             }
263             }
264             ### parse_normal result: @tokens
265 92         297 @tokens;
266             }
267              
268             sub _tokenize_command {
269 56     56   83 my $s = shift;
270 56         53 my @tokens;
271 56         68 my $pending_token = '';
272 56         43 my $next_token;
273 56         79 my $strlen = length $s;
274 56         208 while ($s =~ /(?x) \G (\s*) ([\@+\-]) /gc) {
275 16         36 my ($whitespace, $modifier) = ($1, $2);
276 16 100       33 if ($whitespace) {
277 7         15 push @tokens, MDOM::Token::Whitespace->new($whitespace);
278             }
279 16         64 push @tokens, MDOM::Token::Modifier->new($modifier);
280             }
281 56         61 while (1) {
282 607         490 my $last = 0;
283 607 100       1150 if ($s =~ /(?x) \G \n /gc) {
    100          
    100          
    100          
    100          
284 45         123 $next_token = MDOM::Token::Whitespace->new("\n");
285             #push @tokens, $next_token;
286             }
287             elsif (my $res = _extract_interp($s)) {
288 11         49 $next_token = MDOM::Token::Interpolation->new($res);
289             }
290             elsif ($s =~ /(?x) \G \$. /gc) {
291 11         56 $next_token = MDOM::Token::Interpolation->new($&);
292             }
293             elsif ($s =~ /(?x) \G \\ ([\#\\\n:]) /gcs) {
294 12         20 my $c = $1;
295 12 100 100     48 if ($c eq "\n" && pos $s == $strlen) {
296 8         29 $next_token = MDOM::Token::Continuation->new("\\\n");
297             } else {
298 4         7 $pending_token .= "\\$c";
299             }
300             }
301             elsif ($s =~ /(?x) \G . /gc) {
302 472         675 $pending_token .= $&;
303             } else {
304 56         90 $last = 1;
305             }
306 607 100       1287 if ($next_token) {
307 75 100       138 if ($pending_token) {
308 60         134 push @tokens, MDOM::Token::Bare->new($pending_token);
309 60         75 $pending_token = '';
310             }
311 75         68 push @tokens, $next_token;
312 75         77 $next_token = undef;
313             }
314 607 100       863 last if $last;
315             }
316 56 50       103 if ($pending_token) {
317 0         0 push @tokens, MDOM::Token::Bare->new($pending_token);
318 0         0 $pending_token = '';
319             }
320 56         186 @tokens;
321             }
322              
323             sub _tokenize_comment {
324 10     10   25 local $_ = shift;
325 10         12 my @tokens;
326 10         12 my $pending_token = '';
327 10         11 while (1) {
328 134 100       310 if (/(?x) \G \n /gc) {
    100          
    50          
329 6 50       33 push @tokens, MDOM::Token::Comment->new($pending_token) if $pending_token ne '';
330 6         18 push @tokens, MDOM::Token::Whitespace->new("\n");
331 6         26 return @tokens;
332             #push @tokens, $next_token;
333             }
334             elsif (/(?x) \G \\ ([\\\n#:]) /gcs) {
335 4         5 my $c = $1;
336 4 50       7 if ($c eq "\n") {
337 4 50       16 push @tokens, MDOM::Token::Comment->new($pending_token) if $pending_token ne '';
338 4         12 push @tokens, MDOM::Token::Continuation->new("\\\n");
339 4         13 return @tokens;
340             } else {
341 0         0 $pending_token .= "\\$c";
342             }
343             }
344             elsif (/(?x) \G . /gc) {
345 124         122 $pending_token .= $&;
346             }
347             else {
348 0         0 last;
349             }
350             }
351 0         0 @tokens;
352             }
353              
354             sub _parse_normal {
355 94     94   177 my @tokens = @_;
356             ### fed to _parse_normal: @tokens
357 94         148 my @sep = grep { $_->isa('MDOM::Token::Separator') } @tokens;
  627         1895  
358             #### Separators: @sep
359 94 100       215 if (@tokens == 1) {
360 8         25 return $tokens[0];
361             }
362             # filter out significant tokens:
363 86         136 my ($fst, $snd) = grep { $_->significant } @tokens;
  619         1157  
364 86         95 my $is_directive;
365 86 100       1174 if ($fst) {
366 81 100 66     180 if ($fst eq '-include') {
    100 66        
      66        
367 2         10 $fst->set_content('include');
368 2         10 unshift @tokens, MDOM::Token::Modifier->new('-');
369 2         3 $is_directive = 1;
370             }
371             elsif ($fst eq 'override' && $snd && $snd eq 'define' ||
372             _is_keyword($fst)) {
373 12         13 $is_directive = 1;
374             }
375 81 100       314 if ($is_directive) {
376             ##### Found directives...
377 14         72 my $node = MDOM::Directive->new;
378 14         50 $node->__add_elements(@tokens);
379 14         54 return $node;
380             }
381             }
382 72 100 66     616 if (@sep >= 2 && $sep[0] =~ /^::?$/ and $sep[1] eq ';') {
    100 100        
    100 66        
    100 66        
    100 100        
      66        
383             #### Found simple rule with inlined command...
384 9         57 my $rule = MDOM::Rule::Simple->new;
385 9     42   80 my @t = before { $_ eq ';' } @tokens;
  42         66  
386 9         47 $rule->__add_elements(@t);
387 9         20 splice @tokens, 0, scalar(@t);
388              
389 9         20 my @prefix = shift @tokens;
390 9 100 66     83 if ($tokens[0] && $tokens[0]->isa('MDOM::Token::Whitespace')) {
391 6         11 push @prefix, shift @tokens;
392             }
393              
394 9         31 @tokens = (@prefix, _tokenize_command(join '', @tokens));
395 9 50       64 if ($tokens[-1]->isa('MDOM::Token::Continuation')) {
396 0         0 $saved_context = $context;
397 0         0 $context = COMMAND;
398             }
399 9         52 my $cmd = MDOM::Command->new;
400 9         29 $cmd->__add_elements(@tokens);
401 9         22 $rule->__add_elements($cmd);
402 9         14 $saved_context = RULE;
403 9 100       25 $context = RULE if $context == VOID;
404 9         37 return $rule;
405             }
406             elsif (@sep >= 2 && $sep[0] eq ':' and $sep[1] =~ /^::?$/) {
407             #### Found static pattern rule...
408 2         16 my $rule = MDOM::Rule::StaticPattern->new;
409 2     21   15 my @t = before { $_ eq ';' } @tokens;
  21         27  
410 2         11 $rule->__add_elements(@t);
411 2         5 splice @tokens, 0, scalar(@t);
412 2 100       6 if (@tokens) {
413 1         2 my @prefix = shift @tokens;
414 1 50 33     9 if ($tokens[0] && $tokens[0]->isa('MDOM::Token::Whitespace')) {
415 1         5 push @prefix, shift @tokens;
416             }
417              
418 1         5 @tokens = (@prefix, _tokenize_command(join '', @tokens));
419 1 50       9 if ($tokens[-1]->isa('MDOM::Token::Continuation')) {
420 0         0 $saved_context = $context;
421 0         0 $context = COMMAND;
422             }
423 1         9 my $cmd = MDOM::Command->new;
424 1         4 $cmd->__add_elements(@tokens);
425 1         2 $rule->__add_elements($cmd);
426             }
427 2         3 $saved_context = RULE;
428 2 50       4 $context = RULE if $context == VOID;
429 2         9 return $rule;
430             }
431             elsif (@sep == 1 && $sep[0] =~ /^::?$/) {
432             #### Found simple rule without inlined command...
433 36         181 my $rule = MDOM::Rule::Simple->new;
434 36         117 $rule->__add_elements(@tokens);
435 36         54 $saved_context = RULE;
436 36 100       75 $context = RULE if $context == VOID;
437 36         125 return $rule;
438             }
439             elsif (@sep && $sep[0] =~ /(?x) ^ (?: = | := | \+= | \?= ) $/) {
440 15         86 my $assign = MDOM::Assignment->new;
441             ### Assignment tokens: @tokens
442 15         66 $assign->__add_elements(@tokens);
443 15         23 $saved_context = VOID;
444 15 100       35 $context = VOID if $context == RULE;
445 15         63 return $assign;
446             }
447             elsif (all {
448 20 100   20   129 $_->isa('MDOM::Token::Comment') ||
449             $_->isa('MDOM::Token::Whitespace')
450             } @tokens) {
451 5         27 @tokens;
452             }
453             else {
454             #### Found unkown token sequence: @tokens
455 5         15 @tokens = _tokenize_command(join '', @tokens);
456 5         38 my $node = MDOM::Unknown->new;
457 5         21 $node->__add_elements(@tokens);
458 5         17 $node;
459             }
460             }
461              
462             sub _dump_tokens {
463 0     0   0 my @tokens = map { $_->clone } @_;
  0         0  
464 0         0 warn "??? ", (join ' ',
465 0         0 map { s/\\/\\\\/g; s/\n/\\n/g; s/\t/\\t/g; "[$_]" } @tokens
  0         0  
  0         0  
  0         0  
466             ), "\n";
467             }
468              
469             sub _state_str {
470 0     0   0 $_rev_map{$saved_context}
471             }
472              
473             sub _is_keyword {
474 777     777   1102 any { $_[0] eq $_ } @keywords;
  79     79   594  
475             }
476              
477             1;
478              
479             __END__