view release on metacpan or  search on metacpan

script/ucpan  view on Meta::CPAN

            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;

# give undef as dummy. this is needed for build argv correctly
    $app->parse_options( @{ $CONFIG->{updater_options} }, undef );
    pop @{ $app->{argv} };

    {
        no strict 'refs';
        $org_m
            = +{ map { $_ => \&{ "App::cpanminus::script::" . $_ } }
                qw/_diag install_module fetch_module configure build test install/
               };
    }
    my $pid;
    no warnings 'once';
    if (WIN32) {
        *App::cpanminus::script::run_timeout = sub {
            my ( $self, $cmd, $timeout ) = @_;
            $cmd = $self->shell_quote(@$cmd) if ref $cmd eq 'ARRAY';
            my $cmd_wrap
                = $cmd . ' >> '
                . $self->shell_quote( $self->{log} ) . ' 2>&1';
            my ( $pid, $pipe, $exit_code );
            local $SIG{ALRM} = sub {
                CORE::die "alarm\n";
            };
            eval {
                $pid = system 1, $cmd_wrap;
                alarm $timeout;
                waitpid $pid, 0;
                $exit_code = $?;
                alarm 0;
            };
            if ( $@ && $@ eq "alarm\n" ) {
                pr_progress($state);
                local $STDERR = $ORG_STDERR;
                $self->diag_fail(
                    "Timed out (> ${timeout}s). Use --verbose to retry.");
                CORE::kill -KILL => $pid;
                return;
            }
            return !$exit_code;
        };
    }
    my $diag_msg;
    *App::cpanminus::script::_diag = sub {
        my ( $self, $m, $a, $e ) = @_;
        $state->{fail} = ( $state->{phase} || 'N/A' ) if $e;
        if ( $m =~ /^! Timed out/ ) {
            $state->{phase} .= "(Timeout)";
        }
    };
    *App::cpanminus::script::install_module = sub {
        my ( $self, $m, $d, $v ) = @_;
        return 1 if $self->{seen}{$m};
        my ( $dist, $mod, $ver, $file )
            = @{ $self->resolve_name($m) }
            {qw/dist module module_version pathname/};
        my ( $target, @mods );
        if ( !$outdated{$dist} ) {
            ($file) = $file =~ m#([^/]+/[^/]+)$#;
            $added{$dist} = +{
                file    => $file,
                version => $ver,
                modules => [
                    +{  module  => $mod,
                        current => undef,
                        new     => $ver,
                     }
                ],
            };
            @mods   = ($mod);
            $target = \$added{$dist};
        }
        else {
            @mods = map $_->{module}, @{ $outdated{$dist}->{modules} };
            $count_of_upgrade++;
            $target = \$outdated{$dist};
        }
        $state = +{
            prev  => $state,
            depth => $d,
            curr  => $dist,
        };
        if ( ( $d || 0 ) > ( $state->{prev}{depth} || 0 ) ) {
            unless ( $state->{prev}{in}{$d}++ ) {
                $state->{prev}{dependency}++;
                pr_progress( $state->{prev} );
                pr( IN_PROGRESS => "Dependency found!" . $/ );
            }
        }
        elsif ( ( $d || 0 ) < ( $state->{prev}{depth} || 0 ) ) {
            pr( DEFAULT => $/ );
        }
        pr( DEFAULT => $ispace x $state->{depth} );
        pr( HEADER  => $dist );
        pr( NOTE    => ' [', join( ', ', @mods ), ']' ) if @mods;
        pr( NOTE =>
                sprintf( qq{ (%d/%d)}, $count_of_upgrade, $num_of_upgrade ) )
            if !$state->{depth};
        pr( DEFAULT => $/ );

        my $elapse_one;
        my $res = do {
            $elapse_one = time;
            my $r = &{ $org_m->{install_module} };
            $elapse_one = time() - $elapse_one;
            $r;
        };

        if ($res) {
            if ( $diag_msg =~ /up to date/i ) {
                $$target->{status} = 1;
                $total_upgrade++;
                pr(       SUCCESS => $ispace x $state->{depth}
                        . "Up to date"
                        . $/ );
            }
            elsif ( $$target and !$$target->{fail_at} ) {
                $$target->{status}        = 1;
                $$target->{time_required} = $elapse_one;
                $total_upgrade++;
                pr_progress($state);
                pr( SUCCESS => "SUCCESS" );
                pr( DEFAULT => "($elapse_one sec)" . $/ );
            }
            elsif ($$target) {
                pr( ( $$target->{status} ? 'SUCCESS' : 'FAIL' ) =>
                        $ispace x $state->{depth} . "Already tried" . $/ );
            }
            if ( !$outdated{$dist} ) {
                my $t = delete $added{$dist};
                $t->{status}        = 1;
                $t->{time_required} = $elapse_one;
                $outdated{$dist}    = +{%$t};
                $total_upgrade--;
                $total_added++;
            }
        }
        else {
            $$target->{fail_at}
                = $state->{dependency} ? 'Dependency' : $state->{fail};
            $$target->{time_required} = $elapse_one;
            $outdated{$dist} ||= delete $added{$dist};
            if ( $state->{in}{ $d + 1 } ) {
                $state->{progress_prev} = undef;
                pr( DEFAULT => $ispace x $state->{depth} );
                pr( DEFAULT => '--> ' . $dist . '..' );
            }
            else {
                pr_progress($state);
            }
            pr( FAIL => "Timeout!!.." ) if $state->{fail} =~ /timeout/i;
            pr( FAIL => "FAIL" );
            pr( DEFAULT => "($elapse_one sec)" . $/ );
        }
        $state = $state->{prev};
        return $res;
    };
    *App::cpanminus::script::fetch_module = sub {
        $state->{phase} = "Fetch";
        pr( FETCH => $ispace x $state->{depth},
            $state->{progress_prev} = "Fetch.."
          );
        goto &{ $org_m->{fetch_module} };
    };
    *App::cpanminus::script::configure = sub {
## configure_ARGS: @_
        if ( $state->{in} ) {
            $state->{in} = $state->{progress_prev} = undef;
            pr( DEFAULT => $ispace x $state->{depth}, '-->' );
            pr( HEADER  => "[$state->{curr}]" );
        }
        pr_progress($state);
        pr( CONFIG => $state->{progress_prev} = "Configure.." );
        $state->{phase} = "Configure";
        goto &{ $org_m->{configure} };
    };
    *App::cpanminus::script::build = sub {
        if ( $state->{in} ) {
            $state->{in} = $state->{progress_prev} = undef;
            pr( DEFAULT => $ispace x $state->{depth}, '-->' );
            pr( HEADER  => "[$state->{curr}]" );
        }
        pr_progress($state);
        pr( BUILD => $state->{progress_prev} = "Build.." );
        $state->{phase} = "Build";
        goto &{ $org_m->{build} };
    };
    *App::cpanminus::script::test = sub {
        pr_progress($state);
        pr( TEST => $state->{progress_prev} = "Test.." );
        $state->{phase} = "Test";
        goto &{ $org_m->{test} };
    };
    *App::cpanminus::script::install = sub {
        pr_progress($state);
        pr( INSTALL => $state->{progress_prev} = "Install.." );
        $state->{phase} = "Install";
        goto &{ $org_m->{install} };
    };
    use warnings 'once';

    for my $method (qw/setup_home init_tools configure_mirrors/) {
        $app->${method};
    }
    for my $method (qw/setup_home init_tools configure_mirrors/) {
        no strict 'refs';
        no warnings 'redefine';
        *{ 'App::cpanminus::script::' . $method } = sub { };
    }

    local $ENV{HARNESS_OPTIONS} = "j$DEBUG{jobs}" if $DEBUG{jobs};

