| 1 | package CPAN; |
| 2 | use vars qw{$META $Signal $Cwd $End $Suppress_readline}; |
| 3 | |
| 4 | $VERSION = '1.09'; |
| 5 | |
| 6 | # $Id: CPAN.pm,v 1.94 1996/12/24 00:41:14 k Exp $ |
| 7 | |
| 8 | # my $version = substr q$Revision: 1.94 $, 10; # only used during development |
| 9 | |
| 10 | BEGIN {require 5.003;} |
| 11 | require UNIVERSAL if $] == 5.003; |
| 12 | |
| 13 | use Carp (); |
| 14 | use Config (); |
| 15 | use Cwd (); |
| 16 | use DirHandle; |
| 17 | use Exporter (); |
| 18 | use ExtUtils::MakeMaker (); |
| 19 | use File::Basename (); |
| 20 | use File::Copy (); |
| 21 | use File::Find; |
| 22 | use File::Path (); |
| 23 | use IO::File (); |
| 24 | use Safe (); |
| 25 | use Text::ParseWords (); |
| 26 | |
| 27 | $Cwd = Cwd::cwd(); |
| 28 | |
| 29 | END { $End++; &cleanup; } |
| 30 | |
| 31 | %CPAN::DEBUG = qw( |
| 32 | CPAN 1 |
| 33 | Index 2 |
| 34 | InfoObj 4 |
| 35 | Author 8 |
| 36 | Distribution 16 |
| 37 | Bundle 32 |
| 38 | Module 64 |
| 39 | CacheMgr 128 |
| 40 | Complete 256 |
| 41 | FTP 512 |
| 42 | Shell 1024 |
| 43 | Eval 2048 |
| 44 | Config 4096 |
| 45 | ); |
| 46 | |
| 47 | $CPAN::DEBUG ||= 0; |
| 48 | |
| 49 | package CPAN; |
| 50 | use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META); |
| 51 | use strict qw(vars); |
| 52 | |
| 53 | @CPAN::ISA = qw(CPAN::Debug Exporter MY); # the MY class from |
| 54 | # MakeMaker, gives us |
| 55 | # catfile and catdir |
| 56 | |
| 57 | $META ||= new CPAN; # In case we reeval ourselves we |
| 58 | # need a || |
| 59 | |
| 60 | CPAN::Config->load; |
| 61 | |
| 62 | @EXPORT = qw(autobundle bundle expand force install make recompile shell test clean); |
| 63 | |
| 64 | |
| 65 | |
| 66 | #-> sub CPAN::autobundle ; |
| 67 | sub autobundle; |
| 68 | #-> sub CPAN::bundle ; |
| 69 | sub bundle; |
| 70 | #-> sub CPAN::expand ; |
| 71 | sub expand; |
| 72 | #-> sub CPAN::force ; |
| 73 | sub force; |
| 74 | #-> sub CPAN::install ; |
| 75 | sub install; |
| 76 | #-> sub CPAN::make ; |
| 77 | sub make; |
| 78 | #-> sub CPAN::shell ; |
| 79 | sub shell; |
| 80 | #-> sub CPAN::clean ; |
| 81 | sub clean; |
| 82 | #-> sub CPAN::test ; |
| 83 | sub test; |
| 84 | |
| 85 | #-> sub CPAN::AUTOLOAD ; |
| 86 | sub AUTOLOAD { |
| 87 | my($l) = $AUTOLOAD; |
| 88 | $l =~ s/.*:://; |
| 89 | my(%EXPORT); |
| 90 | @EXPORT{@EXPORT} = ''; |
| 91 | if (exists $EXPORT{$l}){ |
| 92 | CPAN::Shell->$l(@_); |
| 93 | } else { |
| 94 | warn "CPAN doesn't know how to autoload $AUTOLOAD :-( |
| 95 | Nothing Done. |
| 96 | "; |
| 97 | CPAN::Shell->h; |
| 98 | } |
| 99 | } |
| 100 | |
| 101 | #-> sub CPAN::all ; |
| 102 | sub all { |
| 103 | my($mgr,$class) = @_; |
| 104 | CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG; |
| 105 | CPAN::Index->reload; |
| 106 | values %{ $META->{$class} }; |
| 107 | } |
| 108 | |
| 109 | # Called by shell, not in batch mode. Not clean XXX |
| 110 | #-> sub CPAN::checklock ; |
| 111 | sub checklock { |
| 112 | my($self) = @_; |
| 113 | my $lockfile = CPAN->catfile($CPAN::Config->{cpan_home},".lock"); |
| 114 | if (-f $lockfile && -M _ > 0) { |
| 115 | my $fh = IO::File->new($lockfile); |
| 116 | my $other = <$fh>; |
| 117 | $fh->close; |
| 118 | if (defined $other && $other) { |
| 119 | chomp $other; |
| 120 | return if $$==$other; # should never happen |
| 121 | print qq{There seems to be running another CPAN process ($other). Trying to contact...\n}; |
| 122 | if (kill 0, $other) { |
| 123 | Carp::croak qq{Other job is running.\n}. |
| 124 | qq{You may want to kill it and delete the lockfile, maybe. On UNIX try:\n}. |
| 125 | qq{ kill $other\n}. |
| 126 | qq{ rm $lockfile\n}; |
| 127 | } elsif (-w $lockfile) { |
| 128 | my($ans)= |
| 129 | ExtUtils::MakeMaker::prompt |
| 130 | (qq{Other job not responding. Shall I overwrite the lockfile? (Y/N)},"y"); |
| 131 | print("Ok, bye\n"), exit unless $ans =~ /^y/i; |
| 132 | } else { |
| 133 | Carp::croak( |
| 134 | qq{Lockfile $lockfile not writeable by you. Cannot proceed.\n}. |
| 135 | qq{ On UNIX try:\n}. |
| 136 | qq{ rm $lockfile\n}. |
| 137 | qq{ and then rerun us.\n} |
| 138 | ); |
| 139 | } |
| 140 | } |
| 141 | } |
| 142 | File::Path::mkpath($CPAN::Config->{cpan_home}); |
| 143 | my $fh; |
| 144 | unless ($fh = IO::File->new(">$lockfile")) { |
| 145 | if ($! =~ /Permission/) { |
| 146 | my $incc = $INC{'CPAN/Config.pm'}; |
| 147 | my $myincc = MY->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm'); |
| 148 | print qq{ |
| 149 | |
| 150 | Your configuration suggests that CPAN.pm should use a working |
| 151 | directory of |
| 152 | $CPAN::Config->{cpan_home} |
| 153 | Unfortunately we could not create the lock file |
| 154 | $lockfile |
| 155 | due to permission problems. |
| 156 | |
| 157 | Please make sure that the configuration variable |
| 158 | \$CPAN::Config->{cpan_home} |
| 159 | points to a directory where you can write a .lock file. You can set |
| 160 | this variable in either |
| 161 | $incc |
| 162 | or |
| 163 | $myincc |
| 164 | |
| 165 | }; |
| 166 | } |
| 167 | Carp::croak "Could not open >$lockfile: $!"; |
| 168 | } |
| 169 | print $fh $$, "\n"; |
| 170 | $self->{LOCK} = $lockfile; |
| 171 | $fh->close; |
| 172 | $SIG{'TERM'} = sub { &cleanup; die "Got SIGTERM, leaving"; }; |
| 173 | $SIG{'INT'} = sub { &cleanup, die "Got a second SIGINT" if $Signal; $Signal = 1; }; |
| 174 | $SIG{'__DIE__'} = \&cleanup; |
| 175 | print STDERR "Signal handler set.\n" unless $CPAN::Config->{'inhibit_startup_message'}; |
| 176 | } |
| 177 | |
| 178 | #-> sub CPAN::DESTROY ; |
| 179 | sub DESTROY { |
| 180 | &cleanup; # need an eval? |
| 181 | } |
| 182 | |
| 183 | #-> sub CPAN::exists ; |
| 184 | sub exists { |
| 185 | my($mgr,$class,$id) = @_; |
| 186 | CPAN::Index->reload; |
| 187 | Carp::croak "exists called without class argument" unless $class; |
| 188 | $id ||= ""; |
| 189 | exists $META->{$class}{$id}; |
| 190 | } |
| 191 | |
| 192 | #-> sub CPAN::hasFTP ; |
| 193 | sub hasFTP { |
| 194 | my($self,$arg) = @_; |
| 195 | if (defined $arg) { |
| 196 | return $self->{'hasFTP'} = $arg; |
| 197 | } elsif (not defined $self->{'hasFTP'}) { |
| 198 | eval {require Net::FTP;}; |
| 199 | $self->{'hasFTP'} = $@ ? 0 : 1; |
| 200 | } |
| 201 | return $self->{'hasFTP'}; |
| 202 | } |
| 203 | |
| 204 | #-> sub CPAN::hasLWP ; |
| 205 | sub hasLWP { |
| 206 | my($self,$arg) = @_; |
| 207 | if (defined $arg) { |
| 208 | return $self->{'hasLWP'} = $arg; |
| 209 | } elsif (not defined $self->{'hasLWP'}) { |
| 210 | eval {require LWP;}; |
| 211 | $LWP::VERSION ||= 0; |
| 212 | $self->{'hasLWP'} = $LWP::VERSION >= 4.98; |
| 213 | } |
| 214 | return $self->{'hasLWP'}; |
| 215 | } |
| 216 | |
| 217 | #-> sub CPAN::hasMD5 ; |
| 218 | sub hasMD5 { |
| 219 | my($self,$arg) = @_; |
| 220 | if (defined $arg) { |
| 221 | $self->{'hasMD5'} = $arg; |
| 222 | } elsif (not defined $self->{'hasMD5'}) { |
| 223 | eval {require MD5;}; |
| 224 | if ($@) { |
| 225 | print "MD5 security checks disabled because MD5 not installed. Please consider installing MD5\n"; |
| 226 | $self->{'hasMD5'} = 0; |
| 227 | } else { |
| 228 | $self->{'hasMD5'}++; |
| 229 | } |
| 230 | } |
| 231 | return $self->{'hasMD5'}; |
| 232 | } |
| 233 | |
| 234 | #-> sub CPAN::instance ; |
| 235 | sub instance { |
| 236 | my($mgr,$class,$id) = @_; |
| 237 | CPAN::Index->reload; |
| 238 | Carp::croak "instance called without class argument" unless $class; |
| 239 | $id ||= ""; |
| 240 | $META->{$class}{$id} ||= $class->new(ID => $id ); |
| 241 | } |
| 242 | |
| 243 | #-> sub CPAN::new ; |
| 244 | sub new { |
| 245 | bless {}, shift; |
| 246 | } |
| 247 | |
| 248 | #-> sub CPAN::cleanup ; |
| 249 | sub cleanup { |
| 250 | local $SIG{__DIE__} = ''; |
| 251 | my $i = 0; my $ineval = 0; my $sub; |
| 252 | while ((undef,undef,undef,$sub) = caller(++$i)) { |
| 253 | $ineval = 1, last if $sub eq '(eval)'; |
| 254 | } |
| 255 | return if $ineval && !$End; |
| 256 | return unless defined $META->{'LOCK'}; |
| 257 | return unless -f $META->{'LOCK'}; |
| 258 | unlink $META->{'LOCK'}; |
| 259 | print STDERR "Lockfile removed.\n"; |
| 260 | # my $mess = Carp::longmess(@_); |
| 261 | # die @_; |
| 262 | } |
| 263 | |
| 264 | #-> sub CPAN::shell ; |
| 265 | sub shell { |
| 266 | $Suppress_readline ||= ! -t STDIN; |
| 267 | |
| 268 | my $prompt = "cpan> "; |
| 269 | local($^W) = 1; |
| 270 | my $term; |
| 271 | unless ($Suppress_readline) { |
| 272 | require Term::ReadLine; |
| 273 | import Term::ReadLine; |
| 274 | $term = new Term::ReadLine 'CPAN Monitor'; |
| 275 | $readline::rl_completion_function = |
| 276 | $readline::rl_completion_function = 'CPAN::Complete::complete'; |
| 277 | } |
| 278 | |
| 279 | no strict; |
| 280 | $META->checklock(); |
| 281 | my $cwd = Cwd::cwd(); |
| 282 | # How should we determine if we have more than stub ReadLine enabled? |
| 283 | my $rl_avail = $Suppress_readline ? "suppressed" : |
| 284 | defined &Term::ReadLine::Perl::readline ? "enabled" : |
| 285 | "available (get Term::ReadKey and Term::ReadLine)"; |
| 286 | |
| 287 | print qq{ |
| 288 | cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION) |
| 289 | Readline support $rl_avail |
| 290 | |
| 291 | } unless $CPAN::Config->{'inhibit_startup_message'} ; |
| 292 | while () { |
| 293 | if ($Suppress_readline) { |
| 294 | print $prompt; |
| 295 | last unless defined (chomp($_ = <>)); |
| 296 | } else { |
| 297 | last unless defined ($_ = $term->readline($prompt)); |
| 298 | } |
| 299 | s/^\s//; |
| 300 | next if /^$/; |
| 301 | $_ = 'h' if $_ eq '?'; |
| 302 | if (/^\!/) { |
| 303 | s/^\!//; |
| 304 | my($eval) = $_; |
| 305 | package CPAN::Eval; |
| 306 | use vars qw($import_done); |
| 307 | CPAN->import(':DEFAULT') unless $import_done++; |
| 308 | CPAN->debug("eval[$eval]") if $CPAN::DEBUG; |
| 309 | eval($eval); |
| 310 | warn $@ if $@; |
| 311 | } elsif (/^q(?:uit)?$/i) { |
| 312 | last; |
| 313 | } elsif (/./) { |
| 314 | my(@line); |
| 315 | eval { @line = Text::ParseWords::shellwords($_) }; |
| 316 | warn($@), next if $@; |
| 317 | $CPAN::META->debug("line[".join(":",@line)."]") if $CPAN::DEBUG; |
| 318 | my $command = shift @line; |
| 319 | eval { CPAN::Shell->$command(@line) }; |
| 320 | warn $@ if $@; |
| 321 | } |
| 322 | } continue { |
| 323 | &cleanup, die if $Signal; |
| 324 | chdir $cwd; |
| 325 | print "\n"; |
| 326 | } |
| 327 | } |
| 328 | |
| 329 | package CPAN::Shell; |
| 330 | use vars qw($AUTOLOAD); |
| 331 | @CPAN::Shell::ISA = qw(CPAN::Debug); |
| 332 | |
| 333 | # private function ro re-eval this module (handy during development) |
| 334 | #-> sub CPAN::Shell::AUTOLOAD ; |
| 335 | sub AUTOLOAD { |
| 336 | warn "CPAN::Shell doesn't know how to autoload $AUTOLOAD :-( |
| 337 | Nothing Done. |
| 338 | "; |
| 339 | CPAN::Shell->h; |
| 340 | } |
| 341 | |
| 342 | #-> sub CPAN::Shell::h ; |
| 343 | sub h { |
| 344 | my($class,$about) = @_; |
| 345 | if (defined $about) { |
| 346 | print "Detailed help not yet implemented\n"; |
| 347 | } else { |
| 348 | print q{ |
| 349 | command arguments description |
| 350 | a string authors |
| 351 | b or display bundles |
| 352 | d /regex/ info distributions |
| 353 | m or about modules |
| 354 | i none anything of above |
| 355 | |
| 356 | r as reinstall recommendations |
| 357 | u above uninstalled distributions |
| 358 | See manpage for autobundle, recompile, force, etc. |
| 359 | |
| 360 | make modules, make |
| 361 | test dists, bundles, make test (implies make) |
| 362 | install "r" or "u" make install (implies test) |
| 363 | clean make clean |
| 364 | |
| 365 | reload index|cpan load most recent indices/CPAN.pm |
| 366 | h or ? display this menu |
| 367 | o various set and query options |
| 368 | ! perl-code eval a perl command |
| 369 | q quit the shell subroutine |
| 370 | }; |
| 371 | } |
| 372 | } |
| 373 | |
| 374 | #-> sub CPAN::Shell::a ; |
| 375 | sub a { print shift->format_result('Author',@_);} |
| 376 | #-> sub CPAN::Shell::b ; |
| 377 | sub b { |
| 378 | my($self,@which) = @_; |
| 379 | my($incdir,$bdir,$dh); |
| 380 | foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { |
| 381 | $bdir = $CPAN::META->catdir($incdir,"Bundle"); |
| 382 | if ($dh = DirHandle->new($bdir)) { # may fail |
| 383 | my($entry); |
| 384 | for $entry ($dh->read) { |
| 385 | next if -d $CPAN::META->catdir($bdir,$entry); |
| 386 | next unless $entry =~ s/\.pm$//; |
| 387 | $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry"); |
| 388 | } |
| 389 | } |
| 390 | } |
| 391 | print $self->format_result('Bundle',@which); |
| 392 | } |
| 393 | #-> sub CPAN::Shell::d ; |
| 394 | sub d { print shift->format_result('Distribution',@_);} |
| 395 | #-> sub CPAN::Shell::m ; |
| 396 | sub m { print shift->format_result('Module',@_);} |
| 397 | |
| 398 | #-> sub CPAN::Shell::i ; |
| 399 | sub i { |
| 400 | my($self) = shift; |
| 401 | my(@args) = @_; |
| 402 | my(@type,$type,@m); |
| 403 | @type = qw/Author Bundle Distribution Module/; |
| 404 | @args = '/./' unless @args; |
| 405 | my(@result); |
| 406 | for $type (@type) { |
| 407 | push @result, $self->expand($type,@args); |
| 408 | } |
| 409 | my $result = @result==1 ? $result[0]->as_string : join "", map {$_->as_glimpse} @result; |
| 410 | $result ||= "No objects found of any type for argument @args\n"; |
| 411 | print $result; |
| 412 | } |
| 413 | |
| 414 | #-> sub CPAN::Shell::o ; |
| 415 | sub o { |
| 416 | my($self,$o_type,@o_what) = @_; |
| 417 | $o_type ||= ""; |
| 418 | CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n"); |
| 419 | if ($o_type eq 'conf') { |
| 420 | shift @o_what if @o_what && $o_what[0] eq 'help'; |
| 421 | if (!@o_what) { |
| 422 | my($k,$v); |
| 423 | print "CPAN::Config options:\n"; |
| 424 | for $k (sort keys %CPAN::Config::can) { |
| 425 | $v = $CPAN::Config::can{$k}; |
| 426 | printf " %-18s %s\n", $k, $v; |
| 427 | } |
| 428 | print "\n"; |
| 429 | for $k (sort keys %$CPAN::Config) { |
| 430 | $v = $CPAN::Config->{$k}; |
| 431 | if (ref $v) { |
| 432 | printf " %-18s\n", $k; |
| 433 | print map {"\t$_\n"} @{$v}; |
| 434 | } else { |
| 435 | printf " %-18s %s\n", $k, $v; |
| 436 | } |
| 437 | } |
| 438 | print "\n"; |
| 439 | } elsif (!CPAN::Config->edit(@o_what)) { |
| 440 | print qq[Type 'o conf' to view configuration edit options\n\n]; |
| 441 | } |
| 442 | } elsif ($o_type eq 'debug') { |
| 443 | my(%valid); |
| 444 | @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i; |
| 445 | if (@o_what) { |
| 446 | while (@o_what) { |
| 447 | my($what) = shift @o_what; |
| 448 | if ( exists $CPAN::DEBUG{$what} ) { |
| 449 | $CPAN::DEBUG |= $CPAN::DEBUG{$what}; |
| 450 | } elsif ($what =~ /^\d/) { |
| 451 | $CPAN::DEBUG = $what; |
| 452 | } elsif (lc $what eq 'all') { |
| 453 | my($max) = 0; |
| 454 | for (values %CPAN::DEBUG) { |
| 455 | $max += $_; |
| 456 | } |
| 457 | $CPAN::DEBUG = $max; |
| 458 | } else { |
| 459 | for (keys %CPAN::DEBUG) { |
| 460 | next unless lc($_) eq lc($what); |
| 461 | $CPAN::DEBUG |= $CPAN::DEBUG{$_}; |
| 462 | } |
| 463 | print "unknown argument $what\n"; |
| 464 | } |
| 465 | } |
| 466 | } else { |
| 467 | print "Valid options for debug are ".join(", ",sort(keys %CPAN::DEBUG), 'all'). |
| 468 | " or a number. Completion works on the options. Case is ignored.\n\n"; |
| 469 | } |
| 470 | if ($CPAN::DEBUG) { |
| 471 | print "Options set for debugging:\n"; |
| 472 | my($k,$v); |
| 473 | for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) { |
| 474 | $v = $CPAN::DEBUG{$k}; |
| 475 | printf " %-14s(%s)\n", $k, $v if $v & $CPAN::DEBUG; |
| 476 | } |
| 477 | } else { |
| 478 | print "Debugging turned off completely.\n"; |
| 479 | } |
| 480 | } else { |
| 481 | print qq{ |
| 482 | Known options: |
| 483 | conf set or get configuration variables |
| 484 | debug set or get debugging options |
| 485 | }; |
| 486 | } |
| 487 | } |
| 488 | |
| 489 | #-> sub CPAN::Shell::reload ; |
| 490 | sub reload { |
| 491 | if ($_[1] =~ /cpan/i) { |
| 492 | CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG; |
| 493 | my $fh = IO::File->new($INC{'CPAN.pm'}); |
| 494 | local $/; |
| 495 | undef $/; |
| 496 | eval <$fh>; |
| 497 | warn $@ if $@; |
| 498 | } elsif ($_[1] =~ /index/) { |
| 499 | CPAN::Index->force_reload; |
| 500 | } |
| 501 | } |
| 502 | |
| 503 | #-> sub CPAN::Shell::_binary_extensions ; |
| 504 | sub _binary_extensions { |
| 505 | my($self) = shift @_; |
| 506 | my(@result,$module,%seen,%need,$headerdone); |
| 507 | for $module ($self->expand('Module','/./')) { |
| 508 | my $file = $module->cpan_file; |
| 509 | next if $file eq "N/A"; |
| 510 | next if $file =~ /^Contact Author/; |
| 511 | next if $file =~ /perl5[._-]\d{3}(?:[\d_]+)?\.tar[._-]gz$/; |
| 512 | next unless $module->xs_file; |
| 513 | push @result, $module; |
| 514 | } |
| 515 | # print join " | ", @result; |
| 516 | # print "\n"; |
| 517 | return @result; |
| 518 | } |
| 519 | |
| 520 | #-> sub CPAN::Shell::recompile ; |
| 521 | sub recompile { |
| 522 | my($self) = shift @_; |
| 523 | my($module,@module,$cpan_file,%dist); |
| 524 | @module = $self->_binary_extensions(); |
| 525 | for $module (@module){ # we force now and compile later, so we don't do it twice |
| 526 | $cpan_file = $module->cpan_file; |
| 527 | my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); |
| 528 | $pack->force; |
| 529 | $dist{$cpan_file}++; |
| 530 | } |
| 531 | for $cpan_file (sort keys %dist) { |
| 532 | print " CPAN: Recompiling $cpan_file\n\n"; |
| 533 | my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); |
| 534 | $pack->install; |
| 535 | $CPAN::Signal = 0; # it's tempting to reset Signal, so we can |
| 536 | # stop a package from recompiling, |
| 537 | # e.g. IO-1.12 when we have perl5.003_10 |
| 538 | } |
| 539 | } |
| 540 | |
| 541 | #-> sub CPAN::Shell::_u_r_common ; |
| 542 | sub _u_r_common { |
| 543 | my($self) = shift @_; |
| 544 | my($what) = shift @_; |
| 545 | CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG; |
| 546 | Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what; |
| 547 | Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/; |
| 548 | my(@args) = @_; |
| 549 | @args = '/./' unless @args; |
| 550 | my(@result,$module,%seen,%need,$headerdone,$version_zeroes); |
| 551 | $version_zeroes = 0; |
| 552 | my $sprintf = "%-25s %9s %9s %s\n"; |
| 553 | for $module ($self->expand('Module',@args)) { |
| 554 | my $file = $module->cpan_file; |
| 555 | next unless defined $file; # ?? |
| 556 | my($latest) = $module->cpan_version || 0; |
| 557 | my($inst_file) = $module->inst_file; |
| 558 | my($have); |
| 559 | if ($inst_file){ |
| 560 | if ($what eq "a") { |
| 561 | $have = $module->inst_version; |
| 562 | } elsif ($what eq "r") { |
| 563 | $have = $module->inst_version; |
| 564 | local($^W) = 0; |
| 565 | $version_zeroes++ unless $have; |
| 566 | next if $have >= $latest; |
| 567 | } elsif ($what eq "u") { |
| 568 | next; |
| 569 | } |
| 570 | } else { |
| 571 | if ($what eq "a") { |
| 572 | next; |
| 573 | } elsif ($what eq "r") { |
| 574 | next; |
| 575 | } elsif ($what eq "u") { |
| 576 | $have = "-"; |
| 577 | } |
| 578 | } |
| 579 | $seen{$file} ||= 0; |
| 580 | if ($what eq "a") { |
| 581 | push @result, sprintf "%s %s\n", $module->id, $have; |
| 582 | } elsif ($what eq "r") { |
| 583 | push @result, $module->id; |
| 584 | next if $seen{$file}++; |
| 585 | } elsif ($what eq "u") { |
| 586 | push @result, $module->id; |
| 587 | next if $seen{$file}++; |
| 588 | next if $file =~ /^Contact/; |
| 589 | } |
| 590 | unless ($headerdone++){ |
| 591 | print "\n"; |
| 592 | printf $sprintf, "Package namespace", "installed", "latest", "in CPAN file"; |
| 593 | } |
| 594 | $latest = substr($latest,0,8) if length($latest) > 8; |
| 595 | $have = substr($have,0,8) if length($have) > 8; |
| 596 | printf $sprintf, $module->id, $have, $latest, $file; |
| 597 | $need{$module->id}++; |
| 598 | return if $CPAN::Signal; # this is sometimes lengthy |
| 599 | } |
| 600 | unless (%need) { |
| 601 | if ($what eq "u") { |
| 602 | print "No modules found for @args\n"; |
| 603 | } elsif ($what eq "r") { |
| 604 | print "All modules are up to date for @args\n"; |
| 605 | } |
| 606 | } |
| 607 | if ($what eq "r" && $version_zeroes) { |
| 608 | my $s = $version_zeroes>1 ? "s have" : " has"; |
| 609 | print qq{$version_zeroes installed module$s no version number to compare\n}; |
| 610 | } |
| 611 | @result; |
| 612 | } |
| 613 | |
| 614 | #-> sub CPAN::Shell::r ; |
| 615 | sub r { |
| 616 | shift->_u_r_common("r",@_); |
| 617 | } |
| 618 | |
| 619 | #-> sub CPAN::Shell::u ; |
| 620 | sub u { |
| 621 | shift->_u_r_common("u",@_); |
| 622 | } |
| 623 | |
| 624 | #-> sub CPAN::Shell::autobundle ; |
| 625 | sub autobundle { |
| 626 | my($self) = shift; |
| 627 | my(@bundle) = $self->_u_r_common("a",@_); |
| 628 | my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle"); |
| 629 | File::Path::mkpath($todir); |
| 630 | unless (-d $todir) { |
| 631 | print "Couldn't mkdir $todir for some reason\n"; |
| 632 | return; |
| 633 | } |
| 634 | my($y,$m,$d) = (localtime)[5,4,3]; |
| 635 | $y+=1900; |
| 636 | $m++; |
| 637 | my($c) = 0; |
| 638 | my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c; |
| 639 | my($to) = $CPAN::META->catfile($todir,"$me.pm"); |
| 640 | while (-f $to) { |
| 641 | $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c; |
| 642 | $to = $CPAN::META->catfile($todir,"$me.pm"); |
| 643 | } |
| 644 | my($fh) = IO::File->new(">$to") or Carp::croak "Can't open >$to: $!"; |
| 645 | $fh->print( |
| 646 | "package Bundle::$me;\n\n", |
| 647 | "\$VERSION = '0.01';\n\n", |
| 648 | "1;\n\n", |
| 649 | "__END__\n\n", |
| 650 | "=head1 NAME\n\n", |
| 651 | "Bundle::$me - Snapshot of installation on ", |
| 652 | $Config::Config{'myhostname'}, |
| 653 | " on ", |
| 654 | scalar(localtime), |
| 655 | "\n\n=head1 SYNOPSIS\n\n", |
| 656 | "perl -MCPAN -e 'install Bundle::$me'\n\n", |
| 657 | "=head1 CONTENTS\n\n", |
| 658 | join("\n", @bundle), |
| 659 | "\n\n=head1 CONFIGURATION\n\n", |
| 660 | Config->myconfig, |
| 661 | "\n\n=head1 AUTHOR\n\n", |
| 662 | "This Bundle has been generated automatically by the autobundle routine in CPAN.pm.\n", |
| 663 | ); |
| 664 | $fh->close; |
| 665 | print "\nWrote bundle file |
| 666 | $to\n\n"; |
| 667 | } |
| 668 | |
| 669 | #-> sub CPAN::Shell::expand ; |
| 670 | sub expand { |
| 671 | shift; |
| 672 | my($type,@args) = @_; |
| 673 | my($arg,@m); |
| 674 | for $arg (@args) { |
| 675 | my $regex; |
| 676 | if ($arg =~ m|^/(.*)/$|) { |
| 677 | $regex = $1; |
| 678 | } |
| 679 | my $class = "CPAN::$type"; |
| 680 | my $obj; |
| 681 | if (defined $regex) { |
| 682 | for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) { |
| 683 | push @m, $obj if $obj->id =~ /$regex/i or $obj->can('name') && $obj->name =~ /$regex/i; |
| 684 | } |
| 685 | } else { |
| 686 | my($xarg) = $arg; |
| 687 | if ( $type eq 'Bundle' ) { |
| 688 | $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/; |
| 689 | } |
| 690 | if ($CPAN::META->exists($class,$xarg)) { |
| 691 | $obj = $CPAN::META->instance($class,$xarg); |
| 692 | } elsif ($obj = $CPAN::META->exists($class,$arg)) { |
| 693 | $obj = $CPAN::META->instance($class,$arg); |
| 694 | } else { |
| 695 | next; |
| 696 | } |
| 697 | push @m, $obj; |
| 698 | } |
| 699 | } |
| 700 | return @m; |
| 701 | } |
| 702 | |
| 703 | #-> sub CPAN::Shell::format_result ; |
| 704 | sub format_result { |
| 705 | my($self) = shift; |
| 706 | my($type,@args) = @_; |
| 707 | @args = '/./' unless @args; |
| 708 | my(@result) = $self->expand($type,@args); |
| 709 | my $result = @result==1 ? $result[0]->as_string : join "", map {$_->as_glimpse} @result; |
| 710 | $result ||= "No objects of type $type found for argument @args\n"; |
| 711 | $result; |
| 712 | } |
| 713 | |
| 714 | #-> sub CPAN::Shell::rematein ; |
| 715 | sub rematein { |
| 716 | shift; |
| 717 | my($meth,@some) = @_; |
| 718 | my $pragma = ""; |
| 719 | if ($meth eq 'force') { |
| 720 | $pragma = $meth; |
| 721 | $meth = shift @some; |
| 722 | } |
| 723 | CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG; |
| 724 | my($s,@s); |
| 725 | foreach $s (@some) { |
| 726 | my $obj; |
| 727 | if (ref $s) { |
| 728 | $obj = $s; |
| 729 | } elsif ($s =~ m|/|) { # looks like a file |
| 730 | $obj = $CPAN::META->instance('CPAN::Distribution',$s); |
| 731 | } elsif ($s =~ m|^Bundle::|) { |
| 732 | $obj = $CPAN::META->instance('CPAN::Bundle',$s); |
| 733 | } else { |
| 734 | $obj = $CPAN::META->instance('CPAN::Module',$s) if $CPAN::META->exists('CPAN::Module',$s); |
| 735 | } |
| 736 | if (ref $obj) { |
| 737 | CPAN->debug(qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}.$obj->as_string.qq{\]}) if $CPAN::DEBUG; |
| 738 | $obj->$pragma() if $pragma && $obj->can($pragma); |
| 739 | $obj->$meth(); |
| 740 | } else { |
| 741 | print "Warning: Cannot $meth $s, don't know what it is\n"; |
| 742 | } |
| 743 | } |
| 744 | } |
| 745 | |
| 746 | #-> sub CPAN::Shell::force ; |
| 747 | sub force { shift->rematein('force',@_); } |
| 748 | #-> sub CPAN::Shell::readme ; |
| 749 | sub readme { shift->rematein('readme',@_); } |
| 750 | #-> sub CPAN::Shell::make ; |
| 751 | sub make { shift->rematein('make',@_); } |
| 752 | #-> sub CPAN::Shell::clean ; |
| 753 | sub clean { shift->rematein('clean',@_); } |
| 754 | #-> sub CPAN::Shell::test ; |
| 755 | sub test { shift->rematein('test',@_); } |
| 756 | #-> sub CPAN::Shell::install ; |
| 757 | sub install { shift->rematein('install',@_); } |
| 758 | |
| 759 | package CPAN::FTP; |
| 760 | use vars qw($Ua); |
| 761 | @CPAN::FTP::ISA = qw(CPAN::Debug); |
| 762 | |
| 763 | #-> sub CPAN::FTP::ftp_get ; |
| 764 | sub ftp_get { |
| 765 | my($class,$host,$dir,$file,$target) = @_; |
| 766 | $class->debug( |
| 767 | qq[Going to fetch file [$file] from dir [$dir] |
| 768 | on host [$host] as local [$target]\n] |
| 769 | ) if $CPAN::DEBUG; |
| 770 | my $ftp = Net::FTP->new($host); |
| 771 | $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; |
| 772 | $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]); |
| 773 | unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){ |
| 774 | warn "Couldn't login on $host"; |
| 775 | return; |
| 776 | } |
| 777 | # print qq[Going to ->cwd("$dir")\n]; |
| 778 | unless ( $ftp->cwd($dir) ){ |
| 779 | warn "Couldn't cwd $dir"; |
| 780 | return; |
| 781 | } |
| 782 | $ftp->binary; |
| 783 | $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; |
| 784 | unless ( $ftp->get($file,$target) ){ |
| 785 | warn "Couldn't fetch $file from $host"; |
| 786 | return; |
| 787 | } |
| 788 | $ftp->quit; |
| 789 | } |
| 790 | |
| 791 | #-> sub CPAN::FTP::localize ; |
| 792 | sub localize { |
| 793 | my($self,$file,$aslocal,$force) = @_; |
| 794 | $force ||= 0; |
| 795 | Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])" unless defined $aslocal; |
| 796 | $self->debug("file [$file] aslocal [$aslocal]") if $CPAN::DEBUG; |
| 797 | |
| 798 | return $aslocal if -f $aslocal && -r _ && ! $force; |
| 799 | |
| 800 | my($aslocal_dir) = File::Basename::dirname($aslocal); |
| 801 | File::Path::mkpath($aslocal_dir); |
| 802 | print STDERR qq{Warning: You are not allowed to write into directory "$aslocal_dir". |
| 803 | I\'ll continue, but if you face any problems, they may be due |
| 804 | to insufficient permissions.\n} unless -w $aslocal_dir; |
| 805 | |
| 806 | # Inheritance is not easier to manage than a few if/else branches |
| 807 | if ($CPAN::META->hasLWP) { |
| 808 | require LWP::UserAgent; |
| 809 | unless ($Ua) { |
| 810 | $Ua = new LWP::UserAgent; |
| 811 | $Ua->proxy('ftp', $ENV{'ftp_proxy'}) if defined $ENV{'ftp_proxy'}; |
| 812 | $Ua->proxy('http', $ENV{'http_proxy'}) if defined $ENV{'http_proxy'}; |
| 813 | $Ua->no_proxy($ENV{'no_proxy'}) if defined $ENV{'no_proxy'}; |
| 814 | } |
| 815 | } |
| 816 | |
| 817 | # Try the list of urls for each single object. We keep a record |
| 818 | # where we did get a file from |
| 819 | for (0..$#{$CPAN::Config->{urllist}}) { |
| 820 | my $url = $CPAN::Config->{urllist}[$_]; |
| 821 | $url .= "/" unless substr($url,-1) eq "/"; |
| 822 | $url .= $file; |
| 823 | $self->debug("localizing[$url]") if $CPAN::DEBUG; |
| 824 | if ($url =~ /^file:/) { |
| 825 | my $l; |
| 826 | if ($CPAN::META->hasLWP) { |
| 827 | require URI::URL; |
| 828 | my $u = new URI::URL $url; |
| 829 | $l = $u->path; |
| 830 | } else { # works only on Unix, is poorly constructed, but |
| 831 | # hopefully better than nothing. |
| 832 | # RFC 1738 says fileurl BNF is |
| 833 | # fileurl = "file://" [ host | "localhost" ] "/" fpath |
| 834 | # Thanks to "Mark D. Baushke" <mdb@cisco.com> for the code |
| 835 | ($l = $url) =~ s,^file://[^/]+,,; # discard the host part |
| 836 | $l =~ s/^file://; # assume they meant file://localhost |
| 837 | } |
| 838 | return $l if -f $l && -r _; |
| 839 | } |
| 840 | |
| 841 | if ($CPAN::META->hasLWP) { |
| 842 | print "Fetching $url\n"; |
| 843 | my $res = $Ua->mirror($url, $aslocal); |
| 844 | if ($res->is_success) { |
| 845 | return $aslocal; |
| 846 | } |
| 847 | } |
| 848 | if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { |
| 849 | my($host,$dir,$getfile) = ($1,$2,$3); |
| 850 | if ($CPAN::META->hasFTP) { |
| 851 | $dir =~ s|/+|/|g; |
| 852 | $self->debug("Going to fetch file [$getfile] |
| 853 | from dir [$dir] |
| 854 | on host [$host] |
| 855 | as local [$aslocal]") if $CPAN::DEBUG; |
| 856 | CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal) && return $aslocal; |
| 857 | } elsif (-x $CPAN::Config->{'ftp'}) { |
| 858 | my($netrc) = CPAN::FTP::netrc->new; |
| 859 | if ($netrc->hasdefault() || $netrc->contains($host)) { |
| 860 | print( |
| 861 | qq{ |
| 862 | Trying with external ftp to get $url |
| 863 | As this requires some features that are not thoroughly tested, we\'re |
| 864 | not sure, that we get it right. Please, install Net::FTP as soon |
| 865 | as possible. Just type "install Net::FTP". Thank you. |
| 866 | |
| 867 | } |
| 868 | ); |
| 869 | my($fh) = IO::File->new; |
| 870 | my($cwd) = Cwd::cwd(); |
| 871 | chdir $aslocal_dir; |
| 872 | my($targetfile) = File::Basename::basename($aslocal); |
| 873 | my(@dialog); |
| 874 | push @dialog, map {"cd $_\n"} split "/", $dir; |
| 875 | push @dialog, "get $getfile $targetfile\n"; |
| 876 | push @dialog, "quit\n"; |
| 877 | open($fh, "|$CPAN::Config->{'ftp'} $host") or die "Couldn't open ftp: $!"; |
| 878 | # pilot is blind now |
| 879 | foreach (@dialog) { |
| 880 | $fh->print($_); |
| 881 | } |
| 882 | chdir($cwd); |
| 883 | return $aslocal; |
| 884 | } else { |
| 885 | my($netrcfile) = $netrc->netrc(); |
| 886 | if ($netrcfile){ |
| 887 | print qq{ Your $netrcfile does not contain host $host.\n} |
| 888 | } else { |
| 889 | print qq{ I could not find or open your .netrc file.\n} |
| 890 | } |
| 891 | print qq{ If you want to use external ftp, |
| 892 | please enter the host $host (or a default entry) |
| 893 | into your .netrc file and retry. |
| 894 | |
| 895 | The format of a proper entry in your .netrc file would be: |
| 896 | machine $host |
| 897 | login ftp |
| 898 | password $Config::Config{cf_email} |
| 899 | |
| 900 | A typical default entry would be: |
| 901 | default login ftp password $Config::Config{cf_email} |
| 902 | |
| 903 | Please make also sure, your .netrc will not be readable by others. |
| 904 | You don\'t have to leave and restart CPAN.pm, I\'ll look again next |
| 905 | time I come around here.\n\n}; |
| 906 | } |
| 907 | } |
| 908 | sleep 2; |
| 909 | } |
| 910 | if (-x $CPAN::Config->{'lynx'}) { |
| 911 | ## $self->debug("Trying with lynx for [$url]") if $CPAN::DEBUG; |
| 912 | my($want_compressed); |
| 913 | print( |
| 914 | qq{ |
| 915 | Trying with lynx to get $url |
| 916 | As lynx has so many options and versions, we\'re not sure, that we |
| 917 | get it right. It is recommended that you install Net::FTP as soon |
| 918 | as possible. Just type "install Net::FTP". Thank you. |
| 919 | |
| 920 | } |
| 921 | ); |
| 922 | $want_compressed = $aslocal =~ s/\.gz//; |
| 923 | my($system) = "$CPAN::Config->{'lynx'} -source '$url' > $aslocal"; |
| 924 | if (system($system)==0) { |
| 925 | if ($want_compressed) { |
| 926 | $system = "$CPAN::Config->{'gzip'} -dt $aslocal"; |
| 927 | if (system($system)==0) { |
| 928 | rename $aslocal, "$aslocal.gz"; |
| 929 | } else { |
| 930 | $system = "$CPAN::Config->{'gzip'} $aslocal"; |
| 931 | system($system); |
| 932 | } |
| 933 | return "$aslocal.gz"; |
| 934 | } else { |
| 935 | $system = "$CPAN::Config->{'gzip'} -dt $aslocal"; |
| 936 | if (system($system)==0) { |
| 937 | $system = "$CPAN::Config->{'gzip'} -d $aslocal"; |
| 938 | system($system); |
| 939 | } else { |
| 940 | # should be fine, eh? |
| 941 | } |
| 942 | return $aslocal; |
| 943 | } |
| 944 | } |
| 945 | } |
| 946 | warn "Can't access URL $url. |
| 947 | Either get LWP or Net::FTP |
| 948 | or an external lynx or ftp"; |
| 949 | } |
| 950 | Carp::croak("Cannot fetch $file from anywhere"); |
| 951 | } |
| 952 | |
| 953 | package CPAN::FTP::external; |
| 954 | |
| 955 | package CPAN::FTP::netrc; |
| 956 | |
| 957 | sub new { |
| 958 | my($class) = @_; |
| 959 | my $file = MY->catfile($ENV{HOME},".netrc"); |
| 960 | my($fh,@machines,$hasdefault); |
| 961 | $hasdefault = 0; |
| 962 | if($fh = IO::File->new($file,"r")){ |
| 963 | local($/) = ""; |
| 964 | NETRC: while (<$fh>) { |
| 965 | my(@tokens) = split ' ', $_; |
| 966 | TOKEN: while (@tokens) { |
| 967 | my($t) = shift @tokens; |
| 968 | $hasdefault++, last NETRC if $t eq "default"; # we will most |
| 969 | # probably be |
| 970 | # able to anonftp |
| 971 | last TOKEN if $t eq "macdef"; |
| 972 | if ($t eq "machine") { |
| 973 | push @machines, shift @tokens; |
| 974 | } |
| 975 | } |
| 976 | } |
| 977 | } else { |
| 978 | $file = ""; |
| 979 | } |
| 980 | bless { |
| 981 | 'mach' => [@machines], |
| 982 | 'netrc' => $file, |
| 983 | 'hasdefault' => $hasdefault, |
| 984 | }, $class; |
| 985 | } |
| 986 | |
| 987 | sub hasdefault { shift->{'hasdefault'} } |
| 988 | sub netrc { shift->{'netrc'} } |
| 989 | sub contains { |
| 990 | my($self,$mach) = @_; |
| 991 | scalar grep {$_ eq $mach} @{$self->{'mach'}}; |
| 992 | } |
| 993 | |
| 994 | package CPAN::Complete; |
| 995 | @CPAN::Complete::ISA = qw(CPAN::Debug); |
| 996 | |
| 997 | #-> sub CPAN::Complete::complete ; |
| 998 | sub complete { |
| 999 | my($word,$line,$pos) = @_; |
| 1000 | $word ||= ""; |
| 1001 | $line ||= ""; |
| 1002 | $pos ||= 0; |
| 1003 | CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG; |
| 1004 | $line =~ s/^\s*//; |
| 1005 | my @return; |
| 1006 | if ($pos == 0) { |
| 1007 | @return = grep(/^$word/, sort qw(! a b d h i m o q r u autobundle clean make test install reload)); |
| 1008 | } elsif ( $line !~ /^[\!abdhimorut]/ ) { |
| 1009 | @return = (); |
| 1010 | } elsif ($line =~ /^a\s/) { |
| 1011 | @return = completex('CPAN::Author',$word); |
| 1012 | } elsif ($line =~ /^b\s/) { |
| 1013 | @return = completex('CPAN::Bundle',$word); |
| 1014 | } elsif ($line =~ /^d\s/) { |
| 1015 | @return = completex('CPAN::Distribution',$word); |
| 1016 | } elsif ($line =~ /^([mru]\s|(make|clean|test|install)\s)/ ) { |
| 1017 | @return = (completex('CPAN::Module',$word),completex('CPAN::Bundle',$word)); |
| 1018 | } elsif ($line =~ /^i\s/) { |
| 1019 | @return = complete_any($word); |
| 1020 | } elsif ($line =~ /^reload\s/) { |
| 1021 | @return = complete_reload($word,$line,$pos); |
| 1022 | } elsif ($line =~ /^o\s/) { |
| 1023 | @return = complete_option($word,$line,$pos); |
| 1024 | } else { |
| 1025 | @return = (); |
| 1026 | } |
| 1027 | return @return; |
| 1028 | } |
| 1029 | |
| 1030 | #-> sub CPAN::Complete::completex ; |
| 1031 | sub completex { |
| 1032 | my($class, $word) = @_; |
| 1033 | grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class); |
| 1034 | } |
| 1035 | |
| 1036 | #-> sub CPAN::Complete::complete_any ; |
| 1037 | sub complete_any { |
| 1038 | my($word) = shift; |
| 1039 | return ( |
| 1040 | completex('CPAN::Author',$word), |
| 1041 | completex('CPAN::Bundle',$word), |
| 1042 | completex('CPAN::Distribution',$word), |
| 1043 | completex('CPAN::Module',$word), |
| 1044 | ); |
| 1045 | } |
| 1046 | |
| 1047 | #-> sub CPAN::Complete::complete_reload ; |
| 1048 | sub complete_reload { |
| 1049 | my($word,$line,$pos) = @_; |
| 1050 | $word ||= ""; |
| 1051 | my(@words) = split " ", $line; |
| 1052 | CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; |
| 1053 | my(@ok) = qw(cpan index); |
| 1054 | return @ok if @words==1; |
| 1055 | return grep /^\Q$word\E/, @ok if @words==2 && $word; |
| 1056 | } |
| 1057 | |
| 1058 | #-> sub CPAN::Complete::complete_option ; |
| 1059 | sub complete_option { |
| 1060 | my($word,$line,$pos) = @_; |
| 1061 | $word ||= ""; |
| 1062 | my(@words) = split " ", $line; |
| 1063 | CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; |
| 1064 | my(@ok) = qw(conf debug); |
| 1065 | return @ok if @words==1; |
| 1066 | return grep /^\Q$word\E/, @ok if @words==2 && $word; |
| 1067 | if (0) { |
| 1068 | } elsif ($words[1] eq 'index') { |
| 1069 | return (); |
| 1070 | } elsif ($words[1] eq 'conf') { |
| 1071 | return CPAN::Config::complete(@_); |
| 1072 | } elsif ($words[1] eq 'debug') { |
| 1073 | return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all'; |
| 1074 | } |
| 1075 | } |
| 1076 | |
| 1077 | package CPAN::Index; |
| 1078 | use vars qw($last_time); |
| 1079 | @CPAN::Index::ISA = qw(CPAN::Debug); |
| 1080 | $last_time ||= 0; |
| 1081 | |
| 1082 | #-> sub CPAN::Index::force_reload ; |
| 1083 | sub force_reload { |
| 1084 | my($class) = @_; |
| 1085 | $CPAN::Index::last_time = 0; |
| 1086 | $class->reload(1); |
| 1087 | } |
| 1088 | |
| 1089 | #-> sub CPAN::Index::reload ; |
| 1090 | sub reload { |
| 1091 | my($cl,$force) = @_; |
| 1092 | my $time = time; |
| 1093 | |
| 1094 | # XXX check if a newer one is available. (We currently read it from time to time) |
| 1095 | return if $last_time + $CPAN::Config->{index_expire}*86400 > $time; |
| 1096 | $last_time = $time; |
| 1097 | |
| 1098 | $cl->read_authindex($cl->reload_x("authors/01mailrc.txt.gz","01mailrc.gz",$force)); |
| 1099 | return if $CPAN::Signal; # this is sometimes lengthy |
| 1100 | $cl->read_modpacks($cl->reload_x("modules/02packages.details.txt.gz","02packag.gz",$force)); |
| 1101 | return if $CPAN::Signal; # this is sometimes lengthy |
| 1102 | $cl->read_modlist($cl->reload_x("modules/03modlist.data.gz","03mlist.gz",$force)); |
| 1103 | } |
| 1104 | |
| 1105 | #-> sub CPAN::Index::reload_x ; |
| 1106 | sub reload_x { |
| 1107 | my($cl,$wanted,$localname,$force) = @_; |
| 1108 | $force ||= 0; |
| 1109 | my $abs_wanted = CPAN->catfile($CPAN::Config->{'keep_source_where'},$localname); |
| 1110 | if (-f $abs_wanted && -M $abs_wanted < $CPAN::Config->{'index_expire'} && !$force) { |
| 1111 | my($s) = $CPAN::Config->{'index_expire'} != 1; |
| 1112 | $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} day$s. I\'ll use that.\n}); |
| 1113 | return $abs_wanted; |
| 1114 | } else { |
| 1115 | $force ||= 1; |
| 1116 | } |
| 1117 | return CPAN::FTP->localize($wanted,$abs_wanted,$force); |
| 1118 | } |
| 1119 | |
| 1120 | #-> sub CPAN::Index::read_authindex ; |
| 1121 | sub read_authindex { |
| 1122 | my($cl,$index_target) = @_; |
| 1123 | my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; |
| 1124 | warn "Going to read $index_target\n"; |
| 1125 | my $fh = IO::File->new("$pipe|"); |
| 1126 | while (<$fh>) { |
| 1127 | chomp; |
| 1128 | my($userid,$fullname,$email) = /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/; |
| 1129 | next unless $userid && $fullname && $email; |
| 1130 | |
| 1131 | # instantiate an author object |
| 1132 | my $userobj = $CPAN::META->instance('CPAN::Author',$userid); |
| 1133 | $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email); |
| 1134 | return if $CPAN::Signal; |
| 1135 | } |
| 1136 | $fh->close; |
| 1137 | $? and Carp::croak "FAILED $pipe: exit status [$?]"; |
| 1138 | } |
| 1139 | |
| 1140 | #-> sub CPAN::Index::read_modpacks ; |
| 1141 | sub read_modpacks { |
| 1142 | my($cl,$index_target) = @_; |
| 1143 | my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; |
| 1144 | warn "Going to read $index_target\n"; |
| 1145 | my $fh = IO::File->new("$pipe|"); |
| 1146 | while (<$fh>) { |
| 1147 | next if 1../^\s*$/; |
| 1148 | chomp; |
| 1149 | my($mod,$version,$dist) = split; |
| 1150 | $version =~ s/^\+//; |
| 1151 | |
| 1152 | # if it as a bundle, instatiate a bundle object |
| 1153 | my($bundle); |
| 1154 | if ($mod =~ /^Bundle::(.*)/) { |
| 1155 | $bundle = $1; |
| 1156 | } |
| 1157 | |
| 1158 | if ($mod eq 'CPAN') { |
| 1159 | local($^W)=0; |
| 1160 | if ($version > $CPAN::VERSION){ |
| 1161 | print qq{ |
| 1162 | Hey, you know what? There\'s a new CPAN.pm version (v$version) |
| 1163 | available! I\'d suggest--provided you have time--you try |
| 1164 | install CPAN |
| 1165 | reload cpan |
| 1166 | without quitting the current session. It should be a seemless upgrade |
| 1167 | while we are running... |
| 1168 | }; |
| 1169 | sleep 2; |
| 1170 | print qq{\n}; |
| 1171 | } |
| 1172 | } |
| 1173 | |
| 1174 | my($id); |
| 1175 | if ($bundle){ |
| 1176 | $id = $CPAN::META->instance('CPAN::Bundle',$mod); |
| 1177 | $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist); |
| 1178 | # This "next" makes us faster but if the job is running long, we ignore |
| 1179 | # rereads which is bad. So we have to be a bit slower again. |
| 1180 | # } elsif ($CPAN::META->exists('CPAN::Module',$mod)) { |
| 1181 | # next; |
| 1182 | } else { |
| 1183 | # instantiate a module object |
| 1184 | $id = $CPAN::META->instance('CPAN::Module',$mod); |
| 1185 | $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist); |
| 1186 | } |
| 1187 | |
| 1188 | # determine the author |
| 1189 | my($userid) = $dist =~ /([^\/]+)/; |
| 1190 | $id->set('CPAN_USERID' => $userid) if $userid =~ /\w/; |
| 1191 | |
| 1192 | # instantiate a distribution object |
| 1193 | unless ($CPAN::META->exists('CPAN::Distribution',$dist)) { |
| 1194 | $CPAN::META->instance( |
| 1195 | 'CPAN::Distribution' => $dist |
| 1196 | )->set( |
| 1197 | 'CPAN_USERID' => $userid |
| 1198 | ) |
| 1199 | if $userid =~ /\w/; |
| 1200 | } |
| 1201 | |
| 1202 | return if $CPAN::Signal; |
| 1203 | } |
| 1204 | $fh->close; |
| 1205 | $? and Carp::croak "FAILED $pipe: exit status [$?]"; |
| 1206 | } |
| 1207 | |
| 1208 | #-> sub CPAN::Index::read_modlist ; |
| 1209 | sub read_modlist { |
| 1210 | my($cl,$index_target) = @_; |
| 1211 | my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; |
| 1212 | warn "Going to read $index_target\n"; |
| 1213 | my $fh = IO::File->new("$pipe|"); |
| 1214 | my $eval = ""; |
| 1215 | while (<$fh>) { |
| 1216 | next if 1../^\s*$/; |
| 1217 | next if /use vars/; # will go away in 03... |
| 1218 | $eval .= $_; |
| 1219 | return if $CPAN::Signal; |
| 1220 | } |
| 1221 | $eval .= q{CPAN::Modulelist->data;}; |
| 1222 | local($^W) = 0; |
| 1223 | my($comp) = Safe->new("CPAN::Safe1"); |
| 1224 | my $ret = $comp->reval($eval); |
| 1225 | Carp::confess($@) if $@; |
| 1226 | return if $CPAN::Signal; |
| 1227 | for (keys %$ret) { |
| 1228 | my $obj = $CPAN::META->instance(CPAN::Module,$_); |
| 1229 | $obj->set(%{$ret->{$_}}); |
| 1230 | return if $CPAN::Signal; |
| 1231 | } |
| 1232 | } |
| 1233 | |
| 1234 | package CPAN::InfoObj; |
| 1235 | @CPAN::InfoObj::ISA = qw(CPAN::Debug); |
| 1236 | |
| 1237 | #-> sub CPAN::InfoObj::new ; |
| 1238 | sub new { my $this = bless {}, shift; %$this = @_; $this } |
| 1239 | |
| 1240 | #-> sub CPAN::InfoObj::set ; |
| 1241 | sub set { |
| 1242 | my($self,%att) = @_; |
| 1243 | my(%oldatt) = %$self; |
| 1244 | %$self = (%oldatt, %att); |
| 1245 | } |
| 1246 | |
| 1247 | #-> sub CPAN::InfoObj::id ; |
| 1248 | sub id { shift->{'ID'} } |
| 1249 | |
| 1250 | #-> sub CPAN::InfoObj::as_glimpse ; |
| 1251 | sub as_glimpse { |
| 1252 | my($self) = @_; |
| 1253 | my(@m); |
| 1254 | my $class = ref($self); |
| 1255 | $class =~ s/^CPAN:://; |
| 1256 | push @m, sprintf "%-15s %s\n", $class, $self->{ID}; |
| 1257 | join "", @m; |
| 1258 | } |
| 1259 | |
| 1260 | #-> sub CPAN::InfoObj::as_string ; |
| 1261 | sub as_string { |
| 1262 | my($self) = @_; |
| 1263 | my(@m); |
| 1264 | my $class = ref($self); |
| 1265 | $class =~ s/^CPAN:://; |
| 1266 | push @m, $class, " id = $self->{ID}\n"; |
| 1267 | for (sort keys %$self) { |
| 1268 | next if $_ eq 'ID'; |
| 1269 | my $extra = ""; |
| 1270 | $_ eq "CPAN_USERID" and $extra = " (".$self->author.")"; |
| 1271 | if (ref $self->{$_}) { # Should we setup a language interface? XXX |
| 1272 | push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; |
| 1273 | } else { |
| 1274 | push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; |
| 1275 | } |
| 1276 | } |
| 1277 | join "", @m, "\n"; |
| 1278 | } |
| 1279 | |
| 1280 | #-> sub CPAN::InfoObj::author ; |
| 1281 | sub author { |
| 1282 | my($self) = @_; |
| 1283 | $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname; |
| 1284 | } |
| 1285 | |
| 1286 | package CPAN::Author; |
| 1287 | @CPAN::Author::ISA = qw(CPAN::Debug CPAN::InfoObj); |
| 1288 | |
| 1289 | #-> sub CPAN::Author::as_glimpse ; |
| 1290 | sub as_glimpse { |
| 1291 | my($self) = @_; |
| 1292 | my(@m); |
| 1293 | my $class = ref($self); |
| 1294 | $class =~ s/^CPAN:://; |
| 1295 | push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname; |
| 1296 | join "", @m; |
| 1297 | } |
| 1298 | |
| 1299 | # Dead code, I would have liked to have,,, but it was never reached,,, |
| 1300 | #sub make { |
| 1301 | # my($self) = @_; |
| 1302 | # return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n"; |
| 1303 | #} |
| 1304 | |
| 1305 | #-> sub CPAN::Author::fullname ; |
| 1306 | sub fullname { shift->{'FULLNAME'} } |
| 1307 | *name = \&fullname; |
| 1308 | #-> sub CPAN::Author::email ; |
| 1309 | sub email { shift->{'EMAIL'} } |
| 1310 | |
| 1311 | package CPAN::Distribution; |
| 1312 | @CPAN::Distribution::ISA = qw(CPAN::Debug CPAN::InfoObj); |
| 1313 | |
| 1314 | #-> sub CPAN::Distribution::called_for ; |
| 1315 | sub called_for { |
| 1316 | my($self,$id) = @_; |
| 1317 | $self->{'CALLED_FOR'} = $id if defined $id; |
| 1318 | return $self->{'CALLED_FOR'}; |
| 1319 | } |
| 1320 | |
| 1321 | #-> sub CPAN::Distribution::get ; |
| 1322 | sub get { |
| 1323 | my($self) = @_; |
| 1324 | EXCUSE: { |
| 1325 | my @e; |
| 1326 | exists $self->{'build_dir'} and push @e, "Unwrapped into directory $self->{'build_dir'}"; |
| 1327 | print join "", map {" $_\n"} @e and return if @e; |
| 1328 | } |
| 1329 | my($local_file); |
| 1330 | my($local_wanted) = |
| 1331 | CPAN->catfile( |
| 1332 | $CPAN::Config->{keep_source_where}, |
| 1333 | "authors", |
| 1334 | "id", |
| 1335 | split("/",$self->{ID}) |
| 1336 | ); |
| 1337 | |
| 1338 | $self->debug("Doing localize") if $CPAN::DEBUG; |
| 1339 | $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted); |
| 1340 | $self->{localfile} = $local_file; |
| 1341 | my $builddir = $CPAN::META->{cachemgr}->dir; |
| 1342 | $self->debug("doing chdir $builddir") if $CPAN::DEBUG; |
| 1343 | chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); |
| 1344 | my $packagedir; |
| 1345 | |
| 1346 | $self->debug("local_file[$local_file]") if $CPAN::DEBUG; |
| 1347 | if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz|\.zip)$/i){ |
| 1348 | $self->debug("Removing tmp") if $CPAN::DEBUG; |
| 1349 | File::Path::rmtree("tmp"); |
| 1350 | mkdir "tmp", 0777 or Carp::croak "Couldn't mkdir tmp: $!"; |
| 1351 | chdir "tmp"; |
| 1352 | $self->debug("Changed directory to tmp") if $CPAN::DEBUG; |
| 1353 | if ($local_file =~ /z$/i){ |
| 1354 | $self->{archived} = "tar"; |
| 1355 | if (system("$CPAN::Config->{gzip} --decompress --stdout $local_file | $CPAN::Config->{tar} xvf -")==0) { |
| 1356 | $self->{unwrapped} = "YES"; |
| 1357 | } else { |
| 1358 | $self->{unwrapped} = "NO"; |
| 1359 | } |
| 1360 | } elsif ($local_file =~ /zip$/i) { |
| 1361 | $self->{archived} = "zip"; |
| 1362 | if (system("$CPAN::Config->{unzip} $local_file")==0) { |
| 1363 | $self->{unwrapped} = "YES"; |
| 1364 | } else { |
| 1365 | $self->{unwrapped} = "NO"; |
| 1366 | } |
| 1367 | } |
| 1368 | # Let's check if the package has its own directory. |
| 1369 | opendir DIR, "." or Carp::croak("Weird: couldn't opendir .: $!"); |
| 1370 | my @readdir = grep $_ !~ /^\.\.?$/, readdir DIR; ### MAC?? |
| 1371 | closedir DIR; |
| 1372 | my ($distdir,$packagedir); |
| 1373 | if (@readdir == 1 && -d $readdir[0]) { |
| 1374 | $distdir = $readdir[0]; |
| 1375 | $packagedir = $CPAN::META->catdir($builddir,$distdir); |
| 1376 | -d $packagedir and print "Removing previously used $packagedir\n"; |
| 1377 | File::Path::rmtree($packagedir); |
| 1378 | rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!"); |
| 1379 | } else { |
| 1380 | my $pragmatic_dir = $self->{'CPAN_USERID'} . '000'; |
| 1381 | $pragmatic_dir =~ s/\W_//g; |
| 1382 | $pragmatic_dir++ while -d "../$pragmatic_dir"; |
| 1383 | $packagedir = $CPAN::META->catdir($builddir,$pragmatic_dir); |
| 1384 | File::Path::mkpath($packagedir); |
| 1385 | my($f); |
| 1386 | for $f (@readdir) { # is already without "." and ".." |
| 1387 | my $to = $CPAN::META->catdir($packagedir,$f); |
| 1388 | rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!"); |
| 1389 | } |
| 1390 | } |
| 1391 | $self->{'build_dir'} = $packagedir; |
| 1392 | |
| 1393 | chdir ".."; |
| 1394 | $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") if $CPAN::DEBUG; |
| 1395 | File::Path::rmtree("tmp"); |
| 1396 | if ($CPAN::Config->{keep_source_where} =~ /^no/i ){ |
| 1397 | print "Going to unlink $local_file\n"; |
| 1398 | unlink $local_file or Carp::carp "Couldn't unlink $local_file"; |
| 1399 | } |
| 1400 | my($makefilepl) = $CPAN::META->catfile($packagedir,"Makefile.PL"); |
| 1401 | unless (-f $makefilepl) { |
| 1402 | my($configure) = $CPAN::META->catfile($packagedir,"Configure"); |
| 1403 | if (-f $configure) { |
| 1404 | # do we have anything to do? |
| 1405 | $self->{'configure'} = $configure; |
| 1406 | } else { |
| 1407 | my $fh = IO::File->new(">$makefilepl") or Carp::croak("Could not open >$makefilepl"); |
| 1408 | my $cf = $self->called_for || "unknown"; |
| 1409 | $fh->print(qq{ |
| 1410 | # This Makefile.PL has been autogenerated by the module CPAN.pm |
| 1411 | # Autogenerated on: }.scalar localtime().qq{ |
| 1412 | use ExtUtils::MakeMaker; |
| 1413 | WriteMakefile(NAME => q[$cf]); |
| 1414 | }); |
| 1415 | print qq{Package comes without Makefile.PL.\n}. |
| 1416 | qq{ Writing one on our own (calling it $cf)\n}; |
| 1417 | } |
| 1418 | } |
| 1419 | } else { |
| 1420 | $self->{archived} = "NO"; |
| 1421 | } |
| 1422 | return $self; |
| 1423 | } |
| 1424 | |
| 1425 | #-> sub CPAN::Distribution::new ; |
| 1426 | sub new { |
| 1427 | my($class,%att) = @_; |
| 1428 | |
| 1429 | $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); |
| 1430 | |
| 1431 | my $this = { %att }; |
| 1432 | return bless $this, $class; |
| 1433 | } |
| 1434 | |
| 1435 | #-> sub CPAN::Distribution::readme ; |
| 1436 | sub readme { |
| 1437 | my($self) = @_; |
| 1438 | print "Readme not yet implemented (says ".$self->id.")\n"; |
| 1439 | } |
| 1440 | |
| 1441 | #-> sub CPAN::Distribution::verifyMD5 ; |
| 1442 | sub verifyMD5 { |
| 1443 | my($self) = @_; |
| 1444 | EXCUSE: { |
| 1445 | my @e; |
| 1446 | $self->{MD5_STATUS} and push @e, "MD5 Checksum was ok"; |
| 1447 | print join "", map {" $_\n"} @e and return if @e; |
| 1448 | } |
| 1449 | my($local_file); |
| 1450 | my(@local) = split("/",$self->{ID}); |
| 1451 | my($basename) = pop @local; |
| 1452 | push @local, "CHECKSUMS"; |
| 1453 | my($local_wanted) = |
| 1454 | CPAN->catfile( |
| 1455 | $CPAN::Config->{keep_source_where}, |
| 1456 | "authors", |
| 1457 | "id", |
| 1458 | @local |
| 1459 | ); |
| 1460 | local($") = "/"; |
| 1461 | if ( |
| 1462 | -f $local_wanted |
| 1463 | && |
| 1464 | $self->MD5_check_file($local_wanted,$basename) |
| 1465 | ) { |
| 1466 | return $self->{MD5_STATUS}="OK"; |
| 1467 | } |
| 1468 | $local_file = CPAN::FTP->localize("authors/id/@local", $local_wanted, 'force>:-{'); |
| 1469 | my($checksum_pipe); |
| 1470 | if ($local_file) { |
| 1471 | # fine |
| 1472 | } else { |
| 1473 | $local[-1] .= ".gz"; |
| 1474 | $local_file = CPAN::FTP->localize( |
| 1475 | "authors/id/@local", |
| 1476 | "$local_wanted.gz", |
| 1477 | 'force>:-{' |
| 1478 | ); |
| 1479 | my $system = "$CPAN::Config->{gzip} --decompress $local_file"; |
| 1480 | system($system)==0 or die "Could not uncompress $local_file"; |
| 1481 | $local_file =~ s/\.gz$//; |
| 1482 | } |
| 1483 | $self->MD5_check_file($local_file,$basename); |
| 1484 | } |
| 1485 | |
| 1486 | #-> sub CPAN::Distribution::MD5_check_file ; |
| 1487 | sub MD5_check_file { |
| 1488 | my($self,$lfile,$basename) = @_; |
| 1489 | my($cksum); |
| 1490 | my $fh = new IO::File; |
| 1491 | local($/)=undef; |
| 1492 | if (open $fh, $lfile){ |
| 1493 | my $eval = <$fh>; |
| 1494 | close $fh; |
| 1495 | my($comp) = Safe->new(); |
| 1496 | $cksum = $comp->reval($eval); |
| 1497 | Carp::confess($@) if $@; |
| 1498 | if ($cksum->{$basename}->{md5}) { |
| 1499 | $self->debug("Found checksum for $basename: $cksum->{$basename}->{md5}\n") if $CPAN::DEBUG; |
| 1500 | my $file = $self->{localfile}; |
| 1501 | my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $self->{localfile}|"; |
| 1502 | if ( |
| 1503 | open($fh, $file) && $self->eq_MD5($fh,$cksum->{$basename}->{md5}) |
| 1504 | or |
| 1505 | open($fh, $pipe) && $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'}) |
| 1506 | ){ |
| 1507 | print "Checksum for $file ok\n"; |
| 1508 | return $self->{MD5_STATUS}="OK"; |
| 1509 | } else { |
| 1510 | die join( |
| 1511 | "", |
| 1512 | "\nChecksum mismatch for distribution file. Please investigate.\n\n", |
| 1513 | $self->as_string, |
| 1514 | $CPAN::META->instance('CPAN::Author',$self->{CPAN_USERID})->as_string, |
| 1515 | "Please contact the author or your CPAN site admin" |
| 1516 | ); |
| 1517 | } |
| 1518 | close $fh if fileno($fh); |
| 1519 | } else { |
| 1520 | print "No md5 checksum for $basename in local $lfile\n"; |
| 1521 | return; |
| 1522 | } |
| 1523 | } else { |
| 1524 | Carp::carp "Could not open $lfile for reading"; |
| 1525 | } |
| 1526 | } |
| 1527 | |
| 1528 | #-> sub CPAN::Distribution::eq_MD5 ; |
| 1529 | sub eq_MD5 { |
| 1530 | my($self,$fh,$expectMD5) = @_; |
| 1531 | my $md5 = new MD5; |
| 1532 | $md5->addfile($fh); |
| 1533 | my $hexdigest = $md5->hexdigest; |
| 1534 | $hexdigest eq $expectMD5; |
| 1535 | } |
| 1536 | |
| 1537 | #-> sub CPAN::Distribution::force ; |
| 1538 | sub force { |
| 1539 | my($self) = @_; |
| 1540 | $self->{'force_update'}++; |
| 1541 | delete $self->{'MD5_STATUS'}; |
| 1542 | delete $self->{'archived'}; |
| 1543 | delete $self->{'build_dir'}; |
| 1544 | delete $self->{'localfile'}; |
| 1545 | delete $self->{'make'}; |
| 1546 | delete $self->{'install'}; |
| 1547 | delete $self->{'unwrapped'}; |
| 1548 | delete $self->{'writemakefile'}; |
| 1549 | } |
| 1550 | |
| 1551 | #-> sub CPAN::Distribution::make ; |
| 1552 | sub make { |
| 1553 | my($self) = @_; |
| 1554 | $self->debug($self->id) if $CPAN::DEBUG; |
| 1555 | print "Running make\n"; |
| 1556 | $self->get; |
| 1557 | if ($CPAN::META->hasMD5) { |
| 1558 | $self->verifyMD5; |
| 1559 | } |
| 1560 | EXCUSE: { |
| 1561 | my @e; |
| 1562 | $self->{archived} eq "NO" and push @e, "Is neither a tar nor a zip archive."; |
| 1563 | $self->{unwrapped} eq "NO" and push @e, "had problems unarchiving. Please build manually"; |
| 1564 | exists $self->{writemakefile} && $self->{writemakefile} eq "NO" and push @e, "Had some problem writing Makefile"; |
| 1565 | defined $self->{'make'} and push @e, "Has already been processed within this session"; |
| 1566 | print join "", map {" $_\n"} @e and return if @e; |
| 1567 | } |
| 1568 | print "\n CPAN: Going to build ".$self->id."\n\n"; |
| 1569 | my $builddir = $self->dir; |
| 1570 | chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); |
| 1571 | $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; |
| 1572 | |
| 1573 | my $system; |
| 1574 | if ($self->{'configure'}) { |
| 1575 | $system = $self->{'configure'}; |
| 1576 | } else { |
| 1577 | my($perl) = $^X =~ /^\.\// ? "$CPAN::Cwd/$^X" : $^X; # XXX subclassing folks, forgive me! |
| 1578 | $system = "$perl Makefile.PL $CPAN::Config->{makepl_arg}"; |
| 1579 | } |
| 1580 | $SIG{ALRM} = sub { die "inactivity_timeout reached\n" }; |
| 1581 | my($ret,$pid); |
| 1582 | $@ = ""; |
| 1583 | if ($CPAN::Config->{inactivity_timeout}) { |
| 1584 | eval { |
| 1585 | alarm $CPAN::Config->{inactivity_timeout}; |
| 1586 | #$SIG{CHLD} = \&REAPER; |
| 1587 | if (defined($pid=fork)) { |
| 1588 | if ($pid) { #parent |
| 1589 | wait; |
| 1590 | } else { #child |
| 1591 | exec $system; |
| 1592 | } |
| 1593 | } else { |
| 1594 | print "Cannot fork: $!"; |
| 1595 | return; |
| 1596 | } |
| 1597 | $ret = system($system); |
| 1598 | }; |
| 1599 | alarm 0; |
| 1600 | } else { |
| 1601 | $ret = system($system); |
| 1602 | } |
| 1603 | if ($@){ |
| 1604 | kill 9, $pid; |
| 1605 | waitpid $pid, 0; |
| 1606 | print $@; |
| 1607 | $self->{writemakefile} = "NO - $@"; |
| 1608 | $@ = ""; |
| 1609 | return; |
| 1610 | } elsif ($ret != 0) { |
| 1611 | $self->{writemakefile} = "NO"; |
| 1612 | return; |
| 1613 | } |
| 1614 | $self->{writemakefile} = "YES"; |
| 1615 | return if $CPAN::Signal; |
| 1616 | $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg}; |
| 1617 | if (system($system)==0) { |
| 1618 | print " $system -- OK\n"; |
| 1619 | $self->{'make'} = "YES"; |
| 1620 | } else { |
| 1621 | $self->{writemakefile} = "YES"; |
| 1622 | $self->{'make'} = "NO"; |
| 1623 | print " $system -- NOT OK\n"; |
| 1624 | } |
| 1625 | } |
| 1626 | |
| 1627 | #-> sub CPAN::Distribution::test ; |
| 1628 | sub test { |
| 1629 | my($self) = @_; |
| 1630 | $self->make; |
| 1631 | return if $CPAN::Signal; |
| 1632 | print "Running make test\n"; |
| 1633 | EXCUSE: { |
| 1634 | my @e; |
| 1635 | exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't test"; |
| 1636 | exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status"; |
| 1637 | exists $self->{'build_dir'} or push @e, "Has no own directory"; |
| 1638 | print join "", map {" $_\n"} @e and return if @e; |
| 1639 | } |
| 1640 | chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}"); |
| 1641 | $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; |
| 1642 | my $system = join " ", $CPAN::Config->{'make'}, "test"; |
| 1643 | if (system($system)==0) { |
| 1644 | print " $system -- OK\n"; |
| 1645 | $self->{'make_test'} = "YES"; |
| 1646 | } else { |
| 1647 | $self->{'make_test'} = "NO"; |
| 1648 | print " $system -- NOT OK\n"; |
| 1649 | } |
| 1650 | } |
| 1651 | |
| 1652 | #-> sub CPAN::Distribution::clean ; |
| 1653 | sub clean { |
| 1654 | my($self) = @_; |
| 1655 | print "Running make clean\n"; |
| 1656 | EXCUSE: { |
| 1657 | my @e; |
| 1658 | exists $self->{'build_dir'} or push @e, "Has no own directory"; |
| 1659 | print join "", map {" $_\n"} @e and return if @e; |
| 1660 | } |
| 1661 | chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}"); |
| 1662 | $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; |
| 1663 | my $system = join " ", $CPAN::Config->{'make'}, "clean"; |
| 1664 | if (system($system)==0) { |
| 1665 | print " $system -- OK\n"; |
| 1666 | $self->force; |
| 1667 | } else { |
| 1668 | # Hmmm, what to do if make clean failed? |
| 1669 | } |
| 1670 | } |
| 1671 | |
| 1672 | #-> sub CPAN::Distribution::install ; |
| 1673 | sub install { |
| 1674 | my($self) = @_; |
| 1675 | $self->test; |
| 1676 | return if $CPAN::Signal; |
| 1677 | print "Running make install\n"; |
| 1678 | EXCUSE: { |
| 1679 | my @e; |
| 1680 | exists $self->{'build_dir'} or push @e, "Has no own directory"; |
| 1681 | exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't install"; |
| 1682 | exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status"; |
| 1683 | exists $self->{'install'} and push @e, $self->{'install'} eq "YES" ? "Already done" : "Already tried without success"; |
| 1684 | print join "", map {" $_\n"} @e and return if @e; |
| 1685 | } |
| 1686 | chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}"); |
| 1687 | $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; |
| 1688 | my $system = join " ", $CPAN::Config->{'make'}, "install", $CPAN::Config->{make_install_arg}; |
| 1689 | my($pipe) = IO::File->new("$system 2>&1 |"); |
| 1690 | my($makeout) = ""; |
| 1691 | |
| 1692 | # #If I were to try this, I'd do something like: |
| 1693 | # # |
| 1694 | # # $SIG{ALRM} = sub { die "alarm\n" }; |
| 1695 | # # |
| 1696 | # # open(PROC,"make somesuch|"); |
| 1697 | # # eval { |
| 1698 | # # alarm 30; |
| 1699 | # # while(<PROC>) { |
| 1700 | # # alarm 30; |
| 1701 | # # } |
| 1702 | # # } |
| 1703 | # # close(PROC); |
| 1704 | # # alarm 0; |
| 1705 | # # |
| 1706 | # #I'm really not sure how reliable this would is, though. |
| 1707 | # # |
| 1708 | # #-- |
| 1709 | # #Kenneth Albanowski (kjahds@kjahds.com, CIS: 70705,126) |
| 1710 | # # |
| 1711 | # # |
| 1712 | # # |
| 1713 | # # |
| 1714 | while (<$pipe>){ |
| 1715 | print; |
| 1716 | $makeout .= $_; |
| 1717 | } |
| 1718 | $pipe->close; |
| 1719 | if ($?==0) { |
| 1720 | print " $system -- OK\n"; |
| 1721 | $self->{'install'} = "YES"; |
| 1722 | } else { |
| 1723 | $self->{'install'} = "NO"; |
| 1724 | print " $system -- NOT OK\n"; |
| 1725 | if ($makeout =~ /permission/s && $> > 0) { |
| 1726 | print " You may have to su to root to install the package\n"; |
| 1727 | } |
| 1728 | } |
| 1729 | } |
| 1730 | |
| 1731 | #-> sub CPAN::Distribution::dir ; |
| 1732 | sub dir { |
| 1733 | shift->{'build_dir'}; |
| 1734 | } |
| 1735 | |
| 1736 | package CPAN::Bundle; |
| 1737 | @CPAN::Bundle::ISA = qw(CPAN::Debug CPAN::InfoObj CPAN::Module); |
| 1738 | |
| 1739 | #-> sub CPAN::Bundle::as_string ; |
| 1740 | sub as_string { |
| 1741 | my($self) = @_; |
| 1742 | $self->contains; |
| 1743 | return $self->SUPER::as_string; |
| 1744 | } |
| 1745 | |
| 1746 | #-> sub CPAN::Bundle::contains ; |
| 1747 | sub contains { |
| 1748 | my($self) = @_; |
| 1749 | my($parsefile) = $self->inst_file; |
| 1750 | unless ($parsefile) { |
| 1751 | # Try to get at it in the cpan directory |
| 1752 | $self->debug("no parsefile") if $CPAN::DEBUG; |
| 1753 | my $dist = $CPAN::META->instance('CPAN::Distribution',$self->{'CPAN_FILE'}); |
| 1754 | $self->debug($dist->as_string) if $CPAN::DEBUG; |
| 1755 | $dist->get; |
| 1756 | $self->debug($dist->as_string) if $CPAN::DEBUG; |
| 1757 | my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle"); |
| 1758 | File::Path::mkpath($todir); |
| 1759 | my($me,$from,$to); |
| 1760 | ($me = $self->id) =~ s/.*://; |
| 1761 | $from = $CPAN::META->catfile($dist->{'build_dir'},"$me.pm"); |
| 1762 | $to = $CPAN::META->catfile($todir,"$me.pm"); |
| 1763 | File::Copy::copy($from, $to) or Carp::confess("Couldn't copy $from to $to: $!"); |
| 1764 | $parsefile = $to; |
| 1765 | } |
| 1766 | my @result; |
| 1767 | my $fh = new IO::File; |
| 1768 | local $/ = "\n"; |
| 1769 | open($fh,$parsefile) or die "Could not open '$parsefile': $!"; |
| 1770 | my $inpod = 0; |
| 1771 | while (<$fh>) { |
| 1772 | $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : /^=head1\s+CONTENTS/ ? 1 : $inpod; |
| 1773 | next unless $inpod; |
| 1774 | next if /^=/; |
| 1775 | next if /^\s+$/; |
| 1776 | chomp; |
| 1777 | push @result, (split " ", $_, 2)[0]; |
| 1778 | } |
| 1779 | close $fh; |
| 1780 | delete $self->{STATUS}; |
| 1781 | $self->{CONTAINS} = [@result]; |
| 1782 | @result; |
| 1783 | } |
| 1784 | |
| 1785 | #-> sub CPAN::Bundle::inst_file ; |
| 1786 | sub inst_file { |
| 1787 | my($self) = @_; |
| 1788 | my($me,$inst_file); |
| 1789 | ($me = $self->id) =~ s/.*://; |
| 1790 | $inst_file = $CPAN::META->catfile($CPAN::Config->{'cpan_home'},"Bundle", "$me.pm"); |
| 1791 | return $self->{'INST_FILE'} = $inst_file if -f $inst_file; |
| 1792 | $inst_file = $self->SUPER::inst_file; |
| 1793 | return $self->{'INST_FILE'} = $inst_file if -f $inst_file; |
| 1794 | return $self->{'INST_FILE'}; # even if undefined? |
| 1795 | } |
| 1796 | |
| 1797 | #-> sub CPAN::Bundle::rematein ; |
| 1798 | sub rematein { |
| 1799 | my($self,$meth) = @_; |
| 1800 | $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG; |
| 1801 | my($s); |
| 1802 | for $s ($self->contains) { |
| 1803 | $CPAN::META->instance('CPAN::Module',$s)->$meth(); |
| 1804 | } |
| 1805 | } |
| 1806 | |
| 1807 | #-> sub CPAN::Bundle::force ; |
| 1808 | sub force { shift->rematein('force',@_); } |
| 1809 | #-> sub CPAN::Bundle::install ; |
| 1810 | sub install { shift->rematein('install',@_); } |
| 1811 | #-> sub CPAN::Bundle::clean ; |
| 1812 | sub clean { shift->rematein('clean',@_); } |
| 1813 | #-> sub CPAN::Bundle::test ; |
| 1814 | sub test { shift->rematein('test',@_); } |
| 1815 | #-> sub CPAN::Bundle::make ; |
| 1816 | sub make { shift->rematein('make',@_); } |
| 1817 | |
| 1818 | # XXX not yet implemented! |
| 1819 | #-> sub CPAN::Bundle::readme ; |
| 1820 | sub readme { |
| 1821 | my($self) = @_; |
| 1822 | my($file) = $self->cpan_file or print("No File found for bundle ", $self->id, "\n"), return; |
| 1823 | $self->debug("self[$self] file[$file]") if $CPAN::DEBUG; |
| 1824 | $CPAN::META->instance('CPAN::Distribution',$file)->readme; |
| 1825 | # CPAN::FTP->localize("authors/id/$file",$index_wanted); # XXX |
| 1826 | } |
| 1827 | |
| 1828 | package CPAN::Module; |
| 1829 | @CPAN::Module::ISA = qw(CPAN::Debug CPAN::InfoObj); |
| 1830 | |
| 1831 | #-> sub CPAN::Module::as_glimpse ; |
| 1832 | sub as_glimpse { |
| 1833 | my($self) = @_; |
| 1834 | my(@m); |
| 1835 | my $class = ref($self); |
| 1836 | $class =~ s/^CPAN:://; |
| 1837 | push @m, sprintf "%-15s %-15s (%s)\n", $class, $self->{ID}, $self->cpan_file; |
| 1838 | join "", @m; |
| 1839 | } |
| 1840 | |
| 1841 | #-> sub CPAN::Module::as_string ; |
| 1842 | sub as_string { |
| 1843 | my($self) = @_; |
| 1844 | my(@m); |
| 1845 | CPAN->debug($self) if $CPAN::DEBUG; |
| 1846 | my $class = ref($self); |
| 1847 | $class =~ s/^CPAN:://; |
| 1848 | local($^W) = 0; |
| 1849 | push @m, $class, " id = $self->{ID}\n"; |
| 1850 | my $sprintf = " %-12s %s\n"; |
| 1851 | push @m, sprintf $sprintf, 'DESCRIPTION', $self->{description} if $self->{description}; |
| 1852 | my $sprintf2 = " %-12s %s (%s)\n"; |
| 1853 | my($userid); |
| 1854 | if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){ |
| 1855 | push @m, sprintf( |
| 1856 | $sprintf2, |
| 1857 | 'CPAN_USERID', |
| 1858 | $userid, |
| 1859 | $CPAN::META->instance(CPAN::Author,$userid)->fullname |
| 1860 | ) |
| 1861 | } |
| 1862 | push @m, sprintf $sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION} if $self->{CPAN_VERSION}; |
| 1863 | push @m, sprintf $sprintf, 'CPAN_FILE', $self->{CPAN_FILE} if $self->{CPAN_FILE}; |
| 1864 | my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n"; |
| 1865 | my(%statd,%stats,%statl,%stati); |
| 1866 | @statd{qw,? i c a b R M S,} = qw,unknown idea pre-alpha alpha beta released mature standard,; |
| 1867 | @stats{qw,? m d u n,} = qw,unknown mailing-list developer comp.lang.perl.* none,; |
| 1868 | @statl{qw,? p c + o,} = qw,unknown perl C C++ other,; |
| 1869 | @stati{qw,? f r O,} = qw,unknown functions references+ties object-oriented,; |
| 1870 | $statd{' '} = 'unknown'; |
| 1871 | $stats{' '} = 'unknown'; |
| 1872 | $statl{' '} = 'unknown'; |
| 1873 | $stati{' '} = 'unknown'; |
| 1874 | push @m, sprintf( |
| 1875 | $sprintf3, |
| 1876 | 'DSLI_STATUS', |
| 1877 | $self->{statd}, |
| 1878 | $self->{stats}, |
| 1879 | $self->{statl}, |
| 1880 | $self->{stati}, |
| 1881 | $statd{$self->{statd}}, |
| 1882 | $stats{$self->{stats}}, |
| 1883 | $statl{$self->{statl}}, |
| 1884 | $stati{$self->{stati}} |
| 1885 | ) if $self->{statd}; |
| 1886 | my $local_file = $self->inst_file; |
| 1887 | if ($local_file && ! exists $self->{MANPAGE}) { |
| 1888 | my $fh = IO::File->new($local_file) or Carp::croak("Couldn't open $local_file: $!"); |
| 1889 | my $inpod = 0; |
| 1890 | my(@result); |
| 1891 | local $/ = "\n"; |
| 1892 | while (<$fh>) { |
| 1893 | $inpod = /^=(?!head1\s+NAME)/ ? 0 : /^=head1\s+NAME/ ? 1 : $inpod; |
| 1894 | next unless $inpod; |
| 1895 | next if /^=/; |
| 1896 | next if /^\s+$/; |
| 1897 | chomp; |
| 1898 | push @result, $_; |
| 1899 | } |
| 1900 | close $fh; |
| 1901 | $self->{MANPAGE} = join " ", @result; |
| 1902 | } |
| 1903 | push @m, sprintf $sprintf, 'MANPAGE', $self->{MANPAGE} if $self->{MANPAGE}; |
| 1904 | push @m, sprintf $sprintf, 'INST_FILE', $local_file || "(not installed)"; |
| 1905 | push @m, sprintf $sprintf, 'INST_VERSION', $self->inst_version if $local_file; |
| 1906 | join "", @m, "\n"; |
| 1907 | } |
| 1908 | |
| 1909 | #-> sub CPAN::Module::cpan_file ; |
| 1910 | sub cpan_file { |
| 1911 | my $self = shift; |
| 1912 | CPAN->debug($self->id) if $CPAN::DEBUG; |
| 1913 | unless (defined $self->{'CPAN_FILE'}) { |
| 1914 | CPAN::Index->reload; |
| 1915 | } |
| 1916 | if (defined $self->{'CPAN_FILE'}){ |
| 1917 | return $self->{'CPAN_FILE'}; |
| 1918 | } elsif (defined $self->{'userid'}) { |
| 1919 | return "Contact Author ".$self->{'userid'}."=".$CPAN::META->instance(CPAN::Author,$self->{'userid'})->fullname |
| 1920 | } else { |
| 1921 | return "N/A"; |
| 1922 | } |
| 1923 | } |
| 1924 | |
| 1925 | *name = \&cpan_file; |
| 1926 | |
| 1927 | #-> sub CPAN::Module::cpan_version ; |
| 1928 | sub cpan_version { shift->{'CPAN_VERSION'} } |
| 1929 | |
| 1930 | #-> sub CPAN::Module::force ; |
| 1931 | sub force { |
| 1932 | my($self) = @_; |
| 1933 | $self->{'force_update'}++; |
| 1934 | } |
| 1935 | |
| 1936 | #-> sub CPAN::Module::rematein ; |
| 1937 | sub rematein { |
| 1938 | my($self,$meth) = @_; |
| 1939 | $self->debug($self->id) if $CPAN::DEBUG; |
| 1940 | my $cpan_file = $self->cpan_file; |
| 1941 | return if $cpan_file eq "N/A"; |
| 1942 | return if $cpan_file =~ /^Contact Author/; |
| 1943 | my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); |
| 1944 | $pack->called_for($self->id); |
| 1945 | $pack->force if exists $self->{'force_update'}; |
| 1946 | $pack->$meth(); |
| 1947 | delete $self->{'force_update'}; |
| 1948 | } |
| 1949 | |
| 1950 | #-> sub CPAN::Module::readme ; |
| 1951 | sub readme { shift->rematein('readme') } |
| 1952 | #-> sub CPAN::Module::make ; |
| 1953 | sub make { shift->rematein('make') } |
| 1954 | #-> sub CPAN::Module::clean ; |
| 1955 | sub clean { shift->rematein('clean') } |
| 1956 | #-> sub CPAN::Module::test ; |
| 1957 | sub test { shift->rematein('test') } |
| 1958 | #-> sub CPAN::Module::install ; |
| 1959 | sub install { |
| 1960 | my($self) = @_; |
| 1961 | my($doit) = 0; |
| 1962 | my($latest) = $self->cpan_version; |
| 1963 | $latest ||= 0; |
| 1964 | my($inst_file) = $self->inst_file; |
| 1965 | my($have) = 0; |
| 1966 | if (defined $inst_file) { |
| 1967 | $have = $self->inst_version; |
| 1968 | } |
| 1969 | if ($inst_file && $have >= $latest && not exists $self->{'force_update'}) { |
| 1970 | print $self->id, " is up to date.\n"; |
| 1971 | } else { |
| 1972 | $doit = 1; |
| 1973 | } |
| 1974 | $self->rematein('install') if $doit; |
| 1975 | } |
| 1976 | |
| 1977 | #-> sub CPAN::Module::inst_file ; |
| 1978 | sub inst_file { |
| 1979 | my($self) = @_; |
| 1980 | my($dir,@packpath); |
| 1981 | @packpath = split /::/, $self->{ID}; |
| 1982 | $packpath[-1] .= ".pm"; |
| 1983 | foreach $dir (@INC) { |
| 1984 | my $pmfile = CPAN->catfile($dir,@packpath); |
| 1985 | if (-f $pmfile){ |
| 1986 | return $pmfile; |
| 1987 | } |
| 1988 | } |
| 1989 | } |
| 1990 | |
| 1991 | #-> sub CPAN::Module::xs_file ; |
| 1992 | sub xs_file { |
| 1993 | my($self) = @_; |
| 1994 | my($dir,@packpath); |
| 1995 | @packpath = split /::/, $self->{ID}; |
| 1996 | push @packpath, $packpath[-1]; |
| 1997 | $packpath[-1] .= "." . $Config::Config{'dlext'}; |
| 1998 | foreach $dir (@INC) { |
| 1999 | my $xsfile = CPAN->catfile($dir,'auto',@packpath); |
| 2000 | if (-f $xsfile){ |
| 2001 | return $xsfile; |
| 2002 | } |
| 2003 | } |
| 2004 | } |
| 2005 | |
| 2006 | #-> sub CPAN::Module::inst_version ; |
| 2007 | sub inst_version { |
| 2008 | my($self) = @_; |
| 2009 | my $parsefile = $self->inst_file or return 0; |
| 2010 | my $have = MY->parse_version($parsefile); |
| 2011 | $have ||= 0; |
| 2012 | $have =~ s/\s+//g; |
| 2013 | $have ||= 0; |
| 2014 | $have; |
| 2015 | } |
| 2016 | |
| 2017 | package CPAN::CacheMgr; |
| 2018 | use vars qw($Du); |
| 2019 | @CPAN::CacheMgr::ISA = qw(CPAN::Debug CPAN::InfoObj); |
| 2020 | use File::Find; |
| 2021 | |
| 2022 | #-> sub CPAN::CacheMgr::as_string ; |
| 2023 | sub as_string { |
| 2024 | eval { require Data::Dumper }; |
| 2025 | if ($@) { |
| 2026 | return shift->SUPER::as_string; |
| 2027 | } else { |
| 2028 | return Data::Dumper::Dumper(shift); |
| 2029 | } |
| 2030 | } |
| 2031 | |
| 2032 | #-> sub CPAN::CacheMgr::cachesize ; |
| 2033 | sub cachesize { |
| 2034 | shift->{DU}; |
| 2035 | } |
| 2036 | |
| 2037 | # sub check { |
| 2038 | # my($self,@dirs) = @_; |
| 2039 | # return unless -d $self->{ID}; |
| 2040 | # my $dir; |
| 2041 | # @dirs = $self->dirs unless @dirs; |
| 2042 | # for $dir (@dirs) { |
| 2043 | # $self->disk_usage($dir); |
| 2044 | # } |
| 2045 | # } |
| 2046 | |
| 2047 | #-> sub CPAN::CacheMgr::clean_cache ; |
| 2048 | sub clean_cache { |
| 2049 | my $self = shift; |
| 2050 | my $dir; |
| 2051 | while ($self->{DU} > $self->{'MAX'} and $dir = shift @{$self->{FIFO}}) { |
| 2052 | $self->force_clean_cache($dir); |
| 2053 | } |
| 2054 | $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG; |
| 2055 | } |
| 2056 | |
| 2057 | #-> sub CPAN::CacheMgr::dir ; |
| 2058 | sub dir { |
| 2059 | shift->{ID}; |
| 2060 | } |
| 2061 | |
| 2062 | #-> sub CPAN::CacheMgr::entries ; |
| 2063 | sub entries { |
| 2064 | my($self,$dir) = @_; |
| 2065 | $dir ||= $self->{ID}; |
| 2066 | my($cwd) = Cwd::cwd(); |
| 2067 | chdir $dir or Carp::croak("Can't chdir to $dir: $!"); |
| 2068 | my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!"); |
| 2069 | my(@entries); |
| 2070 | for ($dh->read) { |
| 2071 | next if $_ eq "." || $_ eq ".."; |
| 2072 | if (-f $_) { |
| 2073 | push @entries, $CPAN::META->catfile($dir,$_); |
| 2074 | } elsif (-d _) { |
| 2075 | push @entries, $CPAN::META->catdir($dir,$_); |
| 2076 | } else { |
| 2077 | print STDERR "Warning: weird direntry in $dir: $_\n"; |
| 2078 | } |
| 2079 | } |
| 2080 | chdir $cwd or Carp::croak("Can't chdir to $cwd: $!"); |
| 2081 | sort {-M $b <=> -M $a} @entries; |
| 2082 | } |
| 2083 | |
| 2084 | #-> sub CPAN::CacheMgr::disk_usage ; |
| 2085 | sub disk_usage { |
| 2086 | my($self,$dir) = @_; |
| 2087 | if (! defined $dir or $dir eq "") { |
| 2088 | $self->debug("Cannot determine disk usage for some reason") if $CPAN::DEBUG; |
| 2089 | return; |
| 2090 | } |
| 2091 | return if defined $self->{SIZE}{$dir}; |
| 2092 | local($Du) = 0; |
| 2093 | find( |
| 2094 | sub { |
| 2095 | return if -l $_; |
| 2096 | $Du += -s; |
| 2097 | }, |
| 2098 | $dir |
| 2099 | ); |
| 2100 | $self->{SIZE}{$dir} = $Du/1024/1024; |
| 2101 | push @{$self->{FIFO}}, $dir; |
| 2102 | $self->debug("measured $dir is $Du") if $CPAN::DEBUG; |
| 2103 | $self->{DU} += $Du/1024/1024; |
| 2104 | if ($self->{DU} > $self->{'MAX'} ) { |
| 2105 | printf "...Hold on a sec... CPAN's cleaning the cache: %.2f MB > %.2f MB\n", |
| 2106 | $self->{DU}, $self->{'MAX'}; |
| 2107 | $self->clean_cache; |
| 2108 | } else { |
| 2109 | $self->debug("NOT have to clean the cache: $self->{DU} <= $self->{'MAX'}") if $CPAN::DEBUG; |
| 2110 | $self->debug($self->as_string) if $CPAN::DEBUG; |
| 2111 | } |
| 2112 | $self->{DU}; |
| 2113 | } |
| 2114 | |
| 2115 | #-> sub CPAN::CacheMgr::force_clean_cache ; |
| 2116 | sub force_clean_cache { |
| 2117 | my($self,$dir) = @_; |
| 2118 | $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") if $CPAN::DEBUG; |
| 2119 | File::Path::rmtree($dir); |
| 2120 | $self->{DU} -= $self->{SIZE}{$dir}; |
| 2121 | delete $self->{SIZE}{$dir}; |
| 2122 | } |
| 2123 | |
| 2124 | #-> sub CPAN::CacheMgr::new ; |
| 2125 | sub new { |
| 2126 | my $class = shift; |
| 2127 | my $self = { ID => $CPAN::Config->{'build_dir'}, MAX => $CPAN::Config->{'build_cache'}, DU => 0 }; |
| 2128 | File::Path::mkpath($self->{ID}); |
| 2129 | my $dh = DirHandle->new($self->{ID}); |
| 2130 | bless $self, $class; |
| 2131 | $self->debug("dir [$self->{ID}]") if $CPAN::DEBUG; |
| 2132 | my $e; |
| 2133 | for $e ($self->entries) { |
| 2134 | next if $e eq ".." || $e eq "."; |
| 2135 | $self->debug("Have to check size $e") if $CPAN::DEBUG; |
| 2136 | $self->disk_usage($e); |
| 2137 | } |
| 2138 | $self; |
| 2139 | } |
| 2140 | |
| 2141 | package CPAN::Debug; |
| 2142 | |
| 2143 | #-> sub CPAN::Debug::debug ; |
| 2144 | sub debug { |
| 2145 | my($self,$arg) = @_; |
| 2146 | my($caller,$func,$line,@rest) = caller(1); # caller(0) eg Complete, caller(1) eg readline |
| 2147 | ($caller) = caller(0); |
| 2148 | $caller =~ s/.*:://; |
| 2149 | # print "caller[$caller]func[$func]line[$line]rest[@rest]\n"; |
| 2150 | # print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]CPAN::DEBUG[$CPAN::DEBUG]\n"; |
| 2151 | if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){ |
| 2152 | if (ref $arg) { |
| 2153 | eval { require Data::Dumper }; |
| 2154 | if ($@) { |
| 2155 | print $arg->as_string; |
| 2156 | } else { |
| 2157 | print Data::Dumper::Dumper($arg); |
| 2158 | } |
| 2159 | } else { |
| 2160 | print "Debug($caller:$func,$line,@rest): $arg\n" |
| 2161 | } |
| 2162 | } |
| 2163 | } |
| 2164 | |
| 2165 | package CPAN::Config; |
| 2166 | import ExtUtils::MakeMaker 'neatvalue'; |
| 2167 | use vars qw(%can); |
| 2168 | |
| 2169 | %can = ( |
| 2170 | 'commit' => "Commit changes to disk", |
| 2171 | 'defaults' => "Reload defaults from disk", |
| 2172 | ); |
| 2173 | |
| 2174 | #-> sub CPAN::Config::edit ; |
| 2175 | sub edit { |
| 2176 | my($class,@args) = @_; |
| 2177 | return unless @args; |
| 2178 | CPAN->debug("class[$class]args[".join(" | ",@args)."]"); |
| 2179 | my($o,$str,$func,$args,$key_exists); |
| 2180 | $o = shift @args; |
| 2181 | if($can{$o}) { |
| 2182 | $class->$o(@args); |
| 2183 | return 1; |
| 2184 | } else { |
| 2185 | if (ref($CPAN::Config->{$o}) eq ARRAY) { |
| 2186 | $func = shift @args; |
| 2187 | # Let's avoid eval, it's easier to comprehend without. |
| 2188 | if ($func eq "push") { |
| 2189 | push @{$CPAN::Config->{$o}}, @args; |
| 2190 | } elsif ($func eq "pop") { |
| 2191 | pop @{$CPAN::Config->{$o}}; |
| 2192 | } elsif ($func eq "shift") { |
| 2193 | shift @{$CPAN::Config->{$o}}; |
| 2194 | } elsif ($func eq "unshift") { |
| 2195 | unshift @{$CPAN::Config->{$o}}, @args; |
| 2196 | } elsif ($func eq "splice") { |
| 2197 | splice @{$CPAN::Config->{$o}}, @args; |
| 2198 | } else { |
| 2199 | $CPAN::Config->{$o} = [@args]; |
| 2200 | } |
| 2201 | } else { |
| 2202 | $CPAN::Config->{$o} = $args[0]; |
| 2203 | print " $o "; |
| 2204 | print defined $CPAN::Config->{$o} ? $CPAN::Config->{$o} : "UNDEFINED"; |
| 2205 | } |
| 2206 | } |
| 2207 | } |
| 2208 | |
| 2209 | #-> sub CPAN::Config::commit ; |
| 2210 | sub commit { |
| 2211 | my($self, $configpm) = @_; |
| 2212 | my $mode; |
| 2213 | # mkpath!? |
| 2214 | |
| 2215 | my($fh) = IO::File->new; |
| 2216 | $configpm ||= cfile(); |
| 2217 | if (-f $configpm) { |
| 2218 | $mode = (stat $configpm)[2]; |
| 2219 | if ($mode && ! -w _) { |
| 2220 | print "$configpm is not writable\n" and return; |
| 2221 | } |
| 2222 | #chmod 0644, $configpm; #? |
| 2223 | } |
| 2224 | |
| 2225 | my $msg = <<EOF unless $configpm =~ /MyConfig/; |
| 2226 | |
| 2227 | # This is CPAN.pm's systemwide configuration file. This file provides |
| 2228 | # defaults for users, and the values can be changed in a per-user configuration |
| 2229 | # file. The user-config file is being looked for as ~/.cpan/CPAN/MyConfig.pm. |
| 2230 | |
| 2231 | EOF |
| 2232 | $msg ||= "\n"; |
| 2233 | open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!"; |
| 2234 | print $fh qq[$msg\$CPAN::Config = \{\n]; |
| 2235 | foreach (sort keys %$CPAN::Config) { |
| 2236 | print $fh " '$_' => ", ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}), ",\n"; |
| 2237 | } |
| 2238 | |
| 2239 | print $fh "};\n1;\n__END__\n"; |
| 2240 | close $fh; |
| 2241 | |
| 2242 | #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); |
| 2243 | #chmod $mode, $configpm; |
| 2244 | $self->defaults; |
| 2245 | print "commit: wrote $configpm\n"; |
| 2246 | 1; |
| 2247 | } |
| 2248 | |
| 2249 | *default = \&defaults; |
| 2250 | #-> sub CPAN::Config::defaults ; |
| 2251 | sub defaults { |
| 2252 | my($self) = @_; |
| 2253 | $self->unload; |
| 2254 | $self->load; |
| 2255 | 1; |
| 2256 | } |
| 2257 | |
| 2258 | my $dot_cpan; |
| 2259 | #-> sub CPAN::Config::load ; |
| 2260 | sub load { |
| 2261 | my($self) = @_; |
| 2262 | eval {require CPAN::Config;}; # We eval, because of some MakeMaker problems |
| 2263 | unshift @INC, $CPAN::META->catdir($ENV{HOME},".cpan") unless $dot_cpan++; |
| 2264 | eval {require CPAN::MyConfig;}; # where you can override system wide settings |
| 2265 | unless ( $self->load_succeeded ) { |
| 2266 | require CPAN::FirstTime; |
| 2267 | my($configpm,$fh); |
| 2268 | if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) { |
| 2269 | $configpm = $INC{"CPAN/Config.pm"}; |
| 2270 | } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) { |
| 2271 | $configpm = $INC{"CPAN/MyConfig.pm"}; |
| 2272 | } else { |
| 2273 | my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"}); |
| 2274 | my($configpmdir) = MY->catdir($path_to_cpan,"CPAN"); |
| 2275 | my($configpmtest) = MY->catfile($configpmdir,"Config.pm"); |
| 2276 | if (-d $configpmdir || File::Path::mkpath($configpmdir)) { |
| 2277 | #_#_# following code dumped core on me with 5.003_11, a.k. |
| 2278 | #_#_# $fh = IO::File->new; |
| 2279 | #_#_# if ($fh->open(">$configpmtest")) { |
| 2280 | #_#_# $fh->print("1;\n"); |
| 2281 | #_#_# $configpm = $configpmtest; |
| 2282 | #_#_# } |
| 2283 | if (-w $configpmtest or -w $configpmdir) { |
| 2284 | $configpm = $configpmtest; |
| 2285 | } |
| 2286 | } |
| 2287 | unless ($configpm) { |
| 2288 | $configpmdir = MY->catdir($ENV{HOME},".cpan","CPAN"); |
| 2289 | File::Path::mkpath($configpmdir); |
| 2290 | $configpmtest = MY->catfile($configpmdir,"MyConfig.pm"); |
| 2291 | if (-w $configpmtest or -w $configpmdir) { |
| 2292 | $configpm = $configpmtest; |
| 2293 | } else { |
| 2294 | warn "WARNING: CPAN.pm is unable to create a configuration file.\n"; |
| 2295 | } |
| 2296 | } |
| 2297 | } |
| 2298 | warn "Calling CPAN::FirstTime::init($configpm)"; |
| 2299 | CPAN::FirstTime::init($configpm); |
| 2300 | } |
| 2301 | } |
| 2302 | |
| 2303 | #-> sub CPAN::Config::load_succeeded ; |
| 2304 | sub load_succeeded { |
| 2305 | my($miss) = 0; |
| 2306 | for (qw( |
| 2307 | cpan_home keep_source_where build_dir build_cache index_expire |
| 2308 | gzip tar unzip make pager makepl_arg make_arg make_install_arg |
| 2309 | urllist inhibit_startup_message |
| 2310 | )) { |
| 2311 | $miss++ unless defined $CPAN::Config->{$_}; # we want them all |
| 2312 | } |
| 2313 | return !$miss; |
| 2314 | } |
| 2315 | |
| 2316 | #-> sub CPAN::Config::unload ; |
| 2317 | sub unload { |
| 2318 | delete $INC{'CPAN/MyConfig.pm'}; |
| 2319 | delete $INC{'CPAN/Config.pm'}; |
| 2320 | } |
| 2321 | |
| 2322 | #-> sub CPAN::Config::cfile ; |
| 2323 | sub cfile { |
| 2324 | $INC{'CPAN/MyConfig.pm'} || $INC{'CPAN/Config.pm'}; |
| 2325 | } |
| 2326 | |
| 2327 | *h = \&help; |
| 2328 | #-> sub CPAN::Config::help ; |
| 2329 | sub help { |
| 2330 | print <<EOF; |
| 2331 | Known options: |
| 2332 | defaults reload default config values from disk |
| 2333 | commit commit session changes to disk |
| 2334 | |
| 2335 | You may edit key values in the follow fashion: |
| 2336 | |
| 2337 | o conf build_cache 15 |
| 2338 | |
| 2339 | o conf build_dir "/foo/bar" |
| 2340 | |
| 2341 | o conf urllist shift |
| 2342 | |
| 2343 | o conf urllist unshift ftp://ftp.foo.bar/ |
| 2344 | |
| 2345 | EOF |
| 2346 | undef; #don't reprint CPAN::Config |
| 2347 | } |
| 2348 | |
| 2349 | #-> sub CPAN::Config::complete ; |
| 2350 | sub complete { |
| 2351 | my($word,$line,$pos) = @_; |
| 2352 | $word ||= ""; |
| 2353 | my(@words) = split " ", $line; |
| 2354 | my(@o_conf) = (sort keys %CPAN::Config::can, sort keys %$CPAN::Config); |
| 2355 | return (@o_conf) unless @words>2; |
| 2356 | if($words[2] =~ /->(.*)/) { |
| 2357 | my $meth = $1; |
| 2358 | my(@methods) = qw(shift unshift push pop splice); |
| 2359 | return @methods unless $meth; |
| 2360 | return sort grep /^\Q$meth\E/, @methods; |
| 2361 | } |
| 2362 | return sort grep /^\Q$word\E/, @o_conf; |
| 2363 | } |
| 2364 | |
| 2365 | 1; |
| 2366 | |
| 2367 | =head1 NAME |
| 2368 | |
| 2369 | CPAN - query, download and build perl modules from CPAN sites |
| 2370 | |
| 2371 | =head1 SYNOPSIS |
| 2372 | |
| 2373 | Interactive mode: |
| 2374 | |
| 2375 | perl -MCPAN -e shell; |
| 2376 | |
| 2377 | Batch mode: |
| 2378 | |
| 2379 | use CPAN; |
| 2380 | |
| 2381 | autobundle, clean, install, make, recompile, test |
| 2382 | |
| 2383 | =head1 DESCRIPTION |
| 2384 | |
| 2385 | The CPAN module is designed to automate the make and install of perl |
| 2386 | modules and extensions. It includes some searching capabilities and |
| 2387 | knows how to use Net::FTP or LWP (or lynx or an external ftp client) |
| 2388 | to fetch the raw data from the net. |
| 2389 | |
| 2390 | Modules are fetched from one or more of the mirrored CPAN |
| 2391 | (Comprehensive Perl Archive Network) sites and unpacked in a dedicated |
| 2392 | directory. |
| 2393 | |
| 2394 | The CPAN module also supports the concept of named and versioned |
| 2395 | 'bundles' of modules. Bundles simplify the handling of sets of |
| 2396 | related modules. See BUNDLES below. |
| 2397 | |
| 2398 | The package contains a session manager and a cache manager. There is |
| 2399 | no status retained between sessions. The session manager keeps track |
| 2400 | of what has been fetched, built and installed in the current |
| 2401 | session. The cache manager keeps track of the disk space occupied by |
| 2402 | the make processes and deletes excess space according to a simple FIFO |
| 2403 | mechanism. |
| 2404 | |
| 2405 | All methods provided are accessible in a programmer style and in an |
| 2406 | interactive shell style. |
| 2407 | |
| 2408 | =head2 Interactive Mode |
| 2409 | |
| 2410 | The interactive mode is entered by running |
| 2411 | |
| 2412 | perl -MCPAN -e shell |
| 2413 | |
| 2414 | which puts you into a readline interface. You will have most fun if |
| 2415 | you install Term::ReadKey and Term::ReadLine to enjoy both history and |
| 2416 | completion. |
| 2417 | |
| 2418 | Once you are on the command line, type 'h' and the rest should be |
| 2419 | self-explanatory. |
| 2420 | |
| 2421 | The most common uses of the interactive modes are |
| 2422 | |
| 2423 | =over 2 |
| 2424 | |
| 2425 | =item Searching for authors, bundles, distribution files and modules |
| 2426 | |
| 2427 | There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m> |
| 2428 | for each of the four categories and another, C<i> for any of the |
| 2429 | mentioned four. Each of the four entities is implemented as a class |
| 2430 | with slightly differing methods for displaying an object. |
| 2431 | |
| 2432 | Arguments you pass to these commands are either strings matching exact |
| 2433 | the identification string of an object or regular expressions that are |
| 2434 | then matched case-insensitively against various attributes of the |
| 2435 | objects. The parser recognizes a regualar expression only if you |
| 2436 | enclose it between two slashes. |
| 2437 | |
| 2438 | The principle is that the number of found objects influences how an |
| 2439 | item is displayed. If the search finds one item, we display the result |
| 2440 | of object-E<gt>as_string, but if we find more than one, we display |
| 2441 | each as object-E<gt>as_glimpse. E.g. |
| 2442 | |
| 2443 | cpan> a ANDK |
| 2444 | Author id = ANDK |
| 2445 | EMAIL a.koenig@franz.ww.TU-Berlin.DE |
| 2446 | FULLNAME Andreas König |
| 2447 | |
| 2448 | |
| 2449 | cpan> a /andk/ |
| 2450 | Author id = ANDK |
| 2451 | EMAIL a.koenig@franz.ww.TU-Berlin.DE |
| 2452 | FULLNAME Andreas König |
| 2453 | |
| 2454 | |
| 2455 | cpan> a /and.*rt/ |
| 2456 | Author ANDYD (Andy Dougherty) |
| 2457 | Author MERLYN (Randal L. Schwartz) |
| 2458 | |
| 2459 | =item make, test, install, clean modules or distributions |
| 2460 | |
| 2461 | The four commands do indeed exist just as written above. Each of them |
| 2462 | takes as many arguments as provided and investigates for each what it |
| 2463 | might be. Is it a distribution file (recognized by embedded slashes), |
| 2464 | this file is being processed. Is it a module, CPAN determines the |
| 2465 | distribution file where this module is included and processes that. |
| 2466 | |
| 2467 | Any C<make> and C<test> are run unconditionally. A |
| 2468 | |
| 2469 | C<install E<lt>distribution_fileE<gt>> |
| 2470 | |
| 2471 | also is run unconditionally. But for |
| 2472 | |
| 2473 | C<install E<lt>moduleE<gt>> |
| 2474 | |
| 2475 | CPAN checks if an install is actually needed for it and prints |
| 2476 | I<Foo up to date> in case the module doesnE<39>t need to be updated. |
| 2477 | |
| 2478 | CPAN also keeps track of what it has done within the current session |
| 2479 | and doesnE<39>t try to build a package a second time regardless if it |
| 2480 | succeeded or not. The C<force > command takes as first argument the |
| 2481 | method to invoke (currently: make, test, or install) and executes the |
| 2482 | command from scratch. |
| 2483 | |
| 2484 | Example: |
| 2485 | |
| 2486 | cpan> install OpenGL |
| 2487 | OpenGL is up to date. |
| 2488 | cpan> force install OpenGL |
| 2489 | Running make |
| 2490 | OpenGL-0.4/ |
| 2491 | OpenGL-0.4/COPYRIGHT |
| 2492 | [...] |
| 2493 | |
| 2494 | =back |
| 2495 | |
| 2496 | =head2 CPAN::Shell |
| 2497 | |
| 2498 | The commands that are available in the shell interface are methods in |
| 2499 | the package CPAN::Shell. If you enter the shell command, all your |
| 2500 | input is split by the Text::ParseWords::shellwords() routine which |
| 2501 | acts like most shells do. The first word is being interpreted as the |
| 2502 | method to be called and the rest of the words are treated as arguments |
| 2503 | to this method. |
| 2504 | |
| 2505 | =head2 ProgrammerE<39>s interface |
| 2506 | |
| 2507 | If you do not enter the shell, the available shell commands are both |
| 2508 | available as methods (C<CPAN::Shell-E<gt>install(...)>) and as |
| 2509 | functions in the calling package (C<install(...)>). The |
| 2510 | programmerE<39>s interface has beta status. Do not heavily rely on it, |
| 2511 | changes may still be necessary. |
| 2512 | |
| 2513 | =head2 Cache Manager |
| 2514 | |
| 2515 | Currently the cache manager only keeps track of the build directory |
| 2516 | ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that |
| 2517 | deletes complete directories below C<build_dir> as soon as the size of |
| 2518 | all directories there gets bigger than $CPAN::Config->{build_cache} |
| 2519 | (in MB). The contents of this cache may be used for later |
| 2520 | re-installations that you intend to do manually, but will never be |
| 2521 | trusted by CPAN itself. This is due to the fact that the user might |
| 2522 | use these directories for building modules on different architectures. |
| 2523 | |
| 2524 | There is another directory ($CPAN::Config->{keep_source_where}) where |
| 2525 | the original distribution files are kept. This directory is not |
| 2526 | covered by the cache manager and must be controlled by the user. If |
| 2527 | you choose to have the same directory as build_dir and as |
| 2528 | keep_source_where directory, then your sources will be deleted with |
| 2529 | the same fifo mechanism. |
| 2530 | |
| 2531 | =head2 Bundles |
| 2532 | |
| 2533 | A bundle is just a perl module in the namespace Bundle:: that does not |
| 2534 | define any functions or methods. It usually only contains documentation. |
| 2535 | |
| 2536 | It starts like a perl module with a package declaration and a $VERSION |
| 2537 | variable. After that the pod section looks like any other pod with the |
| 2538 | only difference, that I<one special pod section> exists starting with |
| 2539 | (verbatim): |
| 2540 | |
| 2541 | =head1 CONTENTS |
| 2542 | |
| 2543 | In this pod section each line obeys the format |
| 2544 | |
| 2545 | Module_Name [Version_String] [- optional text] |
| 2546 | |
| 2547 | The only required part is the first field, the name of a module |
| 2548 | (eg. Foo::Bar, ie. I<not> the name of the distribution file). The rest |
| 2549 | of the line is optional. The comment part is delimited by a dash just |
| 2550 | as in the man page header. |
| 2551 | |
| 2552 | The distribution of a bundle should follow the same convention as |
| 2553 | other distributions. |
| 2554 | |
| 2555 | Bundles are treated specially in the CPAN package. If you say 'install |
| 2556 | Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all |
| 2557 | the modules in the CONTENTS section of the pod. You can install your |
| 2558 | own Bundles locally by placing a conformant Bundle file somewhere into |
| 2559 | your @INC path. The autobundle() command which is available in the |
| 2560 | shell interface does that for you by including all currently installed |
| 2561 | modules in a snapshot bundle file. |
| 2562 | |
| 2563 | There is a meaningless Bundle::Demo available on CPAN. Try to install |
| 2564 | it, it usually does no harm, just demonstrates what the Bundle |
| 2565 | interface looks like. |
| 2566 | |
| 2567 | =head2 autobundle |
| 2568 | |
| 2569 | C<autobundle> writes a bundle file into the |
| 2570 | C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains |
| 2571 | a list of all modules that are both available from CPAN and currently |
| 2572 | installed within @INC. The name of the bundle file is based on the |
| 2573 | current date and a counter. |
| 2574 | |
| 2575 | =head2 recompile |
| 2576 | |
| 2577 | recompile() is a very special command in that it takes no argument and |
| 2578 | runs the make/test/install cycle with brute force over all installed |
| 2579 | dynamically loadable extensions (aka XS modules) with 'force' in |
| 2580 | effect. Primary purpose of this command is to act as a rescue in case |
| 2581 | your perl breaks binary compatibility. If one of the modules that CPAN |
| 2582 | uses is in turn depending on binary compatibility (so you cannot run |
| 2583 | CPAN commands), then you should try the CPAN::Nox module for recovery. |
| 2584 | |
| 2585 | Another popular use for recompile is to finish a network |
| 2586 | installation. Imagine, you have a common source tree for two different |
| 2587 | architectures. You decide to do a completely independent fresh |
| 2588 | installation. You start on one architecture with the help of a Bundle |
| 2589 | file produced earlier. CPAN installs the whole Bundle for you, but |
| 2590 | when you try to repeat the job on the second architecture, CPAN |
| 2591 | responds with a C<"Foo up to date"> message for all modules. So you |
| 2592 | will be glad to run recompile in the second architecture and |
| 2593 | youE<39>re done. |
| 2594 | |
| 2595 | =head1 CONFIGURATION |
| 2596 | |
| 2597 | When the CPAN module is installed a site wide configuration file is |
| 2598 | created as CPAN/Config.pm. The default values defined there can be |
| 2599 | overridden in another configuration file: CPAN/MyConfig.pm. You can |
| 2600 | store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because |
| 2601 | $HOME/.cpan is added to the search path of the CPAN module before the |
| 2602 | use() or require() statements. |
| 2603 | |
| 2604 | Currently the following keys in the hash reference $CPAN::Config are |
| 2605 | defined: |
| 2606 | |
| 2607 | build_cache size of cache for directories to build modules |
| 2608 | build_dir locally accessible directory to build modules |
| 2609 | index_expire after how many days refetch index files |
| 2610 | cpan_home local directory reserved for this package |
| 2611 | gzip location of external program gzip |
| 2612 | inactivity_timeout breaks interactive Makefile.PLs after that |
| 2613 | many seconds inactivity. Set to 0 to never break. |
| 2614 | inhibit_startup_message |
| 2615 | if true, does not print the startup message |
| 2616 | keep_source keep the source in a local directory? |
| 2617 | keep_source_where where keep the source (if we do) |
| 2618 | make location of external program make |
| 2619 | make_arg arguments that should always be passed to 'make' |
| 2620 | make_install_arg same as make_arg for 'make install' |
| 2621 | makepl_arg arguments passed to 'perl Makefile.PL' |
| 2622 | pager location of external program more (or any pager) |
| 2623 | tar location of external program tar |
| 2624 | unzip location of external program unzip |
| 2625 | urllist arrayref to nearby CPAN sites (or equivalent locations) |
| 2626 | |
| 2627 | You can set and query each of these options interactively in the cpan |
| 2628 | shell with the command set defined within the C<o conf> command: |
| 2629 | |
| 2630 | =over 2 |
| 2631 | |
| 2632 | =item o conf E<lt>scalar optionE<gt> |
| 2633 | |
| 2634 | prints the current value of the I<scalar option> |
| 2635 | |
| 2636 | =item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt> |
| 2637 | |
| 2638 | Sets the value of the I<scalar option> to I<value> |
| 2639 | |
| 2640 | =item o conf E<lt>list optionE<gt> |
| 2641 | |
| 2642 | prints the current value of the I<list option> in MakeMaker's |
| 2643 | neatvalue format. |
| 2644 | |
| 2645 | =item o conf E<lt>list optionE<gt> [shift|pop] |
| 2646 | |
| 2647 | shifts or pops the array in the I<list option> variable |
| 2648 | |
| 2649 | =item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt> |
| 2650 | |
| 2651 | works like the corresponding perl commands. |
| 2652 | |
| 2653 | =back |
| 2654 | |
| 2655 | =head1 SECURITY |
| 2656 | |
| 2657 | There's no strong security layer in CPAN.pm. CPAN.pm helps you to |
| 2658 | install foreign, unmasked, unsigned code on your machine. We compare |
| 2659 | to a checksum that comes from the net just as the distribution file |
| 2660 | itself. If somebody has managed to tamper with the distribution file, |
| 2661 | they may have as well tampered with the CHECKSUMS file. Future |
| 2662 | development will go towards strong authentification. |
| 2663 | |
| 2664 | =head1 EXPORT |
| 2665 | |
| 2666 | Most functions in package CPAN are exported per default. The reason |
| 2667 | for this is that the primary use is intended for the cpan shell or for |
| 2668 | oneliners. |
| 2669 | |
| 2670 | =head1 Debugging |
| 2671 | |
| 2672 | The debugging of this module is pretty difficult, because we have |
| 2673 | interferences of the software producing the indices on CPAN, of the |
| 2674 | mirroring process on CPAN, of packaging, of configuration, of |
| 2675 | synchronicity, and of bugs within CPAN.pm. |
| 2676 | |
| 2677 | In interactive mode you can try "o debug" which will list options for |
| 2678 | debugging the various parts of the package. The output may not be very |
| 2679 | useful for you as it's just a byproduct of my own testing, but if you |
| 2680 | have an idea which part of the package may have a bug, it's sometimes |
| 2681 | worth to give it a try and send me more specific output. You should |
| 2682 | know that "o debug" has built-in completion support. |
| 2683 | |
| 2684 | =head2 Prerequisites |
| 2685 | |
| 2686 | If you have a local mirror of CPAN and can access all files with |
| 2687 | "file:" URLs, then you only need perl5.003 to run this |
| 2688 | module. Otherwise Net::FTP is recommended. LWP may be required for |
| 2689 | non-UNIX systems or if your nearest CPAN site is associated with an |
| 2690 | URL that is not C<ftp:>. |
| 2691 | |
| 2692 | If you have neither Net::FTP nor LWP, there is a fallback mechanism |
| 2693 | implemented for an external ftp command or for an external lynx |
| 2694 | command. |
| 2695 | |
| 2696 | This module presumes that all packages on CPAN |
| 2697 | |
| 2698 | =over 2 |
| 2699 | |
| 2700 | =item * |
| 2701 | |
| 2702 | declare their $VERSION variable in an easy to parse manner. This |
| 2703 | prerequisite can hardly be relaxed because it consumes by far too much |
| 2704 | memory to load all packages into the running program just to determine |
| 2705 | the $VERSION variable . Currently all programs that are dealing with |
| 2706 | version use something like this |
| 2707 | |
| 2708 | perl -MExtUtils::MakeMaker -le \ |
| 2709 | 'print MM->parse_version($ARGV[0])' filename |
| 2710 | |
| 2711 | If you are author of a package and wonder if your $VERSION can be |
| 2712 | parsed, please try the above method. |
| 2713 | |
| 2714 | =item * |
| 2715 | |
| 2716 | come as compressed or gzipped tarfiles or as zip files and contain a |
| 2717 | Makefile.PL (well we try to handle a bit more, but without much |
| 2718 | enthusiasm). |
| 2719 | |
| 2720 | =back |
| 2721 | |
| 2722 | =head1 AUTHOR |
| 2723 | |
| 2724 | Andreas König E<lt>a.koenig@mind.deE<gt> |
| 2725 | |
| 2726 | =head1 SEE ALSO |
| 2727 | |
| 2728 | perl(1), CPAN::Nox(3) |
| 2729 | |
| 2730 | =cut |
| 2731 | |