default.pm

source of perl for linux application,

package CPANPLUS::Shell::Default;

use strict;


use CPANPLUS::Error;
use CPANPLUS::Backend;
use CPANPLUS::Configure::Setup;
use CPANPLUS::Internals::Constants;
use CPANPLUS::Internals::Constants::Report qw[GRADE_FAIL];

use Cwd;
use IPC::Cmd;
use Term::UI;
use Data::Dumper;
use Term::ReadLine;

use Module::Load                qw[load];
use Params::Check               qw[check];
use Module::Load::Conditional   qw[can_load check_install];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

local $Params::Check::VERBOSE   = 1;
local $Data::Dumper::Indent     = 1; # for dumpering from !

BEGIN {
    use vars        qw[ $VERSION @ISA ];
    @ISA        =   qw[ CPANPLUS::Shell::_Base::ReadLine ];
    $VERSION = "0.84";
}

load CPANPLUS::Shell;


my $map = {
    'm'     => '_search_module',
    'a'     => '_search_author',
    '!'     => '_bang',
    '?'     => '_help',
    'h'     => '_help',
    'q'     => '_quit',
    'r'     => '_readme',
    'v'     => '_show_banner',
    'w'     => '__display_results',
    'd'     => '_fetch',
    'z'     => '_shell',
    'f'     => '_distributions',
    'x'     => '_reload_indices',
    'i'     => '_install',
    't'     => '_install',
    'l'     => '_details',
    'p'     => '_print',
    's'     => '_set_conf',
    'o'     => '_uptodate',
    'b'     => '_autobundle',
    'u'     => '_uninstall',
    '/'     => '_meta',         # undocumented for now
    'c'     => '_reports',
};
### free letters: e g j k n y ###


### will be filled if you have a .default-shell.rc and
### Config::Auto installed
my $rc = {};

### the shell object, scoped to the file ###
my $Shell;
my $Brand   = loc('CPAN Terminal');
my $Prompt  = $Brand . '> ';

=pod

=head1 NAME

CPANPLUS::Shell::Default

=head1 SYNOPSIS

    ### loading the shell:
    $ cpanp                     # run 'cpanp' from the command line
    $ perl -MCPANPLUS -eshell   # load the shell from the command line


    use CPANPLUS::Shell qw[Default];        # load this shell via the API
                                            # always done via CPANPLUS::Shell

    my $ui = CPANPLUS::Shell->new;
    $ui->shell;                             # run the shell
    $ui->dispatch_on_input( input => 'x');  # update the source using the
                                            # dispatch method

    ### when in the shell:
    ### Note that all commands can also take options.
    ### Look at their underlying CPANPLUS::Backend methods to see
    ### what options those are.
    cpanp> h                 # show help messages
    cpanp> ?                 # show help messages

    cpanp> m Acme            # find acme modules, allows regexes
    cpanp> a KANE            # find modules by kane, allows regexes
    cpanp> f Acme::Foo       # get a list of all releases of Acme::Foo

    cpanp> i Acme::Foo       # install Acme::Foo
    cpanp> i Acme-Foo-1.3    # install version 1.3 of Acme::Foo
    cpanp> i <URI>           # install from URI, like ftp://foo.com/X.tgz
    cpanp> i 1 3..5          # install search results 1, 3, 4 and 5
    cpanp> i *               # install all search results
    cpanp> a KANE; i *;      # find modules by kane, install all results
    cpanp> t Acme::Foo       # test Acme::Foo, without installing it
    cpanp> u Acme::Foo       # uninstall Acme::Foo
    cpanp> d Acme::Foo       # download Acme::Foo
    cpanp> z Acme::Foo       # download & extract Acme::Foo, then open a
                             # shell in the extraction directory

    cpanp> c Acme::Foo       # get a list of test results for Acme::Foo
    cpanp> l Acme::Foo       # view details about the Acme::Foo package
    cpanp> r Acme::Foo       # view Acme::Foo's README file
    cpanp> o                 # get a list of all installed modules that
                             # are out of date
    cpanp> o 1..3            # list uptodateness from a previous search 
                            
    cpanp> s conf            # show config settings
    cpanp> s conf md5 1      # enable md5 checks
    cpanp> s program         # show program settings
    cpanp> s edit            # edit config file
    cpanp> s reconfigure     # go through initial configuration again
    cpanp> s selfupdate      # update your CPANPLUS install
    cpanp> s save            # save config to disk
    cpanp> s mirrors         # show currently selected mirrors

    cpanp> ! [PERL CODE]     # execute the following perl code

    cpanp> b                 # create an autobundle for this computers
                             # perl installation
    cpanp> x                 # reload index files (purges cache)
    cpanp> x --update_source # reload index files, get fresh source files
    cpanp> p [FILE]          # print error stack (to a file)
    cpanp> v                 # show the banner
    cpanp> w                 # show last search results again

    cpanp> q                 # quit the shell

    cpanp> /plugins          # list avialable plugins
    cpanp> /? PLUGIN         # list help test of <PLUGIN>                  

    ### common options:
    cpanp> i ... --skiptest # skip tests
    cpanp> i ... --force    # force all operations
    cpanp> i ... --verbose  # run in verbose mode

