File Coverage

blib/lib/Module/Build/Convert.pm

Criterion	Covered	Total	%
statement	37	39	94.8
branch			n/a
condition			n/a
subroutine	13	13	100.0
pod			n/a
total	50	52	96.1

package Module::Build::Convert;

use 5.005;
use strict;
use warnings;

use Carp ();
use Cwd ();
use Data::Dumper ();
use ExtUtils::MakeMaker ();
use File::Basename ();
use File::HomeDir ();
use File::Slurp ();
use File::Spec ();
use IO::File ();
use IO::Prompt ();
use PPI ();
use Text::Balanced ();

our $VERSION = '0.49';

use constant LEADCHAR => '* ';

sub new {
    my ($self, %params) = @_;
    my $class = ref($self) || $self;

    my $obj = bless { Config => { Path                => $params{Path}                || '',
                                  Makefile_PL         => $params{Makefile_PL}         || 'Makefile.PL',
                                  Build_PL            => $params{Build_PL}            || 'Build.PL',
                                  MANIFEST            => $params{MANIFEST}            || 'MANIFEST',
                                  RC                  => $params{RC}                  || '.make2buildrc',
                                  Dont_Overwrite_Auto => $params{Dont_Overwrite_Auto} || 1,
                                  Create_RC           => $params{Create_RC}           || 0,
                                  Parse_PPI           => $params{Parse_PPI}           || 0,
                                  Exec_Makefile       => $params{Exec_Makefile}       || 0,
                                  Verbose             => $params{Verbose}             || 0,
                                  Debug               => $params{Debug}               || 0,
                                  Process_Code        => $params{Process_Code}        || 0,
                                  Use_Native_Order    => $params{Use_Native_Order}    || 0,
                                  Len_Indent          => $params{Len_Indent}          || 3,
                                  DD_Indent           => $params{DD_Indent}           || 2,
                                  DD_Sortkeys         => $params{DD_Sortkeys}         || 1 }}, $class;

    $obj->{Config}{RC} = File::Spec->catfile(File::HomeDir::home(), $obj->{Config}{RC});

    # Save length of filename for creating underlined title in output
    $obj->{Config}{Build_PL_Length} = length($obj->{Config}{Build_PL});

    return $obj;
}

