diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/CPANPLUS/Shell/Classic.pm')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/CPANPLUS/Shell/Classic.pm | 1236 |
1 files changed, 1236 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/CPANPLUS/Shell/Classic.pm b/Master/tlpkg/tlperl0/lib/CPANPLUS/Shell/Classic.pm new file mode 100755 index 00000000000..08c03bcf383 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/CPANPLUS/Shell/Classic.pm @@ -0,0 +1,1236 @@ +################################################## +### 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 }, + }; + + 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 = @_; + + 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: |