Commit | Line | Data |
6aaee015 |
1 | ################################################## |
2 | ### CPANPLUS/Shell/Classic.pm ### |
3 | ### Backwards compatible shell for CPAN++ ### |
4 | ### Written 08-04-2002 by Jos Boumans ### |
5 | ################################################## |
6 | |
7 | package CPANPLUS::Shell::Classic; |
8 | |
9 | use strict; |
10 | |
11 | |
12 | use CPANPLUS::Error; |
13 | use CPANPLUS::Backend; |
14 | use CPANPLUS::Configure::Setup; |
15 | use CPANPLUS::Internals::Constants; |
16 | |
17 | use Cwd; |
18 | use IPC::Cmd; |
19 | use Term::UI; |
20 | use Data::Dumper; |
21 | use Term::ReadLine; |
22 | |
23 | use Module::Load qw[load]; |
24 | use Params::Check qw[check]; |
25 | use Module::Load::Conditional qw[can_load]; |
26 | |
27 | $Params::Check::VERBOSE = 1; |
28 | $Params::Check::ALLOW_UNKNOWN = 1; |
29 | |
30 | BEGIN { |
31 | use vars qw[ $VERSION @ISA ]; |
32 | @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; |
33 | $VERSION = '0.0562'; |
34 | } |
35 | |
36 | load CPANPLUS::Shell; |
37 | |
38 | |
39 | ### our command set ### |
40 | my $map = { |
41 | a => '_author', |
42 | b => '_bundle', |
43 | d => '_distribution', |
44 | 'm' => '_module', |
45 | i => '_find_all', |
46 | r => '_uptodate', |
47 | u => '_not_supported', |
48 | ls => '_ls', |
49 | get => '_fetch', |
50 | make => '_install', |
51 | test => '_install', |
52 | install => '_install', |
53 | clean => '_not_supported', |
54 | look => '_shell', |
55 | readme => '_readme', |
56 | h => '_help', |
57 | '?' => '_help', |
58 | o => '_set_conf', |
59 | reload => '_reload', |
60 | autobundle => '_autobundle', |
61 | '!' => '_bang', |
62 | #'q' => '_quit', # done it the loop itself |
63 | }; |
64 | |
65 | ### the shell object, scoped to the file ### |
66 | my $Shell; |
67 | my $Brand = 'cpan'; |
68 | my $Prompt = $Brand . '> '; |
69 | |
70 | sub new { |
71 | my $class = shift; |
72 | |
73 | my $cb = new CPANPLUS::Backend; |
74 | my $self = $class->SUPER::_init( |
75 | brand => $Brand, |
76 | term => Term::ReadLine->new( $Brand ), |
77 | prompt => $Prompt, |
78 | backend => $cb, |
79 | format => "%5s %-50s %8s %-10s\n", |
80 | ); |
81 | ### make it available package wide ### |
82 | $Shell = $self; |
83 | |
84 | ### enable verbose, it's the cpan.pm way |
85 | $cb->configure_object->set_conf( verbose => 1 ); |
86 | |
87 | |
88 | ### register install callback ### |
89 | $cb->_register_callback( |
90 | name => 'install_prerequisite', |
91 | code => \&__ask_about_install, |
92 | ); |
93 | |
94 | ### register test report callback ### |
95 | $cb->_register_callback( |
96 | name => 'edit_test_report', |
97 | code => \&__ask_about_test_report, |
98 | ); |
99 | |
100 | return $self; |
101 | } |
102 | |
103 | sub shell { |
104 | my $self = shift; |
105 | my $term = $self->term; |
106 | |
107 | $self->_show_banner; |
108 | $self->_input_loop && print "\n"; |
109 | $self->_quit; |
110 | } |
111 | |
112 | sub _input_loop { |
113 | my $self = shift; |
114 | my $term = $self->term; |
115 | my $cb = $self->backend; |
116 | |
117 | my $normal_quit = 0; |
118 | while ( |
119 | defined (my $input = eval { $term->readline($self->prompt) } ) |
120 | or $self->_signals->{INT}{count} == 1 |
121 | ) { |
122 | ### re-initiate all signal handlers |
123 | while (my ($sig, $entry) = each %{$self->_signals} ) { |
124 | $SIG{$sig} = $entry->{handler} if exists($entry->{handler}); |
125 | } |
126 | |
127 | last if $self->_dispatch_on_input( input => $input ); |
128 | |
129 | ### flush the lib cache ### |
130 | $cb->_flush( list => [qw|lib load|] ); |
131 | |
132 | } continue { |
133 | $self->_signals->{INT}{count}-- |
134 | if $self->_signals->{INT}{count}; # clear the sigint count |
135 | } |
136 | |
137 | return 1; |
138 | } |
139 | |
140 | sub _dispatch_on_input { |
141 | my $self = shift; |
142 | my $conf = $self->backend->configure_object(); |
143 | my $term = $self->term; |
144 | my %hash = @_; |
145 | |
146 | my $string; |
147 | my $tmpl = { |
148 | input => { required => 1, store => \$string } |
149 | }; |
150 | |
151 | check( $tmpl, \%hash ) or return; |
152 | |
153 | ### the original force setting; |
154 | my $force_store = $conf->get_conf( 'force' ); |
155 | |
156 | ### parse the input: the first part before the space |
157 | ### is the command, followed by arguments. |
158 | ### see the usage below |
159 | my $key; |
160 | PARSE_INPUT: { |
161 | $string =~ s|^\s*([\w\?\!]+)\s*||; |
162 | chomp $string; |
163 | $key = lc($1); |
164 | } |
165 | |
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 ); |
172 | goto PARSE_INPUT; |
173 | } |
174 | |
175 | ### you want to quit |
176 | return 1 if $key =~ /^q/; |
177 | |
178 | my $method = $map->{$key}; |
179 | unless( $self->can( $method ) ) { |
180 | print "Unknown command '$key'. Type ? for help.\n"; |
181 | return; |
182 | } |
183 | |
184 | ### dispatch the method call |
185 | eval { $self->$method( |
186 | command => $key, |
187 | result => [ split /\s+/, $string ], |
188 | input => $string ); |
189 | }; |
190 | warn $@ if $@; |
191 | |
192 | return; |
193 | } |
194 | |
195 | ### displays quit message |
196 | sub _quit { |
197 | |
198 | ### well, that's what CPAN.pm says... |
199 | print "Lockfile removed\n"; |
200 | } |
201 | |
202 | sub _not_supported { |
203 | my $self = shift; |
204 | my %hash = @_; |
205 | |
206 | my $cmd; |
207 | my $tmpl = { |
208 | command => { required => 1, store => \$cmd } |
209 | }; |
210 | |
211 | check( $tmpl, \%hash ) or return; |
212 | |
213 | print "Sorry, the command '$cmd' is not supported\n"; |
214 | |
215 | return; |
216 | } |
217 | |
218 | sub _fetch { |
219 | my $self = shift; |
220 | my $cb = $self->backend; |
221 | my %hash = @_; |
222 | |
223 | my($aref, $input); |
224 | my $tmpl = { |
225 | result => { store => \$aref, default => [] }, |
226 | input => { default => 'all', store => \$input }, |
227 | }; |
228 | |
229 | check( $tmpl, \%hash ) or return; |
230 | |
231 | for my $mod (@$aref) { |
232 | my $obj; |
233 | |
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"; |
239 | |
240 | next; |
241 | } |
242 | |
243 | $obj->fetch && $obj->extract; |
244 | } |
245 | |
246 | return $aref; |
247 | } |
248 | |
249 | sub _install { |
250 | my $self = shift; |
251 | my $cb = $self->backend; |
252 | my %hash = @_; |
253 | |
254 | my $mapping = { |
255 | make => { target => TARGET_CREATE, skiptest => 1 }, |
256 | test => { target => TARGET_CREATE }, |
257 | install => { target => TARGET_INSTALL }, |
258 | }; |
259 | |
260 | my($aref,$cmd); |
261 | my $tmpl = { |
262 | result => { store => \$aref, default => [] }, |
263 | command => { required => 1, store => \$cmd, allow => [keys %$mapping] }, |
264 | }; |
265 | |
266 | check( $tmpl, \%hash ) or return; |
267 | |
268 | for my $mod (@$aref) { |
269 | my $obj = $cb->module_tree( $mod ); |
270 | |
271 | unless( $obj ) { |
272 | print "No such module '$mod'\n"; |
273 | next; |
274 | } |
275 | |
276 | my $opts = $mapping->{$cmd}; |
277 | $obj->install( %$opts ); |
278 | } |
279 | |
280 | return $aref; |
281 | } |
282 | |
283 | sub _shell { |
284 | my $self = shift; |
285 | my $cb = $self->backend; |
286 | my $conf = $cb->configure_object; |
287 | my %hash = @_; |
288 | |
289 | my($aref, $cmd); |
290 | my $tmpl = { |
291 | result => { store => \$aref, default => [] }, |
292 | command => { required => 1, store => \$cmd }, |
293 | |
294 | }; |
295 | |
296 | check( $tmpl, \%hash ) or return; |
297 | |
298 | |
299 | my $shell = $conf->get_program('shell'); |
300 | unless( $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]; |
303 | return; |
304 | } |
305 | |
306 | my $cwd = Cwd::cwd(); |
307 | |
308 | for my $mod (@$aref) { |
309 | print "Running $cmd for $mod\n"; |
310 | |
311 | my $obj = $cb->module_tree( $mod ) or next; |
312 | $obj->fetch or next; |
313 | $obj->extract or next; |
314 | |
315 | $cb->_chdir( dir => $obj->status->extract ) or next; |
316 | |
317 | local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt; |
318 | if( system($shell) and $! ) { |
319 | print "Error executing your subshell '$shell': $!\n"; |
320 | next; |
321 | } |
322 | } |
323 | $cb->_chdir( dir => $cwd ); |
324 | |
325 | return $aref; |
326 | } |
327 | |
328 | sub _readme { |
329 | my $self = shift; |
330 | my $cb = $self->backend; |
331 | my $conf = $cb->configure_object; |
332 | my %hash = @_; |
333 | |
334 | my($aref, $cmd); |
335 | my $tmpl = { |
336 | result => { store => \$aref, default => [] }, |
337 | command => { required => 1, store => \$cmd }, |
338 | |
339 | }; |
340 | |
341 | check( $tmpl, \%hash ) or return; |
342 | |
343 | for my $mod (@$aref) { |
344 | my $obj = $cb->module_tree( $mod ) or next; |
345 | |
346 | if( my $readme = $obj->readme ) { |
347 | |
348 | $self->_pager_open; |
349 | print $readme; |
350 | $self->_pager_close; |
351 | } |
352 | } |
353 | |
354 | return 1; |
355 | } |
356 | |
357 | sub _reload { |
358 | my $self = shift; |
359 | my $cb = $self->backend; |
360 | my $conf = $cb->configure_object; |
361 | my %hash = @_; |
362 | |
363 | my($input, $cmd); |
364 | my $tmpl = { |
365 | input => { default => 'all', store => \$input }, |
366 | command => { required => 1, store => \$cmd }, |
367 | |
368 | }; |
369 | |
370 | check( $tmpl, \%hash ) or return; |
371 | |
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]; |
376 | |
377 | } elsif ( $input =~ /index/i ) { |
378 | $cb->reload_indices(update_source => 1); |
379 | |
380 | } else { |
381 | print qq[cpan re-evals the CPANPLUS.pm file\n]; |
382 | print qq[index re-reads the index files\n]; |
383 | } |
384 | |
385 | return 1; |
386 | } |
387 | |
388 | sub _autobundle { |
389 | my $self = shift; |
390 | my $cb = $self->backend; |
391 | |
392 | print qq[Writing bundle file... This may take a while\n]; |
393 | |
394 | my $where = $cb->autobundle(); |
395 | |
396 | print $where |
397 | ? qq[\nWrote autobundle to $where\n] |
398 | : qq[\nCould not create autobundle\n]; |
399 | |
400 | return 1; |
401 | } |
402 | |
403 | sub _set_conf { |
404 | my $self = shift; |
405 | my $cb = $self->backend; |
406 | my $conf = $cb->configure_object; |
407 | my %hash = @_; |
408 | |
409 | my($aref, $input); |
410 | my $tmpl = { |
411 | result => { store => \$aref, default => [] }, |
412 | input => { default => 'all', store => \$input }, |
413 | }; |
414 | |
415 | check( $tmpl, \%hash ) or return; |
416 | |
417 | my $type = shift @$aref; |
418 | |
419 | if( $type eq 'debug' ) { |
420 | print qq[Sorry you cannot set debug options through ] . |
421 | qq[this shell in CPANPLUS\n]; |
422 | return; |
423 | |
424 | } elsif ( $type eq 'conf' ) { |
425 | |
426 | ### from CPAN.pm :o) |
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' |
429 | |
430 | # commit Commit changes to disk |
431 | # defaults Reload defaults from disk |
432 | # init Interactive setting of all options |
433 | |
434 | my $name = shift @$aref; |
435 | my $value = "@$aref"; |
436 | |
437 | if( $name eq 'init' ) { |
438 | my $setup = CPANPLUS::Configure::Setup->new( |
439 | conf => $cb->configure_object, |
440 | term => $self->term, |
441 | backend => $cb, |
442 | ); |
443 | return $setup->init; |
444 | |
445 | } elsif ($name eq 'commit' ) {; |
446 | $cb->configure_object->save; |
447 | print "Your CPAN++ configuration info has been saved!\n\n"; |
448 | return; |
449 | |
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]; |
454 | return; |
455 | |
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. |
460 | } else { |
461 | unless( $name ) { |
462 | my @list = grep { $_ ne 'hosts' } |
463 | $conf->options( type => $type ); |
464 | |
465 | my $method = 'get_' . $type; |
466 | |
467 | local $Data::Dumper::Indent = 0; |
468 | for my $name ( @list ) { |
469 | my $val = $conf->$method($name); |
470 | ($val) = ref($val) |
471 | ? (Data::Dumper::Dumper($val) =~ /= (.*);$/) |
472 | : "'$val'"; |
473 | printf " %-25s %s\n", $name, $val; |
474 | } |
475 | |
476 | } elsif ( $name eq 'hosts' ) { |
477 | print "Setting hosts is not trivial.\n" . |
478 | "It is suggested you edit the " . |
479 | "configuration file manually"; |
480 | |
481 | } else { |
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"; |
486 | } |
487 | } |
488 | } |
489 | } else { |
490 | print qq[Known options:\n] . |
491 | qq[ conf set or get configuration variables\n] . |
492 | qq[ debug set or get debugging options\n]; |
493 | } |
494 | |
495 | return; |
496 | } |
497 | |
498 | ######################## |
499 | ### search functions ### |
500 | ######################## |
501 | |
502 | sub _author { |
503 | my $self = shift; |
504 | my $cb = $self->backend; |
505 | my %hash = @_; |
506 | |
507 | my($aref, $short, $input, $class); |
508 | my $tmpl = { |
509 | result => { store => \$aref, default => ['/./'] }, |
510 | short => { default => 0, store => \$short }, |
511 | input => { default => 'all', store => \$input }, |
512 | class => { default => 'Author', no_override => 1, |
513 | store => \$class }, |
514 | }; |
515 | |
516 | check( $tmpl, \%hash ) or return; |
517 | |
518 | my @regexes = map { m|/(.+)/| ? qr/$1/ : $_ } @$aref; |
519 | |
520 | |
521 | my @rv; |
522 | for my $type (qw[author cpanid]) { |
523 | push @rv, $cb->search( type => $type, allow => \@regexes ); |
524 | } |
525 | |
526 | unless( @rv ) { |
527 | print "No object of type $class found for argument $input\n" |
528 | unless $short; |
529 | return; |
530 | } |
531 | |
532 | return $self->_pp_author( |
533 | result => \@rv, |
534 | class => $class, |
535 | short => $short, |
536 | input => $input ); |
537 | |
538 | } |
539 | |
540 | ### find all modules matching a query ### |
541 | sub _module { |
542 | my $self = shift; |
543 | my $cb = $self->backend; |
544 | my %hash = @_; |
545 | |
546 | my($aref, $short, $input, $class); |
547 | my $tmpl = { |
548 | result => { store => \$aref, default => ['/./'] }, |
549 | short => { default => 0, store => \$short }, |
550 | input => { default => 'all', store => \$input }, |
551 | class => { default => 'Module', no_override => 1, |
552 | store => \$class }, |
553 | }; |
554 | |
555 | check( $tmpl, \%hash ) or return; |
556 | |
557 | my @rv; |
558 | for my $module (@$aref) { |
559 | if( $module =~ m|/(.+)/| ) { |
560 | push @rv, $cb->search( type => 'module', |
561 | allow => [qr/$1/i] ); |
562 | } else { |
563 | my $obj = $cb->module_tree( $module ) or next; |
564 | push @rv, $obj; |
565 | } |
566 | } |
567 | |
568 | return $self->_pp_module( |
569 | result => \@rv, |
570 | class => $class, |
571 | short => $short, |
572 | input => $input ); |
573 | } |
574 | |
575 | ### find all bundles matching a query ### |
576 | sub _bundle { |
577 | my $self = shift; |
578 | my $cb = $self->backend; |
579 | my %hash = @_; |
580 | |
581 | my($aref, $short, $input, $class); |
582 | my $tmpl = { |
583 | result => { store => \$aref, default => ['/./'] }, |
584 | short => { default => 0, store => \$short }, |
585 | input => { default => 'all', store => \$input }, |
586 | class => { default => 'Bundle', no_override => 1, |
587 | store => \$class }, |
588 | }; |
589 | |
590 | check( $tmpl, \%hash ) or return; |
591 | |
592 | my @rv; |
593 | for my $bundle (@$aref) { |
594 | if( $bundle =~ m|/(.+)/| ) { |
595 | push @rv, $cb->search( type => 'module', |
596 | allow => [qr/Bundle::.*?$1/i] ); |
597 | } else { |
598 | my $obj = $cb->module_tree( "Bundle::${bundle}" ) or next; |
599 | push @rv, $obj; |
600 | } |
601 | } |
602 | |
603 | return $self->_pp_module( |
604 | result => \@rv, |
605 | class => $class, |
606 | short => $short, |
607 | input => $input ); |
608 | } |
609 | |
610 | sub _distribution { |
611 | my $self = shift; |
612 | my $cb = $self->backend; |
613 | my %hash = @_; |
614 | |
615 | my($aref, $short, $input, $class); |
616 | my $tmpl = { |
617 | result => { store => \$aref, default => ['/./'] }, |
618 | short => { default => 0, store => \$short }, |
619 | input => { default => 'all', store => \$input }, |
620 | class => { default => 'Distribution', no_override => 1, |
621 | store => \$class }, |
622 | }; |
623 | |
624 | check( $tmpl, \%hash ) or return; |
625 | |
626 | my @rv; |
627 | for my $module (@$aref) { |
628 | ### if it's a regex... ### |
629 | if ( my ($match) = $module =~ m|^/(.+)/$|) { |
630 | |
631 | ### something like /FOO/Bar.tar.gz/ was entered |
632 | if (my ($path,$package) = $match =~ m|^/?(.+)/(.+)$|) { |
633 | my $seen; |
634 | |
635 | my @data = $cb->search( type => 'package', |
636 | allow => [qr/$package/i] ); |
637 | |
638 | my @list = $cb->search( type => 'path', |
639 | allow => [qr/$path/i], |
640 | data => \@data ); |
641 | |
642 | ### make sure we dont list the same dist twice |
643 | for my $val ( @list ) { |
644 | next if $seen->{$val->package}++; |
645 | |
646 | push @rv, $val; |
647 | } |
648 | |
649 | ### something like /FOO/ or /Bar.tgz/ was entered |
650 | ### so we look both in the path, as well as in the package name |
651 | } else { |
652 | my $seen; |
653 | { my @list = $cb->search( type => 'package', |
654 | allow => [qr/$match/i] ); |
655 | |
656 | ### make sure we dont list the same dist twice |
657 | for my $val ( @list ) { |
658 | next if $seen->{$val->package}++; |
659 | |
660 | push @rv, $val; |
661 | } |
662 | } |
663 | |
664 | { my @list = $cb->search( type => 'path', |
665 | allow => [qr/$match/i] ); |
666 | |
667 | ### make sure we dont list the same dist twice |
668 | for my $val ( @list ) { |
669 | next if $seen->{$val->package}++; |
670 | |
671 | push @rv, $val; |
672 | } |
673 | |
674 | } |
675 | } |
676 | |
677 | } else { |
678 | |
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], |
685 | data => \@data); |
686 | |
687 | ### make sure we dont list the same dist twice |
688 | my $seen; |
689 | for my $val ( @list ) { |
690 | next if $seen->{$val->package}++; |
691 | |
692 | push @rv, $val; |
693 | } |
694 | } |
695 | } |
696 | } |
697 | |
698 | return $self->_pp_distribution( |
699 | result => \@rv, |
700 | class => $class, |
701 | short => $short, |
702 | input => $input ); |
703 | } |
704 | |
705 | sub _find_all { |
706 | my $self = shift; |
707 | |
708 | my @rv; |
709 | for my $method (qw[_author _bundle _module _distribution]) { |
710 | my $aref = $self->$method( @_, short => 1 ); |
711 | |
712 | push @rv, @$aref if $aref; |
713 | } |
714 | |
715 | print scalar(@rv). " items found\n" |
716 | } |
717 | |
718 | sub _uptodate { |
719 | my $self = shift; |
720 | my $cb = $self->backend; |
721 | my %hash = @_; |
722 | |
723 | my($aref, $short, $input, $class); |
724 | my $tmpl = { |
725 | result => { store => \$aref, default => ['/./'] }, |
726 | short => { default => 0, store => \$short }, |
727 | input => { default => 'all', store => \$input }, |
728 | class => { default => 'Uptodate', no_override => 1, |
729 | store => \$class }, |
730 | }; |
731 | |
732 | check( $tmpl, \%hash ) or return; |
733 | |
734 | |
735 | my @rv; |
736 | if( @$aref) { |
737 | for my $module (@$aref) { |
738 | if( $module =~ m|/(.+)/| ) { |
739 | my @list = $cb->search( type => 'module', |
740 | allow => [qr/$1/i] ); |
741 | |
742 | ### only add those that are installed and not core |
743 | push @rv, grep { not $_->package_is_perl_core } |
744 | grep { $_->installed_file } |
745 | @list; |
746 | |
747 | } else { |
748 | my $obj = $cb->module_tree( $module ) or next; |
749 | push @rv, $obj; |
750 | } |
751 | } |
752 | } else { |
753 | @rv = @{$cb->_all_installed}; |
754 | } |
755 | |
756 | return $self->_pp_uptodate( |
757 | result => \@rv, |
758 | class => $class, |
759 | short => $short, |
760 | input => $input ); |
761 | } |
762 | |
763 | sub _ls { |
764 | my $self = shift; |
765 | my $cb = $self->backend; |
766 | my %hash = @_; |
767 | |
768 | my($aref, $short, $input, $class); |
769 | my $tmpl = { |
770 | result => { store => \$aref, default => [] }, |
771 | short => { default => 0, store => \$short }, |
772 | input => { default => 'all', store => \$input }, |
773 | class => { default => 'Uptodate', no_override => 1, |
774 | store => \$class }, |
775 | }; |
776 | |
777 | check( $tmpl, \%hash ) or return; |
778 | |
779 | my @rv; |
780 | for my $name (@$aref) { |
781 | my $auth = $cb->author_tree( uc $name ); |
782 | |
783 | unless( $auth ) { |
784 | print qq[ls command rejects argument $name: not an author\n]; |
785 | next; |
786 | } |
787 | |
788 | push @rv, $auth->distributions; |
789 | } |
790 | |
791 | return $self->_pp_ls( |
792 | result => \@rv, |
793 | class => $class, |
794 | short => $short, |
795 | input => $input ); |
796 | } |
797 | |
798 | ############################ |
799 | ### pretty printing subs ### |
800 | ############################ |
801 | |
802 | |
803 | sub _pp_author { |
804 | my $self = shift; |
805 | my %hash = @_; |
806 | |
807 | my( $aref, $short, $class, $input ); |
808 | my $tmpl = { |
809 | result => { required => 1, default => [], strict_type => 1, |
810 | store => \$aref }, |
811 | short => { default => 0, store => \$short }, |
812 | class => { required => 1, store => \$class }, |
813 | input => { required => 1, store => \$input }, |
814 | }; |
815 | |
816 | check( $tmpl, \%hash ) or return; |
817 | |
818 | ### no results |
819 | if( !@$aref ) { |
820 | print "No objects of type $class found for argument $input\n" |
821 | unless $short; |
822 | |
823 | ### one result, long output desired; |
824 | } elsif( @$aref == 1 and !$short ) { |
825 | |
826 | ### should look like this: |
827 | #cpan> a KANE |
828 | #Author id = KANE |
829 | # EMAIL boumans@frg.eur.nl |
830 | # FULLNAME Jos Boumans |
831 | |
832 | my $obj = shift @$aref; |
833 | |
834 | print "$class id = ", $obj->cpanid(), "\n"; |
835 | printf " %-12s %s\n", 'EMAIL', $obj->email(); |
836 | printf " %-12s %s%s\n", 'FULLNAME', $obj->author(); |
837 | |
838 | } else { |
839 | |
840 | ### should look like this: |
841 | #Author KANE (Jos Boumans) |
842 | #Author LBROCARD (Leon Brocard) |
843 | #2 items found |
844 | |
845 | for my $obj ( @$aref ) { |
846 | printf qq[%-15s %s ("%s" (%s))\n], |
847 | $class, $obj->cpanid, $obj->author, $obj->email; |
848 | } |
849 | print scalar(@$aref)." items found\n" unless $short; |
850 | } |
851 | |
852 | return $aref; |
853 | } |
854 | |
855 | sub _pp_module { |
856 | my $self = shift; |
857 | my %hash = @_; |
858 | |
859 | my( $aref, $short, $class, $input ); |
860 | my $tmpl = { |
861 | result => { required => 1, default => [], strict_type => 1, |
862 | store => \$aref }, |
863 | short => { default => 0, store => \$short }, |
864 | class => { required => 1, store => \$class }, |
865 | input => { required => 1, store => \$input }, |
866 | }; |
867 | |
868 | check( $tmpl, \%hash ) or return; |
869 | |
870 | |
871 | ### no results |
872 | if( !@$aref ) { |
873 | print "No objects of type $class found for argument $input\n" |
874 | unless $short; |
875 | |
876 | ### one result, long output desired; |
877 | } elsif( @$aref == 1 and !$short ) { |
878 | |
879 | |
880 | ### should look like this: |
881 | #Module id = LWP |
882 | # DESCRIPTION Libwww-perl |
883 | # CPAN_USERID GAAS (Gisle Aas <gisle@ActiveState.com>) |
884 | # CPAN_VERSION 5.64 |
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 |
889 | # INST_VERSION 5.62 |
890 | |
891 | my $obj = shift @$aref; |
892 | my $aut_obj = $obj->author; |
893 | my $format = " %-12s %s%s\n"; |
894 | |
895 | print "$class id = ", $obj->module(), "\n"; |
896 | printf $format, 'DESCRIPTION', $obj->description() |
897 | if $obj->description(); |
898 | |
899 | printf $format, 'CPAN_USERID', $aut_obj->cpanid() . " (" . |
900 | $aut_obj->author() . " <" . $aut_obj->email() . ">)"; |
901 | |
902 | printf $format, 'CPAN_VERSION', $obj->version(); |
903 | printf $format, 'CPAN_FILE', $obj->path() . '/' . $obj->package(); |
904 | |
905 | printf $format, 'DSLI_STATUS', $self->_pp_dslip($obj->dslip) |
906 | if $obj->dslip() =~ /\w/; |
907 | |
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... |
912 | |
913 | printf $format, 'INST_FILE', $obj->installed_file || |
914 | '(not installed)'; |
915 | printf $format, 'INST_VERSION', $obj->installed_version; |
916 | |
917 | |
918 | |
919 | } else { |
920 | |
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) |
924 | #2 items found |
925 | |
926 | for my $obj ( @$aref ) { |
927 | printf "%-15s %-15s (%s)\n", $class, $obj->module(), |
928 | $obj->path() .'/'. $obj->package(); |
929 | } |
930 | print scalar(@$aref). " items found\n" unless $short; |
931 | } |
932 | |
933 | return $aref; |
934 | } |
935 | |
936 | sub _pp_dslip { |
937 | my $self = shift; |
938 | my $dslip = shift or return; |
939 | |
940 | my (%_statusD, %_statusS, %_statusL, %_statusI); |
941 | |
942 | @_statusD{qw(? i c a b R M S)} = |
943 | qw(unknown idea pre-alpha alpha beta released mature standard); |
944 | |
945 | @_statusS{qw(? m d u n)} = |
946 | qw(unknown mailing-list developer comp.lang.perl.* none); |
947 | |
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); |
951 | |
952 | my @status = split("", $dslip); |
953 | |
954 | my $results = sprintf( "%s (%s,%s,%s,%s)", |
955 | $dslip, |
956 | $_statusD{$status[0]}, |
957 | $_statusS{$status[1]}, |
958 | $_statusL{$status[2]}, |
959 | $_statusI{$status[3]} |
960 | ); |
961 | |
962 | return $results; |
963 | } |
964 | |
965 | sub _pp_distribution { |
966 | my $self = shift; |
967 | my $cb = $self->backend; |
968 | my %hash = @_; |
969 | |
970 | my( $aref, $short, $class, $input ); |
971 | my $tmpl = { |
972 | result => { required => 1, default => [], strict_type => 1, |
973 | store => \$aref }, |
974 | short => { default => 0, store => \$short }, |
975 | class => { required => 1, store => \$class }, |
976 | input => { required => 1, store => \$input }, |
977 | }; |
978 | |
979 | check( $tmpl, \%hash ) or return; |
980 | |
981 | |
982 | ### no results |
983 | if( !@$aref ) { |
984 | print "No objects of type $class found for argument $input\n" |
985 | unless $short; |
986 | |
987 | ### one result, long output desired; |
988 | } elsif( @$aref == 1 and !$short ) { |
989 | |
990 | |
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 |
995 | |
996 | my $obj = shift @$aref; |
997 | my $aut_obj = $obj->author; |
998 | my $pkg = $obj->package; |
999 | my $format = " %-12s %s\n"; |
1000 | |
1001 | my @list = $cb->search( type => 'package', |
1002 | allow => [qr/^$pkg$/] ); |
1003 | |
1004 | |
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 .')'; |
1009 | |
1010 | ### yes i know it's ugly, but it's what cpan.pm does |
1011 | printf $format, 'CONTAINSMODS', join (' ', map { $_->module } @list); |
1012 | |
1013 | } else { |
1014 | |
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) |
1018 | #2 items found |
1019 | |
1020 | for my $obj ( @$aref ) { |
1021 | printf "%-15s %s\n", $class, $obj->path() .'/'. $obj->package(); |
1022 | } |
1023 | |
1024 | print scalar(@$aref). " items found\n" unless $short; |
1025 | } |
1026 | |
1027 | return $aref; |
1028 | } |
1029 | |
1030 | sub _pp_uptodate { |
1031 | my $self = shift; |
1032 | my $cb = $self->backend; |
1033 | my %hash = @_; |
1034 | |
1035 | my( $aref, $short, $class, $input ); |
1036 | my $tmpl = { |
1037 | result => { required => 1, default => [], strict_type => 1, |
1038 | store => \$aref }, |
1039 | short => { default => 0, store => \$short }, |
1040 | class => { required => 1, store => \$class }, |
1041 | input => { required => 1, store => \$input }, |
1042 | }; |
1043 | |
1044 | check( $tmpl, \%hash ) or return; |
1045 | |
1046 | my $format = "%-25s %9s %9s %s\n"; |
1047 | |
1048 | my @not_uptodate; |
1049 | my $no_version; |
1050 | |
1051 | my %seen; |
1052 | for my $mod (@$aref) { |
1053 | next if $mod->package_is_perl_core; |
1054 | next if $seen{ $mod->package }++; |
1055 | |
1056 | |
1057 | if( $mod->installed_file and not $mod->installed_version ) { |
1058 | $no_version++; |
1059 | next; |
1060 | } |
1061 | |
1062 | push @not_uptodate, $mod unless $mod->is_uptodate; |
1063 | } |
1064 | |
1065 | unless( @not_uptodate ) { |
1066 | my $string = $input |
1067 | ? "for $input" |
1068 | : ''; |
1069 | print "All modules are up to date $string\n"; |
1070 | return; |
1071 | |
1072 | } else { |
1073 | printf $format, ( 'Package namespace', |
1074 | 'installed', |
1075 | 'latest', |
1076 | 'in CPAN file' |
1077 | ); |
1078 | } |
1079 | |
1080 | for my $mod ( sort { $a->module cmp $b->module } @not_uptodate ) { |
1081 | printf $format, ( $mod->module, |
1082 | $mod->installed_version, |
1083 | $mod->version, |
1084 | $mod->path .'/'. $mod->package, |
1085 | ); |
1086 | } |
1087 | |
1088 | print "$no_version installed modules have no (parsable) version number\n" |
1089 | if $no_version; |
1090 | |
1091 | return \@not_uptodate; |
1092 | } |
1093 | |
1094 | sub _pp_ls { |
1095 | my $self = shift; |
1096 | my $cb = $self->backend; |
1097 | my %hash = @_; |
1098 | |
1099 | my( $aref, $short, $class, $input ); |
1100 | my $tmpl = { |
1101 | result => { required => 1, default => [], strict_type => 1, |
1102 | store => \$aref }, |
1103 | short => { default => 0, store => \$short }, |
1104 | class => { required => 1, store => \$class }, |
1105 | input => { required => 1, store => \$input }, |
1106 | }; |
1107 | |
1108 | check( $tmpl, \%hash ) or return; |
1109 | |
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 |
1117 | |
1118 | ### don't know size or mtime |
1119 | #my $format = "%8d %10s %s/%s\n"; |
1120 | |
1121 | for my $mod ( sort { $a->package cmp $b->package } @$aref ) { |
1122 | print "\t" . $mod->package . "\n"; |
1123 | } |
1124 | |
1125 | return $aref; |
1126 | } |
1127 | |
1128 | |
1129 | ############################# |
1130 | ### end pretty print subs ### |
1131 | ############################# |
1132 | |
1133 | |
1134 | sub _bang { |
1135 | my $self = shift; |
1136 | my %hash = @_; |
1137 | |
1138 | my( $input ); |
1139 | my $tmpl = { |
1140 | input => { required => 1, store => \$input }, |
1141 | }; |
1142 | |
1143 | check( $tmpl, \%hash ) or return; |
1144 | |
1145 | eval $input; |
1146 | warn $@ if $@; |
1147 | |
1148 | print "\n"; |
1149 | |
1150 | return; |
1151 | } |
1152 | |
1153 | sub _help { |
1154 | print qq[ |
1155 | Display Information |
1156 | a authors |
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 |
1163 | |
1164 | Download, Test, Make, Install... |
1165 | get download |
1166 | make make (implies get) |
1167 | test modules, make test (implies make) |
1168 | install dists, bundles make install (implies test) |
1169 | clean make clean |
1170 | look open subshell in these dists' directories |
1171 | readme display these dists' README files |
1172 | |
1173 | Other |
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 |
1178 | ]; |
1179 | |
1180 | } |
1181 | |
1182 | |
1183 | |
1184 | 1; |
1185 | __END__ |
1186 | |
1187 | =pod |
1188 | |
1189 | =head1 NAME |
1190 | |
1191 | CPANPLUS::Shell::Classic - CPAN.pm emulation for CPANPLUS |
1192 | |
1193 | =head1 DESCRIPTION |
1194 | |
1195 | The Classic shell is designed to provide the feel of the CPAN.pm shell |
1196 | using CPANPLUS underneath. |
1197 | |
1198 | For detailed documentation, refer to L<CPAN>. |
1199 | |
1200 | =head1 BUG REPORTS |
1201 | |
1202 | Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. |
1203 | |
1204 | =head1 AUTHOR |
1205 | |
1206 | This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. |
1207 | |
1208 | =head1 COPYRIGHT |
1209 | |
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. |
1212 | |
1213 | This library is free software; you may redistribute and/or modify it |
1214 | under the same terms as Perl itself. |
1215 | |
1216 | =head1 SEE ALSO |
1217 | |
1218 | L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author> |
1219 | |
1220 | =cut |
1221 | |
1222 | |
1223 | =head1 SEE ALSO |
1224 | |
1225 | L<CPAN> |
1226 | |
1227 | =cut |
1228 | |
1229 | |
1230 | |
1231 | # Local variables: |
1232 | # c-indentation-style: bsd |
1233 | # c-basic-offset: 4 |
1234 | # indent-tabs-mode: nil |
1235 | # End: |
1236 | # vim: expandtab shiftwidth=4: |