script/ucpan  view on Meta::CPAN

=item -S, --sudo

=item --no-sudo

Switch to the root user with sudo when installing modules,
or deny this.

See L<cpanm> for more detail.

=back

=head1 RECODING FILE

The previous result is recorded in the recoding file of this program.
Normally you do not need to edit this file.

The recoding file is named .ucpandb and placed in the top of @INC (ie. $INC[0]).
For example, if using local::lib, it is placed in /your/local/lib/$Config{archname}/.ucpandb.
This is to ensure that the settings do not interfere with running this program for different Perl environments.

In the recording file, the following items are recorded in YAML format.

=over 4

=item Successful module

Module name, preinstallation version, installed version

=item Failed distribution

Distribution file path, distribution version, module name of included module, version before installation, latest version, reason (for example, build, test, test timeout), processing time (seconds)

=back

=head1 BRIEF EXPLANATION OF THE MECHANISM

At first, the previous execution record is loaded from the recoding file.

In Check Phase, information on outdated modules is gathered via L<cpan-outdated>. The module to be skipped is determined by collating with the previous execution record.

In Installation Phase, the installation work is progressed using the function of loaded L<cpanm> (yes, loading L<cpanm>). Success of the result, which phases of the work failed, etc. are recorded.

In Result Phase, the summary is assembled and displayed based on the record of the installation.

Finally, the execution record is written to the recoding file.

=head1 SPECIAL FEATURE FOR WIN32

In the Win32 environment, the following matters have been improved for L<cpanm>.

=over 4

=item Symbolic link

L<cpanm> creates a symbolic link of the latest build log and working directory directly under $HOME/.cpanm,
but it is not created under Win32 environment.
ucpan can emulate symlink() and create it using Win32's mklink command.
(There is no one working in FAT32 environment anymore, is it?)

=item Timeout

L<cpanm> ignores the --*-timeout option in Win32 environment,
but in Win32 environment SIGALARM can also be used to implement timeout processing.
ucpan implements this.

=back

=head1 ENVIRONMENT VARIABLES

The following environment variables affect this program.

=over 4

=item PERL5LIB, PERL_LOCAL_LIB_ROOT, PERL_MB_OPT, PERL_MM_OPT,

=item PERL_CPANM_HOME, PERL_CPANM_OPT

=item HARNESS_OPTIONS( for test environment )

=back

=head1 SEE ALSO

L<App::ucpan>, L<App::cpanminus>, L<cpanm>

=head1 LICENSE

Copyright (C) KPEE.

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 AUTHOR

KPEE E<lt>kpee.cpan@gmail.comE<gt>

=cut