classic.pm

source of perl for linux application,

##################################################
###            CPANPLUS/Shell/Classic.pm       ###
###    Backwards compatible shell for CPAN++   ###
###      Written 08-04-2002 by Jos Boumans     ###
##################################################

package CPANPLUS::Shell::Classic;

use strict;


use CPANPLUS::Error;
use CPANPLUS::Backend;
use CPANPLUS::Configure::Setup;
use CPANPLUS::Internals::Constants;

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];

$Params::Check::VERBOSE       = 1;
$Params::Check::ALLOW_UNKNOWN = 1;

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

load CPANPLUS::Shell;


### our command set ###
my $map = {
    a           => '_author',
    b           => '_bundle',
    d           => '_distribution',
    'm'         => '_module',
    i           => '_find_all',
    r           => '_uptodate',
    u           => '_not_supported',
    ls          => '_ls',
    get         => '_fetch',
    make        => '_install',
    test        => '_install',
    install     => '_install',
    clean       => '_not_supported',
    look        => '_shell',
    readme      => '_readme',
    h           => '_help',
    '?'         => '_help',
    o           => '_set_conf',
    reload      => '_reload',
    autobundle  => '_autobundle',
    '!'         => '_bang',
    #'q'         => '_quit', # done it the loop itself
};

### the shell object, scoped to the file ###
my $Shell;
my $Brand   = 'cpan';
my $Prompt  = $Brand . '> ';

sub new {
    my $class   = shift;

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

    ### enable verbose, it's the cpan.pm way
    $cb->configure_object->set_conf( verbose => 1 );


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

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

    return $self;
}

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

    $self->_show_banner;
    $self->_input_loop && 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});
        }

        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;
}

sub _dispatch_on_input {
    my $self = shift;
    my $conf = $self->backend->configure_object();
    my $term = $self->term;
    my %hash = @_;

    my $string;
    my $tmpl = {
        input   => { required => 1, store => \$string }
    };

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

    ### the original force setting;
    my $force_store = $conf->get_conf( 'force' );

    ### parse the input: the first part before the space
    ### is the command, followed by arguments.
    ### see the usage below
    my $key;
    PARSE_INPUT: {
        $string =~ s|^\s*([\w\?\!]+)\s*||;
        chomp $string;
        $key = lc($1);
    }

    ### you prefixed the input with 'force'
    ### that means we set the force flag, and
    ### reparse the input...
    ### YAY goto block :)
    if( $key eq 'force' ) {
        $conf->set_conf( force => 1 );
        goto PARSE_INPUT;
    }

    ### you want to quit
    return 1 if $key =~ /^q/;

    my $method = $map->{$key};
    unless( $self->can( $method ) ) {
        print "Unknown command '$key'. Type ? for help.\n";
        return;
    }

    ### dispatch the method call
    eval { $self->$method(
                    command => $key,
                    result  => [ split /\s+/, $string ],
                    input   => $string );
    };
    warn $@ if $@;

    return;
}

### displays quit message
sub _quit {

    ### well, that's what CPAN.pm says...
    print "Lockfile removed\n";
}

sub _not_supported {
    my $self = shift;
    my %hash = @_;

    my $cmd;
    my $tmpl = {
        command => { required => 1, store => \$cmd }
    };

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

    print "Sorry, the command '$cmd' is not supported\n";

    return;
}

sub _fetch {
    my $self = shift;
    my $cb   = $self->backend;
    my %hash = @_;

    my($aref, $input);
    my $tmpl = {
        result  => { store => \$aref, default => [] },
        input   => { default => 'all', store => \$input },
    };

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

    for my $mod (@$aref) {
        my $obj;

        unless( $obj = $cb->module_tree($mod) ) {
            print "Warning: Cannot get $input, don't know what it is\n";
            print "Try the command\n\n";
            print "\ti /$mod/\n\n";
            print "to find objects with matching identifiers.\n";

            next;
        }

        $obj->fetch && $obj->extract;
    }

    return $aref;
}

sub _install {
    my $self = shift;
    my $cb   = $self->backend;
    my %hash = @_;

    my $mapping = {
        make        => { target => TARGET_CREATE, skiptest => 1 },
        test        => { target => TARGET_CREATE },
        install     => { target => TARGET_INSTALL },
    };

    my($aref,$cmd);
    my $tmpl = {
        result  => { store => \$aref, default => [] },
        command => { required => 1, store => \$cmd, allow => [keys %$mapping] },
    };

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

    for my $mod (@$aref) {
        my $obj = $cb->module_tree( $mod );

        unless( $obj ) {
            print "No such module '$mod'\n";
            next;
        }

        my $opts = $mapping->{$cmd};
        $obj->install( %$opts );
    }

    return $aref;
}

sub _shell {
    my $self    = shift;
    my $cb      = $self->backend;
    my $conf    = $cb->configure_object;
    my %hash    = @_;

    my($aref, $cmd);
    my $tmpl = {
        result  => { store => \$aref, default => [] },
        command => { required => 1, store => \$cmd },

    };

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


    my $shell = $conf->get_program('shell');
    unless( $shell ) {
        print "Your configuration does not define a value for subshells.\n".
              qq[Please define it with "o conf shell <your shell>"\n];
        return;
    }

    my $cwd = Cwd::cwd();

    for my $mod (@$aref) {
        print "Running $cmd for $mod\n";

        my $obj = $cb->module_tree( $mod )  or next;
        $obj->fetch                         or next;
        $obj->extract                       or next;

        $cb->_chdir( dir => $obj->status->extract )   or next;

        local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt;
        if( system($shell) and $! ) {
            print "Error executing your subshell '$shell': $!\n";
            next;
        }
    }
    $cb->_chdir( dir => $cwd );

    return $aref;
}

sub _readme {
    my $self    = shift;
    my $cb      = $self->backend;
    my $conf    = $cb->configure_object;
    my %hash    = @_;

    my($aref, $cmd);
    my $tmpl = {
        result  => { store => \$aref, default => [] },
        command => { required => 1, store => \$cmd },

    };

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

    for my $mod (@$aref) {
        my $obj = $cb->module_tree( $mod ) or next;

        if( my $readme = $obj->readme ) {

            $self->_pager_open;
            print $readme;
            $self->_pager_close;
        }
    }

    return 1;
}

sub _reload {
    my $self    = shift;
    my $cb      = $self->backend;
    my $conf    = $cb->configure_object;
    my %hash    = @_;

    my($input, $cmd);
    my $tmpl = {
        input   => { default => 'all', store => \$input },
        command => { required => 1, store => \$cmd },

    };

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

    if ( $input =~ /cpan/i ) {
        print qq[You want to reload the CPAN code\n];
        print qq[Just type 'q' and then restart... ] .
              qq[Trust me, it is MUCH safer\n];

    } elsif ( $input =~ /index/i ) {
        $cb->reload_indices(update_source => 1);

    } else {
        print qq[cpan     re-evals the CPANPLUS.pm file\n];
        print qq[index    re-reads the index files\n];
    }

    return 1;
}

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

    print qq[Writing bundle file... This may take a while\n];

    my $where = $cb->autobundle();

    print $where
        ? qq[\nWrote autobundle to $where\n]
        : qq[\nCould not create autobundle\n];

    return 1;
}

sub _set_conf {
    my $self = shift;
    my $cb   = $self->backend;
    my $conf = $cb->configure_object;
    my %hash = @_;

    my($aref, $input);
    my $tmpl = {
        result  => { store => \$aref, default => [] },
        input   => { default => 'all', store => \$input },
    };