=head1 DESCRIPTION

This module provides the default user interface to C<CPANPLUS>. You
can start it via the C<cpanp> binary, or as detailed in the L<SYNOPSIS>.

=cut

sub new {
    my $class   = shift;

    my $cb      = CPANPLUS::Backend->new( @_ );
    my $self    = $class->SUPER::_init(
                            brand       => $Brand,
                            term        => Term::ReadLine->new( $Brand ),
                            prompt      => $Prompt,
                            backend     => $cb,
                            format      => "%4s %-55s %8s %-10s\n",
                            dist_format => "%4s %-42s %-12s %8s %-10s\n",
                        );
    ### make it available package wide ###
    $Shell = $self;

    my $rc_file = File::Spec->catfile(
                        $cb->configure_object->get_conf('base'),
                        DOT_SHELL_DEFAULT_RC,
                    );


    if( -e $rc_file && -r _ ) {
        $rc = $self->_read_configuration_from_rc( $rc_file );
    }

    ### register install callback ###
    $cb->_register_callback(
            name    => 'install_prerequisite',
            code    => \&__ask_about_install,
    );

    ### execute any login commands specified ###
    $self->dispatch_on_input( input => $rc->{'login'} )
            if defined $rc->{'login'};

    ### register test report callbacks ###
    $cb->_register_callback(
            name    => 'edit_test_report',
            code    => \&__ask_about_edit_test_report,
    );

    $cb->_register_callback(
            name    => 'send_test_report',
            code    => \&__ask_about_send_test_report,
    );

    $cb->_register_callback(
            name    => 'proceed_on_test_failure',
            code    => \&__ask_about_test_failure,
    );

    ### load all the plugins
    $self->_plugins_init;

    return $self;
}

sub shell {
    my $self = shift;
    my $term = $self->term;
    my $conf = $self->backend->configure_object;

    $self->_show_banner;
    $self->__print( "*** Type 'p' now to show start up log\n" ); # XXX add to banner?
    $self->_show_random_tip if $conf->get_conf('show_startup_tip');
    $self->_input_loop && $self->__print( "\n" );
    $self->_quit;
}

sub _input_loop {
    my $self    = shift;
    my $term    = $self->term;
    my $cb      = $self->backend;

    my $normal_quit = 0;
    while (
        defined (my $input = eval { $term->readline($self->prompt) } )
        or $self->_signals->{INT}{count} == 1
    ) {
        ### re-initiate all signal handlers
        while (my ($sig, $entry) = each %{$self->_signals} ) {
            $SIG{$sig} = $entry->{handler} if exists($entry->{handler});
        }

        $self->__print( "\n" );
        last if $self->dispatch_on_input( input => $input );

        ### flush the lib cache ###
        $cb->_flush( list => [qw|lib load|] );

    } continue {
        $self->_signals->{INT}{count}--
            if $self->_signals->{INT}{count}; # clear the sigint count
    }

    return 1;
}