sub convert {
    my $self = shift;

    unless ($self->{Config}{reinit} || @{$self->{dirs}||[]}) {
        if ($self->{Config}{Path}) {
            if (-f $self->{Config}{Path}) {
                my ($basename, $dirname)     = File::Basename::fileparse($self->{Config}{Path});
                $self->{Config}{Makefile_PL} = $basename;
                $self->{Config}{Path}        = $dirname;
            }

            opendir(my $dh, $self->{Config}{Path}) or die "Can't open $self->{Config}{Path}\n";
            @{$self->{dirs}} = grep { /[\w\-]+[\d\.]+/
              and -d File::Spec->catfile($self->{Config}{Path}, $_) } sort readdir $dh;

            unless (@{$self->{dirs}}) {
                unshift @{$self->{dirs}}, $self->{Config}{Path};
                $self->{have_single_dir} = 1;
            }
        } else {
            unshift @{$self->{dirs}}, '.';
            $self->{have_single_dir} = 1;
        }
    }

    my $Makefile_PL = File::Basename::basename($self->{Config}{Makefile_PL});
    my $Build_PL    = File::Basename::basename($self->{Config}{Build_PL});
    my $MANIFEST    = File::Basename::basename($self->{Config}{MANIFEST});

    unshift @{$self->{dirs}}, $self->{current_dir} if $self->{Config}{reinit};

    $self->{show_summary} = 1 if @{$self->{dirs}} > 1;

    while (my $dir = shift @{$self->{dirs}}) {
        $self->{current_dir} = $dir;

        %{$self->{make_args}} = ();

        unless ($self->{have_single_dir}) {
            local $" = "\n";
            $self->_do_verbose(<{Config}{reinit};
Remaining dists:
----------------
$dir
@{$self->{dirs}}

TITLE
        }

        $dir = File::Spec->catfile($self->{Config}{Path}, $dir) if !$self->{have_single_dir};
        $self->{Config}{Makefile_PL} = File::Spec->catfile($dir, $Makefile_PL);
        $self->{Config}{Build_PL}    = File::Spec->catfile($dir, $Build_PL);
        $self->{Config}{MANIFEST}    = File::Spec->catfile($dir, $MANIFEST);

        unless ($self->{Config}{reinit}) {
            no warnings 'uninitialized';

            $self->_do_verbose(LEADCHAR."Converting $self->{Config}{Makefile_PL} -> $self->{Config}{Build_PL}\n");

            my $skip_msg  = LEADCHAR."Skipping $self->{Config}{Path}\n";
               $skip_msg .= "\n" if @{$self->{dirs}};

            $self->_create_rcfile if $self->{Config}{Create_RC};

            if (!$self->_exists_overwrite || !$self->_makefile_ok) {
                $self->_do_verbose($skip_msg);
                next;
            }

            $self->_get_data;
        }

        $self->_extract_args;
        $self->_register_summary;
        $self->_convert;
        $self->_dump;
        $self->_write;
        $self->_add_to_manifest if -e $self->{Config}{MANIFEST};
    }

    $self->_show_summary if $self->{show_summary};
}

sub _exists_overwrite {
    my $self = shift;

    if (-e $self->{Config}{Build_PL}) {
        print "$self->{current_dir}:\n"
          if $self->{show_summary} && !$self->{Config}{Verbose};

        print "\n" if $self->{Config}{Verbose};
        print 'A Build.PL exists already';

        if ($self->{Config}{Dont_Overwrite_Auto}) {
            print ".\n";
            my $input_ok = IO::Prompt::prompt -yn, 'Shall I overwrite it? ';

            if (!$input_ok) {
                print "Skipped...\n";
                print "\n" if $self->{Config}{Verbose};
                push @{$self->{summary}{skipped}}, $self->{current_dir};
                return 0;
            } else {
                print "\n" if $self->{Config}{Verbose};
            }
        } else {
            print ", continuing...\n";
        }
    }

    return 1;
}

sub _create_rcfile {
    my $self = shift;

    my $rcfile = $self->{Config}{RC};

    if (-e $rcfile && !-z $rcfile && File::Slurp::read_file($rcfile) =~ /\w+/) {
        die "$rcfile exists\n";
    } else {
        my $data = $self->_parse_data('create_rc');
        my $fh = IO::File->new($rcfile, '>') or die "Can't open $rcfile: $!\n";
        print {$fh} $data;
        $fh->close;
        print LEADCHAR."Created $rcfile\n";
        exit;
    }
}

sub _makefile_ok {
    my $self = shift;

    my $makefile;

    if (-e $self->{Config}{Makefile_PL}) {
        $makefile = File::Slurp::read_file($self->{Config}{Makefile_PL});
    } else {
        die 'No ', File::Basename::basename($self->{Config}{Makefile_PL}), ' found at ',
          $self->{Config}{Path}
            ? File::Basename::dirname($self->{Config}{Makefile_PL})
            : Cwd::cwd(), "\n";
    }

    my $max_failures = 2;
    my ($failed, @failures);

    if ($makefile =~ /use\s+inc::Module::Install/) {
        push @failures, "Unsuitable Makefile: Module::Install being used";
        $failed++;
    }

    unless ($makefile =~ /WriteMakefile\s*\(/s) {
        push @failures, "Unsuitable Makefile: doesn't consist of WriteMakefile()";
        $failed++;
    }

    if (!$failed && $makefile =~ /WriteMakefile\(\s*%\w+.*\s*\)/s && !$self->{Config}{Exec_Makefile}) {
        $self->_do_verbose(LEADCHAR."Indirect arguments to WriteMakefile() via hash detected, setting executing mode\n");
        $self->{Config}{Exec_Makefile} = 1;
    }

    if ($failed) {
        my ($i, $output);

        $output .= "\n" if $self->{Config}{Verbose} && @{$self->{dirs}};
        $output .= join '', map { $i++; "[$i] $_\n" } @failures;
        $output .= "$self->{current_dir}: Failed $failed/$max_failures.\n";
        $output .= "\n" if $self->{Config}{Verbose} && @{$self->{dirs}};

        print $output;

        push @{$self->{summary}{failed}}, $self->{current_dir};

        return 0;
    }

    return 1;
}

sub _get_data {
    my $self = shift;
    my @data = $self->_parse_data;

    $self->{Data}{table}           = { split /\s+/, shift @data };
    $self->{Data}{default_args}    = { split /\s+/, shift @data };
    $self->{Data}{sort_order}      = [ split /\s+/, shift @data ];
   ($self->{Data}{begin},
    $self->{Data}{end})            =                      @data;

    # allow for embedded values such as clean => { FILES => '' }
    foreach my $arg (keys %{$self->{Data}{table}}) {
        if (index($arg, '.') > 0) {
            my @path = split /\./, $arg;
            my $value = $self->{Data}{table}->{$arg};
            my $current = $self->{Data}{table};
            while (@path) {
                my $key = shift @path;
                $current->{$key} ||= @path ? {} : $value;
                $current = $current->{$key};
            }
        }
    }
}

sub _parse_data {
    my $self = shift;
    my $create_rc = 1 if (shift || 'undef') eq 'create_rc';

    my ($data, @data_parsed);
    my $rcfile = $self->{Config}{RC};

    if (-e $rcfile && !-z $rcfile && File::Slurp::read_file($rcfile) =~ /\w+/) {
        $data = File::Slurp::read_file($rcfile);
    } else {
        if (!defined $self->{DATA}) {
            local $/ = '__END__';
            $data = ;
            chomp $data;
	    $self->{DATA} = $data;
	} else {
	    $data = $self->{DATA};
	}
    }

    unless ($create_rc) {
        @data_parsed = do {               #  # description
            split /#\s+.*\s+?-\n/, $data; #  -
        };
    }

    unless ($create_rc) {
        # superfluosity
        shift @data_parsed;
        chomp $data_parsed[-1];

        foreach my $line (split /\n/, $data_parsed[0]) {
            next unless $line;

            if ($line =~ /^#/) {
                my ($arg) = split /\s+/, $line;
                $self->{disabled}{substr($arg, 1)} = 1;
            }
        }

        @data_parsed = map { 1 while s/^#.*?\n(.*)$/$1/gs; $_ } @data_parsed;
    }

    return $create_rc ? $data : @data_parsed;
}

sub _extract_args {
    my $self = shift;

    if ($self->{Config}{Exec_Makefile}) {
        $self->_do_verbose(LEADCHAR."Executing $self->{Config}{Makefile_PL}\n");
        $self->_run_makefile;
    } else {
        if ($self->{Config}{Parse_PPI}) {
            $self->_parse_makefile_ppi;
        } else {
            $self->_parse_makefile;
        }
    }
}

sub _register_summary {
    my $self = shift;

    push @{$self->{summary}->{succeeded}}, $self->{current_dir};

    push @{$self->{summary}{$self->{Config}{Exec_Makefile} ? 'method_execute' : 'method_parse'}},
           $self->{current_dir};

    $self->{Config}{Exec_Makefile} =
           $self->{Config}{reinit} = 0;
}

sub _run_makefile {
    my $self = shift;
    no warnings 'redefine';

    *ExtUtils::MakeMaker::WriteMakefile = sub {
      %{$self->{make_args}{args}} = @{$self->{make_args_arr}} = @_;
    };

    # beware, do '' overwrites existing globals
    $self->_save_globals;
    do $self->{Config}{Makefile_PL};
    $self->_restore_globals;
}

sub _save_globals {
    my $self = shift;
    my @vars;

    my $makefile = File::Slurp::read_file($self->{Config}{Makefile_PL});
    $makefile =~ s/.*WriteMakefile\(\s*?(.*?)\);.*/$1/s;

    while ($makefile =~ s/\$(\w+)//) {
        push @vars, $1 if defined ${$1};
    }

    no strict 'refs';
    foreach my $var (@vars) {
        ${__PACKAGE__.'::globals'}{$var} = ${$var};
    }
}

sub _restore_globals {
    my $self = shift;
    no strict 'refs';

    while (my ($var, $value) = each %{__PACKAGE__.'::globals'}) {
        ${__PACKAGE__.'::'.$var} = $value;
    }
    undef %{__PACKAGE__.'::globals'};
}

sub _parse_makefile_ppi {
    my $self = shift;

    $self->_parse_init;

    ($self->{parse}{makefile}, $self->{make_code}{begin}, $self->{make_code}{end}) = $self->_read_makefile;

    $self->_debug(LEADCHAR."Entering parse\n\n", 'no_wait');

    my $doc = PPI::Document->new(\$self->{parse}{makefile});

    my @elements = $doc->children;
    my @tokens   = $elements[0]->tokens;

    $self->_scrub_ternary(\@tokens);

    my ($keyword, %have, @items, %seen, $structure_ended, $type);

    for (my $i = 0; $i < @tokens; $i++) {
        my %token = (curr => sub {
                                      my $c = $i;
                                      while (!$tokens[$c]->significant) { $c++ }
                                      $i = $c;
                                      return $tokens[$c];
                                 },

                     next => sub {
                                      my $iter      = $_[0] ? $_[0] : 1;
                                      my ($c, $pos) = ($i + 1, 0);

                                      while ($c < @tokens) {
                                          $pos++ if $tokens[$c]->significant;
                                          last if $pos == $iter;
                                          $c++;
                                      }

                                      return $tokens[$c];
                                 },

                     last => sub {
                                      my $iter      = $_[0] ? $_[0] : 1;
                                      my ($c, $pos) = ($i, 0);

                                      $c-- if $c >= 1;

                                      while ($c > 0) {
                                          $pos++ if $tokens[$c]->significant;
                                          last if $pos == $iter;
                                          $c--;
                                      }

                                      return $tokens[$c];
                                 });

        my %finalize = (string => sub { $self->{parse}{makeargs}{$keyword} = join '', @items },
                        array  => sub { $self->{parse}{makeargs}{$keyword} = [ @items      ] },
                        hash   => sub { $self->{parse}{makeargs}{$keyword} = { @items      } });

        my $token = $have{code} ? $tokens[$i] : $token{curr}->();

        if ($self->_is_quotelike($token) && !$have{code} && !$have{nested_structure} && $token{last}->(1) ne '=>') {
            $keyword = $token;
            $type    = 'string';
            next;
        } elsif ($token eq '=>' && !$have{nested_structure}) {
            next;
        }

        next if $structure_ended && $token eq ',';
        $structure_ended = 0;

        if ($token->isa('PPI::Token::Structure') && !$have{code}) {
            if ($token =~ /[\Q[{\E]/) {
                $have{nested_structure}++;

                my %assoc = ('[' => 'array',
                             '{' => 'hash');

                $type = $assoc{$token};
            } elsif ($token =~ /[\Q]}\E]/) {
                $have{nested_structure}--;
                $structure_ended = 1 unless $have{nested_structure};
            }
        }

        $structure_ended = 1 if  $token{next}->() eq ',' && !$have{code} && !$have{nested_structure};
        $have{code}      = 1 if  $token->isa('PPI::Token::Word') && $token{next}->(1) ne '=>';

        if ($have{code}) {
            my $followed_by_arrow = sub { $token eq ',' && $token{next}->(2) eq '=>' };

            my %finalize = (seen   => sub { $structure_ended = 1; $seen{code} = 1; $have{code} = 0 },
                            unseen => sub { $structure_ended = 1; $seen{code} = 0; $have{code} = 0 });

            if ($followed_by_arrow->()) {
                ($token{next}->(1) =~ /^[\Q}]\E]$/ || !$have{nested_structure})
                  ? $finalize{seen}->()
                  : $have{nested_structure}
                    ? $finalize{unseen}->()
                    : ();
            } elsif (($token eq ',' && $token{next}->(1) eq ']')
                   || $token{next}->(1) eq ']') {
                      $finalize{unseen}->();
            }
        }

        unless ($token =~ /^[\Q[]{}\E]$/ && !$have{code}) {
            next if $token eq '=>';
            next if $token eq ',' && !$have{code} && !$seen{code};

            if (defined $keyword) {
                $keyword =~ s/['"]//g;
                $token   =~ s/['"]//g unless $token =~ /^['"]\s+['"]$/ || $have{code};

                if (!$have{code} && !$structure_ended) {
                    push @items, $token;
                } else {
                    if ((@items % 2 == 1 && $type ne 'array') || !@items) {
                        push @items, $token;
                    } else {
                        $items[-1] .= $token unless $structure_ended
                                                 && $type eq 'string';
                    }
                }
            }
        }

        if ($structure_ended && @items) {
            # Obscure construct. Needed to 'serialize' the PPI tokens.
            @items = map { /(.*)/; $1 } @items;

            # Sanitize code elements within a hash.
            $items[-1] =~ s/[,\s]+$// if $type eq 'hash' && defined $items[-1];

            $finalize{$type}->();

            undef $keyword;

            $have{code} = 0;
            @items      = ();
            %seen       = ();

            $type = 'string';
        }
    }

    $self->_debug(LEADCHAR."Leaving parse\n\n", 'no_wait');

    %{$self->{make_args}{args}} = %{$self->{parse}{makeargs}};
}

sub _is_quotelike {
    my ($self, $token) = @_;

    return ($token->isa('PPI::Token::Double')
         or $token->isa('PPI::Token::Quote::Interpolate')
         or $token->isa('PPI::Token::Quote::Literal')
         or $token->isa('PPI::Token::Quote::Single')
         or $token->isa('PPI::Token::Word')) ? 1 : 0;
}

sub _scrub_ternary {
    my ($self, $tokens) = @_;

    my (%last, %have, %occurences);

    for (my $i = 0; $i < @$tokens; $i++) {
        my $token = $tokens->[$i];

        $last{comma} = $i if $token eq ',' && !$have{'?'};

        unless ($have{ternary}) {
            $occurences{subsequent}{'('}++ if $token eq '(';
            $occurences{subsequent}{')'}++ if $token eq ')';
        }

        $have{'?'} = 1 if $token eq '?';
        $have{':'} = 1 if $token eq ':';

        $have{ternary} = 1 if $have{'?'} && $have{':'};

        if ($have{ternary}) {
            $occurences{'('} ||= 0;
            $occurences{')'} ||= 0;

            $occurences{'('} += $occurences{subsequent}{'('};
            $occurences{')'} += $occurences{subsequent}{')'};

            $occurences{subsequent}{'('} = 0;
            $occurences{subsequent}{')'} = 0;

            $occurences{'('}++ if $token eq '(';
            $occurences{')'}++ if $token eq ')';

            $have{parentheses} = 1 if $occurences{'('} || $occurences{')'};
            $have{comma}       = 1 if $token eq ',';

            if ($occurences{'('} == $occurences{')'} && $have{parentheses} && $have{comma}) {
                $i++ while $tokens->[$i] ne ',';
                splice(@$tokens, $last{comma}, $i-$last{comma});

                @have{qw(? : comma parentheses ternary)} = (0,0,0,0,0);
                @occurences{qw{( )}}                     = (0,0);

                $i = 0; redo;
            }
        }
    }
}

sub _parse_makefile {
    my $self = shift;

    $self->_parse_init;

    ($self->{parse}{makefile}, $self->{make_code}{begin}, $self->{make_code}{end}) = $self->_read_makefile;
    my ($found_string, $found_array, $found_hash) = $self->_parse_regexps;

    $self->_debug(LEADCHAR."Entering parse\n\n", 'no_wait');

    while ($self->{parse}{makefile}) {
        $self->{parse}{makefile} .= "\n"
          unless $self->{parse}{makefile} =~ /\n$/s;

        # process string
        if ($self->{parse}{makefile} =~ s/$found_string//) {
            $self->_parse_process_string($1,$2,$3);
            $self->_parse_register_comment;
            $self->_debug($self->_debug_string_text);
        # process array
        } elsif ($self->{parse}{makefile} =~ s/$found_array//s) {
            $self->_parse_process_array($1,$2,$3);
            $self->_parse_register_comment;
            $self->_debug($self->_debug_array_text);
        # process hash
        } elsif ($self->{parse}{makefile} =~ s/$found_hash//s) {
            $self->_parse_process_hash($1,$2,$3);
            $self->_parse_register_comment;
            $self->_debug($self->_debug_hash_text);
        # process "code"
        } else {
            chomp $self->{parse}{makefile};

            $self->_parse_process_code;
            $self->_parse_catch_trapped_loop;

            if ($self->{Config}{Process_Code}) {
                $self->_parse_substitute_makeargs;
                $self->_parse_append_makecode;
                $self->_debug($self->_debug_code_text);
            }
        }

        $self->{parse}{makefile} = ''
          unless $self->{parse}{makefile} =~ /\w/;
    }

    $self->_debug(LEADCHAR."Leaving parse\n\n", 'no_wait');

    %{$self->{make_args}{args}} = %{$self->{parse}{makeargs}};
}

sub _parse_init {
    my $self = shift;

    %{$self->{make_code}} = ();
    %{$self->{parse}}     = ();
}

sub _parse_regexps {
    my $self = shift;

    my $found_string = qr/^
                            \s*
                            ['"]? (\w+) ['"]?
                            \s* => \s* (?![ \{ \[ ])
                            ['"]? ([\$ \@ \% \< \> \( \) \\ \/ \- \: \. \w]+.*?) ['"]?
                            ,? ([^\n]+ \# \s+ \w+ .*?)? \n
                       /sx;
    my $found_array  = qr/^
                            \s*
                            ['"]? (\w+) ['"]?
                            \s* => \s*
                            \[ \s* (.*?) \s* \]
                            ,? ([^\n]+ \# \s+ \w+ .*?)? \n
                       /sx;
    my $found_hash   = qr/^
                            \s*
                            ['"]? (\w+) ['"]?
                            \s* => \s*
                            \{ \s* (.*?) \s*? \}
                            ,? ([^\n]+ \# \s+ \w+ .*?)? \n
                       /sx;

    return ($found_string, $found_array, $found_hash);
}

sub _parse_process_string {
    my ($self, $arg, $value, $comment) = @_;

    $value   ||= '';
    $comment ||= '';

    $value =~ s/^['"]//;
    $value =~ s/['"]$//;

    $self->{parse}{makeargs}{$arg} = $value;
    push @{$self->{parse}{histargs}}, $arg;

    $self->{parse}{arg}     = $arg;
    $self->{parse}{value}   = $value;
    $self->{parse}{comment} = $comment;
}

sub _parse_process_array {
    my ($self, $arg, $values, $comment) = @_;

    $values  ||= '';
    $comment ||= '';

    $self->{parse}{makeargs}{$arg} = [ map { tr/['",]//d; $_ } split /,\s*/, $values ];
    push @{$self->{parse}{histargs}}, $arg;

    $self->{parse}{arg}     = $arg;
    $self->{parse}{values}  = $self->{parse}{makeargs}{$arg},
    $self->{parse}{comment} = $comment;
}


sub _parse_process_hash {
    my ($self, $arg, $values, $comment) = @_;

    $values  ||= '';
    $comment ||= '';

    my @values_debug = split /,\s*/, $values;
    my @values;

    foreach my $value (@values_debug) {
        push @values, map { tr/['",]//d; $_ } split /\s*=>\s*/, $value;
    }

    @values_debug = map { "$_\n        " } @values_debug;

    $self->{parse}{makeargs}{$arg} = { @values };
    push @{$self->{parse}{histargs}}, $arg;

    $self->{parse}{arg}     = $arg;
    $self->{parse}{values}  = \@values_debug,
    $self->{parse}{comment} = $comment;
}

sub _parse_process_code {
    my $self = shift;

    my ($debug_desc, $retval);

    my @code     = Text::Balanced::extract_codeblock($self->{parse}{makefile}, '()');
    my @variable = Text::Balanced::extract_variable($self->{parse}{makefile});

    # [0] extracted
    # [1] remainder

    if ($code[0]) {
        $code[0] =~ s/^\s*\(\s*//s;
        $code[0] =~ s/\s*\)\s*$//s;

        $code[0] =~ s/\s*=>\s*/\ =>\ /gs;
        $code[1] =~ s/^\s*,//;

        $self->{parse}{makefile} = $code[1];
        $retval                  = $code[0];

        $debug_desc = 'code';
    } elsif ($variable[0]) {
        $self->{parse}{makefile} = $variable[1];
        $retval                  = $variable[0];

        $debug_desc = 'variable';
    } elsif ($self->{parse}{makefile} =~ /\#/) {
        my $comment;

        $self->{parse}{makefile} .= "\n"
          unless $self->{parse}{makefile} =~ /\n$/s;

        while ($self->{parse}{makefile} =~ /\G(\s*?\#.*?\n)/cgs) {
            $comment .= $1;
        }

        $comment ||= '';

        my $quoted_comment = quotemeta $comment;
        $self->{parse}{makefile} =~ s/$quoted_comment//s;

        my @comment;

        @comment = split /\n/,   $comment;
        @comment = grep { /\#/ } @comment;

        foreach $comment (@comment) {
            $comment =~ s/^\s*?(\#.*)$/$1/gm;
            chomp $comment;
        }

        $retval     = \@comment;
        $debug_desc = 'comment';
    } else {
        $retval     = '';
        $debug_desc = 'unclassified';
    }

    $self->{parse}{debug_desc} = $debug_desc;
    $self->{parse}{makecode}   = $retval;
}

sub _parse_catch_trapped_loop {
    my $self = shift;

    no warnings 'uninitialized';

    $self->{parse}{trapped_loop}{$self->{parse}{makecode}}++
      if $self->{parse}{makecode} eq $self->{makecode_prev};

    if ($self->{parse}{trapped_loop}{$self->{parse}{makecode}} > 1) {
        $self->{Config}{Exec_Makefile} = 1;
        $self->{Config}{reinit}        = 1;
        $self->convert;
        exit;
    }

    $self->{makecode_prev} = $self->{parse}{makecode};
}

sub _parse_substitute_makeargs {
    my $self = shift;

    $self->{parse}{makecode} ||= '';

    foreach my $make (keys %{$self->{Data}{table}}) {
        if ($self->{parse}{makecode} =~ /\b$make\b/s) {
            $self->{parse}{makecode} =~ s/$make/$self->{Data}{table}{$make}/;
       }
    }
}

sub _parse_append_makecode {
    my $self = shift;

    unless (@{$self->{parse}{histargs}||[]}) {
        push @{$self->{make_code}{args}{begin}}, $self->{parse}{makecode};
    } else {
        pop @{$self->{parse}{histargs}}
          until $self->{Data}{table}{$self->{parse}{histargs}->[-1]};

        push @{$self->{make_code}{args}{$self->{Data}{table}{$self->{parse}{histargs}->[-1]}}},
               $self->{parse}{makecode};
    }
}

sub _parse_register_comment {
    my $self = shift;

    my $arg     = $self->{parse}{arg};
    my $comment = $self->{parse}{comment};

    if (defined($comment) && defined($self->{Data}{table}{$arg})) {
        $self->{make_comments}{$self->{Data}{table}{$arg}} = $comment;
    }
}

sub _debug_string_text {
    my $self = shift;

    my $output = <
Found string ''
+++++++++++++++
\$arg: $self->{parse}{arg}
\$value: $self->{parse}{value}
\$comment: $self->{parse}{comment}
\$remaining args:
$self->{parse}{makefile}

EOT
    return $output;
}

sub _debug_array_text {
    my $self = shift;

    my @values = @{$self->{parse}{values}};

    my $output = <
Found array []
++++++++++++++
\$arg: $self->{parse}{arg}
\$values: @values
\$comment: $self->{parse}{comment}
\$remaining args:
$self->{parse}{makefile}

EOT
    return $output;
}

sub _debug_hash_text {
    my $self = shift;

    my $output = <
Found hash {}
+++++++++++++
\$key: $self->{parse}{arg}
\$values: @{$self->{parse}{values}}
\$comment: $self->{parse}{comment}
\$remaining args:
$self->{parse}{makefile}
EOT
    return $output;
}

sub _debug_code_text {
    my $self = shift;

    my @args;

    if (ref $self->{parse}{makecode} eq 'ARRAY') {
        push @args, @{$self->{parse}{makecode}};
    } else {
        push @args, $self->{parse}{makecode};
    }

    @args = map { "\n$_" } @args if @args > 1;

    my $output = <
Found code &
++++++++++++
$self->{parse}{debug_desc}: @args
remaining args:
$self->{parse}{makefile}

EOT
    return $output;
}

sub _read_makefile {
    my $self = shift;

    my $makefile = File::Slurp::read_file($self->{Config}{Makefile_PL});
    $makefile =~ s/^(.*?)\&?WriteMakefile\s*?\(\s*(.*?)\s*\)\s*?;(.*)$/$2/s;

    my $makecode_begin = $1;
    my $makecode_end   = $3;
    $makecode_begin    =~ s/\s*([\#\w]+.*)\s*/$1/s;
    $makecode_end      =~ s/\s*([\#\w]+.*)\s*/$1/s;

    return ($makefile, $makecode_begin, $makecode_end);
}

sub _convert {
    my $self = shift;

    $self->_insert_args;

    foreach my $arg (keys %{$self->{make_args}{args}}) {
        if ($self->{disabled}{$arg}) {
            $self->_do_verbose(LEADCHAR."$arg disabled, skipping\n");
            next;
        }
        unless ($self->{Data}{table}->{$arg}) {
            $self->_do_verbose(LEADCHAR."$arg unknown, skipping\n");
            next;
        }
        if (ref $self->{make_args}{args}{$arg} eq 'HASH') {
            if (ref $self->{Data}{table}->{$arg} eq 'HASH') {
                # embedded structure
                my @iterators = ();
                my $current = $self->{Data}{table}->{$arg};
                my $value = $self->{make_args}{args}{$arg};
                push @iterators, _iterator($current, $value, keys %$current);
                while (@iterators) {
                    my $iterator = shift @iterators;
                    while (($current, $value) = $iterator->()) {
                        if (ref $current eq 'HASH') {
                            push @iterators, _iterator($current, $value, keys %$current);
                        } else {
                            if (substr($current, 0, 1) eq '@') {
                                my $attr = substr($current, 1);
                                if (ref $value eq 'ARRAY') {
                                    push @{$self->{build_args}}, { $attr => $value };
                                } else {
                                    push @{$self->{build_args}}, { $attr => [ split ' ', $value ] };
                                }
                            } else {
                                push @{$self->{build_args}}, { $current => $value };
                            }
                        }
                    }
                }
            } else {
                # flat structure
                my %tmphash;
                %{$tmphash{$self->{Data}{table}->{$arg}}} =
                  map { $_ => $self->{make_args}{args}{$arg}{$_} } keys %{$self->{make_args}{args}{$arg}};
                push @{$self->{build_args}}, \%tmphash;
            }
        } elsif (ref $self->{make_args}{args}{$arg} eq 'ARRAY') {
            push @{$self->{build_args}}, { $self->{Data}{table}->{$arg} => $self->{make_args}{args}{$arg} };
        } elsif (ref $self->{make_args}{args}{$arg} eq '') {
            push @{$self->{build_args}}, { $self->{Data}{table}->{$arg} => $self->{make_args}{args}{$arg} };
        } else { # unknown type
            warn "$arg - unknown type of argument\n";
        }
    }

    $self->_sort_args if @{$self->{Data}{sort_order}};
}

sub _insert_args {
    my ($self, $make) = @_;

    my @insert_args;
    my %build = map { $self->{Data}{table}{$_} => $_ } keys %{$self->{Data}{table}};

    while (my ($arg, $value) = each %{$self->{Data}{default_args}}) {
        no warnings 'uninitialized';

        if (exists $self->{make_args}{args}{$build{$arg}}) {
            $self->_do_verbose(LEADCHAR."Overriding default \'$arg => $value\'\n");
            next;
        }

        $value = {} if $value eq 'HASH';
        $value = [] if $value eq 'ARRAY';
        $value = '' if $value eq 'SCALAR' && $value !~ /\d+/;

        push @insert_args, { $arg => $value };
    }

    @{$self->{build_args}} = @insert_args;
}

sub _iterator {
    my ($build, $make) = (shift, shift);
    my @queue = @_;

    return sub {
        my $key = shift @queue || return;
        return $build->{$key}, $make->{$key};
    }
}

sub _sort_args {
    my $self = shift;

    my %native_sortorder;

    if ($self->{Config}{Use_Native_Order}) {
        no warnings 'uninitialized';

        # Mapping an incremental value to the arguments (keys) in the
        # order they appear.
        for (my ($i,$s) = 0; $s < @{$self->{make_args_arr}}; $s++) {
            # Skipping values
            next unless $s % 2 == 0;
            # Populating table with according M::B arguments and counter
            $native_sortorder{$self->{Data}{table}{$self->{make_args_arr}[$s]}} = $i
              if exists $self->{Data}{table}{$self->{make_args_arr}[$s]};
            $i++;
        }
    }

    my %sortorder;
    {
        my %have_args = map { keys %$_ => 1 } @{$self->{build_args}};
        # Filter sort items, that we didn't receive as args,
        # and map the rest to according array indexes.
        my $i = 0;
        if ($self->{Config}{Use_Native_Order}) {
            my %slot;

            foreach my $arg (grep $have_args{$_}, @{$self->{Data}{sort_order}}) {
                # Building sorting table for existing MakeMaker arguments
                if ($native_sortorder{$arg}) {
                    $sortorder{$arg} = $native_sortorder{$arg};
                    $slot{$native_sortorder{$arg}} = 1;
                # Inject default arguments at free indexes
                } else {
                    $i++ while $slot{$i};
                    $sortorder{$arg} = $i++;
                }
            }

            # Sorting sort table ascending
            my @args = sort { $sortorder{$a} <=> $sortorder{$b} } keys %sortorder;
            $i = 0; %sortorder = map { $_ => $i++ } @args;

        } else {
            %sortorder = map {
              $_ => $i++
            } grep $have_args{$_}, @{$self->{Data}{sort_order}};
        }
    }

    my ($is_sorted, @unsorted);
    do {

        $is_sorted = 1;

          SORT: for (my $i = 0; $i < @{$self->{build_args}}; $i++) {
              my ($arg) = keys %{$self->{build_args}[$i]};

              unless (exists $sortorder{$arg}) {
                  push @unsorted, splice(@{$self->{build_args}}, $i, 1);
                  next;
              }

              if ($i != $sortorder{$arg}) {
                  $is_sorted = 0;
                  # Move element $i to pos $sortorder{$arg}
                  # and the element at $sortorder{$arg} to
                  # the end.
                  push @{$self->{build_args}},
                    splice(@{$self->{build_args}}, $sortorder{$arg}, 1,
                      splice(@{$self->{build_args}}, $i, 1));

                  last SORT;
              }
          }
    } until ($is_sorted);

    push @{$self->{build_args}}, @unsorted;
}

sub _dump {
    my $self = shift;

    $Data::Dumper::Indent    = $self->{Config}{DD_Indent} || 2;
    $Data::Dumper::Quotekeys = 0;
    $Data::Dumper::Sortkeys  = $self->{Config}{DD_Sortkeys};
    $Data::Dumper::Terse     = 1;

    my $d = Data::Dumper->new(\@{$self->{build_args}});
    $self->{buildargs_dumped} = [ $d->Dump ];
}

sub _write {
    my $self = shift;

    $self->{INDENT} = ' ' x $self->{Config}{Len_Indent};

    no warnings 'once';
    my $fh = IO::File->new($self->{Config}{Build_PL}, '>')
      or die "Can't open $self->{Config}{Build_PL}: $!\n";

    my $selold = select($fh);

    $self->_compose_header;
    $self->_write_begin;
    $self->_write_args;
    $self->_write_end;
    $fh->close;

    select($selold);

    $self->_do_verbose("\n", LEADCHAR."Conversion done\n");
    $self->_do_verbose("\n") if !$self->{have_single_dir};
}

sub _compose_header {
    my $self = shift;

    my ($comments_header, $code_header);

    my $note = '# Note: this file has been initially generated by ' . __PACKAGE__ . " $VERSION";
    my $pragmas = "use strict;\nuse warnings;\n";

    # Warnings are thrown for chomp() & regular expressions when enabled
    no warnings 'uninitialized';

    if (defined $self->{make_code}{begin} || defined $self->{make_code}{end}) {
        # Removing ExtUtils::MakeMaker dependency
        $self->_do_verbose(LEADCHAR."Removing ExtUtils::MakeMaker as dependency\n");
        $self->{make_code}{begin} =~ s/[ \t]*(?:use|require)\s+ExtUtils::MakeMaker\s*;//;

        # Mapping (prompt|Verbose) calls to Module::Build ones
        if ($self->{make_code}{begin} =~ /(?:prompt|Verbose)\s*\(/s) {
            my $regexp = qr/^(.*?=\s*)(prompt|Verbose)\s*?\(['"](.*)['"]\);$/;

            foreach my $var (qw(begin end)) {
                while ($self->{make_code}{$var} =~ /$regexp/m) {
                    my $replace = $1 . 'Module::Build->' . $2 . '("' . $3 . '");';
                    $self->{make_code}{$var} =~ s/$regexp/$replace/m;
                }
            }
        }

        # Removing Module::Build::Compat Note
        if ($self->{make_code}{begin} =~ /Module::Build::Compat/) {
            $self->_do_verbose(LEADCHAR."Removing Module::Build::Compat Note\n");
            $self->{make_code}{begin} =~ s/^\#.*Module::Build::Compat.*?\n//s;
        }

        # Removing customized MakeMaker subs
        my $has_MM_sub    = qr/sub MY::/;
        my $MM_sub_prefix = 'MY::';

        foreach my $var (qw(begin end)) {
            if ($self->{make_code}{$var} =~ $has_MM_sub) {
                foreach my $sub (_extract_sub($self->{make_code}{$var}, $MM_sub_prefix)) {
                    my $quoted_sub = quotemeta $sub;
                    my ($subname)  = $sub =~ /sub.*?\s+(.*?)\s*\{/;

                    $self->{make_code}{$var} =~ s/$quoted_sub\n//;
                    $self->_do_verbose(LEADCHAR."Removing sub: '$subname'\n");
                }
            }
        }

        # Removing strict & warnings pragmas quietly here to ensure that they'll
        # be inserted after an eventually appearing version requirement.
        $self->{make_code}{begin} =~ s/[ \t]*use\s+(?:strict|warnings)\s*;//g;

        # Saving the shebang (interpreter) line
        while ($self->{make_code}{begin} =~ s/^(\#\!?.*?\n)//) {
            $comments_header .= $1;
        }
        chomp $comments_header;

        # Grabbing use & require statements
        while ($self->{make_code}{begin} =~ /^(?:use|require)\s+(?:[a-z]|[\d\.\_])+?\s*;/m) {
            $self->{make_code}{begin} =~ s/^\n*(.*?;)//s;
            $code_header .= "$1\n";
        }

        # Adding strict & warnings pragmas
        $self->_do_verbose(LEADCHAR."Adding use strict & use warnings pragmas\n");

        if ($code_header =~ /(?:use|require)\s+\d\.[\d_]*\s*;/) {
            $code_header =~ s/([ \t]*(?:use|require)\s+\d\.[\d_]*\s*;\n)(.*)/$1$pragmas$2/;
        } else {
            $code_header = $pragmas . $code_header;
        }
        chomp $code_header;

        # Removing leading & trailing newlines
        1 while $self->{make_code}{begin} =~ s/^\n//;
        chomp $self->{make_code}{begin} while $self->{make_code}{begin} =~ /\n$/s;
    }

    # Constructing the Build.PL header
    $self->{Data}{begin} = $comments_header || $code_header
      ? ($comments_header  =~ /\w/ ? "$comments_header\n" : '') . "$note\n" .
        ($code_header =~ /\w/ ? "\n$code_header\n\n" : "\n") .
        $self->{Data}{begin}
      : "$note\n\n" . $self->{Data}{begin};
}

# Albeit Text::Balanced exists, extract_tagged() and friends
# were (or I?) unable to extract subs.
sub _extract_sub {
    my ($text, $pattern) = @_;

    my ($quoted_pattern, %seen, @sub, @subs);

    $quoted_pattern = quotemeta $pattern;

    foreach my $line (split /\n/, $text) {
        if ($line =~ /^sub $quoted_pattern\w+/s ||
            $line =~ /^\{/)                        { $seen{begin} = 1 }
        if ($seen{begin} && $line =~ /^\s*}/)      { $seen{end}   = 1 }

        if ($seen{begin} || $seen{end}) {
            push @sub, $line;
        } else {
            next;
        }

        if ($seen{end}) {
            push @subs, join "\n", @sub;
            @sub = ();
            @seen{qw(begin end)} = (0,0);
        }
    }

    return @subs;
}

sub _write_begin {
    my $self = shift;

    my $INDENT = substr($self->{INDENT}, 0, length($self->{INDENT})-1);

    $self->_subst_makecode('begin');
    $self->{Data}{begin} =~ s/(\$INDENT)/$1/eego;
    $self->_do_verbose("\n", File::Basename::basename($self->{Config}{Build_PL}), " written:\n", 2);
    $self->_do_verbose('-' x ($self->{Config}{Build_PL_Length} + 9), "\n", 2);
    $self->_do_verbose($self->{Data}{begin}, 2);

    print $self->{Data}{begin};
}

sub _write_args {
    my $self = shift;

    my $arg;
    my $regex = '$chunk =~ /=> \{/';

    if (@{$self->{make_code}{args}{begin}||[]}) {
        foreach my $codechunk (@{$self->{make_code}{args}{begin}}) {
            if (ref $codechunk eq 'ARRAY') {
                foreach my $code (@$codechunk) {
                    $self->_do_verbose("$self->{INDENT}$code\n", 2);
                    print "$self->{INDENT}$code\n";
                }
            } else {
                $self->_do_verbose("$self->{INDENT}$codechunk\n", 2);
                print "$self->{INDENT}$codechunk\n";
            }
        }
    }

    foreach my $chunk (@{$self->{buildargs_dumped}}) {
        # Hash/Array output
        if ($chunk =~ /=> [\{\[]/) {

            # Remove redundant parentheses
            $chunk =~ s/^\{.*?\n(.*(?{ $regex ? '\}' : '\]' }))\s+\}\s+$/$1/os;

            # One element per each line
            my @lines;
            push @lines, $1 while $chunk =~ s/^(.*?\n)(.*)$/$2/s;

            # Gather whitespace up to hash key in order
            # to recreate native Dump() indentation.
            my ($whitespace) = $lines[0] =~ /^(\s+)(\w+)/;
            $arg = $2;
            my $shorten = length($whitespace);

            foreach (my $i = 0; $i < @lines; $i++) {
                my $line = $lines[$i];
                chomp $line;
                # Remove additional whitespace
                $line =~ s/^\s{$shorten}(.*)$/$1/o;

                # Quote sub hash keys
                $line =~ s/^(\s+)([\w:]+)/$1'$2'/ if $line =~ /^\s+/;

                # Add comma where appropriate (version numbers, parentheses, brackets)
                $line .= ',' if $line =~ /[\d+ \} \]] $/x;

                # (De)quotify numbers, variables & code bits
                $line =~ s/' \\? ( \d | [\\ \/ \( \) \$ \@ \%]+ \w+) '/$1/gx;
                $self->_quotify(\$line) if $line =~ /\(/;

                # Add comma to dequotified key/value pairs
                my $comma   = ',' if $line =~ /['"](?!,)$/ && $#lines - $i != 1;
                   $comma ||= '';

                # Construct line output
                my $output = "$self->{INDENT}$line$comma";

                # Add adhering comments at end of array/hash
                $output .= ($i == $#lines && defined $self->{make_comments}{$arg})
                  ? "$self->{make_comments}{$arg}\n"
                  : "\n";

                # Output line
                $self->_do_verbose($output, 2);
                print $output;
            }
        # String output
        } else {
            chomp $chunk;
            # Remove redundant parentheses
            $chunk =~ s/^\{\s+(.*?)\s+\}$/$1/sx;

            # (De)quotify numbers, variables & code bits
            $chunk =~ s/' \\? ( \d | [\\ \/ \( \) \$ \@ \%]+ \w+ ) '/$1/gx;
            $self->_quotify(\$chunk) if $chunk =~ /\(/;

            # Extract argument (key)
            ($arg) = $chunk =~ /^\s*(\w+)/;

            # Construct line output & add adhering comment
            my $output = "$self->{INDENT}$chunk,";
            $output .= $self->{make_comments}{$arg} if defined $self->{make_comments}{$arg};

            # Output key/value pair
            $self->_do_verbose("$output\n", 2);
            print "$output\n";
        }

        no warnings 'uninitialized';
        my @args;

        if ($self->{make_code}{args}{$arg}) {
            @args = ();
            foreach my $arg (@{$self->{make_code}{args}{$arg}}) {
                if (ref $arg eq 'ARRAY') {
                    push @args, @$arg;
                } else {
                    push @args, $arg;
                }
            }

            foreach $arg (@args) {
                next unless $arg;

                $arg .= ',' unless $arg =~ /^\#/;

                $self->_do_verbose("$self->{INDENT}$arg\n", 2);
                print "$self->{INDENT}$arg\n";
            }
        }
    }
}

sub _quotify {
    my ($self, $string) = @_;

    # Removing single-quotes and escaping backslashes
    $$string =~ s/(=>\s+?)'/$1/;
    $$string =~ s/',?$//;
    $$string =~ s/\\'/'/g;

    # Double-quoting $(NAME) variables
    if ($$string =~ /\$\(/) {
        $$string =~ s/(=>\s+?)(.*)/$1"$2"/;
    }
}

sub _write_end {
    my $self = shift;

    my $INDENT = substr($self->{INDENT}, 0, length($self->{INDENT})-1);

    $self->_subst_makecode('end');
    $self->{Data}{end} =~ s/(\$INDENT)/$1/eego;
    $self->_do_verbose($self->{Data}{end}, 2);

    print $self->{Data}{end};
}

sub _subst_makecode {
    my ($self, $section) = @_;

    $self->{make_code}{$section} ||= '';

    $self->{make_code}{$section} =~ /\w/
      ? $self->{Data}{$section} =~ s/\$MAKECODE/$self->{make_code}{$section}/o
      : $self->{Data}{$section} =~ s/\n\$MAKECODE\n//o;
}

sub _add_to_manifest {
    my $self = shift;

    my $fh = IO::File->new($self->{Config}{MANIFEST}, '<')
      or die "Can't open $self->{Config}{MANIFEST}: $!\n";
    my @manifest = <$fh>;
    $fh->close;

    my $build_pl = File::Basename::basename($self->{Config}{Build_PL});

    unless (grep { /^$build_pl\s+$/o } @manifest) {
        unshift @manifest, "$build_pl\n";

        $fh = IO::File->new($self->{Config}{MANIFEST}, '>')
          or die "Can't open $self->{Config}{MANIFEST}: $!\n";
        print {$fh} sort @manifest;
        $fh->close;

        $self->_do_verbose(LEADCHAR."Added to $self->{Config}{MANIFEST}: $self->{Config}{Build_PL}\n");
    }
}

sub _show_summary {
    my $self = shift;

    my @summary = (
        [ 'Succeeded',       'succeeded'      ],
        [ 'Skipped',         'skipped'        ],
        [ 'Failed',          'failed'         ],
        [ 'Method: parse',   'method_parse'   ],
        [ 'Method: execute', 'method_execute' ],
    );

    local $" = "\n";

    foreach my $item (@summary) {
        next unless @{$self->{summary}{$item->[1]}||[]};

        $self->_do_verbose("$item->[0]\n");
        $self->_do_verbose('-' x length($item->[0]), "\n");
        $self->_do_verbose("@{$self->{summary}{$item->[1]}}\n\n");
    }

    my $howmany = @{$self->{summary}->{succeeded}};

    print "Processed $howmany directories\n";
}

sub _do_verbose {
    my $self = shift;

    my $level = $_[-1] =~ /^\d$/ ? pop : 1;

    if (($self->{Config}{Verbose} && $level == 1)
      || ($self->{Config}{Verbose} == 2 && $level == 2)) {
        print STDOUT @_;
    }
}

sub _debug {
    my $self = shift;

    if ($self->{Config}{Debug}) {
        pop and my $no_wait = 1 if $_[-1] eq 'no_wait';
        warn @_;
        warn "Press [enter] to continue...\n"
          and  unless $no_wait;
    }
}

1;
__DATA__