Commit | Line | Data |
---|---|---|
6aaee015 RGS |
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: |