# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN;
-$VERSION = '1.76_02';
+$VERSION = '1.83_55';
$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.412 $, 10)."]";
+use strict;
+use CPAN::HandleConfig;
+use CPAN::Version;
+use CPAN::Debug;
+use CPAN::Tarzip;
use Carp ();
use Config ();
use Cwd ();
-use DirHandle;
+use DirHandle ();
use Exporter ();
use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
use File::Basename ();
use File::Copy ();
use File::Find;
use File::Path ();
+use File::Spec ();
+use File::Temp ();
use FileHandle ();
use Safe ();
+use Sys::Hostname qw(hostname);
use Text::ParseWords ();
-use Text::Wrap;
-use File::Spec;
-use Sys::Hostname;
+use Text::Wrap ();
no lib "."; # we need to run chdir all over and we would get at wrong
# libraries there
require Mac::BuildTools if $^O eq 'MacOS';
-END { $End++; &cleanup; }
-
-%CPAN::DEBUG = qw[
- CPAN 1
- Index 2
- InfoObj 4
- Author 8
- Distribution 16
- Bundle 32
- Module 64
- CacheMgr 128
- Complete 256
- FTP 512
- Shell 1024
- Eval 2048
- Config 4096
- Tarzip 8192
- Version 16384
- Queue 32768
-];
-
-$CPAN::DEBUG ||= 0;
+END { $CPAN::End++; &cleanup; }
+
$CPAN::Signal ||= 0;
$CPAN::Frontend ||= "CPAN::Shell";
$CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
+# $CPAN::iCwd (i for initial) is going to be initialized during find_perl
+$CPAN::Perl ||= CPAN::find_perl();
+$CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
+$CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
+
package CPAN;
-use strict qw(vars);
+use strict;
use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
- $Revision $Signal $End $Suppress_readline $Frontend
- $Defaultsite $Have_warned);
+ $Signal $Suppress_readline $Frontend
+ $Defaultsite $Have_warned $Defaultdocs $Defaultrecent
+ $Be_Silent );
@CPAN::ISA = qw(CPAN::Debug Exporter);
@EXPORT = qw(
- autobundle bundle expand force get cvs_import
+ autobundle bundle expand force notest get cvs_import
install make readme recompile shell test clean
+ perldoc recent
);
+sub soft_chdir_with_alternatives ($);
+
#-> sub CPAN::AUTOLOAD ;
sub AUTOLOAD {
my($l) = $AUTOLOAD;
$l =~ s/.*:://;
my(%EXPORT);
@EXPORT{@EXPORT} = '';
- CPAN::Config->load unless $CPAN::Config_loaded++;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
if (exists $EXPORT{$l}){
CPAN::Shell->$l(@_);
} else {
- $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
+ $CPAN::Frontend->mywarn(qq{Unknown CPAN command "$AUTOLOAD". }.
qq{Type ? for help.
});
}
sub shell {
my($self) = @_;
$Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
- CPAN::Config->load unless $CPAN::Config_loaded++;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
- my $oprompt = shift || "cpan> ";
+ my $oprompt = shift || CPAN::Prompt->new;
my $prompt = $oprompt;
my $commandline = shift || "";
+ $CPAN::CurrentCommandId ||= 1;
local($^W) = 1;
unless ($Suppress_readline) {
# no strict; # I do not recall why no strict was here (2000-09-03)
$META->checklock();
- my $cwd = CPAN::anycwd();
+ my @cwd = (CPAN::anycwd(),File::Spec->tmpdir(),File::Spec->rootdir());
my $try_detect_readline;
$try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
my $rl_avail = $Suppress_readline ? "suppressed" :
$CPAN::Frontend->myprint(
sprintf qq{
-cpan shell -- CPAN exploration and modules installation (v%s%s)
+cpan shell -- CPAN exploration and modules installation (v%s)
ReadLine support %s
},
$CPAN::VERSION,
- $CPAN::Revision,
$rl_avail
)
unless $CPAN::Config->{'inhibit_startup_message'} ;
s/^\!//;
my($eval) = $_;
package CPAN::Eval;
+ use strict;
use vars qw($import_done);
CPAN->import(':DEFAULT') unless $import_done++;
CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
my $command = shift @line;
eval { CPAN::Shell->$command(@line) };
warn $@ if $@;
- chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
+ if ($command =~ /^(make|test|install|force|notest)$/) {
+ CPAN::Shell->failed($CPAN::CurrentCommandId,1);
+ }
+ soft_chdir_with_alternatives(\@cwd);
$CPAN::Frontend->myprint("\n");
$continuation = "";
+ $CPAN::CurrentCommandId++;
$prompt = $oprompt;
}
} continue {
}
}
}
- chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
+ soft_chdir_with_alternatives(\@cwd);
}
+sub soft_chdir_with_alternatives ($) {
+ my($cwd) = @_;
+ while (not chdir $cwd->[0]) {
+ if (@$cwd>1) {
+ $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
+Trying to chdir to "$cwd->[1]" instead.
+});
+ shift @$cwd;
+ } else {
+ $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
+ }
+ }
+}
package CPAN::CacheMgr;
+use strict;
@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
use File::Find;
-package CPAN::Config;
-use vars qw(%can $dot_cpan);
-
-%can = (
- 'commit' => "Commit changes to disk",
- 'defaults' => "Reload defaults from disk",
- 'init' => "Interactive setting of all options",
-);
-
package CPAN::FTP;
+use strict;
use vars qw($Ua $Thesite $Themethod);
@CPAN::FTP::ISA = qw(CPAN::Debug);
package CPAN::LWP::UserAgent;
+use strict;
use vars qw(@ISA $USER $PASSWD $SETUPDONE);
-# we delay requiring LWP::UserAgent and setting up inheritence until we need it
+# we delay requiring LWP::UserAgent and setting up inheritance until we need it
package CPAN::Complete;
+use strict;
@CPAN::Complete::ISA = qw(CPAN::Debug);
@CPAN::Complete::COMMANDS = sort qw(
- ! a b d h i m o q r u autobundle clean dump
- make test install force readme reload look
- cvs_import ls
-) unless @CPAN::Complete::COMMANDS;
+ ! a b d h i m o q r u
+ autobundle
+ clean
+ cvs_import
+ dump
+ force
+ install
+ look
+ ls
+ make test
+ notest
+ perldoc
+ readme
+ recent
+ reload
+);
package CPAN::Index;
+use strict;
use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
@CPAN::Index::ISA = qw(CPAN::Debug);
$LAST_TIME ||= 0;
sub PROTOCOL { 2.0 }
package CPAN::InfoObj;
+use strict;
@CPAN::InfoObj::ISA = qw(CPAN::Debug);
package CPAN::Author;
+use strict;
@CPAN::Author::ISA = qw(CPAN::InfoObj);
package CPAN::Distribution;
+use strict;
@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
package CPAN::Bundle;
+use strict;
@CPAN::Bundle::ISA = qw(CPAN::Module);
package CPAN::Module;
+use strict;
@CPAN::Module::ISA = qw(CPAN::InfoObj);
package CPAN::Exception::RecursiveDependency;
+use strict;
use overload '""' => "as_string";
sub new {
".\nCannot continue.\n";
}
+package CPAN::Prompt; use overload '""' => "as_string";
+our $prompt = "cpan> ";
+$CPAN::CurrentCommandId ||= 0;
+sub as_randomly_capitalized_string {
+ # pure fun variant
+ substr($prompt,$_,1)=rand()<0.5 ?
+ uc(substr($prompt,$_,1)) :
+ lc(substr($prompt,$_,1)) for 0..3;
+ $prompt;
+}
+sub new {
+ bless {}, shift;
+}
+sub as_string {
+ if ($CPAN::Config->{commandnumber_in_prompt}) {
+ sprintf "cpan[%d]> ", $CPAN::CurrentCommandId;
+ } else {
+ "cpan> ";
+ }
+}
+
+package CPAN::Distrostatus;
+use overload '""' => "as_string",
+ fallback => 1;
+sub new {
+ my($class,$arg) = @_;
+ bless {
+ TEXT => $arg,
+ FAILED => substr($arg,0,2) eq "NO",
+ COMMANDID => $CPAN::CurrentCommandId,
+ }, $class;
+}
+sub commandid { shift->{COMMANDID} }
+sub failed { shift->{FAILED} }
+sub text {
+ my($self,$set) = @_;
+ if (defined $set) {
+ $self->{TEXT} = $set;
+ }
+ $self->{TEXT};
+}
+sub as_string {
+ my($self) = @_;
+ if (0) { # called from rematein during install?
+ require Carp;
+ Carp::cluck("HERE");
+ }
+ $self->{TEXT};
+}
+
package CPAN::Shell;
+use strict;
use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
@CPAN::Shell::ISA = qw(CPAN::Debug);
$COLOR_REGISTERED ||= 0;
});
}
} else {
- $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
+ $CPAN::Frontend->mywarn(qq{Unknown shell command '$autoload'. }.
qq{Type ? for help.
});
}
}
-package CPAN::Tarzip;
-use vars qw($AUTOLOAD @ISA $BUGHUNTING);
-@CPAN::Tarzip::ISA = qw(CPAN::Debug);
-$BUGHUNTING = 0; # released code must have turned off
-
package CPAN::Queue;
+use strict;
# One use of the queue is to determine if we should or shouldn't
# announce the availability of a new CPAN module
package CPAN;
+use strict;
$META ||= CPAN->new; # In case we re-eval ourselves we need the ||
#-> sub CPAN::all_objects ;
sub all_objects {
my($mgr,$class) = @_;
- CPAN::Config->load unless $CPAN::Config_loaded++;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
CPAN::Index->reload;
values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
if (-f $lockfile && -M _ > 0) {
my $fh = FileHandle->new($lockfile) or
- $CPAN::Frontend->mydie("Could not open $lockfile: $!");
+ $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
my $otherpid = <$fh>;
my $otherhost = <$fh>;
$fh->close;
if (defined $otherhost && defined $thishost &&
$otherhost ne '' && $thishost ne '' &&
$otherhost ne $thishost) {
- $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
+ $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
"reports other host $otherhost and other process $otherpid.\n".
"Cannot proceed.\n"));
}
my($ans) =
ExtUtils::MakeMaker::prompt
(qq{Other job not responding. Shall I overwrite }.
- qq{the lockfile? (Y/N)},"y");
+ qq{the lockfile '$lockfile'? (Y/n)},"y");
$CPAN::Frontend->myexit("Ok, bye\n")
unless $ans =~ /^y/i;
} else {
Carp::croak(
- qq{Lockfile $lockfile not writeable by you. }.
+ qq{Lockfile '$lockfile' not writeable by you. }.
qq{Cannot proceed.\n}.
qq{ On UNIX try:\n}.
- qq{ rm $lockfile\n}.
+ qq{ rm '$lockfile'\n}.
qq{ and then rerun us.\n}
);
}
} else {
- $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
+ $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
"reports other process with ID ".
"$otherpid. Cannot proceed.\n"));
}
#-> sub CPAN::getcwd ;
sub getcwd {Cwd::getcwd();}
+#-> sub CPAN::find_perl ;
+sub find_perl {
+ my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
+ my $pwd = $CPAN::iCwd = CPAN::anycwd();
+ my $candidate = File::Spec->catfile($pwd,$^X);
+ $perl ||= $candidate if MM->maybe_command($candidate);
+
+ unless ($perl) {
+ my ($component,$perl_name);
+ DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
+ PATH_COMPONENT: foreach $component (File::Spec->path(),
+ $Config::Config{'binexp'}) {
+ next unless defined($component) && $component;
+ my($abs) = File::Spec->catfile($component,$perl_name);
+ if (MM->maybe_command($abs)) {
+ $perl = $abs;
+ last DIST_PERLNAME;
+ }
+ }
+ }
+ }
+
+ return $perl;
+}
+
+
#-> sub CPAN::exists ;
sub exists {
my($mgr,$class,$id) = @_;
- CPAN::Config->load unless $CPAN::Config_loaded++;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
CPAN::Index->reload;
### Carp::croak "exists called without class argument" unless $class;
$id ||= "";
+ $id =~ s/:+/::/g if $class eq "CPAN::Module";
exists $META->{readonly}{$class}{$id} or
exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
}
sub {require HTTP::Request},
sub {require URI::URL},
],
- Net::FTP => [
+ 'Net::FTP' => [
sub {require Net::FTP},
sub {require Net::Config},
]
my $file = $mod;
my $obj;
$file =~ s|::|/|g;
- $file =~ s|/|\\|g if $^O eq 'MSWin32';
$file .= ".pm";
if ($INC{$file}) {
# checking %INC is wrong, because $INC{LWP} may be true
$CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
if ($mod eq "CPAN::WAIT") {
- push @CPAN::Shell::ISA, CPAN::WAIT;
+ push @CPAN::Shell::ISA, 'CPAN::WAIT';
}
return 1;
} elsif ($mod eq "Net::FTP") {
}) unless $Have_warned->{"Net::FTP"}++;
sleep 3;
- } elsif ($mod eq "Digest::MD5"){
+ } elsif ($mod eq "Digest::SHA"){
$CPAN::Frontend->myprint(qq{
- CPAN: MD5 security checks disabled because Digest::MD5 not installed.
- Please consider installing the Digest::MD5 module.
+ CPAN: checksum security checks disabled because Digest::SHA not installed.
+ Please consider installing the Digest::SHA module.
});
sleep 2;
+ } elsif ($mod eq "Module::Signature"){
+ unless ($Have_warned->{"Module::Signature"}++) {
+ # No point in complaining unless the user can
+ # reasonably install and use it.
+ if (eval { require Crypt::OpenPGP; 1 } ||
+ defined $CPAN::Config->{'gpg'}) {
+ $CPAN::Frontend->myprint(qq{
+ CPAN: Module::Signature security checks disabled because Module::Signature
+ not installed. Please consider installing the Module::Signature module.
+ You may also need to be able to connect over the Internet to the public
+ keyservers like pgp.mit.edu (port 11371).
+
+});
+ sleep 2;
+ }
+ }
} else {
delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
}
#-> sub CPAN::cleanup ;
sub cleanup {
- # warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
+ # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
local $SIG{__DIE__} = '';
my($message) = @_;
my $i = 0;
$ineval = 1, last if
$subroutine eq '(eval)';
}
- return if $ineval && !$End;
+ return if $ineval && !$CPAN::End;
return unless defined $META->{LOCK};
return unless -f $META->{LOCK};
$META->savehist;
}
package CPAN::CacheMgr;
+use strict;
#-> sub CPAN::CacheMgr::as_string ;
sub as_string {
return if exists $self->{SIZE}{$dir};
return if $CPAN::Signal;
my($Du) = 0;
+ unless (-x $dir) {
+ unless (chmod 0755, $dir) {
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor the permission ".
+ "to change the permission; cannot estimate disk usage ".
+ "of '$dir'\n");
+ sleep 5;
+ return;
+ }
+ }
find(
- sub {
- $File::Find::prune++ if $CPAN::Signal;
- return if -l $_;
- if ($^O eq 'MacOS') {
- require Mac::Files;
- my $cat = Mac::Files::FSpGetCatInfo($_);
- $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
- } else {
- $Du += (-s _);
- }
- },
- $dir
- );
+ sub {
+ $File::Find::prune++ if $CPAN::Signal;
+ return if -l $_;
+ if ($^O eq 'MacOS') {
+ require Mac::Files;
+ my $cat = Mac::Files::FSpGetCatInfo($_);
+ $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
+ } else {
+ if (-d _) {
+ unless (-x _) {
+ unless (chmod 0755, $_) {
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
+ "the permission to change the permission; ".
+ "can only partially estimate disk usage ".
+ "of '$_'\n");
+ sleep 5;
+ return;
+ }
+ }
+ } else {
+ $Du += (-s _);
+ }
+ }
+ },
+ $dir
+ );
return if $CPAN::Signal;
$self->{SIZE}{$dir} = $Du/1024/1024;
push @{$self->{FIFO}}, $dir;
$self->tidyup;
}
-package CPAN::Debug;
-
-#-> sub CPAN::Debug::debug ;
-sub debug {
- my($self,$arg) = @_;
- my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
- # Complete, caller(1)
- # eg readline
- ($caller) = caller(0);
- $caller =~ s/.*:://;
- $arg = "" unless defined $arg;
- my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
- if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
- if ($arg and ref $arg) {
- eval { require Data::Dumper };
- if ($@) {
- $CPAN::Frontend->myprint($arg->as_string);
- } else {
- $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
- }
- } else {
- $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
- }
- }
-}
-
-package CPAN::Config;
-
-#-> sub CPAN::Config::edit ;
-# returns true on successful action
-sub edit {
- my($self,@args) = @_;
- return unless @args;
- CPAN->debug("self[$self]args[".join(" | ",@args)."]");
- my($o,$str,$func,$args,$key_exists);
- $o = shift @args;
- if($can{$o}) {
- $self->$o(@args);
- return 1;
- } else {
- CPAN->debug("o[$o]") if $CPAN::DEBUG;
- if ($o =~ /list$/) {
- $func = shift @args;
- $func ||= "";
- CPAN->debug("func[$func]") if $CPAN::DEBUG;
- my $changed;
- # Let's avoid eval, it's easier to comprehend without.
- if ($func eq "push") {
- push @{$CPAN::Config->{$o}}, @args;
- $changed = 1;
- } elsif ($func eq "pop") {
- pop @{$CPAN::Config->{$o}};
- $changed = 1;
- } elsif ($func eq "shift") {
- shift @{$CPAN::Config->{$o}};
- $changed = 1;
- } elsif ($func eq "unshift") {
- unshift @{$CPAN::Config->{$o}}, @args;
- $changed = 1;
- } elsif ($func eq "splice") {
- splice @{$CPAN::Config->{$o}}, @args;
- $changed = 1;
- } elsif (@args) {
- $CPAN::Config->{$o} = [@args];
- $changed = 1;
- } else {
- $self->prettyprint($o);
- }
- if ($o eq "urllist" && $changed) {
- # reset the cached values
- undef $CPAN::FTP::Thesite;
- undef $CPAN::FTP::Themethod;
- }
- return $changed;
- } else {
- $CPAN::Config->{$o} = $args[0] if defined $args[0];
- $self->prettyprint($o);
- }
- }
-}
-
-sub prettyprint {
- my($self,$k) = @_;
- my $v = $CPAN::Config->{$k};
- if (ref $v) {
- my(@report) = ref $v eq "ARRAY" ?
- @$v :
- map { sprintf(" %-18s => %s\n",
- $_,
- defined $v->{$_} ? $v->{$_} : "UNDEFINED"
- )} keys %$v;
- $CPAN::Frontend->myprint(
- join(
- "",
- sprintf(
- " %-18s\n",
- $k
- ),
- map {"\t$_\n"} @report
- )
- );
- } elsif (defined $v) {
- $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
- } else {
- $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
- }
-}
-
-#-> sub CPAN::Config::commit ;
-sub commit {
- my($self,$configpm) = @_;
- unless (defined $configpm){
- $configpm ||= $INC{"CPAN/MyConfig.pm"};
- $configpm ||= $INC{"CPAN/Config.pm"};
- $configpm || Carp::confess(q{
-CPAN::Config::commit called without an argument.
-Please specify a filename where to save the configuration or try
-"o conf init" to have an interactive course through configing.
-});
- }
- my($mode);
- if (-f $configpm) {
- $mode = (stat $configpm)[2];
- if ($mode && ! -w _) {
- Carp::confess("$configpm is not writable");
- }
- }
-
- my $msg;
- $msg = <<EOF unless $configpm =~ /MyConfig/;
-
-# This is CPAN.pm's systemwide configuration file. This file provides
-# defaults for users, and the values can be changed in a per-user
-# configuration file. The user-config file is being looked for as
-# ~/.cpan/CPAN/MyConfig.pm.
-
-EOF
- $msg ||= "\n";
- my($fh) = FileHandle->new;
- rename $configpm, "$configpm~" if -f $configpm;
- open $fh, ">$configpm" or
- $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
- $fh->print(qq[$msg\$CPAN::Config = \{\n]);
- foreach (sort keys %$CPAN::Config) {
- $fh->print(
- " '$_' => ",
- ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
- ",\n"
- );
- }
-
- $fh->print("};\n1;\n__END__\n");
- close $fh;
-
- #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
- #chmod $mode, $configpm;
-###why was that so? $self->defaults;
- $CPAN::Frontend->myprint("commit: wrote $configpm\n");
- 1;
-}
-
-*default = \&defaults;
-#-> sub CPAN::Config::defaults ;
-sub defaults {
- my($self) = @_;
- $self->unload;
- $self->load;
- 1;
-}
-
-sub init {
- my($self) = @_;
- undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
- # have the least
- # important
- # variable
- # undefined
- $self->load;
- 1;
-}
-
-# This is a piece of repeated code that is abstracted here for
-# maintainability. RMB
-#
-sub _configpmtest {
- my($configpmdir, $configpmtest) = @_;
- if (-w $configpmtest) {
- return $configpmtest;
- } elsif (-w $configpmdir) {
- #_#_# following code dumped core on me with 5.003_11, a.k.
- my $configpm_bak = "$configpmtest.bak";
- unlink $configpm_bak if -f $configpm_bak;
- if( -f $configpmtest ) {
- if( rename $configpmtest, $configpm_bak ) {
- $CPAN::Frontend->mywarn(<<END)
-Old configuration file $configpmtest
- moved to $configpm_bak
-END
- }
- }
- my $fh = FileHandle->new;
- if ($fh->open(">$configpmtest")) {
- $fh->print("1;\n");
- return $configpmtest;
- } else {
- # Should never happen
- Carp::confess("Cannot open >$configpmtest");
- }
- } else { return }
-}
-
-#-> sub CPAN::Config::load ;
-sub load {
- my($self) = shift;
- my(@miss);
- use Carp;
- eval {require CPAN::Config;}; # We eval because of some
- # MakeMaker problems
- unless ($dot_cpan++){
- unshift @INC, File::Spec->catdir($ENV{HOME},".cpan");
- eval {require CPAN::MyConfig;}; # where you can override
- # system wide settings
- shift @INC;
- }
- return unless @miss = $self->missing_config_data;
-
- require CPAN::FirstTime;
- my($configpm,$fh,$redo,$theycalled);
- $redo ||= "";
- $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
- if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
- $configpm = $INC{"CPAN/Config.pm"};
- $redo++;
- } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
- $configpm = $INC{"CPAN/MyConfig.pm"};
- $redo++;
- } else {
- my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
- my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
- my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
- if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
- $configpm = _configpmtest($configpmdir,$configpmtest);
- }
- unless ($configpm) {
- $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
- File::Path::mkpath($configpmdir);
- $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
- $configpm = _configpmtest($configpmdir,$configpmtest);
- unless ($configpm) {
- Carp::confess(qq{WARNING: CPAN.pm is unable to }.
- qq{create a configuration file.});
- }
- }
- }
- local($") = ", ";
- $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
-We have to reconfigure CPAN.pm due to following uninitialized parameters:
-
-@miss
-END
- $CPAN::Frontend->myprint(qq{
-$configpm initialized.
-});
- sleep 2;
- CPAN::FirstTime::init($configpm);
-}
-
-#-> sub CPAN::Config::missing_config_data ;
-sub missing_config_data {
- my(@miss);
- for (
- "cpan_home", "keep_source_where", "build_dir", "build_cache",
- "scan_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",
- "prerequisites_policy",
- "cache_metadata",
- ) {
- push @miss, $_ unless defined $CPAN::Config->{$_};
- }
- return @miss;
-}
-
-#-> sub CPAN::Config::unload ;
-sub unload {
- delete $INC{'CPAN/MyConfig.pm'};
- delete $INC{'CPAN/Config.pm'};
-}
-
-#-> sub CPAN::Config::help ;
-sub help {
- $CPAN::Frontend->myprint(q[
-Known options:
- defaults reload default config values from disk
- commit commit session changes to disk
- init go through a dialog to set all parameters
-
-You may edit key values in the follow fashion (the "o" is a literal
-letter o):
-
- o conf build_cache 15
-
- o conf build_dir "/foo/bar"
-
- o conf urllist shift
-
- o conf urllist unshift ftp://ftp.foo.bar/
-
-]);
- undef; #don't reprint CPAN::Config
-}
-
-#-> sub CPAN::Config::cpl ;
-sub cpl {
- my($word,$line,$pos) = @_;
- $word ||= "";
- CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
- my(@words) = split " ", substr($line,0,$pos+1);
- if (
- defined($words[2])
- and
- (
- $words[2] =~ /list$/ && @words == 3
- ||
- $words[2] =~ /list$/ && @words == 4 && length($word)
- )
- ) {
- return grep /^\Q$word\E/, qw(splice shift unshift pop push);
- } elsif (@words >= 4) {
- return ();
- }
- my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
- return grep /^\Q$word\E/, @o_conf;
-}
-
package CPAN::Shell;
+use strict;
#-> sub CPAN::Shell::h ;
sub h {
if (defined $about) {
$CPAN::Frontend->myprint("Detailed help not yet implemented\n");
} else {
- $CPAN::Frontend->myprint(q{
-Display Information
+ my $filler = " " x (80 - 28 - length($CPAN::VERSION));
+ $CPAN::Frontend->myprint(qq{
+Display Information $filler (ver $CPAN::VERSION)
command argument description
a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
i WORD or /REGEXP/ about any of the above
r NONE report updatable modules
- ls AUTHOR about files in the author's directory
+ ls AUTHOR or GLOB about files in the author's directory
+ (with WORD being a module, bundle or author name or a distribution
+ name of the form AUTHOR/DISTRIBUTION)
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
+ get download clean make clean
+ make make (implies get) look open subshell in dist directory
+ test make test (implies make) readme display these README files
+ install make install (implies test) perldoc display POD documentation
+
+Pragmas
+ force COMMAND unconditionally do command
+ notest COMMAND skip testing
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});
+ autobundle Snapshot recent latest CPAN uploads});
}
}
$CPAN::Frontend->myprint($self->format_result('Author',@arg));
}
-#-> sub CPAN::Shell::ls ;
-sub ls {
- my($self,@arg) = @_;
- my @accept;
- for (@arg) {
- unless (/^[A-Z\-]+$/i) {
+sub handle_ls {
+ my($self,$pragmas,$s) = @_;
+ # ls is really very different, but we had it once as an ordinary
+ # command in the Shell (upto rev. 321) and we could not handle
+ # force well then
+ my(@accept,@preexpand);
+ if ($s =~ /[\*\?\/]/) {
+ if ($CPAN::META->has_inst("Text::Glob")) {
+ if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
+ my $rau = Text::Glob::glob_to_regex(uc $au);
+ CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
+ if $CPAN::DEBUG;
+ push @preexpand, map { $_->id . "/" . $pathglob }
+ CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
+ } else {
+ my $rau = Text::Glob::glob_to_regex(uc $s);
+ push @preexpand, map { $_->id }
+ CPAN::Shell->expand_by_method('CPAN::Author',
+ ['id'],
+ "/$rau/");
+ }
+ } else {
+ $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
+ }
+ } else {
+ push @preexpand, uc $s;
+ }
+ for (@preexpand) {
+ unless (/^[A-Z0-9\-]+(\/|$)/i) {
$CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
next;
}
- push @accept, uc $_;
+ push @accept, $_;
}
+ my $silent = @accept>1;
+ my $last_alpha = "";
for my $a (@accept){
- my $author = $self->expand('Author',$a) or die "No author found for $a";
- $author->ls;
+ my($author,$pathglob);
+ if ($a =~ m|(.*?)/(.*)|) {
+ my $a2 = $1;
+ $pathglob = $2;
+ $author = CPAN::Shell->expand_by_method('CPAN::Author',
+ ['id'],
+ $a2) or die "No author found for $a2";
+ } else {
+ $author = CPAN::Shell->expand_by_method('CPAN::Author',
+ ['id'],
+ $a) or die "No author found for $a";
+ }
+ if ($silent) {
+ my $alpha = substr $author->id, 0, 1;
+ my $ad;
+ if ($alpha eq $last_alpha) {
+ $ad = "";
+ } else {
+ $ad = "[$alpha]";
+ $last_alpha = $alpha;
+ }
+ $CPAN::Frontend->myprint($ad);
+ }
+ for my $pragma (@$pragmas) {
+ if ($author->can($pragma)) {
+ $author->$pragma();
+ }
+ }
+ $author->ls($pathglob,$silent); # silent if more than one author
+ for my $pragma (@$pragmas) {
+ my $meth = "un$pragma";
+ if ($author->can($meth)) {
+ $author->$meth();
+ }
+ }
}
}
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) {
+ for my $type (qw/Bundle Distribution Module/) {
push @result, $self->expand($type,@args);
}
+ # Authors are always uppercase.
+ push @result, $self->expand("Author", map { uc $_ } @args);
+
my $result = @result == 1 ?
$result[0]->as_string :
@result == 0 ?
# should have been called set and 'o debug' maybe 'set debug'
sub o {
my($self,$o_type,@o_what) = @_;
+ $DB::single = 1;
$o_type ||= "";
CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
if ($o_type eq 'conf') {
$CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
}
$CPAN::Frontend->myprint(":\n");
- for $k (sort keys %CPAN::Config::can) {
- $v = $CPAN::Config::can{$k};
- $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
+ for $k (sort keys %CPAN::HandleConfig::can) {
+ $v = $CPAN::HandleConfig::can{$k};
+ $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
}
$CPAN::Frontend->myprint("\n");
for $k (sort keys %$CPAN::Config) {
- CPAN::Config->prettyprint($k);
+ CPAN::HandleConfig->prettyprint($k);
}
$CPAN::Frontend->myprint("\n");
- } elsif (!CPAN::Config->edit(@o_what)) {
- $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
- qq{edit options\n\n});
+ } elsif (!CPAN::HandleConfig->edit(@o_what)) {
+ $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
+ qq{items\n\n});
}
} elsif ($o_type eq 'debug') {
my(%valid);
$command ||= "";
$self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
if ($command =~ /cpan/i) {
- for my $f (qw(CPAN.pm CPAN/FirstTime.pm)) {
+ my $redef = 0;
+ chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
+ my $failed;
+ MFILE: for my $f (qw(CPAN.pm CPAN/HandleConfig.pm CPAN/FirstTime.pm CPAN/Tarzip.pm
+ CPAN/Debug.pm CPAN/Version.pm)) {
next unless $INC{$f};
- CPAN->debug("reloading the whole $f") if $CPAN::DEBUG;
- my $fh = FileHandle->new($INC{$f});
+ my $pwd = CPAN::anycwd();
+ CPAN->debug("reloading the whole '$f' from '$INC{$f}' while pwd='$pwd'")
+ if $CPAN::DEBUG;
+ my $read;
+ for my $inc (@INC) {
+ $read = File::Spec->catfile($inc,split /\//, $f);
+ last if -f $read;
+ }
+ unless (-f $read) {
+ $failed++;
+ $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
+ next MFILE;
+ }
+ my $fh = FileHandle->new($read) or
+ $CPAN::Frontend->mydie("Could not open $read: $!");
local($/);
- my $redef = 0;
+ local $^W = 1;
local($SIG{__WARN__}) = paintdots_onreload(\$redef);
- eval <$fh>;
- warn $@ if $@;
- $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
+ my $eval = <$fh>;
+ CPAN->debug(sprintf("evaling [%s...]\n",substr($eval,0,64)))
+ if $CPAN::DEBUG;
+ eval $eval;
+ if ($@){
+ $failed++;
+ warn $@;
+ }
+ }
+ $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
+ $failed++ unless $redef;
+ if ($failed) {
+ $CPAN::Frontend->mywarn("\n$failed errors during reload. You better quit ".
+ "this session.\n");
}
} elsif ($command =~ /index/) {
CPAN::Index->force_reload;
# for metadata cache
$CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
}
- for $module (@expand) {
+ MODULE: for $module (@expand) {
my $file = $module->cpan_file;
- next unless defined $file; # ??
+ next MODULE unless defined $file; # ??
+ $file =~ s|^./../||;
my($latest) = $module->cpan_version;
my($inst_file) = $module->inst_file;
my($have);
} elsif ($have == 0){
$version_zeroes++;
}
- next unless CPAN::Version->vgt($latest, $have);
+ next MODULE unless CPAN::Version->vgt($latest, $have);
# to be pedantic we should probably say:
# && !($have eq "undef" && $latest ne "undef" && $latest gt "");
# to catch the case where CPAN has a version 0 and we have a version undef
} elsif ($what eq "u") {
- next;
+ next MODULE;
}
} else {
if ($what eq "a") {
- next;
+ next MODULE;
} elsif ($what eq "r") {
- next;
+ next MODULE;
} elsif ($what eq "u") {
$have = "-";
}
push @result, sprintf "%s %s\n", $module->id, $have;
} elsif ($what eq "r") {
push @result, $module->id;
- next if $seen{$file}++;
+ next MODULE if $seen{$file}++;
} elsif ($what eq "u") {
push @result, $module->id;
- next if $seen{$file}++;
- next if $file =~ /^Contact/;
+ next MODULE if $seen{$file}++;
+ next MODULE if $file =~ /^Contact/;
}
unless ($headerdone++){
$CPAN::Frontend->myprint("\n");
&&
$CPAN::META->has_inst("Term::ANSIColor")
&&
- $module->{RO}{description}
+ $module->description
) {
$color_on = Term::ANSIColor::color("green");
$color_off = Term::ANSIColor::color("reset");
shift->_u_r_common("u",@_);
}
+# XXX intentionally undocumented because not considered enough
+#-> sub CPAN::Shell::failed ;
+sub failed {
+ my($self,$only_id,$silent) = @_;
+ my $print = "";
+ DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
+ my $failed = "";
+ for my $nosayer (qw(signature_verify make make_test install)) {
+ next unless exists $d->{$nosayer};
+ next unless $d->{$nosayer}->failed;
+ $failed = $nosayer;
+ last;
+ }
+ next DIST unless $failed;
+ next DIST if $only_id && $only_id != $d->{$failed}->commandid;
+ my $id = $d->id;
+ $id =~ s|^./../||;
+ $print .= sprintf(
+ " %-45s: %s %s\n",
+ $id,
+ $failed,
+ $d->{$failed}->text,
+ );
+ }
+ my $scope = $only_id ? "command" : "session";
+ if ($print) {
+ $CPAN::Frontend->myprint("Failed installations in this $scope:\n$print");
+ } elsif (!$only_id || !$silent) {
+ $CPAN::Frontend->myprint("No installations failed in this $scope\n");
+ }
+}
+
+# XXX intentionally undocumented because not considered enough
+#-> sub CPAN::Shell::status ;
+sub status {
+ my($self) = @_;
+ require Devel::Size;
+ my $ps = FileHandle->new;
+ open $ps, "/proc/$$/status";
+ my $vm = 0;
+ while (<$ps>) {
+ next unless /VmSize:\s+(\d+)/;
+ $vm = $1;
+ last;
+ }
+ $CPAN::Frontend->mywarn(sprintf(
+ "%-27s %6d\n%-27s %6d\n",
+ "vm",
+ $vm,
+ "CPAN::META",
+ Devel::Size::total_size($CPAN::META)/1024,
+ ));
+ for my $k (sort keys %$CPAN::META) {
+ next unless substr($k,0,4) eq "read";
+ warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
+ for my $k2 (sort keys %{$CPAN::META->{$k}}) {
+ warn sprintf " %-25s %6d %6d\n",
+ $k2,
+ Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
+ scalar keys %{$CPAN::META->{$k}{$k2}};
+ }
+ }
+}
+
#-> sub CPAN::Shell::autobundle ;
sub autobundle {
my($self) = shift;
- CPAN::Config->load unless $CPAN::Config_loaded++;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
my(@bundle) = $self->_u_r_common("a",@_);
my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
File::Path::mkpath($todir);
#-> sub CPAN::Shell::expand ;
sub expand {
- shift;
+ my $self = shift;
my($type,@args) = @_;
- my($arg,@m);
CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
+ my $class = "CPAN::$type";
+ my $methods = ['id'];
+ for my $meth (qw(name)) {
+ next if $] < 5.00303; # no "can"
+ next unless $class->can($meth);
+ push @$methods, $meth;
+ }
+ $self->expand_by_method($class,$methods,@args);
+}
+
+sub expand_by_method {
+ my $self = shift;
+ my($class,$methods,@args) = @_;
+ my($arg,@m);
for $arg (@args) {
my($regex,$command);
if ($arg =~ m|^/(.*)/$|) {
} elsif ($arg =~ m/=/) {
$command = 1;
}
- my $class = "CPAN::$type";
my $obj;
CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
$class,
defined $regex ? $regex : "UNDEFINED",
- $command || "UNDEFINED",
+ defined $command ? $command : "UNDEFINED",
) if $CPAN::DEBUG;
if (defined $regex) {
for $obj (
- sort
- {$a->id cmp $b->id}
$CPAN::META->all_objects($class)
) {
unless ($obj->id){
)) if $CPAN::DEBUG;
next;
}
- 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
- );
+ for my $method (@$methods) {
+ if ($obj->$method() =~ /$regex/i) {
+ push @m, $obj;
+ last;
+ }
+ }
}
} elsif ($command) {
die "equal sign in command disabled (immature interface), ".
}
} else {
my($xarg) = $arg;
- if ( $type eq 'Bundle' ) {
+ if ( $class eq 'CPAN::Bundle' ) {
$xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
- } elsif ($type eq "Distribution") {
+ } elsif ($class eq "CPAN::Distribution") {
$xarg = CPAN::Distribution->normalize($arg);
+ } else {
+ $xarg =~ s/:+/::/g;
}
if ($CPAN::META->exists($class,$xarg)) {
$obj = $CPAN::META->instance($class,$xarg);
push @m, $obj;
}
}
+ @m = sort {$a->id cmp $b->id} @m;
+ if ( $CPAN::DEBUG ) {
+ my $wantarray = wantarray;
+ my $join_m = join ",", map {$_->id} @m;
+ $self->debug("wantarray[$wantarray]join_m[$join_m]");
+ }
return wantarray ? @m : $m[0];
}
$result;
}
+#-> sub CPAN::Shell::report_fh ;
+{
+ my $installation_report_fh;
+ my $previously_noticed = 0;
+
+ sub report_fh {
+ return $installation_report_fh if $installation_report_fh;
+ $installation_report_fh = File::Temp->new(
+ template => 'cpan_install_XXXX',
+ suffix => '.txt',
+ unlink => 0,
+ );
+ unless ( $installation_report_fh ) {
+ warn("Couldn't open installation report file; " .
+ "no report file will be generated."
+ ) unless $previously_noticed++;
+ }
+ }
+}
+
+
# The only reason for this method is currently to have a reliable
# debugging utility that reveals which output is going through which
# channel. No, I don't like the colors ;-)
my $longest = 0;
return unless defined $what;
+ local $| = 1; # Flush immediately
+ if ( $CPAN::Be_Silent ) {
+ print {report_fh()} $what;
+ return;
+ }
+
if ($CPAN::Config->{term_is_latin}){
# courtesy jhi:
$what
die "\n";
}
+sub mysleep {
+ my($self, $sleep) = @_;
+ sleep $sleep;
+}
+
sub setup_output {
return if -t STDOUT;
my $odef = select STDERR;
#-> sub CPAN::Shell::rematein ;
# RE-adme||MA-ke||TE-st||IN-stall
sub rematein {
- shift;
+ my $self = shift;
my($meth,@some) = @_;
- my $pragma = "";
- if ($meth eq 'force') {
- $pragma = $meth;
- $meth = shift @some;
+ my @pragma;
+ while($meth =~ /^(force|notest)$/) {
+ push @pragma, $meth;
+ $meth = shift @some or
+ $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
+ "cannot continue");
}
setup_output();
- CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
+ CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
# Here is the place to set "test_count" on all involved parties to
# 0. We then can pass this counter on to the involved
# construct the queue
my($s,@s,@qcopy);
- foreach $s (@some) {
+ STHING: foreach $s (@some) {
my $obj;
if (ref $s) {
CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
"not supported\n");
sleep 2;
next;
- } else {
+ } elsif ($meth eq "ls") {
+ $self->handle_ls(\@pragma,$s);
+ next STHING;
+ } else {
CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
$obj = CPAN::Shell->expandany($s);
}
$obj->color_cmd_tmps(0,1);
CPAN::Queue->new($obj->id);
push @qcopy, $obj;
- } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
- $obj = $CPAN::META->instance('CPAN::Author',$s);
+ } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
+ $obj = $CPAN::META->instance('CPAN::Author',uc($s));
if ($meth =~ /^(dump|ls)$/) {
$obj->$meth();
} else {
} else {
$obj = CPAN::Shell->expandany($s);
}
- if ($pragma
- &&
- ($] < 5.00303 || $obj->can($pragma))){
- ### compatibility with 5.003
- $obj->$pragma($meth); # the pragma "force" in
- # "CPAN::Distribution" must know
- # what we are intending
+ for my $pragma (@pragma) {
+ if ($pragma
+ &&
+ ($] < 5.00303 || $obj->can($pragma))){
+ ### compatibility with 5.003
+ $obj->$pragma($meth); # the pragma "force" in
+ # "CPAN::Distribution" must know
+ # what we are intending
+ }
}
if ($]>=5.00303 && $obj->can('called_for')) {
$obj->called_for($s);
}
CPAN->debug(
- qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
+ qq{pragma[@pragma]meth[$meth]obj[$obj]as_string\[}.
$obj->as_string.
qq{\]}
) if $CPAN::DEBUG;
}
for my $obj (@qcopy) {
$obj->color_cmd_tmps(0,0);
+ delete $obj->{incommandcolor};
}
}
-#-> sub CPAN::Shell::dump ;
-sub dump { shift->rematein('dump',@_); }
-#-> 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',@_); }
-#-> sub CPAN::Shell::cvs_import ;
-sub cvs_import { shift->rematein('cvs_import',@_); }
+#-> sub CPAN::Shell::recent ;
+sub recent {
+ my($self) = @_;
+
+ CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
+ return;
+}
+
+{
+ # set up the dispatching methods
+ no strict "refs";
+ for my $command (qw(
+ clean
+ cvs_import
+ dump
+ force
+ get
+ install
+ look
+ ls
+ make
+ notest
+ perldoc
+ readme
+ test
+ )) {
+ *$command = sub { shift->rematein($command, @_); };
+ }
+}
package CPAN::LWP::UserAgent;
+use strict;
sub config {
return if $SETUPDONE;
# $USER and $PASSWD to give the get_basic_credentials routine another
# chance to set $USER and $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);
}
package CPAN::FTP;
+use strict;
#-> 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]
+ 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}")]);
- unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
- warn "Couldn't login on $host";
- return;
- }
- 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;
+ ) if $CPAN::DEBUG;
+ my $ftp = Net::FTP->new($host);
+ unless ($ftp) {
+ $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
+ return;
+ }
+ 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}")]);
+ unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
+ my $msg = $ftp->message;
+ $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg");
+ return;
+ }
+ unless ( $ftp->cwd($dir) ){
+ my $msg = $ftp->message;
+ $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg");
+ return;
+ }
+ $ftp->binary;
+ $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
+ unless ( $ftp->get($file,$target) ){
+ my $msg = $ftp->message;
+ $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg");
+ return;
+ }
+ $ftp->quit; # it's ok if this fails
+ return 1;
}
# If more accuracy is wanted/needed, Chris Leach sent me this patch...
}
}
- return $aslocal if -f $aslocal && -r _ && !($force & 1);
+ if (-f $aslocal && -r _ && !($force & 1)){
+ if (-s $aslocal) {
+ return $aslocal;
+ } else {
+ # empty file from a previous unsuccessful attempt to download it
+ unlink $aslocal or
+ $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I could not remove.");
+ }
+ }
my($restore) = 0;
if (-f $aslocal){
rename $aslocal, "$aslocal.bak";
# Maybe mirror has compressed it?
if (-f "$l.gz") {
$self->debug("found compressed $l.gz") if $CPAN::DEBUG;
- CPAN::Tarzip->gunzip("$l.gz", $aslocal);
+ CPAN::Tarzip->new("$l.gz")->gunzip($aslocal);
if ( -f $aslocal) {
$Thesite = $i;
return $aslocal;
");
$res = $Ua->mirror($gzurl, "$aslocal.gz");
if ($res->is_success &&
- CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
+ CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
) {
$Thesite = $i;
return $aslocal;
$CPAN::Frontend->myprint("Fetching with Net::FTP
$url.gz
");
- if (CPAN::FTP->ftp_get($host,
- $dir,
- "$getfile.gz",
- $gz) &&
- CPAN::Tarzip->gunzip($gz,$aslocal)
+ if (CPAN::FTP->ftp_get($host,
+ $dir,
+ "$getfile.gz",
+ $gz) &&
+ CPAN::Tarzip->new($gz)->gunzip($aslocal)
){
$Thesite = $i;
return $aslocal;
# success above. Likely a bogus URL
$self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
- my($f,$funkyftp);
-
- # Try the most capable first (wget does HTTP, HTTPS and FTP) and
- # leave ncftp* for last as it only does FTP.
- for $f (qw(wget lynx ncftpget ncftp)) {
- next unless exists $CPAN::Config->{$f};
- $funkyftp = $CPAN::Config->{$f};
- next unless defined $funkyftp;
+
+ # Try the most capable first and leave ncftp* for last as it only
+ # does FTP.
+ for my $f (qw(curl wget lynx ncftpget ncftp)) {
+ my $funkyftp = $CPAN::Config->{$f};
+ next unless defined $funkyftp;
next if $funkyftp =~ /^\s*$/;
+
my($asl_ungz, $asl_gz);
($asl_ungz = $aslocal) =~ s/\.gz//;
$asl_gz = "$asl_ungz.gz";
+
my($src_switch) = "";
+ my($chdir) = "";
+ my($stdout_redir) = " > $asl_ungz";
if ($f eq "lynx"){
$src_switch = " -source";
} elsif ($f eq "ncftp"){
$src_switch = " -c";
- } elsif ($f eq "wget"){
- $src_switch = " -O -";
+ } elsif ($f eq "wget"){
+ $src_switch = " -O $asl_ungz";
+ $stdout_redir = "";
+ } elsif ($f eq 'curl'){
+ $src_switch = ' -L';
}
- my($chdir) = "";
- my($stdout_redir) = " > $asl_ungz";
+
if ($f eq "ncftpget"){
$chdir = "cd $aslocal_dir && ";
$stdout_redir = "";
# Looks good
} elsif ($asl_ungz ne $aslocal) {
# test gzip integrity
- if (CPAN::Tarzip->gtest($asl_ungz)) {
+ if (CPAN::Tarzip->new($asl_ungz)->gtest) {
# e.g. foo.tar is gzipped --> foo.tar.gz
rename $asl_ungz, $aslocal;
} else {
- CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
+ CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz);
}
}
$Thesite = $i;
-s $asl_gz
) {
# test gzip integrity
- if (CPAN::Tarzip->gtest($asl_gz)) {
- CPAN::Tarzip->gunzip($asl_gz,$aslocal);
+ my $ct = CPAN::Tarzip->new($asl_gz);
+ if ($ct->gtest) {
+ $ct->gunzip($aslocal);
} else {
# somebody uncompressed file for us?
rename $asl_ungz, $aslocal;
});
}
return if $CPAN::Signal;
- } # wget,lynx,ncftpget,ncftp
+ } # transfer programs
} # host
}
}
package CPAN::FTP::netrc;
+use strict;
sub new {
my($class) = @_;
}
package CPAN::Complete;
+use strict;
sub gnu_cpl {
my($text, $line, $start, $end) = @_;
} elsif ($line =~ /^d\s/) {
@return = cplx('CPAN::Distribution',$word);
} elsif ($line =~ m/^(
- [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
+ [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
)\s/x ) {
if ($word =~ /^Bundle::/) {
CPAN::Shell->local_bundles;
} elsif ($words[1] eq 'index') {
return ();
} elsif ($words[1] eq 'conf') {
- return CPAN::Config::cpl(@_);
+ return CPAN::HandleConfig::cpl(@_);
} elsif ($words[1] eq 'debug') {
- return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
+ return sort grep /^\Q$word\E/i,
+ sort keys %CPAN::DEBUG, 'all';
}
}
package CPAN::Index;
+use strict;
#-> sub CPAN::Index::force_reload ;
sub force_reload {
sub reload_x {
my($cl,$wanted,$localname,$force) = @_;
$force |= 2; # means we're dealing with an index here
- CPAN::Config->load; # we should guarantee loading wherever we rely
+ CPAN::HandleConfig->load; # we should guarantee loading wherever we rely
# on Config XXX
$localname ||= $wanted;
my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
return unless defined $index_target;
$CPAN::Frontend->myprint("Going to read $index_target\n");
local(*FH);
- tie *FH, CPAN::Tarzip, $index_target;
+ tie *FH, 'CPAN::Tarzip', $index_target;
local($/) = "\n";
+ local($_);
push @lines, split /\012/ while <FH>;
foreach (@lines) {
my($userid,$fullname,$email) =
$CPAN::Frontend->myprint("Going to read $index_target\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local($/) = "\n";
+ local $_;
while ($_ = $fh->READLINE) {
s/\012/\n/g;
my @ls = map {"$_\n"} split /\n/, $_;
$last_updated);
$DATE_OF_02 = $last_updated;
- if ($CPAN::META->has_inst(HTTP::Date)) {
+ my $age = time;
+ if ($CPAN::META->has_inst('HTTP::Date')) {
require HTTP::Date;
- my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
- if ($age > 30) {
+ $age -= HTTP::Date::str2time($last_updated);
+ } else {
+ $CPAN::Frontend->myprint(" HTTP::Date not available\n");
+ require Time::Local;
+ my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
+ $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
+ $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
+ }
+ $age /= 3600*24;
+ if ($age > 30) {
- $CPAN::Frontend
- ->mywarn(sprintf
- qq{Warning: This index file is %d days old.
+ $CPAN::Frontend
+ ->mywarn(sprintf
+ qq{Warning: This index file is %d days old.
Please check the host you chose as your CPAN mirror for staleness.
I'll continue but problems seem likely to happen.\a\n},
- $age);
+ $age);
+
+ } elsif ($age < -1) {
+
+ $CPAN::Frontend
+ ->mywarn(sprintf
+ qq{Warning: Your system date is %d days behind this index file!
+ System time: %s
+ Timestamp index file: %s
+ Please fix your system time, problems with the make command expected.\n},
+ -$age,
+ scalar gmtime,
+ $DATE_OF_02,
+ );
- }
- } else {
- $CPAN::Frontend->myprint(" HTTP::Date not available\n");
}
}
}
- if ($id->cpan_file ne $dist){ # update only if file is
- # different. CPAN prohibits same
- # name with different version
+ # Although CPAN prohibits same name with different version the
+ # indexer may have changed the version for the same distro
+ # since the last time ("Force Reindexing" feature)
+ if ($id->cpan_file ne $dist
+ ||
+ $id->cpan_version ne $version
+ ){
$userid = $id->userid || $self->userid($dist);
$id->set(
'CPAN_USERID' => $userid,
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
my @eval;
local($/) = "\n";
+ local $_;
while ($_ = $fh->READLINE) {
s/\012/\n/g;
my @ls = map {"$_\n"} split /\n/, $_;
}
package CPAN::InfoObj;
+use strict;
+
+sub ro {
+ my $self = shift;
+ exists $self->{RO} and return $self->{RO};
+}
-# Accessors
sub cpan_userid {
my $self = shift;
- $self->{RO}{CPAN_USERID}
+ my $ro = $self->ro or return;
+ return $ro->{CPAN_USERID};
}
sub id { shift->{ID}; }
my $class = ref($self);
$class =~ s/^CPAN:://;
push @m, $class, " id = $self->{ID}\n";
- for (sort keys %{$self->{RO}}) {
+ my $ro = $self->ro;
+ for (sort keys %$ro) {
# next if m/^(ID|RO)$/;
my $extra = "";
if ($_ eq "CPAN_USERID") {
push @m, sprintf " %-12s %s\n", $_, $self->fullname;
next;
}
- next unless defined $self->{RO}{$_};
- push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
+ next unless defined $ro->{$_};
+ push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
}
for (sort keys %$self) {
next if m/^(ID|RO)$/;
}
package CPAN::Author;
+use strict;
+
+#-> sub CPAN::Author::force
+sub force {
+ my $self = shift;
+ $self->{force}++;
+}
+
+#-> sub CPAN::Author::force
+sub unforce {
+ my $self = shift;
+ delete $self->{force};
+}
#-> sub CPAN::Author::id
sub id {
#-> sub CPAN::Author::fullname ;
sub fullname {
- shift->{RO}{FULLNAME};
+ shift->ro->{FULLNAME};
}
*name = \&fullname;
#-> sub CPAN::Author::email ;
-sub email { shift->{RO}{EMAIL}; }
+sub email { shift->ro->{EMAIL}; }
#-> sub CPAN::Author::ls ;
sub ls {
my $self = shift;
+ my $glob = shift || "";
+ my $silent = shift || 0;
my $id = $self->id;
- # adapted from CPAN::Distribution::verifyMD5 ;
+ # adapted from CPAN::Distribution::verifyCHECKSUM ;
my(@csf); # chksumfile
@csf = $self->id =~ /(.)(.)(.*)/;
$csf[1] = join "", @csf[0,1];
- $csf[2] = join "", @csf[1,2];
+ $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
my(@dl);
- @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
+ @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
unless (grep {$_->[2] eq $csf[1]} @dl) {
- $CPAN::Frontend->myprint("No files in the directory of $id\n");
+ $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
return;
}
- @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
+ @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
unless (grep {$_->[2] eq $csf[2]} @dl) {
- $CPAN::Frontend->myprint("No files in the directory of $id\n");
+ $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
return;
}
- @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
+ @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
+ if ($glob) {
+ my $rglob = Text::Glob::glob_to_regex($glob);
+ @dl = grep { $_->[2] =~ /$rglob/ } @dl;
+ }
$CPAN::Frontend->myprint(join "", map {
sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
} sort { $a->[2] cmp $b->[2] } @dl);
my $self = shift;
my $chksumfile = shift;
my $recursive = shift;
+ my $may_ftp = shift;
my $lc_want =
File::Spec->catfile($CPAN::Config->{keep_source_where},
"authors", "id", @$chksumfile);
+
+ my $fh;
+
+ # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
+ # hazard. (Without GPG installed they are not that much better,
+ # though.)
+ $fh = FileHandle->new;
+ if (open($fh, $lc_want)) {
+ my $line = <$fh>; close $fh;
+ unlink($lc_want) unless $line =~ /PGP/;
+ }
+
local($") = "/";
# connect "force" argument with "index_expire".
- my $force = 0;
+ my $force = $self->{force};
if (my @stat = stat $lc_want) {
- $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
- }
- my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
- $lc_want,$force);
- unless ($lc_file) {
- $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
- $chksumfile->[-1] .= ".gz";
- $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
- "$lc_want.gz",1);
- if ($lc_file) {
- $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
- CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
- } else {
- return;
- }
+ $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
+ }
+ my $lc_file;
+ if ($may_ftp) {
+ $lc_file = CPAN::FTP->localize(
+ "authors/id/@$chksumfile",
+ $lc_want,
+ $force,
+ );
+ unless ($lc_file) {
+ $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
+ $chksumfile->[-1] .= ".gz";
+ $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
+ "$lc_want.gz",1);
+ if ($lc_file) {
+ $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
+ CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
+ } else {
+ return;
+ }
+ }
+ } else {
+ $lc_file = $lc_want;
+ # we *could* second-guess and if the user has a file: URL,
+ # then we could look there. But on the other hand, if they do
+ # have a file: URL, wy did they choose to set
+ # $CPAN::Config->{show_upload_date} to false?
}
- # adapted from CPAN::Distribution::MD5_check_file ;
- my $fh = FileHandle->new;
+ # adapted from CPAN::Distribution::CHECKSUM_check_file ;
+ $fh = FileHandle->new;
my($cksum);
if (open $fh, $lc_file){
local($/);
rename $lc_file, "$lc_file.bad";
Carp::confess($@) if $@;
}
+ } elsif ($may_ftp) {
+ Carp::carp "Could not open $lc_file for reading.";
} else {
- Carp::carp "Could not open $lc_file for reading";
+ # Maybe should warn: "You may want to set show_upload_date to a true value"
+ return;
}
my(@result,$f);
for $f (sort keys %$cksum) {
push @dir, $f, "CHECKSUMS";
push @result, map {
[$_->[0], $_->[1], "$f/$_->[2]"]
- } $self->dir_listing(\@dir,1);
+ } $self->dir_listing(\@dir,1,$may_ftp);
} else {
push @result, [ 0, "-", $f ];
}
}
package CPAN::Distribution;
+use strict;
# Accessors
-sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
+sub cpan_comment {
+ my $self = shift;
+ my $ro = $self->ro or return;
+ $ro->{CPAN_COMMENT}
+}
sub undelay {
my $self = shift;
delete $self->{later};
}
+# add the A/AN/ stuff
# CPAN::Distribution::normalize
sub normalize {
my($self,$s) = @_;
$s;
}
+sub pretty_id {
+ my $self = shift;
+ my $id = $self->id;
+ return $id unless $id =~ m|^./../|;
+ substr($id,5);
+}
+
+# mark as dirty/clean
#-> sub CPAN::Distribution::color_cmd_tmps ;
sub color_cmd_tmps {
my($self) = shift;
sub as_string {
my $self = shift;
$self->containsmods;
+ $self->upload_date;
$self->SUPER::as_string(@_);
}
keys %{$self->{CONTAINSMODS}};
}
+#-> sub CPAN::Distribution::upload_date ;
+sub upload_date {
+ my $self = shift;
+ return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
+ my(@local_wanted) = split(/\//,$self->id);
+ my $filename = pop @local_wanted;
+ push @local_wanted, "CHECKSUMS";
+ my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
+ return unless $author;
+ my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
+ return unless @dl;
+ my($dirent) = grep { $_->[2] eq $filename } @dl;
+ # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
+ return unless $dirent->[1];
+ return $self->{UPLOAD_DATE} = $dirent->[1];
+}
+
#-> sub CPAN::Distribution::uptodate ;
sub uptodate {
my($self) = @_;
#-> sub CPAN::Distribution::safe_chdir ;
sub safe_chdir {
- my($self,$todir) = @_;
- # we die if we cannot chdir and we are debuggable
- Carp::confess("safe_chdir called without todir argument")
- unless defined $todir and length $todir;
- if (chdir $todir) {
- $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
- if $CPAN::DEBUG;
- } else {
+ my($self,$todir) = @_;
+ # we die if we cannot chdir and we are debuggable
+ Carp::confess("safe_chdir called without todir argument")
+ unless defined $todir and length $todir;
+ if (chdir $todir) {
+ $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
+ if $CPAN::DEBUG;
+ } else {
+ unless (-x $todir) {
+ unless (chmod 0755, $todir) {
my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor the permission ".
+ "to change the permission; cannot chdir ".
+ "to '$todir'\n");
+ sleep 5;
$CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
qq{to todir[$todir]: $!});
+ }
+ }
+ if (chdir $todir) {
+ $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
+ if $CPAN::DEBUG;
+ } else {
+ my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
+ qq{to todir[$todir] (a chmod has been issued): $!});
}
+ }
}
#-> sub CPAN::Distribution::get ;
#
# Check integrity
#
- if ($CPAN::META->has_inst("Digest::MD5")) {
- $self->debug("Digest::MD5 is installed, verifying");
- $self->verifyMD5;
+ if ($CPAN::META->has_inst("Digest::SHA")) {
+ $self->debug("Digest::SHA is installed, verifying");
+ $self->verifyCHECKSUM;
} else {
- $self->debug("Digest::MD5 is NOT installed");
+ $self->debug("Digest::SHA is NOT installed");
}
return if $CPAN::Signal;
#
# Unpack the goods
#
- if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
- $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
- $self->untar_me($local_file);
+ $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
+ my $ct = CPAN::Tarzip->new($local_file);
+ if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
+ $self->{was_uncompressed}++ unless $ct->gtest();
+ $self->untar_me($ct);
} elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
- $self->unzip_me($local_file);
- } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
- $self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
+ $self->unzip_me($ct);
+ } elsif ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/) {
+ $self->{was_uncompressed}++ unless $ct->gtest();
+ $self->debug("calling pm2dir for local_file[$local_file]") if $CPAN::DEBUG;
$self->pm2dir_me($local_file);
} else {
$self->{archived} = "NO";
$self->safe_chdir($builddir);
File::Path::rmtree("tmp");
+ $self->safe_chdir($packagedir);
+ if ($CPAN::META->has_inst("Module::Signature")) {
+ if (-f "SIGNATURE") {
+ $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
+ my $rv = Module::Signature::verify();
+ if ($rv != Module::Signature::SIGNATURE_OK() and
+ $rv != Module::Signature::SIGNATURE_MISSING()) {
+ $CPAN::Frontend->myprint(
+ qq{\nSignature invalid for }.
+ qq{distribution file. }.
+ qq{Please investigate.\n\n}.
+ $self->as_string,
+ $CPAN::META->instance(
+ 'CPAN::Author',
+ $self->cpan_userid,
+ )->as_string
+ );
+
+ my $wrap =
+ sprintf(qq{I'd recommend removing %s. Its signature
+is invalid. Maybe you have configured your 'urllist' with
+a bad URL. Please check this array with 'o conf urllist', and
+retry. For more information, try opening a subshell with
+ look %s
+and there run
+ cpansign -v
+},
+ $self->{localfile},
+ $self->pretty_id,
+ );
+ $self->{signature_verify} = CPAN::Distrostatus->new("NO");
+ $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
+ $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
+ } else {
+ $self->{signature_verify} = CPAN::Distrostatus->new("YES");
+ }
+ } else {
+ $CPAN::Frontend->myprint(qq{Package came without SIGNATURE\n\n});
+ }
+ } else {
+ $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
+ }
+ $self->safe_chdir($builddir);
+ return if $CPAN::Signal;
+
+
my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
my($mpl_exists) = -f $mpl;
unless ($mpl_exists) {
$mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
$mpldh->close;
}
- unless ($mpl_exists) {
+ my $prefer_installer = "eumm"; # eumm|mb
+ if (-f File::Spec->catfile($packagedir,"Build.PL")) {
+ if ($mpl_exists) { # they *can* choose
+ if ($CPAN::META->has_inst("Module::Build")) {
+ $prefer_installer = $CPAN::Config->{prefer_installer};
+ }
+ } else {
+ $prefer_installer = "mb";
+ }
+ }
+ if (lc($prefer_installer) eq "mb") {
+ $self->{modulebuild} = "YES";
+ } elsif (! $mpl_exists) {
$self->debug(sprintf("makefilepl[%s]anycwd[%s]",
$mpl,
CPAN::anycwd(),
# CPAN::Distribution::untar_me ;
sub untar_me {
- my($self,$local_file) = @_;
+ my($self,$ct) = @_;
$self->{archived} = "tar";
- if (CPAN::Tarzip->untar($local_file)) {
+ if ($ct->untar()) {
$self->{unwrapped} = "YES";
} else {
$self->{unwrapped} = "NO";
# CPAN::Distribution::unzip_me ;
sub unzip_me {
- my($self,$local_file) = @_;
+ my($self,$ct) = @_;
$self->{archived} = "zip";
- if (CPAN::Tarzip->unzip($local_file)) {
+ if ($ct->unzip()) {
$self->{unwrapped} = "YES";
} else {
$self->{unwrapped} = "NO";
my($self,$local_file) = @_;
$self->{archived} = "pm";
my $to = File::Basename::basename($local_file);
- $to =~ s/\.(gz|Z)(?!\n)\Z//;
- if (CPAN::Tarzip->gunzip($local_file,$to)) {
- $self->{unwrapped} = "YES";
+ if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
+ if (CPAN::Tarzip->new($local_file)->gunzip($to)) {
+ $self->{unwrapped} = "YES";
+ } else {
+ $self->{unwrapped} = "NO";
+ }
} else {
- $self->{unwrapped} = "NO";
+ File::Copy::cp($local_file,".");
+ $self->{unwrapped} = "YES";
}
}
my $pwd = CPAN::anycwd();
$self->safe_chdir($dir);
$CPAN::Frontend->myprint(qq{Working directory is $dir\n});
- unless (system($CPAN::Config->{'shell'}) == 0) {
- my $code = $? >> 8;
- $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
+ {
+ local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
+ $ENV{CPAN_SHELL_LEVEL} += 1;
+ unless (system($CPAN::Config->{'shell'}) == 0) {
+ my $code = $? >> 8;
+ $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
+ }
}
$self->safe_chdir($pwd);
}
});
sleep 2;
$fh_pager->print(<$fh_readme>);
+ $fh_pager->close;
}
-#-> sub CPAN::Distribution::verifyMD5 ;
-sub verifyMD5 {
+#-> sub CPAN::Distribution::verifyCHECKSUM ;
+sub verifyCHECKSUM {
my($self) = @_;
EXCUSE: {
my @e;
- $self->{MD5_STATUS} ||= "";
- $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
+ $self->{CHECKSUM_STATUS} ||= "";
+ $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
}
my($lc_want,$lc_file,@local,$basename);
if (
-s $lc_want
&&
- $self->MD5_check_file($lc_want)
+ $self->CHECKSUM_check_file($lc_want)
) {
- return $self->{MD5_STATUS} = "OK";
+ return $self->{CHECKSUM_STATUS} = "OK";
}
$lc_file = CPAN::FTP->localize("authors/id/@local",
$lc_want,1);
"$lc_want.gz",1);
if ($lc_file) {
$lc_file =~ s/\.gz(?!\n)\Z//;
- CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
+ CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
} else {
return;
}
}
- $self->MD5_check_file($lc_file);
+ $self->CHECKSUM_check_file($lc_file);
+}
+
+sub SIG_check_file {
+ my($self,$chk_file) = @_;
+ my $rv = eval { Module::Signature::_verify($chk_file) };
+
+ if ($rv == Module::Signature::SIGNATURE_OK()) {
+ $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
+ return $self->{SIG_STATUS} = "OK";
+ } else {
+ $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
+ qq{distribution file. }.
+ qq{Please investigate.\n\n}.
+ $self->as_string,
+ $CPAN::META->instance(
+ 'CPAN::Author',
+ $self->cpan_userid
+ )->as_string);
+
+ my $wrap = qq{I\'d recommend removing $chk_file. Its signature
+is invalid. Maybe you have configured your 'urllist' with
+a bad URL. Please check this array with 'o conf urllist', and
+retry.};
+
+ $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
+ }
}
-#-> sub CPAN::Distribution::MD5_check_file ;
-sub MD5_check_file {
+#-> sub CPAN::Distribution::CHECKSUM_check_file ;
+sub CHECKSUM_check_file {
my($self,$chk_file) = @_;
my($cksum,$file,$basename);
+
+ if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
+ $self->debug("Module::Signature is installed, verifying");
+ $self->SIG_check_file($chk_file);
+ } else {
+ $self->debug("Module::Signature is NOT installed");
+ }
+
$file = $self->{localfile};
$basename = File::Basename::basename($file);
my $fh = FileHandle->new;
Carp::carp "Could not open $chk_file for reading";
}
- if (exists $cksum->{$basename}{md5}) {
+ if (exists $cksum->{$basename}{sha256}) {
$self->debug("Found checksum for $basename:" .
- "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
+ "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
open($fh, $file);
binmode $fh;
- my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
+ my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
$fh->close;
$fh = CPAN::Tarzip->TIEHANDLE($file);
unless ($eq) {
- # had to inline it, when I tied it, the tiedness got lost on
- # the call to eq_MD5. (Jan 1998)
- my $md5 = Digest::MD5->new;
+ my $dg = Digest::SHA->new(256);
my($data,$ref);
$ref = \$data;
while ($fh->READ($ref, 4096) > 0){
- $md5->add($data);
+ $dg->add($data);
}
- my $hexdigest = $md5->hexdigest;
- $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
+ my $hexdigest = $dg->hexdigest;
+ $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
}
if ($eq) {
$CPAN::Frontend->myprint("Checksum for $file ok\n");
- return $self->{MD5_STATUS} = "OK";
+ return $self->{CHECKSUM_STATUS} = "OK";
} else {
$CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
qq{distribution file. }.
$self->cpan_userid
)->as_string);
- my $wrap = qq{I\'d recommend removing $file. Its MD5
+ my $wrap = qq{I\'d recommend removing $file. Its
checksum is incorrect. Maybe you have configured your 'urllist' with
a bad URL. Please check this array with 'o conf urllist', and
retry.};
}
# close $fh if fileno($fh);
} else {
- $self->{MD5_STATUS} ||= "";
- if ($self->{MD5_STATUS} eq "NIL") {
+ $self->{CHECKSUM_STATUS} ||= "";
+ if ($self->{CHECKSUM_STATUS} eq "NIL") {
$CPAN::Frontend->mywarn(qq{
-Warning: No md5 checksum for $basename in $chk_file.
+Warning: No checksum for $basename in $chk_file.
The cause for this may be that the file is very new and the checksum
has not yet been calculated, but it may also be that something is
my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
$answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
}
- $self->{MD5_STATUS} = "NIL";
+ $self->{CHECKSUM_STATUS} = "NIL";
return;
}
}
-#-> sub CPAN::Distribution::eq_MD5 ;
-sub eq_MD5 {
- my($self,$fh,$expectMD5) = @_;
- my $md5 = Digest::MD5->new;
+#-> sub CPAN::Distribution::eq_CHECKSUM ;
+sub eq_CHECKSUM {
+ my($self,$fh,$expect) = @_;
+ my $dg = Digest::SHA->new(256);
my($data);
while (read($fh, $data, 4096)){
- $md5->add($data);
+ $dg->add($data);
}
- # $md5->addfile($fh);
- my $hexdigest = $md5->hexdigest;
+ my $hexdigest = $dg->hexdigest;
# warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
- $hexdigest eq $expectMD5;
+ $hexdigest eq $expect;
}
#-> sub CPAN::Distribution::force ;
-# Both modules and distributions know if "force" is in effect by
-# autoinspection, not by inspecting a global variable. One of the
-# reason why this was chosen to work that way was the treatment of
-# dependencies. They should not autpomatically inherit the force
+# Both CPAN::Modules and CPAN::Distributions know if "force" is in
+# effect by autoinspection, not by inspecting a global variable. One
+# of the reason why this was chosen to work that way was the treatment
+# of dependencies. They should not automatically inherit the force
# status. But this has the downside that ^C and die() will return to
# the prompt but will not be able to reset the force_update
# attributes. We try to correct for it currently in the read_metadata
sub force {
my($self, $method) = @_;
for my $att (qw(
- MD5_STATUS archived build_dir localfile make install unwrapped
+ CHECKSUM_STATUS archived build_dir localfile make install unwrapped
writemakefile
)) {
delete $self->{$att};
}
- if ($method && $method eq "install") {
+ if ($method && $method =~ /make|test|install/) {
$self->{"force_update"}++; # name should probably have been force_install
}
}
+sub notest {
+ my($self, $method) = @_;
+ # warn "XDEBUG: set notest for $self $method";
+ $self->{"notest"}++; # name should probably have been force_install
+}
+
+sub unnotest {
+ my($self) = @_;
+ # warn "XDEBUG: deleting notest";
+ delete $self->{'notest'};
+}
+
#-> sub CPAN::Distribution::unforce ;
sub unforce {
my($self) = @_;
}
}
+
#-> sub CPAN::Distribution::perl ;
sub perl {
- my($self) = @_;
- my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
- my $pwd = CPAN::anycwd();
- my $candidate = File::Spec->catfile($pwd,$^X);
- $perl ||= $candidate if MM->maybe_command($candidate);
- unless ($perl) {
- my ($component,$perl_name);
- DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
- PATH_COMPONENT: foreach $component (File::Spec->path(),
- $Config::Config{'binexp'}) {
- next unless defined($component) && $component;
- my($abs) = File::Spec->catfile($component,$perl_name);
- if (MM->maybe_command($abs)) {
- $perl = $abs;
- last DIST_PERLNAME;
- }
- }
- }
- }
- $perl;
+ return $CPAN::Perl;
}
+
#-> sub CPAN::Distribution::make ;
sub make {
my($self) = @_;
- $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
+ my $make = $self->{modulebuild} ? "Build" : "make";
+ $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
# Emergency brake if they said install Pippi and get newest perl
if ($self->isa_perl) {
if (
}
$self->get;
EXCUSE: {
- my @e;
- $self->{archived} eq "NO" and push @e,
- "Is neither a tar nor a zip archive.";
+ my @e;
+ !$self->{archived} || $self->{archived} eq "NO" and push @e,
+ "Is neither a tar nor a zip archive.";
+
+ !$self->{unwrapped} || $self->{unwrapped} eq "NO" and push @e,
+ "Had problems unarchiving. Please build manually";
- $self->{unwrapped} eq "NO" and push @e,
- "had problems unarchiving. Please build manually";
+ unless ($self->{force_update}) {
+ exists $self->{signature_verify} and $self->{signature_verify}->failed
+ and push @e, "Did not pass the signature test.";
+ }
- exists $self->{writemakefile} &&
- $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
- $1 || "Had some problem writing Makefile";
+ exists $self->{writemakefile} &&
+ $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";
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
}
$CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
- my $builddir = $self->dir;
+ my $builddir = $self->dir or
+ $CPAN::Frontend->mydie("PANIC: Cannot determine build directory");
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'};
+ $system = $self->{'configure'};
+ } elsif ($self->{modulebuild}) {
+ my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
+ $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
} else {
my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
my $switch = "";
# wait;
waitpid $pid, 0;
} else { #child
- # note, this exec isn't necessary if
- # inactivity_timeout is 0. On the Mac I'd
- # suggest, we set it always to 0.
- exec $system;
+ # note, this exec isn't necessary if
+ # inactivity_timeout is 0. On the Mac I'd
+ # suggest, we set it always to 0.
+ exec $system;
}
} else {
$CPAN::Frontend->myprint("Cannot fork: $!");
return;
}
}
- if (-f "Makefile") {
+ if (-f "Makefile" || -f "Build") {
$self->{writemakefile} = "YES";
delete $self->{make_clean}; # if cleaned before, enable next
} else {
if (my @prereq = $self->unsat_prereq){
return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
}
- $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
+ if ($self->{modulebuild}) {
+ $system = "./Build $CPAN::Config->{mbuild_arg}";
+ } else {
+ $system = join " ", _make_command(), $CPAN::Config->{make_arg};
+ }
if (system($system) == 0) {
$CPAN::Frontend->myprint(" $system -- OK\n");
- $self->{'make'} = "YES";
+ $self->{'make'} = CPAN::Distrostatus->new("YES");
} else {
$self->{writemakefile} ||= "YES";
- $self->{'make'} = "NO";
+ $self->{'make'} = CPAN::Distrostatus->new("NO");
$CPAN::Frontend->myprint(" $system -- NOT OK\n");
}
}
+sub _make_command {
+ return $CPAN::Config->{'make'} || $Config::Config{make} || 'make';
+}
+
sub follow_prereqs {
my($self) = shift;
- my(@prereq) = @_;
+ my(@prereq) = grep {$_ ne "perl"} @_;
+ return unless @prereq;
my $id = $self->id;
$CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
"during [$id] -----\n");
# if they have not specified a version, we accept any installed one
if (not defined $need_version or
- $need_version == 0 or
+ $need_version eq "0" or
$need_version eq "undef") {
next if defined $nmo->inst_file;
}
# We only want to install prereqs if either they're not installed
# or if the installed version is too old. We cannot omit this
# check, because if 'force' is in effect, nobody else will check.
- {
+ if (defined $nmo->inst_file) {
+ my(@all_requirements) = split /\s*,\s*/, $need_version;
local($^W) = 0;
- if (
- defined $nmo->inst_file &&
- ! CPAN::Version->vgt($need_version, $nmo->inst_version)
- ){
- CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
+ my $ok = 0;
+ RQ: for my $rq (@all_requirements) {
+ if ($rq =~ s|>=\s*||) {
+ } elsif ($rq =~ s|>\s*||) {
+ # 2005-12: one user
+ if (CPAN::Version->vgt($nmo->inst_version,$rq)){
+ $ok++;
+ }
+ next RQ;
+ } elsif ($rq =~ s|!=\s*||) {
+ # 2005-12: no user
+ if (CPAN::Version->vcmp($nmo->inst_version,$rq)){
+ $ok++;
+ next RQ;
+ } else {
+ last RQ;
+ }
+ } elsif ($rq =~ m|<=?\s*|) {
+ # 2005-12: no user
+ $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])");
+ $ok++;
+ next RQ;
+ }
+ if (! CPAN::Version->vgt($rq, $nmo->inst_version)){
+ $ok++;
+ }
+ CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]rq[%s]ok[%d]",
$nmo->id,
$nmo->inst_file,
$nmo->inst_version,
- CPAN::Version->readable($need_version)
- );
- next NEED;
+ CPAN::Version->readable($rq),
+ $ok,
+ ) if $CPAN::DEBUG;
}
+ next NEED if $ok == @all_requirements;
}
if ($self->{sponsored_mods}{$need_module}++){
@need;
}
+#-> sub CPAN::Distribution::read_yaml ;
+sub read_yaml {
+ my($self) = @_;
+ return $self->{yaml_content} if exists $self->{yaml_content};
+ my $build_dir = $self->{build_dir};
+ my $yaml = File::Spec->catfile($build_dir,"META.yml");
+ return unless -f $yaml;
+ if ($CPAN::META->has_inst("YAML")) {
+ eval { $self->{yaml_content} = YAML::LoadFile($yaml); };
+ if ($@) {
+ $CPAN::Frontend->mywarn("Error while parsing META.yml: $@");
+ return;
+ }
+ }
+ return $self->{yaml_content};
+}
+
#-> sub CPAN::Distribution::prereq_pm ;
sub prereq_pm {
- my($self) = @_;
- return $self->{prereq_pm} if
- exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
- return unless $self->{writemakefile}; # no need to have succeeded
- # but we must have run it
- my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
- my $makefile = File::Spec->catfile($build_dir,"Makefile");
- my(%p) = ();
- my $fh;
- if (-f $makefile
- and
- $fh = FileHandle->new("<$makefile\0")) {
-
- local($/) = "\n";
-
- # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
- while (<$fh>) {
- last if /MakeMaker post_initialize section/;
- my($p) = m{^[\#]
- \s+PREREQ_PM\s+=>\s+(.+)
- }x;
- next unless $p;
- # warn "Found prereq expr[$p]";
-
- # Regexp modified by A.Speer to remember actual version of file
- # PREREQ_PM hash key wants, then add to
- while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
- # In case a prereq is mentioned twice, complain.
- if ( defined $p{$1} ) {
- warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
- }
- $p{$1} = $2;
- }
- last;
- }
- }
- $self->{prereq_pm_detected}++;
- return $self->{prereq_pm} = \%p;
+ my($self) = @_;
+ return $self->{prereq_pm} if
+ exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
+ return unless $self->{writemakefile} # no need to have succeeded
+ # but we must have run it
+ || $self->{mudulebuild};
+ my $req;
+ if (my $yaml = $self->read_yaml) {
+ $req = $yaml->{requires};
+ undef $req unless ref $req eq "HASH" && %$req;
+ if ($req) {
+ if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
+ my $eummv = do { local $^W = 0; $1+0; };
+ if ($eummv < 6.2501) {
+ # thanks to Slaven for digging that out: MM before
+ # that could be wrong because it could reflect a
+ # previous release
+ undef $req;
+ }
+ }
+ my $areq;
+ my $do_replace;
+ while (my($k,$v) = each %{$req||{}}) {
+ if ($v =~ /\d/) {
+ $areq->{$k} = $v;
+ } elsif ($k =~ /[A-Za-z]/ &&
+ $v =~ /[A-Za-z]/ &&
+ $CPAN::META->exists("Module",$v)
+ ) {
+ $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
+ "requires hash: $k => $v; I'll take both ".
+ "key and value as a module name\n");
+ sleep 1;
+ $areq->{$k} = 0;
+ $areq->{$v} = 0;
+ $do_replace++;
+ }
+ }
+ $req = $areq if $do_replace;
+ }
+ if ($req) {
+ delete $req->{perl};
+ }
+ }
+ unless ($req) {
+ my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
+ my $makefile = File::Spec->catfile($build_dir,"Makefile");
+ my $fh;
+ if (-f $makefile
+ and
+ $fh = FileHandle->new("<$makefile\0")) {
+ local($/) = "\n";
+ while (<$fh>) {
+ last if /MakeMaker post_initialize section/;
+ my($p) = m{^[\#]
+ \s+PREREQ_PM\s+=>\s+(.+)
+ }x;
+ next unless $p;
+ # warn "Found prereq expr[$p]";
+
+ # Regexp modified by A.Speer to remember actual version of file
+ # PREREQ_PM hash key wants, then add to
+ while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
+ # In case a prereq is mentioned twice, complain.
+ if ( defined $req->{$1} ) {
+ warn "Warning: PREREQ_PM mentions $1 more than once, ".
+ "last mention wins";
+ }
+ $req->{$1} = $2;
+ }
+ last;
+ }
+ } elsif (-f "Build") {
+ if ($CPAN::META->has_inst("Module::Build")) {
+ $req = Module::Build->current->requires();
+ }
+ }
+ }
+ $self->{prereq_pm_detected}++;
+ return $self->{prereq_pm} = $req;
}
#-> sub CPAN::Distribution::test ;
delete $self->{force_update};
return;
}
- $CPAN::Frontend->myprint("Running make test\n");
+ # warn "XDEBUG: checking for notest: $self->{notest} $self";
+ if ($self->{notest}) {
+ $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
+ return 1;
+ }
+
+ my $make = $self->{modulebuild} ? "Build" : "make";
+ $CPAN::Frontend->myprint("Running $make test\n");
if (my @prereq = $self->unsat_prereq){
return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
}
"Make had some problems, maybe interrupted? Won't test";
exists $self->{'make'} and
- $self->{'make'} eq 'NO' and
+ $self->{'make'}->failed and
push @e, "Can't test without successful make";
exists $self->{build_dir} or push @e, "Has no own directory";
return;
}
- local $ENV{PERL5LIB} = $ENV{PERL5LIB} || "";
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+
$CPAN::META->set_perl5lib;
- my $system = join " ", $CPAN::Config->{'make'}, "test";
+ my $system;
+ if ($self->{modulebuild}) {
+ $system = "./Build test";
+ } else {
+ $system = join " ", _make_command(), "test";
+ }
if (system($system) == 0) {
$CPAN::Frontend->myprint(" $system -- OK\n");
$CPAN::META->is_tested($self->{'build_dir'});
- $self->{make_test} = "YES";
+ $self->{make_test} = CPAN::Distrostatus->new("YES");
} else {
- $self->{make_test} = "NO";
+ $self->{make_test} = CPAN::Distrostatus->new("NO");
$self->{badtestcnt}++;
$CPAN::Frontend->myprint(" $system -- NOT OK\n");
}
#-> sub CPAN::Distribution::clean ;
sub clean {
my($self) = @_;
- $CPAN::Frontend->myprint("Running make clean\n");
+ my $make = $self->{modulebuild} ? "Build" : "make";
+ $CPAN::Frontend->myprint("Running $make clean\n");
+ unless (exists $self->{build_dir}) {
+ $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
+ return 1;
+ }
EXCUSE: {
my @e;
exists $self->{make_clean} and $self->{make_clean} eq "YES" and
push @e, "make clean already called once";
- exists $self->{build_dir} or push @e, "Has no own directory";
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
}
chdir $self->{'build_dir'} or
return;
}
- my $system = join " ", $CPAN::Config->{'make'}, "clean";
+ my $system;
+ if ($self->{modulebuild}) {
+ $system = "./Build clean";
+ } else {
+ $system = join " ", _make_command(), "clean";
+ }
if (system($system) == 0) {
$CPAN::Frontend->myprint(" $system -- OK\n");
# will untar everything again. Instead we should bring the
# object's state back to where it is after untarring.
- delete $self->{force_update};
- delete $self->{install};
- delete $self->{writemakefile};
- delete $self->{make};
- delete $self->{make_test}; # no matter if yes or no, tests must be redone
+ for my $k (qw(
+ force_update
+ install
+ writemakefile
+ make
+ make_test
+ )) {
+ delete $self->{$k};
+ }
$self->{make_clean} = "YES";
} else {
delete $self->{force_update};
return;
}
- $CPAN::Frontend->myprint("Running make install\n");
+ my $make = $self->{modulebuild} ? "Build" : "make";
+ $CPAN::Frontend->myprint("Running $make install\n");
EXCUSE: {
my @e;
exists $self->{build_dir} or push @e, "Has no own directory";
"Make had some problems, maybe interrupted? Won't install";
exists $self->{'make'} and
- $self->{'make'} eq 'NO' and
+ $self->{'make'}->failed and
push @e, "make had returned bad status, install seems impossible";
- push @e, "make test had returned bad status, ".
- "won't install without force"
- if exists $self->{'make_test'} and
- $self->{'make_test'} eq 'NO' and
- ! $self->{'force_update'};
-
+ if (exists $self->{make_test} and
+ $self->{make_test}->failed){
+ if ($self->{force_update}) {
+ $self->{make_test}->text("FAILED but failure ignored because ".
+ "'force' in effect");
+ } else {
+ push @e, "make test had returned bad status, ".
+ "won't install without force"
+ }
+ }
exists $self->{'install'} and push @e,
- $self->{'install'} eq "YES" ?
+ $self->{'install'}->text eq "YES" ?
"Already done" : "Already tried without success";
exists $self->{later} and length($self->{later}) and
return;
}
- my $system = join(" ", $CPAN::Config->{'make'},
- "install", $CPAN::Config->{make_install_arg});
+ my $system;
+ if ($self->{modulebuild}) {
+ my($mbuild_install_build_command) = $CPAN::Config->{'mbuild_install_build_command'} ||
+ "./Build";
+ $system = join(" ",
+ $mbuild_install_build_command,
+ "install",
+ $CPAN::Config->{mbuild_install_arg},
+ );
+ } else {
+ my($make_install_make_command) = $CPAN::Config->{'make_install_make_command'} ||
+ _make_command();
+ $system = join(" ",
+ $make_install_make_command,
+ "install",
+ $CPAN::Config->{make_install_arg},
+ );
+ }
+
my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
my($pipe) = FileHandle->new("$system $stderr |");
my($makeout) = "";
if ($?==0) {
$CPAN::Frontend->myprint(" $system -- OK\n");
$CPAN::META->is_installed($self->{'build_dir'});
- return $self->{'install'} = "YES";
+ return $self->{'install'} = CPAN::Distrostatus->new("YES");
} else {
- $self->{'install'} = "NO";
+ $self->{'install'} = CPAN::Distrostatus->new("NO");
$CPAN::Frontend->myprint(" $system -- NOT OK\n");
- if ($makeout =~ /permission/s && $> > 0) {
- $CPAN::Frontend->myprint(qq{ You may have to su }.
- qq{to root to install the package\n});
+ if (
+ $makeout =~ /permission/s
+ && $> > 0
+ && (
+ ! $CPAN::Config->{make_install_make_command}
+ || $CPAN::Config->{make_install_make_command} eq $CPAN::Config->{make}
+ )
+ ) {
+ $CPAN::Frontend->myprint(
+ qq{----\n}.
+ qq{ You may have to su }.
+ qq{to root to install the package\n}.
+ qq{ (Or you may want to run something like\n}.
+ qq{ o conf make_install_make_command 'sudo make'\n}.
+ qq{ to raise your permissions.}
+ );
}
}
delete $self->{force_update};
shift->{'build_dir'};
}
+#-> sub CPAN::Distribution::perldoc ;
+sub perldoc {
+ my($self) = @_;
+
+ my($dist) = $self->id;
+ my $package = $self->called_for;
+
+ $self->_display_url( $CPAN::Defaultdocs . $package );
+}
+
+#-> sub CPAN::Distribution::_check_binary ;
+sub _check_binary {
+ my ($dist,$shell,$binary) = @_;
+ my ($pid,$readme,$out);
+
+ $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
+ if $CPAN::DEBUG;
+
+ $pid = open $readme, "which $binary|"
+ or $CPAN::Frontend->mydie(qq{Could not fork 'which $binary': $!});
+ while (<$readme>) {
+ $out .= $_;
+ }
+ close $readme or die "Could not run 'which $binary': $!";
+
+ $CPAN::Frontend->myprint(qq{ + $out \n})
+ if $CPAN::DEBUG && $out;
+
+ return $out;
+}
+
+#-> sub CPAN::Distribution::_display_url ;
+sub _display_url {
+ my($self,$url) = @_;
+ my($res,$saved_file,$pid,$readme,$out);
+
+ $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
+ if $CPAN::DEBUG;
+
+ # should we define it in the config instead?
+ my $html_converter = "html2text";
+
+ my $web_browser = $CPAN::Config->{'lynx'} || undef;
+ my $web_browser_out = $web_browser
+ ? CPAN::Distribution->_check_binary($self,$web_browser)
+ : undef;
+
+ my ($tmpout,$tmperr);
+ if (not $web_browser_out) {
+ # web browser not found, let's try text only
+ my $html_converter_out =
+ CPAN::Distribution->_check_binary($self,$html_converter);
+
+ if ($html_converter_out ) {
+ # html2text found, run it
+ $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
+ $CPAN::Frontend->myprint(qq{ERROR: problems while getting $url, $!\n})
+ unless defined($saved_file);
+
+ $pid = open $readme, "$html_converter $saved_file |"
+ or $CPAN::Frontend->mydie(qq{
+Could not fork '$html_converter $saved_file': $!});
+ my $fh = File::Temp->new(
+ template => 'cpan_htmlconvert_XXXX',
+ suffix => '.txt',
+ unlink => 0,
+ );
+ while (<$readme>) {
+ $fh->print($_);
+ }
+ close $readme
+ or $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
+ my $tmpin = $fh->filename;
+ $CPAN::Frontend->myprint(sprintf(qq{
+Run '%s %s' and
+saved output to %s\n},
+ $html_converter,
+ $saved_file,
+ $tmpin,
+ )) if $CPAN::DEBUG;
+ close $fh; undef $fh;
+ open $fh, $tmpin
+ or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
+ my $fh_pager = FileHandle->new;
+ local($SIG{PIPE}) = "IGNORE";
+ $fh_pager->open("|$CPAN::Config->{'pager'}")
+ or $CPAN::Frontend->mydie(qq{
+Could not open pager $CPAN::Config->{'pager'}: $!});
+ $CPAN::Frontend->myprint(qq{
+Displaying URL
+ $url
+with pager "$CPAN::Config->{'pager'}"
+});
+ sleep 2;
+ $fh_pager->print(<$fh>);
+ $fh_pager->close;
+ } else {
+ # coldn't find the web browser or html converter
+ $CPAN::Frontend->myprint(qq{
+You need to install lynx or $html_converter to use this feature.});
+ }
+ } else {
+ # web browser found, run the action
+ my $browser = $CPAN::Config->{'lynx'};
+ $CPAN::Frontend->myprint(qq{system[$browser $url]})
+ if $CPAN::DEBUG;
+ $CPAN::Frontend->myprint(qq{
+Displaying URL
+ $url
+with browser $browser
+});
+ sleep 2;
+ system("$browser $url");
+ if ($saved_file) { 1 while unlink($saved_file) }
+ }
+}
+
+#-> sub CPAN::Distribution::_getsave_url ;
+sub _getsave_url {
+ my($dist, $shell, $url) = @_;
+
+ $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
+ if $CPAN::DEBUG;
+
+ my $fh = File::Temp->new(
+ template => "cpan_getsave_url_XXXX",
+ suffix => ".html",
+ unlink => 0,
+ );
+ my $tmpin = $fh->filename;
+ if ($CPAN::META->has_usable('LWP')) {
+ $CPAN::Frontend->myprint("Fetching with LWP:
+ $url
+");
+ my $Ua;
+ CPAN::LWP::UserAgent->config;
+ eval { $Ua = CPAN::LWP::UserAgent->new; };
+ if ($@) {
+ $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
+ return;
+ } else {
+ my($var);
+ $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};
+ }
+
+ my $req = HTTP::Request->new(GET => $url);
+ $req->header('Accept' => 'text/html');
+ my $res = $Ua->request($req);
+ if ($res->is_success) {
+ $CPAN::Frontend->myprint(" + request successful.\n")
+ if $CPAN::DEBUG;
+ print $fh $res->content;
+ close $fh;
+ $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
+ if $CPAN::DEBUG;
+ return $tmpin;
+ } else {
+ $CPAN::Frontend->myprint(sprintf(
+ "LWP failed with code[%s], message[%s]\n",
+ $res->code,
+ $res->message,
+ ));
+ return;
+ }
+ } else {
+ $CPAN::Frontend->myprint("LWP not available\n");
+ return;
+ }
+}
+
package CPAN::Bundle;
+use strict;
sub look {
my $self = shift;
}
}
+# mark as dirty/clean
#-> sub CPAN::Bundle::color_cmd_tmps ;
sub color_cmd_tmps {
my($self) = shift;
$self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
my $obj = $CPAN::META->instance($type,$s);
$obj->$meth();
- if ($obj->isa(CPAN::Bundle)
+ if ($obj->isa('CPAN::Bundle')
&&
exists $obj->{install_failed}
&&
#-> sub CPAN::Bundle::force ;
sub force { shift->rematein('force',@_); }
+#-> sub CPAN::Bundle::notest ;
+sub notest { shift->rematein('notest',@_); }
#-> sub CPAN::Bundle::get ;
sub get { shift->rematein('get',@_); }
#-> sub CPAN::Bundle::make ;
}
package CPAN::Module;
+use strict;
# Accessors
# sub CPAN::Module::userid
sub userid {
my $self = shift;
- return unless exists $self->{RO}; # should never happen
- return $self->{RO}{userid} || $self->{RO}{CPAN_USERID};
+ my $ro = $self->ro;
+ return unless $ro;
+ return $ro->{userid} || $ro->{CPAN_USERID};
}
# sub CPAN::Module::description
-sub description { shift->{RO}{description} }
+sub description {
+ my $self = shift;
+ my $ro = $self->ro or return "";
+ $ro->{description}
+}
sub undelay {
my $self = shift;
}
}
+# mark as dirty/clean
#-> sub CPAN::Module::color_cmd_tmps ;
sub color_cmd_tmps {
my($self) = shift;
return if exists $self->{incommandcolor}
&& $self->{incommandcolor}==$color;
+ return if $depth>=1 && $self->uptodate;
if ($depth>=100){
$CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
}
&&
$CPAN::META->has_inst("Term::ANSIColor")
&&
- $self->{RO}{description}
+ $self->description
) {
$color_on = Term::ANSIColor::color("green");
$color_off = Term::ANSIColor::color("reset");
}
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;
+ if (my $cpan_file = $self->cpan_file){
+ push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
+ if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
+ my $upload_date = $dist->upload_date;
+ if ($upload_date) {
+ push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
+ }
+ }
+ }
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
$stats{' '} = 'unknown';
$statl{' '} = 'unknown';
$stati{' '} = 'unknown';
+ my $ro = $self->ro;
push @m, sprintf(
$sprintf3,
'DSLI_STATUS',
- $self->{RO}{statd},
- $self->{RO}{stats},
- $self->{RO}{statl},
- $self->{RO}{stati},
- $statd{$self->{RO}{statd}},
- $stats{$self->{RO}{stats}},
- $statl{$self->{RO}{statl}},
- $stati{$self->{RO}{stati}}
- ) if $self->{RO}{statd};
+ $ro->{statd},
+ $ro->{stats},
+ $ro->{statl},
+ $ro->{stati},
+ $statd{$ro->{statd}},
+ $stats{$ro->{stats}},
+ $statl{$ro->{statl}},
+ $stati{$ro->{stati}}
+ ) if $ro && $ro->{statd};
my $local_file = $self->inst_file;
unless ($self->{MANPAGE}) {
if ($local_file) {
sub cpan_file {
my $self = shift;
CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
- unless (defined $self->{RO}{CPAN_FILE}) {
+ unless ($self->ro) {
CPAN::Index->reload;
}
- if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
- return $self->{RO}{CPAN_FILE};
+ my $ro = $self->ro;
+ if ($ro && defined $ro->{CPAN_FILE}){
+ return $ro->{CPAN_FILE};
} else {
my $userid = $self->userid;
if ( $userid ) {
sub cpan_version {
my $self = shift;
- $self->{RO}{CPAN_VERSION} = 'undef'
- unless defined $self->{RO}{CPAN_VERSION};
- # I believe this is always a bug in the index and should be reported
- # as such, but usually I find out such an error and do not want to
- # provoke too many bugreports
-
- $self->{RO}{CPAN_VERSION};
+ my $ro = $self->ro;
+ unless ($ro) {
+ # Can happen with modules that are not on CPAN
+ $ro = {};
+ }
+ $ro->{CPAN_VERSION} = 'undef'
+ unless defined $ro->{CPAN_VERSION};
+ $ro->{CPAN_VERSION};
}
#-> sub CPAN::Module::force ;
$self->{'force_update'}++;
}
+sub notest {
+ my($self) = @_;
+ # warn "XDEBUG: set notest for Module";
+ $self->{'notest'}++;
+}
+
#-> sub CPAN::Module::rematein ;
sub rematein {
my($self,$meth) = @_;
my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
$pack->called_for($self->id);
$pack->force($meth) if exists $self->{'force_update'};
- $pack->$meth();
+ $pack->notest($meth) if exists $self->{'notest'};
+ eval {
+ $pack->$meth();
+ };
+ my $err = $@;
$pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
+ $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
delete $self->{'force_update'};
+ delete $self->{'notest'};
+ if ($err) {
+ die $err;
+ }
}
+#-> sub CPAN::Module::perldoc ;
+sub perldoc { shift->rematein('perldoc') }
#-> sub CPAN::Module::readme ;
-sub readme { shift->rematein('readme') }
+sub readme { shift->rematein('readme') }
#-> sub CPAN::Module::look ;
-sub look { shift->rematein('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 get { shift->rematein('get',@_) }
#-> sub CPAN::Module::make ;
-sub make {
- my $self = shift;
- $self->rematein('make');
-}
+sub make { shift->rematein('make') }
#-> sub CPAN::Module::test ;
sub test {
my $self = shift;
&&
not exists $self->{'force_update'}
) {
- $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
+ $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
+ $self->id,
+ $self->inst_version,
+ ));
} else {
$doit = 1;
}
- if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") {
+ my $ro = $self->ro;
+ if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
$CPAN::Frontend->mywarn(qq{
\n\n\n ***WARNING***
The module $self->{ID} has no active maintainer.\n\n\n
$have; # no stringify needed, \s* above matches always
}
-package CPAN::Tarzip;
-
-# CPAN::Tarzip::gzip
-sub gzip {
- my($class,$read,$write) = @_;
- if ($CPAN::META->has_inst("Compress::Zlib")) {
- my($buffer,$fhw);
- $fhw = FileHandle->new($read)
- or $CPAN::Frontend->mydie("Could not open $read: $!");
- my $gz = Compress::Zlib::gzopen($write, "wb")
- or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
- $gz->gzwrite($buffer)
- while read($fhw,$buffer,4096) > 0 ;
- $gz->gzclose() ;
- $fhw->close;
- return 1;
- } else {
- system("$CPAN::Config->{gzip} -c $read > $write")==0;
- }
-}
-
-
-# CPAN::Tarzip::gunzip
-sub gunzip {
- my($class,$read,$write) = @_;
- if ($CPAN::META->has_inst("Compress::Zlib")) {
- my($buffer,$fhw);
- $fhw = FileHandle->new(">$write")
- or $CPAN::Frontend->mydie("Could not open >$write: $!");
- my $gz = Compress::Zlib::gzopen($read, "rb")
- or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
- $fhw->print($buffer)
- while $gz->gzread($buffer) > 0 ;
- $CPAN::Frontend->mydie("Error reading from $read: $!\n")
- if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
- $gz->gzclose() ;
- $fhw->close;
- return 1;
- } else {
- system("$CPAN::Config->{gzip} -dc $read > $write")==0;
- }
-}
-
-
-# CPAN::Tarzip::gtest
-sub gtest {
- my($class,$read) = @_;
- # After I had reread the documentation in zlib.h, I discovered that
- # uncompressed files do not lead to an gzerror (anymore?).
- if ( $CPAN::META->has_inst("Compress::Zlib") ) {
- my($buffer,$len);
- $len = 0;
- my $gz = Compress::Zlib::gzopen($read, "rb")
- or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
- $read,
- $Compress::Zlib::gzerrno));
- while ($gz->gzread($buffer) > 0 ){
- $len += length($buffer);
- $buffer = "";
- }
- my $err = $gz->gzerror;
- my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
- if ($len == -s $read){
- $success = 0;
- CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
- }
- $gz->gzclose();
- CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
- return $success;
- } else {
- return system("$CPAN::Config->{gzip} -dt $read")==0;
- }
-}
-
-
-# CPAN::Tarzip::TIEHANDLE
-sub TIEHANDLE {
- my($class,$file) = @_;
- my $ret;
- $class->debug("file[$file]");
- if ($CPAN::META->has_inst("Compress::Zlib")) {
- my $gz = Compress::Zlib::gzopen($file,"rb") or
- die "Could not gzopen $file";
- $ret = bless {GZ => $gz}, $class;
- } else {
- my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file |";
- my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
- binmode $fh;
- $ret = bless {FH => $fh}, $class;
- }
- $ret;
-}
-
-
-# CPAN::Tarzip::READLINE
-sub READLINE {
- my($self) = @_;
- if (exists $self->{GZ}) {
- my $gz = $self->{GZ};
- my($line,$bytesread);
- $bytesread = $gz->gzreadline($line);
- return undef if $bytesread <= 0;
- return $line;
- } else {
- my $fh = $self->{FH};
- return scalar <$fh>;
- }
-}
-
-
-# CPAN::Tarzip::READ
-sub READ {
- my($self,$ref,$length,$offset) = @_;
- die "read with offset not implemented" if defined $offset;
- if (exists $self->{GZ}) {
- my $gz = $self->{GZ};
- my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
- return $byteread;
- } else {
- my $fh = $self->{FH};
- return read($fh,$$ref,$length);
- }
-}
-
-
-# CPAN::Tarzip::DESTROY
-sub DESTROY {
- my($self) = @_;
- if (exists $self->{GZ}) {
- my $gz = $self->{GZ};
- $gz->gzclose() if defined $gz; # hard to say if it is allowed
- # to be undef ever. AK, 2000-09
- } else {
- my $fh = $self->{FH};
- $fh->close if defined $fh;
- }
- undef $self;
-}
-
-
-# CPAN::Tarzip::untar
-sub untar {
- my($class,$file) = @_;
- my($prefer) = 0;
-
- if (0) { # makes changing order easier
- } elsif ($BUGHUNTING){
- $prefer=2;
- } elsif (MM->maybe_command($CPAN::Config->{gzip})
- &&
- MM->maybe_command($CPAN::Config->{'tar'})) {
- # should be default until Archive::Tar is fixed
- $prefer = 1;
- } elsif (
- $CPAN::META->has_inst("Archive::Tar")
- &&
- $CPAN::META->has_inst("Compress::Zlib") ) {
- $prefer = 2;
- } else {
- $CPAN::Frontend->mydie(qq{
-CPAN.pm needs either both external programs tar and gzip installed or
-both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
-is available. Can\'t continue.
-});
- }
- if ($prefer==1) { # 1 => external gzip+tar
- my($system);
- my $is_compressed = $class->gtest($file);
- if ($is_compressed) {
- $system = "$CPAN::Config->{gzip} --decompress --stdout " .
- "< $file | $CPAN::Config->{tar} xvf -";
- } else {
- $system = "$CPAN::Config->{tar} xvf $file";
- }
- if (system($system) != 0) {
- # people find the most curious tar binaries that cannot handle
- # pipes
- if ($is_compressed) {
- (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
- if (CPAN::Tarzip->gunzip($file, $ungzf)) {
- $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
- } else {
- $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
- }
- $file = $ungzf;
- }
- $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 {
- return 1;
- }
- } elsif ($prefer==2) { # 2 => modules
- my $tar = Archive::Tar->new($file,1);
- my $af; # archive file
- my @af;
- if ($BUGHUNTING) {
- # RCS 1.337 had this code, it turned out unacceptable slow but
- # it revealed a bug in Archive::Tar. Code is only here to hunt
- # the bug again. It should never be enabled in published code.
- # GDGraph3d-0.53 was an interesting case according to Larry
- # Virden.
- warn(">>>Bughunting code enabled<<< " x 20);
- for $af ($tar->list_files) {
- if ($af =~ m!^(/|\.\./)!) {
- $CPAN::Frontend->mydie("ALERT: Archive contains ".
- "illegal member [$af]");
- }
- $CPAN::Frontend->myprint("$af\n");
- $tar->extract($af); # slow but effective for finding the bug
- return if $CPAN::Signal;
- }
- } else {
- for $af ($tar->list_files) {
- if ($af =~ m!^(/|\.\./)!) {
- $CPAN::Frontend->mydie("ALERT: Archive contains ".
- "illegal member [$af]");
- }
- $CPAN::Frontend->myprint("$af\n");
- push @af, $af;
- return if $CPAN::Signal;
- }
- $tar->extract(@af);
- }
-
- Mac::BuildTools::convert_files([$tar->list_files], 1)
- if ($^O eq 'MacOS');
-
- return 1;
- }
-}
-
-sub unzip {
- my($class,$file) = @_;
- if ($CPAN::META->has_inst("Archive::Zip")) {
- # blueprint of the code from Archive::Zip::Tree::extractTree();
- my $zip = Archive::Zip->new();
- my $status;
- $status = $zip->read($file);
- die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
- $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
- my @members = $zip->members();
- for my $member ( @members ) {
- my $af = $member->fileName();
- if ($af =~ m!^(/|\.\./)!) {
- $CPAN::Frontend->mydie("ALERT: Archive contains ".
- "illegal member [$af]");
- }
- my $status = $member->extractToFileNamed( $af );
- $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
- die "Extracting of file[$af] from zipfile[$file] failed\n" if
- $status != Archive::Zip::AZ_OK();
- return if $CPAN::Signal;
- }
- return 1;
- } else {
- my $unzip = $CPAN::Config->{unzip} or
- $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
- my @system = ($unzip, $file);
- return system(@system) == 0;
- }
-}
-
-
-package CPAN::Version;
-# CPAN::Version::vcmp courtesy Jost Krieger
-sub vcmp {
- my($self,$l,$r) = @_;
- local($^W) = 0;
- CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
-
- return 0 if $l eq $r; # short circuit for quicker success
-
- if ($l=~/^v/ <=> $r=~/^v/) {
- for ($l,$r) {
- next if /^v/;
- $_ = $self->float2vv($_);
- }
- }
-
- return
- ($l ne "undef") <=> ($r ne "undef") ||
- ($] >= 5.006 &&
- $l =~ /^v/ &&
- $r =~ /^v/ &&
- $self->vstring($l) cmp $self->vstring($r)) ||
- $l <=> $r ||
- $l cmp $r;
-}
-
-sub vgt {
- my($self,$l,$r) = @_;
- $self->vcmp($l,$r) > 0;
-}
-
-sub vstring {
- my($self,$n) = @_;
- $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
- pack "U*", split /\./, $n;
-}
-
-# vv => visible vstring
-sub float2vv {
- my($self,$n) = @_;
- my($rev) = int($n);
- $rev ||= 0;
- my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
- # architecture influence
- $mantissa ||= 0;
- $mantissa .= "0" while length($mantissa)%3;
- my $ret = "v" . $rev;
- while ($mantissa) {
- $mantissa =~ s/(\d{1,3})// or
- die "Panic: length>0 but not a digit? mantissa[$mantissa]";
- $ret .= ".".int($1);
- }
- # warn "n[$n]ret[$ret]";
- $ret;
-}
-
-sub readable {
- my($self,$n) = @_;
- $n =~ /^([\w\-\+\.]+)/;
-
- return $1 if defined $1 && length($1)>0;
- # if the first user reaches version v43, he will be treated as "+".
- # We'll have to decide about a new rule here then, depending on what
- # will be the prevailing versioning behavior then.
-
- if ($] < 5.006) { # or whenever v-strings were introduced
- # we get them wrong anyway, whatever we do, because 5.005 will
- # have already interpreted 0.2.4 to be "0.24". So even if he
- # indexer sends us something like "v0.2.4" we compare wrongly.
-
- # And if they say v1.2, then the old perl takes it as "v12"
-
- $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
- return $n;
- }
- my $better = sprintf "v%vd", $n;
- CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
- return $better;
-}
-
package CPAN;
+use strict;
1;
file name (recognized by embedded slashes), it is processed. If it is
a module, CPAN determines the distribution file in which this module
is included and processes that, following any dependencies named in
-the module's Makefile.PL (this behavior is controlled by
+the module's META.yml or Makefile.PL (this behavior is controlled by
I<prerequisites_policy>.)
Any C<make> or C<test> are run unconditionally. An
CPAN also keeps track of what it has done within the current session
and doesn't try to build a package a second time regardless if it
-succeeded or not. The C<force> command takes as a first argument the
-method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
+succeeded or not. The C<force> pragma may precede another command
+(currently: C<make>, C<test>, or C<install>) and executes the
command from scratch.
Example:
OpenGL-0.4/COPYRIGHT
[...]
+The C<notest> pragma may be set to skip the test part in the build
+process.
+
+Example:
+
+ cpan> notest install Tk
+
A C<clean> command results in a
make clean
being executed within the distribution file's working directory.
-=item get, readme, look module or distribution
+=item get, readme, perldoc, look module or distribution
C<get> downloads a distribution file without further action. C<readme>
displays the README file of the associated distribution. C<Look> gets
and untars (if not yet done) the distribution file, changes to the
appropriate directory and opens a subshell process in that directory.
+C<perldoc> displays the pod documentation of the module in html or
+plain text format.
=item ls author
-C<ls> lists all distribution files in and below an author's CPAN
-directory. Only those files that contain modules are listed and if
-there is more than one for any given module, only the most recent one
-is listed.
+=item ls globbing_expresion
+
+The first form lists all distribution files in and below an author's
+CPAN directory as they are stored in the CHECKUMS files distrbute on
+CPAN.
+
+The second form allows to limit or expand the output with shell
+globbing as in the following examples:
+
+ ls JV/make*
+ ls GSAR/*make*
+ ls */*make*
+
+The last example is very slow and outputs extra progress indicators
+that break the alignment of the result.
+
+=item failed
+
+The C<failed> command reports all distributions that failed on one of
+C<make>, C<test> or C<install> for some reason in the currently
+running shell session.
=item Signals
pressing C<^C> twice.
CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
-SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
+SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
+Build.PL> subprocess.
=back
perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
# install my favorite programs if necessary:
- for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
+ for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
my $obj = CPAN::Shell->expand('Module',$mod);
$obj->install;
}
First runs the C<get> method to make sure the distribution is
downloaded and unpacked. Changes to the directory where the
distribution has been unpacked and runs the external commands C<perl
-Makefile.PL> and C<make> there.
+Makefile.PL> or C<perl Build.PL> and C<make> there.
=item CPAN::Distribution::prereq_pm()
Returns the hash reference that has been announced by a distribution
-as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
-attempt has been made to C<make> the distribution. Returns undef
-otherwise.
+as the C<requires> element of the META.yml or the C<PREREQ_PM> hash in
+the C<Makefile.PL>. Note: works only after an attempt has been made to
+C<make> the distribution. Returns undef otherwise.
=item CPAN::Distribution::readme()
Downloads the README file associated with a distribution and runs it
through the pager specified in C<$CPAN::Config->{pager}>.
+=item CPAN::Distribution::perldoc()
+
+Downloads the pod documentation of the file associated with a
+distribution (in html format) and runs it through the external
+command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
+isn't available, it converts it to plain text with external
+command html2text and runs it through the pager specified
+in C<$CPAN::Config->{pager}>
+
=item CPAN::Distribution::test()
Changes to the directory where the distribution has been unpacked and
=item CPAN::Index::reload()
-Reloads all indices if they have been read more than
+Reloads all indices if they have not been read for more than
C<$CPAN::Config->{index_expire}> days.
=item CPAN::InfoObj::dump()
Runs a C<readme> on the distribution associated with this module.
+=item CPAN::Module::perldoc()
+
+Runs a C<perldoc> on this module.
+
=item CPAN::Module::test()
Runs a C<test> on the distribution associated with this module.
=item *
come as compressed or gzipped tarfiles or as zip files and contain a
-Makefile.PL (well, we try to handle a bit more, but without much
-enthusiasm).
+C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
+without much enthusiasm).
=back
require() statements.
The configuration dialog can be started any time later again by
-issueing the command C< o conf init > in the CPAN shell.
+issuing the command C< o conf init > in the CPAN shell.
Currently the following keys in the hash reference $CPAN::Config are
defined:
gzip location of external program gzip
histfile file to maintain history between sessions
histsize maximum number of lines to keep in histfile
- inactivity_timeout breaks interactive Makefile.PLs after this
- many seconds inactivity. Set to 0 to never break.
+ inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
+ after this many seconds inactivity. Set to 0 to
+ never break.
inhibit_startup_message
if true, does not print the startup message
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'
+ make_install_make_command
+ the make command for running 'make install', for
+ example 'sudo make'
make_install_arg same as make_arg for 'make install'
makepl_arg arguments passed to 'perl Makefile.PL'
+ mbuild_arg arguments passed to './Build'
+ mbuild_install_arg arguments passed to './Build install'
+ mbuild_install_build_command
+ command to use instead of './Build' when we are
+ in the install stage, for example 'sudo ./Build'
+ mbuildpl_arg arguments passed to 'perl Build.PL'
pager location of external program more (or any pager)
+ prefer_installer legal values are MB and EUMM: if a module
+ comes with both a Makefile.PL and a Build.PL, use
+ the former (EUMM) or the latter (MB)
prerequisites_policy
what to do if you are missing module prerequisites
('follow' automatically, 'ask' me, or 'ignore')
There's no strong security layer in CPAN.pm. CPAN.pm helps you to
install foreign, unmasked, unsigned code on your machine. We compare
to a checksum that comes from the net just as the distribution file
-itself. If somebody has managed to tamper with the distribution file,
-they may have as well tampered with the CHECKSUMS file. Future
-development will go towards strong authentication.
+itself. But we try to make it easy to add security on demand:
+
+=head2 Cryptographically signed modules
+
+Since release 1.77 CPAN.pm has been able to verify cryptographically
+signed module distributions using Module::Signature. The CPAN modules
+can be signed by their authors, thus giving more security. The simple
+unsigned MD5 checksums that were used before by CPAN protect mainly
+against accidental file corruption.
+
+You will need to have Module::Signature installed, which in turn
+requires that you have at least one of Crypt::OpenPGP module or the
+command-line F<gpg> tool installed.
+
+You will also need to be able to connect over the Internet to the public
+keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
=head1 EXPORT
for this is that the primary use is intended for the cpan shell or for
one-liners.
+=head1 ENVIRONMENT
+
+When the CPAN shell enters a subshell via the look command, it sets
+the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
+already set.
+
=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
Populating a freshly installed perl with my favorite modules is pretty
Thanks to Graham Barr for contributing the following paragraphs about
the interaction between perl, and various firewall configurations. For
-further informations on firewalls, it is recommended to consult the
+further information on firewalls, it is recommended to consult the
documentation that comes with the ncftp program. If you are unable to
go through the firewall with a simple Perl setup, it is very likely
that you can configure ncftp so that it works for your firewall.
I am not root, how can I install a module in a personal directory?
+First of all, you will want to use your own configuration, not the one
+that your root user installed. The following command sequence is a
+possible approach:
+
+ % mkdir -p $HOME/.cpan/CPAN
+ % echo '$CPAN::Config={ };' > $HOME/.cpan/CPAN/MyConfig.pm
+ % cpan
+ [...answer all questions...]
+
You will most probably like something like this:
o conf makepl_arg "LIB=~/myperl/lib \
INSTALLMAN1DIR=~/myperl/man/man1 \
INSTALLMAN3DIR=~/myperl/man/man3"
- install Sybase::Sybperl
You can make this setting permanent like all C<o conf> settings with
C<o conf commit>.
the queue of things to install in a topologically correct order. It
resolves perfectly well IFF all modules declare the prerequisites
correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
-fail and you need to install often, it is recommended sort the Bundle
+fail and you need to install often, it is recommended to sort the Bundle
definition file manually. It is planned to improve the metadata
situation for dependencies on CPAN in general, but this will still
take some time.
Extended support for converters will be made available as soon as perl
becomes stable with regard to charset issues.
-=back
+=item 11)
-=head1 BUGS
+When an install fails for some reason and then I correct the error
+condition and retry, CPAN.pm refuses to install the module, saying
+C<Already tried without success>.
+
+Use the force pragma like so
+
+ force install Foo::Bar
+
+This does a bit more than really needed because it untars the
+distribution again and runs make and test and only then install.
-We should give coverage for B<all> of the CPAN and not just the PAUSE
-part, right? In this discussion CPAN and PAUSE have become equal --
-but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
-PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
+Or, if you find this is too fast and you would prefer to do smaller
+steps, say
-Future development should be directed towards a better integration of
-the other parts.
+ force get Foo::Bar
+
+first and then continue as always. C<Force get> I<forgets> previous
+error conditions.
+
+Or you can use
+
+ look Foo::Bar
+
+and then 'make install' directly in the subshell.
+
+Or you leave the CPAN shell and start it again.
+
+For the really curious, by accessing internals directly, you I<could>
+
+ ! delete CPAN::Shell->expand("Distribution", \
+ CPAN::Shell->expand("Module","Foo::Bar") \
+ ->cpan_file)->{install}
+
+but this is neither guaranteed to work in the future nor is it a
+decent command.
+
+=back
+
+=head1 BUGS
If a Makefile.PL requires special customization of libraries, prompts
the user for special input, etc. then you may find CPAN is not able to
-build the distribution. In that case, you should attempt the
-traditional method of building a Perl module package from a shell.
+build the distribution. In that case it is recommended to attempt the
+traditional method of building a Perl module package from a shell, for
+example by using the 'look' command to open a subshell in the
+distribution's own directory.
=head1 AUTHOR
-Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
+Andreas Koenig C<< <andk@cpan.org> >>
=head1 TRANSLATIONS
=head1 SEE ALSO
-perl(1), CPAN::Nox(3)
+cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
=cut
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# End:
projects / p5sagit/p5-mst-13.2.git / blobdiff