X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCPAN.pm;h=bbebf6fe81bb6323ed68d6c955f1eea39a47a4f9;hb=46726cbe13a1bbdca5ff648034840cd7466b80c5;hp=0c6b5d92502fcf6979da2dcda112c8b585ad6261;hpb=f14b5cec44a20371f37547f211a9de1d22dda6cb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/CPAN.pm b/lib/CPAN.pm index 0c6b5d9..bbebf6f 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1,17 +1,18 @@ package CPAN; -use vars qw{$Try_autoload $Revision +use vars qw{$Try_autoload + $Revision $META $Signal $Cwd $End $Suppress_readline %Dontload $Frontend $Defaultsite - }; + }; #}; -$VERSION = '1.47'; +$VERSION = '1.52'; -# $Id: CPAN.pm,v 1.256 1999/01/25 13:06:22 k Exp $ +# $Id: CPAN.pm,v 1.276 2000/01/08 15:29:46 k Exp $ # only used during development: $Revision = ""; -# $Revision = "[".substr(q$Revision: 1.256 $, 10)."]"; +# $Revision = "[".substr(q$Revision: 1.276 $, 10)."]"; use Carp (); use Config (); @@ -60,7 +61,7 @@ use strict qw(vars); @CPAN::ISA = qw(CPAN::Debug Exporter); @EXPORT = qw( - autobundle bundle expand force get + autobundle bundle expand force get cvs_import install make readme recompile shell test clean ); @@ -70,6 +71,7 @@ sub AUTOLOAD { $l =~ s/.*:://; my(%EXPORT); @EXPORT{@EXPORT} = ''; + CPAN::Config->load unless $CPAN::Config_loaded++; if (exists $EXPORT{$l}){ CPAN::Shell->$l(@_); } else { @@ -87,7 +89,9 @@ sub AUTOLOAD { #-> sub CPAN::shell ; sub shell { - $Suppress_readline ||= ! -t STDIN; + my($self) = @_; + $Suppress_readline = ! -t STDIN unless defined $Suppress_readline; + CPAN::Config->load unless $CPAN::Config_loaded++; my $prompt = "cpan> "; local($^W) = 1; @@ -95,8 +99,26 @@ sub shell { require Term::ReadLine; # import Term::ReadLine; $term = Term::ReadLine->new('CPAN Monitor'); - $readline::rl_completion_function = - $readline::rl_completion_function = 'CPAN::Complete::cpl'; + if ($term->ReadLine eq "Term::ReadLine::Gnu") { + my $attribs = $term->Attribs; +# $attribs->{completion_entry_function} = +# $attribs->{'list_completion_function'}; + $attribs->{attempted_completion_function} = sub { + &CPAN::Complete::gnu_cpl; + } +# $attribs->{completion_word} = +# [qw(help me somebody to find out how +# to use completion with GNU)]; + } else { + $readline::rl_completion_function = + $readline::rl_completion_function = 'CPAN::Complete::cpl'; + } + # $term->OUT is autoflushed anyway + my $odef = select STDERR; + $| = 1; + select STDOUT; + $| = 1; + select $odef; } no strict; @@ -104,6 +126,8 @@ sub shell { my $getcwd; $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; my $cwd = CPAN->$getcwd(); + my $try_detect_readline; + $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term; my $rl_avail = $Suppress_readline ? "suppressed" : ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : "available (try ``install Bundle::CPAN'')"; @@ -163,6 +187,21 @@ ReadLine support $rl_avail } } continue { $Signal=0; + CPAN::Queue->nullify_queue; + if ($try_detect_readline) { + if ($CPAN::META->has_inst("Term::ReadLine::Gnu") + || + $CPAN::META->has_inst("Term::ReadLine::Perl") + ) { + delete $INC{"Term/ReadLine.pm"}; + my $redef; + local($SIG{__WARN__}) = CPAN::Shell::dotdot_onreload(\$redef); + require Term::ReadLine; + $CPAN::Frontend->myprint("\n$redef subroutines in ". + "Term::ReadLine redefined\n"); + goto &shell; + } + } } } @@ -282,7 +321,7 @@ sub try_dot_al { } } else { - $ok = 1; + $ok = 1; } $@ = $save; @@ -300,7 +339,7 @@ sub try_dot_al { # $Try_autoload = 1; if ($CPAN::Try_autoload) { - my $p; + my $p; for $p (qw( CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP @@ -427,13 +466,16 @@ sub delete { # warn "Deleting Queue object for mod[$mod] all[@all]"; } +sub nullify_queue { + @All = (); +} + + + package CPAN; $META ||= CPAN->new; # In case we re-eval ourselves we need the || -# Do this after you have set up the whole inheritance -CPAN::Config->load unless defined $CPAN::No_Config_is_ok; - 1; # __END__ # uncomment this and AutoSplit version 1.01 will split it @@ -456,12 +498,14 @@ sub clean; sub test; #-> sub CPAN::all ; -sub all { +sub all_objects { my($mgr,$class) = @_; + CPAN::Config->load unless $CPAN::Config_loaded++; CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG; CPAN::Index->reload; values %{ $META->{$class} }; } +*all = \&all_objects; # Called by shell, not in batch mode. Not clean XXX #-> sub CPAN::checklock ; @@ -503,7 +547,40 @@ You may want to kill it and delete the lockfile, maybe. On UNIX try: } } } - File::Path::mkpath($CPAN::Config->{cpan_home}); + my $dotcpan = $CPAN::Config->{cpan_home}; + eval { File::Path::mkpath($dotcpan);}; + if ($@) { + # A special case at least for Jarkko. + my $firsterror = $@; + my $seconderror; + my $symlinkcpan; + if (-l $dotcpan) { + $symlinkcpan = readlink $dotcpan; + die "readlink $dotcpan failed: $!" unless defined $symlinkcpan; + eval { File::Path::mkpath($symlinkcpan); }; + if ($@) { + $seconderror = $@; + } else { + $CPAN::Frontend->mywarn(qq{ +Working directory $symlinkcpan created. +}); + } + } + unless (-d $dotcpan) { + my $diemess = qq{ +Your configuration suggests "$dotcpan" as your +CPAN.pm working directory. I could not create this directory due +to this error: $firsterror\n}; + $diemess .= qq{ +As "$dotcpan" is a symlink to "$symlinkcpan", +I tried to create that, but I failed with this error: $seconderror +} if $seconderror; + $diemess .= qq{ +Please make sure the directory exists and is writable. +}; + $CPAN::Frontend->mydie($diemess); + } + } my $fh; unless ($fh = FileHandle->new(">$lockfile")) { if ($! =~ /Permission/) { @@ -544,6 +621,27 @@ or print "Caught SIGINT\n"; $Signal++; }; + +# From: Larry Wall +# Subject: Re: deprecating SIGDIE +# To: perl5-porters@perl.org +# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT) +# +# The original intent of __DIE__ was only to allow you to substitute one +# kind of death for another on an application-wide basis without respect +# to whether you were in an eval or not. As a global backstop, it should +# not be used any more lightly (or any more heavily :-) than class +# UNIVERSAL. Any attempt to build a general exception model on it should +# be politely squashed. Any bug that causes every eval {} to have to be +# modified should be not so politely squashed. +# +# Those are my current opinions. It is also my optinion that polite +# arguments degenerate to personal arguments far too frequently, and that +# when they do, it's because both people wanted it to, or at least didn't +# sufficiently want it not to. +# +# Larry + $SIG{'__DIE__'} = \&cleanup; $self->debug("Signal handler set.") if $CPAN::DEBUG; } @@ -748,7 +846,7 @@ sub disk_usage { if ($^O eq 'MacOS') { require Mac::Files; my $cat = Mac::Files::FSpGetCatInfo($_); - $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen(); + $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat; } else { $Du += (-s _); } @@ -1067,7 +1165,8 @@ Known options: commit commit session changes to disk init go through a dialog to set all parameters -You may edit key values in the follow fashion: +You may edit key values in the follow fashion (the "o" is a literal +letter o): o conf build_cache 15 @@ -1113,29 +1212,29 @@ sub h { $CPAN::Frontend->myprint("Detailed help not yet implemented\n"); } else { $CPAN::Frontend->myprint(q{ -command arguments description -a string authors -b or display bundles -d /regex/ info distributions -m or about modules -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 -}); +Display Information + a authors + b string display bundles + d or info distributions + m /regex/ about modules + i or anything of above + r none reinstall recommendations + u uninstalled distributions + +Download, Test, Make, Install... + get download + make make (implies get) + test modules, make test (implies make) + install dists, bundles make install (implies test) + clean make clean + look open subshell in these dists' directories + readme display these dists' README files + +Other + h,? display this menu ! perl-code eval a perl command + o conf [opt] set and query options q quit the cpan shell + reload cpan load CPAN.pm again reload index load newer indices + autobundle Snapshot force cmd unconditionally do cmd}); } } @@ -1257,10 +1356,13 @@ sub o { } } } else { - $CPAN::Frontend->myprint("Valid options for debug are ". - join(", ",sort(keys %CPAN::DEBUG), 'all'). - qq{ or a number. Completion works on the options. }. - qq{Case is ignored.\n\n}); + my $raw = "Valid options for debug are ". + join(", ",sort(keys %CPAN::DEBUG), 'all'). + qq{ or a number. Completion works on the options. }. + qq{Case is ignored.}; + require Text::Wrap; + $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw)); + $CPAN::Frontend->myprint("\n\n"); } if ($CPAN::DEBUG) { $CPAN::Frontend->myprint("Options set for debugging:\n"); @@ -1281,6 +1383,21 @@ Known options: } } +sub dotdot_onreload { + my($ref) = shift; + sub { + if ( $_[0] =~ /Subroutine (\w+) redefined/ ) { + my($subr) = $1; + ++$$ref; + local($|) = 1; + # $CPAN::Frontend->myprint(".($subr)"); + $CPAN::Frontend->myprint("."); + return; + } + warn @_; + }; +} + #-> sub CPAN::Shell::reload ; sub reload { my($self,$command,@arg) = @_; @@ -1291,18 +1408,7 @@ sub reload { my $fh = FileHandle->new($INC{'CPAN.pm'}); local($/); $redef = 0; - local($SIG{__WARN__}) - = sub { - if ( $_[0] =~ /Subroutine (\w+) redefined/ ) { - my($subr) = $1; - ++$redef; - local($|) = 1; - # $CPAN::Frontend->myprint(".($subr)"); - $CPAN::Frontend->myprint("."); - return; - } - warn @_; - }; + local($SIG{__WARN__}) = dotdot_onreload(\$redef); eval <$fh>; warn $@ if $@; $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); @@ -1465,6 +1571,7 @@ sub u { #-> sub CPAN::Shell::autobundle ; sub autobundle { my($self) = shift; + CPAN::Config->load unless $CPAN::Config_loaded++; my(@bundle) = $self->_u_r_common("a",@_); my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle"); File::Path::mkpath($todir); @@ -1521,21 +1628,34 @@ sub expand { 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 + for $obj ( + sort + {$a->id cmp $b->id} + $CPAN::META->all_objects($class) + ) { + unless ($obj->id){ + # BUG, we got an empty object somewhere + CPAN->debug(sprintf( + "Empty id on obj[%s]%%[%s]", + $obj, + join(":", %$obj) + )) if $CPAN::DEBUG; + next; + } + push @m, $obj + if $obj->id =~ /$regex/i + or ( ( - $] < 5.00303 ### provide sort of compatibility with 5.003 + $] < 5.00303 ### provide sort of + ### compatibility with 5.003 || $obj->can('name') ) && $obj->name =~ /$regex/i ); - } + } } else { my($xarg) = $arg; if ( $type eq 'Bundle' ) { @@ -1629,6 +1749,15 @@ sub mydie { die "\n"; } +sub setup_output { + return if -t STDOUT; + my $odef = select STDERR; + $| = 1; + select STDOUT; + $| = 1; + select $odef; +} + #-> sub CPAN::Shell::rematein ; # RE-adme||MA-ke||TE-st||IN-stall sub rematein { @@ -1639,6 +1768,7 @@ sub rematein { $pragma = $meth; $meth = shift @some; } + setup_output(); CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG; my($s,@s); foreach $s (@some) { @@ -1715,6 +1845,8 @@ sub install { shift->rematein('install',@_); } sub clean { shift->rematein('clean',@_); } #-> sub CPAN::Shell::look ; sub look { shift->rematein('look',@_); } +#-> sub CPAN::Shell::cvs_import ; +sub cvs_import { shift->rematein('cvs_import',@_); } package CPAN::FTP; @@ -1841,7 +1973,7 @@ sub localize { to insufficient permissions.\n}) unless -w $aslocal_dir; # Inheritance is not easier to manage than a few if/else branches - if ($CPAN::META->has_inst('LWP')) { + if ($CPAN::META->has_inst('LWP::UserAgent')) { require LWP::UserAgent; unless ($Ua) { $Ua = LWP::UserAgent->new; @@ -1891,6 +2023,9 @@ sub localize { my $ret = $self->$method(\@host_seq,$file,$aslocal); if ($ret) { $Themethod = $level; + my $now = time; + # utime $now, $now, $aslocal; # too bad, if we do that, we + # might alter a local mirror $self->debug("level[$level]") if $CPAN::DEBUG; return $ret; } else { @@ -1940,8 +2075,11 @@ sub hosteasy { # 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 + ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part + $l =~ s|^file:||; # assume they + # meant + # file://localhost + $l =~ s|^/|| unless -f $l; # e.g. /P: } if ( -f $l && -r _) { $Thesite = $i; @@ -1968,6 +2106,9 @@ sub hosteasy { my $res = $Ua->mirror($url, $aslocal); if ($res->is_success) { $Thesite = $i; + my $now = time; + utime $now, $now, $aslocal; # download time is more + # important than upload time return $aslocal; } elsif ($url !~ /\.gz$/) { my $gzurl = "$url.gz"; @@ -2042,8 +2183,8 @@ sub hosthard { HOSTHARD: for $i (@$host_seq) { my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite; unless ($self->is_reachable($url)) { - $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); - next; + $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); + next; } $url .= "/" unless substr($url,-1) eq "/"; $url .= $file; @@ -2053,90 +2194,107 @@ sub hosthard { # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { # to if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) { - # proto not yet used - ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4); + # proto not yet used + ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4); } else { - next HOSTHARD; # who said, we could ftp anything except ftp? + next HOSTHARD; # who said, we could ftp anything except ftp? } + $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; my($f,$funkyftp); for $f ('lynx','ncftpget','ncftp') { - next unless exists $CPAN::Config->{$f}; - $funkyftp = $CPAN::Config->{$f}; - next unless defined $funkyftp; - next if $funkyftp =~ /^\s*$/; - my($want_compressed); - my $aslocal_uncompressed; - ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; - my($source_switch) = ""; - $source_switch = " -source" if $funkyftp =~ /\blynx$/; - $source_switch = " -c" if $funkyftp =~ /\bncftp$/; - $CPAN::Frontend->myprint( - qq[ + next unless exists $CPAN::Config->{$f}; + $funkyftp = $CPAN::Config->{$f}; + next unless defined $funkyftp; + next if $funkyftp =~ /^\s*$/; + my($want_compressed); + my $aslocal_uncompressed; + ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; + my($source_switch) = ""; + if ($f eq "lynx"){ + $source_switch = " -source"; + } elsif ($f eq "ncftp"){ + $source_switch = " -c"; + } + my($chdir) = ""; + my($stdout_redir) = " > $aslocal_uncompressed"; + if ($f eq "ncftpget"){ + $chdir = "cd $aslocal_dir && "; + $stdout_redir = ""; + } + $CPAN::Frontend->myprint( + qq[ Trying with "$funkyftp$source_switch" to get $url ]); - my($system) = "$funkyftp$source_switch '$url' $devnull > ". - "$aslocal_uncompressed"; + my($system) = + "$chdir$funkyftp$source_switch '$url' $devnull$stdout_redir"; + $self->debug("system[$system]") if $CPAN::DEBUG; + my($wstatus); + if (($wstatus = system($system)) == 0 + && + ($f eq "lynx" ? + -s $aslocal_uncompressed # lynx returns 0 on my + # system even if it fails + : 1 + ) + ) { + if (-s $aslocal) { + # Looks good + } elsif ($aslocal_uncompressed ne $aslocal) { + # test gzip integrity + if ( + CPAN::Tarzip->gtest($aslocal_uncompressed) + ) { + rename $aslocal_uncompressed, $aslocal; + } else { + CPAN::Tarzip->gzip($aslocal_uncompressed, + "$aslocal_uncompressed.gz"); + } + } + $Thesite = $i; + return $aslocal; + } elsif ($url !~ /\.gz$/) { + unlink $aslocal_uncompressed if + -f $aslocal_uncompressed && -s _ == 0; + my $gz = "$aslocal.gz"; + my $gzurl = "$url.gz"; + $CPAN::Frontend->myprint( + qq[ +Trying with "$funkyftp$source_switch" to get + $url.gz +]); + my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ". + "$aslocal_uncompressed.gz"; $self->debug("system[$system]") if $CPAN::DEBUG; my($wstatus); if (($wstatus = system($system)) == 0 && - -s $aslocal_uncompressed # lynx returns 0 on my - # system even if it fails + -s "$aslocal_uncompressed.gz" ) { - if ($aslocal_uncompressed ne $aslocal) { - # test gzip integrity - if ( - CPAN::Tarzip->gtest($aslocal_uncompressed) - ) { - rename $aslocal_uncompressed, $aslocal; - } else { - CPAN::Tarzip->gzip($aslocal_uncompressed, - "$aslocal_uncompressed.gz"); - } - } - $Thesite = $i; - return $aslocal; - } elsif ($url !~ /\.gz$/) { - unlink $aslocal_uncompressed if - -f $aslocal_uncompressed && -s _ == 0; - my $gz = "$aslocal.gz"; - my $gzurl = "$url.gz"; - $CPAN::Frontend->myprint( - qq[ -Trying with "$funkyftp$source_switch" to get - $url.gz -]); - my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ". - "$aslocal_uncompressed.gz"; - $self->debug("system[$system]") if $CPAN::DEBUG; - my($wstatus); - if (($wstatus = system($system)) == 0 - && - -s "$aslocal_uncompressed.gz" - ) { - # test gzip integrity - if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) { - CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz", - $aslocal); - } else { - rename $aslocal_uncompressed, $aslocal; - } - $Thesite = $i; - return $aslocal; + # test gzip integrity + if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) { + CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz", + $aslocal); } else { - unlink "$aslocal_uncompressed.gz" if - -f "$aslocal_uncompressed.gz"; + rename $aslocal_uncompressed, $aslocal; } + $Thesite = $i; + return $aslocal; } else { - my $estatus = $wstatus >> 8; - my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : ""; - $CPAN::Frontend->myprint(qq{ + unlink "$aslocal_uncompressed.gz" if + -f "$aslocal_uncompressed.gz"; + } + } else { + my $estatus = $wstatus >> 8; + my $size = -f $aslocal ? + ", left\n$aslocal with size ".-s _ : + "\nWarning: expected file [$aslocal] doesn't exist"; + $CPAN::Frontend->myprint(qq{ System call "$system" returned status $estatus (wstat $wstatus)$size }); - } + } } } } @@ -2164,12 +2322,12 @@ sub hosthardest { next; } my($host,$dir,$getfile) = ($1,$2,$3); - my($netrcfile,$fh); my $timestamp = 0; my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime, $ctime,$blksize,$blocks) = stat($aslocal); $timestamp = $mtime ||= 0; my($netrc) = CPAN::FTP::netrc->new; + my($netrcfile) = $netrc->netrc; my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : ""; my $targetfile = File::Basename::basename($aslocal); my(@dialog); @@ -2182,7 +2340,7 @@ sub hosthardest { "get $getfile $targetfile", "quit" ); - if (! $netrc->netrc) { + if (! $netrcfile) { CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG; } elsif ($netrc->hasdefault || $netrc->contains($host)) { CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]", @@ -2217,7 +2375,7 @@ sub hosthardest { $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host nor does it have a default entry\n"); } - + # OK, they don't have a valid ~/.netrc. Use 'ftp -n' # then and login manually to host, using e-mail as # password. @@ -2381,6 +2539,27 @@ sub contains { package CPAN::Complete; +sub gnu_cpl { + my($text, $line, $start, $end) = @_; + my(@perlret) = cpl($text, $line, $start); + # find longest common match. Can anybody show me how to peruse + # T::R::Gnu to have this done automatically? Seems expensive. + return () unless @perlret; + my($newtext) = $text; + for (my $i = length($text)+1;;$i++) { + last unless length($perlret[0]) && length($perlret[0]) >= $i; + my $try = substr($perlret[0],0,$i); + my @tries = grep {substr($_,0,$i) eq $try} @perlret; + # warn "try[$try]tries[@tries]"; + if (@tries == @perlret) { + $newtext = $try; + } else { + last; + } + } + ($newtext,@perlret); +} + #-> sub CPAN::Complete::cpl ; sub cpl { my($word,$line,$pos) = @_; @@ -2398,10 +2577,10 @@ sub cpl { /^$word/, sort qw( ! a b d h i m o q r u autobundle clean - make test install force reload look + make test install force reload look cvs_import ) ); - } elsif ( $line !~ /^[\!abdhimorutl]/ ) { + } elsif ( $line !~ /^[\!abcdhimorutl]/ ) { @return = (); } elsif ($line =~ /^a\s/) { @return = cplx('CPAN::Author',$word); @@ -2409,7 +2588,7 @@ sub cpl { @return = cplx('CPAN::Bundle',$word); } elsif ($line =~ /^d\s/) { @return = cplx('CPAN::Distribution',$word); - } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) { + } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look|cvs_import)\s/ ) { @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); } elsif ($line =~ /^i\s/) { @return = cpl_any($word); @@ -2426,7 +2605,7 @@ sub cpl { #-> sub CPAN::Complete::cplx ; sub cplx { my($class, $word) = @_; - grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class); + grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class); } #-> sub CPAN::Complete::cpl_any ; @@ -2487,10 +2666,15 @@ sub reload { # XXX check if a newer one is available. (We currently read it # from time to time) for ($CPAN::Config->{index_expire}) { - $_ = 0.001 unless $_ > 0.001; + $_ = 0.001 unless $_ && $_ > 0.001; } return if $last_time + $CPAN::Config->{index_expire}*86400 > $time and ! $force; + ## IFF we are developing, it helps to wipe out the memory between + ## reloads, otherwise it is not what a user expects. + + ## undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274) + ## $CPAN::META = CPAN->new; my($debug,$t2); $last_time = $time; @@ -2610,7 +2794,7 @@ sub rd_modpacks { my($mod,$version,$dist) = split; ### $version =~ s/^\+//; - # if it is a bundle, instatiate a bundle object + # if it is a bundle, instantiate a bundle object my($bundle,$id,$userid); if ($mod eq 'CPAN' && @@ -2623,6 +2807,7 @@ sub rd_modpacks { if ($version > $CPAN::VERSION){ $CPAN::Frontend->myprint(qq{ There\'s a new CPAN.pm version (v$version) available! + [Current version is v$CPAN::VERSION] You might want to try install Bundle::CPAN reload cpan @@ -2666,12 +2851,20 @@ sub rd_modpacks { } # instantiate a distribution object - unless ($CPAN::META->exists('CPAN::Distribution',$dist)) { - $CPAN::META->instance( - 'CPAN::Distribution' => $dist - )->set( - 'CPAN_USERID' => $userid - ); + if ($CPAN::META->exists('CPAN::Distribution',$dist)) { + # we do not need CONTAINSMODS unless we do something with + # this dist, so we better produce it on demand. + + ## my $obj = $CPAN::META->instance( + ## 'CPAN::Distribution' => $dist + ## ); + ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental + } else { + $CPAN::META->instance( + 'CPAN::Distribution' => $dist + )->set( + 'CPAN_USERID' => $userid + ); } return if $CPAN::Signal; @@ -2764,9 +2957,15 @@ sub as_string { $extra .= ")"; } if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX - push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; + push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; + } elsif (ref($self->{$_}) eq "HASH") { + push @m, sprintf( + " %-12s %s%s\n", + $_, + join(" ",keys %{$self->{$_}}), + $extra); } else { - push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; + push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; } } join "", @m, "\n"; @@ -2778,6 +2977,12 @@ sub author { $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname; } +sub dump { + my($self) = @_; + require Data::Dumper; + Data::Dumper::Dumper($self); +} + package CPAN::Author; #-> sub CPAN::Author::as_glimpse ; @@ -2799,11 +3004,31 @@ sub as_glimpse { #-> sub CPAN::Author::fullname ; sub fullname { shift->{'FULLNAME'} } *name = \&fullname; + #-> sub CPAN::Author::email ; sub email { shift->{'EMAIL'} } package CPAN::Distribution; +#-> sub CPAN::Distribution::as_string ; +sub as_string { + my $self = shift; + $self->containsmods; + $self->SUPER::as_string(@_); +} + +#-> sub CPAN::Distribution::containsmods ; +sub containsmods { + my $self = shift; + return if exists $self->{CONTAINSMODS}; + for my $mod ($CPAN::META->all_objects("CPAN::Module")) { + my $mod_file = $mod->{CPAN_FILE} or next; + my $dist_id = $self->{ID} or next; + my $mod_id = $mod->{ID} or next; + $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id; + } +} + #-> sub CPAN::Distribution::called_for ; sub called_for { my($self,$id) = @_; @@ -2979,6 +3204,12 @@ sub new { #-> sub CPAN::Distribution::look ; sub look { my($self) = @_; + + if ($^O eq 'MacOS') { + $self->ExtUtils::MM_MacOS::look; + return; + } + if ( $CPAN::Config->{'shell'} ) { $CPAN::Frontend->myprint(qq{ Trying to open a subshell in the build directory... @@ -3003,6 +3234,44 @@ Please define it with "o conf shell " chdir($pwd); } +sub cvs_import { + my($self) = @_; + $self->get; + my $dir = $self->dir; + + my $package = $self->called_for; + my $module = $CPAN::META->instance('CPAN::Module', $package); + my $version = $module->cpan_version; + + my $userid = $self->{CPAN_USERID}; + + my $cvs_dir = (split '/', $dir)[-1]; + $cvs_dir =~ s/-\d+[^-]+$//; + my $cvs_root = + $CPAN::Config->{cvsroot} || $ENV{CVSROOT}; + my $cvs_site_perl = + $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL}; + if ($cvs_site_perl) { + $cvs_dir = "$cvs_site_perl/$cvs_dir"; + } + my $cvs_log = qq{"imported $package $version sources"}; + $version =~ s/\./_/g; + my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log, + "$cvs_dir", $userid, "v$version"); + + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my $pwd = CPAN->$getcwd(); + chdir($dir); + + $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); + + $CPAN::Frontend->myprint(qq{@cmd\n}); + system(@cmd) == 0 or + $CPAN::Frontend->mydie("cvs import failed"); + chdir($pwd); +} + #-> sub CPAN::Distribution::readme ; sub readme { my($self) = @_; @@ -3121,7 +3390,7 @@ sub MD5_check_file { my $md5 = MD5->new; my($data,$ref); $ref = \$data; - while ($fh->READ($ref, 4096)){ + while ($fh->READ($ref, 4096) > 0){ $md5->add($data); } my $hexdigest = $md5->hexdigest; @@ -3185,7 +3454,7 @@ sub force { $self->{'force_update'}++; for my $att (qw( MD5_STATUS archived build_dir localfile make install unwrapped - writemakefile have_sponsored + writemakefile )) { delete $self->{$att}; } @@ -3266,8 +3535,8 @@ or "had problems unarchiving. Please build manually"; exists $self->{writemakefile} && - $self->{writemakefile} eq "NO" and push @e, - "Had some problem writing Makefile"; + $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e, + $1 || "Had some problem writing Makefile"; defined $self->{'make'} and push @e, "Has already been processed within this session"; @@ -3324,18 +3593,27 @@ or kill 9, $pid; waitpid $pid, 0; $CPAN::Frontend->myprint($@); - $self->{writemakefile} = "NO - $@"; + $self->{writemakefile} = "NO $@"; $@ = ""; return; } } else { $ret = system($system); if ($ret != 0) { - $self->{writemakefile} = "NO"; + $self->{writemakefile} = "NO Makefile.PL returned status $ret"; return; } } - $self->{writemakefile} = "YES"; + if (-f "Makefile") { + $self->{writemakefile} = "YES"; + } else { + $self->{writemakefile} = + qq{NO Makefile.PL refused to write a Makefile.}; + # It's probably worth to record the reason, so let's retry + # local $/; + # my $fh = IO::File->new("$system |"); # STDERR? STDIN? + # $self->{writemakefile} .= <$fh>; + } } return if $CPAN::Signal; if (my @prereq = $self->needs_prereq){ @@ -3369,7 +3647,7 @@ of modules we are processing right now?", "yes"); $CPAN::Frontend->myprint(" $system -- OK\n"); $self->{'make'} = "YES"; } else { - $self->{writemakefile} = "YES"; + $self->{writemakefile} ||= "YES"; $self->{'make'} = "NO"; $CPAN::Frontend->myprint(" $system -- NOT OK\n"); } @@ -3402,7 +3680,7 @@ sub needs_prereq { next if $mo->uptodate; # it's not needed, so don't push it. We cannot omit this step, because # if 'force' is in effect, nobody else will check. - if ($self->{'have_sponsored'}{$p}++){ + if ($self->{have_sponsored}{$p}++){ # We have already sponsored it and for some reason it's still # not available. So we do nothing. Or what should we do? # if we push it again, we have a potential infinite loop @@ -3585,13 +3863,14 @@ sub contains { my $fh = FileHandle->new; local $/ = "\n"; open($fh,$parsefile) or die "Could not open '$parsefile': $!"; - my $inpod = 0; + my $in_cont = 0; $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; while (<$fh>) { - $inpod = m/^=(?!head1\s+CONTENTS)/ ? 0 : - m/^=head1\s+CONTENTS/ ? 1 : $inpod; - next unless $inpod; + $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 : + m/^=head1\s+CONTENTS/ ? 1 : $in_cont; + next unless $in_cont; next if /^=/; + s/\#.*//; next if /^\s+$/; chomp; push @result, (split " ", $_, 2)[0]; @@ -3637,7 +3916,7 @@ sub find_bundle_file { $what2 =~ s/:Bundle://; $what2 =~ tr|:|/|; } else { - $what2 =~ s|Bundle/||; + $what2 =~ s|Bundle[/\\]||; } my $bu; while (<$fh>) { @@ -3703,13 +3982,19 @@ explicitly a file $s. # recap with less noise if ( $meth eq "install") { if (%fail) { - $CPAN::Frontend->myprint(qq{\nBundle summary: }. - qq{The following items seem to }. - qq{have had installation problems:\n}); + require Text::Wrap; + my $raw = sprintf(qq{Bundle summary: +The following items in bundle %s had installation problems:}, + $self->id + ); + $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw)); + $CPAN::Frontend->myprint("\n"); + my $paragraph = ""; for $s ($self->contains) { - $CPAN::Frontend->myprint( "$s " ) if $fail{$s}; + $paragraph .= "$s " if $fail{$s}; } - $CPAN::Frontend->myprint(qq{\n}); + $CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph)); + $CPAN::Frontend->myprint("\n"); } else { $self->{'install'} = 'YES'; } @@ -3939,6 +4224,8 @@ sub rematein { sub readme { shift->rematein('readme') } #-> sub CPAN::Module::look ; sub look { shift->rematein('look') } +#-> sub CPAN::Module::cvs_import ; +sub cvs_import { shift->rematein('cvs_import') } #-> sub CPAN::Module::get ; sub get { shift->rematein('get',@_); } #-> sub CPAN::Module::make ; @@ -4019,7 +4306,7 @@ sub inst_version { local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38; # warn "HERE"; my $have = MM->parse_version($parsefile) || "undef"; - $have =~ s/\s+//g; + $have =~ s/\s*//g; # stringify to float around floating point issues $have; } @@ -4102,7 +4389,7 @@ sub READLINE { my $gz = $self->{GZ}; my($line,$bytesread); $bytesread = $gz->gzreadline($line); - return undef if $bytesread == 0; + return undef if $bytesread <= 0; return $line; } else { my $fh = $self->{FH}; @@ -4130,7 +4417,7 @@ sub DESTROY { $gz->gzclose(); } else { my $fh = $self->{FH}; - $fh->close; + $fh->close if defined $fh; } undef $self; } @@ -4141,29 +4428,30 @@ sub untar { if (MM->maybe_command($CPAN::Config->{'gzip'}) && MM->maybe_command($CPAN::Config->{'tar'})) { - if ($^O =~ /win/i) { # irgggh - # people find the most curious tar binaries that cannot handle - # pipes - my $system = "$CPAN::Config->{'gzip'} --decompress $file"; - if (system($system)==0) { - $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); - } else { - $CPAN::Frontend->mydie( - qq{Couldn\'t uncompress $file\n} - ); - } - $file =~ s/\.gz$//; - $system = "$CPAN::Config->{tar} xvf $file"; - if (system($system)==0) { - $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); - } else { - $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); - } - return 1; + my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " . + "< $file | $CPAN::Config->{tar} xvf -"; + if (system($system) != 0) { + # people find the most curious tar binaries that cannot handle + # pipes + my $system = "$CPAN::Config->{'gzip'} --decompress $file"; + if (system($system)==0) { + $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); + } else { + $CPAN::Frontend->mydie( + qq{Couldn\'t uncompress $file\n} + ); + } + $file =~ s/\.gz$//; + $system = "$CPAN::Config->{tar} xvf $file"; + $CPAN::Frontend->myprint(qq{Using Tar:$system:\n}); + if (system($system)==0) { + $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); + } else { + $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); + } + return 1; } else { - my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " . - "< $file | $CPAN::Config->{tar} xvf -"; - return system($system) == 0; + return 1; } } elsif ($CPAN::META->has_inst("Archive::Tar") && @@ -4219,8 +4507,8 @@ Modules are fetched from one or more of the mirrored CPAN directory. The CPAN module also supports the concept of named and versioned -'bundles' of modules. Bundles simplify the handling of sets of -related modules. See BUNDLES below. +I of modules. Bundles simplify the handling of sets of +related modules. See Bundles below. The package contains a session manager and a cache manager. There is no status retained between sessions. The session manager keeps track @@ -4271,29 +4559,14 @@ objects. The parser recognizes a regular expression only if you enclose it between two slashes. The principle is that the number of found objects influences how an -item is displayed. If the search finds one item, the result is displayed -as object-Eas_string, but if we find more than one, we display -each as object-Eas_glimpse. E.g. - - cpan> a ANDK - Author id = ANDK - EMAIL a.koenig@franz.ww.TU-Berlin.DE - FULLNAME Andreas König - - - cpan> a /andk/ - Author id = ANDK - EMAIL a.koenig@franz.ww.TU-Berlin.DE - FULLNAME Andreas König - - - cpan> a /and.*rt/ - Author ANDYD (Andy Dougherty) - Author MERLYN (Randal L. Schwartz) +item is displayed. If the search finds one item, the result is +displayed with the rather verbose method C, but if we find +more than one, we display each object with the terse method +. =item make, test, install, clean modules or distributions -These commands take any number of arguments and investigates what is +These commands take any number of arguments and investigate what is necessary to perform the action. If the argument is a distribution file name (recognized by embedded slashes), it is processed. If it is a module, CPAN determines the distribution file in which this module @@ -4335,12 +4608,11 @@ A C command results in a being executed within the distribution file's working directory. -=item readme, look module or distribution +=item get, readme, look module or distribution -These two commands take only one argument, be it a module or a -distribution file. C unconditionally runs, displaying the -README of the associated distribution file. C gets and -untars (if not yet done) the distribution file, changes to the +C downloads a distribution file without further action. C +displays the README file of the associated distribution. C gets +and untars (if not yet done) the distribution file, changes to the appropriate directory and opens a subshell process in that directory. =item Signals @@ -4441,8 +4713,8 @@ functions in the calling package (C). There's currently only one class that has a stable interface - CPAN::Shell. All commands that are available in the CPAN shell are methods of the class CPAN::Shell. Each of the commands that produce -listings of modules (C, C, C) returns a list of the -IDs of all modules within the list. +listings of modules (C, C, C) also return a list of +the IDs of all modules within the list. =over 2 @@ -4477,6 +4749,41 @@ functionalities that are available in the shell. print "No VERSION in ", $mod->id, "\n"; } +Or if you want to write a cronjob to watch The CPAN, you could list +all modules that need updating: + + perl -e 'use CPAN; CPAN::Shell->r;' + +If you don't want to get any output if all modules are up to date, you +can parse the output of above command for the regular expression +//modules are up to date// and decide to mail the output only if it +doesn't match. Ick? + +If you prefer to do it more in a programmer style in one single +process, maybe something like this suites you better: + + # list all modules on my disk that have newer versions on CPAN + for $mod (CPAN::Shell->expand("Module","/./")){ + next unless $mod->inst_file; + next if $mod->uptodate; + printf "Module %s is installed as %s, could be updated to %s from CPAN\n", + $mod->id, $mod->inst_version, $mod->cpan_version; + } + +If that gives you too much output every day, you maybe only want to +watch for three modules. You can write + + for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){ + +as the first line instead. Or you can combine some of the above +tricks: + + # watch only for a new mod_perl module + $mod = CPAN::Shell->expand("Module","mod_perl"); + exit if $mod->uptodate; + # new mod_perl arrived, let me know all update recommendations + CPAN::Shell->r; + =back =head2 Methods in the four Classes @@ -4594,7 +4901,7 @@ you might use CPAN.pm to put together all you need on a networked machine. Then copy the $CPAN::Config->{keep_source_where} (but not $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind of a personal CPAN. CPAN.pm on the non-networked machines works nicely -with this floppy. +with this floppy. See also below the paragraph about CD-ROM support. =head1 CONFIGURATION @@ -4617,7 +4924,6 @@ defined: many seconds inactivity. Set to 0 to never break. inhibit_startup_message if true, does not print the startup message - keep_source keep the source in a local directory? keep_source_where directory in which to keep the source (if we do) make location of external make program make_arg arguments that should always be passed to 'make' @@ -4641,29 +4947,40 @@ shell with the command set defined within the C command: =over 2 -=item o conf Escalar optionE +=item Cscalar optionE> prints the current value of the I -=item o conf Escalar optionE EvalueE +=item Cscalar optionE EvalueE> Sets the value of the I to I -=item o conf Elist optionE +=item Clist optionE> prints the current value of the I in MakeMaker's neatvalue format. -=item o conf Elist optionE [shift|pop] +=item Clist optionE [shift|pop]> shifts or pops the array in the I variable -=item o conf Elist optionE [unshift|push|splice] ElistE +=item Clist optionE [unshift|push|splice] ElistE> works like the corresponding perl commands. =back +=head2 Note on urllist parameter's format + +urllist parameters are URLs according to RFC 1738. We do a little +guessing if your URL is not compliant, but if you have problems with file URLs, please try the correct format. Either: + + file://localhost/whatever/ftp/pub/CPAN/ + +or + + file:///home/ftp/pub/CPAN/ + =head2 urllist parameter has CD-ROM support The C parameter of the configuration table contains a list of @@ -4708,28 +5025,30 @@ To populate a freshly installed perl with my favorite modules is pretty easiest by maintaining a private bundle definition file. To get a useful blueprint of a bundle definition file, the command autobundle can be used on the CPAN shell command line. This command writes a bundle definition -file for all modules that re installed for the currently running perl +file for all modules that are installed for the currently running perl interpreter. It's recommended to run this command only once and from then on maintain the file manually under a private name, say Bundle/my_bundle.pm. With a clever bundle file you can then simply say cpan> install Bundle::my_bundle -then answer a few questions and then go out. +then answer a few questions and then go out for a coffee. -Maintaining a bundle definition file means to keep track of two things: -dependencies and interactivity. CPAN.pm (currently) does not take into -account dependencies between distributions, so a bundle definition file -should specify distributions that depend on others B the others. -On the other hand, it's a bit annoying that many distributions need some -interactive configuring. So what I try to accomplish in my private bundle -file is to have the packages that need to be configured early in the file -and the gentle ones later, so I can go out after a few minutes and leave -CPAN.pm unattained. +Maintaining a bundle definition file means to keep track of two +things: dependencies and interactivity. CPAN.pm sometimes fails on +calculating dependencies because not all modules define all MakeMaker +attributes correctly, so a bundle definition file should specify +prerequisites as early as possible. On the other hand, it's a bit +annoying that many distributions need some interactive configuring. So +what I try to accomplish in my private bundle file is to have the +packages that need to be configured early in the file and the gentle +ones later, so I can go out after a few minutes and leave CPAN.pm +unattained. =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS -Thanks to Graham Barr for contributing the firewall following howto. +Thanks to Graham Barr for contributing the following paragraphs about +the interaction between perl, and various firewall configurations. Firewalls can be categorized into three basic types. @@ -4748,10 +5067,10 @@ ftp) you will need to use LWP. =item ftp firewall -This where the firewall machine runs a ftp server. This kind of firewall will -only let you access ftp serves outside the firewall. This is usually done by -connecting to the firewall with ftp, then entering a username like -"user@outside.host.com" +This where the firewall machine runs a ftp server. This kind of +firewall will only let you access ftp servers outside the firewall. +This is usually done by connecting to the firewall with ftp, then +entering a username like "user@outside.host.com" To access servers outside these type of firewalls with perl you will need to use Net::FTP. @@ -4788,7 +5107,7 @@ special compiling is need as you can access hosts directly. =head1 BUGS -We should give coverage for _all_ of the CPAN and not just the PAUSE +We should give coverage for B of the CPAN and not just the PAUSE part, right? In this discussion CPAN and PAUSE have become equal -- but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus the clpa/, doc/, misc/, ports/, src/, scripts/. @@ -4803,7 +5122,7 @@ traditional method of building a Perl module package from a shell. =head1 AUTHOR -Andreas König Ea.koenig@kulturbox.deE +Andreas Koenig Eandreas.koenig@anima.deE =head1 SEE ALSO