1269 lines
34 KiB
Perl
1269 lines
34 KiB
Perl
##################################################
|
|
### 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.9910";
|
|
}
|
|
|
|
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 don't 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 don't 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 don't 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 don't 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 = @_;
|
|
|
|
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:
|
|
#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 = @_;
|
|
|
|
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:
|
|
#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 = @_;
|
|
|
|
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;
|
|
|
|
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 = @_;
|
|
|
|
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;
|
|
|
|
### 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
|
|
|
|
The CPAN++ interface (of which this module is a part of) is copyright (c)
|
|
2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
|
|
|
|
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:
|