File Coverage

blib/lib/Makefile/Parser.pm
Criterion Covered Total %
statement 236 606 38.9
branch 90 240 37.5
condition 34 58 58.6
subroutine 31 43 72.0
pod 10 10 100.0
total 401 957 41.9


line stmt bran cond sub pod time code
1             package Makefile::Parser;
2              
3 1     1   719 use strict;
  1         2  
  1         39  
4 1     1   5 use warnings;
  1         2  
  1         24  
5              
6 1     1   9 use File::Spec;
  1         1  
  1         20  
7 1     1   4 use Cwd qw/ realpath /;
  1         1  
  1         66  
8 1     1   809 use List::MoreUtils qw( uniq pairwise ) ;
  1         1299  
  1         82  
9 1     1   1616 use Text::Balanced qw( gen_extract_tagged );
  1         21840  
  1         6489  
10             #use Smart::Comments;
11              
12             #our $Debug = 0;
13             our $Strict = 0;
14             our $VERSION = '0.215';
15             our $Error;
16             our $Runtime = undef;
17              
18             # usage: $class->new;
19             sub new {
20 10     10 1 109 my $proto = shift;
21 10   66     55 my $class = ref $proto || $proto;
22 10         91 my $self = bless {
23             _vars => {}, # all the definitions of variables
24             _tars => undef, # all the targets
25             _default => undef, # default target
26             _depends => {}, # all the dependencies
27             _imps => [], # targets in implicit rules
28             }, $class;
29 10         31 return $self;
30             }
31              
32             my $extract_interp_1 = gen_extract_tagged('\$[(]', '[)]', '');
33             my $extract_interp_2 = gen_extract_tagged('\$[{]', '[}]', '');
34              
35             sub _extract_interp {
36 3589     3589   9416 my ($res) = $extract_interp_1->($_[0]);
37 3589 100       347834 if (!$res) {
38 2374         6395 ($res) = $extract_interp_2->($_[0]);
39             }
40 3589         130845 $res;
41             }
42              
43             # usage: $obj->parse($filename);
44             sub parse {
45 15     15 1 69 my ($self, $file, $vars) = @_;
46 15   100     47 $file ||= 'Makefile';
47 15 50       33 my %init_vars = %$vars if $vars;
48              
49 15         40 $self->{_file} = $file;
50 15         104 $self->{_vars} = {
51             MAKE => $0,
52             CC => 'cc',
53             SHELL => 'sh',
54             %init_vars,
55             };
56 15         70 undef $self->{_tars};
57 15         129 undef $self->{_default};
58 15         54 $self->{_depends} = {};
59 15         93 $self->{_imps} = [];
60              
61 15         30 my $rvars = $self->{_vars};
62 15         21 my $in;
63 15 100       817 unless (open $in, $file) {
64 2         39 $Error = "Cannot open $file for reading: $!";
65 2         14 return undef;
66             }
67              
68 13         31 my $state = 'S_IDLE';
69 13         17 my ($var, $value, $tar_name, $tar, $colon_type, $depends, $cmd);
70 0         0 my @cmds;
71 0         0 my %tars;
72             #%$rvars = ();
73 13         18 my $first_tar = 1;
74 13         483 while (<$in>) {
75 3247 100 66     10798 next if /^\s*#/ and $state ne 'S_IN_VAL';
76 2883 100 100     13176 next if /^\s*$/ and $state ne 'S_IN_VAL';
77             #$tar_name = '' unless defined $var;
78             #warn "(tar: $tar_name) Switching to tate $state with $_";
79             #warn $state if $state ne 'S_IDLE';
80 1902         2624 chomp;
81             #if (/TEST_VERBOSE=/) {
82             #### line: $_
83             #### state: $state
84             #}
85              
86             # expand the value of use-defined variables:
87             #s/\$[\{\(](\w+)[\}\)]/exists $rvars->{$1} ? $rvars->{$1} : $&/ge;
88 1902         3621 $_ = $self->_process_refs($_);
89              
90 1902 100 100     40929 if (($state eq 'S_IDLE' or $state eq 'S_CMD') and /^(\w+) \s* :?= \s* (.*)$/xo) {
    100 100        
    100 100        
    100 100        
    100 100        
    100 100        
    50 66        
    0 66        
      33        
91 271         497 $var = $1;
92 271         437 $value = $2;
93             #warn "matched $var = $value\n";
94 271 100       723 if ($value =~ m{\\\s*$}) {
95 29         51 $value .= "\n";
96 29         145 $state = 'S_IN_VAL' ;
97             } else {
98 242         418 $value =~ s/#.*//m;
99 242         557 $rvars->{$var} = $value;
100             ### variable: $var
101             ### value: $value
102 242         1076 $state = 'S_IDLE';
103             }
104             #warn "$1 * $2 * $3";
105              
106             } elsif ($state eq 'S_IN_VAL') {
107             #warn $1;
108 58         80 my $line = $_;
109             #warn "adding value line $line\n";
110 58         111 $value .= "$line\n";
111 58 100       350 if ($line !~ m{\\\s*$}) {
112 29         47 $state = 'S_IDLE' ;
113             #warn "Processing value '$value'\n";
114 29         373 $value =~ s/[ \t]*\\\n[ \t]*/ /sg;
115 29         63 $value =~ s/#.*//smg;
116             #warn "Finale value '$value'\n";
117 29         80 $value =~ s/\n//gs;
118 29         588 $value =~ s/^\s+|\s+$//gs;
119 29         205 $rvars->{$var} = $value;
120             #warn "$var <=> $value\n";
121             }
122              
123             } elsif (($state eq 'S_IDLE' or $state eq 'S_CMD') and /^(\.\w+) (\.\w+) \s* (::?)\s*$/xo) {
124 2         9 $_ = "%$2 $3 %$1\n";
125             #warn $_;
126 2         3 redo;
127              
128             } elsif (($state eq 'S_IDLE' or $state eq 'S_CMD') and /^(\S[^:]*) (::?) \s* (.*)$/xo) {
129 599         1399 $tar_name = $1;
130 599         997 $colon_type = $2;
131 599         863 $depends = $3;
132 599         3401 $tar_name =~ s/^\s+|\s+$//g;
133              
134 599         997 my $cmd;
135 599 50       1719 if ($depends =~ s/;(.*)//) {
136 0         0 $cmd = $1;
137             }
138              
139             # Ignore .SUFFIXES currently:
140 599 100       1274 next if $tar_name eq '.SUFFIXES';
141              
142             #warn "Adding target $tar_name...\n";
143 598         1803 $tar = Makefile::Target->new($tar_name, $colon_type);
144 598 100       1334 if (my $old_tars = $tars{$tar_name}) {
145 3 100       7 if ($colon_type eq ':') {
146 2         6 $tar->add_prereq($old_tars->[0]->prereqs);
147 2 100       7 if (my @cmd = $old_tars->[0]->commands) {
148 1         3 $tar->add_command(@cmd);
149             }
150 2         7 @$old_tars = $tar;
151             } else {
152 1         3 push @$old_tars, $tar;
153             }
154             } else {
155 595         1754 $tars{$tar_name} = [$tar];
156             }
157 598 100       1359 if ($tar_name =~ m/%/) {
158 9         11 push @{$self->{_imps}}, $tar_name;
  9         23  
159             }
160 598 100       1215 if ($first_tar) {
161 13         19 $self->{_default} = $tar;
162 13         25 $first_tar = 0;
163             }
164 598 100       1128 if ($depends =~ s/\s+\\$//o) {
165 14         26 $state = 'S_IN_DEPENDS';
166             } else {
167 584         719 $depends =~ s/\^\\$/\\/;
168 584         708 $state = 'S_CMD';
169             }
170 598         2241 my @depends = split /\s+/, $depends;
171 598         931 map { $self->{_depends}->{$_} = 1 } @depends;
  1735         4615  
172 598         1310 $tar->add_depend(@depends);
173 598 50       8220 $tar->add_command($cmd) if defined $cmd;
174             }
175             elsif ($state eq 'S_IN_DEPENDS' and /^\s+ (.*)$/xo) {
176 14         29 $depends = $1;
177 14 50       51 if ($depends !~ s/\s+\\$//o) {
178 14         35 $depends =~ s/\^\\$/\\/;
179 14         48 my @depends = split /\s+/, $depends;
180 14         25 map { $self->{_depends}->{$_} = 1 } @depends;
  35         110  
181 14         33 $tar->add_depend(@depends);
182 14         74 $state = 'S_CMD';
183             }
184             }
185             elsif ($state eq 'S_CMD' and /^\s+(.*)/o) {
186 825         1794 $cmd = $1;
187 825 100       1610 if ($cmd =~ s/\s+\\$//o) {
188 35         307 $state = 'S_IN_CMD';
189             } else {
190 790         1874 $tar->add_command($cmd);
191             }
192             }
193             elsif ($state eq 'S_IN_CMD' and /^\s+(.*)/o) {
194 133         397 $cmd .= " $1";
195 133 100       1360 if ($cmd !~ s/\s+\\$//o) {
196 35         84 $tar->add_command($cmd);
197 35         180 $state = 'S_CMD';
198             }
199             }
200             elsif ($Strict) {
201 0         0 $Error = "syntax error: line $.: $_\n";
202 0         0 return undef;
203             } else {
204 0         0 warn "I dunno how to do with it: $_\n";
205             }
206             }
207 13         33 $self->{_tars} = \%tars;
208 13         52 $self->post_parse;
209             #warn Data::Dumper->Dump([\%tars], ['TARGETS']);
210 13         498 close $in;
211 13         104 return $self;
212             }
213              
214             sub post_parse {
215 13     13 1 20 my $self = shift;
216 13         25 my $rdepends = $self->{_depends};
217 13         22 my $rimps = $self->{_imps};
218 13         311 for (keys %$rdepends) {
219 942 100       1712 next if /%/;
220             #warn "Trying to match implicit rules one by one against $_...\n";
221 933         1441 $self->solve_imp($_);
222             }
223 13         81 for (@$rimps) {
224 9         40 delete $self->{_tars}->{$_};
225             }
226             }
227              
228             sub solve_imp {
229 948     948 1 1009 my ($self, $depend) = @_;
230 948         1071 my $rimps = $self->{_imps};
231 948         1653 for my $imp (@$rimps) {
232 72         140 my $obj = $self->target($imp);
233 72 50 33     144 die "Rules for $imp not found" unless $obj and ref $obj;
234 72         143 my $regex = quotemeta($imp);
235 72         176 $regex =~ s/\\%/(.+)/; # `%' can match any nonempty substring
236             #warn "Processing regex $regex...\n";
237 72 100       1027 if ($depend =~ m/^$regex$/) {
238             #warn "Succeeded to match $imp against $depend!\n";
239 15         33 my $matched_part = $1;
240 15         40 my $tar = Makefile::Target->new($depend, $obj->colon_type);
241 15         23 my $dep;
242 15         42 my @deps = map {
243 15         32 s/%/$matched_part/;
244 15         45 $self->{_depends}->{$_} = 1;
245             #warn "Recursively solving dependent gole $_...\n";
246 15         48 $self->solve_imp($_);
247 15         22 $dep = $_;
248 15         42 $_
249             } $obj->depends;
250 15         38 $tar->add_depend(@deps);
251 15         45 my @cmds = map {
252 15         31 s/\$
253 15         63 s/\$\*/$matched_part/g;
254 15         37 $_
255             } $obj->commands;
256 15         36 $tar->add_command(@cmds);
257 15         83 $self->{_tars}->{$depend} = [$tar];
258             }
259             }
260             }
261              
262             sub var {
263 26     26 1 323 my ($self, $var) = @_;
264 26 100       74 $self->parse if !defined $self->{_file};
265 26         136 return $self->{_vars}->{$var};
266             }
267              
268             sub vars {
269 2     2 1 275 my $self = shift;
270 2 100       11 $self->parse if !defined $self->{_file};
271 2         5 return keys %{$self->{_vars}};
  2         21  
272             }
273              
274             sub target {
275 96     96 1 445 my ($self, $tar_name) = @_;
276 96 100       250 $self->parse if !defined $self->{_file};
277 96 100       177 return $self->{_default} if !defined $tar_name;
278 94         163 my $tars = $self->{_tars}->{$tar_name};
279 94   50     162 $tars ||= [];
280 94 100       249 wantarray ? @$tars : $tars->[0];
281             }
282              
283             sub targets {
284 5     5 1 310 my $self = shift;
285 5 100       19 $self->parse if !defined $self->{_file};
286 5         11 return map { @$_ } values %{$self->{_tars}};
  185         650  
  5         39  
287             }
288              
289             sub roots {
290 6     6 1 93 my $self = shift;
291 6 100       29 $self->parse if !defined $self->{_file};
292 6         11 my %depends = %{$self->{_depends}};
  6         198  
293 6         27 my %tars = %{$self->{_tars}};
  6         112  
294 6         21 my @roots = ();
295 6         9 my ($key, $val);
296 6         34 while (($key, $val) = each %tars) {
297             #next if $key =~ m/%/;
298 187 100       542 next if $depends{$key};
299 25         65 push @roots, $key;
300             }
301 6         306 return @roots;
302             }
303              
304             sub error {
305 3     3 1 20 return $Error;
306             }
307              
308             sub _solve_refs_in_tokens ($$) {
309 1902     1902   2729 my ($self, $tokens) = @_;
310 1902 50       3576 return '' if !$tokens;
311 1902         3046 my $rvars = $self->{_vars};
312 1902         2030 my @new_tokens;
313 1902         3471 for my $token (@$tokens) {
314 5276 100       22647 if ($token =~ /^\$[{(](.*)[)}]$/) {
    100          
    50          
    100          
315 1217         2590 my $s = $1;
316 1217 50       5944 if ($s =~ /^([-\w]+)\s+(.*)$/) {
    50          
317 0         0 my $res = $self->_process_func_ref($1, $2);
318 0 0       0 if (defined $res) {
319 0         0 push @new_tokens, $res;
320 0         0 next;
321             }
322             } elsif ($s =~ /^(\S+?):(\S+?)=(\S+)$/) {
323 0         0 my ($var, $from, $to) = ($1, $2, $3);
324 0         0 my $res = $self->_process_func_ref(
325             'patsubst', "\%$from,\%$to,\$($var)"
326             );
327 0 0       0 if (defined $res) {
328 0         0 push @new_tokens, $res;
329 0         0 next;
330             }
331             }
332 1217 100       2390 if (exists $rvars->{$s}) {
333 1216         2099 push @new_tokens, $rvars->{$s};
334 1216         2320 next;
335             } else {
336             # FIXME: undefined var == ''
337             #push @new_tokens, '';
338             #next;
339             }
340             } elsif ($token =~ /^\$[@<|]$/) {
341             # currently do nothing with the automatic vars
342             } elsif ($token =~ /^\$\$$/) {
343 0         0 push @new_tokens, '$';
344 0         0 next;
345             } elsif ($token =~ /^\$(.)$/) {
346 101 50       344 if (exists $rvars->{$1}) {
347 0         0 push @new_tokens, $rvars->{$1};
348 0         0 next;
349             } else {
350             # FIXME: undef var == ''
351             # push @new_tokens, '';
352             # next;
353             }
354             ### found single-letter variable: $1
355             ### value: $rvars->{$1}
356             ### token: $token
357             }
358 4060         9592 push @new_tokens, $token;
359             }
360             ### retval: join '', @$tokens
361 1902         9279 return join '', @new_tokens;
362             }
363              
364             sub _process_refs {
365 1902     1902   3360 my ($self, $s) = @_;
366 1902         3512 my @tokens = '';
367 1902         1958 while (1) {
368 6692 100       20858 if ($s =~ /\G[^\$]+/gc) {
    100          
    100          
    50          
369 3103         8006 $tokens[-1] .= $&;
370             } elsif (my $res = _extract_interp($s)) {
371 1217         2739 push @tokens, $res, '';
372             } elsif ($s =~ /\G\$./gc) {
373 470         1439 push @tokens, $&, '';
374             } elsif ($s =~ /\G./gc) {
375 0         0 $tokens[-1] .= $&;
376             } else {
377 1902         2691 last;
378             }
379             }
380             ### tokens: @tokens
381 1902         4881 return $self->_solve_refs_in_tokens(\@tokens);
382             }
383              
384             sub _pat2re ($@) {
385 0     0   0 my ($pat, $capture) = @_;
386 0         0 $pat = quotemeta $pat;
387 0 0       0 if ($capture) {
388 0         0 $pat =~ s/\\\%/(\\S*)/g;
389             } else {
390 0         0 $pat =~ s/\\\%/\\S*/g;
391             }
392 0         0 $pat;
393             }
394              
395             sub _text2words ($) {
396 0     0   0 my ($text) = @_;
397 0         0 $text =~ s/^\s+|\s+$//g;
398 0         0 split /\s+/, $text;
399             }
400              
401             sub _check_numeric ($$$$) {
402 0     0   0 my ($self, $func, $order, $n) = @_;
403 0 0       0 if ($n !~ /^\d+$/) {
404 0         0 warn $self->{_file}, ":$.: ",
405             "*** non-numeric $order argument to `$func' function: '$n'. Stop.\n";
406 0         0 exit(2);
407             }
408             }
409              
410             sub _check_greater_than ($$$$$) {
411 0     0   0 my ($self, $func, $order, $n, $value) = @_;
412 0 0       0 if ($n <= $value) {
413 0         0 warn $self->{_file}, ":$.: *** $order argument to `$func' function must be greater than $value. Stop.\n";
414 0         0 exit(2);
415             }
416             }
417              
418             sub _trim ($@) {
419 0     0   0 for (@_) {
420 0         0 s/^\s+|\s+$//g;
421             }
422             }
423              
424             sub _split_args($$$$) {
425 0     0   0 my ($self, $func, $s, $m, $n) = @_;
426 0   0     0 $n ||= $m;
427 0         0 my @tokens = '';
428 0         0 my @args;
429             ### $n
430 0         0 while (@args <= $n) {
431             ### split args: @args
432             ### split tokens: @tokens
433 0 0       0 if ($s =~ /\G\s+/gc) {
    0          
    0          
    0          
    0          
    0          
434 0         0 push @tokens, $&, '';
435             }
436             elsif ($s =~ /\G[^\$,]+/gc) {
437 0         0 $tokens[-1] .= $&;
438             }
439             elsif ($s =~ /\G,/gc) {
440 0 0       0 if (@args < $n - 1) {
441 0         0 push @args, [grep { $_ ne '' } @tokens];
  0         0  
442 0         0 @tokens = '';
443             } else {
444 0         0 $tokens[-1] .= $&;
445             }
446             }
447             elsif (my $res = _extract_interp($s)) {
448 0         0 push @tokens, $res, '';
449             }
450             elsif ($s =~ /\G\$./gc) {
451 0         0 push @tokens, $&, '';
452             }
453             elsif ($s =~ /\G./gc) {
454 0         0 $tokens[-1] .= $&;
455             }
456             else {
457 0 0       0 if (@args <= $n - 1) {
458 0         0 push @args, [grep { $_ ne '' } @tokens];
  0         0  
459             }
460 0 0 0     0 last if @args >= $m and @args <= $n;
461 0         0 warn $self->{_file}, ":$.: ",
462             "*** insufficient number of arguments (",
463             scalar(@args), ") to function `$func'. Stop.\n";
464 0         0 exit(2);
465             }
466             }
467 0         0 return @args;
468             }
469              
470             sub _trim_tokens ($) {
471 0     0   0 my $tokens = shift;
472 0 0       0 return if !@$tokens;
473 0 0       0 if ($tokens->[0] =~ /^\s+$/) {
474 0         0 shift @$tokens;
475             }
476 0 0       0 return if !@$tokens;
477 0 0       0 if ($tokens->[-1] =~ /^\s+$/) {
478 0         0 pop @$tokens;
479             }
480             }
481              
482             sub _process_func_ref ($$$) {
483 0     0   0 my ($self, $name, $args) = @_;
484             #### process func ref: $name
485 0         0 $name = $self->_process_refs($name);
486 0         0 my @args;
487 0         0 my $nargs = scalar(@args);
488 0 0       0 if ($name eq 'subst') {
489 0         0 my @args = $self->_split_args($name, $args, 3);
490 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
491             ### arguments: @args
492 0         0 my ($from, $to, $text) = @args;
493 0         0 $from = quotemeta($from);
494 0         0 $text =~ s/$from/$to/g;
495 0         0 return $text;
496             }
497 0 0       0 if ($name eq 'patsubst') {
498 0         0 my @args = $self->_split_args($name, $args, 3);
499 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
500 0         0 my ($pattern, $replacement, $text) = @args;
501 0         0 my $re = _pat2re($pattern, 1);
502 0         0 $replacement =~ s/\%/\${1}/g;
503 0         0 $replacement = qq("$replacement");
504             #### pattern: $re
505             #### replacement: $replacement
506             #### text: $text
507 0         0 my $code = "s/^$re\$/$replacement/e";
508             #### code: $code
509 0         0 my @words = _text2words($text);
510 0         0 map { eval $code; } @words;
  0         0  
511 0         0 return join ' ', grep { $_ ne '' } @words;
  0         0  
512             }
513 0 0       0 if ($name eq 'strip') {
514 0         0 my @args = $self->_split_args($name, $args, 1);
515 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
516 0         0 my ($string) = @args;
517 0         0 $string =~ s/^\s+|\s+$//g;
518 0         0 $string =~ s/\s+/ /g;
519 0         0 return $string;
520             }
521 0 0       0 if ($name eq 'findstring') {
522 0         0 my @args = $self->_split_args($name, $args, 2);
523 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
524 0         0 my ($find, $in) = @args;
525 0 0       0 if (index($in, $find) >= 0) {
526 0         0 return $find;
527             } else {
528 0         0 return '';
529             }
530 0         0 my ($patterns, $text) = @args;
531 0         0 my @regexes = map { _pat2re($_) }
  0         0  
532             split /\s+/, $patterns;
533             ### regexes: @regexes
534 0         0 my $regex = join '|', map { "(?:$_)" } @regexes;
  0         0  
535             ### regex: $regex
536 0         0 my @words = _text2words($text);
537 0         0 return join ' ', grep /^$regex$/, @words;
538              
539             }
540 0 0       0 if ($name eq 'filter') {
541 0         0 my @args = $self->_split_args($name, $args, 2);
542 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
543 0         0 my ($patterns, $text) = @args;
544 0         0 my @regexes = map { _pat2re($_) }
  0         0  
545             split /\s+/, $patterns;
546             ### regexes: @regexes
547 0         0 my $regex = join '|', map { "(?:$_)" } @regexes;
  0         0  
548             ### regex: $regex
549 0         0 my @words = _text2words($text);
550 0         0 return join ' ', grep /^$regex$/, @words;
551             }
552 0 0       0 if ($name eq 'filter-out') {
553 0         0 my @args = $self->_split_args($name, $args, 2);
554 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
555 0         0 my ($patterns, $text) = @args;
556 0         0 my @regexes = map { _pat2re($_) }
  0         0  
557             split /\s+/, $patterns;
558             ### regexes: @regexes
559 0         0 my $regex = join '|', map { "(?:$_)" } @regexes;
  0         0  
560             ### regex: $regex
561 0         0 my @words = _text2words($text);
562 0         0 return join ' ', grep !/^$regex$/, @words;
563             }
564 0 0       0 if ($name eq 'sort') {
565 0         0 my @args = $self->_split_args($name, $args, 1);
566 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
567 0         0 my ($list) = @args;
568 0         0 _trim($list);
569 0         0 return join ' ', uniq sort split /\s+/, $list;
570             }
571 0 0       0 if ($name eq 'words') {
572 0         0 my @args = $self->_split_args($name, $args, 1);
573 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
574 0         0 my ($text) = @args;
575 0         0 my @words = _text2words($text);
576 0         0 return scalar(@words);
577             }
578 0 0       0 if ($name eq 'word') {
579 0         0 my @args = $self->_split_args($name, $args, 2);
580 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
581 0         0 my ($n, $text) = @args;
582 0         0 _trim($n);
583 0         0 $self->_check_numeric('word', 'first', $n);
584 0         0 $self->_check_greater_than('word', 'first', $n, 0);
585 0         0 my @words = _text2words($text);
586 0 0       0 return $n > @words ? '' : $words[$n - 1];
587             }
588 0 0       0 if ($name eq 'wordlist') {
589 0         0 my @args = $self->_split_args($name, $args, 3);
590 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
591 0         0 my ($s, $e, $text) = @args;
592 0         0 _trim($s, $e, $text);
593 0         0 $self->_check_numeric('wordlist', 'first', $s);
594 0         0 $self->_check_numeric('wordlist', 'second', $e);
595 0         0 $self->_check_greater_than('wordlist', 'first', $s, 0);
596 0         0 $self->_check_greater_than('wordlist', 'second', $s, -1);
597 0         0 my @words = _text2words($text);
598 0 0 0     0 if ($s > $e || $s > @words || $e == 0) {
      0        
599 0         0 return '';
600             }
601 0 0       0 $e = @words if $e > @words;
602 0         0 return join ' ', @words[$s-1..$e-1];
603             }
604 0 0       0 if ($name eq 'firstword') {
605 0         0 my @args = $self->_split_args($name, $args, 1);
606 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
607 0         0 my ($text) = @args;
608 0         0 my @words = _text2words($text);
609 0 0       0 return @words > 0 ? $words[0] : '';
610             }
611 0 0       0 if ($name eq 'lastword') {
612 0         0 my @args = $self->_split_args($name, $args, 1);
613 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
614 0         0 my ($text) = @args;
615 0         0 my @words = _text2words($text);
616 0 0       0 return @words > 0 ? $words[-1] : '';
617             }
618 0 0       0 if ($name eq 'dir') {
619 0         0 my @args = $self->_split_args($name, $args, 1);
620 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
621 0         0 my ($text) = @args;
622 0         0 my @names = _text2words($text);
623 0 0       0 return join ' ', map { /.*\// ? $& : './' } @names;
  0         0  
624             }
625 0 0       0 if ($name eq 'notdir') {
626 0         0 my @args = $self->_split_args($name, $args, 1);
627 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
628 0         0 my ($text) = @args;
629 0         0 my @names = _text2words($text);
630 0         0 return join ' ', map { s/.*\///; $_ } @names;
  0         0  
  0         0  
631             }
632 0 0       0 if ($name eq 'suffix') {
633 0         0 my @args = $self->_split_args($name, $args, 1);
634 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
635 0         0 my ($text) = @args;
636 0         0 my @names = _text2words($text);
637 0 0       0 my $s = join ' ', map { /.*(\..*)/ ? $1 : '' } @names;
  0         0  
638 0         0 $s =~ s/\s+$//g;
639 0         0 return $s;
640             }
641 0 0       0 if ($name eq 'basename') {
642 0         0 my @args = $self->_split_args($name, $args, 1);
643 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
644 0         0 my ($text) = @args;
645 0         0 my @names = _text2words($text);
646 0 0       0 my $s = join ' ', map { /(.*)\./ ? $1 : $_ } @names;
  0         0  
647 0         0 $s =~ s/\s+$//g;
648 0         0 return $s;
649             }
650 0 0       0 if ($name eq 'addsuffix') {
651 0         0 my @args = $self->_split_args($name, $args, 2);
652 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
653 0         0 my ($suffix, $text) = @args;
654             #_trim($suffix);
655 0         0 my @names = _text2words($text);
656 0         0 return join ' ', map { $_ . $suffix } @names;
  0         0  
657             }
658 0 0       0 if ($name eq 'addprefix') {
659 0         0 my @args = $self->_split_args($name, $args, 2);
660 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
661 0         0 my ($suffix, $text) = @args;
662             #_trim($suffix);
663 0         0 my @names = _text2words($text);
664 0         0 return join ' ', map { $suffix . $_ } @names;
  0         0  
665             }
666 0 0       0 if ($name eq 'join') {
667 0         0 my @args = $self->_split_args($name, $args, 2);
668 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
669 0         0 my ($list_1, $list_2) = @args;
670 0         0 my @list_1 = _text2words($list_1);
671 0         0 my @list_2 = _text2words($list_2);
672             return join ' ', pairwise {
673 1     1   12 no warnings 'uninitialized';
  1         1  
  1         262  
674 0     0   0 $a . $b
675 0         0 } @list_1, @list_2;
676             }
677 0 0       0 if ($name eq 'wildcard') {
678 0         0 my @args = $self->_split_args($name, $args, 1);
679 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
680 0         0 my ($pattern) = @args;
681 0         0 return join ' ', grep { -e $_ } glob $pattern;
  0         0  
682             }
683 0 0       0 if ($name eq 'realpath') {
684 1     1   5 no warnings 'uninitialized';
  1         2  
  1         1704  
685 0         0 my @args = $self->_split_args($name, $args, 1);
686 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
687 0         0 my ($text) = @args;
688 0         0 my @names = _text2words($text);
689 0         0 return join ' ', map { realpath($_) } @names;
  0         0  
690             }
691 0 0       0 if ($name eq 'abspath') {
692 0         0 my @args = $self->_split_args($name, $args, 1);
693 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
694 0         0 my ($text) = @args;
695 0         0 my @names = _text2words($text);
696 0         0 my @paths = map { File::Spec->rel2abs($_) } @names;
  0         0  
697 0         0 for my $path (@paths) {
698 0         0 my @f = split '/', $path;
699 0         0 my @new_f;
700 0         0 for (@f) {
701 0 0       0 if ($_ eq '..') {
702 0         0 pop @new_f;
703             } else {
704 0         0 push @new_f, $_;
705             }
706             }
707 0         0 $path = join '/', @new_f;
708             }
709 0         0 return join ' ', @paths;
710             }
711 0 0       0 if ($name eq 'shell') {
712 0         0 my @args = $self->_split_args($name, $args, 1);
713 0         0 map { $_ = $self->_solve_refs_in_tokens($_) } @args;
  0         0  
714 0         0 my ($cmd) = @args;
715 0         0 my $output = `$cmd`;
716 0         0 $output =~ s/(?:\r?\n)+$//g;
717 0         0 $output =~ s/\r?\n/ /g;
718 0         0 return $output;
719             }
720 0 0       0 if ($name eq 'if') {
721 0         0 my @args = $self->_split_args($name, $args, 2, 3);
722             #map { $_ = $self->_solve_refs_in_tokens($_) } @args;
723 0         0 my ($condition, $then_part, $else_part) = @args;
724 0         0 _trim_tokens($condition);
725 0         0 $condition = $self->_solve_refs_in_tokens($condition);
726 0 0       0 return $condition eq '' ?
727             $self->_solve_refs_in_tokens($else_part)
728             :
729             $self->_solve_refs_in_tokens($then_part);
730             }
731 0 0       0 if ($name eq 'or') {
732 0         0 my @args = $self->_split_args($name, $args, 1, 1000_000_000);
733             #map { $_ = $self->_solve_refs_in_tokens($_) } @args;
734 0         0 for my $arg (@args) {
735 0         0 _trim_tokens($arg);
736 0         0 my $value = $self->_solve_refs_in_tokens($arg);
737 0 0       0 return $value if $value ne '';
738             }
739 0         0 return '';
740             }
741 0 0       0 if ($name eq 'and') {
742 0         0 my @args = $self->_split_args($name, $args, 1, 1000_000_000);
743             #map { $_ = $self->_solve_refs_in_tokens($_) } @args;
744             ### arguments for 'and': @args
745 0         0 my $value;
746 0         0 for my $arg (@args) {
747 0         0 _trim_tokens($arg);
748 0         0 $value = $self->_solve_refs_in_tokens($arg);
749 0 0       0 return '' if $value eq '';
750             }
751 0         0 return $value;
752             }
753 0 0       0 if ($name eq 'foreach') {
754 0         0 my @args = $self->_split_args($name, $args, 3);
755 0         0 my ($var, $list, $text) = @args;
756 0         0 $var = $self->_solve_refs_in_tokens($var);
757 0         0 $list = $self->_solve_refs_in_tokens($list);
758 0         0 my @words = _text2words($list);
759             # save the original status of $var
760 0         0 my $rvars = $self->{_vars};
761 0         0 my $not_exist = !exists $rvars->{$var};
762 0         0 my $old_val = $rvars->{$var};
763              
764 0         0 my @results;
765 0         0 for my $word (@words) {
766 0         0 $rvars->{$var} = $word;
767             #warn "$word";
768 0         0 push @results, $self->_solve_refs_in_tokens($text);
769             }
770              
771             # restore the original status of $var
772 0 0       0 if ($not_exist) {
773 0         0 delete $rvars->{$var};
774             } else {
775 0         0 $rvars->{$var} = $old_val;
776             }
777              
778 0         0 return join ' ', @results;
779             }
780 0 0       0 if ($name eq 'error') {
781 0         0 my ($text) = $self->_split_args($name, $args, 1);
782 0         0 $text = $self->_solve_refs_in_tokens($text);
783 0         0 warn $self->{_file}, ":$.: *** $text. Stop.\n";
784 0 0       0 exit(2) if $Runtime;
785 0         0 return '';
786             }
787 0 0       0 if ($name eq 'warning') {
788 0         0 my ($text) = $self->_split_args($name, $args, 1);
789 0         0 $text = $self->_solve_refs_in_tokens($text);
790 0         0 warn $self->{_file}, ":$.: $text\n";
791 0         0 return '';
792             }
793 0 0       0 if ($name eq 'info') {
794 0         0 my ($text) = $self->_split_args($name, $args, 1);
795 0         0 $text = $self->_solve_refs_in_tokens($text);
796 0         0 print "$text\n";
797 0         0 return '';
798             }
799              
800 0         0 return undef;
801             }
802              
803             #######################################
804              
805             package Makefile::Target;
806              
807             use overload
808 274     274   488 '""' => sub { shift->name },
809 33     33   63 'cmp' => sub { my ($a,$b) = @_; "$a" cmp "$b" },
  33         57  
810 0     0   0 'eq' => sub { my ($a,$b) = @_; "$a" eq "$b" },
  0         0  
811 1     1   8 'lt' => sub { my ($a,$b) = @_; "$a" lt "$b" };
  1     0   2  
  1         27  
  0         0  
  0         0  
812              
813             # usage: $class->new($name, $colon_type)
814             sub new {
815 613     613   958 my $class = shift;
816 613         3040 my $self = {
817             _name => shift,
818             _colon_type => shift,
819             _commands => [],
820             _depends => [],
821             };
822 613         2000 return bless $self, $class;
823             }
824              
825             sub name {
826 1139     1139   3193 return shift->{_name};
827             }
828              
829             sub colon_type {
830 22     22   102 return shift->{_colon_type};
831             }
832              
833             sub prereqs {
834 39     39   63 return @{shift->{_depends}};
  39         161  
835             }
836              
837             *depends = \&prereqs;
838              
839             sub add_prereq {
840 629     629   664 push @{shift->{_depends}}, @_;
  629         2197  
841             }
842              
843             *add_depend = \&add_prereq;
844              
845             sub commands {
846 29     29   79 return @{shift->{_commands}};
  29         299  
847             }
848              
849             sub add_command {
850 841     841   1045 my $self = shift;
851 841         1674 my @cmds = @_;
852 841         1576 my $name = $self->name;
853 841 100       2129 if ($name !~ m/%/) {
854 832         1454 map { s/\$\@/$self->{_name}/g } @cmds;
  833         3863  
855             }
856 841         1013 push @{$self->{_commands}}, @cmds;
  841         6107  
857             }
858              
859             sub run_commands {
860 0     0     my $self = shift;
861 0           my @cmd = $self->commands;
862 0           for my $cmd (@cmd) {
863 0           my ($quiet, $continue);
864 0           while (1) {
865 0 0         if ($cmd =~ s/^\s*\@//) {
    0          
866 0           $quiet = 1;
867             } elsif ($cmd =~ s/^\s*-//) {
868 0           $continue = 1;
869             } else {
870 0           last;
871             }
872             }
873 0           $cmd =~ s/^\s+|\s+$//gs;
874 0 0         next if $cmd =~ /^$/;
875 0 0         print "$cmd\n" unless $quiet;
876             # currently only 'sh' is specified
877 0           system('/bin/sh', '-c', $cmd);
878 0 0 0       if ($? != 0 && !$continue) {
879 0           die "$cmd returns nonzero status value: $?\n";
880             }
881             }
882             }
883              
884             1;
885             __END__