X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCPAN.pm;h=887d5cd3c43f625dabf3214180e6d08362e72a36;hb=9e01bed8b6dd351933b88ffcf539432d47e152bc;hp=0abfe1d8e75fbb228d3bd49ab2bc0fbfe0790040;hpb=5fc0f0f6e90f423ffa278e3f31f7021206604ee9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/CPAN.pm b/lib/CPAN.pm index 0abfe1d..887d5cd 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1,11 +1,12 @@ # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- package CPAN; -$VERSION = '1.64'; -# $Id: CPAN.pm,v 1.397 2003/02/06 09:44:40 k Exp $ +$VERSION = '1.76_01'; +$VERSION = eval $VERSION; +# $Id: CPAN.pm,v 1.412 2003/07/31 14:53:04 k Exp $ # only used during development: $Revision = ""; -# $Revision = "[".substr(q$Revision: 1.397 $, 10)."]"; +# $Revision = "[".substr(q$Revision: 1.412 $, 10)."]"; use Carp (); use Config (); @@ -281,6 +282,28 @@ package CPAN::Bundle; package CPAN::Module; @CPAN::Module::ISA = qw(CPAN::InfoObj); +package CPAN::Exception::RecursiveDependency; +use overload '""' => "as_string"; + +sub new { + my($class) = shift; + my($deps) = shift; + my @deps; + my %seen; + for my $dep (@$deps) { + push @deps, $dep; + last if $seen{$dep}++; + } + bless { deps => \@deps }, $class; +} + +sub as_string { + my($self) = shift; + "\nRecursive dependency detected:\n " . + join("\n => ", @{$self->{deps}}) . + ".\nCannot continue.\n"; +} + package CPAN::Shell; use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING); @CPAN::Shell::ISA = qw(CPAN::Debug); @@ -803,14 +826,18 @@ sub savehist { return; } $histsize = $CPAN::Config->{'histsize'} || 100; - unless ($CPAN::term->can("GetHistory")) { - $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n"); + if ($CPAN::term){ + unless ($CPAN::term->can("GetHistory")) { + $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n"); + return; + } + } else { return; } my @h = $CPAN::term->GetHistory; splice @h, 0, @h-$histsize if @h>$histsize; my($fh) = FileHandle->new; - open $fh, ">$histfile" or mydie("Couldn't open >$histfile: $!"); + open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!"); local $\ = local $, = "\n"; print $fh @h; close $fh; @@ -1419,7 +1446,8 @@ sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));} #-> sub CPAN::Shell::m ; sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here - $CPAN::Frontend->myprint(shift->format_result('Module',@_)); + my $self = shift; + $CPAN::Frontend->myprint($self->format_result('Module',@_)); } #-> sub CPAN::Shell::i ; @@ -2160,7 +2188,7 @@ sub get_basic_credentials { return unless $proxy; if ($USER && $PASSWD) { } elsif (defined $CPAN::Config->{proxy_user} && - defined $CPAN::Config->{proxy_pass}) { + defined $CPAN::Config->{proxy_pass}) { $USER = $CPAN::Config->{proxy_user}; $PASSWD = $CPAN::Config->{proxy_pass}; } else { @@ -2185,6 +2213,21 @@ sub get_basic_credentials { return($USER,$PASSWD); } +# mirror(): Its purpose is to deal with proxy authentication. When we +# call SUPER::mirror, we relly call the mirror method in +# LWP::UserAgent. LWP::UserAgent will then call +# $self->get_basic_credentials or some equivalent and this will be +# $self->dispatched to our own get_basic_credentials method. + +# Our own get_basic_credentials sets $USER and $PASSWD, two globals. + +# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means +# although we have gone through our get_basic_credentials, the proxy +# server refuses to connect. This could be a case where the username or +# password has changed in the meantime, so I'm trying once again without +# $USER and $PASSWD to give the get_basic_credentials routine another +# chance to set $USER and $PASSWD. + sub mirror { my($self,$url,$aslocal) = @_; my $result = $self->SUPER::mirror($url,$aslocal); @@ -2335,10 +2378,9 @@ sub localize { } } } - $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy}; - $ENV{http_proxy} = $CPAN::Config->{http_proxy} - if $CPAN::Config->{http_proxy}; - $ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy}; + for my $prx (qw(ftp_proxy http_proxy no_proxy)) { + $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx}; + } # Try the list of urls for each single object. We keep a record # where we did get a file from @@ -2664,8 +2706,9 @@ sub hosthardest { my($i); my($aslocal_dir) = File::Basename::dirname($aslocal); File::Path::mkpath($aslocal_dir); + my $ftpbin = $CPAN::Config->{ftp}; HOSTHARDEST: for $i (@$host_seq) { - unless (length $CPAN::Config->{'ftp'}) { + unless (length $ftpbin && MM->maybe_command($ftpbin)) { $CPAN::Frontend->myprint("No external ftp command available\n\n"); last HOSTHARDEST; } @@ -2710,7 +2753,7 @@ sub hosthardest { } ); - $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host", + $self->talk_ftp("$ftpbin$verbose $host", @dialog); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); @@ -2735,13 +2778,13 @@ sub hosthardest { # OK, they don't have a valid ~/.netrc. Use 'ftp -n' # then and login manually to host, using e-mail as # password. - $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n}); + $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n}); unshift( @dialog, "open $host", "user anonymous $Config::Config{'cf_email'}" ); - $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog); + $self->talk_ftp("$ftpbin$verbose -n", @dialog); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); $mtime ||= 0; @@ -3286,7 +3329,7 @@ happen.\a if ($id->cpan_file ne $dist){ # update only if file is # different. CPAN prohibits same # name with different version - $userid = $self->userid($dist); + $userid = $id->userid || $self->userid($dist); $id->set( 'CPAN_USERID' => $userid, 'CPAN_VERSION' => $version, @@ -3452,7 +3495,11 @@ sub read_metadata_cache { package CPAN::InfoObj; # Accessors -sub cpan_userid { shift->{RO}{CPAN_USERID} } +sub cpan_userid { + my $self = shift; + $self->{RO}{CPAN_USERID} +} + sub id { shift->{ID}; } #-> sub CPAN::InfoObj::new ; @@ -3722,22 +3769,20 @@ sub color_cmd_tmps { my($self) = shift; my($depth) = shift || 0; my($color) = shift || 0; + my($ancestors) = shift || []; # a distribution needs to recurse into its prereq_pms return if exists $self->{incommandcolor} && $self->{incommandcolor}==$color; - $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ". - "color_cmd_tmps depth[%s] self[%s] id[%s]", - $depth, - $self, - $self->id - )) if $depth>=100; - ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; + if ($depth>=100){ + $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors)); + } + # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; my $prereq_pm = $self->prereq_pm; if (defined $prereq_pm) { for my $pre (keys %$prereq_pm) { my $premo = CPAN::Shell->expand("Module",$pre); - $premo->color_cmd_tmps($depth+1,$color); + $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); } } if ($color==0) { @@ -3932,7 +3977,7 @@ sub get { } $self->{'build_dir'} = $packagedir; - $self->safe_chdir(File::Spec->updir); + $self->safe_chdir($builddir); File::Path::rmtree("tmp"); my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL"); @@ -4077,8 +4122,10 @@ Could not determine which directory to use for looking at $dist. my $pwd = CPAN::anycwd(); $self->safe_chdir($dir); $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); - system($CPAN::Config->{'shell'}) == 0 - or $CPAN::Frontend->mydie("Subprocess shell error"); + unless (system($CPAN::Config->{'shell'}) == 0) { + my $code = $? >> 8; + $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n"); + } $self->safe_chdir($pwd); } @@ -4553,6 +4600,7 @@ of modules we are processing right now?", "yes"); if ($follow) { # color them as dirty for my $p (@prereq) { + # warn "calling color_cmd_tmps(0,1)"; CPAN::Shell->expandany($p)->color_cmd_tmps(0,1); } CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself @@ -4834,10 +4882,7 @@ package CPAN::Bundle; sub look { my $self = shift; - $CPAN::Frontend->myprint( - qq{ look() commmand on bundles not}. - qq{ implemented (What should it do?)} - ); + $CPAN::Frontend->myprint($self->as_string); } sub undelay { @@ -4854,23 +4899,21 @@ sub color_cmd_tmps { my($self) = shift; my($depth) = shift || 0; my($color) = shift || 0; + my($ancestors) = shift || []; # a module needs to recurse to its cpan_file, a distribution needs # to recurse into its prereq_pms, a bundle needs to recurse into its modules return if exists $self->{incommandcolor} && $self->{incommandcolor}==$color; - $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ". - "color_cmd_tmps depth[%s] self[%s] id[%s]", - $depth, - $self, - $self->id - )) if $depth>=100; - ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; + if ($depth>=100){ + $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors)); + } + # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; for my $c ( $self->contains ) { my $obj = CPAN::Shell->expandany($c) or next; CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG; - $obj->color_cmd_tmps($depth+1,$color); + $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); } if ($color==0) { delete $self->{badtestcnt}; @@ -5160,12 +5203,13 @@ No File found for bundle } . $self->id . qq{\n}), return; package CPAN::Module; # Accessors -# sub cpan_userid { shift->{RO}{CPAN_USERID} } +# sub CPAN::Module::userid sub userid { my $self = shift; return unless exists $self->{RO}; # should never happen - return $self->{RO}{CPAN_USERID} || $self->{RO}{userid}; + return $self->{RO}{userid} || $self->{RO}{CPAN_USERID}; } +# sub CPAN::Module::description sub description { shift->{RO}{description} } sub undelay { @@ -5181,20 +5225,18 @@ sub color_cmd_tmps { my($self) = shift; my($depth) = shift || 0; my($color) = shift || 0; + my($ancestors) = shift || []; # a module needs to recurse to its cpan_file return if exists $self->{incommandcolor} && $self->{incommandcolor}==$color; - $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ". - "color_cmd_tmps depth[%s] self[%s] id[%s]", - $depth, - $self, - $self->id - )) if $depth>=100; - ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; + if ($depth>=100){ + $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors)); + } + # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) { - $dist->color_cmd_tmps($depth+1,$color); + $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); } if ($color==0) { delete $self->{badtestcnt}; @@ -5233,7 +5275,7 @@ sub as_glimpse { sub as_string { my($self) = @_; my(@m); - CPAN->debug($self) if $CPAN::DEBUG; + CPAN->debug("$self entering as_string") if $CPAN::DEBUG; my $class = ref($self); $class =~ s/^CPAN:://; local($^W) = 0; @@ -5243,7 +5285,8 @@ sub as_string { if $self->description; my $sprintf2 = " %-12s %s (%s)\n"; my($userid); - if ($userid = $self->cpan_userid || $self->userid){ + $userid = $self->userid; + if ( $userid ){ my $author; if ($author = CPAN::Shell->expand('Author',$userid)) { my $email = ""; @@ -5267,8 +5310,8 @@ sub as_string { 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,; + @stats{qw,? m d u n a,} = qw,unknown mailing-list + developer comp.lang.perl.* none abandoned,; @statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,; @stati{qw,? f r O h,} = qw,unknown functions references+ties object-oriented hybrid,; @@ -5400,7 +5443,7 @@ sub cpan_file { } return "Contact Author $fullname <$email>"; } else { - return "UserID $userid"; + return "Contact Author $userid (Email address not available)"; } } else { return "N/A"; @@ -5507,6 +5550,13 @@ sub install { } else { $doit = 1; } + if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") { + $CPAN::Frontend->mywarn(qq{ +\n\n\n ***WARNING*** + The module $self->{ID} has no active maintainer.\n\n\n +}); + sleep 5; + } $self->rematein('install') if $doit; } #-> sub CPAN::Module::clean ; @@ -5972,7 +6022,7 @@ stalled. =head1 DESCRIPTION The CPAN module is designed to automate the make and install of perl -modules and extensions. It includes some searching capabilities and +modules and extensions. It includes some primitive searching capabilities and knows how to use Net::FTP or LWP (or lynx or an external ftp client) to fetch the raw data from the net. @@ -6693,12 +6743,19 @@ with this floppy. See also below the paragraph about CD-ROM support. =head1 CONFIGURATION -When the CPAN module is installed, a site wide configuration file is -created as CPAN/Config.pm. The default values defined there can be -overridden in another configuration file: CPAN/MyConfig.pm. You can -store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because -$HOME/.cpan is added to the search path of the CPAN module before the -use() or require() statements. +When the CPAN module is used for the first time, a configuration +dialog tries to determine a couple of site specific options. The +result of the dialog is stored in a hash reference C< $CPAN::Config > +in a file CPAN/Config.pm. + +The default values defined in the CPAN/Config.pm file can be +overridden in a user specific file: CPAN/MyConfig.pm. Such a file is +best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is +added to the search path of the CPAN module before the use() or +require() statements. + +The configuration dialog can be started any time later again by +issueing the command C< o conf init > in the CPAN shell. Currently the following keys in the hash reference $CPAN::Config are defined: