Admin Control Panel v2.0

✎ Editing: Classic.pm ← Back

##################################################
###            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.9138";
}

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,
    );

if (my $histfile = $self->configure_object->get_conf( 'histfile' )) {
        my $term = $self->term;
        if ($term->can('AddHistory')) {
            if (open my $fh, '<', $histfile) {
                local $/ = "\n";
                while (my $line = <$fh>) {
                    chomp($line);
                    $term->AddHistory($line);
                }
                close($fh);
            }
        }
    }

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 {
    my $self = shift;
    my $term = $self->term;

if ($term->can('GetHistory')) {
        my @history = $term->GetHistory;

my $histfile = $self->configure_object->get_conf('histfile');

if (open my $fh, '>', $histfile) {
            foreach my $line (@history) {
                print {$fh} "$line\n";
            }
            close($fh);
        }
        else {
            warn "Cannot open history file '$histfile' - $!";
        }
    }

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

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

my $type = shift @$aref;

if( $type eq 'debug' ) {
        print   qq[Sorry you cannot set debug options through ] .
                qq[this shell in CPANPLUS\n];
        return;

} elsif ( $type eq 'conf' ) {

### from CPAN.pm :o)
        # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
        # should have been called set and 'o debug' maybe 'set debug'

#    commit             Commit changes to disk
        #    defaults           Reload defaults from disk
        #    init               Interactive setting of all options

my $name    = shift @$aref;
        my $value   = "@$aref";

if( $name eq 'init' ) {
            my $setup = CPANPLUS::Configure::Setup->new(
                        conf    => $cb->configure_object,
                        term    => $self->term,
                        backend => $cb,
                    );
            return $setup->init;

} elsif ($name eq 'commit' ) {;
            $cb->configure_object->save;
            print "Your CPAN++ configuration info has been saved!\n\n";
            return;

} elsif ($name eq 'defaults' ) {
            print   qq[Sorry, CPANPLUS cannot restore default for you.\n] .
                    qq[Perhaps you should run the interactive setup again.\n] .
                    qq[\ttry running 'o conf init'\n];
            return;

### we're just supplying things in the 'conf' section now,
        ### not the program section.. it's a bit of a hassle to make that
        ### work cleanly with the original CPAN.pm interface, so we'll fix
        ### it when people start complaining, which is hopefully never.
        } else {
            unless( $name ) {
                my @list =  grep { $_ ne 'hosts' }
                            $conf->options( type => $type );

my $method = 'get_' . $type;

local $Data::Dumper::Indent = 0;
                for my $name ( @list ) {
                    my $val = $conf->$method($name);
                    ($val)  = ref($val)
                                ? (Data::Dumper::Dumper($val) =~ /= (.*);$/)
                                : "'$val'";
                    printf  "    %-25s %s\n", $name, $val;
                }

} elsif ( $name eq 'hosts' ) {
                print   "Setting hosts is not trivial.\n" .
                        "It is suggested you edit the " .
                        "configuration file manually";

} else {
                my $method = 'set_' . $type;
                if( $conf->$method($name => defined $value ? $value : '') ) {
                    my $set_to = defined $value ? $value : 'EMPTY STRING';
                    print "Key '$name' was set to '$set_to'\n";
                }
            }
        }
    } else {
        print   qq[Known options:\n] .
                qq[  conf    set or get configuration variables\n] .
                qq[  debug   set or get debugging options\n];
    }

return;
}

########################
### search functions ###
########################

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

my($aref, $short, $input, $class);
    my $tmpl = {
        result  => { store => \$aref, default => ['/./'] },
        short   => { default => 0, store => \$short },
        input   => { default => 'all', store => \$input },
        class   => { default => 'Author', no_override => 1,
                    store => \$class },
    };

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

my @regexes = map { m|/(.+)/| ? qr/$1/ : $_ } @$aref;

my @rv;
    for my $type (qw[author cpanid]) {
        push @rv, $cb->search( type => $type, allow => \@regexes );
    }

unless( @rv ) {
        print "No object of type $class found for argument $input\n"
            unless $short;
        return;
    }

return $self->_pp_author(
                result  => \@rv,
                class   => $class,
                short   => $short,
                input   => $input );

}

### find all modules matching a query ###
sub _module {
    my $self = shift;
    my $cb   = $self->backend;
    my %hash = @_;

my($aref, $short, $input, $class);
    my $tmpl = {
        result  => { store => \$aref, default => ['/./'] },
        short   => { default => 0, store => \$short },
        input   => { default => 'all', store => \$input },
        class   => { default => 'Module', no_override => 1,
                    store => \$class },
    };

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

my @rv;
    for my $module (@$aref) {
        if( $module =~ m|/(.+)/| ) {
            push @rv, $cb->search(  type    => 'module',
                                    allow   => [qr/$1/i] );
        } else {
            my $obj = $cb->module_tree( $module ) or next;
            push @rv, $obj;
        }
    }

return $self->_pp_module(
                result  => \@rv,
                class   => $class,
                short   => $short,
                input   => $input );
}

### find all bundles matching a query ###
sub _bundle {
    my $self = shift;
    my $cb   = $self->backend;
    my %hash = @_;

my($aref, $short, $input, $class);
    my $tmpl = {
        result  => { store => \$aref, default => ['/./'] },
        short   => { default => 0, store => \$short },
        input   => { default => 'all', store => \$input },
        class   => { default => 'Bundle', no_override => 1,
                    store => \$class },
    };

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

my @rv;
    for my $bundle (@$aref) {
        if( $bundle =~ m|/(.+)/| ) {
            push @rv, $cb->search(  type    => 'module',
                                    allow   => [qr/Bundle::.*?$1/i] );
        } else {
            my $obj = $cb->module_tree( "Bundle::${bundle}" ) or next;
            push @rv, $obj;
        }
    }

return $self->_pp_module(
                result  => \@rv,
                class   => $class,
                short   => $short,
                input   => $input );
}

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

my($aref, $short, $input, $class);
    my $tmpl = {
        result  => { store => \$aref, default => ['/./'] },
        short   => { default => 0, store => \$short },
        input   => { default => 'all', store => \$input },
        class   => { default => 'Distribution', no_override => 1,
                    store => \$class },
    };

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

my @rv;
    for my $module (@$aref) {
        ### if it's a regex... ###
        if ( my ($match) = $module =~ m|^/(.+)/$|) {

### something like /FOO/Bar.tar.gz/ was entered
            if (my ($path,$package) = $match =~ m|^/?(.+)/(.+)$|) {
                my $seen;

my @data = $cb->search( type    => 'package',
                                        allow   => [qr/$package/i] );

my @list = $cb->search( type    => 'path',
                                        allow   => [qr/$path/i],
                                        data    => \@data );

### make sure we dont list the same dist twice
                for my $val ( @list ) {
                    next if $seen->{$val->package}++;

push @rv, $val;
                }

### something like /FOO/ or /Bar.tgz/ was entered
            ### so we look both in the path, as well as in the package name
            } else {
                my $seen;
                {   my @list = $cb->search( type    => 'package',
                                            allow   => [qr/$match/i] );

### make sure we dont list the same dist twice
                    for my $val ( @list ) {
                        next if $seen->{$val->package}++;

push @rv, $val;
                    }
                }

{   my @list = $cb->search( type    => 'path',
                                            allow   => [qr/$match/i] );

### make sure we dont list the same dist twice
                    for my $val ( @list ) {
                        next if $seen->{$val->package}++;

push @rv, $val;
                    }

}
            }

} else {

### user entered a full dist, like: R/RC/RCAPUTO/POE-0.19.tar.gz
            if (my ($path,$package) = $module =~ m|^/?(.+)/(.+)$|) {
                my @data = $cb->search( type    => 'package',
                                        allow   => [qr/^$package$/] );
                my @list = $cb->search( type    => 'path',
                                        allow   => [qr/$path$/i],
                                        data    => \@data);

### make sure we dont list the same dist twice
                my $seen;
                for my $val ( @list ) {
                    next if $seen->{$val->package}++;

push @rv, $val;
                }
            }
        }
    }

