—

              
#!perl
use 5.008001;
use strict;
use File::Which;
our $VERSION = '0.04';
$App::cpanmw::VERSION = $VERSION;
use constant IS_WIN32 => $^O eq 'MSWin32';
use constant IS_WIN60 => IS_WIN32 && $ENV{HOMEPATH} && $ENV{HOMEPATH} =~ /^\\Users\\/;
# Conditional load
BEGIN {
    if (IS_WIN32) {
        require Win32::Console::ANSI;
        Win32::Console::ANSI->import();
    }
    use Term::ANSIColor;
}
use FindBin;
$| = 1;
# HACK
my $cpanm_file = File::Which::which 'cpanm';
$cpanm_file =~ s/\\/\//g;
# override system & symlink for App::cpanminus::script
if (IS_WIN32) {
    no warnings 'once';
    *App::cpanminus::script::system = sub {
        my $cmd = shift;
        $cmd .= ' 2>&1';
        CORE::system $cmd;
    };
    # hack for making 'latest-build' as symlink
    # Windows6.x can make symlink via 'mklink' utility
    if (IS_WIN60) {
        *CORE::GLOBAL::symlink = sub {
            my ( $org, $dest ) = @_;
            return 1 unless ( $org || $dest );
            my $flag = '';
            if ( -d $org ) {
                $flag = '/J';
                rmdir $dest;
            }
            !system qq{mklink $flag "$dest" "$org" >NUL};
        };
    }
}
#== customizing cpanm!!
eval qq{require '$cpanm_file'};
my $app = App::cpanminus::script->new;
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__
HideShow 107 lines of Pod
=pod
=head1 NAME
cpanmw - the cpanm wrapper
=head1 SYNOPSIS
    # type "cpanmw" instead of "cpanm"
    $ cpanmw Acme::Bleach
    $ cpanmw --verbose Plack
    $ cpanmw -L Twiggy@0.10
=head1 DESCRIPTION
This script is wrapper for L<cpanm>.
Commands and options are completely the same as L<cpanm>.
See L<cpanm> for details.
It can use like L<cpanm>, but has some features.
=over 4
=item - Display color-coded phrases and keywords
Several phrases and keywords are displayed in different colors.
=over 2
=item * BOLD GREEN for Success
=item * BOLD RED for Fail and Error messages
=item * BOLD YELLOW for Module-Name and Dist-Name
=item * CYAN for Progress Keywords (eg. Fetching..., Building...)
=item * YELLOW for Outputs from L<cpanm> (except from external tool)
=back
This feature requires L<Win32::Console::ANSI> on Win32.
=item - Supports --****-timeout options on Win32
In L<cpanm>, --****-timeout option is ignored on Win32.
cpanmw makes it possible by emulates this.
=item - Create ~/.cpanm/build.log as symbolic link on Win32
Perl-CORE does not support symlink,
so L<cpanm> is skip this process.
cpanmw emulates symlink by using Windows' "mklink" command,
then make it possible.
This feature requires Windows 6.0(aka. Windows Vista) or later.
Otherwise, it is copied from work directory
(This is the default behavior of L<cpanm>)
=over 4
=item NOTE: If an error "permission denied" occurs...
=over 2
Your user account does not have administrator privileges
(exactly authority "SeCreateSymbolicLinkPrivilege" is required).
You can check by typing the following,
then check the error message.
    > cd %Temp% && mklink foo bar
=back
=back
=item - Create ~/.cpanm/latest-build/ as junction point on Win32
cpanmw makes this possible by the mechanism of previous section.
Doesn't create it if not.
This feature requires Windows 5.0(aka. Windows 2000) or later.
=back
=head1 AUTHOR
KPEE
=head1 LICENSE
Copyright (C) 2014 KPEE
This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
=head1 SEE ALSO
L<App::cpanminus>,
L<cpanm>
=cut