1package Module::Build::Convert;
2
3use 5.005;
4use strict;
5use warnings;
6
7use Carp ();
8use Cwd ();
9use Data::Dumper ();
10use ExtUtils::MakeMaker ();
11use File::Basename ();
12use File::HomeDir ();
13use File::Slurp ();
14use File::Spec ();
15use IO::File ();
16use IO::Prompt ();
17use PPI ();
18use Text::Balanced ();
19
20our $VERSION = '0.49';
21
22use constant LEADCHAR => '* ';
23
24sub new {
25    my ($self, %params) = @_;
26    my $class = ref($self) || $self;
27
28    my $obj = bless { Config => { Path                => $params{Path}                || '',
29                                  Makefile_PL         => $params{Makefile_PL}         || 'Makefile.PL',
30                                  Build_PL            => $params{Build_PL}            || 'Build.PL',
31                                  MANIFEST            => $params{MANIFEST}            || 'MANIFEST',
32                                  RC                  => $params{RC}                  || '.make2buildrc',
33                                  Dont_Overwrite_Auto => $params{Dont_Overwrite_Auto} || 1,
34                                  Create_RC           => $params{Create_RC}           || 0,
35                                  Parse_PPI           => $params{Parse_PPI}           || 0,
36                                  Exec_Makefile       => $params{Exec_Makefile}       || 0,
37                                  Verbose             => $params{Verbose}             || 0,
38                                  Debug               => $params{Debug}               || 0,
39                                  Process_Code        => $params{Process_Code}        || 0,
40                                  Use_Native_Order    => $params{Use_Native_Order}    || 0,
41                                  Len_Indent          => $params{Len_Indent}          || 3,
42                                  DD_Indent           => $params{DD_Indent}           || 2,
43                                  DD_Sortkeys         => $params{DD_Sortkeys}         || 1 }}, $class;
44
45    $obj->{Config}{RC} = File::Spec->catfile(File::HomeDir::home(), $obj->{Config}{RC});
46
47    # Save length of filename for creating underlined title in output
48    $obj->{Config}{Build_PL_Length} = length($obj->{Config}{Build_PL});
49
50    return $obj;
51}
52
53sub convert {
54    my $self = shift;
55
56    unless ($self->{Config}{reinit} || @{$self->{dirs}||[]}) {
57        if ($self->{Config}{Path}) {
58            if (-f $self->{Config}{Path}) {
59                my ($basename, $dirname)     = File::Basename::fileparse($self->{Config}{Path});
60                $self->{Config}{Makefile_PL} = $basename;
61                $self->{Config}{Path}        = $dirname;
62            }
63
64            opendir(my $dh, $self->{Config}{Path}) or die "Can't open $self->{Config}{Path}\n";
65            @{$self->{dirs}} = grep { /[\w\-]+[\d\.]+/
66              and -d File::Spec->catfile($self->{Config}{Path}, $_) } sort readdir $dh;
67
68            unless (@{$self->{dirs}}) {
69                unshift @{$self->{dirs}}, $self->{Config}{Path};
70                $self->{have_single_dir} = 1;
71            }
72        } else {
73            unshift @{$self->{dirs}}, '.';
74            $self->{have_single_dir} = 1;
75        }
76    }
77
78    my $Makefile_PL = File::Basename::basename($self->{Config}{Makefile_PL});
79    my $Build_PL    = File::Basename::basename($self->{Config}{Build_PL});
80    my $MANIFEST    = File::Basename::basename($self->{Config}{MANIFEST});
81
82    unshift @{$self->{dirs}}, $self->{current_dir} if $self->{Config}{reinit};
83
84    $self->{show_summary} = 1 if @{$self->{dirs}} > 1;
85
86    while (my $dir = shift @{$self->{dirs}}) {
87        $self->{current_dir} = $dir;
88
89        %{$self->{make_args}} = ();
90
91        unless ($self->{have_single_dir}) {
92            local $" = "\n";
93            $self->_do_verbose(<<TITLE) if !$self->{Config}{reinit};
94Remaining dists:
95----------------
96$dir
97@{$self->{dirs}}
98
99TITLE
100        }
101
102        $dir = File::Spec->catfile($self->{Config}{Path}, $dir) if !$self->{have_single_dir};
103        $self->{Config}{Makefile_PL} = File::Spec->catfile($dir, $Makefile_PL);
104        $self->{Config}{Build_PL}    = File::Spec->catfile($dir, $Build_PL);
105        $self->{Config}{MANIFEST}    = File::Spec->catfile($dir, $MANIFEST);
106
107        unless ($self->{Config}{reinit}) {
108            no warnings 'uninitialized';
109
110            $self->_do_verbose(LEADCHAR."Converting $self->{Config}{Makefile_PL} -> $self->{Config}{Build_PL}\n");
111
112            my $skip_msg  = LEADCHAR."Skipping $self->{Config}{Path}\n";
113               $skip_msg .= "\n" if @{$self->{dirs}};
114
115            $self->_create_rcfile if $self->{Config}{Create_RC};
116
117            if (!$self->_exists_overwrite || !$self->_makefile_ok) {
118                $self->_do_verbose($skip_msg);
119                next;
120            }
121
122            $self->_get_data;
123        }
124
125        $self->_extract_args;
126        $self->_register_summary;
127        $self->_convert;
128        $self->_dump;
129        $self->_write;
130        $self->_add_to_manifest if -e $self->{Config}{MANIFEST};
131    }
132
133    $self->_show_summary if $self->{show_summary};
134}
135
136sub _exists_overwrite {
137    my $self = shift;
138
139    if (-e $self->{Config}{Build_PL}) {
140        print "$self->{current_dir}:\n"
141          if $self->{show_summary} && !$self->{Config}{Verbose};
142
143        print "\n" if $self->{Config}{Verbose};
144        print 'A Build.PL exists already';
145
146        if ($self->{Config}{Dont_Overwrite_Auto}) {
147            print ".\n";
148            my $input_ok = IO::Prompt::prompt -yn, 'Shall I overwrite it? ';
149
150            if (!$input_ok) {
151                print "Skipped...\n";
152                print "\n" if $self->{Config}{Verbose};
153                push @{$self->{summary}{skipped}}, $self->{current_dir};
154                return 0;
155            } else {
156                print "\n" if $self->{Config}{Verbose};
157            }
158        } else {
159            print ", continuing...\n";
160        }
161    }
162
163    return 1;
164}
165
166sub _create_rcfile {
167    my $self = shift;
168
169    my $rcfile = $self->{Config}{RC};
170
171    if (-e $rcfile && !-z $rcfile && File::Slurp::read_file($rcfile) =~ /\w+/) {
172        die "$rcfile exists\n";
173    } else {
174        my $data = $self->_parse_data('create_rc');
175        my $fh = IO::File->new($rcfile, '>') or die "Can't open $rcfile: $!\n";
176        print {$fh} $data;
177        $fh->close;
178        print LEADCHAR."Created $rcfile\n";
179        exit;
180    }
181}
182
183sub _makefile_ok {
184    my $self = shift;
185
186    my $makefile;
187
188    if (-e $self->{Config}{Makefile_PL}) {
189        $makefile = File::Slurp::read_file($self->{Config}{Makefile_PL});
190    } else {
191        die 'No ', File::Basename::basename($self->{Config}{Makefile_PL}), ' found at ',
192          $self->{Config}{Path}
193            ? File::Basename::dirname($self->{Config}{Makefile_PL})
194            : Cwd::cwd(), "\n";
195    }
196
197    my $max_failures = 2;
198    my ($failed, @failures);
199
200    if ($makefile =~ /use\s+inc::Module::Install/) {
201        push @failures, "Unsuitable Makefile: Module::Install being used";
202        $failed++;
203    }
204
205    unless ($makefile =~ /WriteMakefile\s*\(/s) {
206        push @failures, "Unsuitable Makefile: doesn't consist of WriteMakefile()";
207        $failed++;
208    }
209
210    if (!$failed && $makefile =~ /WriteMakefile\(\s*%\w+.*\s*\)/s && !$self->{Config}{Exec_Makefile}) {
211        $self->_do_verbose(LEADCHAR."Indirect arguments to WriteMakefile() via hash detected, setting executing mode\n");
212        $self->{Config}{Exec_Makefile} = 1;
213    }
214
215    if ($failed) {
216        my ($i, $output);
217
218        $output .= "\n" if $self->{Config}{Verbose} && @{$self->{dirs}};
219        $output .= join '', map { $i++; "[$i] $_\n" } @failures;
220        $output .= "$self->{current_dir}: Failed $failed/$max_failures.\n";
221        $output .= "\n" if $self->{Config}{Verbose} && @{$self->{dirs}};
222
223        print $output;
224
225        push @{$self->{summary}{failed}}, $self->{current_dir};
226
227        return 0;
228    }
229
230    return 1;
231}
232
233sub _get_data {
234    my $self = shift;
235    my @data = $self->_parse_data;
236
237    $self->{Data}{table}           = { split /\s+/, shift @data };
238    $self->{Data}{default_args}    = { split /\s+/, shift @data };
239    $self->{Data}{sort_order}      = [ split /\s+/, shift @data ];
240   ($self->{Data}{begin},
241    $self->{Data}{end})            =                      @data;
242
243    # allow for embedded values such as clean => { FILES => '' }
244    foreach my $arg (keys %{$self->{Data}{table}}) {
245        if (index($arg, '.') > 0) {
246            my @path = split /\./, $arg;
247            my $value = $self->{Data}{table}->{$arg};
248            my $current = $self->{Data}{table};
249            while (@path) {
250                my $key = shift @path;
251                $current->{$key} ||= @path ? {} : $value;
252                $current = $current->{$key};
253            }
254        }
255    }
256}
257
258sub _parse_data {
259    my $self = shift;
260    my $create_rc = 1 if (shift || 'undef') eq 'create_rc';
261
262    my ($data, @data_parsed);
263    my $rcfile = $self->{Config}{RC};
264
265    if (-e $rcfile && !-z $rcfile && File::Slurp::read_file($rcfile) =~ /\w+/) {
266        $data = File::Slurp::read_file($rcfile);
267    } else {
268        if (!defined $self->{DATA}) {
269            local $/ = '__END__';
270            $data = <DATA>;
271            chomp $data;
272	    $self->{DATA} = $data;
273	} else {
274	    $data = $self->{DATA};
275	}
276    }
277
278    unless ($create_rc) {
279        @data_parsed = do {               #  # description
280            split /#\s+.*\s+?-\n/, $data; #  -
281        };
282    }
283
284    unless ($create_rc) {
285        # superfluosity
286        shift @data_parsed;
287        chomp $data_parsed[-1];
288
289        foreach my $line (split /\n/, $data_parsed[0]) {
290            next unless $line;
291
292            if ($line =~ /^#/) {
293                my ($arg) = split /\s+/, $line;
294                $self->{disabled}{substr($arg, 1)} = 1;
295            }
296        }
297
298        @data_parsed = map { 1 while s/^#.*?\n(.*)$/$1/gs; $_ } @data_parsed;
299    }
300
301    return $create_rc ? $data : @data_parsed;
302}
303
304sub _extract_args {
305    my $self = shift;
306
307    if ($self->{Config}{Exec_Makefile}) {
308        $self->_do_verbose(LEADCHAR."Executing $self->{Config}{Makefile_PL}\n");
309        $self->_run_makefile;
310    } else {
311        if ($self->{Config}{Parse_PPI}) {
312            $self->_parse_makefile_ppi;
313        } else {
314            $self->_parse_makefile;
315        }
316    }
317}
318
319sub _register_summary {
320    my $self = shift;
321
322    push @{$self->{summary}->{succeeded}}, $self->{current_dir};
323
324    push @{$self->{summary}{$self->{Config}{Exec_Makefile} ? 'method_execute' : 'method_parse'}},
325           $self->{current_dir};
326
327    $self->{Config}{Exec_Makefile} =
328           $self->{Config}{reinit} = 0;
329}
330
331sub _run_makefile {
332    my $self = shift;
333    no warnings 'redefine';
334
335    *ExtUtils::MakeMaker::WriteMakefile = sub {
336      %{$self->{make_args}{args}} = @{$self->{make_args_arr}} = @_;
337    };
338
339    # beware, do '' overwrites existing globals
340    $self->_save_globals;
341    do $self->{Config}{Makefile_PL};
342    $self->_restore_globals;
343}
344
345sub _save_globals {
346    my $self = shift;
347    my @vars;
348
349    my $makefile = File::Slurp::read_file($self->{Config}{Makefile_PL});
350    $makefile =~ s/.*WriteMakefile\(\s*?(.*?)\);.*/$1/s;
351
352    while ($makefile =~ s/\$(\w+)//) {
353        push @vars, $1 if defined ${$1};
354    }
355
356    no strict 'refs';
357    foreach my $var (@vars) {
358        ${__PACKAGE__.'::globals'}{$var} = ${$var};
359    }
360}
361
362sub _restore_globals {
363    my $self = shift;
364    no strict 'refs';
365
366    while (my ($var, $value) = each %{__PACKAGE__.'::globals'}) {
367        ${__PACKAGE__.'::'.$var} = $value;
368    }
369    undef %{__PACKAGE__.'::globals'};
370}
371
372sub _parse_makefile_ppi {
373    my $self = shift;
374
375    $self->_parse_init;
376
377    ($self->{parse}{makefile}, $self->{make_code}{begin}, $self->{make_code}{end}) = $self->_read_makefile;
378
379    $self->_debug(LEADCHAR."Entering parse\n\n", 'no_wait');
380
381    my $doc = PPI::Document->new(\$self->{parse}{makefile});
382
383    my @elements = $doc->children;
384    my @tokens   = $elements[0]->tokens;
385
386    $self->_scrub_ternary(\@tokens);
387
388    my ($keyword, %have, @items, %seen, $structure_ended, $type);
389
390    for (my $i = 0; $i < @tokens; $i++) {
391        my %token = (curr => sub {
392                                      my $c = $i;
393                                      while (!$tokens[$c]->significant) { $c++ }
394                                      $i = $c;
395                                      return $tokens[$c];
396                                 },
397
398                     next => sub {
399                                      my $iter      = $_[0] ? $_[0] : 1;
400                                      my ($c, $pos) = ($i + 1, 0);
401
402                                      while ($c < @tokens) {
403                                          $pos++ if $tokens[$c]->significant;
404                                          last if $pos == $iter;
405                                          $c++;
406                                      }
407
408                                      return $tokens[$c];
409                                 },
410
411                     last => sub {
412                                      my $iter      = $_[0] ? $_[0] : 1;
413                                      my ($c, $pos) = ($i, 0);
414
415                                      $c-- if $c >= 1;
416
417                                      while ($c > 0) {
418                                          $pos++ if $tokens[$c]->significant;
419                                          last if $pos == $iter;
420                                          $c--;
421                                      }
422
423                                      return $tokens[$c];
424                                 });
425
426        my %finalize = (string => sub { $self->{parse}{makeargs}{$keyword} = join '', @items },
427                        array  => sub { $self->{parse}{makeargs}{$keyword} = [ @items      ] },
428                        hash   => sub { $self->{parse}{makeargs}{$keyword} = { @items      } });
429
430        my $token = $have{code} ? $tokens[$i] : $token{curr}->();
431
432        if ($self->_is_quotelike($token) && !$have{code} && !$have{nested_structure} && $token{last}->(1) ne '=>') {
433            $keyword = $token;
434            $type    = 'string';
435            next;
436        } elsif ($token eq '=>' && !$have{nested_structure}) {
437            next;
438        }
439
440        next if $structure_ended && $token eq ',';
441        $structure_ended = 0;
442
443        if ($token->isa('PPI::Token::Structure') && !$have{code}) {
444            if ($token =~ /[\Q[{\E]/) {
445                $have{nested_structure}++;
446
447                my %assoc = ('[' => 'array',
448                             '{' => 'hash');
449
450                $type = $assoc{$token};
451            } elsif ($token =~ /[\Q]}\E]/) {
452                $have{nested_structure}--;
453                $structure_ended = 1 unless $have{nested_structure};
454            }
455        }
456
457        $structure_ended = 1 if  $token{next}->() eq ',' && !$have{code} && !$have{nested_structure};
458        $have{code}      = 1 if  $token->isa('PPI::Token::Word') && $token{next}->(1) ne '=>';
459
460        if ($have{code}) {
461            my $followed_by_arrow = sub { $token eq ',' && $token{next}->(2) eq '=>' };
462
463            my %finalize = (seen   => sub { $structure_ended = 1; $seen{code} = 1; $have{code} = 0 },
464                            unseen => sub { $structure_ended = 1; $seen{code} = 0; $have{code} = 0 });
465
466            if ($followed_by_arrow->()) {
467                ($token{next}->(1) =~ /^[\Q}]\E]$/ || !$have{nested_structure})
468                  ? $finalize{seen}->()
469                  : $have{nested_structure}
470                    ? $finalize{unseen}->()
471                    : ();
472            } elsif (($token eq ',' && $token{next}->(1) eq ']')
473                   || $token{next}->(1) eq ']') {
474                      $finalize{unseen}->();
475            }
476        }
477
478        unless ($token =~ /^[\Q[]{}\E]$/ && !$have{code}) {
479            next if $token eq '=>';
480            next if $token eq ',' && !$have{code} && !$seen{code};
481
482            if (defined $keyword) {
483                $keyword =~ s/['"]//g;
484                $token   =~ s/['"]//g unless $token =~ /^['"]\s+['"]$/ || $have{code};
485
486                if (!$have{code} && !$structure_ended) {
487                    push @items, $token;
488                } else {
489                    if ((@items % 2 == 1 && $type ne 'array') || !@items) {
490                        push @items, $token;
491                    } else {
492                        $items[-1] .= $token unless $structure_ended
493                                                 && $type eq 'string';
494                    }
495                }
496            }
497        }
498
499        if ($structure_ended && @items) {
500            # Obscure construct. Needed to 'serialize' the PPI tokens.
501            @items = map { /(.*)/; $1 } @items;
502
503            # Sanitize code elements within a hash.
504            $items[-1] =~ s/[,\s]+$// if $type eq 'hash' && defined $items[-1];
505
506            $finalize{$type}->();
507
508            undef $keyword;
509
510            $have{code} = 0;
511            @items      = ();
512            %seen       = ();
513
514            $type = 'string';
515        }
516    }
517
518    $self->_debug(LEADCHAR."Leaving parse\n\n", 'no_wait');
519
520    %{$self->{make_args}{args}} = %{$self->{parse}{makeargs}};
521}
522
523sub _is_quotelike {
524    my ($self, $token) = @_;
525
526    return ($token->isa('PPI::Token::Double')
527         or $token->isa('PPI::Token::Quote::Interpolate')
528         or $token->isa('PPI::Token::Quote::Literal')
529         or $token->isa('PPI::Token::Quote::Single')
530         or $token->isa('PPI::Token::Word')) ? 1 : 0;
531}
532
533sub _scrub_ternary {
534    my ($self, $tokens) = @_;
535
536    my (%last, %have, %occurences);
537
538    for (my $i = 0; $i < @$tokens; $i++) {
539        my $token = $tokens->[$i];
540
541        $last{comma} = $i if $token eq ',' && !$have{'?'};
542
543        unless ($have{ternary}) {
544            $occurences{subsequent}{'('}++ if $token eq '(';
545            $occurences{subsequent}{')'}++ if $token eq ')';
546        }
547
548        $have{'?'} = 1 if $token eq '?';
549        $have{':'} = 1 if $token eq ':';
550
551        $have{ternary} = 1 if $have{'?'} && $have{':'};
552
553        if ($have{ternary}) {
554            $occurences{'('} ||= 0;
555            $occurences{')'} ||= 0;
556
557            $occurences{'('} += $occurences{subsequent}{'('};
558            $occurences{')'} += $occurences{subsequent}{')'};
559
560            $occurences{subsequent}{'('} = 0;
561            $occurences{subsequent}{')'} = 0;
562
563            $occurences{'('}++ if $token eq '(';
564            $occurences{')'}++ if $token eq ')';
565
566            $have{parentheses} = 1 if $occurences{'('} || $occurences{')'};
567            $have{comma}       = 1 if $token eq ',';
568
569            if ($occurences{'('} == $occurences{')'} && $have{parentheses} && $have{comma}) {
570                $i++ while $tokens->[$i] ne ',';
571                splice(@$tokens, $last{comma}, $i-$last{comma});
572
573                @have{qw(? : comma parentheses ternary)} = (0,0,0,0,0);
574                @occurences{qw{( )}}                     = (0,0);
575
576                $i = 0; redo;
577            }
578        }
579    }
580}
581
582sub _parse_makefile {
583    my $self = shift;
584
585    $self->_parse_init;
586
587    ($self->{parse}{makefile}, $self->{make_code}{begin}, $self->{make_code}{end}) = $self->_read_makefile;
588    my ($found_string, $found_array, $found_hash) = $self->_parse_regexps;
589
590    $self->_debug(LEADCHAR."Entering parse\n\n", 'no_wait');
591
592    while ($self->{parse}{makefile}) {
593        $self->{parse}{makefile} .= "\n"
594          unless $self->{parse}{makefile} =~ /\n$/s;
595
596        # process string
597        if ($self->{parse}{makefile} =~ s/$found_string//) {
598            $self->_parse_process_string($1,$2,$3);
599            $self->_parse_register_comment;
600            $self->_debug($self->_debug_string_text);
601        # process array
602        } elsif ($self->{parse}{makefile} =~ s/$found_array//s) {
603            $self->_parse_process_array($1,$2,$3);
604            $self->_parse_register_comment;
605            $self->_debug($self->_debug_array_text);
606        # process hash
607        } elsif ($self->{parse}{makefile} =~ s/$found_hash//s) {
608            $self->_parse_process_hash($1,$2,$3);
609            $self->_parse_register_comment;
610            $self->_debug($self->_debug_hash_text);
611        # process "code"
612        } else {
613            chomp $self->{parse}{makefile};
614
615            $self->_parse_process_code;
616            $self->_parse_catch_trapped_loop;
617
618            if ($self->{Config}{Process_Code}) {
619                $self->_parse_substitute_makeargs;
620                $self->_parse_append_makecode;
621                $self->_debug($self->_debug_code_text);
622            }
623        }
624
625        $self->{parse}{makefile} = ''
626          unless $self->{parse}{makefile} =~ /\w/;
627    }
628
629    $self->_debug(LEADCHAR."Leaving parse\n\n", 'no_wait');
630
631    %{$self->{make_args}{args}} = %{$self->{parse}{makeargs}};
632}
633
634sub _parse_init {
635    my $self = shift;
636
637    %{$self->{make_code}} = ();
638    %{$self->{parse}}     = ();
639}
640
641sub _parse_regexps {
642    my $self = shift;
643
644    my $found_string = qr/^
645                            \s*
646                            ['"]? (\w+) ['"]?
647                            \s* => \s* (?![ \{ \[ ])
648                            ['"]? ([\$ \@ \% \< \> \( \) \\ \/ \- \: \. \w]+.*?) ['"]?
649                            ,? ([^\n]+ \# \s+ \w+ .*?)? \n
650                       /sx;
651    my $found_array  = qr/^
652                            \s*
653                            ['"]? (\w+) ['"]?
654                            \s* => \s*
655                            \[ \s* (.*?) \s* \]
656                            ,? ([^\n]+ \# \s+ \w+ .*?)? \n
657                       /sx;
658    my $found_hash   = qr/^
659                            \s*
660                            ['"]? (\w+) ['"]?
661                            \s* => \s*
662                            \{ \s* (.*?) \s*? \}
663                            ,? ([^\n]+ \# \s+ \w+ .*?)? \n
664                       /sx;
665
666    return ($found_string, $found_array, $found_hash);
667}
668
669sub _parse_process_string {
670    my ($self, $arg, $value, $comment) = @_;
671
672    $value   ||= '';
673    $comment ||= '';
674
675    $value =~ s/^['"]//;
676    $value =~ s/['"]$//;
677
678    $self->{parse}{makeargs}{$arg} = $value;
679    push @{$self->{parse}{histargs}}, $arg;
680
681    $self->{parse}{arg}     = $arg;
682    $self->{parse}{value}   = $value;
683    $self->{parse}{comment} = $comment;
684}
685
686sub _parse_process_array {
687    my ($self, $arg, $values, $comment) = @_;
688
689    $values  ||= '';
690    $comment ||= '';
691
692    $self->{parse}{makeargs}{$arg} = [ map { tr/['",]//d; $_ } split /,\s*/, $values ];
693    push @{$self->{parse}{histargs}}, $arg;
694
695    $self->{parse}{arg}     = $arg;
696    $self->{parse}{values}  = $self->{parse}{makeargs}{$arg},
697    $self->{parse}{comment} = $comment;
698}
699
700
701sub _parse_process_hash {
702    my ($self, $arg, $values, $comment) = @_;
703
704    $values  ||= '';
705    $comment ||= '';
706
707    my @values_debug = split /,\s*/, $values;
708    my @values;
709
710    foreach my $value (@values_debug) {
711        push @values, map { tr/['",]//d; $_ } split /\s*=>\s*/, $value;
712    }
713
714    @values_debug = map { "$_\n        " } @values_debug;
715
716    $self->{parse}{makeargs}{$arg} = { @values };
717    push @{$self->{parse}{histargs}}, $arg;
718
719    $self->{parse}{arg}     = $arg;
720    $self->{parse}{values}  = \@values_debug,
721    $self->{parse}{comment} = $comment;
722}
723
724sub _parse_process_code {
725    my $self = shift;
726
727    my ($debug_desc, $retval);
728
729    my @code     = Text::Balanced::extract_codeblock($self->{parse}{makefile}, '()');
730    my @variable = Text::Balanced::extract_variable($self->{parse}{makefile});
731
732    # [0] extracted
733    # [1] remainder
734
735    if ($code[0]) {
736        $code[0] =~ s/^\s*\(\s*//s;
737        $code[0] =~ s/\s*\)\s*$//s;
738
739        $code[0] =~ s/\s*=>\s*/\ =>\ /gs;
740        $code[1] =~ s/^\s*,//;
741
742        $self->{parse}{makefile} = $code[1];
743        $retval                  = $code[0];
744
745        $debug_desc = 'code';
746    } elsif ($variable[0]) {
747        $self->{parse}{makefile} = $variable[1];
748        $retval                  = $variable[0];
749
750        $debug_desc = 'variable';
751    } elsif ($self->{parse}{makefile} =~ /\#/) {
752        my $comment;
753
754        $self->{parse}{makefile} .= "\n"
755          unless $self->{parse}{makefile} =~ /\n$/s;
756
757        while ($self->{parse}{makefile} =~ /\G(\s*?\#.*?\n)/cgs) {
758            $comment .= $1;
759        }
760
761        $comment ||= '';
762
763        my $quoted_comment = quotemeta $comment;
764        $self->{parse}{makefile} =~ s/$quoted_comment//s;
765
766        my @comment;
767
768        @comment = split /\n/,   $comment;
769        @comment = grep { /\#/ } @comment;
770
771        foreach $comment (@comment) {
772            $comment =~ s/^\s*?(\#.*)$/$1/gm;
773            chomp $comment;
774        }
775
776        $retval     = \@comment;
777        $debug_desc = 'comment';
778    } else {
779        $retval     = '';
780        $debug_desc = 'unclassified';
781    }
782
783    $self->{parse}{debug_desc} = $debug_desc;
784    $self->{parse}{makecode}   = $retval;
785}
786
787sub _parse_catch_trapped_loop {
788    my $self = shift;
789
790    no warnings 'uninitialized';
791
792    $self->{parse}{trapped_loop}{$self->{parse}{makecode}}++
793      if $self->{parse}{makecode} eq $self->{makecode_prev};
794
795    if ($self->{parse}{trapped_loop}{$self->{parse}{makecode}} > 1) {
796        $self->{Config}{Exec_Makefile} = 1;
797        $self->{Config}{reinit}        = 1;
798        $self->convert;
799        exit;
800    }
801
802    $self->{makecode_prev} = $self->{parse}{makecode};
803}
804
805sub _parse_substitute_makeargs {
806    my $self = shift;
807
808    $self->{parse}{makecode} ||= '';
809
810    foreach my $make (keys %{$self->{Data}{table}}) {
811        if ($self->{parse}{makecode} =~ /\b$make\b/s) {
812            $self->{parse}{makecode} =~ s/$make/$self->{Data}{table}{$make}/;
813       }
814    }
815}
816
817sub _parse_append_makecode {
818    my $self = shift;
819
820    unless (@{$self->{parse}{histargs}||[]}) {
821        push @{$self->{make_code}{args}{begin}}, $self->{parse}{makecode};
822    } else {
823        pop @{$self->{parse}{histargs}}
824          until $self->{Data}{table}{$self->{parse}{histargs}->[-1]};
825
826        push @{$self->{make_code}{args}{$self->{Data}{table}{$self->{parse}{histargs}->[-1]}}},
827               $self->{parse}{makecode};
828    }
829}
830
831sub _parse_register_comment {
832    my $self = shift;
833
834    my $arg     = $self->{parse}{arg};
835    my $comment = $self->{parse}{comment};
836
837    if (defined($comment) && defined($self->{Data}{table}{$arg})) {
838        $self->{make_comments}{$self->{Data}{table}{$arg}} = $comment;
839    }
840}
841
842sub _debug_string_text {
843    my $self = shift;
844
845    my $output = <<EOT;
846Found string ''
847+++++++++++++++
848\$arg: $self->{parse}{arg}
849\$value: $self->{parse}{value}
850\$comment: $self->{parse}{comment}
851\$remaining args:
852$self->{parse}{makefile}
853
854EOT
855    return $output;
856}
857
858sub _debug_array_text {
859    my $self = shift;
860
861    my @values = @{$self->{parse}{values}};
862
863    my $output = <<EOT;
864Found array []
865++++++++++++++
866\$arg: $self->{parse}{arg}
867\$values: @values
868\$comment: $self->{parse}{comment}
869\$remaining args:
870$self->{parse}{makefile}
871
872EOT
873    return $output;
874}
875
876sub _debug_hash_text {
877    my $self = shift;
878
879    my $output = <<EOT;
880Found hash {}
881+++++++++++++
882\$key: $self->{parse}{arg}
883\$values: @{$self->{parse}{values}}
884\$comment: $self->{parse}{comment}
885\$remaining args:
886$self->{parse}{makefile}
887EOT
888    return $output;
889}
890
891sub _debug_code_text {
892    my $self = shift;
893
894    my @args;
895
896    if (ref $self->{parse}{makecode} eq 'ARRAY') {
897        push @args, @{$self->{parse}{makecode}};
898    } else {
899        push @args, $self->{parse}{makecode};
900    }
901
902    @args = map { "\n$_" } @args if @args > 1;
903
904    my $output = <<EOT;
905Found code &
906++++++++++++
907$self->{parse}{debug_desc}: @args
908remaining args:
909$self->{parse}{makefile}
910
911EOT
912    return $output;
913}
914
915sub _read_makefile {
916    my $self = shift;
917
918    my $makefile = File::Slurp::read_file($self->{Config}{Makefile_PL});
919    $makefile =~ s/^(.*?)\&?WriteMakefile\s*?\(\s*(.*?)\s*\)\s*?;(.*)$/$2/s;
920
921    my $makecode_begin = $1;
922    my $makecode_end   = $3;
923    $makecode_begin    =~ s/\s*([\#\w]+.*)\s*/$1/s;
924    $makecode_end      =~ s/\s*([\#\w]+.*)\s*/$1/s;
925
926    return ($makefile, $makecode_begin, $makecode_end);
927}
928
929sub _convert {
930    my $self = shift;
931
932    $self->_insert_args;
933
934    foreach my $arg (keys %{$self->{make_args}{args}}) {
935        if ($self->{disabled}{$arg}) {
936            $self->_do_verbose(LEADCHAR."$arg disabled, skipping\n");
937            next;
938        }
939        unless ($self->{Data}{table}->{$arg}) {
940            $self->_do_verbose(LEADCHAR."$arg unknown, skipping\n");
941            next;
942        }
943        if (ref $self->{make_args}{args}{$arg} eq 'HASH') {
944            if (ref $self->{Data}{table}->{$arg} eq 'HASH') {
945                # embedded structure
946                my @iterators = ();
947                my $current = $self->{Data}{table}->{$arg};
948                my $value = $self->{make_args}{args}{$arg};
949                push @iterators, _iterator($current, $value, keys %$current);
950                while (@iterators) {
951                    my $iterator = shift @iterators;
952                    while (($current, $value) = $iterator->()) {
953                        if (ref $current eq 'HASH') {
954                            push @iterators, _iterator($current, $value, keys %$current);
955                        } else {
956                            if (substr($current, 0, 1) eq '@') {
957                                my $attr = substr($current, 1);
958                                if (ref $value eq 'ARRAY') {
959                                    push @{$self->{build_args}}, { $attr => $value };
960                                } else {
961                                    push @{$self->{build_args}}, { $attr => [ split ' ', $value ] };
962                                }
963                            } else {
964                                push @{$self->{build_args}}, { $current => $value };
965                            }
966                        }
967                    }
968                }
969            } else {
970                # flat structure
971                my %tmphash;
972                %{$tmphash{$self->{Data}{table}->{$arg}}} =
973                  map { $_ => $self->{make_args}{args}{$arg}{$_} } keys %{$self->{make_args}{args}{$arg}};
974                push @{$self->{build_args}}, \%tmphash;
975            }
976        } elsif (ref $self->{make_args}{args}{$arg} eq 'ARRAY') {
977            push @{$self->{build_args}}, { $self->{Data}{table}->{$arg} => $self->{make_args}{args}{$arg} };
978        } elsif (ref $self->{make_args}{args}{$arg} eq '') {
979            push @{$self->{build_args}}, { $self->{Data}{table}->{$arg} => $self->{make_args}{args}{$arg} };
980        } else { # unknown type
981            warn "$arg - unknown type of argument\n";
982        }
983    }
984
985    $self->_sort_args if @{$self->{Data}{sort_order}};
986}
987
988sub _insert_args {
989    my ($self, $make) = @_;
990
991    my @insert_args;
992    my %build = map { $self->{Data}{table}{$_} => $_ } keys %{$self->{Data}{table}};
993
994    while (my ($arg, $value) = each %{$self->{Data}{default_args}}) {
995        no warnings 'uninitialized';
996
997        if (exists $self->{make_args}{args}{$build{$arg}}) {
998            $self->_do_verbose(LEADCHAR."Overriding default \'$arg => $value\'\n");
999            next;
1000        }
1001
1002        $value = {} if $value eq 'HASH';
1003        $value = [] if $value eq 'ARRAY';
1004        $value = '' if $value eq 'SCALAR' && $value !~ /\d+/;
1005
1006        push @insert_args, { $arg => $value };
1007    }
1008
1009    @{$self->{build_args}} = @insert_args;
1010}
1011
1012sub _iterator {
1013    my ($build, $make) = (shift, shift);
1014    my @queue = @_;
1015
1016    return sub {
1017        my $key = shift @queue || return;
1018        return $build->{$key}, $make->{$key};
1019    }
1020}
1021
1022sub _sort_args {
1023    my $self = shift;
1024
1025    my %native_sortorder;
1026
1027    if ($self->{Config}{Use_Native_Order}) {
1028        no warnings 'uninitialized';
1029
1030        # Mapping an incremental value to the arguments (keys) in the
1031        # order they appear.
1032        for (my ($i,$s) = 0; $s < @{$self->{make_args_arr}}; $s++) {
1033            # Skipping values
1034            next unless $s % 2 == 0;
1035            # Populating table with according M::B arguments and counter
1036            $native_sortorder{$self->{Data}{table}{$self->{make_args_arr}[$s]}} = $i
1037              if exists $self->{Data}{table}{$self->{make_args_arr}[$s]};
1038            $i++;
1039        }
1040    }
1041
1042    my %sortorder;
1043    {
1044        my %have_args = map { keys %$_ => 1 } @{$self->{build_args}};
1045        # Filter sort items, that we didn't receive as args,
1046        # and map the rest to according array indexes.
1047        my $i = 0;
1048        if ($self->{Config}{Use_Native_Order}) {
1049            my %slot;
1050
1051            foreach my $arg (grep $have_args{$_}, @{$self->{Data}{sort_order}}) {
1052                # Building sorting table for existing MakeMaker arguments
1053                if ($native_sortorder{$arg}) {
1054                    $sortorder{$arg} = $native_sortorder{$arg};
1055                    $slot{$native_sortorder{$arg}} = 1;
1056                # Inject default arguments at free indexes
1057                } else {
1058                    $i++ while $slot{$i};
1059                    $sortorder{$arg} = $i++;
1060                }
1061            }
1062
1063            # Sorting sort table ascending
1064            my @args = sort { $sortorder{$a} <=> $sortorder{$b} } keys %sortorder;
1065            $i = 0; %sortorder = map { $_ => $i++ } @args;
1066
1067        } else {
1068            %sortorder = map {
1069              $_ => $i++
1070            } grep $have_args{$_}, @{$self->{Data}{sort_order}};
1071        }
1072    }
1073
1074    my ($is_sorted, @unsorted);
1075    do {
1076
1077        $is_sorted = 1;
1078
1079          SORT: for (my $i = 0; $i < @{$self->{build_args}}; $i++) {
1080              my ($arg) = keys %{$self->{build_args}[$i]};
1081
1082              unless (exists $sortorder{$arg}) {
1083                  push @unsorted, splice(@{$self->{build_args}}, $i, 1);
1084                  next;
1085              }
1086
1087              if ($i != $sortorder{$arg}) {
1088                  $is_sorted = 0;
1089                  # Move element $i to pos $sortorder{$arg}
1090                  # and the element at $sortorder{$arg} to
1091                  # the end.
1092                  push @{$self->{build_args}},
1093                    splice(@{$self->{build_args}}, $sortorder{$arg}, 1,
1094                      splice(@{$self->{build_args}}, $i, 1));
1095
1096                  last SORT;
1097              }
1098          }
1099    } until ($is_sorted);
1100
1101    push @{$self->{build_args}}, @unsorted;
1102}
1103
1104sub _dump {
1105    my $self = shift;
1106
1107    $Data::Dumper::Indent    = $self->{Config}{DD_Indent} || 2;
1108    $Data::Dumper::Quotekeys = 0;
1109    $Data::Dumper::Sortkeys  = $self->{Config}{DD_Sortkeys};
1110    $Data::Dumper::Terse     = 1;
1111
1112    my $d = Data::Dumper->new(\@{$self->{build_args}});
1113    $self->{buildargs_dumped} = [ $d->Dump ];
1114}
1115
1116sub _write {
1117    my $self = shift;
1118
1119    $self->{INDENT} = ' ' x $self->{Config}{Len_Indent};
1120
1121    no warnings 'once';
1122    my $fh = IO::File->new($self->{Config}{Build_PL}, '>')
1123      or die "Can't open $self->{Config}{Build_PL}: $!\n";
1124
1125    my $selold = select($fh);
1126
1127    $self->_compose_header;
1128    $self->_write_begin;
1129    $self->_write_args;
1130    $self->_write_end;
1131    $fh->close;
1132
1133    select($selold);
1134
1135    $self->_do_verbose("\n", LEADCHAR."Conversion done\n");
1136    $self->_do_verbose("\n") if !$self->{have_single_dir};
1137}
1138
1139sub _compose_header {
1140    my $self = shift;
1141
1142    my ($comments_header, $code_header);
1143
1144    my $note = '# Note: this file has been initially generated by ' . __PACKAGE__ . " $VERSION";
1145    my $pragmas = "use strict;\nuse warnings;\n";
1146
1147    # Warnings are thrown for chomp() & regular expressions when enabled
1148    no warnings 'uninitialized';
1149
1150    if (defined $self->{make_code}{begin} || defined $self->{make_code}{end}) {
1151        # Removing ExtUtils::MakeMaker dependency
1152        $self->_do_verbose(LEADCHAR."Removing ExtUtils::MakeMaker as dependency\n");
1153        $self->{make_code}{begin} =~ s/[ \t]*(?:use|require)\s+ExtUtils::MakeMaker\s*;//;
1154
1155        # Mapping (prompt|Verbose) calls to Module::Build ones
1156        if ($self->{make_code}{begin} =~ /(?:prompt|Verbose)\s*\(/s) {
1157            my $regexp = qr/^(.*?=\s*)(prompt|Verbose)\s*?\(['"](.*)['"]\);$/;
1158
1159            foreach my $var (qw(begin end)) {
1160                while ($self->{make_code}{$var} =~ /$regexp/m) {
1161                    my $replace = $1 . 'Module::Build->' . $2 . '("' . $3 . '");';
1162                    $self->{make_code}{$var} =~ s/$regexp/$replace/m;
1163                }
1164            }
1165        }
1166
1167        # Removing Module::Build::Compat Note
1168        if ($self->{make_code}{begin} =~ /Module::Build::Compat/) {
1169            $self->_do_verbose(LEADCHAR."Removing Module::Build::Compat Note\n");
1170            $self->{make_code}{begin} =~ s/^\#.*Module::Build::Compat.*?\n//s;
1171        }
1172
1173        # Removing customized MakeMaker subs
1174        my $has_MM_sub    = qr/sub MY::/;
1175        my $MM_sub_prefix = 'MY::';
1176
1177        foreach my $var (qw(begin end)) {
1178            if ($self->{make_code}{$var} =~ $has_MM_sub) {
1179                foreach my $sub (_extract_sub($self->{make_code}{$var}, $MM_sub_prefix)) {
1180                    my $quoted_sub = quotemeta $sub;
1181                    my ($subname)  = $sub =~ /sub.*?\s+(.*?)\s*\{/;
1182
1183                    $self->{make_code}{$var} =~ s/$quoted_sub\n//;
1184                    $self->_do_verbose(LEADCHAR."Removing sub: '$subname'\n");
1185                }
1186            }
1187        }
1188
1189        # Removing strict & warnings pragmas quietly here to ensure that they'll
1190        # be inserted after an eventually appearing version requirement.
1191        $self->{make_code}{begin} =~ s/[ \t]*use\s+(?:strict|warnings)\s*;//g;
1192
1193        # Saving the shebang (interpreter) line
1194        while ($self->{make_code}{begin} =~ s/^(\#\!?.*?\n)//) {
1195            $comments_header .= $1;
1196        }
1197        chomp $comments_header;
1198
1199        # Grabbing use & require statements
1200        while ($self->{make_code}{begin} =~ /^(?:use|require)\s+(?:[a-z]|[\d\.\_])+?\s*;/m) {
1201            $self->{make_code}{begin} =~ s/^\n*(.*?;)//s;
1202            $code_header .= "$1\n";
1203        }
1204
1205        # Adding strict & warnings pragmas
1206        $self->_do_verbose(LEADCHAR."Adding use strict & use warnings pragmas\n");
1207
1208        if ($code_header =~ /(?:use|require)\s+\d\.[\d_]*\s*;/) {
1209            $code_header =~ s/([ \t]*(?:use|require)\s+\d\.[\d_]*\s*;\n)(.*)/$1$pragmas$2/;
1210        } else {
1211            $code_header = $pragmas . $code_header;
1212        }
1213        chomp $code_header;
1214
1215        # Removing leading & trailing newlines
1216        1 while $self->{make_code}{begin} =~ s/^\n//;
1217        chomp $self->{make_code}{begin} while $self->{make_code}{begin} =~ /\n$/s;
1218    }
1219
1220    # Constructing the Build.PL header
1221    $self->{Data}{begin} = $comments_header || $code_header
1222      ? ($comments_header  =~ /\w/ ? "$comments_header\n" : '') . "$note\n" .
1223        ($code_header =~ /\w/ ? "\n$code_header\n\n" : "\n") .
1224        $self->{Data}{begin}
1225      : "$note\n\n" . $self->{Data}{begin};
1226}
1227
1228# Albeit Text::Balanced exists, extract_tagged() and friends
1229# were (or I?) unable to extract subs.
1230sub _extract_sub {
1231    my ($text, $pattern) = @_;
1232
1233    my ($quoted_pattern, %seen, @sub, @subs);
1234
1235    $quoted_pattern = quotemeta $pattern;
1236
1237    foreach my $line (split /\n/, $text) {
1238        if ($line =~ /^sub $quoted_pattern\w+/s ||
1239            $line =~ /^\{/)                        { $seen{begin} = 1 }
1240        if ($seen{begin} && $line =~ /^\s*}/)      { $seen{end}   = 1 }
1241
1242        if ($seen{begin} || $seen{end}) {
1243            push @sub, $line;
1244        } else {
1245            next;
1246        }
1247
1248        if ($seen{end}) {
1249            push @subs, join "\n", @sub;
1250            @sub = ();
1251            @seen{qw(begin end)} = (0,0);
1252        }
1253    }
1254
1255    return @subs;
1256}
1257
1258sub _write_begin {
1259    my $self = shift;
1260
1261    my $INDENT = substr($self->{INDENT}, 0, length($self->{INDENT})-1);
1262
1263    $self->_subst_makecode('begin');
1264    $self->{Data}{begin} =~ s/(\$INDENT)/$1/eego;
1265    $self->_do_verbose("\n", File::Basename::basename($self->{Config}{Build_PL}), " written:\n", 2);
1266    $self->_do_verbose('-' x ($self->{Config}{Build_PL_Length} + 9), "\n", 2);
1267    $self->_do_verbose($self->{Data}{begin}, 2);
1268
1269    print $self->{Data}{begin};
1270}
1271
1272sub _write_args {
1273    my $self = shift;
1274
1275    my $arg;
1276    my $regex = '$chunk =~ /=> \{/';
1277
1278    if (@{$self->{make_code}{args}{begin}||[]}) {
1279        foreach my $codechunk (@{$self->{make_code}{args}{begin}}) {
1280            if (ref $codechunk eq 'ARRAY') {
1281                foreach my $code (@$codechunk) {
1282                    $self->_do_verbose("$self->{INDENT}$code\n", 2);
1283                    print "$self->{INDENT}$code\n";
1284                }
1285            } else {
1286                $self->_do_verbose("$self->{INDENT}$codechunk\n", 2);
1287                print "$self->{INDENT}$codechunk\n";
1288            }
1289        }
1290    }
1291
1292    foreach my $chunk (@{$self->{buildargs_dumped}}) {
1293        # Hash/Array output
1294        if ($chunk =~ /=> [\{\[]/) {
1295
1296            # Remove redundant parentheses
1297            $chunk =~ s/^\{.*?\n(.*(?{ $regex ? '\}' : '\]' }))\s+\}\s+$/$1/os;
1298
1299            # One element per each line
1300            my @lines;
1301            push @lines, $1 while $chunk =~ s/^(.*?\n)(.*)$/$2/s;
1302
1303            # Gather whitespace up to hash key in order
1304            # to recreate native Dump() indentation.
1305            my ($whitespace) = $lines[0] =~ /^(\s+)(\w+)/;
1306            $arg = $2;
1307            my $shorten = length($whitespace);
1308
1309            foreach (my $i = 0; $i < @lines; $i++) {
1310                my $line = $lines[$i];
1311                chomp $line;
1312                # Remove additional whitespace
1313                $line =~ s/^\s{$shorten}(.*)$/$1/o;
1314
1315                # Quote sub hash keys
1316                $line =~ s/^(\s+)([\w:]+)/$1'$2'/ if $line =~ /^\s+/;
1317
1318                # Add comma where appropriate (version numbers, parentheses, brackets)
1319                $line .= ',' if $line =~ /[\d+ \} \]] $/x;
1320
1321                # (De)quotify numbers, variables & code bits
1322                $line =~ s/' \\? ( \d | [\\ \/ \( \) \$ \@ \%]+ \w+) '/$1/gx;
1323                $self->_quotify(\$line) if $line =~ /\(/;
1324
1325                # Add comma to dequotified key/value pairs
1326                my $comma   = ',' if $line =~ /['"](?!,)$/ && $#lines - $i != 1;
1327                   $comma ||= '';
1328
1329                # Construct line output
1330                my $output = "$self->{INDENT}$line$comma";
1331
1332                # Add adhering comments at end of array/hash
1333                $output .= ($i == $#lines && defined $self->{make_comments}{$arg})
1334                  ? "$self->{make_comments}{$arg}\n"
1335                  : "\n";
1336
1337                # Output line
1338                $self->_do_verbose($output, 2);
1339                print $output;
1340            }
1341        # String output
1342        } else {
1343            chomp $chunk;
1344            # Remove redundant parentheses
1345            $chunk =~ s/^\{\s+(.*?)\s+\}$/$1/sx;
1346
1347            # (De)quotify numbers, variables & code bits
1348            $chunk =~ s/' \\? ( \d | [\\ \/ \( \) \$ \@ \%]+ \w+ ) '/$1/gx;
1349            $self->_quotify(\$chunk) if $chunk =~ /\(/;
1350
1351            # Extract argument (key)
1352            ($arg) = $chunk =~ /^\s*(\w+)/;
1353
1354            # Construct line output & add adhering comment
1355            my $output = "$self->{INDENT}$chunk,";
1356            $output .= $self->{make_comments}{$arg} if defined $self->{make_comments}{$arg};
1357
1358            # Output key/value pair
1359            $self->_do_verbose("$output\n", 2);
1360            print "$output\n";
1361        }
1362
1363        no warnings 'uninitialized';
1364        my @args;
1365
1366        if ($self->{make_code}{args}{$arg}) {
1367            @args = ();
1368            foreach my $arg (@{$self->{make_code}{args}{$arg}}) {
1369                if (ref $arg eq 'ARRAY') {
1370                    push @args, @$arg;
1371                } else {
1372                    push @args, $arg;
1373                }
1374            }
1375
1376            foreach $arg (@args) {
1377                next unless $arg;
1378
1379                $arg .= ',' unless $arg =~ /^\#/;
1380
1381                $self->_do_verbose("$self->{INDENT}$arg\n", 2);
1382                print "$self->{INDENT}$arg\n";
1383            }
1384        }
1385    }
1386}
1387
1388sub _quotify {
1389    my ($self, $string) = @_;
1390
1391    # Removing single-quotes and escaping backslashes
1392    $$string =~ s/(=>\s+?)'/$1/;
1393    $$string =~ s/',?$//;
1394    $$string =~ s/\\'/'/g;
1395
1396    # Double-quoting $(NAME) variables
1397    if ($$string =~ /\$\(/) {
1398        $$string =~ s/(=>\s+?)(.*)/$1"$2"/;
1399    }
1400}
1401
1402sub _write_end {
1403    my $self = shift;
1404
1405    my $INDENT = substr($self->{INDENT}, 0, length($self->{INDENT})-1);
1406
1407    $self->_subst_makecode('end');
1408    $self->{Data}{end} =~ s/(\$INDENT)/$1/eego;
1409    $self->_do_verbose($self->{Data}{end}, 2);
1410
1411    print $self->{Data}{end};
1412}
1413
1414sub _subst_makecode {
1415    my ($self, $section) = @_;
1416
1417    $self->{make_code}{$section} ||= '';
1418
1419    $self->{make_code}{$section} =~ /\w/
1420      ? $self->{Data}{$section} =~ s/\$MAKECODE/$self->{make_code}{$section}/o
1421      : $self->{Data}{$section} =~ s/\n\$MAKECODE\n//o;
1422}
1423
1424sub _add_to_manifest {
1425    my $self = shift;
1426
1427    my $fh = IO::File->new($self->{Config}{MANIFEST}, '<')
1428      or die "Can't open $self->{Config}{MANIFEST}: $!\n";
1429    my @manifest = <$fh>;
1430    $fh->close;
1431
1432    my $build_pl = File::Basename::basename($self->{Config}{Build_PL});
1433
1434    unless (grep { /^$build_pl\s+$/o } @manifest) {
1435        unshift @manifest, "$build_pl\n";
1436
1437        $fh = IO::File->new($self->{Config}{MANIFEST}, '>')
1438          or die "Can't open $self->{Config}{MANIFEST}: $!\n";
1439        print {$fh} sort @manifest;
1440        $fh->close;
1441
1442        $self->_do_verbose(LEADCHAR."Added to $self->{Config}{MANIFEST}: $self->{Config}{Build_PL}\n");
1443    }
1444}
1445
1446sub _show_summary {
1447    my $self = shift;
1448
1449    my @summary = (
1450        [ 'Succeeded',       'succeeded'      ],
1451        [ 'Skipped',         'skipped'        ],
1452        [ 'Failed',          'failed'         ],
1453        [ 'Method: parse',   'method_parse'   ],
1454        [ 'Method: execute', 'method_execute' ],
1455    );
1456
1457    local $" = "\n";
1458
1459    foreach my $item (@summary) {
1460        next unless @{$self->{summary}{$item->[1]}||[]};
1461
1462        $self->_do_verbose("$item->[0]\n");
1463        $self->_do_verbose('-' x length($item->[0]), "\n");
1464        $self->_do_verbose("@{$self->{summary}{$item->[1]}}\n\n");
1465    }
1466
1467    my $howmany = @{$self->{summary}->{succeeded}};
1468
1469    print "Processed $howmany directories\n";
1470}
1471
1472sub _do_verbose {
1473    my $self = shift;
1474
1475    my $level = $_[-1] =~ /^\d$/ ? pop : 1;
1476
1477    if (($self->{Config}{Verbose} && $level == 1)
1478      || ($self->{Config}{Verbose} == 2 && $level == 2)) {
1479        print STDOUT @_;
1480    }
1481}
1482
1483sub _debug {
1484    my $self = shift;
1485
1486    if ($self->{Config}{Debug}) {
1487        pop and my $no_wait = 1 if $_[-1] eq 'no_wait';
1488        warn @_;
1489        warn "Press [enter] to continue...\n"
1490          and <STDIN> unless $no_wait;
1491    }
1492}
1493
14941;
1495__DATA__
1496
1497# argument conversion
1498-
1499NAME                  module_name
1500DISTNAME              dist_name
1501ABSTRACT              dist_abstract
1502AUTHOR                dist_author
1503VERSION               dist_version
1504VERSION_FROM          dist_version_from
1505PREREQ_PM             requires
1506PL_FILES              PL_files
1507PM                    pm_files
1508MAN1PODS              pod_files
1509XS                    xs_files
1510INC                   include_dirs
1511INSTALLDIRS           installdirs
1512DESTDIR               destdir
1513CCFLAGS               extra_compiler_flags
1514EXTRA_META            meta_add
1515SIGN                  sign
1516LICENSE               license
1517clean.FILES           @add_to_cleanup
1518
1519# default arguments
1520-
1521#build_requires       HASH
1522#recommends           HASH
1523#conflicts            HASH
1524license               unknown
1525create_readme         1
1526create_makefile_pl    traditional
1527
1528# sorting order
1529-
1530module_name
1531dist_name
1532dist_abstract
1533dist_author
1534dist_version
1535dist_version_from
1536requires
1537build_requires
1538recommends
1539conflicts
1540PL_files
1541pm_files
1542pod_files
1543xs_files
1544include_dirs
1545installdirs
1546destdir
1547add_to_cleanup
1548extra_compiler_flags
1549meta_add
1550sign
1551license
1552create_readme
1553create_makefile_pl
1554
1555# begin code
1556-
1557use Module::Build;
1558
1559$MAKECODE
1560
1561my $build = Module::Build->new
1562$INDENT(
1563# end code
1564-
1565$INDENT);
1566
1567$build->create_build_script;
1568
1569$MAKECODE
1570
1571__END__
1572
1573=head1 NAME
1574
1575Module::Build::Convert - Makefile.PL to Build.PL converter
1576
1577=head1 SYNOPSIS
1578
1579 use Module::Build::Convert;
1580
1581 # example arguments (empty %args is sufficient too)
1582 %args = (Path => '/path/to/perl/distribution(s)',
1583          Verbose => 2,
1584          Use_Native_Order => 1,
1585          Len_Indent => 4);
1586
1587 $make = Module::Build::Convert->new(%args);
1588 $make->convert;
1589
1590=head1 DESCRIPTION
1591
1592C<ExtUtils::MakeMaker> has been a de-facto standard for the common distribution of Perl
1593modules; C<Module::Build> is expected to supersede C<ExtUtils::MakeMaker> in some time
1594(part of the Perl core as of 5.9.4).
1595
1596The transition takes place slowly, as the converting process manually achieved
1597is yet an uncommon practice. The Module::Build::Convert F<Makefile.PL> parser is
1598intended to ease the transition process.
1599
1600=head1 CONSTRUCTOR
1601
1602=head2 new
1603
1604Options:
1605
1606=over 4
1607
1608=item * C<Path>
1609
1610Path to a Perl distribution. May point to a single distribution
1611directory or to one containing more than one distribution.
1612Default: C<''>
1613
1614=item * C<Makefile_PL>
1615
1616Filename of the Makefile script. Default: F<Makefile.PL>
1617
1618=item * C<Build_PL>
1619
1620Filename of the Build script. Default: F<Build.PL>
1621
1622=item * C<MANIFEST>
1623
1624Filename of the MANIFEST file. Default: F<MANIFEST>
1625
1626=item * C<RC>
1627
1628Filename of the RC file. Default: F<.make2buildrc>
1629
1630=item * C<Dont_Overwrite_Auto>
1631
1632If a Build.PL already exists, output a notification and ask whether it
1633should be overwritten.
1634Default: 1
1635
1636=item * C<Create_RC>
1637
1638Create a RC file in the homedir of the current user.
1639Default: 0
1640
1641=item * C<Parse_PPI>
1642
1643Parse the Makefile.PL in the L<PPI> Parser mode.
1644Default: 0
1645
1646=item * C<Exec_Makefile>
1647
1648Execute the Makefile.PL via C<'do Makefile.PL'>.
1649Default: 0
1650
1651=item * C<Verbose>
1652
1653Verbose mode. If set to 1, overridden defaults and skipped arguments
1654are printed while converting; if set to 2, output of C<Verbose = 1> and
1655created Build script will be printed. May be set via the make2build
1656switches C<-v> (mode 1) and C<-vv> (mode 2). Default: 0
1657
1658=item * C<Debug>
1659
1660Rudimentary debug facility for examining the parsing process.
1661Default: 0
1662
1663=item * C<Process_Code>
1664
1665Process code embedded within the arguments list.
1666Default: 0
1667
1668=item * C<Use_Native_Order>
1669
1670Native sorting order. If set to 1, the native sorting order of
1671the Makefile arguments will be tried to preserve; it's equal to
1672using the make2build switch C<-n>. Default: 0
1673
1674=item * C<Len_Indent>
1675
1676Indentation (character width). May be set via the make2build
1677switch C<-l>. Default: 3
1678
1679=item * C<DD_Indent>
1680
1681C<Data::Dumper> indendation mode. Mode 0 will be disregarded in favor
1682of 2. Default: 2
1683
1684=item * C<DD_Sortkeys>
1685
1686C<Data::Dumper> sort keys. Default: 1
1687
1688=back
1689
1690=head1 METHODS
1691
1692=head2 convert
1693
1694Parses the F<Makefile.PL>'s C<WriteMakefile()> arguments and converts them
1695to C<Module::Build> equivalents; subsequently the according F<Build.PL>
1696is created. Takes no arguments.
1697
1698=head1 DATA SECTION
1699
1700=head2 Argument conversion
1701
1702C<ExtUtils::MakeMaker> arguments followed by their C<Module::Build> equivalents.
1703Converted data structures preserve their native structure,
1704that is, C<HASH> -> C<HASH>, etc.
1705
1706 NAME                  module_name
1707 DISTNAME              dist_name
1708 ABSTRACT              dist_abstract
1709 AUTHOR                dist_author
1710 VERSION               dist_version
1711 VERSION_FROM          dist_version_from
1712 PREREQ_PM             requires
1713 PL_FILES              PL_files
1714 PM                    pm_files
1715 MAN1PODS              pod_files
1716 XS                    xs_files
1717 INC                   include_dirs
1718 INSTALLDIRS           installdirs
1719 DESTDIR               destdir
1720 CCFLAGS               extra_compiler_flags
1721 EXTRA_META            meta_add
1722 SIGN                  sign
1723 LICENSE               license
1724 clean.FILES           @add_to_cleanup
1725
1726=head2 Default arguments
1727
1728C<Module::Build> default arguments may be specified as key/value pairs.
1729Arguments attached to multidimensional structures are unsupported.
1730
1731 #build_requires       HASH
1732 #recommends           HASH
1733 #conflicts            HASH
1734 license               unknown
1735 create_readme         1
1736 create_makefile_pl    traditional
1737
1738Value may be either a string or of type C<SCALAR, ARRAY, HASH>.
1739
1740=head2 Sorting order
1741
1742C<Module::Build> arguments are sorted as enlisted herein. Additional arguments,
1743that don't occur herein, are lower prioritized and will be inserted in
1744unsorted order after preceedingly sorted arguments.
1745
1746 module_name
1747 dist_name
1748 dist_abstract
1749 dist_author
1750 dist_version
1751 dist_version_from
1752 requires
1753 build_requires
1754 recommends
1755 conflicts
1756 PL_files
1757 pm_files
1758 pod_files
1759 xs_files
1760 include_dirs
1761 installdirs
1762 destdir
1763 add_to_cleanup
1764 extra_compiler_flags
1765 meta_add
1766 sign
1767 license
1768 create_readme
1769 create_makefile_pl
1770
1771=head2 Begin code
1772
1773Code that preceeds converted C<Module::Build> arguments.
1774
1775 use strict;
1776 use warnings;
1777
1778 use Module::Build;
1779
1780 $MAKECODE
1781
1782 my $b = Module::Build->new
1783 $INDENT(
1784
1785=head2 End code
1786
1787Code that follows converted C<Module::Build> arguments.
1788
1789 $INDENT);
1790
1791 $b->create_build_script;
1792
1793 $MAKECODE
1794
1795=head1 INTERNALS
1796
1797=head2 co-opting C<WriteMakefile()>
1798
1799This behavior is no longer the default way to receive WriteMakefile()'s
1800arguments; the Makefile.PL is now statically parsed unless one forces
1801manually the co-opting of WriteMakefile().
1802
1803In order to convert arguments, a typeglob from C<WriteMakefile()> to an
1804internal sub will be set; subsequently Makefile.PL will be executed and the
1805arguments are then accessible to the internal sub.
1806
1807=head2 Data::Dumper
1808
1809Converted C<ExtUtils::MakeMaker> arguments will be dumped by
1810C<Data::Dumper's> C<Dump()> and are then furtherly processed.
1811
1812=head1 BUGS & CAVEATS
1813
1814C<Module::Build::Convert> should be considered experimental as the parsing
1815of the Makefile.PL doesn't necessarily return valid arguments, especially for
1816Makefiles with bad or even worse, missing intendation.
1817
1818The parsing process may sometimes hang with or without warnings in such cases.
1819Debugging by using the appropriate option/switch (see CONSTRUCTOR/new) may reveal
1820the root cause.
1821
1822=head1 SEE ALSO
1823
1824L<http://www.makemaker.org>, L<ExtUtils::MakeMaker>, L<Module::Build>,
1825L<http://www.makemaker.org/wiki/index.cgi?ModuleBuildConversionGuide>
1826
1827=head1 AUTHOR
1828
1829Steven Schubiger <schubiger@cpan.org>
1830
1831=head1 LICENSE
1832
1833This program is free software; you may redistribute it and/or
1834modify it under the same terms as Perl itself.
1835
1836See L<http://www.perl.com/perl/misc/Artistic.html>
1837
1838=cut
1839