return $self->_pp_distribution(
                result  => \@rv,
                class   => $class,
                short   => $short,
                input   => $input );
}

sub _find_all {
    my $self = shift;

my @rv;
    for my $method (qw[_author _bundle _module _distribution]) {
        my $aref = $self->$method( @_, short => 1 );

push @rv, @$aref if $aref;
    }

print scalar(@rv). " items found\n"
}

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

my($aref, $short, $input, $class);
    my $tmpl = {
        result  => { store => \$aref, default => ['/./'] },
        short   => { default => 0, store => \$short },
        input   => { default => 'all', store => \$input },
        class   => { default => 'Uptodate', no_override => 1,
                    store => \$class },
    };

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

my @rv;
    if( @$aref) {
        for my $module (@$aref) {
            if( $module =~ m|/(.+)/| ) {
                my @list = $cb->search( type    => 'module',
                                        allow   => [qr/$1/i] );

### only add those that are installed and not core
                push @rv, grep { not $_->package_is_perl_core }
                          grep { $_->installed_file }
                          @list;

} else {
                my $obj = $cb->module_tree( $module ) or next;
                push @rv, $obj;
            }
        }
    } else {
        @rv = @{$cb->_all_installed};
    }

return $self->_pp_uptodate(
            result  => \@rv,
            class   => $class,
            short   => $short,
            input   => $input );
}

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

my($aref, $short, $input, $class);
    my $tmpl = {
        result  => { store => \$aref, default => [] },
        short   => { default => 0, store => \$short },
        input   => { default => 'all', store => \$input },
        class   => { default => 'Uptodate', no_override => 1,
                    store => \$class },
    };

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

my @rv;
    for my $name (@$aref) {
        my $auth = $cb->author_tree( uc $name );

unless( $auth ) {
            print qq[ls command rejects argument $name: not an author\n];
            next;
        }

push @rv, $auth->distributions;
    }

return $self->_pp_ls(
            result  => \@rv,
            class   => $class,
            short   => $short,
            input   => $input );
}

############################
### pretty printing subs ###
############################

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

my( $aref, $short, $class, $input );
    my $tmpl = {
        result  => { required => 1, default => [], strict_type => 1,
                        store => \$aref },
        short   => { default => 0, store => \$short },
        class   => { required => 1, store => \$class },
        input   => { required => 1, store => \$input },
    };

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

### no results
    if( !@$aref ) {
        print "No objects of type $class found for argument $input\n"
            unless $short;

### one result, long output desired;
    } elsif( @$aref == 1 and !$short ) {

### should look like this:
        #cpan> a KANE
        #Author id = KANE
        #    EMAIL        boumans@frg.eur.nl
        #    FULLNAME     Jos Boumans

my $obj = shift @$aref;

print "$class id = ",                   $obj->cpanid(), "\n";
        printf "    %-12s %s\n", 'EMAIL',       $obj->email();
        printf "    %-12s %s%s\n", 'FULLNAME',  $obj->author();

} else {

### should look like this:
        #Author          KANE (Jos Boumans)
        #Author          LBROCARD (Leon Brocard)
        #2 items found

for my $obj ( @$aref ) {
            printf qq[%-15s %s ("%s" (%s))\n],
                $class, $obj->cpanid, $obj->author, $obj->email;
        }
        print scalar(@$aref)." items found\n" unless $short;
    }

return $aref;
}

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

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