### return 1 to quit ###
sub dispatch_on_input {
    my $self = shift;
    my $conf = $self->backend->configure_object();
    my $term = $self->term;
    my %hash = @_;

    my($string, $noninteractive);
    my $tmpl = {
        input          => { required => 1, store => \$string },
        noninteractive => { required => 0, store => \$noninteractive },
    };

    check( $tmpl, \%hash ) or return;

    ### indicates whether or not the user will receive a shell
    ### prompt after the command has finished.
    $self->noninteractive($noninteractive) if defined $noninteractive;

    my @cmds =  split ';', $string;
    while( my $input = shift @cmds ) {

        ### to send over the socket ###
        my $org_input = $input;

        my $key; my $options;
        {   ### make whitespace not count when using special chars
            { $input =~ s|^\s*([!?/])|$1 |; }

            ### get the first letter of the input
            $input =~ s|^\s*([\w\?\!/])\w*||;

            chomp $input;
            $key =  lc($1);

            ### we figured out what the command was...
            ### if we have more input, that DOES NOT start with a white
            ### space char, we misparsed.. like 'Test::Foo::Bar', which
            ### would turn into 't', '::Foo::Bar'...
            if( $input and $input !~ s/^\s+// ) {
                $self->__print( loc("Could not understand command: %1\n".
                          "Possibly missing command before argument(s)?\n",
                          $org_input) ); 
                return;
            }     

            ### allow overrides from the config file ###
            if( defined $rc->{$key} ) {
                $input = $rc->{$key} . $input;
            }

            ### grab command line options like --no-force and --verbose ###
            ($options,$input) = $term->parse_options($input)
                unless $key eq '!';
        }

        ### emtpy line? ###
        return unless $key;

        ### time to quit ###
        return 1 if $key eq 'q';

        my $method = $map->{$key};

        ### dispatch meta locally at all times ###
        $self->$method(input => $input, options => $options), next
            if $key eq '/';

        ### flush unless we're trying to print the stack
        CPANPLUS::Error->flush unless $key eq 'p';

        ### connected over a socket? ###
        if( $self->remote ) {

            ### unsupported commands ###
            if( $key eq 'z' or
                ($key eq 's' and $input =~ /^\s*edit/)
            ) {
                $self->__print( "\n", 
                      loc(  "Command '%1' not supported over remote connection",
                            join ' ', $key, $input 
                      ), "\n\n" );

            } else {
                my($status,$buff) = $self->__send_remote_command($org_input);

                $self->__print( "\n", loc("Command failed!"), "\n\n" )
                    unless $status;

                $self->_pager_open if $buff =~ tr/\n// > $self->_term_rowcount;
                $self->__print( $buff );
                $self->_pager_close;
            }

        ### or just a plain local shell? ###
        } else {

            unless( $self->can($method) ) {
                $self->__print(loc("Unknown command '%1'. Usage:", $key), "\n");
                $self->_help;

            } else {

                ### some methods don't need modules ###
                my @mods;
                @mods = $self->_select_modules($input)
                        unless grep {$key eq $_} qw[! m a v w x p s b / ? h];

                eval { $self->$method(  modules => \@mods,
                                        options => $options,
                                        input   => $input,
                                        choice  => $key )
                };
                error( $@ ) if $@;
            }
        }
    }

    return;
}

sub _select_modules {
    my $self    = shift;
    my $input   = shift or return;
    my $cache   = $self->cache;
    my $cb      = $self->backend;

    ### expand .. in $input
    $input =~ s{\b(\d+)\s*\.\.\s*(\d+)\b}
               {join(' ', ($1 < 1 ? 1 : $1) .. ($2 > $#{$cache} ? $#{$cache} : $2))}eg;

    $input = join(' ', 1 .. $#{$cache}) if $input eq '*';
    $input =~ s/'/::/g; # perl 4 convention

    my @rv;
    for my $mod (split /\s+/, $input) {

        ### it's a cache look up ###
        if( $mod =~ /^\d+/ and $mod > 0 ) {
            unless( scalar @$cache ) {
                $self->__print( loc("No search was done yet!"), "\n" );

            } elsif ( my $obj = $cache->[$mod] ) {
                push @rv, $obj;

            } else {
                $self->__print( loc("No such module: %1", $mod), "\n" );
            }

        } else {
            my $obj = $cb->parse_module( module => $mod );

            unless( $obj ) {
                $self->__print( loc("No such module: %1", $mod), "\n" );

            } else {
                push @rv, $obj;
            }
        }
    }

    unless( scalar @rv ) {
        $self->__print( loc("No modules found to operate on!\n") );
        return;
    } else {
        return @rv;
    }
}

sub _format_version {
    my $self    = shift;
    my $version = shift;

    ### fudge $version into the 'optimal' format
    $version = 0 if $version eq 'undef';
    $version =~ s/_//g; # everything after gets stripped off otherwise

    ### allow 6 digits after the dot, as that's how perl stringifies
    ### x.y.z numbers.
    $version = sprintf('%3.6f', $version);
    $version = '' if $version == '0.00';
    $version =~ s/(00{0,3})$/' ' x (length $1)/e;

    return $version;
}

sub __display_results {
    my $self    = shift;
    my $cache   = $self->cache;

    my @rv = @$cache;

    if( scalar @rv ) {

        $self->_pager_open if $#{$cache} >= $self->_term_rowcount;

        my $i = 1;
        for my $mod (@rv) {
            next unless $mod;   # first one is undef
                                # humans start counting at 1

            ### for dists only -- we have checksum info
            if( $mod->mtime ) {
                $self->__printf(
                    $self->dist_format,
                    $i,
                    $mod->module,
                    $mod->mtime,
                    $self->_format_version( $mod->version ),
                    $mod->author->cpanid