X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCPAN.pm;h=11af0a68853a7422b6a54179bd68081616c91568;hb=09b7f37c58c6da6f4965b846b64eab7d9a205663;hp=3db4870fdc32b43bb4cf3e6fde674e493f7f5519;hpb=42d3b621acfbc6855b2412a93aa2e992b263aba0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/CPAN.pm b/lib/CPAN.pm index 3db4870..11af0a6 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1,14 +1,17 @@ package CPAN; -use vars qw{$META $Signal $Cwd $End $Suppress_readline}; +use vars qw{$Try_autoload $Revision + $META $Signal $Cwd $End + $Suppress_readline %Dontload + $Frontend + }; -$VERSION = '1.09'; +$VERSION = '1.3102'; -# $Id: CPAN.pm,v 1.94 1996/12/24 00:41:14 k Exp $ +# $Id: CPAN.pm,v 1.202 1997/09/23 18:30:36 k Exp k $ -# my $version = substr q$Revision: 1.94 $, 10; # only used during development - -BEGIN {require 5.003;} -require UNIVERSAL if $] == 5.003; +# only used during development: +$Revision = ""; +# $Revision = "[".substr(q$Revision: 1.202 $, 10)."]"; use Carp (); use Config (); @@ -20,11 +23,10 @@ use File::Basename (); use File::Copy (); use File::Find; use File::Path (); -use IO::File (); +use FileHandle (); use Safe (); use Text::ParseWords (); - -$Cwd = Cwd::cwd(); +use Text::Wrap; END { $End++; &cleanup; } @@ -45,23 +47,282 @@ END { $End++; &cleanup; } ); $CPAN::DEBUG ||= 0; +$CPAN::Signal ||= 0; +$CPAN::Frontend ||= "CPAN::Shell"; package CPAN; -use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META); +use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term); use strict qw(vars); -@CPAN::ISA = qw(CPAN::Debug Exporter MY); # the MY class from - # MakeMaker, gives us - # catfile and catdir +@CPAN::ISA = qw(CPAN::Debug Exporter MM); # MM will go away + # soonish. Already version + # 1.29 doesn't rely on + # catfile and catdir being + # available via + # inheritance. Anything else + # in danger? -$META ||= new CPAN; # In case we reeval ourselves we - # need a || +@EXPORT = qw( + autobundle bundle expand force get + install make readme recompile shell test clean + ); + +#-> sub CPAN::AUTOLOAD ; +sub AUTOLOAD { + my($l) = $AUTOLOAD; + $l =~ s/.*:://; + my(%EXPORT); + @EXPORT{@EXPORT} = ''; + if (exists $EXPORT{$l}){ + CPAN::Shell->$l(@_); + } else { + my $ok = CPAN::Shell->try_dot_al($AUTOLOAD); + if ($ok) { + goto &$AUTOLOAD; +# } else { +# $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD"); + } + $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }. + qq{Type ? for help. +}); + } +} + +#-> sub CPAN::shell ; +sub shell { + $Suppress_readline ||= ! -t STDIN; + + my $prompt = "cpan> "; + local($^W) = 1; + unless ($Suppress_readline) { + require Term::ReadLine; +# import Term::ReadLine; + $term = Term::ReadLine->new('CPAN Monitor'); + $readline::rl_completion_function = + $readline::rl_completion_function = 'CPAN::Complete::cpl'; + } + + no strict; + $META->checklock(); + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my $cwd = CPAN->$getcwd(); + my $rl_avail = $Suppress_readline ? "suppressed" : + ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : + "available (try ``install Bundle::CPAN'')"; + + $CPAN::Frontend->myprint( + qq{ +cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision) +ReadLine support $rl_avail + +}) unless $CPAN::Config->{'inhibit_startup_message'} ; + my($continuation) = ""; + while () { + if ($Suppress_readline) { + print $prompt; + last unless defined ($_ = <> ); + chomp; + } else { + last unless defined ($_ = $term->readline($prompt)); + } + $_ = "$continuation$_" if $continuation; + s/^\s+//; + next if /^$/; + $_ = 'h' if $_ eq '?'; + if (/^q(?:uit)?$/i) { + last; + } elsif (s/\\$//s) { + chomp; + $continuation = $_; + $prompt = " > "; + } elsif (/^\!/) { + s/^\!//; + my($eval) = $_; + package CPAN::Eval; + use vars qw($import_done); + CPAN->import(':DEFAULT') unless $import_done++; + CPAN->debug("eval[$eval]") if $CPAN::DEBUG; + eval($eval); + warn $@ if $@; + $continuation = ""; + $prompt = "cpan> "; + } elsif (/./) { + my(@line); + if ($] < 5.00322) { # parsewords had a bug until recently + @line = split; + } else { + eval { @line = Text::ParseWords::shellwords($_) }; + warn($@), next if $@; + } + $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; + my $command = shift @line; + eval { CPAN::Shell->$command(@line) }; + warn $@ if $@; + chdir $cwd; + $CPAN::Frontend->myprint("\n"); + $continuation = ""; + $prompt = "cpan> "; + } + } continue { + &cleanup, $CPAN::Frontend->mydie("Goodbye\n") if $Signal; + } +} + +package CPAN::CacheMgr; +use vars qw($Du); +@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN); +use File::Find; + +package CPAN::Config; +import ExtUtils::MakeMaker 'neatvalue'; +use vars qw(%can $dot_cpan); + +%can = ( + 'commit' => "Commit changes to disk", + 'defaults' => "Reload defaults from disk", + 'init' => "Interactive setting of all options", +); + +package CPAN::FTP; +use vars qw($Ua $Thesite $Themethod); +@CPAN::FTP::ISA = qw(CPAN::Debug); + +package CPAN::Complete; +@CPAN::Complete::ISA = qw(CPAN::Debug); + +package CPAN::Index; +use vars qw($last_time $date_of_03); +@CPAN::Index::ISA = qw(CPAN::Debug); +$last_time ||= 0; +$date_of_03 ||= 0; + +package CPAN::InfoObj; +@CPAN::InfoObj::ISA = qw(CPAN::Debug); + +package CPAN::Author; +@CPAN::Author::ISA = qw(CPAN::InfoObj); + +package CPAN::Distribution; +@CPAN::Distribution::ISA = qw(CPAN::InfoObj); + +package CPAN::Bundle; +@CPAN::Bundle::ISA = qw(CPAN::Module); + +package CPAN::Module; +@CPAN::Module::ISA = qw(CPAN::InfoObj); + +package CPAN::Shell; +use vars qw($AUTOLOAD $redef @ISA); +@CPAN::Shell::ISA = qw(CPAN::Debug); + +#-> sub CPAN::Shell::AUTOLOAD ; +sub AUTOLOAD { + my($autoload) = $AUTOLOAD; + my $class = shift(@_); + $autoload =~ s/.*:://; + if ($autoload =~ /^w/) { + if ($CPAN::META->has_inst('CPAN::WAIT')) { + CPAN::WAIT->$autoload(@_); + } else { + $CPAN::Frontend->mywarn(qq{ +Commands starting with "w" require CPAN::WAIT to be installed. +Please consider installing CPAN::WAIT to use the fulltext index. +For this you just need to type + install CPAN::WAIT +}); + } + } else { + my $ok = CPAN::Shell->try_dot_al($AUTOLOAD); + if ($ok) { + goto &$AUTOLOAD; +# } else { +# $CPAN::Frontend->mywarn("Could not autoload $autoload"); + } + $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }. + qq{Type ? for help. +}); + } +} + +#-> CPAN::Shell::try_dot_al +sub try_dot_al { + my($class,$autoload) = @_; + return unless $CPAN::Try_autoload; + # I don't see how to re-use that from the AutoLoader... + my($name,$ok); + # Braces used to preserve $1 et al. + { + my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/; + $pkg =~ s|::|/|g; + if (defined($name=$INC{"$pkg.pm"})) + { + $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|; + $name = undef unless (-r $name); + } + unless (defined $name) + { + $name = "auto/$autoload.al"; + $name =~ s|::|/|g; + } + } + my $save = $@; + eval {local $SIG{__DIE__};require $name}; + if ($@) { + if (substr($autoload,-9) eq '::DESTROY') { + *$autoload = sub {}; + $ok = 1; + } else { + if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ + eval {local $SIG{__DIE__};require $name}; + } + if ($@){ + $@ =~ s/ at .*\n//; + Carp::croak $@; + } else { + $ok = 1; + } + } + } else { + $ok = 1; + } + $@ = $save; +# my $lm = Carp::longmess(); +# warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug + return $ok; +} + +#### autoloader is experimental +#### to try it we have to set $Try_autoload and uncomment +#### the use statement and uncomment the __END__ below +#### You also need AutoSplit 1.01 available. MakeMaker will +#### then build CPAN with all the AutoLoad stuff. +# use AutoLoader; +# $Try_autoload = 1; + +if ($CPAN::Try_autoload) { + my $p; + for $p (qw( + CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete + CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP + CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module + )) { + *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD; + } +} -CPAN::Config->load; -@EXPORT = qw(autobundle bundle expand force install make recompile shell test clean); +package CPAN; + +$META ||= CPAN->new; # In case we reeval ourselves we + # need a || + +# Do this after you have set up the whole inheritance +CPAN::Config->load unless defined $CPAN::No_Config_is_ok; +1; +# __END__ # uncomment this and AutoSplit version 1.01 will split it #-> sub CPAN::autobundle ; sub autobundle; @@ -75,29 +336,11 @@ sub force; sub install; #-> sub CPAN::make ; sub make; -#-> sub CPAN::shell ; -sub shell; #-> sub CPAN::clean ; sub clean; #-> sub CPAN::test ; sub test; -#-> sub CPAN::AUTOLOAD ; -sub AUTOLOAD { - my($l) = $AUTOLOAD; - $l =~ s/.*:://; - my(%EXPORT); - @EXPORT{@EXPORT} = ''; - if (exists $EXPORT{$l}){ - CPAN::Shell->$l(@_); - } else { - warn "CPAN doesn't know how to autoload $AUTOLOAD :-( -Nothing Done. -"; - CPAN::Shell->h; - } -} - #-> sub CPAN::all ; sub all { my($mgr,$class) = @_; @@ -110,28 +353,35 @@ sub all { #-> sub CPAN::checklock ; sub checklock { my($self) = @_; - my $lockfile = CPAN->catfile($CPAN::Config->{cpan_home},".lock"); + my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock"); if (-f $lockfile && -M _ > 0) { - my $fh = IO::File->new($lockfile); + my $fh = FileHandle->new($lockfile); my $other = <$fh>; $fh->close; if (defined $other && $other) { chomp $other; return if $$==$other; # should never happen - print qq{There seems to be running another CPAN process ($other). Trying to contact...\n}; + $CPAN::Frontend->mywarn( + qq{ +There seems to be running another CPAN process ($other). Contacting... +}); if (kill 0, $other) { - Carp::croak qq{Other job is running.\n}. - qq{You may want to kill it and delete the lockfile, maybe. On UNIX try:\n}. - qq{ kill $other\n}. - qq{ rm $lockfile\n}; + $CPAN::Frontend->mydie(qq{Other job is running. +You may want to kill it and delete the lockfile, maybe. On UNIX try: + kill $other + rm $lockfile +}); } elsif (-w $lockfile) { - my($ans)= + my($ans) = ExtUtils::MakeMaker::prompt - (qq{Other job not responding. Shall I overwrite the lockfile? (Y/N)},"y"); - print("Ok, bye\n"), exit unless $ans =~ /^y/i; + (qq{Other job not responding. Shall I overwrite }. + qq{the lockfile? (Y/N)},"y"); + $CPAN::Frontend->myexit("Ok, bye\n") + unless $ans =~ /^y/i; } else { Carp::croak( - qq{Lockfile $lockfile not writeable by you. Cannot proceed.\n}. + qq{Lockfile $lockfile not writeable by you. }. + qq{Cannot proceed.\n}. qq{ On UNIX try:\n}. qq{ rm $lockfile\n}. qq{ and then rerun us.\n} @@ -141,11 +391,11 @@ sub checklock { } File::Path::mkpath($CPAN::Config->{cpan_home}); my $fh; - unless ($fh = IO::File->new(">$lockfile")) { + unless ($fh = FileHandle->new(">$lockfile")) { if ($! =~ /Permission/) { my $incc = $INC{'CPAN/Config.pm'}; - my $myincc = MY->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm'); - print qq{ + my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm'); + $CPAN::Frontend->myprint(qq{ Your configuration suggests that CPAN.pm should use a working directory of @@ -162,17 +412,24 @@ this variable in either or $myincc -}; +}); } - Carp::croak "Could not open >$lockfile: $!"; + $CPAN::Frontend->mydie("Could not open >$lockfile: $!"); } - print $fh $$, "\n"; + $fh->print($$, "\n"); $self->{LOCK} = $lockfile; $fh->close; - $SIG{'TERM'} = sub { &cleanup; die "Got SIGTERM, leaving"; }; - $SIG{'INT'} = sub { &cleanup, die "Got a second SIGINT" if $Signal; $Signal = 1; }; + $SIG{'TERM'} = sub { + &cleanup; + $CPAN::Frontend->mydie("Got SIGTERM, leaving"); + }; + $SIG{'INT'} = sub { + my $s = $Signal == 2 ? "a second" : "another"; + &cleanup, $CPAN::Frontend->mydie("Got $s SIGINT") if $Signal; + $Signal = 1; + }; $SIG{'__DIE__'} = \&cleanup; - print STDERR "Signal handler set.\n" unless $CPAN::Config->{'inhibit_startup_message'}; + $self->debug("Signal handler set.") if $CPAN::DEBUG; } #-> sub CPAN::DESTROY ; @@ -180,62 +437,73 @@ sub DESTROY { &cleanup; # need an eval? } +#-> sub CPAN::cwd ; +sub cwd {Cwd::cwd();} + +#-> sub CPAN::getcwd ; +sub getcwd {Cwd::getcwd();} + #-> sub CPAN::exists ; sub exists { my($mgr,$class,$id) = @_; CPAN::Index->reload; - Carp::croak "exists called without class argument" unless $class; + ### Carp::croak "exists called without class argument" unless $class; $id ||= ""; exists $META->{$class}{$id}; } -#-> sub CPAN::hasFTP ; -sub hasFTP { - my($self,$arg) = @_; - if (defined $arg) { - return $self->{'hasFTP'} = $arg; - } elsif (not defined $self->{'hasFTP'}) { - eval {require Net::FTP;}; - $self->{'hasFTP'} = $@ ? 0 : 1; - } - return $self->{'hasFTP'}; -} +#-> sub CPAN::has_inst +sub has_inst { + my($self,$mod,$message) = @_; + Carp::croak("CPAN->has_inst() called without an argument") + unless defined $mod; + if (defined $message && $message eq "no") { + $Dontload{$mod}||=1; + return 0; + } elsif (exists $Dontload{$mod}) { + return 0; + } + my $file = $mod; + my $obj; + $file =~ s|::|/|g; + $file =~ s|/|\\|g if $^O eq 'MSWin32'; + $file .= ".pm"; + if ($INC{$file}) { +# warn "$file in %INC"; #debug + return 1; + } elsif (eval { require $file }) { + # eval is good: if we haven't yet read the database it's + # perfect and if we have installed the module in the meantime, + # it tries again. The second require is only a NOOP returning + # 1 if we had success, otherwise it's retrying + $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n"); + if ($mod eq "CPAN::WAIT") { + push @CPAN::Shell::ISA, CPAN::WAIT; + } + return 1; + } elsif ($mod eq "Net::FTP") { + warn qq{ + Please, install Net::FTP as soon as possible. CPAN.pm installs it for you + if you just type + install Bundle::libnet -#-> sub CPAN::hasLWP ; -sub hasLWP { - my($self,$arg) = @_; - if (defined $arg) { - return $self->{'hasLWP'} = $arg; - } elsif (not defined $self->{'hasLWP'}) { - eval {require LWP;}; - $LWP::VERSION ||= 0; - $self->{'hasLWP'} = $LWP::VERSION >= 4.98; - } - return $self->{'hasLWP'}; -} +}; + sleep 2; + } elsif ($mod eq "MD5"){ + $CPAN::Frontend->myprint(qq{ + CPAN: MD5 security checks disabled because MD5 not installed. + Please consider installing the MD5 module. -#-> sub CPAN::hasMD5 ; -sub hasMD5 { - my($self,$arg) = @_; - if (defined $arg) { - $self->{'hasMD5'} = $arg; - } elsif (not defined $self->{'hasMD5'}) { - eval {require MD5;}; - if ($@) { - print "MD5 security checks disabled because MD5 not installed. Please consider installing MD5\n"; - $self->{'hasMD5'} = 0; - } else { - $self->{'hasMD5'}++; - } +}); + sleep 2; } - return $self->{'hasMD5'}; + return 0; } #-> sub CPAN::instance ; sub instance { my($mgr,$class,$id) = @_; CPAN::Index->reload; - Carp::croak "instance called without class argument" unless $class; $id ||= ""; $META->{$class}{$id} ||= $class->new(ID => $id ); } @@ -256,98 +524,438 @@ sub cleanup { return unless defined $META->{'LOCK'}; return unless -f $META->{'LOCK'}; unlink $META->{'LOCK'}; - print STDERR "Lockfile removed.\n"; -# my $mess = Carp::longmess(@_); -# die @_; + $CPAN::Frontend->mywarn("Lockfile removed.\n"); } -#-> sub CPAN::shell ; -sub shell { - $Suppress_readline ||= ! -t STDIN; +package CPAN::CacheMgr; - my $prompt = "cpan> "; - local($^W) = 1; - my $term; - unless ($Suppress_readline) { - require Term::ReadLine; - import Term::ReadLine; - $term = new Term::ReadLine 'CPAN Monitor'; - $readline::rl_completion_function = - $readline::rl_completion_function = 'CPAN::Complete::complete'; +#-> sub CPAN::CacheMgr::as_string ; +sub as_string { + eval { require Data::Dumper }; + if ($@) { + return shift->SUPER::as_string; + } else { + return Data::Dumper::Dumper(shift); } +} - no strict; - $META->checklock(); - my $cwd = Cwd::cwd(); - # How should we determine if we have more than stub ReadLine enabled? - my $rl_avail = $Suppress_readline ? "suppressed" : - defined &Term::ReadLine::Perl::readline ? "enabled" : - "available (get Term::ReadKey and Term::ReadLine)"; +#-> sub CPAN::CacheMgr::cachesize ; +sub cachesize { + shift->{DU}; +} + +# sub check { +# my($self,@dirs) = @_; +# return unless -d $self->{ID}; +# my $dir; +# @dirs = $self->dirs unless @dirs; +# for $dir (@dirs) { +# $self->disk_usage($dir); +# } +# } - print qq{ -cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION) -Readline support $rl_avail +#-> sub CPAN::CacheMgr::clean_cache ; +#=# sub clean_cache { +#=# my $self = shift; +#=# my $dir; +#=# while ($self->{DU} > $self->{'MAX'} and $dir = shift @{$self->{FIFO}}) { +#=# $self->force_clean_cache($dir); +#=# } +#=# $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG; +#=# } -} unless $CPAN::Config->{'inhibit_startup_message'} ; - while () { - if ($Suppress_readline) { - print $prompt; - last unless defined (chomp($_ = <>)); +#-> sub CPAN::CacheMgr::dir ; +sub dir { + shift->{ID}; +} + +#-> sub CPAN::CacheMgr::entries ; +sub entries { + my($self,$dir) = @_; + return unless defined $dir; + $self->debug("reading dir[$dir]") if $CPAN::DEBUG; + $dir ||= $self->{ID}; + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my($cwd) = CPAN->$getcwd(); + chdir $dir or Carp::croak("Can't chdir to $dir: $!"); + my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!"); + my(@entries); + for ($dh->read) { + next if $_ eq "." || $_ eq ".."; + if (-f $_) { + push @entries, MM->catfile($dir,$_); + } elsif (-d _) { + push @entries, MM->catdir($dir,$_); } else { - last unless defined ($_ = $term->readline($prompt)); - } - s/^\s//; - next if /^$/; - $_ = 'h' if $_ eq '?'; - if (/^\!/) { - s/^\!//; - my($eval) = $_; - package CPAN::Eval; - use vars qw($import_done); - CPAN->import(':DEFAULT') unless $import_done++; - CPAN->debug("eval[$eval]") if $CPAN::DEBUG; - eval($eval); - warn $@ if $@; - } elsif (/^q(?:uit)?$/i) { - last; - } elsif (/./) { - my(@line); - eval { @line = Text::ParseWords::shellwords($_) }; - warn($@), next if $@; - $CPAN::META->debug("line[".join(":",@line)."]") if $CPAN::DEBUG; - my $command = shift @line; - eval { CPAN::Shell->$command(@line) }; - warn $@ if $@; + $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n"); } - } continue { - &cleanup, die if $Signal; - chdir $cwd; - print "\n"; } + chdir $cwd or Carp::croak("Can't chdir to $cwd: $!"); + sort { -M $b <=> -M $a} @entries; } -package CPAN::Shell; -use vars qw($AUTOLOAD); -@CPAN::Shell::ISA = qw(CPAN::Debug); - -# private function ro re-eval this module (handy during development) -#-> sub CPAN::Shell::AUTOLOAD ; -sub AUTOLOAD { - warn "CPAN::Shell doesn't know how to autoload $AUTOLOAD :-( -Nothing Done. -"; - CPAN::Shell->h; -} - -#-> sub CPAN::Shell::h ; -sub h { - my($class,$about) = @_; - if (defined $about) { - print "Detailed help not yet implemented\n"; - } else { - print q{ -command arguments description -a string authors +#-> sub CPAN::CacheMgr::disk_usage ; +sub disk_usage { + my($self,$dir) = @_; +# if (! defined $dir or $dir eq "") { +# $self->debug("Cannot determine disk usage for some reason") if $CPAN::DEBUG; +# return; +# } + return if $self->{SIZE}{$dir}; + local($Du) = 0; + find( + sub { + return if -l $_; + $Du += -s _; + }, + $dir + ); + $self->{SIZE}{$dir} = $Du/1024/1024; + push @{$self->{FIFO}}, $dir; + $self->debug("measured $dir is $Du") if $CPAN::DEBUG; + $self->{DU} += $Du/1024/1024; + if ($self->{DU} > $self->{'MAX'} ) { + my($toremove) = shift @{$self->{FIFO}}; + $CPAN::Frontend->myprint(sprintf( + "...Hold on a sec... ". + "cleaning from cache ". + "(%.1f>%.1f MB): $toremove\n", + $self->{DU}, $self->{'MAX'}) + ); + $self->force_clean_cache($toremove); + } + $self->{DU}; +} + +#-> sub CPAN::CacheMgr::force_clean_cache ; +sub force_clean_cache { + my($self,$dir) = @_; + $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") + if $CPAN::DEBUG; + File::Path::rmtree($dir); + $self->{DU} -= $self->{SIZE}{$dir}; + delete $self->{SIZE}{$dir}; +} + +#-> sub CPAN::CacheMgr::new ; +sub new { + my $class = shift; + my $time = time; + my($debug,$t2); + $debug = ""; + my $self = { + ID => $CPAN::Config->{'build_dir'}, + MAX => $CPAN::Config->{'build_cache'}, + DU => 0 + }; + File::Path::mkpath($self->{ID}); + my $dh = DirHandle->new($self->{ID}); + bless $self, $class; + $self->debug("dir [$self->{ID}]") if $CPAN::DEBUG; + my $e; + for $e ($self->entries) { + next if $e eq ".." || $e eq "."; + $self->disk_usage($e); + } + $t2 = time; + $debug .= "timing of CacheMgr->new: ".($t2 - $time); + $time = $t2; + CPAN->debug($debug) if $CPAN::DEBUG; + $self; +} + +package CPAN::Debug; + +#-> sub CPAN::Debug::debug ; +sub debug { + my($self,$arg) = @_; + my($caller,$func,$line,@rest) = caller(1); # caller(0) eg + # Complete, caller(1) + # eg readline + ($caller) = caller(0); + $caller =~ s/.*:://; + $arg = "" unless defined $arg; + my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest; + if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){ + if ($arg and ref $arg) { + eval { require Data::Dumper }; + if ($@) { + $CPAN::Frontend->myprint($arg->as_string); + } else { + $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg)); + } + } else { + $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n"); + } + } +} + +package CPAN::Config; + +#-> sub CPAN::Config::edit ; +sub edit { + my($class,@args) = @_; + return unless @args; + CPAN->debug("class[$class]args[".join(" | ",@args)."]"); + my($o,$str,$func,$args,$key_exists); + $o = shift @args; + if($can{$o}) { + $class->$o(@args); + return 1; + } else { + if (ref($CPAN::Config->{$o}) eq ARRAY) { + $func = shift @args; + $func ||= ""; + # Let's avoid eval, it's easier to comprehend without. + if ($func eq "push") { + push @{$CPAN::Config->{$o}}, @args; + } elsif ($func eq "pop") { + pop @{$CPAN::Config->{$o}}; + } elsif ($func eq "shift") { + shift @{$CPAN::Config->{$o}}; + } elsif ($func eq "unshift") { + unshift @{$CPAN::Config->{$o}}, @args; + } elsif ($func eq "splice") { + splice @{$CPAN::Config->{$o}}, @args; + } elsif (@args) { + $CPAN::Config->{$o} = [@args]; + } else { + $CPAN::Frontend->myprint( + join "", + " $o ", + ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}), + "\n" + ); + } + } else { + $CPAN::Config->{$o} = $args[0] if defined $args[0]; + $CPAN::Frontend->myprint(" $o " . + (defined $CPAN::Config->{$o} ? + $CPAN::Config->{$o} : "UNDEFINED")); + } + } +} + +#-> sub CPAN::Config::commit ; +sub commit { + my($self,$configpm) = @_; + unless (defined $configpm){ + $configpm ||= $INC{"CPAN/MyConfig.pm"}; + $configpm ||= $INC{"CPAN/Config.pm"}; + $configpm || Carp::confess(qq{ +CPAN::Config::commit called without an argument. +Please specify a filename where to save the configuration or try +"o conf init" to have an interactive course through configing. +}); + } + my($mode); + if (-f $configpm) { + $mode = (stat $configpm)[2]; + if ($mode && ! -w _) { + Carp::confess("$configpm is not writable"); + } + } + + my $msg = <new; + open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!"; + $fh->print(qq[$msg\$CPAN::Config = \{\n]); + foreach (sort keys %$CPAN::Config) { + $fh->print( + " '$_' => ", + ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}), + ",\n" + ); + } + + $fh->print("};\n1;\n__END__\n"); + close $fh; + + #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); + #chmod $mode, $configpm; +###why was that so? $self->defaults; + $CPAN::Frontend->myprint("commit: wrote $configpm\n"); + 1; +} + +*default = \&defaults; +#-> sub CPAN::Config::defaults ; +sub defaults { + my($self) = @_; + $self->unload; + $self->load; + 1; +} + +sub init { + my($self) = @_; + undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to + # have the least + # important + # variable + # undefined + $self->load; + 1; +} + +#-> sub CPAN::Config::load ; +sub load { + my($self) = shift; + my(@miss); + eval {require CPAN::Config;}; # We eval because of some + # MakeMaker problems + unshift @INC, MM->catdir($ENV{HOME},".cpan") unless $dot_cpan++; + eval {require CPAN::MyConfig;}; # where you can override + # system wide settings + return unless @miss = $self->not_loaded; + # XXX better check for arrayrefs too + require CPAN::FirstTime; + my($configpm,$fh,$redo,$theycalled); + $redo ||= ""; + $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message'; + if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) { + $configpm = $INC{"CPAN/Config.pm"}; + $redo++; + } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) { + $configpm = $INC{"CPAN/MyConfig.pm"}; + $redo++; + } else { + my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"}); + my($configpmdir) = MM->catdir($path_to_cpan,"CPAN"); + my($configpmtest) = MM->catfile($configpmdir,"Config.pm"); + if (-d $configpmdir or File::Path::mkpath($configpmdir)) { + if (-w $configpmtest) { + $configpm = $configpmtest; + } elsif (-w $configpmdir) { + #_#_# following code dumped core on me with 5.003_11, a.k. + unlink "$configpmtest.bak" if -f "$configpmtest.bak"; + rename $configpmtest, "$configpmtest.bak" if -f $configpmtest; + my $fh = FileHandle->new; + if ($fh->open(">$configpmtest")) { + $fh->print("1;\n"); + $configpm = $configpmtest; + } else { + # Should never happen + Carp::confess("Cannot open >$configpmtest"); + } + } + } + unless ($configpm) { + $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN"); + File::Path::mkpath($configpmdir); + $configpmtest = MM->catfile($configpmdir,"MyConfig.pm"); + if (-w $configpmtest) { + $configpm = $configpmtest; + } elsif (-w $configpmdir) { + #_#_# following code dumped core on me with 5.003_11, a.k. + my $fh = FileHandle->new; + if ($fh->open(">$configpmtest")) { + $fh->print("1;\n"); + $configpm = $configpmtest; + } else { + # Should never happen + Carp::confess("Cannot open >$configpmtest"); + } + } else { + Carp::confess(qq{WARNING: CPAN.pm is unable to }. + qq{create a configuration file.}); + } + } + } + local($") = ", "; + $CPAN::Frontend->myprint(qq{ +We have to reconfigure CPAN.pm due to following uninitialized parameters: + +@miss +}) if $redo && ! $theycalled; + $CPAN::Frontend->myprint(qq{ +$configpm initialized. +}); + sleep 2; + CPAN::FirstTime::init($configpm); +} + +#-> sub CPAN::Config::not_loaded ; +sub not_loaded { + my(@miss); + for (qw( + cpan_home keep_source_where build_dir build_cache index_expire + gzip tar unzip make pager makepl_arg make_arg make_install_arg + urllist inhibit_startup_message ftp_proxy http_proxy no_proxy + )) { + push @miss, $_ unless defined $CPAN::Config->{$_}; + } + return @miss; +} + +#-> sub CPAN::Config::unload ; +sub unload { + delete $INC{'CPAN/MyConfig.pm'}; + delete $INC{'CPAN/Config.pm'}; +} + +*h = \&help; +#-> sub CPAN::Config::help ; +sub help { + $CPAN::Frontend->myprint(qq{ +Known options: + defaults reload default config values from disk + commit commit session changes to disk + init go through a dialog to set all parameters + +You may edit key values in the follow fashion: + + o conf build_cache 15 + + o conf build_dir "/foo/bar" + + o conf urllist shift + + o conf urllist unshift ftp://ftp.foo.bar/ + +}); + undef; #don't reprint CPAN::Config +} + +#-> sub CPAN::Config::cpl ; +sub cpl { + my($word,$line,$pos) = @_; + $word ||= ""; + CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; + my(@words) = split " ", substr($line,0,$pos+1); + if ( + $words[2] =~ /list$/ && @words == 3 + || + $words[2] =~ /list$/ && @words == 4 && length($word) + ) { + return grep /^\Q$word\E/, qw(splice shift unshift pop push); + } elsif (@words >= 4) { + return (); + } + my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config); + return grep /^\Q$word\E/, @o_conf; +} + +package CPAN::Shell; + +#-> sub CPAN::Shell::h ; +sub h { + my($class,$about) = @_; + if (defined $about) { + $CPAN::Frontend->myprint("Detailed help not yet implemented\n"); + } else { + $CPAN::Frontend->myprint(q{ +command arguments description +a string authors b or display bundles d /regex/ info distributions m or about modules @@ -355,45 +963,47 @@ i none anything of above r as reinstall recommendations u above uninstalled distributions -See manpage for autobundle, recompile, force, etc. +See manpage for autobundle, recompile, force, look, etc. -make modules, make -test dists, bundles, make test (implies make) -install "r" or "u" make install (implies test) -clean make clean +make make +test modules, make test (implies make) +install dists, bundles, make install (implies test) +clean "r" or "u" make clean +readme display the README file reload index|cpan load most recent indices/CPAN.pm h or ? display this menu o various set and query options ! perl-code eval a perl command q quit the shell subroutine -}; +}); } } #-> sub CPAN::Shell::a ; -sub a { print shift->format_result('Author',@_);} +sub a { $CPAN::Frontend->myprint(shift->format_result('Author',@_));} #-> sub CPAN::Shell::b ; sub b { my($self,@which) = @_; - my($incdir,$bdir,$dh); + CPAN->debug("which[@which]") if $CPAN::DEBUG; + my($incdir,$bdir,$dh); foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { - $bdir = $CPAN::META->catdir($incdir,"Bundle"); + $bdir = MM->catdir($incdir,"Bundle"); if ($dh = DirHandle->new($bdir)) { # may fail my($entry); for $entry ($dh->read) { - next if -d $CPAN::META->catdir($bdir,$entry); + next if -d MM->catdir($bdir,$entry); next unless $entry =~ s/\.pm$//; $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry"); } } } - print $self->format_result('Bundle',@which); + $CPAN::Frontend->myprint($self->format_result('Bundle',@which)); } #-> sub CPAN::Shell::d ; -sub d { print shift->format_result('Distribution',@_);} +sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));} #-> sub CPAN::Shell::m ; -sub m { print shift->format_result('Module',@_);} +sub m { $CPAN::Frontend->myprint(shift->format_result('Module',@_));} #-> sub CPAN::Shell::i ; sub i { @@ -406,9 +1016,11 @@ sub i { for $type (@type) { push @result, $self->expand($type,@args); } - my $result = @result==1 ? $result[0]->as_string : join "", map {$_->as_glimpse} @result; + my $result = @result == 1 ? + $result[0]->as_string : + join "", map {$_->as_glimpse} @result; $result ||= "No objects found of any type for argument @args\n"; - print $result; + $CPAN::Frontend->myprint($result); } #-> sub CPAN::Shell::o ; @@ -420,24 +1032,32 @@ sub o { shift @o_what if @o_what && $o_what[0] eq 'help'; if (!@o_what) { my($k,$v); - print "CPAN::Config options:\n"; + $CPAN::Frontend->myprint("CPAN::Config options:\n"); for $k (sort keys %CPAN::Config::can) { $v = $CPAN::Config::can{$k}; - printf " %-18s %s\n", $k, $v; + $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v); } - print "\n"; + $CPAN::Frontend->myprint("\n"); for $k (sort keys %$CPAN::Config) { $v = $CPAN::Config->{$k}; if (ref $v) { - printf " %-18s\n", $k; - print map {"\t$_\n"} @{$v}; + $CPAN::Frontend->myprint( + join( + "", + sprintf( + " %-18s\n", + $k + ), + map {"\t$_\n"} @{$v} + ) + ); } else { - printf " %-18s %s\n", $k, $v; + $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v); } } - print "\n"; + $CPAN::Frontend->myprint("\n"); } elsif (!CPAN::Config->edit(@o_what)) { - print qq[Type 'o conf' to view configuration edit options\n\n]; + $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]); } } elsif ($o_type eq 'debug') { my(%valid); @@ -456,47 +1076,71 @@ sub o { } $CPAN::DEBUG = $max; } else { + my($known) = 0; for (keys %CPAN::DEBUG) { next unless lc($_) eq lc($what); $CPAN::DEBUG |= $CPAN::DEBUG{$_}; + $known = 1; } - print "unknown argument $what\n"; + $CPAN::Frontend->myprint("unknown argument [$what]\n") + unless $known; } } } else { - print "Valid options for debug are ".join(", ",sort(keys %CPAN::DEBUG), 'all'). - " or a number. Completion works on the options. Case is ignored.\n\n"; + $CPAN::Frontend->myprint("Valid options for debug are ". + join(", ",sort(keys %CPAN::DEBUG), 'all'). + qq{ or a number. Completion works on the options. }. + qq{Case is ignored.\n\n}); } if ($CPAN::DEBUG) { - print "Options set for debugging:\n"; + $CPAN::Frontend->myprint("Options set for debugging:\n"); my($k,$v); for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) { $v = $CPAN::DEBUG{$k}; - printf " %-14s(%s)\n", $k, $v if $v & $CPAN::DEBUG; + $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) if $v & $CPAN::DEBUG; } } else { - print "Debugging turned off completely.\n"; + $CPAN::Frontend->myprint("Debugging turned off completely.\n"); } } else { - print qq{ + $CPAN::Frontend->myprint(qq{ Known options: conf set or get configuration variables debug set or get debugging options -}; +}); } } #-> sub CPAN::Shell::reload ; sub reload { - if ($_[1] =~ /cpan/i) { + my($self,$command,@arg) = @_; + $command ||= ""; + $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG; + if ($command =~ /cpan/i) { CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG; - my $fh = IO::File->new($INC{'CPAN.pm'}); - local $/; + my $fh = FileHandle->new($INC{'CPAN.pm'}); + local($/); undef $/; + $redef = 0; + local($SIG{__WARN__}) + = sub { + if ( $_[0] =~ /Subroutine \w+ redefined/ ) { + ++$redef; + local($|) = 1; + $CPAN::Frontend->myprint("."); + return; + } + warn @_; + }; eval <$fh>; warn $@ if $@; - } elsif ($_[1] =~ /index/) { + $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); + } elsif ($command =~ /index/) { CPAN::Index->force_reload; + } else { + $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file +index re-reads the index files +}); } } @@ -504,16 +1148,19 @@ sub reload { sub _binary_extensions { my($self) = shift @_; my(@result,$module,%seen,%need,$headerdone); + my $isaperl = q{perl5[._-]\\d{3}(_[0-4][0-9])?\\.tar[._-]gz$}; for $module ($self->expand('Module','/./')) { my $file = $module->cpan_file; next if $file eq "N/A"; next if $file =~ /^Contact Author/; - next if $file =~ /perl5[._-]\d{3}(?:[\d_]+)?\.tar[._-]gz$/; + next if $file =~ / $isaperl /xo; next unless $module->xs_file; + local($|) = 1; + $CPAN::Frontend->myprint("."); push @result, $module; } # print join " | ", @result; -# print "\n"; + $CPAN::Frontend->myprint("\n"); return @result; } @@ -522,14 +1169,15 @@ sub recompile { my($self) = shift @_; my($module,@module,$cpan_file,%dist); @module = $self->_binary_extensions(); - for $module (@module){ # we force now and compile later, so we don't do it twice + for $module (@module){ # we force now and compile later, so we + # don't do it twice $cpan_file = $module->cpan_file; my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); $pack->force; $dist{$cpan_file}++; } for $cpan_file (sort keys %dist) { - print " CPAN: Recompiling $cpan_file\n\n"; + $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n"); my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); $pack->install; $CPAN::Signal = 0; # it's tempting to reset Signal, so we can @@ -547,13 +1195,14 @@ sub _u_r_common { Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/; my(@args) = @_; @args = '/./' unless @args; - my(@result,$module,%seen,%need,$headerdone,$version_zeroes); - $version_zeroes = 0; + my(@result,$module,%seen,%need,$headerdone, + $version_undefs,$version_zeroes); + $version_undefs = $version_zeroes = 0; my $sprintf = "%-25s %9s %9s %s\n"; for $module ($self->expand('Module',@args)) { my $file = $module->cpan_file; next unless defined $file; # ?? - my($latest) = $module->cpan_version || 0; + my($latest) = $module->cpan_version; my($inst_file) = $module->inst_file; my($have); if ($inst_file){ @@ -562,8 +1211,15 @@ sub _u_r_common { } elsif ($what eq "r") { $have = $module->inst_version; local($^W) = 0; - $version_zeroes++ unless $have; + if ($have eq "undef"){ + $version_undefs++; + } elsif ($have == 0){ + $version_zeroes++; + } next if $have >= $latest; +# to be pedantic we should probably say: +# && !($have eq "undef" && $latest ne "undef" && $latest gt ""); +# to catch the case where CPAN has a version 0 and we have a version undef } elsif ($what eq "u") { next; } @@ -576,6 +1232,7 @@ sub _u_r_common { $have = "-"; } } + return if $CPAN::Signal; # this is sometimes lengthy $seen{$file} ||= 0; if ($what eq "a") { push @result, sprintf "%s %s\n", $module->id, $have; @@ -588,25 +1245,38 @@ sub _u_r_common { next if $file =~ /^Contact/; } unless ($headerdone++){ - print "\n"; - printf $sprintf, "Package namespace", "installed", "latest", "in CPAN file"; + $CPAN::Frontend->myprint("\n"); + $CPAN::Frontend->myprint(sprintf( + $sprintf, + "Package namespace", + "installed", + "latest", + "in CPAN file" + )); } $latest = substr($latest,0,8) if length($latest) > 8; $have = substr($have,0,8) if length($have) > 8; - printf $sprintf, $module->id, $have, $latest, $file; + $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $file); $need{$module->id}++; - return if $CPAN::Signal; # this is sometimes lengthy } unless (%need) { if ($what eq "u") { - print "No modules found for @args\n"; + $CPAN::Frontend->myprint("No modules found for @args\n"); } elsif ($what eq "r") { - print "All modules are up to date for @args\n"; + $CPAN::Frontend->myprint("All modules are up to date for @args\n"); } } - if ($what eq "r" && $version_zeroes) { - my $s = $version_zeroes>1 ? "s have" : " has"; - print qq{$version_zeroes installed module$s no version number to compare\n}; + if ($what eq "r") { + if ($version_zeroes) { + my $s_has = $version_zeroes > 1 ? "s have" : " has"; + $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }. + qq{a version number of 0\n}); + } + if ($version_undefs) { + my $s_has = $version_undefs > 1 ? "s have" : " has"; + $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }. + qq{parseable version number\n}); + } } @result; } @@ -625,10 +1295,10 @@ sub u { sub autobundle { my($self) = shift; my(@bundle) = $self->_u_r_common("a",@_); - my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle"); + my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle"); File::Path::mkpath($todir); unless (-d $todir) { - print "Couldn't mkdir $todir for some reason\n"; + $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n"); return; } my($y,$m,$d) = (localtime)[5,4,3]; @@ -636,12 +1306,12 @@ sub autobundle { $m++; my($c) = 0; my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c; - my($to) = $CPAN::META->catfile($todir,"$me.pm"); + my($to) = MM->catfile($todir,"$me.pm"); while (-f $to) { $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c; - $to = $CPAN::META->catfile($todir,"$me.pm"); + $to = MM->catfile($todir,"$me.pm"); } - my($fh) = IO::File->new(">$to") or Carp::croak "Can't open >$to: $!"; + my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!"; $fh->print( "package Bundle::$me;\n\n", "\$VERSION = '0.01';\n\n", @@ -659,11 +1329,12 @@ sub autobundle { "\n\n=head1 CONFIGURATION\n\n", Config->myconfig, "\n\n=head1 AUTHOR\n\n", - "This Bundle has been generated automatically by the autobundle routine in CPAN.pm.\n", + "This Bundle has been generated automatically ", + "by the autobundle routine in CPAN.pm.\n", ); $fh->close; - print "\nWrote bundle file - $to\n\n"; + $CPAN::Frontend->myprint("\nWrote bundle file + $to\n\n"); } #-> sub CPAN::Shell::expand ; @@ -680,7 +1351,19 @@ sub expand { my $obj; if (defined $regex) { for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) { - push @m, $obj if $obj->id =~ /$regex/i or $obj->can('name') && $obj->name =~ /$regex/i; + push @m, $obj + if + $obj->id =~ /$regex/i + or + ( + ( + $] < 5.00303 ### provide sort of compatibility with 5.003 + || + $obj->can('name') + ) + && + $obj->name =~ /$regex/i + ); } } else { my($xarg) = $arg; @@ -689,7 +1372,7 @@ sub expand { } if ($CPAN::META->exists($class,$xarg)) { $obj = $CPAN::META->instance($class,$xarg); - } elsif ($obj = $CPAN::META->exists($class,$arg)) { + } elsif ($CPAN::META->exists($class,$arg)) { $obj = $CPAN::META->instance($class,$arg); } else { next; @@ -697,7 +1380,7 @@ sub expand { push @m, $obj; } } - return @m; + return wantarray ? @m : $m[0]; } #-> sub CPAN::Shell::format_result ; @@ -706,11 +1389,74 @@ sub format_result { my($type,@args) = @_; @args = '/./' unless @args; my(@result) = $self->expand($type,@args); - my $result = @result==1 ? $result[0]->as_string : join "", map {$_->as_glimpse} @result; + my $result = @result == 1 ? + $result[0]->as_string : + join "", map {$_->as_glimpse} @result; $result ||= "No objects of type $type found for argument @args\n"; $result; } +# The only reason for this method is currently to have a reliable +# debugging utility that reveals which output is going through which +# channel. No, I don't like the colors ;-) +sub print_ornamented { + my($self,$what,$ornament) = @_; + my $longest = 0; + my $ornamenting = 0; # turn the colors on + + if ($ornamenting) { + unless (defined &color) { + if ($CPAN::META->has_inst("Term::ANSIColor")) { + import Term::ANSIColor "color"; + } else { + *color = sub { return "" }; + } + } + for my $line (split /\n/, $what) { + $longest = length($line) if length($line) > $longest; + } + my $sprintf = "%-" . $longest . "s"; + while ($what){ + $what =~ s/(.*\n?)//m; + my $line = $1; + last unless $line; + my($nl) = chomp $line ? "\n" : ""; + # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n"; + print color($ornament), sprintf($sprintf,$line), color("reset"), $nl; + } + } else { + print $what; + } +} + +sub myprint { + my($self,$what) = @_; + $self->print_ornamented($what, 'bold blue on_yellow'); +} + +sub myexit { + my($self,$what) = @_; + $self->myprint($what); + exit; +} + +sub mywarn { + my($self,$what) = @_; + $self->print_ornamented($what, 'bold red on_yellow'); +} + +sub myconfess { + my($self,$what) = @_; + $self->print_ornamented($what, 'bold red on_white'); + Carp::confess "died"; +} + +sub mydie { + my($self,$what) = @_; + $self->print_ornamented($what, 'bold red on_white'); + die "\n"; +} + #-> sub CPAN::Shell::rematein ; sub rematein { shift; @@ -731,34 +1477,59 @@ sub rematein { } elsif ($s =~ m|^Bundle::|) { $obj = $CPAN::META->instance('CPAN::Bundle',$s); } else { - $obj = $CPAN::META->instance('CPAN::Module',$s) if $CPAN::META->exists('CPAN::Module',$s); + $obj = $CPAN::META->instance('CPAN::Module',$s) + if $CPAN::META->exists('CPAN::Module',$s); } if (ref $obj) { - CPAN->debug(qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}.$obj->as_string.qq{\]}) if $CPAN::DEBUG; - $obj->$pragma() if $pragma && $obj->can($pragma); + CPAN->debug( + qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}. + $obj->as_string. + qq{\]} + ) if $CPAN::DEBUG; + $obj->$pragma() + if + $pragma + && + ($] < 5.00303 || $obj->can($pragma)); ### compatibility with 5.003 $obj->$meth(); + } elsif ($CPAN::META->exists('CPAN::Author',$s)) { + $obj = $CPAN::META->instance('CPAN::Author',$s); + $CPAN::Frontend->myprint( + join "", + "Don't be silly, you can't $meth ", + $obj->fullname, + " ;-)\n" + ); } else { - print "Warning: Cannot $meth $s, don't know what it is\n"; + $CPAN::Frontend->myprint(qq{Warning: Cannot $meth $s, don\'t know what it is. +Try the command + + i /$s/ + +to find objects with similar identifiers. +}); } } } #-> sub CPAN::Shell::force ; sub force { shift->rematein('force',@_); } +#-> sub CPAN::Shell::get ; +sub get { shift->rematein('get',@_); } #-> sub CPAN::Shell::readme ; sub readme { shift->rematein('readme',@_); } #-> sub CPAN::Shell::make ; sub make { shift->rematein('make',@_); } -#-> sub CPAN::Shell::clean ; -sub clean { shift->rematein('clean',@_); } #-> sub CPAN::Shell::test ; sub test { shift->rematein('test',@_); } #-> sub CPAN::Shell::install ; sub install { shift->rematein('install',@_); } +#-> sub CPAN::Shell::clean ; +sub clean { shift->rematein('clean',@_); } +#-> sub CPAN::Shell::look ; +sub look { shift->rematein('look',@_); } package CPAN::FTP; -use vars qw($Ua); -@CPAN::FTP::ISA = qw(CPAN::Debug); #-> sub CPAN::FTP::ftp_get ; sub ftp_get { @@ -768,13 +1539,13 @@ sub ftp_get { on host [$host] as local [$target]\n] ) if $CPAN::DEBUG; my $ftp = Net::FTP->new($host); + return 0 unless defined $ftp; $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]); unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){ warn "Couldn't login on $host"; return; } - # print qq[Going to ->cwd("$dir")\n]; unless ( $ftp->cwd($dir) ){ warn "Couldn't cwd $dir"; return; @@ -782,192 +1553,549 @@ sub ftp_get { $ftp->binary; $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; unless ( $ftp->get($file,$target) ){ - warn "Couldn't fetch $file from $host"; + warn "Couldn't fetch $file from $host\n"; return; } - $ftp->quit; + $ftp->quit; # it's ok if this fails + return 1; +} + +sub is_reachable { + my($self,$url) = @_; + return 1; # we can't simply roll our own, firewalls may break ping + return 0 unless $url; + return 1 if substr($url,0,4) eq "file"; + return 1 unless $url =~ m|://([^/]+)|; + my $host = $1; + require Net::Ping; + return 1 unless $Net::Ping::VERSION >= 2; + my $p; + eval {$p = Net::Ping->new("icmp");}; + eval {$p = Net::Ping->new("tcp");} if $@; + $CPAN::Frontend->mydie($@) if $@; + return $p->ping($host, 3); } #-> sub CPAN::FTP::localize ; +# sorry for the ugly code here, I'll clean it up as soon as Net::FTP +# is in the core sub localize { my($self,$file,$aslocal,$force) = @_; $force ||= 0; - Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])" unless defined $aslocal; - $self->debug("file [$file] aslocal [$aslocal]") if $CPAN::DEBUG; + Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])" + unless defined $aslocal; + $self->debug("file[$file] aslocal[$aslocal] force[$force]") + if $CPAN::DEBUG; - return $aslocal if -f $aslocal && -r _ && ! $force; + return $aslocal if -f $aslocal && -r _ && !($force & 1); + my($restore) = 0; + if (-f $aslocal){ + rename $aslocal, "$aslocal.bak"; + $restore++; + } my($aslocal_dir) = File::Basename::dirname($aslocal); File::Path::mkpath($aslocal_dir); - print STDERR qq{Warning: You are not allowed to write into directory "$aslocal_dir". - I\'ll continue, but if you face any problems, they may be due - to insufficient permissions.\n} unless -w $aslocal_dir; + $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }. + qq{directory "$aslocal_dir". + I\'ll continue, but if you encounter problems, they may be due + to insufficient permissions.\n}) unless -w $aslocal_dir; # Inheritance is not easier to manage than a few if/else branches - if ($CPAN::META->hasLWP) { + if ($CPAN::META->has_inst('LWP')) { require LWP::UserAgent; unless ($Ua) { - $Ua = new LWP::UserAgent; - $Ua->proxy('ftp', $ENV{'ftp_proxy'}) if defined $ENV{'ftp_proxy'}; - $Ua->proxy('http', $ENV{'http_proxy'}) if defined $ENV{'http_proxy'}; - $Ua->no_proxy($ENV{'no_proxy'}) if defined $ENV{'no_proxy'}; + $Ua = LWP::UserAgent->new; + my($var); + $Ua->proxy('ftp', $var) + if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'}; + $Ua->proxy('http', $var) + if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'}; + $Ua->no_proxy($var) + if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'}; } } # Try the list of urls for each single object. We keep a record # where we did get a file from - for (0..$#{$CPAN::Config->{urllist}}) { - my $url = $CPAN::Config->{urllist}[$_]; + my(@reordered,$last); +#line 1621 + $last = $#{$CPAN::Config->{urllist}}; + if ($force & 2) { # local cpans probably out of date, don't reorder + @reordered = (0..$last); + } else { + @reordered = + sort { + (substr($CPAN::Config->{urllist}[$b],0,4) eq "file") + <=> + (substr($CPAN::Config->{urllist}[$a],0,4) eq "file") + or + defined($Thesite) + and + ($b == $Thesite) + <=> + ($a == $Thesite) + } 0..$last; + +# ((grep { substr($CPAN::Config->{urllist}[$_],0,4) +# eq "file" } 0..$last), +# (grep { substr($CPAN::Config->{urllist}[$_],0,4) +# ne "file" } 0..$last)); + } + my($level,@levels); + if ($Themethod) { + @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/); + } else { + @levels = qw/easy hard hardest/; + } + for $level (@levels) { + my $method = "host$level"; + my @host_seq = $level eq "easy" ? + @reordered : 0..$last; # reordered has CDROM up front + my $ret = $self->$method(\@host_seq,$file,$aslocal); + if ($ret) { + $Themethod = $level; + $self->debug("level[$level]") if $CPAN::DEBUG; + return $ret; + } + } + my(@mess); + push @mess, + qq{Please check, if the URLs I found in your configuration file \(}. + join(", ", @{$CPAN::Config->{urllist}}). + qq{\) are valid. The urllist can be edited.}, + qq{E.g. with ``o conf urllist push ftp://myurl/''}; + $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n"); + sleep 2; + $CPAN::Frontend->myprint("Cannot fetch $file\n\n"); + if ($restore) { + rename "$aslocal.bak", $aslocal; + $CPAN::Frontend->myprint("Trying to get away with old file:\n" . + $self->ls($aslocal)); + return $aslocal; + } + return; +} + +sub hosteasy { + my($self,$host_seq,$file,$aslocal) = @_; + my($i); + HOSTEASY: for $i (@$host_seq) { + my $url = $CPAN::Config->{urllist}[$i]; + unless ($self->is_reachable($url)) { + $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n"); + sleep 2; + next; + } $url .= "/" unless substr($url,-1) eq "/"; $url .= $file; - $self->debug("localizing[$url]") if $CPAN::DEBUG; + $self->debug("localizing perlish[$url]") if $CPAN::DEBUG; if ($url =~ /^file:/) { my $l; - if ($CPAN::META->hasLWP) { + if ($CPAN::META->has_inst('LWP')) { require URI::URL; - my $u = new URI::URL $url; + my $u = URI::URL->new($url); $l = $u->path; } else { # works only on Unix, is poorly constructed, but - # hopefully better than nothing. - # RFC 1738 says fileurl BNF is - # fileurl = "file://" [ host | "localhost" ] "/" fpath - # Thanks to "Mark D. Baushke" for the code + # hopefully better than nothing. + # RFC 1738 says fileurl BNF is + # fileurl = "file://" [ host | "localhost" ] "/" fpath + # Thanks to "Mark D. Baushke" for + # the code ($l = $url) =~ s,^file://[^/]+,,; # discard the host part $l =~ s/^file://; # assume they meant file://localhost } - return $l if -f $l && -r _; + if ( -f $l && -r _) { + $Thesite = $i; + return $l; + } + # Maybe mirror has compressed it? + if (-f "$l.gz") { + $self->debug("found compressed $l.gz") if $CPAN::DEBUG; + system("$CPAN::Config->{gzip} -dc $l.gz > $aslocal"); + if ( -f $aslocal) { + $Thesite = $i; + return $aslocal; + } + } } - - if ($CPAN::META->hasLWP) { - print "Fetching $url\n"; + if ($CPAN::META->has_inst('LWP')) { + $CPAN::Frontend->myprint("Fetching with LWP: + $url +"); my $res = $Ua->mirror($url, $aslocal); if ($res->is_success) { + $Thesite = $i; return $aslocal; + } elsif ($url !~ /\.gz$/) { + my $gzurl = "$url.gz"; + $CPAN::Frontend->myprint("Fetching with LWP: + $gzurl +"); + $res = $Ua->mirror($gzurl, "$aslocal.gz"); + if ($res->is_success && + system("$CPAN::Config->{gzip} -d $aslocal.gz")==0) { + $Thesite = $i; + return $aslocal; + } else { + next HOSTEASY ; + } + } else { + next HOSTEASY ; } } if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { + # that's the nice and easy way thanks to Graham my($host,$dir,$getfile) = ($1,$2,$3); - if ($CPAN::META->hasFTP) { + if ($CPAN::META->has_inst('Net::FTP')) { $dir =~ s|/+|/|g; - $self->debug("Going to fetch file [$getfile] - from dir [$dir] - on host [$host] - as local [$aslocal]") if $CPAN::DEBUG; - CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal) && return $aslocal; - } elsif (-x $CPAN::Config->{'ftp'}) { - my($netrc) = CPAN::FTP::netrc->new; - if ($netrc->hasdefault() || $netrc->contains($host)) { - print( - qq{ - Trying with external ftp to get $url - As this requires some features that are not thoroughly tested, we\'re - not sure, that we get it right. Please, install Net::FTP as soon - as possible. Just type "install Net::FTP". Thank you. - -} - ); - my($fh) = IO::File->new; - my($cwd) = Cwd::cwd(); - chdir $aslocal_dir; - my($targetfile) = File::Basename::basename($aslocal); - my(@dialog); - push @dialog, map {"cd $_\n"} split "/", $dir; - push @dialog, "get $getfile $targetfile\n"; - push @dialog, "quit\n"; - open($fh, "|$CPAN::Config->{'ftp'} $host") or die "Couldn't open ftp: $!"; - # pilot is blind now - foreach (@dialog) { - $fh->print($_); - } - chdir($cwd); + $CPAN::Frontend->myprint("Fetching with Net::FTP: + $aslocal +"); + $self->debug("getfile[$getfile]dir[$dir]host[$host]" . + "aslocal[$aslocal]") if $CPAN::DEBUG; + if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) { + $Thesite = $i; return $aslocal; - } else { - my($netrcfile) = $netrc->netrc(); - if ($netrcfile){ - print qq{ Your $netrcfile does not contain host $host.\n} - } else { - print qq{ I could not find or open your .netrc file.\n} + } + if ($aslocal !~ /\.gz$/) { + my $gz = "$aslocal.gz"; + $CPAN::Frontend->myprint("Fetching with Net::FTP + $gz +"); + if (CPAN::FTP->ftp_get($host, + $dir, + "$getfile.gz", + $gz) && + system("$CPAN::Config->{gzip} -d $gz")==0 ){ + $Thesite = $i; + return $aslocal; } - print qq{ If you want to use external ftp, - please enter the host $host (or a default entry) - into your .netrc file and retry. - - The format of a proper entry in your .netrc file would be: - machine $host - login ftp - password $Config::Config{cf_email} - - A typical default entry would be: - default login ftp password $Config::Config{cf_email} - - Please make also sure, your .netrc will not be readable by others. - You don\'t have to leave and restart CPAN.pm, I\'ll look again next - time I come around here.\n\n}; - } + } + next HOSTEASY; } - sleep 2; } - if (-x $CPAN::Config->{'lynx'}) { -## $self->debug("Trying with lynx for [$url]") if $CPAN::DEBUG; + } +} + +sub hosthard { + my($self,$host_seq,$file,$aslocal) = @_; + + # Came back if Net::FTP couldn't establish connection (or + # failed otherwise) Maybe they are behind a firewall, but they + # gave us a socksified (or other) ftp program... + + my($i); + my($aslocal_dir) = File::Basename::dirname($aslocal); + File::Path::mkpath($aslocal_dir); + HOSTHARD: for $i (@$host_seq) { + my $url = $CPAN::Config->{urllist}[$i]; + unless ($self->is_reachable($url)) { + $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); + next; + } + $url .= "/" unless substr($url,-1) eq "/"; + $url .= $file; + my($host,$dir,$getfile); + if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { + ($host,$dir,$getfile) = ($1,$2,$3); + } else { + next HOSTHARD; # who said, we could ftp anything except ftp? + } + $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; + my($f,$funkyftp); + for $f ('lynx','ncftp') { + next unless exists $CPAN::Config->{$f}; + $funkyftp = $CPAN::Config->{$f}; + next unless defined $funkyftp; + next if $funkyftp =~ /^\s*$/; my($want_compressed); - print( + my $aslocal_uncompressed; + ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; + my($source_switch) = ""; + $source_switch = "-source" if $funkyftp =~ /\blynx$/; + $source_switch = "-c" if $funkyftp =~ /\bncftp$/; + $CPAN::Frontend->myprint( qq{ - Trying with lynx to get $url - As lynx has so many options and versions, we\'re not sure, that we - get it right. It is recommended that you install Net::FTP as soon - as possible. Just type "install Net::FTP". Thank you. - -} - ); - $want_compressed = $aslocal =~ s/\.gz//; - my($system) = "$CPAN::Config->{'lynx'} -source '$url' > $aslocal"; - if (system($system)==0) { - if ($want_compressed) { - $system = "$CPAN::Config->{'gzip'} -dt $aslocal"; - if (system($system)==0) { - rename $aslocal, "$aslocal.gz"; +Trying with "$funkyftp $source_switch" to get + $url +}); + my($system) = "$funkyftp $source_switch '$url' > ". + "$aslocal_uncompressed"; + $self->debug("system[$system]") if $CPAN::DEBUG; + my($wstatus); + if (($wstatus = system($system)) == 0 + && + -s $aslocal_uncompressed # lynx returns 0 on my + # system even if it fails + ) { + if ($aslocal_uncompressed ne $aslocal) { + # test gzip integrity + $system = + "$CPAN::Config->{'gzip'} -dt $aslocal_uncompressed"; + if (system($system) == 0) { + rename $aslocal_uncompressed, $aslocal; } else { - $system = "$CPAN::Config->{'gzip'} $aslocal"; + $system = + "$CPAN::Config->{'gzip'} $aslocal_uncompressed"; system($system); } - return "$aslocal.gz"; - } else { - $system = "$CPAN::Config->{'gzip'} -dt $aslocal"; - if (system($system)==0) { - $system = "$CPAN::Config->{'gzip'} -d $aslocal"; + $Thesite = $i; + return $aslocal; + } + } elsif ($url !~ /\.gz$/) { + my $gz = "$aslocal.gz"; + my $gzurl = "$url.gz"; + $CPAN::Frontend->myprint( + qq{ +Trying with "$funkyftp $source_switch" to get + $url.gz +}); + my($system) = "$funkyftp $source_switch '$url.gz' > ". + "$aslocal_uncompressed.gz"; + $self->debug("system[$system]") if $CPAN::DEBUG; + my($wstatus); + if (($wstatus = system($system)) == 0 + && + -s "$aslocal_uncompressed.gz" + ) { + # test gzip integrity + $system = + "$CPAN::Config->{'gzip'} -dt $aslocal_uncompressed.gz"; + $CPAN::Frontend->mywarn("system[$system]"); + if (system($system) == 0) { + $system = "$CPAN::Config->{'gzip'} -dc ". + "$aslocal_uncompressed.gz > $aslocal"; + $CPAN::Frontend->mywarn("system[$system]"); system($system); } else { - # should be fine, eh? + rename $aslocal_uncompressed, $aslocal; } +#line 1739 + $Thesite = $i; return $aslocal; } + } else { + my $estatus = $wstatus >> 8; + my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : ""; + $CPAN::Frontend->myprint(qq{ +System call "$system" +returned status $estatus (wstat $wstatus)$size +}); } } - warn "Can't access URL $url. - Either get LWP or Net::FTP - or an external lynx or ftp"; } - Carp::croak("Cannot fetch $file from anywhere"); } -package CPAN::FTP::external; +sub hosthardest { + my($self,$host_seq,$file,$aslocal) = @_; + + my($i); + my($aslocal_dir) = File::Basename::dirname($aslocal); + File::Path::mkpath($aslocal_dir); + HOSTHARDEST: for $i (@$host_seq) { + unless (length $CPAN::Config->{'ftp'}) { + $CPAN::Frontend->myprint("No external ftp command available\n\n"); + last HOSTHARDEST; + } + my $url = $CPAN::Config->{urllist}[$i]; + unless ($self->is_reachable($url)) { + $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); + next; + } + $url .= "/" unless substr($url,-1) eq "/"; + $url .= $file; + $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG; + unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { + next; + } + my($host,$dir,$getfile) = ($1,$2,$3); + my($netrcfile,$fh); + my $timestamp = 0; + my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime, + $ctime,$blksize,$blocks) = stat($aslocal); + $timestamp = $mtime ||= 0; + my($netrc) = CPAN::FTP::netrc->new; + my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : ""; + my $targetfile = File::Basename::basename($aslocal); + my(@dialog); + push( + @dialog, + "lcd $aslocal_dir", + "cd /", + map("cd $_", split "/", $dir), # RFC 1738 + "bin", + "get $getfile $targetfile", + "quit" + ); + if (! $netrc->netrc) { + CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG; + } elsif ($netrc->hasdefault || $netrc->contains($host)) { + CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]", + $netrc->hasdefault, + $netrc->contains($host))) if $CPAN::DEBUG; + if ($netrc->protected) { + $CPAN::Frontend->myprint(qq{ + Trying with external ftp to get + $url + As this requires some features that are not thoroughly tested, we\'re + not sure, that we get it right.... + +} + ); + $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host", + @dialog); + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); + $mtime ||= 0; + if ($mtime > $timestamp) { + $CPAN::Frontend->myprint("GOT $aslocal\n"); + $Thesite = $i; + return $aslocal; + } else { + $CPAN::Frontend->myprint("Hmm... Still failed!\n"); + } + } else { + $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }. + qq{correctly protected.\n}); + } + } else { + $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host + nor does it have a default entry\n"); + } + + # OK, they don't have a valid ~/.netrc. Use 'ftp -n' + # then and login manually to host, using e-mail as + # password. + $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n}); + unshift( + @dialog, + "open $host", + "user anonymous $Config::Config{'cf_email'}" + ); + $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog); + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); + $mtime ||= 0; + if ($mtime > $timestamp) { + $CPAN::Frontend->myprint("GOT $aslocal\n"); + $Thesite = $i; + return $aslocal; + } else { + $CPAN::Frontend->myprint("Bad luck... Still failed!\n"); + } + $CPAN::Frontend->myprint("Can't access URL $url.\n\n"); + sleep 2; + } +} + +sub talk_ftp { + my($self,$command,@dialog) = @_; + my $fh = FileHandle->new; + $fh->open("|$command") or die "Couldn't open ftp: $!"; + foreach (@dialog) { $fh->print("$_\n") } + $fh->close; # Wait for process to complete + my $wstatus = $?; + my $estatus = $wstatus >> 8; + $CPAN::Frontend->myprint(qq{ +Subprocess "|$command" + returned status $estatus (wstat $wstatus) +}) if $wstatus; + +} + +# find2perl needs modularization, too, all the following is stolen +# from there +sub ls { + my($self,$name) = @_; + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm, + $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name); + + my($perms,%user,%group); + my $pname = $name; + + if ($blocks) { + $blocks = int(($blocks + 1) / 2); + } + else { + $blocks = int(($sizemm + 1023) / 1024); + } + + if (-f _) { $perms = '-'; } + elsif (-d _) { $perms = 'd'; } + elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; } + elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; } + elsif (-p _) { $perms = 'p'; } + elsif (-S _) { $perms = 's'; } + else { $perms = 'l'; $pname .= ' -> ' . readlink($_); } + + my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx'); + my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); + my $tmpmode = $mode; + my $tmp = $rwx[$tmpmode & 7]; + $tmpmode >>= 3; + $tmp = $rwx[$tmpmode & 7] . $tmp; + $tmpmode >>= 3; + $tmp = $rwx[$tmpmode & 7] . $tmp; + substr($tmp,2,1) =~ tr/-x/Ss/ if -u _; + substr($tmp,5,1) =~ tr/-x/Ss/ if -g _; + substr($tmp,8,1) =~ tr/-x/Tt/ if -k _; + $perms .= $tmp; + + my $user = $user{$uid} || $uid; # too lazy to implement lookup + my $group = $group{$gid} || $gid; + + my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime); + my($timeyear); + my($moname) = $moname[$mon]; + if (-M _ > 365.25 / 2) { + $timeyear = $year + 1900; + } + else { + $timeyear = sprintf("%02d:%02d", $hour, $min); + } + + sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n", + $ino, + $blocks, + $perms, + $nlink, + $user, + $group, + $sizemm, + $moname, + $mday, + $timeyear, + $pname; +} package CPAN::FTP::netrc; sub new { my($class) = @_; - my $file = MY->catfile($ENV{HOME},".netrc"); + my $file = MM->catfile($ENV{HOME},".netrc"); + + my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) + = stat($file); + $mode ||= 0; + my $protected = 0; + my($fh,@machines,$hasdefault); $hasdefault = 0; - if($fh = IO::File->new($file,"r")){ + $fh = FileHandle->new or die "Could not create a filehandle"; + + if($fh->open($file)){ + $protected = ($mode & 077) == 0; local($/) = ""; NETRC: while (<$fh>) { - my(@tokens) = split ' ', $_; + my(@tokens) = split " ", $_; TOKEN: while (@tokens) { my($t) = shift @tokens; - $hasdefault++, last NETRC if $t eq "default"; # we will most - # probably be - # able to anonftp + if ($t eq "default"){ + $hasdefault++; + last NETRC; + } last TOKEN if $t eq "macdef"; if ($t eq "machine") { push @machines, shift @tokens; @@ -975,109 +2103,120 @@ sub new { } } } else { - $file = ""; + $file = $hasdefault = $protected = ""; } + bless { 'mach' => [@machines], 'netrc' => $file, 'hasdefault' => $hasdefault, + 'protected' => $protected, }, $class; } sub hasdefault { shift->{'hasdefault'} } -sub netrc { shift->{'netrc'} } +sub netrc { shift->{'netrc'} } +sub protected { shift->{'protected'} } sub contains { my($self,$mach) = @_; - scalar grep {$_ eq $mach} @{$self->{'mach'}}; + for ( @{$self->{'mach'}} ) { + return 1 if $_ eq $mach; + } + return 0; } package CPAN::Complete; -@CPAN::Complete::ISA = qw(CPAN::Debug); -#-> sub CPAN::Complete::complete ; -sub complete { +#-> sub CPAN::Complete::cpl ; +sub cpl { my($word,$line,$pos) = @_; $word ||= ""; $line ||= ""; $pos ||= 0; CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG; $line =~ s/^\s*//; + if ($line =~ s/^(force\s*)//) { + $pos -= length($1); + } my @return; if ($pos == 0) { - @return = grep(/^$word/, sort qw(! a b d h i m o q r u autobundle clean make test install reload)); - } elsif ( $line !~ /^[\!abdhimorut]/ ) { + @return = grep( + /^$word/, + sort qw( + ! a b d h i m o q r u autobundle clean + make test install force reload look + ) + ); + } elsif ( $line !~ /^[\!abdhimorutl]/ ) { @return = (); } elsif ($line =~ /^a\s/) { - @return = completex('CPAN::Author',$word); + @return = cplx('CPAN::Author',$word); } elsif ($line =~ /^b\s/) { - @return = completex('CPAN::Bundle',$word); + @return = cplx('CPAN::Bundle',$word); } elsif ($line =~ /^d\s/) { - @return = completex('CPAN::Distribution',$word); - } elsif ($line =~ /^([mru]\s|(make|clean|test|install)\s)/ ) { - @return = (completex('CPAN::Module',$word),completex('CPAN::Bundle',$word)); + @return = cplx('CPAN::Distribution',$word); + } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) { + @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); } elsif ($line =~ /^i\s/) { - @return = complete_any($word); + @return = cpl_any($word); } elsif ($line =~ /^reload\s/) { - @return = complete_reload($word,$line,$pos); + @return = cpl_reload($word,$line,$pos); } elsif ($line =~ /^o\s/) { - @return = complete_option($word,$line,$pos); + @return = cpl_option($word,$line,$pos); } else { @return = (); } return @return; } -#-> sub CPAN::Complete::completex ; -sub completex { +#-> sub CPAN::Complete::cplx ; +sub cplx { my($class, $word) = @_; grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class); } -#-> sub CPAN::Complete::complete_any ; -sub complete_any { +#-> sub CPAN::Complete::cpl_any ; +sub cpl_any { my($word) = shift; return ( - completex('CPAN::Author',$word), - completex('CPAN::Bundle',$word), - completex('CPAN::Distribution',$word), - completex('CPAN::Module',$word), + cplx('CPAN::Author',$word), + cplx('CPAN::Bundle',$word), + cplx('CPAN::Distribution',$word), + cplx('CPAN::Module',$word), ); } -#-> sub CPAN::Complete::complete_reload ; -sub complete_reload { +#-> sub CPAN::Complete::cpl_reload ; +sub cpl_reload { my($word,$line,$pos) = @_; $word ||= ""; my(@words) = split " ", $line; CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; my(@ok) = qw(cpan index); - return @ok if @words==1; - return grep /^\Q$word\E/, @ok if @words==2 && $word; + return @ok if @words == 1; + return grep /^\Q$word\E/, @ok if @words == 2 && $word; } -#-> sub CPAN::Complete::complete_option ; -sub complete_option { +#-> sub CPAN::Complete::cpl_option ; +sub cpl_option { my($word,$line,$pos) = @_; $word ||= ""; my(@words) = split " ", $line; CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; my(@ok) = qw(conf debug); - return @ok if @words==1; - return grep /^\Q$word\E/, @ok if @words==2 && $word; + return @ok if @words == 1; + return grep /^\Q$word\E/, @ok if @words == 2 && length($word); if (0) { } elsif ($words[1] eq 'index') { return (); } elsif ($words[1] eq 'conf') { - return CPAN::Config::complete(@_); + return CPAN::Config::cpl(@_); } elsif ($words[1] eq 'debug') { return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all'; } } package CPAN::Index; -use vars qw($last_time); -@CPAN::Index::ISA = qw(CPAN::Debug); -$last_time ||= 0; #-> sub CPAN::Index::force_reload ; sub force_reload { @@ -1091,41 +2230,79 @@ sub reload { my($cl,$force) = @_; my $time = time; - # XXX check if a newer one is available. (We currently read it from time to time) - return if $last_time + $CPAN::Config->{index_expire}*86400 > $time; + # XXX check if a newer one is available. (We currently read it + # from time to time) + for ($CPAN::Config->{index_expire}) { + $_ = 0.001 unless $_ > 0.001; + } + return if $last_time + $CPAN::Config->{index_expire}*86400 > $time + and ! $force; + my($debug,$t2); $last_time = $time; - $cl->read_authindex($cl->reload_x("authors/01mailrc.txt.gz","01mailrc.gz",$force)); + my $needshort = $^O eq "dos"; + + $cl->rd_authindex($cl->reload_x( + "authors/01mailrc.txt.gz", + $needshort ? "01mailrc.gz" : "", + $force)); + $t2 = time; + $debug = "timing reading 01[".($t2 - $time)."]"; + $time = $t2; return if $CPAN::Signal; # this is sometimes lengthy - $cl->read_modpacks($cl->reload_x("modules/02packages.details.txt.gz","02packag.gz",$force)); + $cl->rd_modpacks($cl->reload_x( + "modules/02packages.details.txt.gz", + $needshort ? "02packag.gz" : "", + $force)); + $t2 = time; + $debug .= "02[".($t2 - $time)."]"; + $time = $t2; return if $CPAN::Signal; # this is sometimes lengthy - $cl->read_modlist($cl->reload_x("modules/03modlist.data.gz","03mlist.gz",$force)); + $cl->rd_modlist($cl->reload_x( + "modules/03modlist.data.gz", + $needshort ? "03mlist.gz" : "", + $force)); + $t2 = time; + $debug .= "03[".($t2 - $time)."]"; + $time = $t2; + CPAN->debug($debug) if $CPAN::DEBUG; } #-> sub CPAN::Index::reload_x ; sub reload_x { my($cl,$wanted,$localname,$force) = @_; - $force ||= 0; - my $abs_wanted = CPAN->catfile($CPAN::Config->{'keep_source_where'},$localname); - if (-f $abs_wanted && -M $abs_wanted < $CPAN::Config->{'index_expire'} && !$force) { - my($s) = $CPAN::Config->{'index_expire'} != 1; - $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} day$s. I\'ll use that.\n}); + $force |= 2; # means we're dealing with an index here + CPAN::Config->load; # we should guarantee loading wherever we rely + # on Config XXX + $localname ||= $wanted; + my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'}, + $localname); + if ( + -f $abs_wanted && + -M $abs_wanted < $CPAN::Config->{'index_expire'} && + !($force & 1) + ) { + my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s"; + $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }. + qq{day$s. I\'ll use that.}); return $abs_wanted; } else { - $force ||= 1; + $force |= 1; # means we're quite serious about it. } return CPAN::FTP->localize($wanted,$abs_wanted,$force); } -#-> sub CPAN::Index::read_authindex ; -sub read_authindex { +#-> sub CPAN::Index::rd_authindex ; +sub rd_authindex { my($cl,$index_target) = @_; + return unless defined $index_target; my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; - warn "Going to read $index_target\n"; - my $fh = IO::File->new("$pipe|"); + $CPAN::Frontend->myprint("Going to read $index_target\n"); + my $fh = FileHandle->new("$pipe|"); while (<$fh>) { chomp; - my($userid,$fullname,$email) = /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/; + my($userid,$fullname,$email) = + /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/; next unless $userid && $fullname && $email; # instantiate an author object @@ -1137,57 +2314,69 @@ sub read_authindex { $? and Carp::croak "FAILED $pipe: exit status [$?]"; } -#-> sub CPAN::Index::read_modpacks ; -sub read_modpacks { +#-> sub CPAN::Index::rd_modpacks ; +sub rd_modpacks { my($cl,$index_target) = @_; + return unless defined $index_target; my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; - warn "Going to read $index_target\n"; - my $fh = IO::File->new("$pipe|"); + $CPAN::Frontend->myprint("Going to read $index_target\n"); + my $fh = FileHandle->new("$pipe|"); + while (<$fh>) { + last if /^\s*$/; + } while (<$fh>) { - next if 1../^\s*$/; chomp; my($mod,$version,$dist) = split; - $version =~ s/^\+//; +### $version =~ s/^\+//; # if it as a bundle, instatiate a bundle object - my($bundle); - if ($mod =~ /^Bundle::(.*)/) { - $bundle = $1; - } - + my($bundle,$id,$userid); + if ($mod eq 'CPAN') { - local($^W)=0; + local($^W)= 0; if ($version > $CPAN::VERSION){ - print qq{ - Hey, you know what? There\'s a new CPAN.pm version (v$version) - available! I\'d suggest--provided you have time--you try + $CPAN::Frontend->myprint(qq{ + There\'s a new CPAN.pm version (v$version) available! + You might want to try install CPAN reload cpan - without quitting the current session. It should be a seemless upgrade + without quitting the current session. It should be a seamless upgrade while we are running... -}; +}); sleep 2; - print qq{\n}; + $CPAN::Frontend->myprint(qq{\n}); } + last if $CPAN::Signal; + } elsif ($mod =~ /^Bundle::(.*)/) { + $bundle = $1; } - my($id); if ($bundle){ $id = $CPAN::META->instance('CPAN::Bundle',$mod); - $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist); + # Let's make it a module too, because bundles have so much + # in common with modules + $CPAN::META->instance('CPAN::Module',$mod); + # This "next" makes us faster but if the job is running long, we ignore # rereads which is bad. So we have to be a bit slower again. # } elsif ($CPAN::META->exists('CPAN::Module',$mod)) { # next; - } else { + + } + else { # instantiate a module object $id = $CPAN::META->instance('CPAN::Module',$mod); - $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist); } - # determine the author - my($userid) = $dist =~ /([^\/]+)/; - $id->set('CPAN_USERID' => $userid) if $userid =~ /\w/; + if ($id->cpan_file ne $dist){ + # determine the author + ($userid) = $dist =~ /([^\/]+)/; + $id->set( + 'CPAN_USERID' => $userid, + 'CPAN_VERSION' => $version, + 'CPAN_FILE' => $dist + ); + } # instantiate a distribution object unless ($CPAN::META->exists('CPAN::Distribution',$dist)) { @@ -1195,8 +2384,7 @@ sub read_modpacks { 'CPAN::Distribution' => $dist )->set( 'CPAN_USERID' => $userid - ) - if $userid =~ /\w/; + ); } return if $CPAN::Signal; @@ -1205,19 +2393,24 @@ sub read_modpacks { $? and Carp::croak "FAILED $pipe: exit status [$?]"; } -#-> sub CPAN::Index::read_modlist ; -sub read_modlist { +#-> sub CPAN::Index::rd_modlist ; +sub rd_modlist { my($cl,$index_target) = @_; + return unless defined $index_target; my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; - warn "Going to read $index_target\n"; - my $fh = IO::File->new("$pipe|"); - my $eval = ""; + $CPAN::Frontend->myprint("Going to read $index_target\n"); + my $fh = FileHandle->new("$pipe|"); + my $eval; while (<$fh>) { - next if 1../^\s*$/; - next if /use vars/; # will go away in 03... - $eval .= $_; - return if $CPAN::Signal; + if (/^Date:\s+(.*)/){ + return if $date_of_03 eq $1; + ($date_of_03) = $1; + } + last if /^\s*$/; } + local($/) = undef; + $eval = <$fh>; + $fh->close; $eval .= q{CPAN::Modulelist->data;}; local($^W) = 0; my($comp) = Safe->new("CPAN::Safe1"); @@ -1232,7 +2425,6 @@ sub read_modlist { } package CPAN::InfoObj; -@CPAN::InfoObj::ISA = qw(CPAN::Debug); #-> sub CPAN::InfoObj::new ; sub new { my $this = bless {}, shift; %$this = @_; $this } @@ -1268,7 +2460,7 @@ sub as_string { next if $_ eq 'ID'; my $extra = ""; $_ eq "CPAN_USERID" and $extra = " (".$self->author.")"; - if (ref $self->{$_}) { # Should we setup a language interface? XXX + if (ref($self->{$_}) eq "ARRAY") { # Should we setup a language interface? XXX push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; } else { push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; @@ -1284,7 +2476,6 @@ sub author { } package CPAN::Author; -@CPAN::Author::ISA = qw(CPAN::Debug CPAN::InfoObj); #-> sub CPAN::Author::as_glimpse ; sub as_glimpse { @@ -1309,7 +2500,6 @@ sub fullname { shift->{'FULLNAME'} } sub email { shift->{'EMAIL'} } package CPAN::Distribution; -@CPAN::Distribution::ISA = qw(CPAN::Debug CPAN::InfoObj); #-> sub CPAN::Distribution::called_for ; sub called_for { @@ -1323,12 +2513,13 @@ sub get { my($self) = @_; EXCUSE: { my @e; - exists $self->{'build_dir'} and push @e, "Unwrapped into directory $self->{'build_dir'}"; - print join "", map {" $_\n"} @e and return if @e; + exists $self->{'build_dir'} and push @e, + "Unwrapped into directory $self->{'build_dir'}"; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } my($local_file); my($local_wanted) = - CPAN->catfile( + MM->catfile( $CPAN::Config->{keep_source_where}, "authors", "id", @@ -1336,7 +2527,9 @@ sub get { ); $self->debug("Doing localize") if $CPAN::DEBUG; - $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted); + $local_file = + CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted) + or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n"); $self->{localfile} = $local_file; my $builddir = $CPAN::META->{cachemgr}->dir; $self->debug("doing chdir $builddir") if $CPAN::DEBUG; @@ -1344,84 +2537,128 @@ sub get { my $packagedir; $self->debug("local_file[$local_file]") if $CPAN::DEBUG; - if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz|\.zip)$/i){ - $self->debug("Removing tmp") if $CPAN::DEBUG; - File::Path::rmtree("tmp"); - mkdir "tmp", 0777 or Carp::croak "Couldn't mkdir tmp: $!"; + if ($CPAN::META->has_inst('MD5')) { + $self->debug("MD5 is installed, verifying"); + $self->verifyMD5; + } else { + $self->debug("MD5 is NOT installed"); + } + $self->debug("Removing tmp") if $CPAN::DEBUG; + File::Path::rmtree("tmp"); + mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!"; + chdir "tmp"; + $self->debug("Changed directory to tmp") if $CPAN::DEBUG; + if (! $local_file) { + Carp::croak "bad download, can't do anything :-(\n"; + } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){ + $self->untar_me($local_file); + } elsif ( $local_file =~ /\.zip$/i ) { + $self->unzip_me($local_file); + } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) { + $self->pm2dir_me($local_file); + } else { + $self->{archived} = "NO"; + } + chdir ".."; + if ($self->{archived} ne 'NO') { chdir "tmp"; - $self->debug("Changed directory to tmp") if $CPAN::DEBUG; - if ($local_file =~ /z$/i){ - $self->{archived} = "tar"; - if (system("$CPAN::Config->{gzip} --decompress --stdout $local_file | $CPAN::Config->{tar} xvf -")==0) { - $self->{unwrapped} = "YES"; - } else { - $self->{unwrapped} = "NO"; - } - } elsif ($local_file =~ /zip$/i) { - $self->{archived} = "zip"; - if (system("$CPAN::Config->{unzip} $local_file")==0) { - $self->{unwrapped} = "YES"; - } else { - $self->{unwrapped} = "NO"; - } - } # Let's check if the package has its own directory. - opendir DIR, "." or Carp::croak("Weird: couldn't opendir .: $!"); - my @readdir = grep $_ !~ /^\.\.?$/, readdir DIR; ### MAC?? - closedir DIR; + my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir .: $!"); + my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC?? + $dh->close; my ($distdir,$packagedir); if (@readdir == 1 && -d $readdir[0]) { $distdir = $readdir[0]; - $packagedir = $CPAN::META->catdir($builddir,$distdir); - -d $packagedir and print "Removing previously used $packagedir\n"; + $packagedir = MM->catdir($builddir,$distdir); + -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n"); File::Path::rmtree($packagedir); rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!"); } else { my $pragmatic_dir = $self->{'CPAN_USERID'} . '000'; $pragmatic_dir =~ s/\W_//g; $pragmatic_dir++ while -d "../$pragmatic_dir"; - $packagedir = $CPAN::META->catdir($builddir,$pragmatic_dir); + $packagedir = MM->catdir($builddir,$pragmatic_dir); File::Path::mkpath($packagedir); my($f); for $f (@readdir) { # is already without "." and ".." - my $to = $CPAN::META->catdir($packagedir,$f); + my $to = MM->catdir($packagedir,$f); rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!"); } } $self->{'build_dir'} = $packagedir; - chdir ".."; - $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") if $CPAN::DEBUG; + + $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") + if $CPAN::DEBUG; File::Path::rmtree("tmp"); if ($CPAN::Config->{keep_source_where} =~ /^no/i ){ - print "Going to unlink $local_file\n"; + $CPAN::Frontend->myprint("Going to unlink $local_file\n"); unlink $local_file or Carp::carp "Couldn't unlink $local_file"; } - my($makefilepl) = $CPAN::META->catfile($packagedir,"Makefile.PL"); + my($makefilepl) = MM->catfile($packagedir,"Makefile.PL"); unless (-f $makefilepl) { - my($configure) = $CPAN::META->catfile($packagedir,"Configure"); + my($configure) = MM->catfile($packagedir,"Configure"); if (-f $configure) { # do we have anything to do? $self->{'configure'} = $configure; } else { - my $fh = IO::File->new(">$makefilepl") or Carp::croak("Could not open >$makefilepl"); + my $fh = FileHandle->new(">$makefilepl") + or Carp::croak("Could not open >$makefilepl"); my $cf = $self->called_for || "unknown"; - $fh->print(qq{ -# This Makefile.PL has been autogenerated by the module CPAN.pm + $fh->print( +qq{# This Makefile.PL has been autogenerated by the module CPAN.pm +# because there was no Makefile.PL supplied. # Autogenerated on: }.scalar localtime().qq{ + use ExtUtils::MakeMaker; WriteMakefile(NAME => q[$cf]); + }); - print qq{Package comes without Makefile.PL.\n}. - qq{ Writing one on our own (calling it $cf)\n}; + $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.\n}. + qq{ Writing one on our own (calling it $cf)\n}); } } - } else { - $self->{archived} = "NO"; } return $self; } +sub untar_me { + my($self,$local_file) = @_; + $self->{archived} = "tar"; + my $system = "$CPAN::Config->{gzip} --decompress --stdout " . + "$local_file | $CPAN::Config->{tar} xvf -"; + if (system($system)== 0) { + $self->{unwrapped} = "YES"; + } else { + $self->{unwrapped} = "NO"; + } +} + +sub unzip_me { + my($self,$local_file) = @_; + $self->{archived} = "zip"; + my $system = "$CPAN::Config->{unzip} $local_file"; + if (system($system) == 0) { + $self->{unwrapped} = "YES"; + } else { + $self->{unwrapped} = "NO"; + } +} + +sub pm2dir_me { + my($self,$local_file) = @_; + $self->{archived} = "pm"; + my $to = File::Basename::basename($local_file); + $to =~ s/\.(gz|Z)$//; + my $system = "$CPAN::Config->{gzip} --decompress --stdout ". + "$local_file > $to"; + if (system($system) == 0) { + $self->{unwrapped} = "YES"; + } else { + $self->{unwrapped} = "NO"; + } +} + #-> sub CPAN::Distribution::new ; sub new { my($class,%att) = @_; @@ -1432,10 +2669,65 @@ sub new { return bless $this, $class; } +#-> sub CPAN::Distribution::look ; +sub look { + my($self) = @_; + if ( $CPAN::Config->{'shell'} ) { + $CPAN::Frontend->myprint(qq{ +Trying to open a subshell in the build directory... +}); + } else { + $CPAN::Frontend->myprint(qq{ +Your configuration does not define a value for subshells. +Please define it with "o conf shell " +}); + return; + } + my $dist = $self->id; + my $dir = $self->dir or $self->get; + $dir = $self->dir; + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my $pwd = CPAN->$getcwd(); + chdir($dir); + $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); + system($CPAN::Config->{'shell'}) == 0 + or $CPAN::Frontend->mydie("Subprocess shell error"); + chdir($pwd); +} + #-> sub CPAN::Distribution::readme ; sub readme { my($self) = @_; - print "Readme not yet implemented (says ".$self->id.")\n"; + my($dist) = $self->id; + my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/; + $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG; + my($local_file); + my($local_wanted) = + MM->catfile( + $CPAN::Config->{keep_source_where}, + "authors", + "id", + split("/","$sans.readme"), + ); + $self->debug("Doing localize") if $CPAN::DEBUG; + $local_file = CPAN::FTP->localize("authors/id/$sans.readme", + $local_wanted) + or $CPAN::Frontend->mydie(qq{No $sans.readme found});; + my $fh_pager = FileHandle->new; + local($SIG{PIPE}) = "IGNORE"; + $fh_pager->open("|$CPAN::Config->{'pager'}") + or die "Could not open pager $CPAN::Config->{'pager'}: $!"; + my $fh_readme = FileHandle->new; + $fh_readme->open($local_file) + or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!}); + $CPAN::Frontend->myprint(qq{ +Displaying file + $local_file +with pager "$CPAN::Config->{'pager'}" +}); + sleep 2; + $fh_pager->print(<$fh_readme>); } #-> sub CPAN::Distribution::verifyMD5 ; @@ -1443,92 +2735,116 @@ sub verifyMD5 { my($self) = @_; EXCUSE: { my @e; - $self->{MD5_STATUS} and push @e, "MD5 Checksum was ok"; - print join "", map {" $_\n"} @e and return if @e; + $self->{MD5_STATUS} ||= ""; + $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok"; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } - my($local_file); - my(@local) = split("/",$self->{ID}); - my($basename) = pop @local; + my($lc_want,$lc_file,@local,$basename); + @local = split("/",$self->{ID}); + pop @local; push @local, "CHECKSUMS"; - my($local_wanted) = - CPAN->catfile( - $CPAN::Config->{keep_source_where}, - "authors", - "id", - @local - ); + $lc_want = + MM->catfile($CPAN::Config->{keep_source_where}, + "authors", "id", @local); local($") = "/"; if ( - -f $local_wanted + -s $lc_want && - $self->MD5_check_file($local_wanted,$basename) + $self->MD5_check_file($lc_want) ) { - return $self->{MD5_STATUS}="OK"; + return $self->{MD5_STATUS} = "OK"; } - $local_file = CPAN::FTP->localize("authors/id/@local", $local_wanted, 'force>:-{'); - my($checksum_pipe); - if ($local_file) { - # fine - } else { + $lc_file = CPAN::FTP->localize("authors/id/@local", + $lc_want,1); + unless ($lc_file) { $local[-1] .= ".gz"; - $local_file = CPAN::FTP->localize( - "authors/id/@local", - "$local_wanted.gz", - 'force>:-{' - ); - my $system = "$CPAN::Config->{gzip} --decompress $local_file"; - system($system)==0 or die "Could not uncompress $local_file"; - $local_file =~ s/\.gz$//; + $lc_file = CPAN::FTP->localize("authors/id/@local", + "$lc_want.gz",1); + if ($lc_file) { + my @system = ($CPAN::Config->{gzip}, '--decompress', $lc_file); + system(@system) == 0 or die "Could not uncompress $lc_file"; + $lc_file =~ s/\.gz$//; + } else { + return; + } } - $self->MD5_check_file($local_file,$basename); + $self->MD5_check_file($lc_file); } #-> sub CPAN::Distribution::MD5_check_file ; sub MD5_check_file { - my($self,$lfile,$basename) = @_; - my($cksum); - my $fh = new IO::File; - local($/)=undef; - if (open $fh, $lfile){ + my($self,$chk_file) = @_; + my($cksum,$file,$basename); + $file = $self->{localfile}; + $basename = File::Basename::basename($file); + my $fh = FileHandle->new; + if (open $fh, $chk_file){ + local($/); my $eval = <$fh>; close $fh; my($comp) = Safe->new(); $cksum = $comp->reval($eval); - Carp::confess($@) if $@; - if ($cksum->{$basename}->{md5}) { - $self->debug("Found checksum for $basename: $cksum->{$basename}->{md5}\n") if $CPAN::DEBUG; - my $file = $self->{localfile}; - my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $self->{localfile}|"; - if ( - open($fh, $file) && $self->eq_MD5($fh,$cksum->{$basename}->{md5}) - or - open($fh, $pipe) && $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'}) - ){ - print "Checksum for $file ok\n"; - return $self->{MD5_STATUS}="OK"; - } else { - die join( - "", - "\nChecksum mismatch for distribution file. Please investigate.\n\n", - $self->as_string, - $CPAN::META->instance('CPAN::Author',$self->{CPAN_USERID})->as_string, - "Please contact the author or your CPAN site admin" - ); - } - close $fh if fileno($fh); + if ($@) { + rename $chk_file, "$chk_file.bad"; + Carp::confess($@) if $@; + } + } else { + Carp::carp "Could not open $chk_file for reading"; + } + if ($cksum->{$basename}->{md5}) { + $self->debug("Found checksum for $basename:" . + "$cksum->{$basename}->{md5}\n") if $CPAN::DEBUG; + my $pipe = "$CPAN::Config->{gzip} --decompress ". + "--stdout $file|"; + if ( + open($fh, $file) && + binmode $fh && + $self->eq_MD5($fh,$cksum->{$basename}->{md5}) + or + open($fh, $pipe) && + binmode $fh && + $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'}) + ){ + $CPAN::Frontend->myprint("Checksum for $file ok\n"); + return $self->{MD5_STATUS} = "OK"; } else { - print "No md5 checksum for $basename in local $lfile\n"; + $CPAN::Frontend->myprint(qq{Checksum mismatch for }. + qq{distribution file. }. + qq{Please investigate.\n\n}. + $self->as_string, + $CPAN::META->instance( + 'CPAN::Author', + $self->{CPAN_USERID} + )->as_string); + my $wrap = qq{I\'d recommend removing $file. It seems to +be a bogus file. Maybe you have configured your \`urllist\' with a +bad URL. Please check this array with \`o conf urllist\', and +retry.}; + $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap)); + $CPAN::Frontend->myprint("\n\n"); + sleep 3; return; } + close $fh if fileno($fh); } else { - Carp::carp "Could not open $lfile for reading"; + $self->{MD5_STATUS} ||= ""; + if ($self->{MD5_STATUS} eq "NIL") { + $CPAN::Frontend->myprint(qq{ +No md5 checksum for $basename in local $chk_file. +Removing $chk_file +}); + unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!"); + sleep 1; + } + $self->{MD5_STATUS} = "NIL"; + return; } } #-> sub CPAN::Distribution::eq_MD5 ; sub eq_MD5 { my($self,$fh,$expectMD5) = @_; - my $md5 = new MD5; + my $md5 = MD5->new; $md5->addfile($fh); my $hexdigest = $md5->hexdigest; $hexdigest eq $expectMD5; @@ -1548,24 +2864,54 @@ sub force { delete $self->{'writemakefile'}; } +#-> sub CPAN::Distribution::perl ; +sub perl { + my($self) = @_; + my($perl) = MM->file_name_is_absolute($^X) ? $^X : ""; + my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my $pwd = CPAN->$getcwd(); + my $candidate = MM->catfile($pwd,$^X); + $perl ||= $candidate if MM->maybe_command($candidate); + unless ($perl) { + my ($component,$perl_name); + DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") { + PATH_COMPONENT: foreach $component (MM->path(), + $Config::Config{'binexp'}) { + next unless defined($component) && $component; + my($abs) = MM->catfile($component,$perl_name); + if (MM->maybe_command($abs)) { + $perl = $abs; + last DIST_PERLNAME; + } + } + } + } + $perl; +} + #-> sub CPAN::Distribution::make ; sub make { my($self) = @_; - $self->debug($self->id) if $CPAN::DEBUG; - print "Running make\n"; + $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id); $self->get; - if ($CPAN::META->hasMD5) { - $self->verifyMD5; + EXCUSE: { + my @e; + $self->{archived} eq "NO" and push @e, + "Is neither a tar nor a zip archive."; + + $self->{unwrapped} eq "NO" and push @e, + "had problems unarchiving. Please build manually"; + + exists $self->{writemakefile} && + $self->{writemakefile} eq "NO" and push @e, + "Had some problem writing Makefile"; + + defined $self->{'make'} and push @e, + "Has already been processed within this session"; + + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } - EXCUSE: { - my @e; - $self->{archived} eq "NO" and push @e, "Is neither a tar nor a zip archive."; - $self->{unwrapped} eq "NO" and push @e, "had problems unarchiving. Please build manually"; - exists $self->{writemakefile} && $self->{writemakefile} eq "NO" and push @e, "Had some problem writing Makefile"; - defined $self->{'make'} and push @e, "Has already been processed within this session"; - print join "", map {" $_\n"} @e and return if @e; - } - print "\n CPAN: Going to build ".$self->id."\n\n"; + $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n"); my $builddir = $self->dir; chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; @@ -1574,53 +2920,60 @@ sub make { if ($self->{'configure'}) { $system = $self->{'configure'}; } else { - my($perl) = $^X =~ /^\.\// ? "$CPAN::Cwd/$^X" : $^X; # XXX subclassing folks, forgive me! - $system = "$perl Makefile.PL $CPAN::Config->{makepl_arg}"; - } - $SIG{ALRM} = sub { die "inactivity_timeout reached\n" }; - my($ret,$pid); - $@ = ""; - if ($CPAN::Config->{inactivity_timeout}) { - eval { - alarm $CPAN::Config->{inactivity_timeout}; - #$SIG{CHLD} = \&REAPER; - if (defined($pid=fork)) { - if ($pid) { #parent - wait; - } else { #child - exec $system; + my($perl) = $self->perl or die "Couldn\'t find executable perl\n"; + my $switch = ""; +# This needs a handler that can be turned on or off: +# $switch = "-MExtUtils::MakeMaker ". +# "-Mops=:default,:filesys_read,:filesys_open,require,chdir" +# if $] > 5.00310; + $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}"; + } + { + local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" }; + my($ret,$pid); + $@ = ""; + if ($CPAN::Config->{inactivity_timeout}) { + eval { + alarm $CPAN::Config->{inactivity_timeout}; + local $SIG{CHLD} = sub { wait }; + if (defined($pid = fork)) { + if ($pid) { #parent + wait; + } else { #child + exec $system; + } + } else { + $CPAN::Frontend->myprint("Cannot fork: $!"); + return; } - } else { - print "Cannot fork: $!"; + }; + alarm 0; + if ($@){ + kill 9, $pid; + waitpid $pid, 0; + $CPAN::Frontend->myprint($@); + $self->{writemakefile} = "NO - $@"; + $@ = ""; return; } + } else { $ret = system($system); - }; - alarm 0; - } else { - $ret = system($system); - } - if ($@){ - kill 9, $pid; - waitpid $pid, 0; - print $@; - $self->{writemakefile} = "NO - $@"; - $@ = ""; - return; - } elsif ($ret != 0) { - $self->{writemakefile} = "NO"; - return; + if ($ret != 0) { + $self->{writemakefile} = "NO"; + return; + } + } } $self->{writemakefile} = "YES"; return if $CPAN::Signal; $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg}; - if (system($system)==0) { - print " $system -- OK\n"; + if (system($system) == 0) { + $CPAN::Frontend->myprint(" $system -- OK\n"); $self->{'make'} = "YES"; } else { $self->{writemakefile} = "YES"; $self->{'make'} = "NO"; - print " $system -- NOT OK\n"; + $CPAN::Frontend->myprint(" $system -- NOT OK\n"); } } @@ -1629,40 +2982,48 @@ sub test { my($self) = @_; $self->make; return if $CPAN::Signal; - print "Running make test\n"; - EXCUSE: { - my @e; - exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't test"; - exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status"; - exists $self->{'build_dir'} or push @e, "Has no own directory"; - print join "", map {" $_\n"} @e and return if @e; - } - chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}"); - $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + $CPAN::Frontend->myprint("Running make test\n"); + EXCUSE: { + my @e; + exists $self->{'make'} or push @e, + "Make had some problems, maybe interrupted? Won't test"; + + exists $self->{'make'} and + $self->{'make'} eq 'NO' and + push @e, "Oops, make had returned bad status"; + + exists $self->{'build_dir'} or push @e, "Has no own directory"; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + } + chdir $self->{'build_dir'} or + Carp::croak("Couldn't chdir to $self->{'build_dir'}"); + $self->debug("Changed directory to $self->{'build_dir'}") + if $CPAN::DEBUG; my $system = join " ", $CPAN::Config->{'make'}, "test"; - if (system($system)==0) { - print " $system -- OK\n"; + if (system($system) == 0) { + $CPAN::Frontend->myprint(" $system -- OK\n"); $self->{'make_test'} = "YES"; } else { $self->{'make_test'} = "NO"; - print " $system -- NOT OK\n"; + $CPAN::Frontend->myprint(" $system -- NOT OK\n"); } } #-> sub CPAN::Distribution::clean ; sub clean { my($self) = @_; - print "Running make clean\n"; - EXCUSE: { - my @e; - exists $self->{'build_dir'} or push @e, "Has no own directory"; - print join "", map {" $_\n"} @e and return if @e; - } - chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}"); + $CPAN::Frontend->myprint("Running make clean\n"); + EXCUSE: { + my @e; + exists $self->{'build_dir'} or push @e, "Has no own directory"; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + } + chdir $self->{'build_dir'} or + Carp::croak("Couldn't chdir to $self->{'build_dir'}"); $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; my $system = join " ", $CPAN::Config->{'make'}, "clean"; - if (system($system)==0) { - print " $system -- OK\n"; + if (system($system) == 0) { + $CPAN::Frontend->myprint(" $system -- OK\n"); $self->force; } else { # Hmmm, what to do if make clean failed? @@ -1674,56 +3035,52 @@ sub install { my($self) = @_; $self->test; return if $CPAN::Signal; - print "Running make install\n"; - EXCUSE: { - my @e; - exists $self->{'build_dir'} or push @e, "Has no own directory"; - exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't install"; - exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status"; - exists $self->{'install'} and push @e, $self->{'install'} eq "YES" ? "Already done" : "Already tried without success"; - print join "", map {" $_\n"} @e and return if @e; - } - chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}"); - $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; - my $system = join " ", $CPAN::Config->{'make'}, "install", $CPAN::Config->{make_install_arg}; - my($pipe) = IO::File->new("$system 2>&1 |"); + $CPAN::Frontend->myprint("Running make install\n"); + EXCUSE: { + my @e; + exists $self->{'build_dir'} or push @e, "Has no own directory"; + + exists $self->{'make'} or push @e, + "Make had some problems, maybe interrupted? Won't install"; + + exists $self->{'make'} and + $self->{'make'} eq 'NO' and + push @e, "Oops, make had returned bad status"; + + push @e, "make test had returned bad status, ". + "won't install without force" + if exists $self->{'make_test'} and + $self->{'make_test'} eq 'NO' and + ! $self->{'force_update'}; + + exists $self->{'install'} and push @e, + $self->{'install'} eq "YES" ? + "Already done" : "Already tried without success"; + + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + } + chdir $self->{'build_dir'} or + Carp::croak("Couldn't chdir to $self->{'build_dir'}"); + $self->debug("Changed directory to $self->{'build_dir'}") + if $CPAN::DEBUG; + my $system = join(" ", $CPAN::Config->{'make'}, + "install", $CPAN::Config->{make_install_arg}); + my($pipe) = FileHandle->new("$system 2>&1 |"); my($makeout) = ""; - - # #If I were to try this, I'd do something like: - # # - # # $SIG{ALRM} = sub { die "alarm\n" }; - # # - # # open(PROC,"make somesuch|"); - # # eval { - # # alarm 30; - # # while() { - # # alarm 30; - # # } - # # } - # # close(PROC); - # # alarm 0; - # # - # #I'm really not sure how reliable this would is, though. - # # - # #-- - # #Kenneth Albanowski (kjahds@kjahds.com, CIS: 70705,126) - # # - # # - # # - # # - while (<$pipe>){ - print; + while (<$pipe>){ + $CPAN::Frontend->myprint($_); $makeout .= $_; } $pipe->close; if ($?==0) { - print " $system -- OK\n"; + $CPAN::Frontend->myprint(" $system -- OK\n"); $self->{'install'} = "YES"; } else { $self->{'install'} = "NO"; - print " $system -- NOT OK\n"; + $CPAN::Frontend->myprint(" $system -- NOT OK\n"); if ($makeout =~ /permission/s && $> > 0) { - print " You may have to su to root to install the package\n"; + $CPAN::Frontend->myprint(qq{ You may have to su }. + qq{to root to install the package\n}); } } } @@ -1734,12 +3091,12 @@ sub dir { } package CPAN::Bundle; -@CPAN::Bundle::ISA = qw(CPAN::Debug CPAN::InfoObj CPAN::Module); #-> sub CPAN::Bundle::as_string ; sub as_string { my($self) = @_; $self->contains; + $self->{INST_VERSION} = $self->inst_version; return $self->SUPER::as_string; } @@ -1747,29 +3104,37 @@ sub as_string { sub contains { my($self) = @_; my($parsefile) = $self->inst_file; + my($id) = $self->id; + $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG; unless ($parsefile) { # Try to get at it in the cpan directory $self->debug("no parsefile") if $CPAN::DEBUG; - my $dist = $CPAN::META->instance('CPAN::Distribution',$self->{'CPAN_FILE'}); - $self->debug($dist->as_string) if $CPAN::DEBUG; + Carp::confess "I don't know a $id" unless $self->{CPAN_FILE}; + my $dist = $CPAN::META->instance('CPAN::Distribution', + $self->{CPAN_FILE}); $dist->get; $self->debug($dist->as_string) if $CPAN::DEBUG; - my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle"); - File::Path::mkpath($todir); - my($me,$from,$to); - ($me = $self->id) =~ s/.*://; - $from = $CPAN::META->catfile($dist->{'build_dir'},"$me.pm"); - $to = $CPAN::META->catfile($todir,"$me.pm"); - File::Copy::copy($from, $to) or Carp::confess("Couldn't copy $from to $to: $!"); + my($todir) = $CPAN::Config->{'cpan_home'}; + my(@me,$from,$to,$me); + @me = split /::/, $self->id; + $me[-1] .= ".pm"; + $me = MM->catfile(@me); + $from = $self->find_bundle_file($dist->{'build_dir'},$me); + $to = MM->catfile($todir,$me); + File::Path::mkpath(File::Basename::dirname($to)); + File::Copy::copy($from, $to) + or Carp::confess("Couldn't copy $from to $to: $!"); $parsefile = $to; } my @result; - my $fh = new IO::File; + my $fh = FileHandle->new; local $/ = "\n"; open($fh,$parsefile) or die "Could not open '$parsefile': $!"; my $inpod = 0; + $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; while (<$fh>) { - $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : /^=head1\s+CONTENTS/ ? 1 : $inpod; + $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : + /^=head1\s+CONTENTS/ ? 1 : $inpod; next unless $inpod; next if /^=/; next if /^\s+$/; @@ -1778,55 +3143,116 @@ sub contains { } close $fh; delete $self->{STATUS}; - $self->{CONTAINS} = [@result]; + $self->{CONTAINS} = join ", ", @result; + $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; @result; } +#-> sub CPAN::Bundle::find_bundle_file +sub find_bundle_file { + my($self,$where,$what) = @_; + $self->debug("where[$where]what[$what]") if $CPAN::DEBUG; + my $bu = MM->catfile($where,$what); + return $bu if -f $bu; + my $manifest = MM->catfile($where,"MANIFEST"); + unless (-f $manifest) { + require ExtUtils::Manifest; + my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my $cwd = CPAN->$getcwd(); + chdir $where; + ExtUtils::Manifest::mkmanifest(); + chdir $cwd; + } + my $fh = FileHandle->new($manifest) + or Carp::croak("Couldn't open $manifest: $!"); + local($/) = "\n"; + while (<$fh>) { + next if /^\s*\#/; + my($file) = /(\S+)/; + if ($file =~ m|\Q$what\E$|) { + $bu = $file; + return MM->catfile($where,$bu); + } elsif ($what =~ s|Bundle/||) { # retry if she managed to + # have no Bundle directory + if ($file =~ m|\Q$what\E$|) { + $bu = $file; + return MM->catfile($where,$bu); + } + } + } + Carp::croak("Couldn't find a Bundle file in $where"); +} + #-> sub CPAN::Bundle::inst_file ; sub inst_file { my($self) = @_; my($me,$inst_file); ($me = $self->id) =~ s/.*://; - $inst_file = $CPAN::META->catfile($CPAN::Config->{'cpan_home'},"Bundle", "$me.pm"); - return $self->{'INST_FILE'} = $inst_file if -f $inst_file; - $inst_file = $self->SUPER::inst_file; +## my(@me,$inst_file); +## @me = split /::/, $self->id; +## $me[-1] .= ".pm"; + $inst_file = MM->catfile($CPAN::Config->{'cpan_home'}, + "Bundle", "$me.pm"); +## "Bundle", @me); return $self->{'INST_FILE'} = $inst_file if -f $inst_file; - return $self->{'INST_FILE'}; # even if undefined? +# $inst_file = + $self->SUPER::inst_file; +# return $self->{'INST_FILE'} = $inst_file if -f $inst_file; +# return $self->{'INST_FILE'}; # even if undefined? } #-> sub CPAN::Bundle::rematein ; sub rematein { my($self,$meth) = @_; $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG; + my($id) = $self->id; + Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n" + unless $self->inst_file || $self->{CPAN_FILE}; my($s); for $s ($self->contains) { - $CPAN::META->instance('CPAN::Module',$s)->$meth(); + my($type) = $s =~ m|/| ? 'CPAN::Distribution' : + $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module'; + if ($type eq 'CPAN::Distribution') { + $CPAN::Frontend->mywarn(qq{ +The Bundle }.$self->id.qq{ contains +explicitly a file $s. +}); + sleep 3; + } + $CPAN::META->instance($type,$s)->$meth(); } } +#sub CPAN::Bundle::xs_file +sub xs_file { + # If a bundle contains another that contains an xs_file we have + # here, we just don't bother I suppose + return 0; +} + #-> sub CPAN::Bundle::force ; sub force { shift->rematein('force',@_); } +#-> sub CPAN::Bundle::get ; +sub get { shift->rematein('get',@_); } +#-> sub CPAN::Bundle::make ; +sub make { shift->rematein('make',@_); } +#-> sub CPAN::Bundle::test ; +sub test { shift->rematein('test',@_); } #-> sub CPAN::Bundle::install ; sub install { shift->rematein('install',@_); } #-> sub CPAN::Bundle::clean ; sub clean { shift->rematein('clean',@_); } -#-> sub CPAN::Bundle::test ; -sub test { shift->rematein('test',@_); } -#-> sub CPAN::Bundle::make ; -sub make { shift->rematein('make',@_); } -# XXX not yet implemented! #-> sub CPAN::Bundle::readme ; sub readme { my($self) = @_; - my($file) = $self->cpan_file or print("No File found for bundle ", $self->id, "\n"), return; + my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{ +No File found for bundle } . $self->id . qq{\n}), return; $self->debug("self[$self] file[$file]") if $CPAN::DEBUG; $CPAN::META->instance('CPAN::Distribution',$file)->readme; -# CPAN::FTP->localize("authors/id/$file",$index_wanted); # XXX } package CPAN::Module; -@CPAN::Module::ISA = qw(CPAN::Debug CPAN::InfoObj); #-> sub CPAN::Module::as_glimpse ; sub as_glimpse { @@ -1834,7 +3260,8 @@ sub as_glimpse { my(@m); my $class = ref($self); $class =~ s/^CPAN:://; - push @m, sprintf "%-15s %-15s (%s)\n", $class, $self->{ID}, $self->cpan_file; + push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID}, + $self->cpan_file); join "", @m; } @@ -1848,25 +3275,34 @@ sub as_string { local($^W) = 0; push @m, $class, " id = $self->{ID}\n"; my $sprintf = " %-12s %s\n"; - push @m, sprintf $sprintf, 'DESCRIPTION', $self->{description} if $self->{description}; + push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description}) + if $self->{description}; my $sprintf2 = " %-12s %s (%s)\n"; my($userid); if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){ - push @m, sprintf( - $sprintf2, - 'CPAN_USERID', - $userid, - $CPAN::META->instance(CPAN::Author,$userid)->fullname - ) - } - push @m, sprintf $sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION} if $self->{CPAN_VERSION}; - push @m, sprintf $sprintf, 'CPAN_FILE', $self->{CPAN_FILE} if $self->{CPAN_FILE}; + my $author; + if ($author = CPAN::Shell->expand('Author',$userid)) { + push @m, sprintf( + $sprintf2, + 'CPAN_USERID', + $userid, + $author->fullname + ); + } + } + push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION}) + if $self->{CPAN_VERSION}; + push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE}) + if $self->{CPAN_FILE}; my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n"; my(%statd,%stats,%statl,%stati); - @statd{qw,? i c a b R M S,} = qw,unknown idea pre-alpha alpha beta released mature standard,; - @stats{qw,? m d u n,} = qw,unknown mailing-list developer comp.lang.perl.* none,; + @statd{qw,? i c a b R M S,} = qw,unknown idea + pre-alpha alpha beta released mature standard,; + @stats{qw,? m d u n,} = qw,unknown mailing-list + developer comp.lang.perl.* none,; @statl{qw,? p c + o,} = qw,unknown perl C C++ other,; - @stati{qw,? f r O,} = qw,unknown functions references+ties object-oriented,; + @stati{qw,? f r O,} = qw,unknown functions + references+ties object-oriented,; $statd{' '} = 'unknown'; $stats{' '} = 'unknown'; $statl{' '} = 'unknown'; @@ -1885,12 +3321,14 @@ sub as_string { ) if $self->{statd}; my $local_file = $self->inst_file; if ($local_file && ! exists $self->{MANPAGE}) { - my $fh = IO::File->new($local_file) or Carp::croak("Couldn't open $local_file: $!"); + my $fh = FileHandle->new($local_file) + or Carp::croak("Couldn't open $local_file: $!"); my $inpod = 0; my(@result); local $/ = "\n"; while (<$fh>) { - $inpod = /^=(?!head1\s+NAME)/ ? 0 : /^=head1\s+NAME/ ? 1 : $inpod; + $inpod = /^=(?!head1\s+NAME)/ ? 0 : + /^=head1\s+NAME/ ? 1 : $inpod; next unless $inpod; next if /^=/; next if /^\s+$/; @@ -1900,9 +3338,15 @@ sub as_string { close $fh; $self->{MANPAGE} = join " ", @result; } - push @m, sprintf $sprintf, 'MANPAGE', $self->{MANPAGE} if $self->{MANPAGE}; - push @m, sprintf $sprintf, 'INST_FILE', $local_file || "(not installed)"; - push @m, sprintf $sprintf, 'INST_VERSION', $self->inst_version if $local_file; + my($item); + for $item (qw/MANPAGE CONTAINS/) { + push @m, sprintf($sprintf, $item, $self->{$item}) + if exists $self->{$item}; + } + push @m, sprintf($sprintf, 'INST_FILE', + $local_file || "(not installed)"); + push @m, sprintf($sprintf, 'INST_VERSION', + $self->inst_version) if $local_file; join "", @m, "\n"; } @@ -1913,10 +3357,17 @@ sub cpan_file { unless (defined $self->{'CPAN_FILE'}) { CPAN::Index->reload; } - if (defined $self->{'CPAN_FILE'}){ + if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){ return $self->{'CPAN_FILE'}; - } elsif (defined $self->{'userid'}) { - return "Contact Author ".$self->{'userid'}."=".$CPAN::META->instance(CPAN::Author,$self->{'userid'})->fullname + } elsif (exists $self->{'userid'} && defined $self->{'userid'}) { + my $fullname = $CPAN::META->instance(CPAN::Author, + $self->{'userid'})->fullname; + unless (defined $fullname) { + $CPAN::Frontend->mywarn(qq{Full name of author }. + qq{$self->{userid} not known}); + return "Contact Author $self->{userid}"; + } + return "Contact Author $self->{userid} ($fullname)" } else { return "N/A"; } @@ -1925,7 +3376,20 @@ sub cpan_file { *name = \&cpan_file; #-> sub CPAN::Module::cpan_version ; -sub cpan_version { shift->{'CPAN_VERSION'} } +sub cpan_version { + my $self = shift; + $self->{'CPAN_VERSION'} = 'undef' + unless defined $self->{'CPAN_VERSION'}; # I believe this is + # always a bug in the + # index and should be + # reported as such, + # but usually I find + # out such an error + # and do not want to + # provoke too many + # bugreports + $self->{'CPAN_VERSION'}; +} #-> sub CPAN::Module::force ; sub force { @@ -1947,423 +3411,93 @@ sub rematein { delete $self->{'force_update'}; } -#-> sub CPAN::Module::readme ; -sub readme { shift->rematein('readme') } -#-> sub CPAN::Module::make ; -sub make { shift->rematein('make') } -#-> sub CPAN::Module::clean ; -sub clean { shift->rematein('clean') } -#-> sub CPAN::Module::test ; -sub test { shift->rematein('test') } -#-> sub CPAN::Module::install ; -sub install { - my($self) = @_; - my($doit) = 0; - my($latest) = $self->cpan_version; - $latest ||= 0; - my($inst_file) = $self->inst_file; - my($have) = 0; - if (defined $inst_file) { - $have = $self->inst_version; - } - if ($inst_file && $have >= $latest && not exists $self->{'force_update'}) { - print $self->id, " is up to date.\n"; - } else { - $doit = 1; - } - $self->rematein('install') if $doit; -} - -#-> sub CPAN::Module::inst_file ; -sub inst_file { - my($self) = @_; - my($dir,@packpath); - @packpath = split /::/, $self->{ID}; - $packpath[-1] .= ".pm"; - foreach $dir (@INC) { - my $pmfile = CPAN->catfile($dir,@packpath); - if (-f $pmfile){ - return $pmfile; - } - } -} - -#-> sub CPAN::Module::xs_file ; -sub xs_file { - my($self) = @_; - my($dir,@packpath); - @packpath = split /::/, $self->{ID}; - push @packpath, $packpath[-1]; - $packpath[-1] .= "." . $Config::Config{'dlext'}; - foreach $dir (@INC) { - my $xsfile = CPAN->catfile($dir,'auto',@packpath); - if (-f $xsfile){ - return $xsfile; - } - } -} - -#-> sub CPAN::Module::inst_version ; -sub inst_version { - my($self) = @_; - my $parsefile = $self->inst_file or return 0; - my $have = MY->parse_version($parsefile); - $have ||= 0; - $have =~ s/\s+//g; - $have ||= 0; - $have; -} - -package CPAN::CacheMgr; -use vars qw($Du); -@CPAN::CacheMgr::ISA = qw(CPAN::Debug CPAN::InfoObj); -use File::Find; - -#-> sub CPAN::CacheMgr::as_string ; -sub as_string { - eval { require Data::Dumper }; - if ($@) { - return shift->SUPER::as_string; - } else { - return Data::Dumper::Dumper(shift); - } -} - -#-> sub CPAN::CacheMgr::cachesize ; -sub cachesize { - shift->{DU}; -} - -# sub check { -# my($self,@dirs) = @_; -# return unless -d $self->{ID}; -# my $dir; -# @dirs = $self->dirs unless @dirs; -# for $dir (@dirs) { -# $self->disk_usage($dir); -# } -# } - -#-> sub CPAN::CacheMgr::clean_cache ; -sub clean_cache { - my $self = shift; - my $dir; - while ($self->{DU} > $self->{'MAX'} and $dir = shift @{$self->{FIFO}}) { - $self->force_clean_cache($dir); - } - $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG; -} - -#-> sub CPAN::CacheMgr::dir ; -sub dir { - shift->{ID}; -} - -#-> sub CPAN::CacheMgr::entries ; -sub entries { - my($self,$dir) = @_; - $dir ||= $self->{ID}; - my($cwd) = Cwd::cwd(); - chdir $dir or Carp::croak("Can't chdir to $dir: $!"); - my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!"); - my(@entries); - for ($dh->read) { - next if $_ eq "." || $_ eq ".."; - if (-f $_) { - push @entries, $CPAN::META->catfile($dir,$_); - } elsif (-d _) { - push @entries, $CPAN::META->catdir($dir,$_); - } else { - print STDERR "Warning: weird direntry in $dir: $_\n"; - } - } - chdir $cwd or Carp::croak("Can't chdir to $cwd: $!"); - sort {-M $b <=> -M $a} @entries; -} - -#-> sub CPAN::CacheMgr::disk_usage ; -sub disk_usage { - my($self,$dir) = @_; - if (! defined $dir or $dir eq "") { - $self->debug("Cannot determine disk usage for some reason") if $CPAN::DEBUG; - return; - } - return if defined $self->{SIZE}{$dir}; - local($Du) = 0; - find( - sub { - return if -l $_; - $Du += -s; - }, - $dir - ); - $self->{SIZE}{$dir} = $Du/1024/1024; - push @{$self->{FIFO}}, $dir; - $self->debug("measured $dir is $Du") if $CPAN::DEBUG; - $self->{DU} += $Du/1024/1024; - if ($self->{DU} > $self->{'MAX'} ) { - printf "...Hold on a sec... CPAN's cleaning the cache: %.2f MB > %.2f MB\n", - $self->{DU}, $self->{'MAX'}; - $self->clean_cache; - } else { - $self->debug("NOT have to clean the cache: $self->{DU} <= $self->{'MAX'}") if $CPAN::DEBUG; - $self->debug($self->as_string) if $CPAN::DEBUG; - } - $self->{DU}; -} - -#-> sub CPAN::CacheMgr::force_clean_cache ; -sub force_clean_cache { - my($self,$dir) = @_; - $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") if $CPAN::DEBUG; - File::Path::rmtree($dir); - $self->{DU} -= $self->{SIZE}{$dir}; - delete $self->{SIZE}{$dir}; -} - -#-> sub CPAN::CacheMgr::new ; -sub new { - my $class = shift; - my $self = { ID => $CPAN::Config->{'build_dir'}, MAX => $CPAN::Config->{'build_cache'}, DU => 0 }; - File::Path::mkpath($self->{ID}); - my $dh = DirHandle->new($self->{ID}); - bless $self, $class; - $self->debug("dir [$self->{ID}]") if $CPAN::DEBUG; - my $e; - for $e ($self->entries) { - next if $e eq ".." || $e eq "."; - $self->debug("Have to check size $e") if $CPAN::DEBUG; - $self->disk_usage($e); - } - $self; -} - -package CPAN::Debug; - -#-> sub CPAN::Debug::debug ; -sub debug { - my($self,$arg) = @_; - my($caller,$func,$line,@rest) = caller(1); # caller(0) eg Complete, caller(1) eg readline - ($caller) = caller(0); - $caller =~ s/.*:://; -# print "caller[$caller]func[$func]line[$line]rest[@rest]\n"; -# print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]CPAN::DEBUG[$CPAN::DEBUG]\n"; - if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){ - if (ref $arg) { - eval { require Data::Dumper }; - if ($@) { - print $arg->as_string; - } else { - print Data::Dumper::Dumper($arg); - } - } else { - print "Debug($caller:$func,$line,@rest): $arg\n" - } - } -} - -package CPAN::Config; -import ExtUtils::MakeMaker 'neatvalue'; -use vars qw(%can); - -%can = ( - 'commit' => "Commit changes to disk", - 'defaults' => "Reload defaults from disk", -); - -#-> sub CPAN::Config::edit ; -sub edit { - my($class,@args) = @_; - return unless @args; - CPAN->debug("class[$class]args[".join(" | ",@args)."]"); - my($o,$str,$func,$args,$key_exists); - $o = shift @args; - if($can{$o}) { - $class->$o(@args); - return 1; - } else { - if (ref($CPAN::Config->{$o}) eq ARRAY) { - $func = shift @args; - # Let's avoid eval, it's easier to comprehend without. - if ($func eq "push") { - push @{$CPAN::Config->{$o}}, @args; - } elsif ($func eq "pop") { - pop @{$CPAN::Config->{$o}}; - } elsif ($func eq "shift") { - shift @{$CPAN::Config->{$o}}; - } elsif ($func eq "unshift") { - unshift @{$CPAN::Config->{$o}}, @args; - } elsif ($func eq "splice") { - splice @{$CPAN::Config->{$o}}, @args; - } else { - $CPAN::Config->{$o} = [@args]; - } - } else { - $CPAN::Config->{$o} = $args[0]; - print " $o "; - print defined $CPAN::Config->{$o} ? $CPAN::Config->{$o} : "UNDEFINED"; - } - } -} - -#-> sub CPAN::Config::commit ; -sub commit { - my($self, $configpm) = @_; - my $mode; - # mkpath!? - - my($fh) = IO::File->new; - $configpm ||= cfile(); - if (-f $configpm) { - $mode = (stat $configpm)[2]; - if ($mode && ! -w _) { - print "$configpm is not writable\n" and return; - } - #chmod 0644, $configpm; #? - } - - my $msg = <$configpm" or warn "Couldn't open >$configpm: $!"; - print $fh qq[$msg\$CPAN::Config = \{\n]; - foreach (sort keys %$CPAN::Config) { - print $fh " '$_' => ", ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}), ",\n"; - } - - print $fh "};\n1;\n__END__\n"; - close $fh; - - #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); - #chmod $mode, $configpm; - $self->defaults; - print "commit: wrote $configpm\n"; - 1; -} - -*default = \&defaults; -#-> sub CPAN::Config::defaults ; -sub defaults { +#-> sub CPAN::Module::readme ; +sub readme { shift->rematein('readme') } +#-> sub CPAN::Module::look ; +sub look { shift->rematein('look') } +#-> sub CPAN::Module::get ; +sub get { shift->rematein('get',@_); } +#-> sub CPAN::Module::make ; +sub make { shift->rematein('make') } +#-> sub CPAN::Module::test ; +sub test { shift->rematein('test') } +#-> sub CPAN::Module::install ; +sub install { my($self) = @_; - $self->unload; - $self->load; - 1; + my($doit) = 0; + my($latest) = $self->cpan_version; + $latest ||= 0; + my($inst_file) = $self->inst_file; + my($have) = 0; + if (defined $inst_file) { + $have = $self->inst_version; + } + if (1){ # A block for scoping $^W, the if is just for the visual + # appeal + local($^W)=0; + if ($inst_file + && + $have >= $latest + && + not exists $self->{'force_update'} + ) { + $CPAN::Frontend->myprint( $self->id. " is up to date.\n"); + } else { + $doit = 1; + } + } + $self->rematein('install') if $doit; } +#-> sub CPAN::Module::clean ; +sub clean { shift->rematein('clean') } -my $dot_cpan; -#-> sub CPAN::Config::load ; -sub load { +#-> sub CPAN::Module::inst_file ; +sub inst_file { my($self) = @_; - eval {require CPAN::Config;}; # We eval, because of some MakeMaker problems - unshift @INC, $CPAN::META->catdir($ENV{HOME},".cpan") unless $dot_cpan++; - eval {require CPAN::MyConfig;}; # where you can override system wide settings - unless ( $self->load_succeeded ) { - require CPAN::FirstTime; - my($configpm,$fh); - if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) { - $configpm = $INC{"CPAN/Config.pm"}; - } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) { - $configpm = $INC{"CPAN/MyConfig.pm"}; - } else { - my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"}); - my($configpmdir) = MY->catdir($path_to_cpan,"CPAN"); - my($configpmtest) = MY->catfile($configpmdir,"Config.pm"); - if (-d $configpmdir || File::Path::mkpath($configpmdir)) { -#_#_# following code dumped core on me with 5.003_11, a.k. -#_#_# $fh = IO::File->new; -#_#_# if ($fh->open(">$configpmtest")) { -#_#_# $fh->print("1;\n"); -#_#_# $configpm = $configpmtest; -#_#_# } - if (-w $configpmtest or -w $configpmdir) { - $configpm = $configpmtest; - } - } - unless ($configpm) { - $configpmdir = MY->catdir($ENV{HOME},".cpan","CPAN"); - File::Path::mkpath($configpmdir); - $configpmtest = MY->catfile($configpmdir,"MyConfig.pm"); - if (-w $configpmtest or -w $configpmdir) { - $configpm = $configpmtest; - } else { - warn "WARNING: CPAN.pm is unable to create a configuration file.\n"; - } - } - } - warn "Calling CPAN::FirstTime::init($configpm)"; - CPAN::FirstTime::init($configpm); + my($dir,@packpath); + @packpath = split /::/, $self->{ID}; + $packpath[-1] .= ".pm"; + foreach $dir (@INC) { + my $pmfile = MM->catfile($dir,@packpath); + if (-f $pmfile){ + return $pmfile; + } } + return; } -#-> sub CPAN::Config::load_succeeded ; -sub load_succeeded { - my($miss) = 0; - for (qw( - cpan_home keep_source_where build_dir build_cache index_expire - gzip tar unzip make pager makepl_arg make_arg make_install_arg - urllist inhibit_startup_message - )) { - $miss++ unless defined $CPAN::Config->{$_}; # we want them all +#-> sub CPAN::Module::xs_file ; +sub xs_file { + my($self) = @_; + my($dir,@packpath); + @packpath = split /::/, $self->{ID}; + push @packpath, $packpath[-1]; + $packpath[-1] .= "." . $Config::Config{'dlext'}; + foreach $dir (@INC) { + my $xsfile = MM->catfile($dir,'auto',@packpath); + if (-f $xsfile){ + return $xsfile; + } } - return !$miss; -} - -#-> sub CPAN::Config::unload ; -sub unload { - delete $INC{'CPAN/MyConfig.pm'}; - delete $INC{'CPAN/Config.pm'}; -} - -#-> sub CPAN::Config::cfile ; -sub cfile { - $INC{'CPAN/MyConfig.pm'} || $INC{'CPAN/Config.pm'}; + return; } -*h = \&help; -#-> sub CPAN::Config::help ; -sub help { - print < sub CPAN::Module::inst_version ; +sub inst_version { + my($self) = @_; + my $parsefile = $self->inst_file or return; + local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38; + my $have = MM->parse_version($parsefile) || "undef"; + $have =~ s/\s+//g; + $have; } -#-> sub CPAN::Config::complete ; -sub complete { - my($word,$line,$pos) = @_; - $word ||= ""; - my(@words) = split " ", $line; - my(@o_conf) = (sort keys %CPAN::Config::can, sort keys %$CPAN::Config); - return (@o_conf) unless @words>2; - if($words[2] =~ /->(.*)/) { - my $meth = $1; - my(@methods) = qw(shift unshift push pop splice); - return @methods unless $meth; - return sort grep /^\Q$meth\E/, @methods; - } - return sort grep /^\Q$word\E/, @o_conf; -} +package CPAN; 1; +__END__ + =head1 NAME CPAN - query, download and build perl modules from CPAN sites @@ -2440,13 +3574,13 @@ item is displayed. If the search finds one item, we display the result of object-Eas_string, but if we find more than one, we display each as object-Eas_glimpse. E.g. - cpan> a ANDK + cpan> a ANDK Author id = ANDK EMAIL a.koenig@franz.ww.TU-Berlin.DE FULLNAME Andreas König - cpan> a /andk/ + cpan> a /andk/ Author id = ANDK EMAIL a.koenig@franz.ww.TU-Berlin.DE FULLNAME Andreas König @@ -2456,21 +3590,21 @@ each as object-Eas_glimpse. E.g. Author ANDYD (Andy Dougherty) Author MERLYN (Randal L. Schwartz) -=item make, test, install, clean modules or distributions +=item make, test, install, clean modules or distributions -The four commands do indeed exist just as written above. Each of them -takes as many arguments as provided and investigates for each what it -might be. Is it a distribution file (recognized by embedded slashes), -this file is being processed. Is it a module, CPAN determines the +These commands do indeed exist just as written above. Each of them +takes any number of arguments and investigates for each what it might +be. Is it a distribution file (recognized by embedded slashes), this +file is being processed. Is it a module, CPAN determines the distribution file where this module is included and processes that. -Any C and C are run unconditionally. A +Any C, C, and C are run unconditionally. A - Cdistribution_fileE> + install -also is run unconditionally. But for +also is run unconditionally. But for - CmoduleE> + install CPAN checks if an install is actually needed for it and prints I in case the module doesnE<39>t need to be updated. @@ -2491,6 +3625,14 @@ Example: OpenGL-0.4/COPYRIGHT [...] +=item readme, look module or distribution + +These two commands take only one argument, be it a module or a +distribution file. C displays the README of the associated +distribution file. C gets and untars (if not yet done) the +distribution file, changes to the appropriate directory and opens a +subshell process in that directory. + =back =head2 CPAN::Shell @@ -2500,15 +3642,123 @@ the package CPAN::Shell. If you enter the shell command, all your input is split by the Text::ParseWords::shellwords() routine which acts like most shells do. The first word is being interpreted as the method to be called and the rest of the words are treated as arguments -to this method. +to this method. Continuation lines are supported if a line ends with a +literal backslash. + +=head2 autobundle + +C writes a bundle file into the +C<$CPAN::Config-E{cpan_home}/Bundle> directory. The file contains +a list of all modules that are both available from CPAN and currently +installed within @INC. The name of the bundle file is based on the +current date and a counter. + +=head2 recompile + +recompile() is a very special command in that it takes no argument and +runs the make/test/install cycle with brute force over all installed +dynamically loadable extensions (aka XS modules) with 'force' in +effect. Primary purpose of this command is to finish a network +installation. Imagine, you have a common source tree for two different +architectures. You decide to do a completely independent fresh +installation. You start on one architecture with the help of a Bundle +file produced earlier. CPAN installs the whole Bundle for you, but +when you try to repeat the job on the second architecture, CPAN +responds with a C<"Foo up to date"> message for all modules. So you +will be glad to run recompile in the second architecture and +youE<39>re done. + +Another popular use for C is to act as a rescue in case your +perl breaks binary compatibility. If one of the modules that CPAN uses +is in turn depending on binary compatibility (so you cannot run CPAN +commands), then you should try the CPAN::Nox module for recovery. + +=head2 The four C Classes: Author, Bundle, Module, Distribution + +Although it may be considered internal, the class hierarchie does +matter for both users and programmer. CPAN.pm deals with above +mentioned four classes, and all those classes share a set of +methods. It is a classical single polymorphism that is in effect. A +metaclass object registers all objects of all kinds and indexes them +with a string. The strings referencing objects have a separated +namespace (well, not completely separated): + + Namespace Class + + words containing a "/" (slash) Distribution + words starting with Bundle:: Bundle + everything else Module or Author + +Modules know their associated Distribution objects. They always refer +to the most recent official release. Developers may mark their +releases as unstable development versions (by inserting an underbar +into the visible version number), so not always is the default +distribution for a given module the really hottest and newest. If a +module Foo circulates on CPAN in both version 1.23 and 1.23_90, +CPAN.pm offers a convenient way to install version 1.23 by saying + + install Foo + +This would install the complete distribution file (say +BAR/Foo-1.23.tar.gz) with all accompanying material in there. But if +you would like to install version 1.23_90, you need to know where the +distribution file resides on CPAN relative to the authors/id/ +directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz, +so you would have to say + + install BAR/Foo-1.23_90.tar.gz + +The first example will be driven by an object of the class +CPAN::Module, the second by an object of class CPAN::Distribution. =head2 ProgrammerE<39>s interface If you do not enter the shell, the available shell commands are both available as methods (Cinstall(...)>) and as -functions in the calling package (C). The -programmerE<39>s interface has beta status. Do not heavily rely on it, -changes may still be necessary. +functions in the calling package (C). + +There's currently only one class that has a stable interface, +CPAN::Shell. All commands that are available in the CPAN shell are +methods of the class CPAN::Shell. Each of the commands that produce +listings of modules (C, C, C) returns a list of the +IDs of all modules within the list. + +=over 2 + +=item expand($type,@things) + +The IDs of all objects available within a program are strings that can +be expanded to the corresponding real objects with the +Cexpand("Module",@things)> method. Expand returns a +list of CPAN::Module objects according to the C<@things> arguments +given. In scalar context it only returns the first element of the +list. + +=item Programming Examples + +This enables the programmer to do operations that combine +functionalities that are available in the shell. + + # install everything that is outdated on my disk: + perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)' + + # install my favorite programs if necessary: + for $mod (qw(Net::FTP MD5 Data::Dumper)){ + my $obj = CPAN::Shell->expand('Module',$mod); + $obj->install; + } + + # list all modules on my disk that have no VERSION number + for $mod (CPAN::Shell->expand("Module","/./")){ + next unless $mod->inst_file; + # MakeMaker convention for undefined $VERSION: + next unless $mod->inst_version eq "undef"; + print "No VERSION in ", $mod->id, "\n"; + } + +=back + +=head2 Methods in the four =head2 Cache Manager @@ -2560,37 +3810,68 @@ your @INC path. The autobundle() command which is available in the shell interface does that for you by including all currently installed modules in a snapshot bundle file. -There is a meaningless Bundle::Demo available on CPAN. Try to install -it, it usually does no harm, just demonstrates what the Bundle -interface looks like. +=head2 Prerequisites -=head2 autobundle +If you have a local mirror of CPAN and can access all files with +"file:" URLs, then you only need a perl better than perl5.003 to run +this module. Otherwise Net::FTP is strongly recommended. LWP may be +required for non-UNIX systems or if your nearest CPAN site is +associated with an URL that is not C. -C writes a bundle file into the -C<$CPAN::Config-E{cpan_home}/Bundle> directory. The file contains -a list of all modules that are both available from CPAN and currently -installed within @INC. The name of the bundle file is based on the -current date and a counter. +If you have neither Net::FTP nor LWP, there is a fallback mechanism +implemented for an external ftp command or for an external lynx +command. -=head2 recompile +This module presumes that all packages on CPAN -recompile() is a very special command in that it takes no argument and -runs the make/test/install cycle with brute force over all installed -dynamically loadable extensions (aka XS modules) with 'force' in -effect. Primary purpose of this command is to act as a rescue in case -your perl breaks binary compatibility. If one of the modules that CPAN -uses is in turn depending on binary compatibility (so you cannot run -CPAN commands), then you should try the CPAN::Nox module for recovery. +=over 2 -Another popular use for recompile is to finish a network -installation. Imagine, you have a common source tree for two different -architectures. You decide to do a completely independent fresh -installation. You start on one architecture with the help of a Bundle -file produced earlier. CPAN installs the whole Bundle for you, but -when you try to repeat the job on the second architecture, CPAN -responds with a C<"Foo up to date"> message for all modules. So you -will be glad to run recompile in the second architecture and -youE<39>re done. +=item * + +declare their $VERSION variable in an easy to parse manner. This +prerequisite can hardly be relaxed because it consumes by far too much +memory to load all packages into the running program just to determine +the $VERSION variable . Currently all programs that are dealing with +version use something like this + + perl -MExtUtils::MakeMaker -le \ + 'print MM->parse_version($ARGV[0])' filename + +If you are author of a package and wonder if your $VERSION can be +parsed, please try the above method. + +=item * + +come as compressed or gzipped tarfiles or as zip files and contain a +Makefile.PL (well we try to handle a bit more, but without much +enthusiasm). + +=back + +=head2 Debugging + +The debugging of this module is pretty difficult, because we have +interferences of the software producing the indices on CPAN, of the +mirroring process on CPAN, of packaging, of configuration, of +synchronicity, and of bugs within CPAN.pm. + +In interactive mode you can try "o debug" which will list options for +debugging the various parts of the package. The output may not be very +useful for you as it's just a byproduct of my own testing, but if you +have an idea which part of the package may have a bug, it's sometimes +worth to give it a try and send me more specific output. You should +know that "o debug" has built-in completion support. + +=head2 Floppy, Zip, and all that Jazz + +CPAN.pm works nicely without network too. If you maintain machines +that are not networked at all, you should consider working with file: +URLs. Of course, you have to collect your modules somewhere first. So +you might use CPAN.pm to put together all you need on a networked +machine. Then copy the $CPAN::Config->{keep_source_where} (but not +$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind +of a personal CPAN. CPAN.pm on the non-networked machines works nicely +with this floppy. =head1 CONFIGURATION @@ -2652,6 +3933,21 @@ works like the corresponding perl commands. =back +=head2 CD-ROM support + +The C parameter of the configuration table contains a list of +URLs that are to be used for downloading. If the list contains any +C URLs, CPAN always tries to get files from there first. This +feature is disabled for index files. So the recommendation for the +owner of a CD-ROM with CPAN contents is: include your local, possibly +outdated CD-ROM as a C URL at the end of urllist, e.g. + + o conf urllist push file://localhost/CDROM/CPAN + +CPAN.pm will then fetch the index files from one of the CPAN sites +that come at the beginning of urllist. It will later check for each +module if there is a local copy of the most recent version. + =head1 SECURITY There's no strong security layer in CPAN.pm. CPAN.pm helps you to @@ -2667,57 +3963,15 @@ Most functions in package CPAN are exported per default. The reason for this is that the primary use is intended for the cpan shell or for oneliners. -=head1 Debugging - -The debugging of this module is pretty difficult, because we have -interferences of the software producing the indices on CPAN, of the -mirroring process on CPAN, of packaging, of configuration, of -synchronicity, and of bugs within CPAN.pm. - -In interactive mode you can try "o debug" which will list options for -debugging the various parts of the package. The output may not be very -useful for you as it's just a byproduct of my own testing, but if you -have an idea which part of the package may have a bug, it's sometimes -worth to give it a try and send me more specific output. You should -know that "o debug" has built-in completion support. - -=head2 Prerequisites - -If you have a local mirror of CPAN and can access all files with -"file:" URLs, then you only need perl5.003 to run this -module. Otherwise Net::FTP is recommended. LWP may be required for -non-UNIX systems or if your nearest CPAN site is associated with an -URL that is not C. - -If you have neither Net::FTP nor LWP, there is a fallback mechanism -implemented for an external ftp command or for an external lynx -command. - -This module presumes that all packages on CPAN - -=over 2 - -=item * - -declare their $VERSION variable in an easy to parse manner. This -prerequisite can hardly be relaxed because it consumes by far too much -memory to load all packages into the running program just to determine -the $VERSION variable . Currently all programs that are dealing with -version use something like this - - perl -MExtUtils::MakeMaker -le \ - 'print MM->parse_version($ARGV[0])' filename - -If you are author of a package and wonder if your $VERSION can be -parsed, please try the above method. - -=item * +=head1 BUGS -come as compressed or gzipped tarfiles or as zip files and contain a -Makefile.PL (well we try to handle a bit more, but without much -enthusiasm). +we should give coverage for _all_ of the CPAN and not just the +PAUSE part, right? In this discussion CPAN and PAUSE have become +equal -- but they are not. PAUSE is authors/ and modules/. CPAN is +PAUSE plus the clpa/, doc/, misc/, ports/, src/, scripts/. -=back +Future development should be directed towards a better integration of +the other parts. =head1 AUTHOR