### no results
    if( !@$aref ) {
        print "No objects of type $class found for argument $input\n"
            unless $short;

### one result, long output desired;
    } elsif( @$aref == 1 and !$short ) {

### should look like this:
        #Module id = LWP
        #    DESCRIPTION  Libwww-perl
        #    CPAN_USERID  GAAS (Gisle Aas <gisle@ActiveState.com>)
        #    CPAN_VERSION 5.64
        #    CPAN_FILE    G/GA/GAAS/libwww-perl-5.64.tar.gz
        #    DSLI_STATUS  RmpO (released,mailing-list,perl,object-oriented)
        #    MANPAGE      LWP - The World-Wide Web library for Perl
        #    INST_FILE    C:\Perl\site\lib\LWP.pm
        #    INST_VERSION 5.62

my $obj     = shift @$aref;
        my $aut_obj = $obj->author;
        my $format  = "    %-12s %s%s\n";

print "$class id = ",           $obj->module(), "\n";
        printf $format, 'DESCRIPTION',  $obj->description()
            if $obj->description();

printf $format, 'CPAN_USERID',  $aut_obj->cpanid() . " (" .
            $aut_obj->author() . " <" . $aut_obj->email() . ">)";

printf $format, 'CPAN_VERSION', $obj->version();
        printf $format, 'CPAN_FILE',    $obj->path() . '/' . $obj->package();

printf $format, 'DSLI_STATUS',  $self->_pp_dslip($obj->dslip)
            if $obj->dslip() =~ /\w/;

#printf $format, 'MANPAGE',      $obj->foo();
        ### this is for bundles... CPAN.pm downloads them,
        #printf $format, 'CONATAINS,
        # parses and goes from there...

printf $format, 'INST_FILE',    $obj->installed_file ||
            '(not installed)';
        printf $format, 'INST_VERSION', $obj->installed_version;

} else {

### should look like this:
        #Module          LWP             (G/GA/GAAS/libwww-perl-5.64.tar.gz)
        #Module          POE             (R/RC/RCAPUTO/POE-0.19.tar.gz)
        #2 items found

for my $obj ( @$aref ) {
            printf "%-15s %-15s (%s)\n", $class, $obj->module(),
                $obj->path() .'/'. $obj->package();
        }
        print scalar(@$aref). " items found\n" unless $short;
    }

return $aref;
}

sub _pp_dslip {
    my $self    = shift;
    my $dslip   = shift or return;

my (%_statusD, %_statusS, %_statusL, %_statusI);

@_statusD{qw(? i c a b R M S)} =
        qw(unknown idea pre-alpha alpha beta released mature standard);

@_statusS{qw(? m d u n)}       =
        qw(unknown mailing-list developer comp.lang.perl.* none);

@_statusL{qw(? p c + o h)}     = qw(unknown perl C C++ other hybrid);
    @_statusI{qw(? f r O h)}       =
        qw(unknown functions references+ties object-oriented hybrid);

my @status = split("", $dslip);

my $results = sprintf( "%s (%s,%s,%s,%s)",
        $dslip,
        $_statusD{$status[0]},
        $_statusS{$status[1]},
        $_statusL{$status[2]},
        $_statusI{$status[3]}
    );

return $results;
}

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

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

### no results
    if( !@$aref ) {
        print "No objects of type $class found for argument $input\n"
            unless $short;

### one result, long output desired;
    } elsif( @$aref == 1 and !$short ) {

### should look like this:
        #Distribution id = S/SA/SABECK/POE-Component-Client-POP3-0.02.tar.gz
        #    CPAN_USERID  SABECK (Scott Beck <scott@gossamer-threads.com>)
        #    CONTAINSMODS POE::Component::Client::POP3

my $obj     = shift @$aref;
        my $aut_obj = $obj->author;
        my $pkg     = $obj->package;
        my $format  = "    %-12s %s\n";

my @list    = $cb->search(  type    => 'package',
                                    allow   => [qr/^$pkg$/] );

print "$class id = ", $obj->path(), '/', $obj->package(), "\n";
        printf $format, 'CPAN_USERID',
                    $aut_obj->cpanid .' ('. $aut_obj->author .
                    ' '. $aut_obj->email .')';

### yes i know it's ugly, but it's what cpan.pm does
        printf $format, 'CONTAINSMODS', join (' ', map { $_->module } @list);

} else {

### should look like this:
        #Distribution    LWP             (G/GA/GAAS/libwww-perl-5.64.tar.gz)
        #Distribution    POE             (R/RC/RCAPUTO/POE-0.19.tar.gz)
        #2 items found

for my $obj ( @$aref ) {
            printf "%-15s %s\n", $class, $obj->path() .'/'. $obj->package();
        }

print scalar(@$aref). " items found\n" unless $short;
    }

