1 ##################################################
2 ### CPANPLUS/Shell/Classic.pm ###
3 ### Backwards compatible shell for CPAN++ ###
4 ### Written 08-04-2002 by Jos Boumans ###
5 ##################################################
7 package CPANPLUS::Shell::Classic;
13 use CPANPLUS::Backend;
14 use CPANPLUS::Configure::Setup;
15 use CPANPLUS::Internals::Constants;
23 use Module::Load qw[load];
24 use Params::Check qw[check];
25 use Module::Load::Conditional qw[can_load];
27 $Params::Check::VERBOSE = 1;
28 $Params::Check::ALLOW_UNKNOWN = 1;
31 use vars qw[ $VERSION @ISA ];
32 @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ];
39 ### our command set ###
47 u => '_not_supported',
52 install => '_install',
53 clean => '_not_supported',
60 autobundle => '_autobundle',
62 #'q' => '_quit', # done it the loop itself
65 ### the shell object, scoped to the file ###
68 my $Prompt = $Brand . '> ';
73 my $cb = new CPANPLUS::Backend;
74 my $self = $class->SUPER::_init(
76 term => Term::ReadLine->new( $Brand ),
79 format => "%5s %-50s %8s %-10s\n",
81 ### make it available package wide ###
84 ### enable verbose, it's the cpan.pm way
85 $cb->configure_object->set_conf( verbose => 1 );
88 ### register install callback ###
89 $cb->_register_callback(
90 name => 'install_prerequisite',
91 code => \&__ask_about_install,
94 ### register test report callback ###
95 $cb->_register_callback(
96 name => 'edit_test_report',
97 code => \&__ask_about_test_report,
105 my $term = $self->term;
108 $self->_input_loop && print "\n";
114 my $term = $self->term;
115 my $cb = $self->backend;
119 defined (my $input = eval { $term->readline($self->prompt) } )
120 or $self->_signals->{INT}{count} == 1
122 ### re-initiate all signal handlers
123 while (my ($sig, $entry) = each %{$self->_signals} ) {
124 $SIG{$sig} = $entry->{handler} if exists($entry->{handler});
127 last if $self->_dispatch_on_input( input => $input );
129 ### flush the lib cache ###
130 $cb->_flush( list => [qw|lib load|] );
133 $self->_signals->{INT}{count}--
134 if $self->_signals->{INT}{count}; # clear the sigint count
140 sub _dispatch_on_input {
142 my $conf = $self->backend->configure_object();
143 my $term = $self->term;
148 input => { required => 1, store => \$string }
151 check( $tmpl, \%hash ) or return;
153 ### the original force setting;
154 my $force_store = $conf->get_conf( 'force' );
156 ### parse the input: the first part before the space
157 ### is the command, followed by arguments.
158 ### see the usage below
161 $string =~ s|^\s*([\w\?\!]+)\s*||;
166 ### you prefixed the input with 'force'
167 ### that means we set the force flag, and
168 ### reparse the input...
169 ### YAY goto block :)
170 if( $key eq 'force' ) {
171 $conf->set_conf( force => 1 );
176 return 1 if $key =~ /^q/;
178 my $method = $map->{$key};
179 unless( $self->can( $method ) ) {
180 print "Unknown command '$key'. Type ? for help.\n";
184 ### dispatch the method call
185 eval { $self->$method(
187 result => [ split /\s+/, $string ],
195 ### displays quit message
198 ### well, that's what CPAN.pm says...
199 print "Lockfile removed\n";
208 command => { required => 1, store => \$cmd }
211 check( $tmpl, \%hash ) or return;
213 print "Sorry, the command '$cmd' is not supported\n";
220 my $cb = $self->backend;
225 result => { store => \$aref, default => [] },
226 input => { default => 'all', store => \$input },
229 check( $tmpl, \%hash ) or return;
231 for my $mod (@$aref) {
234 unless( $obj = $cb->module_tree($mod) ) {
235 print "Warning: Cannot get $input, don't know what it is\n";
236 print "Try the command\n\n";
237 print "\ti /$mod/\n\n";
238 print "to find objects with matching identifiers.\n";
243 $obj->fetch && $obj->extract;
251 my $cb = $self->backend;
255 make => { target => TARGET_CREATE, skiptest => 1 },
256 test => { target => TARGET_CREATE },
257 install => { target => TARGET_INSTALL },
262 result => { store => \$aref, default => [] },
263 command => { required => 1, store => \$cmd, allow => [keys %$mapping] },
266 check( $tmpl, \%hash ) or return;
268 for my $mod (@$aref) {
269 my $obj = $cb->module_tree( $mod );
272 print "No such module '$mod'\n";
276 my $opts = $mapping->{$cmd};
277 $obj->install( %$opts );
285 my $cb = $self->backend;
286 my $conf = $cb->configure_object;
291 result => { store => \$aref, default => [] },
292 command => { required => 1, store => \$cmd },
296 check( $tmpl, \%hash ) or return;
299 my $shell = $conf->get_program('shell');
301 print "Your configuration does not define a value for subshells.\n".
302 qq[Please define it with "o conf shell <your shell>"\n];
306 my $cwd = Cwd::cwd();
308 for my $mod (@$aref) {
309 print "Running $cmd for $mod\n";
311 my $obj = $cb->module_tree( $mod ) or next;
313 $obj->extract or next;
315 $cb->_chdir( dir => $obj->status->extract ) or next;
317 #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt;
318 if( system($shell) and $! ) {
319 print "Error executing your subshell '$shell': $!\n";
323 $cb->_chdir( dir => $cwd );
330 my $cb = $self->backend;
331 my $conf = $cb->configure_object;
336 result => { store => \$aref, default => [] },
337 command => { required => 1, store => \$cmd },
341 check( $tmpl, \%hash ) or return;
343 for my $mod (@$aref) {
344 my $obj = $cb->module_tree( $mod ) or next;
346 if( my $readme = $obj->readme ) {
359 my $cb = $self->backend;
360 my $conf = $cb->configure_object;
365 input => { default => 'all', store => \$input },
366 command => { required => 1, store => \$cmd },
370 check( $tmpl, \%hash ) or return;
372 if ( $input =~ /cpan/i ) {
373 print qq[You want to reload the CPAN code\n];
374 print qq[Just type 'q' and then restart... ] .
375 qq[Trust me, it is MUCH safer\n];
377 } elsif ( $input =~ /index/i ) {
378 $cb->reload_indices(update_source => 1);
381 print qq[cpan re-evals the CPANPLUS.pm file\n];
382 print qq[index re-reads the index files\n];
390 my $cb = $self->backend;
392 print qq[Writing bundle file... This may take a while\n];
394 my $where = $cb->autobundle();
397 ? qq[\nWrote autobundle to $where\n]
398 : qq[\nCould not create autobundle\n];
405 my $cb = $self->backend;
406 my $conf = $cb->configure_object;
411 result => { store => \$aref, default => [] },
412 input => { default => 'all', store => \$input },
415 check( $tmpl, \%hash ) or return;
417 my $type = shift @$aref;
419 if( $type eq 'debug' ) {
420 print qq[Sorry you cannot set debug options through ] .
421 qq[this shell in CPANPLUS\n];
424 } elsif ( $type eq 'conf' ) {
427 # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
428 # should have been called set and 'o debug' maybe 'set debug'
430 # commit Commit changes to disk
431 # defaults Reload defaults from disk
432 # init Interactive setting of all options
434 my $name = shift @$aref;
435 my $value = "@$aref";
437 if( $name eq 'init' ) {
438 my $setup = CPANPLUS::Configure::Setup->new(
439 conf => $cb->configure_object,
445 } elsif ($name eq 'commit' ) {;
446 $cb->configure_object->save;
447 print "Your CPAN++ configuration info has been saved!\n\n";
450 } elsif ($name eq 'defaults' ) {
451 print qq[Sorry, CPANPLUS cannot restore default for you.\n] .
452 qq[Perhaps you should run the interactive setup again.\n] .
453 qq[\ttry running 'o conf init'\n];
456 ### we're just supplying things in the 'conf' section now,
457 ### not the program section.. it's a bit of a hassle to make that
458 ### work cleanly with the original CPAN.pm interface, so we'll fix
459 ### it when people start complaining, which is hopefully never.
462 my @list = grep { $_ ne 'hosts' }
463 $conf->options( type => $type );
465 my $method = 'get_' . $type;
467 local $Data::Dumper::Indent = 0;
468 for my $name ( @list ) {
469 my $val = $conf->$method($name);
471 ? (Data::Dumper::Dumper($val) =~ /= (.*);$/)
473 printf " %-25s %s\n", $name, $val;
476 } elsif ( $name eq 'hosts' ) {
477 print "Setting hosts is not trivial.\n" .
478 "It is suggested you edit the " .
479 "configuration file manually";
482 my $method = 'set_' . $type;
483 if( $conf->$method($name => defined $value ? $value : '') ) {
484 my $set_to = defined $value ? $value : 'EMPTY STRING';
485 print "Key '$name' was set to '$set_to'\n";
490 print qq[Known options:\n] .
491 qq[ conf set or get configuration variables\n] .
492 qq[ debug set or get debugging options\n];
498 ########################
499 ### search functions ###
500 ########################
504 my $cb = $self->backend;
507 my($aref, $short, $input, $class);
509 result => { store => \$aref, default => ['/./'] },
510 short => { default => 0, store => \$short },
511 input => { default => 'all', store => \$input },
512 class => { default => 'Author', no_override => 1,
516 check( $tmpl, \%hash ) or return;
518 my @regexes = map { m|/(.+)/| ? qr/$1/ : $_ } @$aref;
522 for my $type (qw[author cpanid]) {
523 push @rv, $cb->search( type => $type, allow => \@regexes );
527 print "No object of type $class found for argument $input\n"
532 return $self->_pp_author(
540 ### find all modules matching a query ###
543 my $cb = $self->backend;
546 my($aref, $short, $input, $class);
548 result => { store => \$aref, default => ['/./'] },
549 short => { default => 0, store => \$short },
550 input => { default => 'all', store => \$input },
551 class => { default => 'Module', no_override => 1,
555 check( $tmpl, \%hash ) or return;
558 for my $module (@$aref) {
559 if( $module =~ m|/(.+)/| ) {
560 push @rv, $cb->search( type => 'module',
561 allow => [qr/$1/i] );
563 my $obj = $cb->module_tree( $module ) or next;
568 return $self->_pp_module(
575 ### find all bundles matching a query ###
578 my $cb = $self->backend;
581 my($aref, $short, $input, $class);
583 result => { store => \$aref, default => ['/./'] },
584 short => { default => 0, store => \$short },
585 input => { default => 'all', store => \$input },
586 class => { default => 'Bundle', no_override => 1,
590 check( $tmpl, \%hash ) or return;
593 for my $bundle (@$aref) {
594 if( $bundle =~ m|/(.+)/| ) {
595 push @rv, $cb->search( type => 'module',
596 allow => [qr/Bundle::.*?$1/i] );
598 my $obj = $cb->module_tree( "Bundle::${bundle}" ) or next;
603 return $self->_pp_module(
612 my $cb = $self->backend;
615 my($aref, $short, $input, $class);
617 result => { store => \$aref, default => ['/./'] },
618 short => { default => 0, store => \$short },
619 input => { default => 'all', store => \$input },
620 class => { default => 'Distribution', no_override => 1,
624 check( $tmpl, \%hash ) or return;
627 for my $module (@$aref) {
628 ### if it's a regex... ###
629 if ( my ($match) = $module =~ m|^/(.+)/$|) {
631 ### something like /FOO/Bar.tar.gz/ was entered
632 if (my ($path,$package) = $match =~ m|^/?(.+)/(.+)$|) {
635 my @data = $cb->search( type => 'package',
636 allow => [qr/$package/i] );
638 my @list = $cb->search( type => 'path',
639 allow => [qr/$path/i],
642 ### make sure we dont list the same dist twice
643 for my $val ( @list ) {
644 next if $seen->{$val->package}++;
649 ### something like /FOO/ or /Bar.tgz/ was entered
650 ### so we look both in the path, as well as in the package name
653 { my @list = $cb->search( type => 'package',
654 allow => [qr/$match/i] );
656 ### make sure we dont list the same dist twice
657 for my $val ( @list ) {
658 next if $seen->{$val->package}++;
664 { my @list = $cb->search( type => 'path',
665 allow => [qr/$match/i] );
667 ### make sure we dont list the same dist twice
668 for my $val ( @list ) {
669 next if $seen->{$val->package}++;
679 ### user entered a full dist, like: R/RC/RCAPUTO/POE-0.19.tar.gz
680 if (my ($path,$package) = $module =~ m|^/?(.+)/(.+)$|) {
681 my @data = $cb->search( type => 'package',
682 allow => [qr/^$package$/] );
683 my @list = $cb->search( type => 'path',
684 allow => [qr/$path$/i],
687 ### make sure we dont list the same dist twice
689 for my $val ( @list ) {
690 next if $seen->{$val->package}++;
698 return $self->_pp_distribution(
709 for my $method (qw[_author _bundle _module _distribution]) {
710 my $aref = $self->$method( @_, short => 1 );
712 push @rv, @$aref if $aref;
715 print scalar(@rv). " items found\n"
720 my $cb = $self->backend;
723 my($aref, $short, $input, $class);
725 result => { store => \$aref, default => ['/./'] },
726 short => { default => 0, store => \$short },
727 input => { default => 'all', store => \$input },
728 class => { default => 'Uptodate', no_override => 1,
732 check( $tmpl, \%hash ) or return;
737 for my $module (@$aref) {
738 if( $module =~ m|/(.+)/| ) {
739 my @list = $cb->search( type => 'module',
740 allow => [qr/$1/i] );
742 ### only add those that are installed and not core
743 push @rv, grep { not $_->package_is_perl_core }
744 grep { $_->installed_file }
748 my $obj = $cb->module_tree( $module ) or next;
753 @rv = @{$cb->_all_installed};
756 return $self->_pp_uptodate(
765 my $cb = $self->backend;
768 my($aref, $short, $input, $class);
770 result => { store => \$aref, default => [] },
771 short => { default => 0, store => \$short },
772 input => { default => 'all', store => \$input },
773 class => { default => 'Uptodate', no_override => 1,
777 check( $tmpl, \%hash ) or return;
780 for my $name (@$aref) {
781 my $auth = $cb->author_tree( uc $name );
784 print qq[ls command rejects argument $name: not an author\n];
788 push @rv, $auth->distributions;
791 return $self->_pp_ls(
798 ############################
799 ### pretty printing subs ###
800 ############################
807 my( $aref, $short, $class, $input );
809 result => { required => 1, default => [], strict_type => 1,
811 short => { default => 0, store => \$short },
812 class => { required => 1, store => \$class },
813 input => { required => 1, store => \$input },
816 check( $tmpl, \%hash ) or return;
820 print "No objects of type $class found for argument $input\n"
823 ### one result, long output desired;
824 } elsif( @$aref == 1 and !$short ) {
826 ### should look like this:
829 # EMAIL boumans@frg.eur.nl
830 # FULLNAME Jos Boumans
832 my $obj = shift @$aref;
834 print "$class id = ", $obj->cpanid(), "\n";
835 printf " %-12s %s\n", 'EMAIL', $obj->email();
836 printf " %-12s %s%s\n", 'FULLNAME', $obj->author();
840 ### should look like this:
841 #Author KANE (Jos Boumans)
842 #Author LBROCARD (Leon Brocard)
845 for my $obj ( @$aref ) {
846 printf qq[%-15s %s ("%s" (%s))\n],
847 $class, $obj->cpanid, $obj->author, $obj->email;
849 print scalar(@$aref)." items found\n" unless $short;
859 my( $aref, $short, $class, $input );
861 result => { required => 1, default => [], strict_type => 1,
863 short => { default => 0, store => \$short },
864 class => { required => 1, store => \$class },
865 input => { required => 1, store => \$input },
868 check( $tmpl, \%hash ) or return;
873 print "No objects of type $class found for argument $input\n"
876 ### one result, long output desired;
877 } elsif( @$aref == 1 and !$short ) {
880 ### should look like this:
882 # DESCRIPTION Libwww-perl
883 # CPAN_USERID GAAS (Gisle Aas <gisle@ActiveState.com>)
885 # CPAN_FILE G/GA/GAAS/libwww-perl-5.64.tar.gz
886 # DSLI_STATUS RmpO (released,mailing-list,perl,object-oriented)
887 # MANPAGE LWP - The World-Wide Web library for Perl
888 # INST_FILE C:\Perl\site\lib\LWP.pm
891 my $obj = shift @$aref;
892 my $aut_obj = $obj->author;
893 my $format = " %-12s %s%s\n";
895 print "$class id = ", $obj->module(), "\n";
896 printf $format, 'DESCRIPTION', $obj->description()
897 if $obj->description();
899 printf $format, 'CPAN_USERID', $aut_obj->cpanid() . " (" .
900 $aut_obj->author() . " <" . $aut_obj->email() . ">)";
902 printf $format, 'CPAN_VERSION', $obj->version();
903 printf $format, 'CPAN_FILE', $obj->path() . '/' . $obj->package();
905 printf $format, 'DSLI_STATUS', $self->_pp_dslip($obj->dslip)
906 if $obj->dslip() =~ /\w/;
908 #printf $format, 'MANPAGE', $obj->foo();
909 ### this is for bundles... CPAN.pm downloads them,
910 #printf $format, 'CONATAINS,
911 # parses and goes from there...
913 printf $format, 'INST_FILE', $obj->installed_file ||
915 printf $format, 'INST_VERSION', $obj->installed_version;
921 ### should look like this:
922 #Module LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz)
923 #Module POE (R/RC/RCAPUTO/POE-0.19.tar.gz)
926 for my $obj ( @$aref ) {
927 printf "%-15s %-15s (%s)\n", $class, $obj->module(),
928 $obj->path() .'/'. $obj->package();
930 print scalar(@$aref). " items found\n" unless $short;
938 my $dslip = shift or return;
940 my (%_statusD, %_statusS, %_statusL, %_statusI);
942 @_statusD{qw(? i c a b R M S)} =
943 qw(unknown idea pre-alpha alpha beta released mature standard);
945 @_statusS{qw(? m d u n)} =
946 qw(unknown mailing-list developer comp.lang.perl.* none);
948 @_statusL{qw(? p c + o h)} = qw(unknown perl C C++ other hybrid);
949 @_statusI{qw(? f r O h)} =
950 qw(unknown functions references+ties object-oriented hybrid);
952 my @status = split("", $dslip);
954 my $results = sprintf( "%s (%s,%s,%s,%s)",
956 $_statusD{$status[0]},
957 $_statusS{$status[1]},
958 $_statusL{$status[2]},
959 $_statusI{$status[3]}
965 sub _pp_distribution {
967 my $cb = $self->backend;
970 my( $aref, $short, $class, $input );
972 result => { required => 1, default => [], strict_type => 1,
974 short => { default => 0, store => \$short },
975 class => { required => 1, store => \$class },
976 input => { required => 1, store => \$input },
979 check( $tmpl, \%hash ) or return;
984 print "No objects of type $class found for argument $input\n"
987 ### one result, long output desired;
988 } elsif( @$aref == 1 and !$short ) {
991 ### should look like this:
992 #Distribution id = S/SA/SABECK/POE-Component-Client-POP3-0.02.tar.gz
993 # CPAN_USERID SABECK (Scott Beck <scott@gossamer-threads.com>)
994 # CONTAINSMODS POE::Component::Client::POP3
996 my $obj = shift @$aref;
997 my $aut_obj = $obj->author;
998 my $pkg = $obj->package;
999 my $format = " %-12s %s\n";
1001 my @list = $cb->search( type => 'package',
1002 allow => [qr/^$pkg$/] );
1005 print "$class id = ", $obj->path(), '/', $obj->package(), "\n";
1006 printf $format, 'CPAN_USERID',
1007 $aut_obj->cpanid .' ('. $aut_obj->author .
1008 ' '. $aut_obj->email .')';
1010 ### yes i know it's ugly, but it's what cpan.pm does
1011 printf $format, 'CONTAINSMODS', join (' ', map { $_->module } @list);
1015 ### should look like this:
1016 #Distribution LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz)
1017 #Distribution POE (R/RC/RCAPUTO/POE-0.19.tar.gz)
1020 for my $obj ( @$aref ) {
1021 printf "%-15s %s\n", $class, $obj->path() .'/'. $obj->package();
1024 print scalar(@$aref). " items found\n" unless $short;
1032 my $cb = $self->backend;
1035 my( $aref, $short, $class, $input );
1037 result => { required => 1, default => [], strict_type => 1,
1039 short => { default => 0, store => \$short },
1040 class => { required => 1, store => \$class },
1041 input => { required => 1, store => \$input },
1044 check( $tmpl, \%hash ) or return;
1046 my $format = "%-25s %9s %9s %s\n";
1052 for my $mod (@$aref) {
1053 next if $mod->package_is_perl_core;
1054 next if $seen{ $mod->package }++;
1057 if( $mod->installed_file and not $mod->installed_version ) {
1062 push @not_uptodate, $mod unless $mod->is_uptodate;
1065 unless( @not_uptodate ) {
1069 print "All modules are up to date $string\n";
1073 printf $format, ( 'Package namespace',
1080 for my $mod ( sort { $a->module cmp $b->module } @not_uptodate ) {
1081 printf $format, ( $mod->module,
1082 $mod->installed_version,
1084 $mod->path .'/'. $mod->package,
1088 print "$no_version installed modules have no (parsable) version number\n"
1091 return \@not_uptodate;
1096 my $cb = $self->backend;
1099 my( $aref, $short, $class, $input );
1101 result => { required => 1, default => [], strict_type => 1,
1103 short => { default => 0, store => \$short },
1104 class => { required => 1, store => \$class },
1105 input => { required => 1, store => \$input },
1108 check( $tmpl, \%hash ) or return;
1110 ### should look something like this:
1111 #6272 2002-05-12 KANE/Acme-Comment-1.00.tar.gz
1112 #8171 2002-08-13 KANE/Acme-Comment-1.01.zip
1113 #7110 2002-09-04 KANE/Acme-Comment-1.02.tar.gz
1114 #7571 2002-09-08 KANE/Acme-Intraweb-1.01.tar.gz
1115 #6625 2001-08-23 KANE/Acme-POE-Knee-1.10.zip
1116 #3058 2003-10-05 KANE/Acme-Test-0.02.tar.gz
1118 ### don't know size or mtime
1119 #my $format = "%8d %10s %s/%s\n";
1121 for my $mod ( sort { $a->package cmp $b->package } @$aref ) {
1122 print "\t" . $mod->package . "\n";
1129 #############################
1130 ### end pretty print subs ###
1131 #############################
1140 input => { required => 1, store => \$input },
1143 check( $tmpl, \%hash ) or return;
1157 b string display bundles
1158 d or info distributions
1159 m /regex/ about modules
1160 i or anything of above
1161 r none reinstall recommendations
1162 u uninstalled distributions
1164 Download, Test, Make, Install...
1166 make make (implies get)
1167 test modules, make test (implies make)
1168 install dists, bundles make install (implies test)
1170 look open subshell in these dists' directories
1171 readme display these dists' README files
1174 h,? display this menu ! perl-code eval a perl command
1175 o conf [opt] set and query options q quit the cpan shell
1176 reload cpan load CPAN.pm again reload index load newer indices
1177 autobundle Snapshot force cmd unconditionally do cmd
1191 CPANPLUS::Shell::Classic - CPAN.pm emulation for CPANPLUS
1195 The Classic shell is designed to provide the feel of the CPAN.pm shell
1196 using CPANPLUS underneath.
1198 For detailed documentation, refer to L<CPAN>.
1202 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
1206 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1210 The CPAN++ interface (of which this module is a part of) is copyright (c)
1211 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
1213 This library is free software; you may redistribute and/or modify it
1214 under the same terms as Perl itself.
1218 L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>
1232 # c-indentation-style: bsd
1234 # indent-tabs-mode: nil
1236 # vim: expandtab shiftwidth=4: