From: Andreas Koenig Date: Sun, 2 Feb 1997 15:08:24 +0000 (+1200) Subject: Refresh CPAN to 1.19 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=05454584367e3b30cae587f2fe716ab984cb8c77;p=p5sagit%2Fp5-mst-13.2.git Refresh CPAN to 1.19 --- diff --git a/lib/Bundle/CPAN.pm b/lib/Bundle/CPAN.pm new file mode 100644 index 0000000..2a05dee --- /dev/null +++ b/lib/Bundle/CPAN.pm @@ -0,0 +1,33 @@ +package Bundle::CPAN; + +$VERSION = '0.02'; + +1; + +__END__ + +=head1 NAME + +Bundle::CPAN - A bundle to play with all the other modules on CPAN + +=head1 SYNOPSIS + +C + +=head1 CONTENTS + +CPAN + +CPAN::WAIT + +=head1 DESCRIPTION + +This bundle includes CPAN.pm as the base module and CPAN::WAIT, the +first plugin for CPAN that was developed even before there was an API. + +After installing this bundle, it is recommended to quit the current +session and start again in a new process. + +=head1 AUTHOR + +Andreas König diff --git a/lib/CPAN.pm b/lib/CPAN.pm index f524983..2a5ef29 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1,11 +1,11 @@ package CPAN; use vars qw{$META $Signal $Cwd $End $Suppress_readline}; -$VERSION = '1.15'; +$VERSION = '1.19'; -# $Id: CPAN.pm,v 1.106 1997/01/24 12:26:36 k Exp $ +# $Id: CPAN.pm,v 1.121 1997/02/03 09:08:23 k Exp $ -# my $version = substr q$Revision: 1.106 $, 10; # only used during development +# my $version = substr q$Revision: 1.121 $, 10; # only used during development use Carp (); use Config (); @@ -20,6 +20,7 @@ use File::Path (); use FileHandle (); use Safe (); use Text::ParseWords (); +use Text::Wrap; $Cwd = Cwd::cwd(); @@ -45,10 +46,10 @@ $CPAN::DEBUG ||= 0; $CPAN::Signal ||= 0; 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 +@CPAN::ISA = qw(CPAN::Debug Exporter MM); # the MM class from # MakeMaker, gives us # catfile and catdir @@ -119,20 +120,24 @@ sub checklock { 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}; + print qq{There seems to be running another CPAN process }. + qq{($other). Trying to contact...\n}; 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{You may want to kill it and delete the lockfile, }. + qq{maybe. On UNIX try:\n}. qq{ kill $other\n}. qq{ rm $lockfile\n}; } elsif (-w $lockfile) { my($ans)= ExtUtils::MakeMaker::prompt - (qq{Other job not responding. Shall I overwrite the lockfile? (Y/N)},"y"); + (qq{Other job not responding. Shall I overwrite }. + qq{the lockfile? (Y/N)},"y"); print("Ok, bye\n"), exit 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} @@ -145,7 +150,7 @@ sub checklock { unless ($fh = FileHandle->new(">$lockfile")) { if ($! =~ /Permission/) { my $incc = $INC{'CPAN/Config.pm'}; - my $myincc = MY->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm'); + my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm'); print qq{ Your configuration suggests that CPAN.pm should use a working @@ -177,7 +182,8 @@ or $Signal = 1; }; $SIG{'__DIE__'} = \&cleanup; - print STDERR "Signal handler set.\n" unless $CPAN::Config->{'inhibit_startup_message'}; + print STDERR "Signal handler set.\n" + unless $CPAN::Config->{'inhibit_startup_message'}; } #-> sub CPAN::DESTROY ; @@ -237,6 +243,22 @@ sub hasMD5 { return $self->{'hasMD5'}; } +#-> sub CPAN::hasWAIT ; +sub hasWAIT { + my($self,$arg) = @_; + if (defined $arg) { + $self->{'hasWAIT'} = $arg; + } elsif (not defined $self->{'hasWAIT'}) { + eval {require CPAN::WAIT;}; + if ($@) { + $self->{'hasWAIT'} = 0; + } else { + $self->{'hasWAIT'} = 1; + } + } + return $self->{'hasWAIT'}; +} + #-> sub CPAN::instance ; sub instance { my($mgr,$class,$id) = @_; @@ -273,7 +295,6 @@ sub shell { my $prompt = "cpan> "; local($^W) = 1; - my $term; unless ($Suppress_readline) { require Term::ReadLine; import Term::ReadLine; @@ -288,7 +309,7 @@ sub shell { # 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)"; + "available (get Term::ReadKey and Term::ReadLine::Perl)"; print qq{ cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION) @@ -298,8 +319,19 @@ Readline support $rl_avail while () { if ($Suppress_readline) { print $prompt; - last unless defined (chomp($_ = <>)); + last unless defined ($_ = <>); + chomp; } else { +# if ($CPAN::DEBUG) { +# my($report,$item); +# $report = ""; +# for $item (qw/ReadLine IN OUT MinLine findConsole Features/) { +# $report .= sprintf "%-15s", $item; +# $report .= $term->$item() || ""; +# $report .= "\n"; +# } +# CPAN->debug($report); +# } last unless defined ($_ = $term->readline($prompt)); } s/^\s//; @@ -318,7 +350,7 @@ Readline support $rl_avail last; } elsif (/./) { my(@line); - if ($] < 5.00322) { # parsewords had a bug at until recently + if ($] < 5.00322) { # parsewords had a bug until recently @line = split; } else { eval { @line = Text::ParseWords::shellwords($_) }; @@ -336,729 +368,1221 @@ Readline support $rl_avail } } -package CPAN::Shell; -use vars qw($AUTOLOAD $redef); -@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; -} +package CPAN::CacheMgr; +use vars qw($Du); +@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj); +use File::Find; -#-> sub CPAN::Shell::h ; -sub h { - my($class,$about) = @_; - if (defined $about) { - print "Detailed help not yet implemented\n"; +#-> sub CPAN::CacheMgr::as_string ; +sub as_string { + eval { require Data::Dumper }; + if ($@) { + return shift->SUPER::as_string; } else { - print q{ -command arguments description -a string authors -b or display bundles -d /regex/ info distributions -m or about modules -i none anything of above - -r as reinstall recommendations -u above uninstalled distributions -See manpage for autobundle, recompile, force, look, etc. - -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 -}; + return Data::Dumper::Dumper(shift); } } -#-> sub CPAN::Shell::a ; -sub a { print shift->format_result('Author',@_);} -#-> sub CPAN::Shell::b ; -sub b { - my($self,@which) = @_; - CPAN->debug("which[@which]") if $CPAN::DEBUG; - my($incdir,$bdir,$dh); - foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { - $bdir = $CPAN::META->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 unless $entry =~ s/\.pm$//; - $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry"); - } - } - } - print $self->format_result('Bundle',@which); +#-> sub CPAN::CacheMgr::cachesize ; +sub cachesize { + shift->{DU}; } -#-> sub CPAN::Shell::d ; -sub d { print shift->format_result('Distribution',@_);} -#-> sub CPAN::Shell::m ; -sub m { print shift->format_result('Module',@_);} -#-> sub CPAN::Shell::i ; -sub i { - my($self) = shift; - my(@args) = @_; - my(@type,$type,@m); - @type = qw/Author Bundle Distribution Module/; - @args = '/./' unless @args; - my(@result); - for $type (@type) { - push @result, $self->expand($type,@args); +# 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); } - 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; + $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG; } -#-> sub CPAN::Shell::o ; -sub o { - my($self,$o_type,@o_what) = @_; - $o_type ||= ""; - CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n"); - if ($o_type eq 'conf') { - shift @o_what if @o_what && $o_what[0] eq 'help'; - if (!@o_what) { - my($k,$v); - print "CPAN::Config options:\n"; - for $k (sort keys %CPAN::Config::can) { - $v = $CPAN::Config::can{$k}; - printf " %-18s %s\n", $k, $v; - } - print "\n"; - for $k (sort keys %$CPAN::Config) { - $v = $CPAN::Config->{$k}; - if (ref $v) { - printf " %-18s\n", $k; - print map {"\t$_\n"} @{$v}; - } else { - printf " %-18s %s\n", $k, $v; - } - } - print "\n"; - } elsif (!CPAN::Config->edit(@o_what)) { - print qq[Type 'o conf' to view configuration edit options\n\n]; - } - } elsif ($o_type eq 'debug') { - my(%valid); - @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i; - if (@o_what) { - while (@o_what) { - my($what) = shift @o_what; - if ( exists $CPAN::DEBUG{$what} ) { - $CPAN::DEBUG |= $CPAN::DEBUG{$what}; - } elsif ($what =~ /^\d/) { - $CPAN::DEBUG = $what; - } elsif (lc $what eq 'all') { - my($max) = 0; - for (values %CPAN::DEBUG) { - $max += $_; - } - $CPAN::DEBUG = $max; - } else { - for (keys %CPAN::DEBUG) { - next unless lc($_) eq lc($what); - $CPAN::DEBUG |= $CPAN::DEBUG{$_}; - } - print "unknown argument [$what]\n"; - } - } - } 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"; - } - if ($CPAN::DEBUG) { - print "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; - } +#-> 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 "Debugging turned off completely.\n"; + print STDERR "Warning: weird direntry in $dir: $_\n"; } - } else { - print qq{ -Known options: - conf set or get configuration variables - debug set or get debugging options -}; } + chdir $cwd or Carp::croak("Can't chdir to $cwd: $!"); + sort {-M $b <=> -M $a} @entries; } -#-> sub CPAN::Shell::reload ; -sub reload { - if ($_[1] =~ /cpan/i) { - CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG; - my $fh = FileHandle->new($INC{'CPAN.pm'}); - local($/); - undef $/; - $redef = 0; - local($SIG{__WARN__}) - = sub { - if ( $_[0] =~ /Subroutine \w+ redefined/ ) { - ++$redef; - local($|) = 1; - print "."; - return; - } - warn @_; - }; - eval <$fh>; - warn $@ if $@; - print "\n$redef subroutines redefined\n"; - } elsif ($_[1] =~ /index/) { - CPAN::Index->force_reload; +#-> 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'} ) { + my($toremove) = $self->{FIFO}[0]; + printf "...Hold on a sec... cleaning from cache (%.1f>%.1f MB): $toremove\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::Shell::_binary_extensions ; -sub _binary_extensions { - my($self) = shift @_; - my(@result,$module,%seen,%need,$headerdone); - 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 unless $module->xs_file; - local($|) = 1; - print "."; - push @result, $module; - } -# print join " | ", @result; - print "\n"; - return @result; +#-> 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::Shell::recompile ; -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 - $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"; - my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); - $pack->install; - $CPAN::Signal = 0; # it's tempting to reset Signal, so we can - # stop a package from recompiling, - # e.g. IO-1.12 when we have perl5.003_10 +#-> 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; } -#-> sub CPAN::Shell::_u_r_common ; -sub _u_r_common { - my($self) = shift @_; - my($what) = shift @_; - CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG; - Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what; - 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 $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($inst_file) = $module->inst_file; - my($have); - if ($inst_file){ - if ($what eq "a") { - $have = $module->inst_version; - } elsif ($what eq "r") { - $have = $module->inst_version; - local($^W) = 0; - $version_zeroes++ unless $have; - next if $have >= $latest; - } elsif ($what eq "u") { - next; +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 { - if ($what eq "a") { - next; - } elsif ($what eq "r") { - next; - } elsif ($what eq "u") { - $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; - } elsif ($what eq "r") { - push @result, $module->id; - next if $seen{$file}++; - } elsif ($what eq "u") { - push @result, $module->id; - next if $seen{$file}++; - next if $file =~ /^Contact/; + print "Debug($caller:$func,$line,@rest): $arg\n" } - unless ($headerdone++){ - print "\n"; - printf $sprintf, "Package namespace", "installed", "latest", "in CPAN file"; + } +} + +package CPAN::Config; +import ExtUtils::MakeMaker 'neatvalue'; +use vars qw(%can); + +%can = ( + 'commit' => "Commit changes to disk", + 'defaults' => "Reload defaults from disk", + 'init' => "Interactive setting of all options", +); + +#-> 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 { + print( + " $o ", + ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}), + "\n" + ); + } + } else { + $CPAN::Config->{$o} = $args[0] if defined $args[0]; + print " $o "; + print defined $CPAN::Config->{$o} ? $CPAN::Config->{$o} : "UNDEFINED"; } - $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; - $need{$module->id}++; } - unless (%need) { - if ($what eq "u") { - print "No modules found for @args\n"; - } elsif ($what eq "r") { - print "All modules are up to date for @args\n"; +} + +#-> 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"); } } - 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}; + + my $msg = <new; + open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!"; + print $fh qq[$msg\$CPAN::Config = \{\n]; + foreach (sort keys %$CPAN::Config) { + $fh->print( + " '$_' => ", + ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}), + ",\n" + ); } - @result; + + 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; } -#-> sub CPAN::Shell::r ; -sub r { - shift->_u_r_common("r",@_); +*default = \&defaults; +#-> sub CPAN::Config::defaults ; +sub defaults { + my($self) = @_; + $self->unload; + $self->load; + 1; } -#-> sub CPAN::Shell::u ; -sub u { - shift->_u_r_common("u",@_); +sub init { + my($self) = @_; + undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to + # have the least + # important + # variable + # undefined + $self->load; + 1; } -#-> sub CPAN::Shell::autobundle ; -sub autobundle { - my($self) = shift; - my(@bundle) = $self->_u_r_common("a",@_); - my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle"); - File::Path::mkpath($todir); - unless (-d $todir) { - print "Couldn't mkdir $todir for some reason\n"; - return; +my $dot_cpan; +#-> sub CPAN::Config::load ; +sub load { + 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) = 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.}); + } + } + } + CPAN->debug(qq{Calling CPAN::FirstTime::init("$configpm")}) + if $CPAN::DEBUG; + print qq{ +Configuring CPAN.pm. +$configpm initialized. +}; + CPAN::FirstTime::init($configpm); } - my($y,$m,$d) = (localtime)[5,4,3]; - $y+=1900; - $m++; - my($c) = 0; - my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c; - my($to) = $CPAN::META->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"); - } - my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!"; - $fh->print( - "package Bundle::$me;\n\n", - "\$VERSION = '0.01';\n\n", - "1;\n\n", - "__END__\n\n", - "=head1 NAME\n\n", - "Bundle::$me - Snapshot of installation on ", - $Config::Config{'myhostname'}, - " on ", - scalar(localtime), - "\n\n=head1 SYNOPSIS\n\n", - "perl -MCPAN -e 'install Bundle::$me'\n\n", - "=head1 CONTENTS\n\n", - join("\n", @bundle), - "\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", - ); - $fh->close; - print "\nWrote bundle file - $to\n\n"; } -#-> sub CPAN::Shell::expand ; -sub expand { - shift; - my($type,@args) = @_; - my($arg,@m); - for $arg (@args) { - my $regex; - if ($arg =~ m|^/(.*)/$|) { - $regex = $1; - } - my $class = "CPAN::$type"; - 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 - ( - ( - $] < 5.00303 ### provide sort of compatibility with 5.003 - || - $obj->can('name') - ) - && - $obj->name =~ /$regex/i - ); - } - } else { - my($xarg) = $arg; - if ( $type eq 'Bundle' ) { - $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/; - } - if ($CPAN::META->exists($class,$xarg)) { - $obj = $CPAN::META->instance($class,$xarg); - } elsif ($CPAN::META->exists($class,$arg)) { - $obj = $CPAN::META->instance($class,$arg); - } else { - next; - } - push @m, $obj; +#-> 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 ftp_proxy http_proxy no_proxy + )) { + unless (defined $CPAN::Config->{$_}){ + $miss++; + CPAN->debug("undefined configuration parameter $_") if $CPAN::DEBUG; } } - return @m; + return !$miss; } -#-> sub CPAN::Shell::format_result ; -sub format_result { - my($self) = shift; - 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; - $result ||= "No objects of type $type found for argument @args\n"; - $result; +#-> sub CPAN::Config::unload ; +sub unload { + delete $INC{'CPAN/MyConfig.pm'}; + delete $INC{'CPAN/Config.pm'}; } -#-> sub CPAN::Shell::rematein ; -sub rematein { - shift; - my($meth,@some) = @_; - my $pragma = ""; - if ($meth eq 'force') { - $pragma = $meth; - $meth = shift @some; - } - CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG; - my($s,@s); - foreach $s (@some) { - my $obj; - if (ref $s) { - $obj = $s; - } elsif ($s =~ m|/|) { # looks like a file - $obj = $CPAN::META->instance('CPAN::Distribution',$s); - } 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); - } - 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 - && - ($] < 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); - print "Don't be silly, you can't $meth ", $obj->fullname, " ;-)\n"; - } else { - print "Warning: Cannot $meth $s, don't know what it is\n"; - } - } -} +*h = \&help; +#-> sub CPAN::Config::help ; +sub help { + print < 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::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',@_); } +You may edit key values in the follow fashion: -package CPAN::FTP; -use vars qw($Ua); -@CPAN::FTP::ISA = qw(CPAN::Debug); + o conf build_cache 15 -#-> sub CPAN::FTP::ftp_get ; -sub ftp_get { - my($class,$host,$dir,$file,$target) = @_; - $class->debug( - qq[Going to fetch file [$file] from dir [$dir] - 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; - } - $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"; - return; - } - $ftp->quit; # it's ok if this fails - return 1; -} + o conf build_dir "/foo/bar" -#-> sub CPAN::FTP::localize ; -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; + o conf urllist shift - return $aslocal if -f $aslocal && -r _ && ! $force; + o conf urllist unshift ftp://ftp.foo.bar/ - 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; +EOF + undef; #don't reprint CPAN::Config +} - # Inheritance is not easier to manage than a few if/else branches - if ($CPAN::META->hasLWP) { - require LWP::UserAgent; - unless ($Ua) { - $Ua = new LWP::UserAgent; - 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'}; +#-> sub CPAN::Config::complete ; +sub complete { + my($word,$line,$pos) = @_; + $word ||= ""; + my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config); + return grep /^\Q$word\E/, @o_conf; +} + +package CPAN::Shell; +use vars qw($AUTOLOAD $redef @ISA); +@CPAN::Shell::ISA = qw(CPAN::Debug); +if ($CPAN::META->hasWAIT) { + unshift @ISA, "CPAN::WAIT"; +} +# private function ro re-eval this module (handy during development) +#-> sub CPAN::Shell::AUTOLOAD ; +sub AUTOLOAD { + my($autoload) = $AUTOLOAD; + $autoload =~ s/.*:://; + if ($autoload =~ /^w/) { + if ($CPAN::META->hasWAIT) { + CPAN::WAIT->wh; + return; + } else { + warn qq{ +Commands starting with "w" require CPAN::WAIT to be installed. +Please consider installing CPAN::WAIT to use the fulltext index. +Type "install CPAN::WAIT" and restart CPAN.pm. +} } + } else { + warn "CPAN::Shell doesn't know how to autoload $autoload :-( +Nothing Done. +"; } + CPAN::Shell->h; +} - # 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}[$_]; - $url .= "/" unless substr($url,-1) eq "/"; - $url .= $file; - $self->debug("localizing[$url]") if $CPAN::DEBUG; - if ($url =~ /^file:/) { - my $l; - if ($CPAN::META->hasLWP) { - require URI::URL; - my $u = new URI::URL $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 - ($l = $url) =~ s,^file://[^/]+,,; # discard the host part - $l =~ s/^file://; # assume they meant file://localhost - } - return $l if -f $l && -r _; - } - - if ($CPAN::META->hasLWP) { - print "Fetching $url with LWP\n"; - my $res = $Ua->mirror($url, $aslocal); - if ($res->is_success) { - return $aslocal; - } - } - 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) { - $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; - warn "Net::FTP failed for some reason\n"; - } else { - warn qq{ - Please, install Net::FTP as soon as possible. Just type - install Net::FTP - Thank you. +#-> 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 +b or display bundles +d /regex/ info distributions +m or about modules +i none anything of above -} - } +r as reinstall recommendations +u above uninstalled distributions +See manpage for autobundle, recompile, force, look, etc. - # 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($netrcfile,$fh); - if (-x $CPAN::Config->{'ftp'}) { - my $timestamp = 0; - my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime, - $ctime,$blksize,$blocks) = stat($aslocal); - $timestamp = $mtime if defined $mtime; +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 - my($netrc) = CPAN::FTP::netrc->new; - my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : ""; +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 +}; + } +} - 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) { - warn "No ~/.netrc file found"; - } elsif ($netrc->hasdefault || $netrc->contains($host)) { - CPAN->debug( - sprint( - "hasdef[%d]cont($host)[%d]", - $netrc->hasdefault, - $netrc->contains($host) - ) - ) if $CPAN::DEBUG; - if ($netrc->protected) { - 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.... +#-> sub CPAN::Shell::a ; +sub a { print shift->format_result('Author',@_);} +#-> sub CPAN::Shell::b ; +sub b { + my($self,@which) = @_; + CPAN->debug("which[@which]") if $CPAN::DEBUG; + my($incdir,$bdir,$dh); + foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { + $bdir = $CPAN::META->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 unless $entry =~ s/\.pm$//; + $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry"); + } + } + } + print $self->format_result('Bundle',@which); +} +#-> sub CPAN::Shell::d ; +sub d { print shift->format_result('Distribution',@_);} +#-> sub CPAN::Shell::m ; +sub m { print shift->format_result('Module',@_);} +#-> sub CPAN::Shell::i ; +sub i { + my($self) = shift; + my(@args) = @_; + my(@type,$type,@m); + @type = qw/Author Bundle Distribution Module/; + @args = '/./' unless @args; + my(@result); + for $type (@type) { + push @result, $self->expand($type,@args); + } + 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; } - ); - my $fh = FileHandle->new; - $fh->open("|$CPAN::Config->{'ftp'}$verbose $host") - or die "Couldn't open ftp: $!"; - # pilot is blind now - CPAN->debug("dialog [".(join "|",@dialog)."]") if $CPAN::DEBUG; - foreach (@dialog) { $fh->print("$_\n") } - $fh->close; # Wait for process to complete - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); - if ($mtime > $timestamp) { - print "GOT $aslocal\n"; - return $aslocal; - } else { - print "Hmm... Still failed!\n"; - } - } else { - warn "Your $netrcfile is not correctly protected.\n"; - } - } else { - warn "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. - print qq{Issuing "ftp$verbose -n"\n}; - unshift @dialog, "open $host", "user anonymous $Config::Config{'cf_email'}"; - CPAN->debug("dialog [".(join "|",@dialog)."]") if $CPAN::DEBUG; - $fh = FileHandle->new; - $fh->open("|$CPAN::Config->{'ftp'} -n") or - die "Cannot fork: $!\n"; - foreach (@dialog) { $fh->print("$_\n") } - $fh->close; - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); - if ($mtime > $timestamp) { - print "GOT $aslocal\n"; - return $aslocal; +#-> sub CPAN::Shell::o ; +sub o { + my($self,$o_type,@o_what) = @_; + $o_type ||= ""; + CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n"); + if ($o_type eq 'conf') { + shift @o_what if @o_what && $o_what[0] eq 'help'; + if (!@o_what) { + my($k,$v); + print "CPAN::Config options:\n"; + for $k (sort keys %CPAN::Config::can) { + $v = $CPAN::Config::can{$k}; + printf " %-18s %s\n", $k, $v; + } + print "\n"; + for $k (sort keys %$CPAN::Config) { + $v = $CPAN::Config->{$k}; + if (ref $v) { + printf " %-18s\n", $k; + print map {"\t$_\n"} @{$v}; } else { - print "Bad luck... Still failed!\n"; + printf " %-18s %s\n", $k, $v; } } - sleep 2; + print "\n"; + } elsif (!CPAN::Config->edit(@o_what)) { + print qq[Type 'o conf' to view configuration edit options\n\n]; } - - # what, still not succeeded? - if (-x $CPAN::Config->{'lynx'}) { - my($want_compressed); - print( - qq{ - Trying with lynx to get $url -} - ); - $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"; - } else { - $system = "$CPAN::Config->{'gzip'} $aslocal"; - system($system); + } elsif ($o_type eq 'debug') { + my(%valid); + @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i; + if (@o_what) { + while (@o_what) { + my($what) = shift @o_what; + if ( exists $CPAN::DEBUG{$what} ) { + $CPAN::DEBUG |= $CPAN::DEBUG{$what}; + } elsif ($what =~ /^\d/) { + $CPAN::DEBUG = $what; + } elsif (lc $what eq 'all') { + my($max) = 0; + for (values %CPAN::DEBUG) { + $max += $_; } - return "$aslocal.gz"; + $CPAN::DEBUG = $max; } else { - $system = "$CPAN::Config->{'gzip'} -dt $aslocal"; - if (system($system)==0) { - $system = "$CPAN::Config->{'gzip'} -d $aslocal"; - system($system); - } else { - # should be fine, eh? + for (keys %CPAN::DEBUG) { + next unless lc($_) eq lc($what); + $CPAN::DEBUG |= $CPAN::DEBUG{$_}; } - return $aslocal; + print "unknown argument [$what]\n"; } } + } else { + print "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"; + 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; + } + } else { + print "Debugging turned off completely.\n"; } - warn "Can't access URL $url. - Either get LWP or Net::FTP - or an external lynx or ftp"; + } else { + print qq{ +Known options: + conf set or get configuration variables + debug set or get debugging options +}; } - Carp::croak("Cannot fetch $file from anywhere"); } -package CPAN::FTP::netrc; - -sub new { - my($class) = @_; - my $file = MY->catfile($ENV{HOME},".netrc"); - - my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) - = stat($file); - my $protected = 0; - +#-> sub CPAN::Shell::reload ; +sub reload { + if ($_[1] =~ /cpan/i) { + CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG; + my $fh = FileHandle->new($INC{'CPAN.pm'}); + local($/); + undef $/; + $redef = 0; + local($SIG{__WARN__}) + = sub { + if ( $_[0] =~ /Subroutine \w+ redefined/ ) { + ++$redef; + local($|) = 1; + print "."; + return; + } + warn @_; + }; + eval <$fh>; + warn $@ if $@; + print "\n$redef subroutines redefined\n"; + } elsif ($_[1] =~ /index/) { + CPAN::Index->force_reload; + } +} + +#-> sub CPAN::Shell::_binary_extensions ; +sub _binary_extensions { + my($self) = shift @_; + my(@result,$module,%seen,%need,$headerdone); + 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 unless $module->xs_file; + local($|) = 1; + print "."; + push @result, $module; + } +# print join " | ", @result; + print "\n"; + return @result; +} + +#-> sub CPAN::Shell::recompile ; +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 + $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"; + my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); + $pack->install; + $CPAN::Signal = 0; # it's tempting to reset Signal, so we can + # stop a package from recompiling, + # e.g. IO-1.12 when we have perl5.003_10 + } +} + +#-> sub CPAN::Shell::_u_r_common ; +sub _u_r_common { + my($self) = shift @_; + my($what) = shift @_; + CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG; + Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what; + 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 $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($inst_file) = $module->inst_file; + my($have); + if ($inst_file){ + if ($what eq "a") { + $have = $module->inst_version; + } elsif ($what eq "r") { + $have = $module->inst_version; + local($^W) = 0; + $version_zeroes++ unless $have; + next if $have >= $latest; + } elsif ($what eq "u") { + next; + } + } else { + if ($what eq "a") { + next; + } elsif ($what eq "r") { + next; + } elsif ($what eq "u") { + $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; + } elsif ($what eq "r") { + push @result, $module->id; + next if $seen{$file}++; + } elsif ($what eq "u") { + push @result, $module->id; + next if $seen{$file}++; + next if $file =~ /^Contact/; + } + unless ($headerdone++){ + print "\n"; + printf( + $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; + $need{$module->id}++; + } + unless (%need) { + if ($what eq "u") { + print "No modules found for @args\n"; + } elsif ($what eq "r") { + print "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}; + } + @result; +} + +#-> sub CPAN::Shell::r ; +sub r { + shift->_u_r_common("r",@_); +} + +#-> sub CPAN::Shell::u ; +sub u { + shift->_u_r_common("u",@_); +} + +#-> sub CPAN::Shell::autobundle ; +sub autobundle { + my($self) = shift; + my(@bundle) = $self->_u_r_common("a",@_); + my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle"); + File::Path::mkpath($todir); + unless (-d $todir) { + print "Couldn't mkdir $todir for some reason\n"; + return; + } + my($y,$m,$d) = (localtime)[5,4,3]; + $y+=1900; + $m++; + my($c) = 0; + my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c; + my($to) = $CPAN::META->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"); + } + my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!"; + $fh->print( + "package Bundle::$me;\n\n", + "\$VERSION = '0.01';\n\n", + "1;\n\n", + "__END__\n\n", + "=head1 NAME\n\n", + "Bundle::$me - Snapshot of installation on ", + $Config::Config{'myhostname'}, + " on ", + scalar(localtime), + "\n\n=head1 SYNOPSIS\n\n", + "perl -MCPAN -e 'install Bundle::$me'\n\n", + "=head1 CONTENTS\n\n", + join("\n", @bundle), + "\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", + ); + $fh->close; + print "\nWrote bundle file + $to\n\n"; +} + +#-> sub CPAN::Shell::expand ; +sub expand { + shift; + my($type,@args) = @_; + my($arg,@m); + for $arg (@args) { + my $regex; + if ($arg =~ m|^/(.*)/$|) { + $regex = $1; + } + my $class = "CPAN::$type"; + 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 + ( + ( + $] < 5.00303 ### provide sort of compatibility with 5.003 + || + $obj->can('name') + ) + && + $obj->name =~ /$regex/i + ); + } + } else { + my($xarg) = $arg; + if ( $type eq 'Bundle' ) { + $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/; + } + if ($CPAN::META->exists($class,$xarg)) { + $obj = $CPAN::META->instance($class,$xarg); + } elsif ($CPAN::META->exists($class,$arg)) { + $obj = $CPAN::META->instance($class,$arg); + } else { + next; + } + push @m, $obj; + } + } + return @m; +} + +#-> sub CPAN::Shell::format_result ; +sub format_result { + my($self) = shift; + 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; + $result ||= "No objects of type $type found for argument @args\n"; + $result; +} + +#-> sub CPAN::Shell::rematein ; +sub rematein { + shift; + my($meth,@some) = @_; + my $pragma = ""; + if ($meth eq 'force') { + $pragma = $meth; + $meth = shift @some; + } + CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG; + my($s,@s); + foreach $s (@some) { + my $obj; + if (ref $s) { + $obj = $s; + } elsif ($s =~ m|/|) { # looks like a file + $obj = $CPAN::META->instance('CPAN::Distribution',$s); + } 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); + } + 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 + && + ($] < 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); + print "Don't be silly, you can't $meth ", $obj->fullname, " ;-)\n"; + } else { + print "Warning: Cannot $meth $s, don't know what it is\n"; + } + } +} + +#-> 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::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 { + my($class,$host,$dir,$file,$target) = @_; + $class->debug( + qq[Going to fetch file [$file] from dir [$dir] + 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; + } + $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\n"; + return; + } + $ftp->quit; # it's ok if this fails + return 1; +} + +#-> sub CPAN::FTP::localize ; +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; + + return $aslocal if -f $aslocal && -r _ && ! $force; + + my($aslocal_dir) = File::Basename::dirname($aslocal); + File::Path::mkpath($aslocal_dir); + print STDERR qq{Warning: You are not allowed to write into }. + qq{directory "$aslocal_dir". + I\'ll continue, but if you face any 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) { + require LWP::UserAgent; + unless ($Ua) { + $Ua = new LWP::UserAgent; + 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 + my($i); + for $i (0..$#{$CPAN::Config->{urllist}}) { + my $url = $CPAN::Config->{urllist}[$i]; + $url .= "/" unless substr($url,-1) eq "/"; + $url .= $file; + $self->debug("localizing[$url]") if $CPAN::DEBUG; + if ($url =~ /^file:/) { + my $l; + if ($CPAN::META->hasLWP) { + require URI::URL; + my $u = new URI::URL $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 + ($l = $url) =~ s,^file://[^/]+,,; # discard the host part + $l =~ s/^file://; # assume they meant file://localhost + } + return $l if -f $l && -r _; + # Maybe mirror has compressed it? + if (-f "$l.gz") { + $self->debug("found compressed $l.gz"); + system("$CPAN::Config->{gzip} -dc $l.gz > $aslocal"); + return $aslocal if -f $aslocal; + } + } + + if ($CPAN::META->hasLWP) { + print "Fetching $url with LWP\n"; + my $res = $Ua->mirror($url, $aslocal); + if ($res->is_success) { + return $aslocal; + } + } + 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) { + $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; + warn "Net::FTP failed for some reason\n"; + } else { + warn qq{ + Please, install Net::FTP as soon as possible. Just type + install Net::FTP + Thank you. + +} + } + } + + # 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($funkyftp); + # does ncftp handle http? + for $funkyftp ($CPAN::Config->{'lynx'},$CPAN::Config->{'ncftp'}) { + next unless defined $funkyftp; + next unless -x $funkyftp; + my($want_compressed); + print( + qq{ +Trying with $funkyftp to get + $url +}); + $want_compressed = $aslocal =~ s/\.gz//; + my($source_switch) = ""; + $source_switch = "-source" if $funkyftp =~ /\blynx$/; + my($system) = "$funkyftp $source_switch '$url' > $aslocal"; + my($wstatus); + if (($wstatus = system($system)) == 0) { + if ($want_compressed) { + $system = "$CPAN::Config->{'gzip'} -dt $aslocal"; + if (system($system)==0) { + rename $aslocal, "$aslocal.gz"; + } else { + $system = "$CPAN::Config->{'gzip'} $aslocal"; + system($system); + } + return "$aslocal.gz"; + } else { + $system = "$CPAN::Config->{'gzip'} -dt $aslocal"; + if (system($system)==0) { + $system = "$CPAN::Config->{'gzip'} -d $aslocal"; + system($system); + } else { + # should be fine, eh? + } + return $aslocal; + } + } else { + my $estatus = $wstatus >> 8; + print qq{ +System call "$system" +returned status $estatus (wstat $wstatus) +}; + } + } + + if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { + my($host,$dir,$getfile) = ($1,$2,$3); + my($netrcfile,$fh); + if (-x $CPAN::Config->{'ftp'}) { + 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( + sprint( + "hasdef[%d]cont($host)[%d]", + $netrc->hasdefault, + $netrc->contains($host) + ) + ) if $CPAN::DEBUG; + if ($netrc->protected) { + 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.... + +} + ); + my $fh = FileHandle->new; + $fh->open("|$CPAN::Config->{'ftp'}$verbose $host") + or die "Couldn't open ftp: $!"; + # pilot is blind now + CPAN->debug("dialog [".(join "|",@dialog)."]") + if $CPAN::DEBUG; + foreach (@dialog) { $fh->print("$_\n") } + $fh->close; # Wait for process to complete + my $wstatus = $?; + my $estatus = $wstatus >> 8; + print qq{ +Subprocess "|$CPAN::Config->{'ftp'}$verbose $host" + returned status $estatus (wstat $wstatus) +} if $wstatus; + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); + $mtime ||= 0; + if ($mtime > $timestamp) { + print "GOT $aslocal\n"; + return $aslocal; + } else { + print "Hmm... Still failed!\n"; + } + } else { + warn "Your $netrcfile is not correctly protected.\n"; + } + } else { + warn "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. + print qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n}; + unshift( + @dialog, + "open $host", + "user anonymous $Config::Config{'cf_email'}" + ); + CPAN->debug("dialog [".(join "|",@dialog)."]") if $CPAN::DEBUG; + $fh = FileHandle->new; + $fh->open("|$CPAN::Config->{'ftp'}$verbose -n") or + die "Cannot fork: $!\n"; + foreach (@dialog) { $fh->print("$_\n") } + $fh->close; + my $wstatus = $?; + my $estatus = $wstatus >> 8; + print qq{ +Subprocess "|$CPAN::Config->{'ftp'}$verbose -n" + returned status $estatus (wstat $wstatus) +} if $wstatus; + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); + $mtime ||= 0; + if ($mtime > $timestamp) { + print "GOT $aslocal\n"; + return $aslocal; + } else { + print "Bad luck... Still failed!\n"; + } + } + sleep 2; + } + + print "Can't access URL $url.\n\n"; + my(@mess,$mess); + push @mess, "LWP" unless CPAN->hasLWP; + push @mess, "Net::FTP" unless CPAN->hasFTP; + my($ext); + for $ext (qw/lynx ncftp ftp/) { + $CPAN::Config->{$ext} ||= ""; + push @mess, "an external $ext" unless -x $CPAN::Config->{$ext}; + } + $mess = qq{Either get }. + join(" or ",@mess). + qq{ or check, if the URL found in your configuration file, }. + $CPAN::Config->{urllist}[$i]. + qq{, is valid.}; + print Text::Wrap::wrap("","",$mess), "\n"; + } + print "Cannot fetch $file\n"; + return; +} + +package CPAN::FTP::netrc; + +sub new { + my($class) = @_; + 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; $fh = FileHandle->new or die "Could not create a filehandle"; @@ -1217,11 +1741,20 @@ sub reload { return if $last_time + $CPAN::Config->{index_expire}*86400 > $time; $last_time = $time; - $cl->read_authindex($cl->reload_x("authors/01mailrc.txt.gz","01mailrc.gz",$force)); + $cl->read_authindex($cl->reload_x( + "authors/01mailrc.txt.gz", + "01mailrc.gz", + $force)); return if $CPAN::Signal; # this is sometimes lengthy - $cl->read_modpacks($cl->reload_x("modules/02packages.details.txt.gz","02packag.gz",$force)); + $cl->read_modpacks($cl->reload_x( + "modules/02packages.details.txt.gz", + "02packag.gz", + $force)); return if $CPAN::Signal; # this is sometimes lengthy - $cl->read_modlist($cl->reload_x("modules/03modlist.data.gz","03mlist.gz",$force)); + $cl->read_modlist($cl->reload_x( + "modules/03modlist.data.gz", + "03mlist.gz", + $force)); } #-> sub CPAN::Index::reload_x ; @@ -1229,9 +1762,12 @@ 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) { + 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}); + $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }. + qq{day$s. I\'ll use that.\n}); return $abs_wanted; } else { $force ||= 1; @@ -1285,1223 +1821,954 @@ sub read_modpacks { available! I\'d suggest--provided you have time--you try install CPAN reload cpan - without quitting the current session. It should be a seemless upgrade - while we are running... -}; - sleep 2; - print qq{\n}; - } - } - - my($id); - if ($bundle){ - $id = $CPAN::META->instance('CPAN::Bundle',$mod); - $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist); -# 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 { - # 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/; - - # instantiate a distribution object - unless ($CPAN::META->exists('CPAN::Distribution',$dist)) { - $CPAN::META->instance( - 'CPAN::Distribution' => $dist - )->set( - 'CPAN_USERID' => $userid - ) - if $userid =~ /\w/; - } - - return if $CPAN::Signal; - } - $fh->close; - $? and Carp::croak "FAILED $pipe: exit status [$?]"; -} - -#-> sub CPAN::Index::read_modlist ; -sub read_modlist { - my($cl,$index_target) = @_; - my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; - warn "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; - } - $eval .= q{CPAN::Modulelist->data;}; - local($^W) = 0; - my($comp) = Safe->new("CPAN::Safe1"); - my $ret = $comp->reval($eval); - Carp::confess($@) if $@; - return if $CPAN::Signal; - for (keys %$ret) { - my $obj = $CPAN::META->instance(CPAN::Module,$_); - $obj->set(%{$ret->{$_}}); - return if $CPAN::Signal; - } -} - -package CPAN::InfoObj; -@CPAN::InfoObj::ISA = qw(CPAN::Debug); - -#-> sub CPAN::InfoObj::new ; -sub new { my $this = bless {}, shift; %$this = @_; $this } - -#-> sub CPAN::InfoObj::set ; -sub set { - my($self,%att) = @_; - my(%oldatt) = %$self; - %$self = (%oldatt, %att); -} - -#-> sub CPAN::InfoObj::id ; -sub id { shift->{'ID'} } - -#-> sub CPAN::InfoObj::as_glimpse ; -sub as_glimpse { - my($self) = @_; - my(@m); - my $class = ref($self); - $class =~ s/^CPAN:://; - push @m, sprintf "%-15s %s\n", $class, $self->{ID}; - join "", @m; -} - -#-> sub CPAN::InfoObj::as_string ; -sub as_string { - my($self) = @_; - my(@m); - my $class = ref($self); - $class =~ s/^CPAN:://; - push @m, $class, " id = $self->{ID}\n"; - for (sort keys %$self) { - next if $_ eq 'ID'; - my $extra = ""; - $_ eq "CPAN_USERID" and $extra = " (".$self->author.")"; - 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; - } - } - join "", @m, "\n"; -} - -#-> sub CPAN::InfoObj::author ; -sub author { - my($self) = @_; - $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname; -} - -package CPAN::Author; -@CPAN::Author::ISA = qw(CPAN::Debug CPAN::InfoObj); - -#-> sub CPAN::Author::as_glimpse ; -sub as_glimpse { - my($self) = @_; - my(@m); - my $class = ref($self); - $class =~ s/^CPAN:://; - push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname; - join "", @m; -} - -# Dead code, I would have liked to have,,, but it was never reached,,, -#sub make { -# my($self) = @_; -# return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n"; -#} - -#-> sub CPAN::Author::fullname ; -sub fullname { shift->{'FULLNAME'} } -*name = \&fullname; -#-> sub CPAN::Author::email ; -sub email { shift->{'EMAIL'} } - -package CPAN::Distribution; -@CPAN::Distribution::ISA = qw(CPAN::Debug CPAN::InfoObj); - -#-> sub CPAN::Distribution::called_for ; -sub called_for { - my($self,$id) = @_; - $self->{'CALLED_FOR'} = $id if defined $id; - return $self->{'CALLED_FOR'}; -} - -#-> sub CPAN::Distribution::get ; -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; - } - my($local_file); - my($local_wanted) = - CPAN->catfile( - $CPAN::Config->{keep_source_where}, - "authors", - "id", - split("/",$self->{ID}) - ); - - $self->debug("Doing localize") if $CPAN::DEBUG; - $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted); - $self->{localfile} = $local_file; - my $builddir = $CPAN::META->{cachemgr}->dir; - $self->debug("doing chdir $builddir") if $CPAN::DEBUG; - chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); - my $packagedir; - - $self->debug("local_file[$local_file]") if $CPAN::DEBUG; - if ($CPAN::META->hasMD5) { - $self->verifyMD5; - } - 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: $!"; - 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"; + without quitting the current session. It should be a seemless upgrade + while we are running... +}; + sleep 2; + print qq{\n}; } + last if $CPAN::Signal; } - # 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 ($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"; - File::Path::rmtree($packagedir); - rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!"); + + my($id); + if ($bundle){ + $id = $CPAN::META->instance('CPAN::Bundle',$mod); + $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist); +# 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 { - 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); - File::Path::mkpath($packagedir); - my($f); - for $f (@readdir) { # is already without "." and ".." - my $to = $CPAN::META->catdir($packagedir,$f); - rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!"); - } + # instantiate a module object + $id = $CPAN::META->instance('CPAN::Module',$mod); + $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist); } - $self->{'build_dir'} = $packagedir; - chdir ".."; - $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"; - unlink $local_file or Carp::carp "Couldn't unlink $local_file"; - } - my($makefilepl) = $CPAN::META->catfile($packagedir,"Makefile.PL"); - unless (-f $makefilepl) { - my($configure) = $CPAN::META->catfile($packagedir,"Configure"); - if (-f $configure) { - # do we have anything to do? - $self->{'configure'} = $configure; - } else { - 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 -# 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}; - } + # determine the author + my($userid) = $dist =~ /([^\/]+)/; + $id->set('CPAN_USERID' => $userid) if $userid =~ /\w/; + + # instantiate a distribution object + unless ($CPAN::META->exists('CPAN::Distribution',$dist)) { + $CPAN::META->instance( + 'CPAN::Distribution' => $dist + )->set( + 'CPAN_USERID' => $userid + ) + if $userid =~ /\w/; } - } else { - $self->{archived} = "NO"; + + return if $CPAN::Signal; } - return $self; + $fh->close; + $? and Carp::croak "FAILED $pipe: exit status [$?]"; } -#-> sub CPAN::Distribution::new ; -sub new { - my($class,%att) = @_; +#-> sub CPAN::Index::read_modlist ; +sub read_modlist { + my($cl,$index_target) = @_; + my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; + warn "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; + } + $eval .= q{CPAN::Modulelist->data;}; + local($^W) = 0; + my($comp) = Safe->new("CPAN::Safe1"); + my $ret = $comp->reval($eval); + Carp::confess($@) if $@; + return if $CPAN::Signal; + for (keys %$ret) { + my $obj = $CPAN::META->instance(CPAN::Module,$_); + $obj->set(%{$ret->{$_}}); + return if $CPAN::Signal; + } +} - $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); +package CPAN::InfoObj; +@CPAN::InfoObj::ISA = qw(CPAN::Debug); - my $this = { %att }; - return bless $this, $class; -} +#-> sub CPAN::InfoObj::new ; +sub new { my $this = bless {}, shift; %$this = @_; $this } -#-> sub CPAN::Distribution::look ; -sub look { - my($self) = @_; - if ( $CPAN::Config->{'shell'} ) { - print qq{ -Trying to open a subshell in the build directory... -}; - } else { - print 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 $pwd = Cwd::cwd(); - chdir($dir); - print qq{Working directory is $dir.\n}; - system($CPAN::Config->{'shell'})==0 or die "Subprocess shell error"; - chdir($pwd); +#-> sub CPAN::InfoObj::set ; +sub set { + my($self,%att) = @_; + my(%oldatt) = %$self; + %$self = (%oldatt, %att); } -#-> sub CPAN::Distribution::readme ; -sub readme { - my($self) = @_; - 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) = - CPAN->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); - my $fh_pager = FileHandle->new; - $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 die "Could not open $local_file: $!"; - $fh_pager->print(<$fh_readme>); -} +#-> sub CPAN::InfoObj::id ; +sub id { shift->{'ID'} } -#-> sub CPAN::Distribution::verifyMD5 ; -sub verifyMD5 { +#-> sub CPAN::InfoObj::as_glimpse ; +sub as_glimpse { my($self) = @_; - EXCUSE: { - my @e; - $self->{MD5_STATUS} and push @e, "MD5 Checksum was ok"; - print join "", map {" $_\n"} @e and return if @e; - } - my($local_file); - my(@local) = split("/",$self->{ID}); - my($basename) = pop @local; - push @local, "CHECKSUMS"; - my($local_wanted) = - CPAN->catfile( - $CPAN::Config->{keep_source_where}, - "authors", - "id", - @local - ); - local($") = "/"; - if ( - -f $local_wanted - && - $self->MD5_check_file($local_wanted,$basename) - ) { - return $self->{MD5_STATUS}="OK"; - } - $local_file = CPAN::FTP->localize("authors/id/@local", $local_wanted, 'force>:-{'); - my($checksum_pipe); - if ($local_file) { - # fine - } else { - $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$//; - } - $self->MD5_check_file($local_file,$basename); + my(@m); + my $class = ref($self); + $class =~ s/^CPAN:://; + push @m, sprintf "%-15s %s\n", $class, $self->{ID}; + join "", @m; } -#-> sub CPAN::Distribution::MD5_check_file ; -sub MD5_check_file { - my($self,$lfile,$basename) = @_; - my($cksum); - my $fh = new FileHandle; - local($/)=undef; - if (open $fh, $lfile){ - 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); +#-> sub CPAN::InfoObj::as_string ; +sub as_string { + my($self) = @_; + my(@m); + my $class = ref($self); + $class =~ s/^CPAN:://; + push @m, $class, " id = $self->{ID}\n"; + for (sort keys %$self) { + next if $_ eq 'ID'; + my $extra = ""; + $_ eq "CPAN_USERID" and $extra = " (".$self->author.")"; + if (ref($self->{$_}) eq "ARRAY") { # Should we setup a language interface? XXX + push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; } else { - print "No md5 checksum for $basename in local $lfile\n"; - return; - } - } else { - Carp::carp "Could not open $lfile for reading"; + push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; + } } + join "", @m, "\n"; } -#-> sub CPAN::Distribution::eq_MD5 ; -sub eq_MD5 { - my($self,$fh,$expectMD5) = @_; - my $md5 = new MD5; - $md5->addfile($fh); - my $hexdigest = $md5->hexdigest; - $hexdigest eq $expectMD5; +#-> sub CPAN::InfoObj::author ; +sub author { + my($self) = @_; + $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname; } -#-> sub CPAN::Distribution::force ; -sub force { +package CPAN::Author; +@CPAN::Author::ISA = qw(CPAN::InfoObj); + +#-> sub CPAN::Author::as_glimpse ; +sub as_glimpse { my($self) = @_; - $self->{'force_update'}++; - delete $self->{'MD5_STATUS'}; - delete $self->{'archived'}; - delete $self->{'build_dir'}; - delete $self->{'localfile'}; - delete $self->{'make'}; - delete $self->{'install'}; - delete $self->{'unwrapped'}; - delete $self->{'writemakefile'}; + my(@m); + my $class = ref($self); + $class =~ s/^CPAN:://; + push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname; + join "", @m; } -#-> sub CPAN::Distribution::make ; -sub make { - my($self) = @_; - $self->debug($self->id) if $CPAN::DEBUG; - print "Running make\n"; - $self->get; - 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.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; +# Dead code, I would have liked to have,,, but it was never reached,,, +#sub make { +# my($self) = @_; +# return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n"; +#} - my $system; - 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; - } - } else { - print "Cannot fork: $!"; - return; - } - $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; - } - $self->{writemakefile} = "YES"; - return if $CPAN::Signal; - $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg}; - if (system($system)==0) { - print " $system -- OK\n"; - $self->{'make'} = "YES"; - } else { - $self->{writemakefile} = "YES"; - $self->{'make'} = "NO"; - print " $system -- NOT OK\n"; - } -} +#-> sub CPAN::Author::fullname ; +sub fullname { shift->{'FULLNAME'} } +*name = \&fullname; +#-> sub CPAN::Author::email ; +sub email { shift->{'EMAIL'} } -#-> sub CPAN::Distribution::test ; -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; - my $system = join " ", $CPAN::Config->{'make'}, "test"; - if (system($system)==0) { - print " $system -- OK\n"; - $self->{'make_test'} = "YES"; - } else { - $self->{'make_test'} = "NO"; - print " $system -- NOT OK\n"; - } -} +package CPAN::Distribution; +@CPAN::Distribution::ISA = qw(CPAN::InfoObj); -#-> 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'}"); - $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"; - $self->force; - } else { - # Hmmm, what to do if make clean failed? - } +#-> sub CPAN::Distribution::called_for ; +sub called_for { + my($self,$id) = @_; + $self->{'CALLED_FOR'} = $id if defined $id; + return $self->{'CALLED_FOR'}; } -#-> sub CPAN::Distribution::install ; -sub install { +#-> sub CPAN::Distribution::get ; +sub get { 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"; + exists $self->{'build_dir'} and push @e, + "Unwrapped into directory $self->{'build_dir'}"; 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) = FileHandle->new("$system 2>&1 |"); - my($makeout) = ""; - while (<$pipe>){ - print; - $makeout .= $_; + my($local_file); + my($local_wanted) = + CPAN->catfile( + $CPAN::Config->{keep_source_where}, + "authors", + "id", + split("/",$self->{ID}) + ); + + $self->debug("Doing localize") if $CPAN::DEBUG; + $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted); + $self->{localfile} = $local_file; + my $builddir = $CPAN::META->{cachemgr}->dir; + $self->debug("doing chdir $builddir") if $CPAN::DEBUG; + chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); + my $packagedir; + + $self->debug("local_file[$local_file]") if $CPAN::DEBUG; + if ($CPAN::META->hasMD5) { + $self->verifyMD5; } - $pipe->close; - if ($?==0) { - print " $system -- OK\n"; - $self->{'install'} = "YES"; - } else { - $self->{'install'} = "NO"; - print " $system -- NOT OK\n"; - if ($makeout =~ /permission/s && $> > 0) { - print " You may have to su to root to install the package\n"; - } + 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: $!"; + 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 ($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"; + 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); + File::Path::mkpath($packagedir); + my($f); + for $f (@readdir) { # is already without "." and ".." + my $to = $CPAN::META->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; + File::Path::rmtree("tmp"); + if ($CPAN::Config->{keep_source_where} =~ /^no/i ){ + print "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"); + unless (-f $makefilepl) { + my($configure) = $CPAN::META->catfile($packagedir,"Configure"); + if (-f $configure) { + # do we have anything to do? + $self->{'configure'} = $configure; + } else { + 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 +# 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}; + } + } + } else { + $self->{archived} = "NO"; } + return $self; } -#-> sub CPAN::Distribution::dir ; -sub dir { - shift->{'build_dir'}; -} - -package CPAN::Bundle; -@CPAN::Bundle::ISA = qw(CPAN::Debug CPAN::InfoObj CPAN::Module); +#-> sub CPAN::Distribution::new ; +sub new { + my($class,%att) = @_; -#-> sub CPAN::Bundle::as_string ; -sub as_string { - my($self) = @_; - $self->contains; - return $self->SUPER::as_string; -} + $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); -#-> sub CPAN::Bundle::contains ; -sub contains { - my($self) = @_; - my($parsefile) = $self->inst_file; - 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; - $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: $!"); - $parsefile = $to; - } - my @result; - my $fh = new FileHandle; - local $/ = "\n"; - open($fh,$parsefile) or die "Could not open '$parsefile': $!"; - my $inpod = 0; - while (<$fh>) { - $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : /^=head1\s+CONTENTS/ ? 1 : $inpod; - next unless $inpod; - next if /^=/; - next if /^\s+$/; - chomp; - push @result, (split " ", $_, 2)[0]; - } - close $fh; - delete $self->{STATUS}; - $self->{CONTAINS} = [@result]; - @result; + my $this = { %att }; + return bless $this, $class; } -#-> sub CPAN::Bundle::inst_file ; -sub inst_file { +#-> sub CPAN::Distribution::look ; +sub look { 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; - 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($s); - for $s ($self->contains) { - $CPAN::META->instance('CPAN::Module',$s)->$meth(); + if ( $CPAN::Config->{'shell'} ) { + print qq{ +Trying to open a subshell in the build directory... +}; + } else { + print 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 $pwd = Cwd::cwd(); + chdir($dir); + print qq{Working directory is $dir.\n}; + system($CPAN::Config->{'shell'})==0 or die "Subprocess shell error"; + chdir($pwd); } -#-> 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::readme ; -sub readme { +#-> sub CPAN::Distribution::readme ; +sub readme { my($self) = @_; - my($file) = $self->cpan_file or print("No File found for bundle ", $self->id, "\n"), return; - $self->debug("self[$self] file[$file]") if $CPAN::DEBUG; - $CPAN::META->instance('CPAN::Distribution',$file)->readme; + 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) = + CPAN->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); + my $fh_pager = FileHandle->new; + $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 die "Could not open $local_file: $!"; + $fh_pager->print(<$fh_readme>); } -package CPAN::Module; -@CPAN::Module::ISA = qw(CPAN::Debug CPAN::InfoObj); - -#-> sub CPAN::Module::as_glimpse ; -sub as_glimpse { +#-> sub CPAN::Distribution::verifyMD5 ; +sub verifyMD5 { my($self) = @_; - my(@m); - my $class = ref($self); - $class =~ s/^CPAN:://; - push @m, sprintf "%-15s %-15s (%s)\n", $class, $self->{ID}, $self->cpan_file; - join "", @m; + EXCUSE: { + my @e; + $self->{MD5_STATUS} ||= ""; + $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok"; + print join "", map {" $_\n"} @e and return if @e; + } + my($local_file); + my(@local) = split("/",$self->{ID}); + my($basename) = pop @local; + push @local, "CHECKSUMS"; + my($local_wanted) = + CPAN->catfile( + $CPAN::Config->{keep_source_where}, + "authors", + "id", + @local + ); + local($") = "/"; + if ( + -f $local_wanted + && + $self->MD5_check_file($local_wanted,$basename) + ) { + return $self->{MD5_STATUS} = "OK"; + } + $local_file = CPAN::FTP->localize( + "authors/id/@local", + $local_wanted, + 'force>:-{'); + my($checksum_pipe); + if ($local_file) { + # fine + } else { + $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$//; + } + $self->MD5_check_file($local_file,$basename); } -#-> sub CPAN::Module::as_string ; -sub as_string { - my($self) = @_; - my(@m); - CPAN->debug($self) if $CPAN::DEBUG; - my $class = ref($self); - $class =~ s/^CPAN:://; - 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}; - 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 $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,; - @statl{qw,? p c + o,} = qw,unknown perl C C++ other,; - @stati{qw,? f r O,} = qw,unknown functions references+ties object-oriented,; - $statd{' '} = 'unknown'; - $stats{' '} = 'unknown'; - $statl{' '} = 'unknown'; - $stati{' '} = 'unknown'; - push @m, sprintf( - $sprintf3, - 'DSLI_STATUS', - $self->{statd}, - $self->{stats}, - $self->{statl}, - $self->{stati}, - $statd{$self->{statd}}, - $stats{$self->{stats}}, - $statl{$self->{statl}}, - $stati{$self->{stati}} - ) if $self->{statd}; - my $local_file = $self->inst_file; - if ($local_file && ! exists $self->{MANPAGE}) { - 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; - next unless $inpod; - next if /^=/; - next if /^\s+$/; - chomp; - push @result, $_; +#-> sub CPAN::Distribution::MD5_check_file ; +sub MD5_check_file { + my($self,$lfile,$basename) = @_; + my($cksum); + my $fh = new FileHandle; + local($/)=undef; + if (open $fh, $lfile){ + 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 { + print join( + "", + qq{Checksum mismatch for distribution file. }, + qq{Please investigate.\n\n} + ); + print $self->as_string; + print $CPAN::META->instance( + 'CPAN::Author', + $self->{CPAN_USERID} + )->as_string; + my $wrap = qq{I\'d recommend removing $self->{'localfile'}}. + qq{, put another URL at the top of the list of URLs to }. + qq{visit, and restart CPAN.pm. If all this doesn\'t help, }. + qq{please contact the author or your CPAN site admin}; + print Text::Wrap::wrap("","",$wrap); + print "\n\n"; + sleep 3; + return; + } + close $fh if fileno($fh); + } else { + $self->{MD5_STATUS} ||= ""; + if ($self->{MD5_STATUS} eq "NIL") { + print "\nNo md5 checksum for $basename in local $lfile."; + print "Removing $lfile\n"; + unlink $lfile or print "Could not unlink: $!"; + sleep 1; + } + $self->{MD5_STATUS} = "NIL"; + return; } - 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; - join "", @m, "\n"; -} - -#-> sub CPAN::Module::cpan_file ; -sub cpan_file { - my $self = shift; - CPAN->debug($self->id) if $CPAN::DEBUG; - unless (defined $self->{'CPAN_FILE'}) { - CPAN::Index->reload; - } - if (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 } else { - return "N/A"; + Carp::carp "Could not open $lfile for reading"; } } -*name = \&cpan_file; - -#-> sub CPAN::Module::cpan_version ; -sub cpan_version { shift->{'CPAN_VERSION'} } +#-> sub CPAN::Distribution::eq_MD5 ; +sub eq_MD5 { + my($self,$fh,$expectMD5) = @_; + my $md5 = new MD5; + $md5->addfile($fh); + my $hexdigest = $md5->hexdigest; + $hexdigest eq $expectMD5; +} -#-> sub CPAN::Module::force ; +#-> sub CPAN::Distribution::force ; sub force { my($self) = @_; $self->{'force_update'}++; + delete $self->{'MD5_STATUS'}; + delete $self->{'archived'}; + delete $self->{'build_dir'}; + delete $self->{'localfile'}; + delete $self->{'make'}; + delete $self->{'install'}; + delete $self->{'unwrapped'}; + delete $self->{'writemakefile'}; } -#-> sub CPAN::Module::rematein ; -sub rematein { - my($self,$meth) = @_; +#-> sub CPAN::Distribution::make ; +sub make { + my($self) = @_; $self->debug($self->id) if $CPAN::DEBUG; - my $cpan_file = $self->cpan_file; - return if $cpan_file eq "N/A"; - return if $cpan_file =~ /^Contact Author/; - my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); - $pack->called_for($self->id); - $pack->force if exists $self->{'force_update'}; - $pack->$meth(); - delete $self->{'force_update'}; -} + print "Running make\n"; + $self->get; + EXCUSE: { + my @e; + $self->{archived} eq "NO" and push @e, + "Is neither a tar nor a zip archive."; -#-> 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) = @_; - 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; + $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; } - if ($inst_file && $have >= $latest && not exists $self->{'force_update'}) { - print $self->id, " is up to date.\n"; + print "\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; + + my $system; + if ($self->{'configure'}) { + $system = $self->{'configure'}; } else { - $doit = 1; + my($perl) = MM->file_name_is_absolute($^X) ? $^X : ""; + $perl ||= "$CPAN::Cwd/$^X" if -x "$CPAN::Cwd/$^X"; + unless ($perl) { + my ($component,$perl_name); + DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") { + DIST_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; + } + } + } + } + die "Couldn\'t find executable perl\n" unless $perl; + $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; + } + } else { + print "Cannot fork: $!"; + return; + } + $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; + } + $self->{writemakefile} = "YES"; + return if $CPAN::Signal; + $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg}; + if (system($system)==0) { + print " $system -- OK\n"; + $self->{'make'} = "YES"; + } else { + $self->{writemakefile} = "YES"; + $self->{'make'} = "NO"; + print " $system -- NOT OK\n"; } - $self->rematein('install') if $doit; } -#-> sub CPAN::Module::clean ; -sub clean { shift->rematein('clean') } -#-> sub CPAN::Module::inst_file ; -sub inst_file { +#-> sub CPAN::Distribution::test ; +sub test { 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; - } + $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; + my $system = join " ", $CPAN::Config->{'make'}, "test"; + if (system($system)==0) { + print " $system -- OK\n"; + $self->{'make_test'} = "YES"; + } else { + $self->{'make_test'} = "NO"; + print " $system -- NOT OK\n"; } } -#-> sub CPAN::Module::xs_file ; -sub xs_file { +#-> sub CPAN::Distribution::clean ; +sub clean { 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; - } + 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'}"); + $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"; + $self->force; + } else { + # Hmmm, what to do if make clean failed? } } -#-> sub CPAN::Module::inst_version ; -sub inst_version { +#-> sub CPAN::Distribution::install ; +sub install { my($self) = @_; - my $parsefile = $self->inst_file or return 0; - local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38; - my $have = MY->parse_version($parsefile); - $have ||= 0; - $have =~ s/\s+//g; - $have ||= 0; - $have; -} + $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"; -package CPAN::CacheMgr; -use vars qw($Du); -@CPAN::CacheMgr::ISA = qw(CPAN::Debug CPAN::InfoObj); -use File::Find; + exists $self->{'make'} or push @e, + "Make had some problems, maybe interrupted? Won't install"; -#-> sub CPAN::CacheMgr::as_string ; -sub as_string { - eval { require Data::Dumper }; - if ($@) { - return shift->SUPER::as_string; + 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) = FileHandle->new("$system 2>&1 |"); + my($makeout) = ""; + while (<$pipe>){ + print; + $makeout .= $_; + } + $pipe->close; + if ($?==0) { + print " $system -- OK\n"; + $self->{'install'} = "YES"; } else { - return Data::Dumper::Dumper(shift); + $self->{'install'} = "NO"; + print " $system -- NOT OK\n"; + if ($makeout =~ /permission/s && $> > 0) { + print " You may have to su to root to install the package\n"; + } } } -#-> sub CPAN::CacheMgr::cachesize ; -sub cachesize { - shift->{DU}; +#-> sub CPAN::Distribution::dir ; +sub dir { + shift->{'build_dir'}; } -# sub check { -# my($self,@dirs) = @_; -# return unless -d $self->{ID}; -# my $dir; -# @dirs = $self->dirs unless @dirs; -# for $dir (@dirs) { -# $self->disk_usage($dir); -# } -# } +package CPAN::Bundle; +@CPAN::Bundle::ISA = qw(CPAN::Module); -#-> 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); +#-> sub CPAN::Bundle::as_string ; +sub as_string { + my($self) = @_; + $self->contains; + $self->{INST_VERSION} = $self->inst_version; + return $self->SUPER::as_string; +} + +#-> sub CPAN::Bundle::contains ; +sub contains { + my($self) = @_; + my($parsefile) = $self->inst_file; + 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; + $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: $!"); + $parsefile = $to; } - $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG; + my @result; + my $fh = new FileHandle; + local $/ = "\n"; + open($fh,$parsefile) or die "Could not open '$parsefile': $!"; + my $inpod = 0; + while (<$fh>) { + $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : /^=head1\s+CONTENTS/ ? 1 : $inpod; + next unless $inpod; + next if /^=/; + next if /^\s+$/; + chomp; + push @result, (split " ", $_, 2)[0]; + } + close $fh; + delete $self->{STATUS}; + $self->{CONTAINS} = [@result]; + @result; } -#-> sub CPAN::CacheMgr::dir ; -sub dir { - shift->{ID}; +#-> 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; + return $self->{'INST_FILE'} = $inst_file if -f $inst_file; + return $self->{'INST_FILE'}; # even if undefined? } -#-> 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"; +#-> sub CPAN::Bundle::rematein ; +sub rematein { + my($self,$meth) = @_; + $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG; + my($s); + for $s ($self->contains) { + my($type) = $s =~ m|/| ? 'CPAN::Distribution' : + $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module'; + if ($type eq 'CPAN::Distribution') { + warn qq{ +The Bundle }.$self->id.qq{ contains +explicitly a file $s. +}; + sleep 3; } + $CPAN::META->instance($type,$s)->$meth(); } - 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::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::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::Bundle::readme ; +sub readme { + my($self) = @_; + my($file) = $self->cpan_file or print("No File found for bundle ", $self->id, "\n"), return; + $self->debug("self[$self] file[$file]") if $CPAN::DEBUG; + $CPAN::META->instance('CPAN::Distribution',$file)->readme; } -#-> 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::Module; +@CPAN::Module::ISA = qw(CPAN::InfoObj); -package CPAN::Debug; +#-> sub CPAN::Module::as_glimpse ; +sub as_glimpse { + my($self) = @_; + my(@m); + my $class = ref($self); + $class =~ s/^CPAN:://; + push @m, sprintf "%-15s %-15s (%s)\n", $class, $self->{ID}, $self->cpan_file; + join "", @m; +} -#-> 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" +#-> sub CPAN::Module::as_string ; +sub as_string { + my($self) = @_; + my(@m); + CPAN->debug($self) if $CPAN::DEBUG; + my $class = ref($self); + $class =~ s/^CPAN:://; + 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}; + 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 $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,; + @statl{qw,? p c + o,} = qw,unknown perl C C++ other,; + @stati{qw,? f r O,} = qw,unknown functions references+ties object-oriented,; + $statd{' '} = 'unknown'; + $stats{' '} = 'unknown'; + $statl{' '} = 'unknown'; + $stati{' '} = 'unknown'; + push @m, sprintf( + $sprintf3, + 'DSLI_STATUS', + $self->{statd}, + $self->{stats}, + $self->{statl}, + $self->{stati}, + $statd{$self->{statd}}, + $stats{$self->{stats}}, + $statl{$self->{statl}}, + $stati{$self->{stati}} + ) if $self->{statd}; + my $local_file = $self->inst_file; + if ($local_file && ! exists $self->{MANPAGE}) { + 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; + next unless $inpod; + next if /^=/; + next if /^\s+$/; + chomp; + push @result, $_; } + 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; + join "", @m, "\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; +#-> sub CPAN::Module::cpan_file ; +sub cpan_file { + my $self = shift; + CPAN->debug($self->id) if $CPAN::DEBUG; + unless (defined $self->{'CPAN_FILE'}) { + CPAN::Index->reload; + } + if (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 } 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] if defined $args[0]; - print " $o "; - print defined $CPAN::Config->{$o} ? $CPAN::Config->{$o} : "UNDEFINED"; - } + return "N/A"; } } -#-> sub CPAN::Config::commit ; -sub commit { - my($self, $configpm) = @_; - my $mode; - # mkpath!? - - my($fh) = FileHandle->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"; - } +*name = \&cpan_file; - print $fh "};\n1;\n__END__\n"; - close $fh; +#-> sub CPAN::Module::cpan_version ; +sub cpan_version { shift->{'CPAN_VERSION'} } - #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); - #chmod $mode, $configpm; - $self->defaults; - print "commit: wrote $configpm\n"; - 1; +#-> sub CPAN::Module::force ; +sub force { + my($self) = @_; + $self->{'force_update'}++; } -*default = \&defaults; -#-> sub CPAN::Config::defaults ; -sub defaults { - my($self) = @_; - $self->unload; - $self->load; - 1; +#-> sub CPAN::Module::rematein ; +sub rematein { + my($self,$meth) = @_; + $self->debug($self->id) if $CPAN::DEBUG; + my $cpan_file = $self->cpan_file; + return if $cpan_file eq "N/A"; + return if $cpan_file =~ /^Contact Author/; + my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); + $pack->called_for($self->id); + $pack->force if exists $self->{'force_update'}; + $pack->$meth(); + delete $self->{'force_update'}; } -my $dot_cpan; -#-> sub CPAN::Config::load ; -sub load { +#-> 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) = @_; - 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)) { - 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($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::clean ; +sub clean { shift->rematein('clean') } -#-> 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 ftp_proxy http_proxy no_proxy - )) { - unless (defined $CPAN::Config->{$_}){ - $miss++; - CPAN->debug("undefined configuration parameter $_") if $CPAN::DEBUG; +#-> 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; } } - 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'}; } -*h = \&help; -#-> sub CPAN::Config::help ; -sub help { - print < 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::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; +#-> sub CPAN::Module::inst_version ; +sub inst_version { + my($self) = @_; + my $parsefile = $self->inst_file or return 0; + local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38; + my $have = MM->parse_version($parsefile); + $have ||= 0; + $have =~ s/\s+//g; + $have ||= 0; + $have; } 1; @@ -2608,11 +2875,11 @@ distribution file where this module is included and processes that. Any C, C, and C are run unconditionally. A - Cdistribution_fileE> + install 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. diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm index e970cf1..3127a5e 100644 --- a/lib/CPAN/FirstTime.pm +++ b/lib/CPAN/FirstTime.pm @@ -12,9 +12,10 @@ package CPAN::FirstTime; use strict; use ExtUtils::MakeMaker qw(prompt); -require File::Path; +use FileHandle (); +use File::Path (); use vars qw($VERSION); -$VERSION = substr q$Revision: 1.13 $, 10; +$VERSION = substr q$Revision: 1.15 $, 10; =head1 NAME @@ -48,7 +49,6 @@ sub init { # print qq{ - The CPAN module needs a directory of its own to cache important index files and maybe keep a temporary mirror of CPAN files. This may be a site-wide directory or a personal directory. @@ -72,11 +72,15 @@ First of all, I\'d like to create this directory. Where? } $default = $cpan_home; - until (-d ($ans = prompt("CPAN build and cache directory?",$default)) && -w _) { - print "Couldn't find directory $ans + while ($ans = prompt("CPAN build and cache directory?",$default)) { + File::Path::mkpath($ans); # dies if it can't + if (-d $ans && -w _) { + last; + } else { + warn "Couldn't find directory $ans or directory is not writable. Please retry.\n"; + } } - File::Path::mkpath($ans); # dies if it can't $CPAN::Config->{cpan_home} = $ans; print qq{ @@ -117,6 +121,8 @@ with all the intermediate files? The CPAN module will need a few external programs to work properly. Please correct me, if I guess the wrong path for a program. +Don\'t panic if you do not have some of them, just press ENTER for +those. }; @@ -134,6 +140,7 @@ properly. Please correct me, if I guess the wrong path for a program. $CPAN::Config->{'pager'} = $ans; $path = $CPAN::Config->{'shell'} || $ENV{SHELL} || ""; $ans = prompt("What is your favorite shell?",$path) || $path; + $CPAN::Config->{'shell'} = $ans; # # Arguments to make etc. @@ -146,6 +153,8 @@ run \'make\' and \'make install\' in processes. If you have any parameters \(e.g. PREFIX, INSTALLPRIVLIB, UNINST or the like\) you want to pass to the calls, please specify them here. +If you don\'t understand this question, just press ENTER. + }; $default = $CPAN::Config->{makepl_arg} || ""; @@ -183,29 +192,59 @@ If you set this value to 0, these processes will wait forever. # $local = 'MIRRORED.BY'; + $local = MM->catfile($CPAN::Config->{keep_source_where},"MIRRORED.BY") unless -f $local; if (@{$CPAN::Config->{urllist}||[]}) { print qq{ I found a list of URLs in CPAN::Config and will use this. You can change it later with the 'o conf' command. } - } elsif (-f $local) { # if they really have a wrong MIRRORED.BY in - # the current directory, we can't help + } elsif ( + -s $local + && + -M $local < 30 + ) { read_mirrored_by($local); } else { $CPAN::Config->{urllist} ||= []; while (! @{$CPAN::Config->{urllist}}) { - print qq{ + my($input) = prompt(qq{ We need to know the URL of your favorite CPAN site. -Please enter it here: }; - chop($_ = <>); - s/\s//g; - push @{$CPAN::Config->{urllist}}, $_ if $_; +Please enter it here:}); + $input =~ s/\s//g; + next unless $input; + my($wanted) = "MIRRORED.BY"; + print qq{ +Testing "$input" ... +}; + push @{$CPAN::Config->{urllist}}, $input; + CPAN::FTP->localize($wanted,$local,"force"); + if (-s $local) { + print qq{ +"$input" seems to work +}; + } else { + my $ans = prompt(qq{$input doesn\'t seem to work. Keep it in the list?},"n"); + last unless $ans =~ /^n/i; + pop @{$CPAN::Config->{urllist}}; + } } } print qq{ +WAIT support is available as a Plugin. You need the CPAN::WAIT module +to actually use it. But we need to know your favorite WAIT server. If +you don\'t know a WAIT server near you, just press ENTER. + +}; + + $default = "wait://ls6.informatik.uni-dortmund.de:1404"; + $ans = prompt("Your favorite WAIT server?\n ",$default); + push @{$CPAN::Config->{'wait_list'}}, $ans; + + print qq{ + If you\'re accessing the net via proxies, you can specify them in the CPAN configuration or via environment variables. The variable in the \$CPAN::Config takes precedence. @@ -240,8 +279,9 @@ sub find_exe { sub read_mirrored_by { my($local) = @_; my(%all,$url,$expected_size,$default,$ans,$host,$dst,$country,$continent,@location); - open FH, $local or die "Couldn't open $local: $!"; - while () { + my $fh = FileHandle->new; + $fh->open($local) or die "Couldn't open $local: $!"; + while (<$fh>) { ($host) = /^([\w\.\-]+)/ unless defined $host; next unless defined $host; next unless /\s+dst_(dst|location)/; @@ -254,6 +294,7 @@ sub read_mirrored_by { undef $host; $dst=$continent=$country=""; } + $fh->close; $CPAN::Config->{urllist} ||= []; if ($expected_size = @{$CPAN::Config->{urllist}}) { for $url (@{$CPAN::Config->{urllist}}) { @@ -286,12 +327,13 @@ file:, ftp: or http: URL, or "q" to finish selecting. while () { my $pipe = -t *STDIN ? "| $CPAN::Config->{'pager'}" : ">/dev/null"; my(@valid,$previous_best); - open FH, $pipe; + my $fh = FileHandle->new; + $fh->open($pipe); { my($cont,$country,$url,$item); my(@cont) = sort keys %all; for $cont (@cont) { - print FH " $cont\n"; + $fh->print(" $cont\n"); for $country (sort {lc $a cmp lc $b} keys %{$all{$cont}}) { for $url (sort {lc $a cmp lc $b} keys %{$all{$cont}{$country}}) { my $t = sprintf( @@ -304,12 +346,11 @@ file:, ftp: or http: URL, or "q" to finish selecting. $previous_best ||= $item; } push @valid, $all{$cont}{$country}{$url}; - print FH $t; + $fh->print($t); } } } } - close FH; $previous_best ||= 1; $default = @{$CPAN::Config->{urllist}} >= $expected_size ? "q" : $previous_best;