return $aref;
}

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

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

my $format  = "%-25s %9s %9s  %s\n";

my @not_uptodate;
    my $no_version;

my %seen;
    for my $mod (@$aref) {
        next if $mod->package_is_perl_core;
        next if $seen{ $mod->package }++;

if( $mod->installed_file and not $mod->installed_version ) {
            $no_version++;
            next;
        }

push @not_uptodate, $mod unless $mod->is_uptodate;
    }

unless( @not_uptodate ) {
        my $string = $input
                        ? "for $input"
                        : '';
        print "All modules are up to date $string\n";
        return;

} else {
        printf $format, (   'Package namespace',
                            'installed',
                            'latest',
                            'in CPAN file'
                        );
    }

for my $mod ( sort { $a->module cmp $b->module } @not_uptodate ) {
        printf $format, (   $mod->module,
                            $mod->installed_version,
                            $mod->version,
                            $mod->path .'/'. $mod->package,
                        );
    }

print "$no_version installed modules have no (parsable) version number\n"
        if $no_version;

return \@not_uptodate;
}

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

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

### should look something like this:
    #6272 2002-05-12 KANE/Acme-Comment-1.00.tar.gz
    #8171 2002-08-13 KANE/Acme-Comment-1.01.zip
    #7110 2002-09-04 KANE/Acme-Comment-1.02.tar.gz
    #7571 2002-09-08 KANE/Acme-Intraweb-1.01.tar.gz
    #6625 2001-08-23 KANE/Acme-POE-Knee-1.10.zip
    #3058 2003-10-05 KANE/Acme-Test-0.02.tar.gz

### don't know size or mtime
    #my $format = "%8d %10s %s/%s\n";

for my $mod ( sort { $a->package cmp $b->package } @$aref ) {
        print "\t" . $mod->package . "\n";
    }

return $aref;
}

#############################
### end pretty print subs ###
#############################

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

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

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

eval $input;
    warn $@ if $@;

print "\n";

return;
}

sub _help {
    print qq[
Display Information
 a                                    authors
 b         string           display   bundles
 d         or               info      distributions
 m         /regex/          about     modules
 i         or                         anything of above
 r         none             reinstall recommendations
 u                          uninstalled distributions

Download, Test, Make, Install...
 get                        download
 make                       make (implies get)
 test      modules,         make test (implies make)
 install   dists, bundles   make install (implies test)
 clean                      make clean
 look                       open subshell in these dists' directories
 readme                     display these dists' README files

Other
 h,?           display this menu       ! perl-code   eval a perl command
 o conf [opt]  set and query options   q             quit the cpan shell
 reload cpan   load CPAN.pm again      reload index  load newer indices
 autobundle    Snapshot                force cmd     unconditionally do cmd
];

}

1;
__END__

=pod

=head1 NAME

CPANPLUS::Shell::Classic - CPAN.pm emulation for CPANPLUS

=head1 DESCRIPTION

The Classic shell is designed to provide the feel of the CPAN.pm shell
using CPANPLUS underneath.

For detailed documentation, refer to L<CPAN>.

=head1 BUG REPORTS

Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.

=head1 AUTHOR

This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.

=head1 COPYRIGHT

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

=head1 SEE ALSO

L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>

=cut

=head1 SEE ALSO

L<CPAN>

=cut

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:

Cancel