view release on metacpan or  search on metacpan

script/cpanmw  view on Meta::CPAN

my $org_m;
{
    no strict 'refs';
    $org_m = +{
        map { $_ => \&{ "App::cpanminus::script::" . $_ } }
           qw/_diag show_help show_version/
    };
}

## Hooks for Win6.0
if (IS_WIN60) {
# hack: kill -9,$pid[perlport#kill@win32] does not work on perl-5.18.
#       use 'taskkill' instead.
    *_kill_group = sub {
        my ($pid) = @_;
        if ( $] >= 5.020 ) {    # bug is resolved on perl-5.20
            CORE::kill '-TERM', $pid;
        }
        else {                  # but collapsed on perl-5.18
            system 'taskkill /F /T /PID ' . $pid . ' >NUL 2>&1';
        }
    };
# hook for run_timeout
# alarm() works on Windows, but need hack for stability.
    *App::cpanminus::script::run_timeout = sub {
### run_timeout_arg[cmd]: $_[1]
        my ( $self, $cmd, $timeout ) = @_;
        return $self->run($cmd) if $self->{verbose} || !$timeout;
        $cmd = $self->shell_quote(@$cmd) if ref $cmd eq 'ARRAY';
        $cmd .= ' >> ' . $self->shell_quote( $self->{log} ) . ' 2>&1';
        my ( $pid, $exit_code );
        local $SIG{ALRM} = sub {
            CORE::die "alarm\n";
        };
        eval {
            $pid = system 1, $cmd;
            alarm $timeout;
            waitpid $pid, 0;
            $exit_code = $?;
            alarm 0;
        };
        if ( $@ && $@ eq "alarm\n" ) {
            $self->diag_fail(
                "Timed out (> ${timeout}s). Use --verbose to retry.");
            _kill_group($pid);
            waitpid $pid, 0;
            return;
        }
        return !$exit_code;
    };
}
## GLOBAL hook
{
    *App::cpanminus::script::_diag = sub {
        my $caller = ( caller(1) )[3];
        goto &{ $org_m->{_diag} }
            unless $caller =~ s/^App::cpanminus::script:://;
### $caller
        my @arg = @_;
        if ( $caller eq 'diag_ok' ) {
            $arg[1] = colored( $arg[1], 'bold green' );
        }
        elsif ( $caller eq 'diag_fail' ) {
            $arg[1] = colored( $arg[1], 'bold red' );
        }
        elsif ( $caller eq 'diag_progress' ) {
            $arg[1]
                =~ s/^(Fetching|Configuring|Building(?: and testing)?)/colored($1,'cyan')/e;
        }
        elsif ( $arg[1] =~ /^-->/ ) {
            $arg[1]
                =~ s/(?<=--> Working on )(\S+)/colored( $1, 'bold yellow' )/e;
        }
        elsif ( $arg[1] =~ /^==>/ ) {
            $arg[1] =~ s/(Found dependencies)/colored($1,'bold magenta')/e;
        }
        elsif ( $arg[1] =~ s/^(Successfully \S+)(\s+\S+)/colored($1,'bold green') . colored($2, 'bold yellow')/e )
        {
        }
        elsif ( $_[0]->{verbose} ) {
            $arg[1] = colored( $arg[1], 'cyan' );
        }
        @_ = @arg;
        goto &{ $org_m->{_diag} };
    };

    *App::cpanminus::script::chat = sub {
        my $self = shift;
        print STDERR colored( join( $,, @_ ), 'yellow' ) if $self->{verbose};
        $self->log(@_);
    };
    $app->parse_options(@ARGV);
    if ( $app->{action} eq 'show_version' ) {
        $org_m->{show_version} = \&App::cpanminus::script::show_version;
        *App::cpanminus::script::show_version = sub {
            print "cpanmw [App::cpanmw] version $App::cpanmw::VERSION ($0)\n";
            print "\n";
            print "=== cpanm version info ===\n";
            local $0 = $cpanm_file;
            $org_m->{show_version}(@_);
        };
    }
    if (   $app->{action} eq 'show_help'
        || !$app->{argv}
        || !$app->{load_from_stdin} )
    {
        $org_m->{show_help} = \&App::cpanminus::script::show_help;
        require IO::Callback;
        my $cb = sub {
            my $s = shift;
            $s =~ s/\bcpanm\b/cpanmw/g;
            $s =~ s/ PERL_CPANM_OPT / PERL_CPANM_OPT( not PERL_CPANMW_OPT ) /g;
            print STDOUT $s;
        };
        my $fh = IO::Callback->new( '>', $cb );
        *App::cpanminus::script::show_help = sub {
            select $fh;
            $org_m->{show_help}(@_);
        };
    }

### @ARGV
}

$app->doit();
__END__

=pod

=head1 NAME

cpanmw - the cpanm wrapper

=head1 SYNOPSIS

    # type "cpanmw" instead of "cpanm"