package CPAN;
use vars qw{$META $Signal $Cwd $End $Suppress_readline};
-$VERSION = '1.15';
+$VERSION = '1.19';
-# $Id: CPAN.pm,v 1.106 1997/01/24 12:26:36 k Exp $
+# $Id: CPAN.pm,v 1.121 1997/02/03 09:08:23 k Exp $
-# my $version = substr q$Revision: 1.106 $, 10; # only used during development
+# my $version = substr q$Revision: 1.121 $, 10; # only used during development
use Carp ();
use Config ();
use FileHandle ();
use Safe ();
use Text::ParseWords ();
+use Text::Wrap;
$Cwd = Cwd::cwd();
$CPAN::Signal ||= 0;
package CPAN;
-use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META);
+use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term);
use strict qw(vars);
-@CPAN::ISA = qw(CPAN::Debug Exporter MY); # the MY class from
+@CPAN::ISA = qw(CPAN::Debug Exporter MM); # the MM class from
# MakeMaker, gives us
# catfile and catdir
if (defined $other && $other) {
chomp $other;
return if $$==$other; # should never happen
- print qq{There seems to be running another CPAN process ($other). Trying to contact...\n};
+ print qq{There seems to be running another CPAN process }.
+ qq{($other). Trying to contact...\n};
if (kill 0, $other) {
Carp::croak qq{Other job is running.\n}.
- qq{You may want to kill it and delete the lockfile, maybe. On UNIX try:\n}.
+ qq{You may want to kill it and delete the lockfile, }.
+ qq{maybe. On UNIX try:\n}.
qq{ kill $other\n}.
qq{ rm $lockfile\n};
} elsif (-w $lockfile) {
my($ans)=
ExtUtils::MakeMaker::prompt
- (qq{Other job not responding. Shall I overwrite the lockfile? (Y/N)},"y");
+ (qq{Other job not responding. Shall I overwrite }.
+ qq{the lockfile? (Y/N)},"y");
print("Ok, bye\n"), exit unless $ans =~ /^y/i;
} else {
Carp::croak(
- qq{Lockfile $lockfile not writeable by you. Cannot proceed.\n}.
+ qq{Lockfile $lockfile not writeable by you. }.
+ qq{Cannot proceed.\n}.
qq{ On UNIX try:\n}.
qq{ rm $lockfile\n}.
qq{ and then rerun us.\n}
unless ($fh = FileHandle->new(">$lockfile")) {
if ($! =~ /Permission/) {
my $incc = $INC{'CPAN/Config.pm'};
- my $myincc = MY->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
+ my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
print qq{
Your configuration suggests that CPAN.pm should use a working
$Signal = 1;
};
$SIG{'__DIE__'} = \&cleanup;
- print STDERR "Signal handler set.\n" unless $CPAN::Config->{'inhibit_startup_message'};
+ print STDERR "Signal handler set.\n"
+ unless $CPAN::Config->{'inhibit_startup_message'};
}
#-> sub CPAN::DESTROY ;
return $self->{'hasMD5'};
}
+#-> sub CPAN::hasWAIT ;
+sub hasWAIT {
+ my($self,$arg) = @_;
+ if (defined $arg) {
+ $self->{'hasWAIT'} = $arg;
+ } elsif (not defined $self->{'hasWAIT'}) {
+ eval {require CPAN::WAIT;};
+ if ($@) {
+ $self->{'hasWAIT'} = 0;
+ } else {
+ $self->{'hasWAIT'} = 1;
+ }
+ }
+ return $self->{'hasWAIT'};
+}
+
#-> sub CPAN::instance ;
sub instance {
my($mgr,$class,$id) = @_;
my $prompt = "cpan> ";
local($^W) = 1;
- my $term;
unless ($Suppress_readline) {
require Term::ReadLine;
import Term::ReadLine;
# How should we determine if we have more than stub ReadLine enabled?
my $rl_avail = $Suppress_readline ? "suppressed" :
defined &Term::ReadLine::Perl::readline ? "enabled" :
- "available (get Term::ReadKey and Term::ReadLine)";
+ "available (get Term::ReadKey and Term::ReadLine::Perl)";
print qq{
cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION)
while () {
if ($Suppress_readline) {
print $prompt;
- last unless defined (chomp($_ = <>));
+ last unless defined ($_ = <>);
+ chomp;
} else {
+# if ($CPAN::DEBUG) {
+# my($report,$item);
+# $report = "";
+# for $item (qw/ReadLine IN OUT MinLine findConsole Features/) {
+# $report .= sprintf "%-15s", $item;
+# $report .= $term->$item() || "";
+# $report .= "\n";
+# }
+# CPAN->debug($report);
+# }
last unless defined ($_ = $term->readline($prompt));
}
s/^\s//;
last;
} elsif (/./) {
my(@line);
- if ($] < 5.00322) { # parsewords had a bug at until recently
+ if ($] < 5.00322) { # parsewords had a bug until recently
@line = split;
} else {
eval { @line = Text::ParseWords::shellwords($_) };
}
}
-package CPAN::Shell;
-use vars qw($AUTOLOAD $redef);
-@CPAN::Shell::ISA = qw(CPAN::Debug);
-
-# private function ro re-eval this module (handy during development)
-#-> sub CPAN::Shell::AUTOLOAD ;
-sub AUTOLOAD {
- warn "CPAN::Shell doesn't know how to autoload $AUTOLOAD :-(
-Nothing Done.
-";
- CPAN::Shell->h;
-}
+package CPAN::CacheMgr;
+use vars qw($Du);
+@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj);
+use File::Find;
-#-> sub CPAN::Shell::h ;
-sub h {
- my($class,$about) = @_;
- if (defined $about) {
- print "Detailed help not yet implemented\n";
+#-> sub CPAN::CacheMgr::as_string ;
+sub as_string {
+ eval { require Data::Dumper };
+ if ($@) {
+ return shift->SUPER::as_string;
} else {
- print q{
-command arguments description
-a string authors
-b or display bundles
-d /regex/ info distributions
-m or about modules
-i none anything of above
-
-r as reinstall recommendations
-u above uninstalled distributions
-See manpage for autobundle, recompile, force, look, etc.
-
-make make
-test modules, make test (implies make)
-install dists, bundles, make install (implies test)
-clean "r" or "u" make clean
-readme display the README file
-
-reload index|cpan load most recent indices/CPAN.pm
-h or ? display this menu
-o various set and query options
-! perl-code eval a perl command
-q quit the shell subroutine
-};
+ return Data::Dumper::Dumper(shift);
}
}
-#-> sub CPAN::Shell::a ;
-sub a { print shift->format_result('Author',@_);}
-#-> sub CPAN::Shell::b ;
-sub b {
- my($self,@which) = @_;
- CPAN->debug("which[@which]") if $CPAN::DEBUG;
- my($incdir,$bdir,$dh);
- foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
- $bdir = $CPAN::META->catdir($incdir,"Bundle");
- if ($dh = DirHandle->new($bdir)) { # may fail
- my($entry);
- for $entry ($dh->read) {
- next if -d $CPAN::META->catdir($bdir,$entry);
- next unless $entry =~ s/\.pm$//;
- $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
- }
- }
- }
- print $self->format_result('Bundle',@which);
+#-> sub CPAN::CacheMgr::cachesize ;
+sub cachesize {
+ shift->{DU};
}
-#-> sub CPAN::Shell::d ;
-sub d { print shift->format_result('Distribution',@_);}
-#-> sub CPAN::Shell::m ;
-sub m { print shift->format_result('Module',@_);}
-#-> sub CPAN::Shell::i ;
-sub i {
- my($self) = shift;
- my(@args) = @_;
- my(@type,$type,@m);
- @type = qw/Author Bundle Distribution Module/;
- @args = '/./' unless @args;
- my(@result);
- for $type (@type) {
- push @result, $self->expand($type,@args);
+# sub check {
+# my($self,@dirs) = @_;
+# return unless -d $self->{ID};
+# my $dir;
+# @dirs = $self->dirs unless @dirs;
+# for $dir (@dirs) {
+# $self->disk_usage($dir);
+# }
+# }
+
+#-> sub CPAN::CacheMgr::clean_cache ;
+sub clean_cache {
+ my $self = shift;
+ my $dir;
+ while ($self->{DU} > $self->{'MAX'} and $dir = shift @{$self->{FIFO}}) {
+ $self->force_clean_cache($dir);
}
- my $result = @result==1 ? $result[0]->as_string : join "", map {$_->as_glimpse} @result;
- $result ||= "No objects found of any type for argument @args\n";
- print $result;
+ $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG;
}
-#-> sub CPAN::Shell::o ;
-sub o {
- my($self,$o_type,@o_what) = @_;
- $o_type ||= "";
- CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
- if ($o_type eq 'conf') {
- shift @o_what if @o_what && $o_what[0] eq 'help';
- if (!@o_what) {
- my($k,$v);
- print "CPAN::Config options:\n";
- for $k (sort keys %CPAN::Config::can) {
- $v = $CPAN::Config::can{$k};
- printf " %-18s %s\n", $k, $v;
- }
- print "\n";
- for $k (sort keys %$CPAN::Config) {
- $v = $CPAN::Config->{$k};
- if (ref $v) {
- printf " %-18s\n", $k;
- print map {"\t$_\n"} @{$v};
- } else {
- printf " %-18s %s\n", $k, $v;
- }
- }
- print "\n";
- } elsif (!CPAN::Config->edit(@o_what)) {
- print qq[Type 'o conf' to view configuration edit options\n\n];
- }
- } elsif ($o_type eq 'debug') {
- my(%valid);
- @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
- if (@o_what) {
- while (@o_what) {
- my($what) = shift @o_what;
- if ( exists $CPAN::DEBUG{$what} ) {
- $CPAN::DEBUG |= $CPAN::DEBUG{$what};
- } elsif ($what =~ /^\d/) {
- $CPAN::DEBUG = $what;
- } elsif (lc $what eq 'all') {
- my($max) = 0;
- for (values %CPAN::DEBUG) {
- $max += $_;
- }
- $CPAN::DEBUG = $max;
- } else {
- for (keys %CPAN::DEBUG) {
- next unless lc($_) eq lc($what);
- $CPAN::DEBUG |= $CPAN::DEBUG{$_};
- }
- print "unknown argument [$what]\n";
- }
- }
- } else {
- print "Valid options for debug are ".join(", ",sort(keys %CPAN::DEBUG), 'all').
- " or a number. Completion works on the options. Case is ignored.\n\n";
- }
- if ($CPAN::DEBUG) {
- print "Options set for debugging:\n";
- my($k,$v);
- for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
- $v = $CPAN::DEBUG{$k};
- printf " %-14s(%s)\n", $k, $v if $v & $CPAN::DEBUG;
- }
+#-> sub CPAN::CacheMgr::dir ;
+sub dir {
+ shift->{ID};
+}
+
+#-> sub CPAN::CacheMgr::entries ;
+sub entries {
+ my($self,$dir) = @_;
+ $dir ||= $self->{ID};
+ my($cwd) = Cwd::cwd();
+ chdir $dir or Carp::croak("Can't chdir to $dir: $!");
+ my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!");
+ my(@entries);
+ for ($dh->read) {
+ next if $_ eq "." || $_ eq "..";
+ if (-f $_) {
+ push @entries, $CPAN::META->catfile($dir,$_);
+ } elsif (-d _) {
+ push @entries, $CPAN::META->catdir($dir,$_);
} else {
- print "Debugging turned off completely.\n";
+ print STDERR "Warning: weird direntry in $dir: $_\n";
}
- } else {
- print qq{
-Known options:
- conf set or get configuration variables
- debug set or get debugging options
-};
}
+ chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
+ sort {-M $b <=> -M $a} @entries;
}
-#-> sub CPAN::Shell::reload ;
-sub reload {
- if ($_[1] =~ /cpan/i) {
- CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
- my $fh = FileHandle->new($INC{'CPAN.pm'});
- local($/);
- undef $/;
- $redef = 0;
- local($SIG{__WARN__})
- = sub {
- if ( $_[0] =~ /Subroutine \w+ redefined/ ) {
- ++$redef;
- local($|) = 1;
- print ".";
- return;
- }
- warn @_;
- };
- eval <$fh>;
- warn $@ if $@;
- print "\n$redef subroutines redefined\n";
- } elsif ($_[1] =~ /index/) {
- CPAN::Index->force_reload;
+#-> sub CPAN::CacheMgr::disk_usage ;
+sub disk_usage {
+ my($self,$dir) = @_;
+ if (! defined $dir or $dir eq "") {
+ $self->debug("Cannot determine disk usage for some reason") if $CPAN::DEBUG;
+ return;
+ }
+ return if defined $self->{SIZE}{$dir};
+ local($Du) = 0;
+ find(
+ sub {
+ return if -l $_;
+ $Du += -s;
+ },
+ $dir
+ );
+ $self->{SIZE}{$dir} = $Du/1024/1024;
+ push @{$self->{FIFO}}, $dir;
+ $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
+ $self->{DU} += $Du/1024/1024;
+ if ($self->{DU} > $self->{'MAX'} ) {
+ my($toremove) = $self->{FIFO}[0];
+ printf "...Hold on a sec... cleaning from cache (%.1f>%.1f MB): $toremove\n",
+ $self->{DU}, $self->{'MAX'};
+ $self->clean_cache;
+ } else {
+ $self->debug("NOT have to clean the cache: $self->{DU} <= $self->{'MAX'}")
+ if $CPAN::DEBUG;
+ $self->debug($self->as_string) if $CPAN::DEBUG;
}
+ $self->{DU};
}
-#-> sub CPAN::Shell::_binary_extensions ;
-sub _binary_extensions {
- my($self) = shift @_;
- my(@result,$module,%seen,%need,$headerdone);
- for $module ($self->expand('Module','/./')) {
- my $file = $module->cpan_file;
- next if $file eq "N/A";
- next if $file =~ /^Contact Author/;
- next if $file =~ /perl5[._-]\d{3}(?:[\d_]+)?\.tar[._-]gz$/;
- next unless $module->xs_file;
- local($|) = 1;
- print ".";
- push @result, $module;
- }
-# print join " | ", @result;
- print "\n";
- return @result;
+#-> sub CPAN::CacheMgr::force_clean_cache ;
+sub force_clean_cache {
+ my($self,$dir) = @_;
+ $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
+ if $CPAN::DEBUG;
+ File::Path::rmtree($dir);
+ $self->{DU} -= $self->{SIZE}{$dir};
+ delete $self->{SIZE}{$dir};
}
-#-> sub CPAN::Shell::recompile ;
-sub recompile {
- my($self) = shift @_;
- my($module,@module,$cpan_file,%dist);
- @module = $self->_binary_extensions();
- for $module (@module){ # we force now and compile later, so we don't do it twice
- $cpan_file = $module->cpan_file;
- my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
- $pack->force;
- $dist{$cpan_file}++;
- }
- for $cpan_file (sort keys %dist) {
- print " CPAN: Recompiling $cpan_file\n\n";
- my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
- $pack->install;
- $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
- # stop a package from recompiling,
- # e.g. IO-1.12 when we have perl5.003_10
+#-> sub CPAN::CacheMgr::new ;
+sub new {
+ my $class = shift;
+ my $self = {
+ ID => $CPAN::Config->{'build_dir'},
+ MAX => $CPAN::Config->{'build_cache'},
+ DU => 0
+ };
+ File::Path::mkpath($self->{ID});
+ my $dh = DirHandle->new($self->{ID});
+ bless $self, $class;
+ $self->debug("dir [$self->{ID}]") if $CPAN::DEBUG;
+ my $e;
+ for $e ($self->entries) {
+ next if $e eq ".." || $e eq ".";
+ $self->debug("Have to check size $e") if $CPAN::DEBUG;
+ $self->disk_usage($e);
}
+ $self;
}
-#-> sub CPAN::Shell::_u_r_common ;
-sub _u_r_common {
- my($self) = shift @_;
- my($what) = shift @_;
- CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
- Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
- Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
- my(@args) = @_;
- @args = '/./' unless @args;
- my(@result,$module,%seen,%need,$headerdone,$version_zeroes);
- $version_zeroes = 0;
- my $sprintf = "%-25s %9s %9s %s\n";
- for $module ($self->expand('Module',@args)) {
- my $file = $module->cpan_file;
- next unless defined $file; # ??
- my($latest) = $module->cpan_version || 0;
- my($inst_file) = $module->inst_file;
- my($have);
- if ($inst_file){
- if ($what eq "a") {
- $have = $module->inst_version;
- } elsif ($what eq "r") {
- $have = $module->inst_version;
- local($^W) = 0;
- $version_zeroes++ unless $have;
- next if $have >= $latest;
- } elsif ($what eq "u") {
- next;
+package CPAN::Debug;
+
+#-> sub CPAN::Debug::debug ;
+sub debug {
+ my($self,$arg) = @_;
+ my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
+ # Complete, caller(1)
+ # eg readline
+ ($caller) = caller(0);
+ $caller =~ s/.*:://;
+# print "caller[$caller]func[$func]line[$line]rest[@rest]\n";
+# print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]CPAN::DEBUG[$CPAN::DEBUG]\n";
+ if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
+ if (ref $arg) {
+ eval { require Data::Dumper };
+ if ($@) {
+ print $arg->as_string;
+ } else {
+ print Data::Dumper::Dumper($arg);
}
} else {
- if ($what eq "a") {
- next;
- } elsif ($what eq "r") {
- next;
- } elsif ($what eq "u") {
- $have = "-";
- }
- }
- return if $CPAN::Signal; # this is sometimes lengthy
- $seen{$file} ||= 0;
- if ($what eq "a") {
- push @result, sprintf "%s %s\n", $module->id, $have;
- } elsif ($what eq "r") {
- push @result, $module->id;
- next if $seen{$file}++;
- } elsif ($what eq "u") {
- push @result, $module->id;
- next if $seen{$file}++;
- next if $file =~ /^Contact/;
+ print "Debug($caller:$func,$line,@rest): $arg\n"
}
- unless ($headerdone++){
- print "\n";
- printf $sprintf, "Package namespace", "installed", "latest", "in CPAN file";
+ }
+}
+
+package CPAN::Config;
+import ExtUtils::MakeMaker 'neatvalue';
+use vars qw(%can);
+
+%can = (
+ 'commit' => "Commit changes to disk",
+ 'defaults' => "Reload defaults from disk",
+ 'init' => "Interactive setting of all options",
+);
+
+#-> sub CPAN::Config::edit ;
+sub edit {
+ my($class,@args) = @_;
+ return unless @args;
+ CPAN->debug("class[$class]args[".join(" | ",@args)."]");
+ my($o,$str,$func,$args,$key_exists);
+ $o = shift @args;
+ if($can{$o}) {
+ $class->$o(@args);
+ return 1;
+ } else {
+ if (ref($CPAN::Config->{$o}) eq ARRAY) {
+ $func = shift @args;
+ $func ||= "";
+ # Let's avoid eval, it's easier to comprehend without.
+ if ($func eq "push") {
+ push @{$CPAN::Config->{$o}}, @args;
+ } elsif ($func eq "pop") {
+ pop @{$CPAN::Config->{$o}};
+ } elsif ($func eq "shift") {
+ shift @{$CPAN::Config->{$o}};
+ } elsif ($func eq "unshift") {
+ unshift @{$CPAN::Config->{$o}}, @args;
+ } elsif ($func eq "splice") {
+ splice @{$CPAN::Config->{$o}}, @args;
+ } elsif (@args) {
+ $CPAN::Config->{$o} = [@args];
+ } else {
+ print(
+ " $o ",
+ ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}),
+ "\n"
+ );
+ }
+ } else {
+ $CPAN::Config->{$o} = $args[0] if defined $args[0];
+ print " $o ";
+ print defined $CPAN::Config->{$o} ? $CPAN::Config->{$o} : "UNDEFINED";
}
- $latest = substr($latest,0,8) if length($latest) > 8;
- $have = substr($have,0,8) if length($have) > 8;
- printf $sprintf, $module->id, $have, $latest, $file;
- $need{$module->id}++;
}
- unless (%need) {
- if ($what eq "u") {
- print "No modules found for @args\n";
- } elsif ($what eq "r") {
- print "All modules are up to date for @args\n";
+}
+
+#-> sub CPAN::Config::commit ;
+sub commit {
+ my($self,$configpm) = @_;
+ unless (defined $configpm){
+ $configpm ||= $INC{"CPAN/MyConfig.pm"};
+ $configpm ||= $INC{"CPAN/Config.pm"};
+ $configpm || Carp::confess(qq{
+CPAN::Config::commit called without an argument.
+Please specify a filename where to save the configuration or try
+"o conf init" to have an interactive course through configing.
+});
+ }
+ my($mode);
+ if (-f $configpm) {
+ $mode = (stat $configpm)[2];
+ if ($mode && ! -w _) {
+ Carp::confess("$configpm is not writable");
}
}
- if ($what eq "r" && $version_zeroes) {
- my $s = $version_zeroes>1 ? "s have" : " has";
- print qq{$version_zeroes installed module$s no version number to compare\n};
+
+ my $msg = <<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;
+ open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
+ print $fh qq[$msg\$CPAN::Config = \{\n];
+ foreach (sort keys %$CPAN::Config) {
+ $fh->print(
+ " '$_' => ",
+ ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
+ ",\n"
+ );
}
- @result;
+
+ print $fh "};\n1;\n__END__\n";
+ close $fh;
+
+ #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
+ #chmod $mode, $configpm;
+ $self->defaults;
+ print "commit: wrote $configpm\n";
+ 1;
}
-#-> sub CPAN::Shell::r ;
-sub r {
- shift->_u_r_common("r",@_);
+*default = \&defaults;
+#-> sub CPAN::Config::defaults ;
+sub defaults {
+ my($self) = @_;
+ $self->unload;
+ $self->load;
+ 1;
}
-#-> sub CPAN::Shell::u ;
-sub u {
- shift->_u_r_common("u",@_);
+sub init {
+ my($self) = @_;
+ undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
+ # have the least
+ # important
+ # variable
+ # undefined
+ $self->load;
+ 1;
}
-#-> sub CPAN::Shell::autobundle ;
-sub autobundle {
- my($self) = shift;
- my(@bundle) = $self->_u_r_common("a",@_);
- my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
- File::Path::mkpath($todir);
- unless (-d $todir) {
- print "Couldn't mkdir $todir for some reason\n";
- return;
+my $dot_cpan;
+#-> sub CPAN::Config::load ;
+sub load {
+ my($self) = @_;
+ eval {require CPAN::Config;}; # We eval, because of some MakeMaker problems
+ unshift @INC, $CPAN::META->catdir($ENV{HOME},".cpan") unless $dot_cpan++;
+ eval {require CPAN::MyConfig;}; # where you can override system wide settings
+ unless ( $self->load_succeeded ) {
+ require CPAN::FirstTime;
+ my($configpm,$fh);
+ if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
+ $configpm = $INC{"CPAN/Config.pm"};
+ } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
+ $configpm = $INC{"CPAN/MyConfig.pm"};
+ } else {
+ my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
+ my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
+ my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
+ if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
+ if (-w $configpmtest) {
+ $configpm = $configpmtest;
+ } elsif (-w $configpmdir) {
+#_#_# following code dumped core on me with 5.003_11, a.k.
+ unlink "$configpmtest.bak" if -f "$configpmtest.bak";
+ rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
+ my $fh = FileHandle->new;
+ if ($fh->open(">$configpmtest")) {
+ $fh->print("1;\n");
+ $configpm = $configpmtest;
+ } else {
+ # Should never happen
+ Carp::confess("Cannot open >$configpmtest");
+ }
+ }
+ }
+ unless ($configpm) {
+ $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
+ File::Path::mkpath($configpmdir);
+ $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
+ if (-w $configpmtest) {
+ $configpm = $configpmtest;
+ } elsif (-w $configpmdir) {
+#_#_# following code dumped core on me with 5.003_11, a.k.
+ my $fh = FileHandle->new;
+ if ($fh->open(">$configpmtest")) {
+ $fh->print("1;\n");
+ $configpm = $configpmtest;
+ } else {
+ # Should never happen
+ Carp::confess("Cannot open >$configpmtest");
+ }
+ } else {
+ Carp::confess(qq{WARNING: CPAN.pm is unable to }.
+ qq{create a configuration file.});
+ }
+ }
+ }
+ CPAN->debug(qq{Calling CPAN::FirstTime::init("$configpm")})
+ if $CPAN::DEBUG;
+ print qq{
+Configuring CPAN.pm.
+$configpm initialized.
+};
+ CPAN::FirstTime::init($configpm);
}
- my($y,$m,$d) = (localtime)[5,4,3];
- $y+=1900;
- $m++;
- my($c) = 0;
- my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
- my($to) = $CPAN::META->catfile($todir,"$me.pm");
- while (-f $to) {
- $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
- $to = $CPAN::META->catfile($todir,"$me.pm");
- }
- my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
- $fh->print(
- "package Bundle::$me;\n\n",
- "\$VERSION = '0.01';\n\n",
- "1;\n\n",
- "__END__\n\n",
- "=head1 NAME\n\n",
- "Bundle::$me - Snapshot of installation on ",
- $Config::Config{'myhostname'},
- " on ",
- scalar(localtime),
- "\n\n=head1 SYNOPSIS\n\n",
- "perl -MCPAN -e 'install Bundle::$me'\n\n",
- "=head1 CONTENTS\n\n",
- join("\n", @bundle),
- "\n\n=head1 CONFIGURATION\n\n",
- Config->myconfig,
- "\n\n=head1 AUTHOR\n\n",
- "This Bundle has been generated automatically by the autobundle routine in CPAN.pm.\n",
- );
- $fh->close;
- print "\nWrote bundle file
- $to\n\n";
}
-#-> sub CPAN::Shell::expand ;
-sub expand {
- shift;
- my($type,@args) = @_;
- my($arg,@m);
- for $arg (@args) {
- my $regex;
- if ($arg =~ m|^/(.*)/$|) {
- $regex = $1;
- }
- my $class = "CPAN::$type";
- my $obj;
- if (defined $regex) {
- for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) {
- push @m, $obj
- if
- $obj->id =~ /$regex/i
- or
- (
- (
- $] < 5.00303 ### provide sort of compatibility with 5.003
- ||
- $obj->can('name')
- )
- &&
- $obj->name =~ /$regex/i
- );
- }
- } else {
- my($xarg) = $arg;
- if ( $type eq 'Bundle' ) {
- $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
- }
- if ($CPAN::META->exists($class,$xarg)) {
- $obj = $CPAN::META->instance($class,$xarg);
- } elsif ($CPAN::META->exists($class,$arg)) {
- $obj = $CPAN::META->instance($class,$arg);
- } else {
- next;
- }
- push @m, $obj;
+#-> sub CPAN::Config::load_succeeded ;
+sub load_succeeded {
+ my($miss) = 0;
+ for (qw(
+ cpan_home keep_source_where build_dir build_cache index_expire
+ gzip tar unzip make pager makepl_arg make_arg make_install_arg
+ urllist inhibit_startup_message ftp_proxy http_proxy no_proxy
+ )) {
+ unless (defined $CPAN::Config->{$_}){
+ $miss++;
+ CPAN->debug("undefined configuration parameter $_") if $CPAN::DEBUG;
}
}
- return @m;
+ return !$miss;
}
-#-> sub CPAN::Shell::format_result ;
-sub format_result {
- my($self) = shift;
- my($type,@args) = @_;
- @args = '/./' unless @args;
- my(@result) = $self->expand($type,@args);
- my $result = @result==1 ? $result[0]->as_string : join "", map {$_->as_glimpse} @result;
- $result ||= "No objects of type $type found for argument @args\n";
- $result;
+#-> sub CPAN::Config::unload ;
+sub unload {
+ delete $INC{'CPAN/MyConfig.pm'};
+ delete $INC{'CPAN/Config.pm'};
}
-#-> sub CPAN::Shell::rematein ;
-sub rematein {
- shift;
- my($meth,@some) = @_;
- my $pragma = "";
- if ($meth eq 'force') {
- $pragma = $meth;
- $meth = shift @some;
- }
- CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
- my($s,@s);
- foreach $s (@some) {
- my $obj;
- if (ref $s) {
- $obj = $s;
- } elsif ($s =~ m|/|) { # looks like a file
- $obj = $CPAN::META->instance('CPAN::Distribution',$s);
- } elsif ($s =~ m|^Bundle::|) {
- $obj = $CPAN::META->instance('CPAN::Bundle',$s);
- } else {
- $obj = $CPAN::META->instance('CPAN::Module',$s) if $CPAN::META->exists('CPAN::Module',$s);
- }
- if (ref $obj) {
- CPAN->debug(qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}.$obj->as_string.qq{\]}) if $CPAN::DEBUG;
- $obj->$pragma()
- if
- $pragma
- &&
- ($] < 5.00303 || $obj->can($pragma)); ### compatibility with 5.003
- $obj->$meth();
- } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
- $obj = $CPAN::META->instance('CPAN::Author',$s);
- print "Don't be silly, you can't $meth ", $obj->fullname, " ;-)\n";
- } else {
- print "Warning: Cannot $meth $s, don't know what it is\n";
- }
- }
-}
+*h = \&help;
+#-> sub CPAN::Config::help ;
+sub help {
+ print <<EOF;
+Known options:
+ defaults reload default config values from disk
+ commit commit session changes to disk
+ init go through a dialog to set all parameters
-#-> sub CPAN::Shell::force ;
-sub force { shift->rematein('force',@_); }
-#-> sub CPAN::Shell::get ;
-sub get { shift->rematein('get',@_); }
-#-> sub CPAN::Shell::readme ;
-sub readme { shift->rematein('readme',@_); }
-#-> sub CPAN::Shell::make ;
-sub make { shift->rematein('make',@_); }
-#-> sub CPAN::Shell::test ;
-sub test { shift->rematein('test',@_); }
-#-> sub CPAN::Shell::install ;
-sub install { shift->rematein('install',@_); }
-#-> sub CPAN::Shell::clean ;
-sub clean { shift->rematein('clean',@_); }
-#-> sub CPAN::Shell::look ;
-sub look { shift->rematein('look',@_); }
+You may edit key values in the follow fashion:
-package CPAN::FTP;
-use vars qw($Ua);
-@CPAN::FTP::ISA = qw(CPAN::Debug);
+ o conf build_cache 15
-#-> sub CPAN::FTP::ftp_get ;
-sub ftp_get {
- my($class,$host,$dir,$file,$target) = @_;
- $class->debug(
- qq[Going to fetch file [$file] from dir [$dir]
- on host [$host] as local [$target]\n]
- ) if $CPAN::DEBUG;
- my $ftp = Net::FTP->new($host);
- return 0 unless defined $ftp;
- $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
- $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
- unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
- warn "Couldn't login on $host";
- return;
- }
- # print qq[Going to ->cwd("$dir")\n];
- unless ( $ftp->cwd($dir) ){
- warn "Couldn't cwd $dir";
- return;
- }
- $ftp->binary;
- $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
- unless ( $ftp->get($file,$target) ){
- warn "Couldn't fetch $file from $host";
- return;
- }
- $ftp->quit; # it's ok if this fails
- return 1;
-}
+ o conf build_dir "/foo/bar"
-#-> sub CPAN::FTP::localize ;
-sub localize {
- my($self,$file,$aslocal,$force) = @_;
- $force ||= 0;
- Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])" unless defined $aslocal;
- $self->debug("file [$file] aslocal [$aslocal]") if $CPAN::DEBUG;
+ o conf urllist shift
- return $aslocal if -f $aslocal && -r _ && ! $force;
+ o conf urllist unshift ftp://ftp.foo.bar/
- my($aslocal_dir) = File::Basename::dirname($aslocal);
- File::Path::mkpath($aslocal_dir);
- print STDERR qq{Warning: You are not allowed to write into directory "$aslocal_dir".
- I\'ll continue, but if you face any problems, they may be due
- to insufficient permissions.\n} unless -w $aslocal_dir;
+EOF
+ undef; #don't reprint CPAN::Config
+}
- # Inheritance is not easier to manage than a few if/else branches
- if ($CPAN::META->hasLWP) {
- require LWP::UserAgent;
- unless ($Ua) {
- $Ua = new LWP::UserAgent;
- my($var);
- $Ua->proxy('ftp', $var)
- if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
- $Ua->proxy('http', $var)
- if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
- $Ua->no_proxy($var)
- if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
+#-> sub CPAN::Config::complete ;
+sub complete {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
+ return grep /^\Q$word\E/, @o_conf;
+}
+
+package CPAN::Shell;
+use vars qw($AUTOLOAD $redef @ISA);
+@CPAN::Shell::ISA = qw(CPAN::Debug);
+if ($CPAN::META->hasWAIT) {
+ unshift @ISA, "CPAN::WAIT";
+}
+# private function ro re-eval this module (handy during development)
+#-> sub CPAN::Shell::AUTOLOAD ;
+sub AUTOLOAD {
+ my($autoload) = $AUTOLOAD;
+ $autoload =~ s/.*:://;
+ if ($autoload =~ /^w/) {
+ if ($CPAN::META->hasWAIT) {
+ CPAN::WAIT->wh;
+ return;
+ } else {
+ warn qq{
+Commands starting with "w" require CPAN::WAIT to be installed.
+Please consider installing CPAN::WAIT to use the fulltext index.
+Type "install CPAN::WAIT" and restart CPAN.pm.
+}
}
+ } else {
+ warn "CPAN::Shell doesn't know how to autoload $autoload :-(
+Nothing Done.
+";
}
+ CPAN::Shell->h;
+}
- # Try the list of urls for each single object. We keep a record
- # where we did get a file from
- for (0..$#{$CPAN::Config->{urllist}}) {
- my $url = $CPAN::Config->{urllist}[$_];
- $url .= "/" unless substr($url,-1) eq "/";
- $url .= $file;
- $self->debug("localizing[$url]") if $CPAN::DEBUG;
- if ($url =~ /^file:/) {
- my $l;
- if ($CPAN::META->hasLWP) {
- require URI::URL;
- my $u = new URI::URL $url;
- $l = $u->path;
- } else { # works only on Unix, is poorly constructed, but
- # hopefully better than nothing.
- # RFC 1738 says fileurl BNF is
- # fileurl = "file://" [ host | "localhost" ] "/" fpath
- # Thanks to "Mark D. Baushke" <mdb@cisco.com> for the code
- ($l = $url) =~ s,^file://[^/]+,,; # discard the host part
- $l =~ s/^file://; # assume they meant file://localhost
- }
- return $l if -f $l && -r _;
- }
-
- if ($CPAN::META->hasLWP) {
- print "Fetching $url with LWP\n";
- my $res = $Ua->mirror($url, $aslocal);
- if ($res->is_success) {
- return $aslocal;
- }
- }
- if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
- # that's the nice and easy way thanks to Graham
- my($host,$dir,$getfile) = ($1,$2,$3);
- if ($CPAN::META->hasFTP) {
- $dir =~ s|/+|/|g;
- $self->debug("Going to fetch file [$getfile]
- from dir [$dir]
- on host [$host]
- as local [$aslocal]") if $CPAN::DEBUG;
- CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal) && return $aslocal;
- warn "Net::FTP failed for some reason\n";
- } else {
- warn qq{
- Please, install Net::FTP as soon as possible. Just type
- install Net::FTP
- Thank you.
+#-> sub CPAN::Shell::h ;
+sub h {
+ my($class,$about) = @_;
+ if (defined $about) {
+ print "Detailed help not yet implemented\n";
+ } else {
+ print q{
+command arguments description
+a string authors
+b or display bundles
+d /regex/ info distributions
+m or about modules
+i none anything of above
-}
- }
+r as reinstall recommendations
+u above uninstalled distributions
+See manpage for autobundle, recompile, force, look, etc.
- # Came back if Net::FTP couldn't establish connection (or failed otherwise)
- # Maybe they are behind a firewall, but they gave us
- # a socksified (or other) ftp program...
- my($netrcfile,$fh);
- if (-x $CPAN::Config->{'ftp'}) {
- my $timestamp = 0;
- my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
- $ctime,$blksize,$blocks) = stat($aslocal);
- $timestamp = $mtime if defined $mtime;
+make make
+test modules, make test (implies make)
+install dists, bundles, make install (implies test)
+clean "r" or "u" make clean
+readme display the README file
- my($netrc) = CPAN::FTP::netrc->new;
- my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
+reload index|cpan load most recent indices/CPAN.pm
+h or ? display this menu
+o various set and query options
+! perl-code eval a perl command
+q quit the shell subroutine
+};
+ }
+}
- my $targetfile = File::Basename::basename($aslocal);
- my(@dialog);
- push(
- @dialog,
- "lcd $aslocal_dir",
- "cd /",
- map("cd $_", split "/", $dir), # RFC 1738
- "bin",
- "get $getfile $targetfile",
- "quit"
- );
- if (! $netrc->netrc) {
- warn "No ~/.netrc file found";
- } elsif ($netrc->hasdefault || $netrc->contains($host)) {
- CPAN->debug(
- sprint(
- "hasdef[%d]cont($host)[%d]",
- $netrc->hasdefault,
- $netrc->contains($host)
- )
- ) if $CPAN::DEBUG;
- if ($netrc->protected) {
- print(
- qq{
- Trying with external ftp to get
- $url
- As this requires some features that are not thoroughly tested, we\'re
- not sure, that we get it right....
+#-> sub CPAN::Shell::a ;
+sub a { print shift->format_result('Author',@_);}
+#-> sub CPAN::Shell::b ;
+sub b {
+ my($self,@which) = @_;
+ CPAN->debug("which[@which]") if $CPAN::DEBUG;
+ my($incdir,$bdir,$dh);
+ foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
+ $bdir = $CPAN::META->catdir($incdir,"Bundle");
+ if ($dh = DirHandle->new($bdir)) { # may fail
+ my($entry);
+ for $entry ($dh->read) {
+ next if -d $CPAN::META->catdir($bdir,$entry);
+ next unless $entry =~ s/\.pm$//;
+ $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
+ }
+ }
+ }
+ print $self->format_result('Bundle',@which);
+}
+#-> sub CPAN::Shell::d ;
+sub d { print shift->format_result('Distribution',@_);}
+#-> sub CPAN::Shell::m ;
+sub m { print shift->format_result('Module',@_);}
+#-> sub CPAN::Shell::i ;
+sub i {
+ my($self) = shift;
+ my(@args) = @_;
+ my(@type,$type,@m);
+ @type = qw/Author Bundle Distribution Module/;
+ @args = '/./' unless @args;
+ my(@result);
+ for $type (@type) {
+ push @result, $self->expand($type,@args);
+ }
+ my $result = @result==1 ?
+ $result[0]->as_string :
+ join "", map {$_->as_glimpse} @result;
+ $result ||= "No objects found of any type for argument @args\n";
+ print $result;
}
- );
- my $fh = FileHandle->new;
- $fh->open("|$CPAN::Config->{'ftp'}$verbose $host")
- or die "Couldn't open ftp: $!";
- # pilot is blind now
- CPAN->debug("dialog [".(join "|",@dialog)."]") if $CPAN::DEBUG;
- foreach (@dialog) { $fh->print("$_\n") }
- $fh->close; # Wait for process to complete
- ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
- $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
- if ($mtime > $timestamp) {
- print "GOT $aslocal\n";
- return $aslocal;
- } else {
- print "Hmm... Still failed!\n";
- }
- } else {
- warn "Your $netrcfile is not correctly protected.\n";
- }
- } else {
- warn "Your ~/.netrc neither contains $host
- nor does it have a default entry\n";
- }
- # OK, they don't have a valid ~/.netrc. Use 'ftp -n' then and
- # login manually to host, using e-mail as password.
- print qq{Issuing "ftp$verbose -n"\n};
- unshift @dialog, "open $host", "user anonymous $Config::Config{'cf_email'}";
- CPAN->debug("dialog [".(join "|",@dialog)."]") if $CPAN::DEBUG;
- $fh = FileHandle->new;
- $fh->open("|$CPAN::Config->{'ftp'} -n") or
- die "Cannot fork: $!\n";
- foreach (@dialog) { $fh->print("$_\n") }
- $fh->close;
- ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
- $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
- if ($mtime > $timestamp) {
- print "GOT $aslocal\n";
- return $aslocal;
+#-> sub CPAN::Shell::o ;
+sub o {
+ my($self,$o_type,@o_what) = @_;
+ $o_type ||= "";
+ CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
+ if ($o_type eq 'conf') {
+ shift @o_what if @o_what && $o_what[0] eq 'help';
+ if (!@o_what) {
+ my($k,$v);
+ print "CPAN::Config options:\n";
+ for $k (sort keys %CPAN::Config::can) {
+ $v = $CPAN::Config::can{$k};
+ printf " %-18s %s\n", $k, $v;
+ }
+ print "\n";
+ for $k (sort keys %$CPAN::Config) {
+ $v = $CPAN::Config->{$k};
+ if (ref $v) {
+ printf " %-18s\n", $k;
+ print map {"\t$_\n"} @{$v};
} else {
- print "Bad luck... Still failed!\n";
+ printf " %-18s %s\n", $k, $v;
}
}
- sleep 2;
+ print "\n";
+ } elsif (!CPAN::Config->edit(@o_what)) {
+ print qq[Type 'o conf' to view configuration edit options\n\n];
}
-
- # what, still not succeeded?
- if (-x $CPAN::Config->{'lynx'}) {
- my($want_compressed);
- print(
- qq{
- Trying with lynx to get $url
-}
- );
- $want_compressed = $aslocal =~ s/\.gz//;
- my($system) = "$CPAN::Config->{'lynx'} -source '$url' > $aslocal";
- if (system($system)==0) {
- if ($want_compressed) {
- $system = "$CPAN::Config->{'gzip'} -dt $aslocal";
- if (system($system)==0) {
- rename $aslocal, "$aslocal.gz";
- } else {
- $system = "$CPAN::Config->{'gzip'} $aslocal";
- system($system);
+ } elsif ($o_type eq 'debug') {
+ my(%valid);
+ @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
+ if (@o_what) {
+ while (@o_what) {
+ my($what) = shift @o_what;
+ if ( exists $CPAN::DEBUG{$what} ) {
+ $CPAN::DEBUG |= $CPAN::DEBUG{$what};
+ } elsif ($what =~ /^\d/) {
+ $CPAN::DEBUG = $what;
+ } elsif (lc $what eq 'all') {
+ my($max) = 0;
+ for (values %CPAN::DEBUG) {
+ $max += $_;
}
- return "$aslocal.gz";
+ $CPAN::DEBUG = $max;
} else {
- $system = "$CPAN::Config->{'gzip'} -dt $aslocal";
- if (system($system)==0) {
- $system = "$CPAN::Config->{'gzip'} -d $aslocal";
- system($system);
- } else {
- # should be fine, eh?
+ for (keys %CPAN::DEBUG) {
+ next unless lc($_) eq lc($what);
+ $CPAN::DEBUG |= $CPAN::DEBUG{$_};
}
- return $aslocal;
+ print "unknown argument [$what]\n";
}
}
+ } else {
+ print "Valid options for debug are ".
+ join(", ",sort(keys %CPAN::DEBUG), 'all').
+ qq{ or a number. Completion works on the options. }.
+ qq{Case is ignored.\n\n};
+ }
+ if ($CPAN::DEBUG) {
+ print "Options set for debugging:\n";
+ my($k,$v);
+ for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
+ $v = $CPAN::DEBUG{$k};
+ printf " %-14s(%s)\n", $k, $v if $v & $CPAN::DEBUG;
+ }
+ } else {
+ print "Debugging turned off completely.\n";
}
- warn "Can't access URL $url.
- Either get LWP or Net::FTP
- or an external lynx or ftp";
+ } else {
+ print qq{
+Known options:
+ conf set or get configuration variables
+ debug set or get debugging options
+};
}
- Carp::croak("Cannot fetch $file from anywhere");
}
-package CPAN::FTP::netrc;
-
-sub new {
- my($class) = @_;
- my $file = MY->catfile($ENV{HOME},".netrc");
-
- my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
- $atime,$mtime,$ctime,$blksize,$blocks)
- = stat($file);
- my $protected = 0;
-
+#-> sub CPAN::Shell::reload ;
+sub reload {
+ if ($_[1] =~ /cpan/i) {
+ CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
+ my $fh = FileHandle->new($INC{'CPAN.pm'});
+ local($/);
+ undef $/;
+ $redef = 0;
+ local($SIG{__WARN__})
+ = sub {
+ if ( $_[0] =~ /Subroutine \w+ redefined/ ) {
+ ++$redef;
+ local($|) = 1;
+ print ".";
+ return;
+ }
+ warn @_;
+ };
+ eval <$fh>;
+ warn $@ if $@;
+ print "\n$redef subroutines redefined\n";
+ } elsif ($_[1] =~ /index/) {
+ CPAN::Index->force_reload;
+ }
+}
+
+#-> sub CPAN::Shell::_binary_extensions ;
+sub _binary_extensions {
+ my($self) = shift @_;
+ my(@result,$module,%seen,%need,$headerdone);
+ for $module ($self->expand('Module','/./')) {
+ my $file = $module->cpan_file;
+ next if $file eq "N/A";
+ next if $file =~ /^Contact Author/;
+ next if $file =~ /perl5[._-]\d{3}(?:[\d_]+)?\.tar[._-]gz$/;
+ next unless $module->xs_file;
+ local($|) = 1;
+ print ".";
+ push @result, $module;
+ }
+# print join " | ", @result;
+ print "\n";
+ return @result;
+}
+
+#-> sub CPAN::Shell::recompile ;
+sub recompile {
+ my($self) = shift @_;
+ my($module,@module,$cpan_file,%dist);
+ @module = $self->_binary_extensions();
+ for $module (@module){ # we force now and compile later, so we don't do it twice
+ $cpan_file = $module->cpan_file;
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->force;
+ $dist{$cpan_file}++;
+ }
+ for $cpan_file (sort keys %dist) {
+ print " CPAN: Recompiling $cpan_file\n\n";
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->install;
+ $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
+ # stop a package from recompiling,
+ # e.g. IO-1.12 when we have perl5.003_10
+ }
+}
+
+#-> sub CPAN::Shell::_u_r_common ;
+sub _u_r_common {
+ my($self) = shift @_;
+ my($what) = shift @_;
+ CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
+ Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
+ Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
+ my(@args) = @_;
+ @args = '/./' unless @args;
+ my(@result,$module,%seen,%need,$headerdone,$version_zeroes);
+ $version_zeroes = 0;
+ my $sprintf = "%-25s %9s %9s %s\n";
+ for $module ($self->expand('Module',@args)) {
+ my $file = $module->cpan_file;
+ next unless defined $file; # ??
+ my($latest) = $module->cpan_version || 0;
+ my($inst_file) = $module->inst_file;
+ my($have);
+ if ($inst_file){
+ if ($what eq "a") {
+ $have = $module->inst_version;
+ } elsif ($what eq "r") {
+ $have = $module->inst_version;
+ local($^W) = 0;
+ $version_zeroes++ unless $have;
+ next if $have >= $latest;
+ } elsif ($what eq "u") {
+ next;
+ }
+ } else {
+ if ($what eq "a") {
+ next;
+ } elsif ($what eq "r") {
+ next;
+ } elsif ($what eq "u") {
+ $have = "-";
+ }
+ }
+ return if $CPAN::Signal; # this is sometimes lengthy
+ $seen{$file} ||= 0;
+ if ($what eq "a") {
+ push @result, sprintf "%s %s\n", $module->id, $have;
+ } elsif ($what eq "r") {
+ push @result, $module->id;
+ next if $seen{$file}++;
+ } elsif ($what eq "u") {
+ push @result, $module->id;
+ next if $seen{$file}++;
+ next if $file =~ /^Contact/;
+ }
+ unless ($headerdone++){
+ print "\n";
+ printf(
+ $sprintf,
+ "Package namespace",
+ "installed",
+ "latest",
+ "in CPAN file"
+ );
+ }
+ $latest = substr($latest,0,8) if length($latest) > 8;
+ $have = substr($have,0,8) if length($have) > 8;
+ printf $sprintf, $module->id, $have, $latest, $file;
+ $need{$module->id}++;
+ }
+ unless (%need) {
+ if ($what eq "u") {
+ print "No modules found for @args\n";
+ } elsif ($what eq "r") {
+ print "All modules are up to date for @args\n";
+ }
+ }
+ if ($what eq "r" && $version_zeroes) {
+ my $s = $version_zeroes>1 ? "s have" : " has";
+ print qq{$version_zeroes installed module$s no version number to compare\n};
+ }
+ @result;
+}
+
+#-> sub CPAN::Shell::r ;
+sub r {
+ shift->_u_r_common("r",@_);
+}
+
+#-> sub CPAN::Shell::u ;
+sub u {
+ shift->_u_r_common("u",@_);
+}
+
+#-> sub CPAN::Shell::autobundle ;
+sub autobundle {
+ my($self) = shift;
+ my(@bundle) = $self->_u_r_common("a",@_);
+ my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
+ File::Path::mkpath($todir);
+ unless (-d $todir) {
+ print "Couldn't mkdir $todir for some reason\n";
+ return;
+ }
+ my($y,$m,$d) = (localtime)[5,4,3];
+ $y+=1900;
+ $m++;
+ my($c) = 0;
+ my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
+ my($to) = $CPAN::META->catfile($todir,"$me.pm");
+ while (-f $to) {
+ $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
+ $to = $CPAN::META->catfile($todir,"$me.pm");
+ }
+ my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
+ $fh->print(
+ "package Bundle::$me;\n\n",
+ "\$VERSION = '0.01';\n\n",
+ "1;\n\n",
+ "__END__\n\n",
+ "=head1 NAME\n\n",
+ "Bundle::$me - Snapshot of installation on ",
+ $Config::Config{'myhostname'},
+ " on ",
+ scalar(localtime),
+ "\n\n=head1 SYNOPSIS\n\n",
+ "perl -MCPAN -e 'install Bundle::$me'\n\n",
+ "=head1 CONTENTS\n\n",
+ join("\n", @bundle),
+ "\n\n=head1 CONFIGURATION\n\n",
+ Config->myconfig,
+ "\n\n=head1 AUTHOR\n\n",
+ "This Bundle has been generated automatically ",
+ "by the autobundle routine in CPAN.pm.\n",
+ );
+ $fh->close;
+ print "\nWrote bundle file
+ $to\n\n";
+}
+
+#-> sub CPAN::Shell::expand ;
+sub expand {
+ shift;
+ my($type,@args) = @_;
+ my($arg,@m);
+ for $arg (@args) {
+ my $regex;
+ if ($arg =~ m|^/(.*)/$|) {
+ $regex = $1;
+ }
+ my $class = "CPAN::$type";
+ my $obj;
+ if (defined $regex) {
+ for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) {
+ push @m, $obj
+ if
+ $obj->id =~ /$regex/i
+ or
+ (
+ (
+ $] < 5.00303 ### provide sort of compatibility with 5.003
+ ||
+ $obj->can('name')
+ )
+ &&
+ $obj->name =~ /$regex/i
+ );
+ }
+ } else {
+ my($xarg) = $arg;
+ if ( $type eq 'Bundle' ) {
+ $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
+ }
+ if ($CPAN::META->exists($class,$xarg)) {
+ $obj = $CPAN::META->instance($class,$xarg);
+ } elsif ($CPAN::META->exists($class,$arg)) {
+ $obj = $CPAN::META->instance($class,$arg);
+ } else {
+ next;
+ }
+ push @m, $obj;
+ }
+ }
+ return @m;
+}
+
+#-> sub CPAN::Shell::format_result ;
+sub format_result {
+ my($self) = shift;
+ my($type,@args) = @_;
+ @args = '/./' unless @args;
+ my(@result) = $self->expand($type,@args);
+ my $result = @result==1 ?
+ $result[0]->as_string :
+ join "", map {$_->as_glimpse} @result;
+ $result ||= "No objects of type $type found for argument @args\n";
+ $result;
+}
+
+#-> sub CPAN::Shell::rematein ;
+sub rematein {
+ shift;
+ my($meth,@some) = @_;
+ my $pragma = "";
+ if ($meth eq 'force') {
+ $pragma = $meth;
+ $meth = shift @some;
+ }
+ CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
+ my($s,@s);
+ foreach $s (@some) {
+ my $obj;
+ if (ref $s) {
+ $obj = $s;
+ } elsif ($s =~ m|/|) { # looks like a file
+ $obj = $CPAN::META->instance('CPAN::Distribution',$s);
+ } elsif ($s =~ m|^Bundle::|) {
+ $obj = $CPAN::META->instance('CPAN::Bundle',$s);
+ } else {
+ $obj = $CPAN::META->instance('CPAN::Module',$s)
+ if $CPAN::META->exists('CPAN::Module',$s);
+ }
+ if (ref $obj) {
+ CPAN->debug(
+ qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}.
+ $obj->as_string.
+ qq{\]}
+ ) if $CPAN::DEBUG;
+ $obj->$pragma()
+ if
+ $pragma
+ &&
+ ($] < 5.00303 || $obj->can($pragma)); ### compatibility with 5.003
+ $obj->$meth();
+ } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
+ $obj = $CPAN::META->instance('CPAN::Author',$s);
+ print "Don't be silly, you can't $meth ", $obj->fullname, " ;-)\n";
+ } else {
+ print "Warning: Cannot $meth $s, don't know what it is\n";
+ }
+ }
+}
+
+#-> sub CPAN::Shell::force ;
+sub force { shift->rematein('force',@_); }
+#-> sub CPAN::Shell::get ;
+sub get { shift->rematein('get',@_); }
+#-> sub CPAN::Shell::readme ;
+sub readme { shift->rematein('readme',@_); }
+#-> sub CPAN::Shell::make ;
+sub make { shift->rematein('make',@_); }
+#-> sub CPAN::Shell::test ;
+sub test { shift->rematein('test',@_); }
+#-> sub CPAN::Shell::install ;
+sub install { shift->rematein('install',@_); }
+#-> sub CPAN::Shell::clean ;
+sub clean { shift->rematein('clean',@_); }
+#-> sub CPAN::Shell::look ;
+sub look { shift->rematein('look',@_); }
+
+package CPAN::FTP;
+use vars qw($Ua);
+@CPAN::FTP::ISA = qw(CPAN::Debug);
+
+#-> sub CPAN::FTP::ftp_get ;
+sub ftp_get {
+ my($class,$host,$dir,$file,$target) = @_;
+ $class->debug(
+ qq[Going to fetch file [$file] from dir [$dir]
+ on host [$host] as local [$target]\n]
+ ) if $CPAN::DEBUG;
+ my $ftp = Net::FTP->new($host);
+ return 0 unless defined $ftp;
+ $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
+ $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
+ unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
+ warn "Couldn't login on $host";
+ return;
+ }
+ # print qq[Going to ->cwd("$dir")\n];
+ unless ( $ftp->cwd($dir) ){
+ warn "Couldn't cwd $dir";
+ return;
+ }
+ $ftp->binary;
+ $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
+ unless ( $ftp->get($file,$target) ){
+ warn "Couldn't fetch $file from $host\n";
+ return;
+ }
+ $ftp->quit; # it's ok if this fails
+ return 1;
+}
+
+#-> sub CPAN::FTP::localize ;
+sub localize {
+ my($self,$file,$aslocal,$force) = @_;
+ $force ||= 0;
+ Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
+ unless defined $aslocal;
+ $self->debug("file [$file] aslocal [$aslocal]") if $CPAN::DEBUG;
+
+ return $aslocal if -f $aslocal && -r _ && ! $force;
+
+ my($aslocal_dir) = File::Basename::dirname($aslocal);
+ File::Path::mkpath($aslocal_dir);
+ print STDERR qq{Warning: You are not allowed to write into }.
+ qq{directory "$aslocal_dir".
+ I\'ll continue, but if you face any problems, they may be due
+ to insufficient permissions.\n} unless -w $aslocal_dir;
+
+ # Inheritance is not easier to manage than a few if/else branches
+ if ($CPAN::META->hasLWP) {
+ require LWP::UserAgent;
+ unless ($Ua) {
+ $Ua = new LWP::UserAgent;
+ my($var);
+ $Ua->proxy('ftp', $var)
+ if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
+ $Ua->proxy('http', $var)
+ if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
+ $Ua->no_proxy($var)
+ if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
+ }
+ }
+
+ # Try the list of urls for each single object. We keep a record
+ # where we did get a file from
+ my($i);
+ for $i (0..$#{$CPAN::Config->{urllist}}) {
+ my $url = $CPAN::Config->{urllist}[$i];
+ $url .= "/" unless substr($url,-1) eq "/";
+ $url .= $file;
+ $self->debug("localizing[$url]") if $CPAN::DEBUG;
+ if ($url =~ /^file:/) {
+ my $l;
+ if ($CPAN::META->hasLWP) {
+ require URI::URL;
+ my $u = new URI::URL $url;
+ $l = $u->path;
+ } else { # works only on Unix, is poorly constructed, but
+ # hopefully better than nothing.
+ # RFC 1738 says fileurl BNF is
+ # fileurl = "file://" [ host | "localhost" ] "/" fpath
+ # Thanks to "Mark D. Baushke" <mdb@cisco.com> for the code
+ ($l = $url) =~ s,^file://[^/]+,,; # discard the host part
+ $l =~ s/^file://; # assume they meant file://localhost
+ }
+ return $l if -f $l && -r _;
+ # Maybe mirror has compressed it?
+ if (-f "$l.gz") {
+ $self->debug("found compressed $l.gz");
+ system("$CPAN::Config->{gzip} -dc $l.gz > $aslocal");
+ return $aslocal if -f $aslocal;
+ }
+ }
+
+ if ($CPAN::META->hasLWP) {
+ print "Fetching $url with LWP\n";
+ my $res = $Ua->mirror($url, $aslocal);
+ if ($res->is_success) {
+ return $aslocal;
+ }
+ }
+ if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ # that's the nice and easy way thanks to Graham
+ my($host,$dir,$getfile) = ($1,$2,$3);
+ if ($CPAN::META->hasFTP) {
+ $dir =~ s|/+|/|g;
+ $self->debug("Going to fetch file [$getfile]
+ from dir [$dir]
+ on host [$host]
+ as local [$aslocal]") if $CPAN::DEBUG;
+ CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal) && return $aslocal;
+ warn "Net::FTP failed for some reason\n";
+ } else {
+ warn qq{
+ Please, install Net::FTP as soon as possible. Just type
+ install Net::FTP
+ Thank you.
+
+}
+ }
+ }
+
+ # Came back if Net::FTP couldn't establish connection (or failed otherwise)
+ # Maybe they are behind a firewall, but they gave us
+ # a socksified (or other) ftp program...
+
+ my($funkyftp);
+ # does ncftp handle http?
+ for $funkyftp ($CPAN::Config->{'lynx'},$CPAN::Config->{'ncftp'}) {
+ next unless defined $funkyftp;
+ next unless -x $funkyftp;
+ my($want_compressed);
+ print(
+ qq{
+Trying with $funkyftp to get
+ $url
+});
+ $want_compressed = $aslocal =~ s/\.gz//;
+ my($source_switch) = "";
+ $source_switch = "-source" if $funkyftp =~ /\blynx$/;
+ my($system) = "$funkyftp $source_switch '$url' > $aslocal";
+ my($wstatus);
+ if (($wstatus = system($system)) == 0) {
+ if ($want_compressed) {
+ $system = "$CPAN::Config->{'gzip'} -dt $aslocal";
+ if (system($system)==0) {
+ rename $aslocal, "$aslocal.gz";
+ } else {
+ $system = "$CPAN::Config->{'gzip'} $aslocal";
+ system($system);
+ }
+ return "$aslocal.gz";
+ } else {
+ $system = "$CPAN::Config->{'gzip'} -dt $aslocal";
+ if (system($system)==0) {
+ $system = "$CPAN::Config->{'gzip'} -d $aslocal";
+ system($system);
+ } else {
+ # should be fine, eh?
+ }
+ return $aslocal;
+ }
+ } else {
+ my $estatus = $wstatus >> 8;
+ print qq{
+System call "$system"
+returned status $estatus (wstat $wstatus)
+};
+ }
+ }
+
+ if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ my($host,$dir,$getfile) = ($1,$2,$3);
+ my($netrcfile,$fh);
+ if (-x $CPAN::Config->{'ftp'}) {
+ my $timestamp = 0;
+ my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
+ $ctime,$blksize,$blocks) = stat($aslocal);
+ $timestamp = $mtime ||=0;
+
+ my($netrc) = CPAN::FTP::netrc->new;
+ my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
+
+ my $targetfile = File::Basename::basename($aslocal);
+ my(@dialog);
+ push(
+ @dialog,
+ "lcd $aslocal_dir",
+ "cd /",
+ map("cd $_", split "/", $dir), # RFC 1738
+ "bin",
+ "get $getfile $targetfile",
+ "quit"
+ );
+ if (! $netrc->netrc) {
+ CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
+ } elsif ($netrc->hasdefault || $netrc->contains($host)) {
+ CPAN->debug(
+ sprint(
+ "hasdef[%d]cont($host)[%d]",
+ $netrc->hasdefault,
+ $netrc->contains($host)
+ )
+ ) if $CPAN::DEBUG;
+ if ($netrc->protected) {
+ print(
+ qq{
+ Trying with external ftp to get
+ $url
+ As this requires some features that are not thoroughly tested, we\'re
+ not sure, that we get it right....
+
+}
+ );
+ my $fh = FileHandle->new;
+ $fh->open("|$CPAN::Config->{'ftp'}$verbose $host")
+ or die "Couldn't open ftp: $!";
+ # pilot is blind now
+ CPAN->debug("dialog [".(join "|",@dialog)."]")
+ if $CPAN::DEBUG;
+ foreach (@dialog) { $fh->print("$_\n") }
+ $fh->close; # Wait for process to complete
+ my $wstatus = $?;
+ my $estatus = $wstatus >> 8;
+ print qq{
+Subprocess "|$CPAN::Config->{'ftp'}$verbose $host"
+ returned status $estatus (wstat $wstatus)
+} if $wstatus;
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
+ $mtime ||= 0;
+ if ($mtime > $timestamp) {
+ print "GOT $aslocal\n";
+ return $aslocal;
+ } else {
+ print "Hmm... Still failed!\n";
+ }
+ } else {
+ warn "Your $netrcfile is not correctly protected.\n";
+ }
+ } else {
+ warn "Your ~/.netrc neither contains $host
+ nor does it have a default entry\n";
+ }
+
+ # OK, they don't have a valid ~/.netrc. Use 'ftp -n' then and
+ # login manually to host, using e-mail as password.
+ print qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n};
+ unshift(
+ @dialog,
+ "open $host",
+ "user anonymous $Config::Config{'cf_email'}"
+ );
+ CPAN->debug("dialog [".(join "|",@dialog)."]") if $CPAN::DEBUG;
+ $fh = FileHandle->new;
+ $fh->open("|$CPAN::Config->{'ftp'}$verbose -n") or
+ die "Cannot fork: $!\n";
+ foreach (@dialog) { $fh->print("$_\n") }
+ $fh->close;
+ my $wstatus = $?;
+ my $estatus = $wstatus >> 8;
+ print qq{
+Subprocess "|$CPAN::Config->{'ftp'}$verbose -n"
+ returned status $estatus (wstat $wstatus)
+} if $wstatus;
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
+ $mtime ||= 0;
+ if ($mtime > $timestamp) {
+ print "GOT $aslocal\n";
+ return $aslocal;
+ } else {
+ print "Bad luck... Still failed!\n";
+ }
+ }
+ sleep 2;
+ }
+
+ print "Can't access URL $url.\n\n";
+ my(@mess,$mess);
+ push @mess, "LWP" unless CPAN->hasLWP;
+ push @mess, "Net::FTP" unless CPAN->hasFTP;
+ my($ext);
+ for $ext (qw/lynx ncftp ftp/) {
+ $CPAN::Config->{$ext} ||= "";
+ push @mess, "an external $ext" unless -x $CPAN::Config->{$ext};
+ }
+ $mess = qq{Either get }.
+ join(" or ",@mess).
+ qq{ or check, if the URL found in your configuration file, }.
+ $CPAN::Config->{urllist}[$i].
+ qq{, is valid.};
+ print Text::Wrap::wrap("","",$mess), "\n";
+ }
+ print "Cannot fetch $file\n";
+ return;
+}
+
+package CPAN::FTP::netrc;
+
+sub new {
+ my($class) = @_;
+ my $file = MM->catfile($ENV{HOME},".netrc");
+
+ my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks)
+ = stat($file);
+ $mode ||= 0;
+ my $protected = 0;
+
my($fh,@machines,$hasdefault);
$hasdefault = 0;
$fh = FileHandle->new or die "Could not create a filehandle";
return if $last_time + $CPAN::Config->{index_expire}*86400 > $time;
$last_time = $time;
- $cl->read_authindex($cl->reload_x("authors/01mailrc.txt.gz","01mailrc.gz",$force));
+ $cl->read_authindex($cl->reload_x(
+ "authors/01mailrc.txt.gz",
+ "01mailrc.gz",
+ $force));
return if $CPAN::Signal; # this is sometimes lengthy
- $cl->read_modpacks($cl->reload_x("modules/02packages.details.txt.gz","02packag.gz",$force));
+ $cl->read_modpacks($cl->reload_x(
+ "modules/02packages.details.txt.gz",
+ "02packag.gz",
+ $force));
return if $CPAN::Signal; # this is sometimes lengthy
- $cl->read_modlist($cl->reload_x("modules/03modlist.data.gz","03mlist.gz",$force));
+ $cl->read_modlist($cl->reload_x(
+ "modules/03modlist.data.gz",
+ "03mlist.gz",
+ $force));
}
#-> sub CPAN::Index::reload_x ;
my($cl,$wanted,$localname,$force) = @_;
$force ||= 0;
my $abs_wanted = CPAN->catfile($CPAN::Config->{'keep_source_where'},$localname);
- if (-f $abs_wanted && -M $abs_wanted < $CPAN::Config->{'index_expire'} && !$force) {
+ if (-f $abs_wanted &&
+ -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
+ !$force) {
my($s) = $CPAN::Config->{'index_expire'} != 1;
- $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} day$s. I\'ll use that.\n});
+ $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
+ qq{day$s. I\'ll use that.\n});
return $abs_wanted;
} else {
$force ||= 1;
available! I\'d suggest--provided you have time--you try
install CPAN
reload cpan
- without quitting the current session. It should be a seemless upgrade
- while we are running...
-};
- sleep 2;
- print qq{\n};
- }
- }
-
- my($id);
- if ($bundle){
- $id = $CPAN::META->instance('CPAN::Bundle',$mod);
- $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist);
-# This "next" makes us faster but if the job is running long, we ignore
-# rereads which is bad. So we have to be a bit slower again.
-# } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
-# next;
- } else {
- # instantiate a module object
- $id = $CPAN::META->instance('CPAN::Module',$mod);
- $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist);
- }
-
- # determine the author
- my($userid) = $dist =~ /([^\/]+)/;
- $id->set('CPAN_USERID' => $userid) if $userid =~ /\w/;
-
- # instantiate a distribution object
- unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
- $CPAN::META->instance(
- 'CPAN::Distribution' => $dist
- )->set(
- 'CPAN_USERID' => $userid
- )
- if $userid =~ /\w/;
- }
-
- return if $CPAN::Signal;
- }
- $fh->close;
- $? and Carp::croak "FAILED $pipe: exit status [$?]";
-}
-
-#-> sub CPAN::Index::read_modlist ;
-sub read_modlist {
- my($cl,$index_target) = @_;
- my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
- warn "Going to read $index_target\n";
- my $fh = FileHandle->new("$pipe|");
- my $eval = "";
- while (<$fh>) {
- next if 1../^\s*$/;
- next if /use vars/; # will go away in 03...
- $eval .= $_;
- return if $CPAN::Signal;
- }
- $eval .= q{CPAN::Modulelist->data;};
- local($^W) = 0;
- my($comp) = Safe->new("CPAN::Safe1");
- my $ret = $comp->reval($eval);
- Carp::confess($@) if $@;
- return if $CPAN::Signal;
- for (keys %$ret) {
- my $obj = $CPAN::META->instance(CPAN::Module,$_);
- $obj->set(%{$ret->{$_}});
- return if $CPAN::Signal;
- }
-}
-
-package CPAN::InfoObj;
-@CPAN::InfoObj::ISA = qw(CPAN::Debug);
-
-#-> sub CPAN::InfoObj::new ;
-sub new { my $this = bless {}, shift; %$this = @_; $this }
-
-#-> sub CPAN::InfoObj::set ;
-sub set {
- my($self,%att) = @_;
- my(%oldatt) = %$self;
- %$self = (%oldatt, %att);
-}
-
-#-> sub CPAN::InfoObj::id ;
-sub id { shift->{'ID'} }
-
-#-> sub CPAN::InfoObj::as_glimpse ;
-sub as_glimpse {
- my($self) = @_;
- my(@m);
- my $class = ref($self);
- $class =~ s/^CPAN:://;
- push @m, sprintf "%-15s %s\n", $class, $self->{ID};
- join "", @m;
-}
-
-#-> sub CPAN::InfoObj::as_string ;
-sub as_string {
- my($self) = @_;
- my(@m);
- my $class = ref($self);
- $class =~ s/^CPAN:://;
- push @m, $class, " id = $self->{ID}\n";
- for (sort keys %$self) {
- next if $_ eq 'ID';
- my $extra = "";
- $_ eq "CPAN_USERID" and $extra = " (".$self->author.")";
- if (ref($self->{$_}) eq "ARRAY") { # Should we setup a language interface? XXX
- push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
- } else {
- push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
- }
- }
- join "", @m, "\n";
-}
-
-#-> sub CPAN::InfoObj::author ;
-sub author {
- my($self) = @_;
- $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
-}
-
-package CPAN::Author;
-@CPAN::Author::ISA = qw(CPAN::Debug CPAN::InfoObj);
-
-#-> sub CPAN::Author::as_glimpse ;
-sub as_glimpse {
- my($self) = @_;
- my(@m);
- my $class = ref($self);
- $class =~ s/^CPAN:://;
- push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
- join "", @m;
-}
-
-# Dead code, I would have liked to have,,, but it was never reached,,,
-#sub make {
-# my($self) = @_;
-# return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
-#}
-
-#-> sub CPAN::Author::fullname ;
-sub fullname { shift->{'FULLNAME'} }
-*name = \&fullname;
-#-> sub CPAN::Author::email ;
-sub email { shift->{'EMAIL'} }
-
-package CPAN::Distribution;
-@CPAN::Distribution::ISA = qw(CPAN::Debug CPAN::InfoObj);
-
-#-> sub CPAN::Distribution::called_for ;
-sub called_for {
- my($self,$id) = @_;
- $self->{'CALLED_FOR'} = $id if defined $id;
- return $self->{'CALLED_FOR'};
-}
-
-#-> sub CPAN::Distribution::get ;
-sub get {
- my($self) = @_;
- EXCUSE: {
- my @e;
- exists $self->{'build_dir'} and push @e, "Unwrapped into directory $self->{'build_dir'}";
- print join "", map {" $_\n"} @e and return if @e;
- }
- my($local_file);
- my($local_wanted) =
- CPAN->catfile(
- $CPAN::Config->{keep_source_where},
- "authors",
- "id",
- split("/",$self->{ID})
- );
-
- $self->debug("Doing localize") if $CPAN::DEBUG;
- $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted);
- $self->{localfile} = $local_file;
- my $builddir = $CPAN::META->{cachemgr}->dir;
- $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
- chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
- my $packagedir;
-
- $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
- if ($CPAN::META->hasMD5) {
- $self->verifyMD5;
- }
- if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz|\.zip)$/i){
- $self->debug("Removing tmp") if $CPAN::DEBUG;
- File::Path::rmtree("tmp");
- mkdir "tmp", 0777 or Carp::croak "Couldn't mkdir tmp: $!";
- chdir "tmp";
- $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
- if ($local_file =~ /z$/i){
- $self->{archived} = "tar";
- if (system("$CPAN::Config->{gzip} --decompress --stdout $local_file | $CPAN::Config->{tar} xvf -")==0) {
- $self->{unwrapped} = "YES";
- } else {
- $self->{unwrapped} = "NO";
- }
- } elsif ($local_file =~ /zip$/i) {
- $self->{archived} = "zip";
- if (system("$CPAN::Config->{unzip} $local_file")==0) {
- $self->{unwrapped} = "YES";
- } else {
- $self->{unwrapped} = "NO";
+ without quitting the current session. It should be a seemless upgrade
+ while we are running...
+};
+ sleep 2;
+ print qq{\n};
}
+ last if $CPAN::Signal;
}
- # Let's check if the package has its own directory.
- opendir DIR, "." or Carp::croak("Weird: couldn't opendir .: $!");
- my @readdir = grep $_ !~ /^\.\.?$/, readdir DIR; ### MAC??
- closedir DIR;
- my ($distdir,$packagedir);
- if (@readdir == 1 && -d $readdir[0]) {
- $distdir = $readdir[0];
- $packagedir = $CPAN::META->catdir($builddir,$distdir);
- -d $packagedir and print "Removing previously used $packagedir\n";
- File::Path::rmtree($packagedir);
- rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
+
+ my($id);
+ if ($bundle){
+ $id = $CPAN::META->instance('CPAN::Bundle',$mod);
+ $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist);
+# This "next" makes us faster but if the job is running long, we ignore
+# rereads which is bad. So we have to be a bit slower again.
+# } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
+# next;
} else {
- my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
- $pragmatic_dir =~ s/\W_//g;
- $pragmatic_dir++ while -d "../$pragmatic_dir";
- $packagedir = $CPAN::META->catdir($builddir,$pragmatic_dir);
- File::Path::mkpath($packagedir);
- my($f);
- for $f (@readdir) { # is already without "." and ".."
- my $to = $CPAN::META->catdir($packagedir,$f);
- rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
- }
+ # instantiate a module object
+ $id = $CPAN::META->instance('CPAN::Module',$mod);
+ $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist);
}
- $self->{'build_dir'} = $packagedir;
- chdir "..";
- $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") if $CPAN::DEBUG;
- File::Path::rmtree("tmp");
- if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
- print "Going to unlink $local_file\n";
- unlink $local_file or Carp::carp "Couldn't unlink $local_file";
- }
- my($makefilepl) = $CPAN::META->catfile($packagedir,"Makefile.PL");
- unless (-f $makefilepl) {
- my($configure) = $CPAN::META->catfile($packagedir,"Configure");
- if (-f $configure) {
- # do we have anything to do?
- $self->{'configure'} = $configure;
- } else {
- my $fh = FileHandle->new(">$makefilepl") or Carp::croak("Could not open >$makefilepl");
- my $cf = $self->called_for || "unknown";
- $fh->print(qq{
-# This Makefile.PL has been autogenerated by the module CPAN.pm
-# Autogenerated on: }.scalar localtime().qq{
- use ExtUtils::MakeMaker;
- WriteMakefile(NAME => q[$cf]);
-});
- print qq{Package comes without Makefile.PL.\n}.
- qq{ Writing one on our own (calling it $cf)\n};
- }
+ # determine the author
+ my($userid) = $dist =~ /([^\/]+)/;
+ $id->set('CPAN_USERID' => $userid) if $userid =~ /\w/;
+
+ # instantiate a distribution object
+ unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
+ $CPAN::META->instance(
+ 'CPAN::Distribution' => $dist
+ )->set(
+ 'CPAN_USERID' => $userid
+ )
+ if $userid =~ /\w/;
}
- } else {
- $self->{archived} = "NO";
+
+ return if $CPAN::Signal;
}
- return $self;
+ $fh->close;
+ $? and Carp::croak "FAILED $pipe: exit status [$?]";
}
-#-> sub CPAN::Distribution::new ;
-sub new {
- my($class,%att) = @_;
+#-> sub CPAN::Index::read_modlist ;
+sub read_modlist {
+ my($cl,$index_target) = @_;
+ my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
+ warn "Going to read $index_target\n";
+ my $fh = FileHandle->new("$pipe|");
+ my $eval = "";
+ while (<$fh>) {
+ next if 1../^\s*$/;
+ next if /use vars/; # will go away in 03...
+ $eval .= $_;
+ return if $CPAN::Signal;
+ }
+ $eval .= q{CPAN::Modulelist->data;};
+ local($^W) = 0;
+ my($comp) = Safe->new("CPAN::Safe1");
+ my $ret = $comp->reval($eval);
+ Carp::confess($@) if $@;
+ return if $CPAN::Signal;
+ for (keys %$ret) {
+ my $obj = $CPAN::META->instance(CPAN::Module,$_);
+ $obj->set(%{$ret->{$_}});
+ return if $CPAN::Signal;
+ }
+}
- $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
+package CPAN::InfoObj;
+@CPAN::InfoObj::ISA = qw(CPAN::Debug);
- my $this = { %att };
- return bless $this, $class;
-}
+#-> sub CPAN::InfoObj::new ;
+sub new { my $this = bless {}, shift; %$this = @_; $this }
-#-> sub CPAN::Distribution::look ;
-sub look {
- my($self) = @_;
- if ( $CPAN::Config->{'shell'} ) {
- print qq{
-Trying to open a subshell in the build directory...
-};
- } else {
- print qq{
-Your configuration does not define a value for subshells.
-Please define it with "o conf shell <your shell>"
-};
- return;
- }
- my $dist = $self->id;
- my $dir = $self->dir or $self->get;
- $dir = $self->dir;
- my $pwd = Cwd::cwd();
- chdir($dir);
- print qq{Working directory is $dir.\n};
- system($CPAN::Config->{'shell'})==0 or die "Subprocess shell error";
- chdir($pwd);
+#-> sub CPAN::InfoObj::set ;
+sub set {
+ my($self,%att) = @_;
+ my(%oldatt) = %$self;
+ %$self = (%oldatt, %att);
}
-#-> sub CPAN::Distribution::readme ;
-sub readme {
- my($self) = @_;
- my($dist) = $self->id;
- my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
- $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
- my($local_file);
- my($local_wanted) =
- CPAN->catfile(
- $CPAN::Config->{keep_source_where},
- "authors",
- "id",
- split("/","$sans.readme"),
- );
- $self->debug("Doing localize") if $CPAN::DEBUG;
- $local_file = CPAN::FTP->localize("authors/id/$sans.readme", $local_wanted);
- my $fh_pager = FileHandle->new;
- $fh_pager->open("|$CPAN::Config->{'pager'}") or die "Could not open pager $CPAN::Config->{'pager'}: $!";
- my $fh_readme = FileHandle->new;
- $fh_readme->open($local_file) or die "Could not open $local_file: $!";
- $fh_pager->print(<$fh_readme>);
-}
+#-> sub CPAN::InfoObj::id ;
+sub id { shift->{'ID'} }
-#-> sub CPAN::Distribution::verifyMD5 ;
-sub verifyMD5 {
+#-> sub CPAN::InfoObj::as_glimpse ;
+sub as_glimpse {
my($self) = @_;
- EXCUSE: {
- my @e;
- $self->{MD5_STATUS} and push @e, "MD5 Checksum was ok";
- print join "", map {" $_\n"} @e and return if @e;
- }
- my($local_file);
- my(@local) = split("/",$self->{ID});
- my($basename) = pop @local;
- push @local, "CHECKSUMS";
- my($local_wanted) =
- CPAN->catfile(
- $CPAN::Config->{keep_source_where},
- "authors",
- "id",
- @local
- );
- local($") = "/";
- if (
- -f $local_wanted
- &&
- $self->MD5_check_file($local_wanted,$basename)
- ) {
- return $self->{MD5_STATUS}="OK";
- }
- $local_file = CPAN::FTP->localize("authors/id/@local", $local_wanted, 'force>:-{');
- my($checksum_pipe);
- if ($local_file) {
- # fine
- } else {
- $local[-1] .= ".gz";
- $local_file = CPAN::FTP->localize(
- "authors/id/@local",
- "$local_wanted.gz",
- 'force>:-{'
- );
- my $system = "$CPAN::Config->{gzip} --decompress $local_file";
- system($system)==0 or die "Could not uncompress $local_file";
- $local_file =~ s/\.gz$//;
- }
- $self->MD5_check_file($local_file,$basename);
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ push @m, sprintf "%-15s %s\n", $class, $self->{ID};
+ join "", @m;
}
-#-> sub CPAN::Distribution::MD5_check_file ;
-sub MD5_check_file {
- my($self,$lfile,$basename) = @_;
- my($cksum);
- my $fh = new FileHandle;
- local($/)=undef;
- if (open $fh, $lfile){
- my $eval = <$fh>;
- close $fh;
- my($comp) = Safe->new();
- $cksum = $comp->reval($eval);
- Carp::confess($@) if $@;
- if ($cksum->{$basename}->{md5}) {
- $self->debug("Found checksum for $basename: $cksum->{$basename}->{md5}\n") if $CPAN::DEBUG;
- my $file = $self->{localfile};
- my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $self->{localfile}|";
- if (
- open($fh, $file) && $self->eq_MD5($fh,$cksum->{$basename}->{md5})
- or
- open($fh, $pipe) && $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'})
- ){
- print "Checksum for $file ok\n";
- return $self->{MD5_STATUS}="OK";
- } else {
- die join(
- "",
- "\nChecksum mismatch for distribution file. Please investigate.\n\n",
- $self->as_string,
- $CPAN::META->instance('CPAN::Author',$self->{CPAN_USERID})->as_string,
- "Please contact the author or your CPAN site admin"
- );
- }
- close $fh if fileno($fh);
+#-> sub CPAN::InfoObj::as_string ;
+sub as_string {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ push @m, $class, " id = $self->{ID}\n";
+ for (sort keys %$self) {
+ next if $_ eq 'ID';
+ my $extra = "";
+ $_ eq "CPAN_USERID" and $extra = " (".$self->author.")";
+ if (ref($self->{$_}) eq "ARRAY") { # Should we setup a language interface? XXX
+ push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
} else {
- print "No md5 checksum for $basename in local $lfile\n";
- return;
- }
- } else {
- Carp::carp "Could not open $lfile for reading";
+ push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
+ }
}
+ join "", @m, "\n";
}
-#-> sub CPAN::Distribution::eq_MD5 ;
-sub eq_MD5 {
- my($self,$fh,$expectMD5) = @_;
- my $md5 = new MD5;
- $md5->addfile($fh);
- my $hexdigest = $md5->hexdigest;
- $hexdigest eq $expectMD5;
+#-> sub CPAN::InfoObj::author ;
+sub author {
+ my($self) = @_;
+ $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
}
-#-> sub CPAN::Distribution::force ;
-sub force {
+package CPAN::Author;
+@CPAN::Author::ISA = qw(CPAN::InfoObj);
+
+#-> sub CPAN::Author::as_glimpse ;
+sub as_glimpse {
my($self) = @_;
- $self->{'force_update'}++;
- delete $self->{'MD5_STATUS'};
- delete $self->{'archived'};
- delete $self->{'build_dir'};
- delete $self->{'localfile'};
- delete $self->{'make'};
- delete $self->{'install'};
- delete $self->{'unwrapped'};
- delete $self->{'writemakefile'};
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
+ join "", @m;
}
-#-> sub CPAN::Distribution::make ;
-sub make {
- my($self) = @_;
- $self->debug($self->id) if $CPAN::DEBUG;
- print "Running make\n";
- $self->get;
- EXCUSE: {
- my @e;
- $self->{archived} eq "NO" and push @e, "Is neither a tar nor a zip archive.";
- $self->{unwrapped} eq "NO" and push @e, "had problems unarchiving. Please build manually";
- exists $self->{writemakefile} && $self->{writemakefile} eq "NO" and push @e, "Had some problem writing Makefile";
- defined $self->{'make'} and push @e, "Has already been processed within this session";
- print join "", map {" $_\n"} @e and return if @e;
- }
- print "\n CPAN.pm: Going to build ".$self->id."\n\n";
- my $builddir = $self->dir;
- chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
- $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
+# Dead code, I would have liked to have,,, but it was never reached,,,
+#sub make {
+# my($self) = @_;
+# return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
+#}
- my $system;
- if ($self->{'configure'}) {
- $system = $self->{'configure'};
- } else {
- my($perl) = $^X =~ /^\.\// ? "$CPAN::Cwd/$^X" : $^X; # XXX subclassing folks, forgive me!
- $system = "$perl Makefile.PL $CPAN::Config->{makepl_arg}";
- }
- $SIG{ALRM} = sub { die "inactivity_timeout reached\n" };
- my($ret,$pid);
- $@ = "";
- if ($CPAN::Config->{inactivity_timeout}) {
- eval {
- alarm $CPAN::Config->{inactivity_timeout};
- #$SIG{CHLD} = \&REAPER;
- if (defined($pid=fork)) {
- if ($pid) { #parent
- wait;
- } else { #child
- exec $system;
- }
- } else {
- print "Cannot fork: $!";
- return;
- }
- $ret = system($system);
- };
- alarm 0;
- } else {
- $ret = system($system);
- }
- if ($@){
- kill 9, $pid;
- waitpid $pid, 0;
- print $@;
- $self->{writemakefile} = "NO - $@";
- $@ = "";
- return;
- } elsif ($ret != 0) {
- $self->{writemakefile} = "NO";
- return;
- }
- $self->{writemakefile} = "YES";
- return if $CPAN::Signal;
- $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
- if (system($system)==0) {
- print " $system -- OK\n";
- $self->{'make'} = "YES";
- } else {
- $self->{writemakefile} = "YES";
- $self->{'make'} = "NO";
- print " $system -- NOT OK\n";
- }
-}
+#-> sub CPAN::Author::fullname ;
+sub fullname { shift->{'FULLNAME'} }
+*name = \&fullname;
+#-> sub CPAN::Author::email ;
+sub email { shift->{'EMAIL'} }
-#-> sub CPAN::Distribution::test ;
-sub test {
- my($self) = @_;
- $self->make;
- return if $CPAN::Signal;
- print "Running make test\n";
- EXCUSE: {
- my @e;
- exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't test";
- exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status";
- exists $self->{'build_dir'} or push @e, "Has no own directory";
- print join "", map {" $_\n"} @e and return if @e;
- }
- chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
- $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
- my $system = join " ", $CPAN::Config->{'make'}, "test";
- if (system($system)==0) {
- print " $system -- OK\n";
- $self->{'make_test'} = "YES";
- } else {
- $self->{'make_test'} = "NO";
- print " $system -- NOT OK\n";
- }
-}
+package CPAN::Distribution;
+@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
-#-> sub CPAN::Distribution::clean ;
-sub clean {
- my($self) = @_;
- print "Running make clean\n";
- EXCUSE: {
- my @e;
- exists $self->{'build_dir'} or push @e, "Has no own directory";
- print join "", map {" $_\n"} @e and return if @e;
- }
- chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
- $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
- my $system = join " ", $CPAN::Config->{'make'}, "clean";
- if (system($system)==0) {
- print " $system -- OK\n";
- $self->force;
- } else {
- # Hmmm, what to do if make clean failed?
- }
+#-> sub CPAN::Distribution::called_for ;
+sub called_for {
+ my($self,$id) = @_;
+ $self->{'CALLED_FOR'} = $id if defined $id;
+ return $self->{'CALLED_FOR'};
}
-#-> sub CPAN::Distribution::install ;
-sub install {
+#-> sub CPAN::Distribution::get ;
+sub get {
my($self) = @_;
- $self->test;
- return if $CPAN::Signal;
- print "Running make install\n";
EXCUSE: {
my @e;
- exists $self->{'build_dir'} or push @e, "Has no own directory";
- exists $self->{'make'} or push @e, "Make had some problems, maybe interrupted? Won't install";
- exists $self->{'make'} and $self->{'make'} eq 'NO' and push @e, "Oops, make had returned bad status";
- exists $self->{'install'} and push @e, $self->{'install'} eq "YES" ? "Already done" : "Already tried without success";
+ exists $self->{'build_dir'} and push @e,
+ "Unwrapped into directory $self->{'build_dir'}";
print join "", map {" $_\n"} @e and return if @e;
}
- chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
- $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
- my $system = join " ", $CPAN::Config->{'make'}, "install", $CPAN::Config->{make_install_arg};
- my($pipe) = FileHandle->new("$system 2>&1 |");
- my($makeout) = "";
- while (<$pipe>){
- print;
- $makeout .= $_;
+ my($local_file);
+ my($local_wanted) =
+ CPAN->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split("/",$self->{ID})
+ );
+
+ $self->debug("Doing localize") if $CPAN::DEBUG;
+ $local_file = CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted);
+ $self->{localfile} = $local_file;
+ my $builddir = $CPAN::META->{cachemgr}->dir;
+ $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
+ chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
+ my $packagedir;
+
+ $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
+ if ($CPAN::META->hasMD5) {
+ $self->verifyMD5;
}
- $pipe->close;
- if ($?==0) {
- print " $system -- OK\n";
- $self->{'install'} = "YES";
- } else {
- $self->{'install'} = "NO";
- print " $system -- NOT OK\n";
- if ($makeout =~ /permission/s && $> > 0) {
- print " You may have to su to root to install the package\n";
- }
+ if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz|\.zip)$/i){
+ $self->debug("Removing tmp") if $CPAN::DEBUG;
+ File::Path::rmtree("tmp");
+ mkdir "tmp", 0777 or Carp::croak "Couldn't mkdir tmp: $!";
+ chdir "tmp";
+ $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
+ if ($local_file =~ /z$/i){
+ $self->{archived} = "tar";
+ if (system("$CPAN::Config->{gzip} --decompress --stdout $local_file | $CPAN::Config->{tar} xvf -")==0) {
+ $self->{unwrapped} = "YES";
+ } else {
+ $self->{unwrapped} = "NO";
+ }
+ } elsif ($local_file =~ /zip$/i) {
+ $self->{archived} = "zip";
+ if (system("$CPAN::Config->{unzip} $local_file")==0) {
+ $self->{unwrapped} = "YES";
+ } else {
+ $self->{unwrapped} = "NO";
+ }
+ }
+ # Let's check if the package has its own directory.
+ opendir DIR, "." or Carp::croak("Weird: couldn't opendir .: $!");
+ my @readdir = grep $_ !~ /^\.\.?$/, readdir DIR; ### MAC??
+ closedir DIR;
+ my ($distdir,$packagedir);
+ if (@readdir == 1 && -d $readdir[0]) {
+ $distdir = $readdir[0];
+ $packagedir = $CPAN::META->catdir($builddir,$distdir);
+ -d $packagedir and print "Removing previously used $packagedir\n";
+ File::Path::rmtree($packagedir);
+ rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
+ } else {
+ my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
+ $pragmatic_dir =~ s/\W_//g;
+ $pragmatic_dir++ while -d "../$pragmatic_dir";
+ $packagedir = $CPAN::META->catdir($builddir,$pragmatic_dir);
+ File::Path::mkpath($packagedir);
+ my($f);
+ for $f (@readdir) { # is already without "." and ".."
+ my $to = $CPAN::META->catdir($packagedir,$f);
+ rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
+ }
+ }
+ $self->{'build_dir'} = $packagedir;
+
+ chdir "..";
+ $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
+ if $CPAN::DEBUG;
+ File::Path::rmtree("tmp");
+ if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
+ print "Going to unlink $local_file\n";
+ unlink $local_file or Carp::carp "Couldn't unlink $local_file";
+ }
+ my($makefilepl) = $CPAN::META->catfile($packagedir,"Makefile.PL");
+ unless (-f $makefilepl) {
+ my($configure) = $CPAN::META->catfile($packagedir,"Configure");
+ if (-f $configure) {
+ # do we have anything to do?
+ $self->{'configure'} = $configure;
+ } else {
+ my $fh = FileHandle->new(">$makefilepl")
+ or Carp::croak("Could not open >$makefilepl");
+ my $cf = $self->called_for || "unknown";
+ $fh->print(qq{
+# This Makefile.PL has been autogenerated by the module CPAN.pm
+# Autogenerated on: }.scalar localtime().qq{
+ use ExtUtils::MakeMaker;
+ WriteMakefile(NAME => q[$cf]);
+});
+ print qq{Package comes without Makefile.PL.\n}.
+ qq{ Writing one on our own (calling it $cf)\n};
+ }
+ }
+ } else {
+ $self->{archived} = "NO";
}
+ return $self;
}
-#-> sub CPAN::Distribution::dir ;
-sub dir {
- shift->{'build_dir'};
-}
-
-package CPAN::Bundle;
-@CPAN::Bundle::ISA = qw(CPAN::Debug CPAN::InfoObj CPAN::Module);
+#-> sub CPAN::Distribution::new ;
+sub new {
+ my($class,%att) = @_;
-#-> sub CPAN::Bundle::as_string ;
-sub as_string {
- my($self) = @_;
- $self->contains;
- return $self->SUPER::as_string;
-}
+ $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
-#-> sub CPAN::Bundle::contains ;
-sub contains {
- my($self) = @_;
- my($parsefile) = $self->inst_file;
- unless ($parsefile) {
- # Try to get at it in the cpan directory
- $self->debug("no parsefile") if $CPAN::DEBUG;
- my $dist = $CPAN::META->instance('CPAN::Distribution',$self->{'CPAN_FILE'});
- $self->debug($dist->as_string) if $CPAN::DEBUG;
- $dist->get;
- $self->debug($dist->as_string) if $CPAN::DEBUG;
- my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
- File::Path::mkpath($todir);
- my($me,$from,$to);
- ($me = $self->id) =~ s/.*://;
- $from = $CPAN::META->catfile($dist->{'build_dir'},"$me.pm");
- $to = $CPAN::META->catfile($todir,"$me.pm");
- File::Copy::copy($from, $to) or Carp::confess("Couldn't copy $from to $to: $!");
- $parsefile = $to;
- }
- my @result;
- my $fh = new FileHandle;
- local $/ = "\n";
- open($fh,$parsefile) or die "Could not open '$parsefile': $!";
- my $inpod = 0;
- while (<$fh>) {
- $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : /^=head1\s+CONTENTS/ ? 1 : $inpod;
- next unless $inpod;
- next if /^=/;
- next if /^\s+$/;
- chomp;
- push @result, (split " ", $_, 2)[0];
- }
- close $fh;
- delete $self->{STATUS};
- $self->{CONTAINS} = [@result];
- @result;
+ my $this = { %att };
+ return bless $this, $class;
}
-#-> sub CPAN::Bundle::inst_file ;
-sub inst_file {
+#-> sub CPAN::Distribution::look ;
+sub look {
my($self) = @_;
- my($me,$inst_file);
- ($me = $self->id) =~ s/.*://;
- $inst_file = $CPAN::META->catfile($CPAN::Config->{'cpan_home'},"Bundle", "$me.pm");
- return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
- $inst_file = $self->SUPER::inst_file;
- return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
- return $self->{'INST_FILE'}; # even if undefined?
-}
-
-#-> sub CPAN::Bundle::rematein ;
-sub rematein {
- my($self,$meth) = @_;
- $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
- my($s);
- for $s ($self->contains) {
- $CPAN::META->instance('CPAN::Module',$s)->$meth();
+ if ( $CPAN::Config->{'shell'} ) {
+ print qq{
+Trying to open a subshell in the build directory...
+};
+ } else {
+ print qq{
+Your configuration does not define a value for subshells.
+Please define it with "o conf shell <your shell>"
+};
+ return;
}
+ my $dist = $self->id;
+ my $dir = $self->dir or $self->get;
+ $dir = $self->dir;
+ my $pwd = Cwd::cwd();
+ chdir($dir);
+ print qq{Working directory is $dir.\n};
+ system($CPAN::Config->{'shell'})==0 or die "Subprocess shell error";
+ chdir($pwd);
}
-#-> sub CPAN::Bundle::force ;
-sub force { shift->rematein('force',@_); }
-#-> sub CPAN::Bundle::get ;
-sub get { shift->rematein('get',@_); }
-#-> sub CPAN::Bundle::make ;
-sub make { shift->rematein('make',@_); }
-#-> sub CPAN::Bundle::test ;
-sub test { shift->rematein('test',@_); }
-#-> sub CPAN::Bundle::install ;
-sub install { shift->rematein('install',@_); }
-#-> sub CPAN::Bundle::clean ;
-sub clean { shift->rematein('clean',@_); }
-
-#-> sub CPAN::Bundle::readme ;
-sub readme {
+#-> sub CPAN::Distribution::readme ;
+sub readme {
my($self) = @_;
- my($file) = $self->cpan_file or print("No File found for bundle ", $self->id, "\n"), return;
- $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
- $CPAN::META->instance('CPAN::Distribution',$file)->readme;
+ my($dist) = $self->id;
+ my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
+ $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
+ my($local_file);
+ my($local_wanted) =
+ CPAN->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split("/","$sans.readme"),
+ );
+ $self->debug("Doing localize") if $CPAN::DEBUG;
+ $local_file = CPAN::FTP->localize("authors/id/$sans.readme", $local_wanted);
+ my $fh_pager = FileHandle->new;
+ $fh_pager->open("|$CPAN::Config->{'pager'}")
+ or die "Could not open pager $CPAN::Config->{'pager'}: $!";
+ my $fh_readme = FileHandle->new;
+ $fh_readme->open($local_file) or die "Could not open $local_file: $!";
+ $fh_pager->print(<$fh_readme>);
}
-package CPAN::Module;
-@CPAN::Module::ISA = qw(CPAN::Debug CPAN::InfoObj);
-
-#-> sub CPAN::Module::as_glimpse ;
-sub as_glimpse {
+#-> sub CPAN::Distribution::verifyMD5 ;
+sub verifyMD5 {
my($self) = @_;
- my(@m);
- my $class = ref($self);
- $class =~ s/^CPAN:://;
- push @m, sprintf "%-15s %-15s (%s)\n", $class, $self->{ID}, $self->cpan_file;
- join "", @m;
+ EXCUSE: {
+ my @e;
+ $self->{MD5_STATUS} ||= "";
+ $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
+ print join "", map {" $_\n"} @e and return if @e;
+ }
+ my($local_file);
+ my(@local) = split("/",$self->{ID});
+ my($basename) = pop @local;
+ push @local, "CHECKSUMS";
+ my($local_wanted) =
+ CPAN->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ @local
+ );
+ local($") = "/";
+ if (
+ -f $local_wanted
+ &&
+ $self->MD5_check_file($local_wanted,$basename)
+ ) {
+ return $self->{MD5_STATUS} = "OK";
+ }
+ $local_file = CPAN::FTP->localize(
+ "authors/id/@local",
+ $local_wanted,
+ 'force>:-{');
+ my($checksum_pipe);
+ if ($local_file) {
+ # fine
+ } else {
+ $local[-1] .= ".gz";
+ $local_file = CPAN::FTP->localize(
+ "authors/id/@local",
+ "$local_wanted.gz",
+ 'force>:-{'
+ );
+ my $system = "$CPAN::Config->{gzip} --decompress $local_file";
+ system($system)==0 or die "Could not uncompress $local_file";
+ $local_file =~ s/\.gz$//;
+ }
+ $self->MD5_check_file($local_file,$basename);
}
-#-> sub CPAN::Module::as_string ;
-sub as_string {
- my($self) = @_;
- my(@m);
- CPAN->debug($self) if $CPAN::DEBUG;
- my $class = ref($self);
- $class =~ s/^CPAN:://;
- local($^W) = 0;
- push @m, $class, " id = $self->{ID}\n";
- my $sprintf = " %-12s %s\n";
- push @m, sprintf $sprintf, 'DESCRIPTION', $self->{description} if $self->{description};
- my $sprintf2 = " %-12s %s (%s)\n";
- my($userid);
- if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
- push @m, sprintf(
- $sprintf2,
- 'CPAN_USERID',
- $userid,
- $CPAN::META->instance(CPAN::Author,$userid)->fullname
- )
- }
- push @m, sprintf $sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION} if $self->{CPAN_VERSION};
- push @m, sprintf $sprintf, 'CPAN_FILE', $self->{CPAN_FILE} if $self->{CPAN_FILE};
- my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
- my(%statd,%stats,%statl,%stati);
- @statd{qw,? i c a b R M S,} = qw,unknown idea pre-alpha alpha beta released mature standard,;
- @stats{qw,? m d u n,} = qw,unknown mailing-list developer comp.lang.perl.* none,;
- @statl{qw,? p c + o,} = qw,unknown perl C C++ other,;
- @stati{qw,? f r O,} = qw,unknown functions references+ties object-oriented,;
- $statd{' '} = 'unknown';
- $stats{' '} = 'unknown';
- $statl{' '} = 'unknown';
- $stati{' '} = 'unknown';
- push @m, sprintf(
- $sprintf3,
- 'DSLI_STATUS',
- $self->{statd},
- $self->{stats},
- $self->{statl},
- $self->{stati},
- $statd{$self->{statd}},
- $stats{$self->{stats}},
- $statl{$self->{statl}},
- $stati{$self->{stati}}
- ) if $self->{statd};
- my $local_file = $self->inst_file;
- if ($local_file && ! exists $self->{MANPAGE}) {
- my $fh = FileHandle->new($local_file) or Carp::croak("Couldn't open $local_file: $!");
- my $inpod = 0;
- my(@result);
- local $/ = "\n";
- while (<$fh>) {
- $inpod = /^=(?!head1\s+NAME)/ ? 0 : /^=head1\s+NAME/ ? 1 : $inpod;
- next unless $inpod;
- next if /^=/;
- next if /^\s+$/;
- chomp;
- push @result, $_;
+#-> sub CPAN::Distribution::MD5_check_file ;
+sub MD5_check_file {
+ my($self,$lfile,$basename) = @_;
+ my($cksum);
+ my $fh = new FileHandle;
+ local($/)=undef;
+ if (open $fh, $lfile){
+ my $eval = <$fh>;
+ close $fh;
+ my($comp) = Safe->new();
+ $cksum = $comp->reval($eval);
+ Carp::confess($@) if $@;
+ if ($cksum->{$basename}->{md5}) {
+ $self->debug("Found checksum for $basename: $cksum->{$basename}->{md5}\n")
+ if $CPAN::DEBUG;
+ my $file = $self->{localfile};
+ my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $self->{localfile}|";
+ if (
+ open($fh, $file) && $self->eq_MD5($fh,$cksum->{$basename}->{md5})
+ or
+ open($fh, $pipe) && $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'})
+ ){
+ print "Checksum for $file ok\n";
+ return $self->{MD5_STATUS} = "OK";
+ } else {
+ print join(
+ "",
+ qq{Checksum mismatch for distribution file. },
+ qq{Please investigate.\n\n}
+ );
+ print $self->as_string;
+ print $CPAN::META->instance(
+ 'CPAN::Author',
+ $self->{CPAN_USERID}
+ )->as_string;
+ my $wrap = qq{I\'d recommend removing $self->{'localfile'}}.
+ qq{, put another URL at the top of the list of URLs to }.
+ qq{visit, and restart CPAN.pm. If all this doesn\'t help, }.
+ qq{please contact the author or your CPAN site admin};
+ print Text::Wrap::wrap("","",$wrap);
+ print "\n\n";
+ sleep 3;
+ return;
+ }
+ close $fh if fileno($fh);
+ } else {
+ $self->{MD5_STATUS} ||= "";
+ if ($self->{MD5_STATUS} eq "NIL") {
+ print "\nNo md5 checksum for $basename in local $lfile.";
+ print "Removing $lfile\n";
+ unlink $lfile or print "Could not unlink: $!";
+ sleep 1;
+ }
+ $self->{MD5_STATUS} = "NIL";
+ return;
}
- close $fh;
- $self->{MANPAGE} = join " ", @result;
- }
- push @m, sprintf $sprintf, 'MANPAGE', $self->{MANPAGE} if $self->{MANPAGE};
- push @m, sprintf $sprintf, 'INST_FILE', $local_file || "(not installed)";
- push @m, sprintf $sprintf, 'INST_VERSION', $self->inst_version if $local_file;
- join "", @m, "\n";
-}
-
-#-> sub CPAN::Module::cpan_file ;
-sub cpan_file {
- my $self = shift;
- CPAN->debug($self->id) if $CPAN::DEBUG;
- unless (defined $self->{'CPAN_FILE'}) {
- CPAN::Index->reload;
- }
- if (defined $self->{'CPAN_FILE'}){
- return $self->{'CPAN_FILE'};
- } elsif (defined $self->{'userid'}) {
- return "Contact Author ".$self->{'userid'}."=".$CPAN::META->instance(CPAN::Author,$self->{'userid'})->fullname
} else {
- return "N/A";
+ Carp::carp "Could not open $lfile for reading";
}
}
-*name = \&cpan_file;
-
-#-> sub CPAN::Module::cpan_version ;
-sub cpan_version { shift->{'CPAN_VERSION'} }
+#-> sub CPAN::Distribution::eq_MD5 ;
+sub eq_MD5 {
+ my($self,$fh,$expectMD5) = @_;
+ my $md5 = new MD5;
+ $md5->addfile($fh);
+ my $hexdigest = $md5->hexdigest;
+ $hexdigest eq $expectMD5;
+}
-#-> sub CPAN::Module::force ;
+#-> sub CPAN::Distribution::force ;
sub force {
my($self) = @_;
$self->{'force_update'}++;
+ delete $self->{'MD5_STATUS'};
+ delete $self->{'archived'};
+ delete $self->{'build_dir'};
+ delete $self->{'localfile'};
+ delete $self->{'make'};
+ delete $self->{'install'};
+ delete $self->{'unwrapped'};
+ delete $self->{'writemakefile'};
}
-#-> sub CPAN::Module::rematein ;
-sub rematein {
- my($self,$meth) = @_;
+#-> sub CPAN::Distribution::make ;
+sub make {
+ my($self) = @_;
$self->debug($self->id) if $CPAN::DEBUG;
- my $cpan_file = $self->cpan_file;
- return if $cpan_file eq "N/A";
- return if $cpan_file =~ /^Contact Author/;
- my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
- $pack->called_for($self->id);
- $pack->force if exists $self->{'force_update'};
- $pack->$meth();
- delete $self->{'force_update'};
-}
+ print "Running make\n";
+ $self->get;
+ EXCUSE: {
+ my @e;
+ $self->{archived} eq "NO" and push @e,
+ "Is neither a tar nor a zip archive.";
-#-> sub CPAN::Module::readme ;
-sub readme { shift->rematein('readme') }
-#-> sub CPAN::Module::look ;
-sub look { shift->rematein('look') }
-#-> sub CPAN::Module::get ;
-sub get { shift->rematein('get',@_); }
-#-> sub CPAN::Module::make ;
-sub make { shift->rematein('make') }
-#-> sub CPAN::Module::test ;
-sub test { shift->rematein('test') }
-#-> sub CPAN::Module::install ;
-sub install {
- my($self) = @_;
- my($doit) = 0;
- my($latest) = $self->cpan_version;
- $latest ||= 0;
- my($inst_file) = $self->inst_file;
- my($have) = 0;
- if (defined $inst_file) {
- $have = $self->inst_version;
+ $self->{unwrapped} eq "NO" and push @e,
+ "had problems unarchiving. Please build manually";
+
+ exists $self->{writemakefile} &&
+ $self->{writemakefile} eq "NO" and push @e,
+ "Had some problem writing Makefile";
+
+ defined $self->{'make'} and push @e,
+ "Has already been processed within this session";
+
+ print join "", map {" $_\n"} @e and return if @e;
}
- if ($inst_file && $have >= $latest && not exists $self->{'force_update'}) {
- print $self->id, " is up to date.\n";
+ print "\n CPAN.pm: Going to build ".$self->id."\n\n";
+ my $builddir = $self->dir;
+ chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
+ $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
+
+ my $system;
+ if ($self->{'configure'}) {
+ $system = $self->{'configure'};
} else {
- $doit = 1;
+ my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
+ $perl ||= "$CPAN::Cwd/$^X" if -x "$CPAN::Cwd/$^X";
+ unless ($perl) {
+ my ($component,$perl_name);
+ DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
+ DIST_COMPONENT: foreach $component (MM->path(), $Config::Config{'binexp'}) {
+ next unless defined($component) && $component;
+ my($abs) = MM->catfile($component,$perl_name);
+ if (MM->maybe_command($abs)) {
+ $perl = $abs;
+ last DIST_PERLNAME;
+ }
+ }
+ }
+ }
+ die "Couldn\'t find executable perl\n" unless $perl;
+ $system = "$perl Makefile.PL $CPAN::Config->{makepl_arg}";
+ }
+ $SIG{ALRM} = sub { die "inactivity_timeout reached\n" };
+ my($ret,$pid);
+ $@ = "";
+ if ($CPAN::Config->{inactivity_timeout}) {
+ eval {
+ alarm $CPAN::Config->{inactivity_timeout};
+ #$SIG{CHLD} = \&REAPER;
+ if (defined($pid=fork)) {
+ if ($pid) { #parent
+ wait;
+ } else { #child
+ exec $system;
+ }
+ } else {
+ print "Cannot fork: $!";
+ return;
+ }
+ $ret = system($system);
+ };
+ alarm 0;
+ } else {
+ $ret = system($system);
+ }
+ if ($@){
+ kill 9, $pid;
+ waitpid $pid, 0;
+ print $@;
+ $self->{writemakefile} = "NO - $@";
+ $@ = "";
+ return;
+ } elsif ($ret != 0) {
+ $self->{writemakefile} = "NO";
+ return;
+ }
+ $self->{writemakefile} = "YES";
+ return if $CPAN::Signal;
+ $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
+ if (system($system)==0) {
+ print " $system -- OK\n";
+ $self->{'make'} = "YES";
+ } else {
+ $self->{writemakefile} = "YES";
+ $self->{'make'} = "NO";
+ print " $system -- NOT OK\n";
}
- $self->rematein('install') if $doit;
}
-#-> sub CPAN::Module::clean ;
-sub clean { shift->rematein('clean') }
-#-> sub CPAN::Module::inst_file ;
-sub inst_file {
+#-> sub CPAN::Distribution::test ;
+sub test {
my($self) = @_;
- my($dir,@packpath);
- @packpath = split /::/, $self->{ID};
- $packpath[-1] .= ".pm";
- foreach $dir (@INC) {
- my $pmfile = CPAN->catfile($dir,@packpath);
- if (-f $pmfile){
- return $pmfile;
- }
+ $self->make;
+ return if $CPAN::Signal;
+ print "Running make test\n";
+ EXCUSE: {
+ my @e;
+ exists $self->{'make'} or push @e,
+ "Make had some problems, maybe interrupted? Won't test";
+
+ exists $self->{'make'} and
+ $self->{'make'} eq 'NO' and
+ push @e, "Oops, make had returned bad status";
+
+ exists $self->{'build_dir'} or push @e, "Has no own directory";
+ print join "", map {" $_\n"} @e and return if @e;
+ }
+ chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
+ $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
+ my $system = join " ", $CPAN::Config->{'make'}, "test";
+ if (system($system)==0) {
+ print " $system -- OK\n";
+ $self->{'make_test'} = "YES";
+ } else {
+ $self->{'make_test'} = "NO";
+ print " $system -- NOT OK\n";
}
}
-#-> sub CPAN::Module::xs_file ;
-sub xs_file {
+#-> sub CPAN::Distribution::clean ;
+sub clean {
my($self) = @_;
- my($dir,@packpath);
- @packpath = split /::/, $self->{ID};
- push @packpath, $packpath[-1];
- $packpath[-1] .= "." . $Config::Config{'dlext'};
- foreach $dir (@INC) {
- my $xsfile = CPAN->catfile($dir,'auto',@packpath);
- if (-f $xsfile){
- return $xsfile;
- }
+ print "Running make clean\n";
+ EXCUSE: {
+ my @e;
+ exists $self->{'build_dir'} or push @e, "Has no own directory";
+ print join "", map {" $_\n"} @e and return if @e;
+ }
+ chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
+ $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
+ my $system = join " ", $CPAN::Config->{'make'}, "clean";
+ if (system($system)==0) {
+ print " $system -- OK\n";
+ $self->force;
+ } else {
+ # Hmmm, what to do if make clean failed?
}
}
-#-> sub CPAN::Module::inst_version ;
-sub inst_version {
+#-> sub CPAN::Distribution::install ;
+sub install {
my($self) = @_;
- my $parsefile = $self->inst_file or return 0;
- local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
- my $have = MY->parse_version($parsefile);
- $have ||= 0;
- $have =~ s/\s+//g;
- $have ||= 0;
- $have;
-}
+ $self->test;
+ return if $CPAN::Signal;
+ print "Running make install\n";
+ EXCUSE: {
+ my @e;
+ exists $self->{'build_dir'} or push @e, "Has no own directory";
-package CPAN::CacheMgr;
-use vars qw($Du);
-@CPAN::CacheMgr::ISA = qw(CPAN::Debug CPAN::InfoObj);
-use File::Find;
+ exists $self->{'make'} or push @e,
+ "Make had some problems, maybe interrupted? Won't install";
-#-> sub CPAN::CacheMgr::as_string ;
-sub as_string {
- eval { require Data::Dumper };
- if ($@) {
- return shift->SUPER::as_string;
+ exists $self->{'make'} and
+ $self->{'make'} eq 'NO' and
+ push @e, "Oops, make had returned bad status";
+
+ exists $self->{'install'} and push @e,
+ $self->{'install'} eq "YES" ?
+ "Already done" : "Already tried without success";
+
+ print join "", map {" $_\n"} @e and return if @e;
+ }
+ chdir $self->{'build_dir'} or Carp::croak("Couldn't chdir to $self->{'build_dir'}");
+ $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
+ my $system = join " ", $CPAN::Config->{'make'}, "install", $CPAN::Config->{make_install_arg};
+ my($pipe) = FileHandle->new("$system 2>&1 |");
+ my($makeout) = "";
+ while (<$pipe>){
+ print;
+ $makeout .= $_;
+ }
+ $pipe->close;
+ if ($?==0) {
+ print " $system -- OK\n";
+ $self->{'install'} = "YES";
} else {
- return Data::Dumper::Dumper(shift);
+ $self->{'install'} = "NO";
+ print " $system -- NOT OK\n";
+ if ($makeout =~ /permission/s && $> > 0) {
+ print " You may have to su to root to install the package\n";
+ }
}
}
-#-> sub CPAN::CacheMgr::cachesize ;
-sub cachesize {
- shift->{DU};
+#-> sub CPAN::Distribution::dir ;
+sub dir {
+ shift->{'build_dir'};
}
-# sub check {
-# my($self,@dirs) = @_;
-# return unless -d $self->{ID};
-# my $dir;
-# @dirs = $self->dirs unless @dirs;
-# for $dir (@dirs) {
-# $self->disk_usage($dir);
-# }
-# }
+package CPAN::Bundle;
+@CPAN::Bundle::ISA = qw(CPAN::Module);
-#-> sub CPAN::CacheMgr::clean_cache ;
-sub clean_cache {
- my $self = shift;
- my $dir;
- while ($self->{DU} > $self->{'MAX'} and $dir = shift @{$self->{FIFO}}) {
- $self->force_clean_cache($dir);
+#-> sub CPAN::Bundle::as_string ;
+sub as_string {
+ my($self) = @_;
+ $self->contains;
+ $self->{INST_VERSION} = $self->inst_version;
+ return $self->SUPER::as_string;
+}
+
+#-> sub CPAN::Bundle::contains ;
+sub contains {
+ my($self) = @_;
+ my($parsefile) = $self->inst_file;
+ unless ($parsefile) {
+ # Try to get at it in the cpan directory
+ $self->debug("no parsefile") if $CPAN::DEBUG;
+ my $dist = $CPAN::META->instance('CPAN::Distribution',$self->{'CPAN_FILE'});
+ $self->debug($dist->as_string) if $CPAN::DEBUG;
+ $dist->get;
+ $self->debug($dist->as_string) if $CPAN::DEBUG;
+ my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
+ File::Path::mkpath($todir);
+ my($me,$from,$to);
+ ($me = $self->id) =~ s/.*://;
+ $from = $CPAN::META->catfile($dist->{'build_dir'},"$me.pm");
+ $to = $CPAN::META->catfile($todir,"$me.pm");
+ File::Copy::copy($from, $to) or Carp::confess("Couldn't copy $from to $to: $!");
+ $parsefile = $to;
}
- $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG;
+ my @result;
+ my $fh = new FileHandle;
+ local $/ = "\n";
+ open($fh,$parsefile) or die "Could not open '$parsefile': $!";
+ my $inpod = 0;
+ while (<$fh>) {
+ $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : /^=head1\s+CONTENTS/ ? 1 : $inpod;
+ next unless $inpod;
+ next if /^=/;
+ next if /^\s+$/;
+ chomp;
+ push @result, (split " ", $_, 2)[0];
+ }
+ close $fh;
+ delete $self->{STATUS};
+ $self->{CONTAINS} = [@result];
+ @result;
}
-#-> sub CPAN::CacheMgr::dir ;
-sub dir {
- shift->{ID};
+#-> sub CPAN::Bundle::inst_file ;
+sub inst_file {
+ my($self) = @_;
+ my($me,$inst_file);
+ ($me = $self->id) =~ s/.*://;
+ $inst_file = $CPAN::META->catfile($CPAN::Config->{'cpan_home'},"Bundle", "$me.pm");
+ return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
+ $inst_file = $self->SUPER::inst_file;
+ return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
+ return $self->{'INST_FILE'}; # even if undefined?
}
-#-> sub CPAN::CacheMgr::entries ;
-sub entries {
- my($self,$dir) = @_;
- $dir ||= $self->{ID};
- my($cwd) = Cwd::cwd();
- chdir $dir or Carp::croak("Can't chdir to $dir: $!");
- my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!");
- my(@entries);
- for ($dh->read) {
- next if $_ eq "." || $_ eq "..";
- if (-f $_) {
- push @entries, $CPAN::META->catfile($dir,$_);
- } elsif (-d _) {
- push @entries, $CPAN::META->catdir($dir,$_);
- } else {
- print STDERR "Warning: weird direntry in $dir: $_\n";
+#-> sub CPAN::Bundle::rematein ;
+sub rematein {
+ my($self,$meth) = @_;
+ $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
+ my($s);
+ for $s ($self->contains) {
+ my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
+ $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
+ if ($type eq 'CPAN::Distribution') {
+ warn qq{
+The Bundle }.$self->id.qq{ contains
+explicitly a file $s.
+};
+ sleep 3;
}
+ $CPAN::META->instance($type,$s)->$meth();
}
- chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
- sort {-M $b <=> -M $a} @entries;
}
-#-> sub CPAN::CacheMgr::disk_usage ;
-sub disk_usage {
- my($self,$dir) = @_;
- if (! defined $dir or $dir eq "") {
- $self->debug("Cannot determine disk usage for some reason") if $CPAN::DEBUG;
- return;
- }
- return if defined $self->{SIZE}{$dir};
- local($Du) = 0;
- find(
- sub {
- return if -l $_;
- $Du += -s;
- },
- $dir
- );
- $self->{SIZE}{$dir} = $Du/1024/1024;
- push @{$self->{FIFO}}, $dir;
- $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
- $self->{DU} += $Du/1024/1024;
- if ($self->{DU} > $self->{'MAX'} ) {
- printf "...Hold on a sec... CPAN's cleaning the cache: %.2f MB > %.2f MB\n",
- $self->{DU}, $self->{'MAX'};
- $self->clean_cache;
- } else {
- $self->debug("NOT have to clean the cache: $self->{DU} <= $self->{'MAX'}") if $CPAN::DEBUG;
- $self->debug($self->as_string) if $CPAN::DEBUG;
- }
- $self->{DU};
-}
+#-> sub CPAN::Bundle::force ;
+sub force { shift->rematein('force',@_); }
+#-> sub CPAN::Bundle::get ;
+sub get { shift->rematein('get',@_); }
+#-> sub CPAN::Bundle::make ;
+sub make { shift->rematein('make',@_); }
+#-> sub CPAN::Bundle::test ;
+sub test { shift->rematein('test',@_); }
+#-> sub CPAN::Bundle::install ;
+sub install { shift->rematein('install',@_); }
+#-> sub CPAN::Bundle::clean ;
+sub clean { shift->rematein('clean',@_); }
-#-> sub CPAN::CacheMgr::force_clean_cache ;
-sub force_clean_cache {
- my($self,$dir) = @_;
- $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") if $CPAN::DEBUG;
- File::Path::rmtree($dir);
- $self->{DU} -= $self->{SIZE}{$dir};
- delete $self->{SIZE}{$dir};
+#-> sub CPAN::Bundle::readme ;
+sub readme {
+ my($self) = @_;
+ my($file) = $self->cpan_file or print("No File found for bundle ", $self->id, "\n"), return;
+ $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
+ $CPAN::META->instance('CPAN::Distribution',$file)->readme;
}
-#-> sub CPAN::CacheMgr::new ;
-sub new {
- my $class = shift;
- my $self = { ID => $CPAN::Config->{'build_dir'}, MAX => $CPAN::Config->{'build_cache'}, DU => 0 };
- File::Path::mkpath($self->{ID});
- my $dh = DirHandle->new($self->{ID});
- bless $self, $class;
- $self->debug("dir [$self->{ID}]") if $CPAN::DEBUG;
- my $e;
- for $e ($self->entries) {
- next if $e eq ".." || $e eq ".";
- $self->debug("Have to check size $e") if $CPAN::DEBUG;
- $self->disk_usage($e);
- }
- $self;
-}
+package CPAN::Module;
+@CPAN::Module::ISA = qw(CPAN::InfoObj);
-package CPAN::Debug;
+#-> sub CPAN::Module::as_glimpse ;
+sub as_glimpse {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ push @m, sprintf "%-15s %-15s (%s)\n", $class, $self->{ID}, $self->cpan_file;
+ join "", @m;
+}
-#-> sub CPAN::Debug::debug ;
-sub debug {
- my($self,$arg) = @_;
- my($caller,$func,$line,@rest) = caller(1); # caller(0) eg Complete, caller(1) eg readline
- ($caller) = caller(0);
- $caller =~ s/.*:://;
-# print "caller[$caller]func[$func]line[$line]rest[@rest]\n";
-# print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]CPAN::DEBUG[$CPAN::DEBUG]\n";
- if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
- if (ref $arg) {
- eval { require Data::Dumper };
- if ($@) {
- print $arg->as_string;
- } else {
- print Data::Dumper::Dumper($arg);
- }
- } else {
- print "Debug($caller:$func,$line,@rest): $arg\n"
+#-> sub CPAN::Module::as_string ;
+sub as_string {
+ my($self) = @_;
+ my(@m);
+ CPAN->debug($self) if $CPAN::DEBUG;
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ local($^W) = 0;
+ push @m, $class, " id = $self->{ID}\n";
+ my $sprintf = " %-12s %s\n";
+ push @m, sprintf $sprintf, 'DESCRIPTION', $self->{description} if $self->{description};
+ my $sprintf2 = " %-12s %s (%s)\n";
+ my($userid);
+ if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
+ push @m, sprintf(
+ $sprintf2,
+ 'CPAN_USERID',
+ $userid,
+ $CPAN::META->instance(CPAN::Author,$userid)->fullname
+ )
+ }
+ push @m, sprintf $sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION} if $self->{CPAN_VERSION};
+ push @m, sprintf $sprintf, 'CPAN_FILE', $self->{CPAN_FILE} if $self->{CPAN_FILE};
+ my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
+ my(%statd,%stats,%statl,%stati);
+ @statd{qw,? i c a b R M S,} = qw,unknown idea pre-alpha alpha beta released mature standard,;
+ @stats{qw,? m d u n,} = qw,unknown mailing-list developer comp.lang.perl.* none,;
+ @statl{qw,? p c + o,} = qw,unknown perl C C++ other,;
+ @stati{qw,? f r O,} = qw,unknown functions references+ties object-oriented,;
+ $statd{' '} = 'unknown';
+ $stats{' '} = 'unknown';
+ $statl{' '} = 'unknown';
+ $stati{' '} = 'unknown';
+ push @m, sprintf(
+ $sprintf3,
+ 'DSLI_STATUS',
+ $self->{statd},
+ $self->{stats},
+ $self->{statl},
+ $self->{stati},
+ $statd{$self->{statd}},
+ $stats{$self->{stats}},
+ $statl{$self->{statl}},
+ $stati{$self->{stati}}
+ ) if $self->{statd};
+ my $local_file = $self->inst_file;
+ if ($local_file && ! exists $self->{MANPAGE}) {
+ my $fh = FileHandle->new($local_file) or Carp::croak("Couldn't open $local_file: $!");
+ my $inpod = 0;
+ my(@result);
+ local $/ = "\n";
+ while (<$fh>) {
+ $inpod = /^=(?!head1\s+NAME)/ ? 0 : /^=head1\s+NAME/ ? 1 : $inpod;
+ next unless $inpod;
+ next if /^=/;
+ next if /^\s+$/;
+ chomp;
+ push @result, $_;
}
+ close $fh;
+ $self->{MANPAGE} = join " ", @result;
}
+ push @m, sprintf $sprintf, 'MANPAGE', $self->{MANPAGE} if $self->{MANPAGE};
+ push @m, sprintf $sprintf, 'INST_FILE', $local_file || "(not installed)";
+ push @m, sprintf $sprintf, 'INST_VERSION', $self->inst_version if $local_file;
+ join "", @m, "\n";
}
-package CPAN::Config;
-import ExtUtils::MakeMaker 'neatvalue';
-use vars qw(%can);
-
-%can = (
- 'commit' => "Commit changes to disk",
- 'defaults' => "Reload defaults from disk",
-);
-
-#-> sub CPAN::Config::edit ;
-sub edit {
- my($class,@args) = @_;
- return unless @args;
- CPAN->debug("class[$class]args[".join(" | ",@args)."]");
- my($o,$str,$func,$args,$key_exists);
- $o = shift @args;
- if($can{$o}) {
- $class->$o(@args);
- return 1;
+#-> sub CPAN::Module::cpan_file ;
+sub cpan_file {
+ my $self = shift;
+ CPAN->debug($self->id) if $CPAN::DEBUG;
+ unless (defined $self->{'CPAN_FILE'}) {
+ CPAN::Index->reload;
+ }
+ if (defined $self->{'CPAN_FILE'}){
+ return $self->{'CPAN_FILE'};
+ } elsif (defined $self->{'userid'}) {
+ return "Contact Author ".$self->{'userid'}."=".$CPAN::META->instance(CPAN::Author,$self->{'userid'})->fullname
} else {
- if (ref($CPAN::Config->{$o}) eq ARRAY) {
- $func = shift @args;
- # Let's avoid eval, it's easier to comprehend without.
- if ($func eq "push") {
- push @{$CPAN::Config->{$o}}, @args;
- } elsif ($func eq "pop") {
- pop @{$CPAN::Config->{$o}};
- } elsif ($func eq "shift") {
- shift @{$CPAN::Config->{$o}};
- } elsif ($func eq "unshift") {
- unshift @{$CPAN::Config->{$o}}, @args;
- } elsif ($func eq "splice") {
- splice @{$CPAN::Config->{$o}}, @args;
- } else {
- $CPAN::Config->{$o} = [@args];
- }
- } else {
- $CPAN::Config->{$o} = $args[0] if defined $args[0];
- print " $o ";
- print defined $CPAN::Config->{$o} ? $CPAN::Config->{$o} : "UNDEFINED";
- }
+ return "N/A";
}
}
-#-> sub CPAN::Config::commit ;
-sub commit {
- my($self, $configpm) = @_;
- my $mode;
- # mkpath!?
-
- my($fh) = FileHandle->new;
- $configpm ||= cfile();
- if (-f $configpm) {
- $mode = (stat $configpm)[2];
- if ($mode && ! -w _) {
- print "$configpm is not writable\n" and return;
- }
- #chmod 0644, $configpm; #?
- }
-
- my $msg = <<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";
- open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
- print $fh qq[$msg\$CPAN::Config = \{\n];
- foreach (sort keys %$CPAN::Config) {
- print $fh " '$_' => ", ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}), ",\n";
- }
+*name = \&cpan_file;
- print $fh "};\n1;\n__END__\n";
- close $fh;
+#-> sub CPAN::Module::cpan_version ;
+sub cpan_version { shift->{'CPAN_VERSION'} }
- #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
- #chmod $mode, $configpm;
- $self->defaults;
- print "commit: wrote $configpm\n";
- 1;
+#-> sub CPAN::Module::force ;
+sub force {
+ my($self) = @_;
+ $self->{'force_update'}++;
}
-*default = \&defaults;
-#-> sub CPAN::Config::defaults ;
-sub defaults {
- my($self) = @_;
- $self->unload;
- $self->load;
- 1;
+#-> sub CPAN::Module::rematein ;
+sub rematein {
+ my($self,$meth) = @_;
+ $self->debug($self->id) if $CPAN::DEBUG;
+ my $cpan_file = $self->cpan_file;
+ return if $cpan_file eq "N/A";
+ return if $cpan_file =~ /^Contact Author/;
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->called_for($self->id);
+ $pack->force if exists $self->{'force_update'};
+ $pack->$meth();
+ delete $self->{'force_update'};
}
-my $dot_cpan;
-#-> sub CPAN::Config::load ;
-sub load {
+#-> sub CPAN::Module::readme ;
+sub readme { shift->rematein('readme') }
+#-> sub CPAN::Module::look ;
+sub look { shift->rematein('look') }
+#-> sub CPAN::Module::get ;
+sub get { shift->rematein('get',@_); }
+#-> sub CPAN::Module::make ;
+sub make { shift->rematein('make') }
+#-> sub CPAN::Module::test ;
+sub test { shift->rematein('test') }
+#-> sub CPAN::Module::install ;
+sub install {
my($self) = @_;
- eval {require CPAN::Config;}; # We eval, because of some MakeMaker problems
- unshift @INC, $CPAN::META->catdir($ENV{HOME},".cpan") unless $dot_cpan++;
- eval {require CPAN::MyConfig;}; # where you can override system wide settings
- unless ( $self->load_succeeded ) {
- require CPAN::FirstTime;
- my($configpm,$fh);
- if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
- $configpm = $INC{"CPAN/Config.pm"};
- } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
- $configpm = $INC{"CPAN/MyConfig.pm"};
- } else {
- my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
- my($configpmdir) = MY->catdir($path_to_cpan,"CPAN");
- my($configpmtest) = MY->catfile($configpmdir,"Config.pm");
- if (-d $configpmdir || File::Path::mkpath($configpmdir)) {
- if (-w $configpmtest or -w $configpmdir) {
- $configpm = $configpmtest;
- }
- }
- unless ($configpm) {
- $configpmdir = MY->catdir($ENV{HOME},".cpan","CPAN");
- File::Path::mkpath($configpmdir);
- $configpmtest = MY->catfile($configpmdir,"MyConfig.pm");
- if (-w $configpmtest or -w $configpmdir) {
- $configpm = $configpmtest;
- } else {
- warn "WARNING: CPAN.pm is unable to create a configuration file.\n";
- }
- }
- }
- warn "Calling CPAN::FirstTime::init($configpm)";
- CPAN::FirstTime::init($configpm);
+ my($doit) = 0;
+ my($latest) = $self->cpan_version;
+ $latest ||= 0;
+ my($inst_file) = $self->inst_file;
+ my($have) = 0;
+ if (defined $inst_file) {
+ $have = $self->inst_version;
+ }
+ if ($inst_file && $have >= $latest && not exists $self->{'force_update'}) {
+ print $self->id, " is up to date.\n";
+ } else {
+ $doit = 1;
}
+ $self->rematein('install') if $doit;
}
+#-> sub CPAN::Module::clean ;
+sub clean { shift->rematein('clean') }
-#-> sub CPAN::Config::load_succeeded ;
-sub load_succeeded {
- my($miss) = 0;
- for (qw(
- cpan_home keep_source_where build_dir build_cache index_expire
- gzip tar unzip make pager makepl_arg make_arg make_install_arg
- urllist inhibit_startup_message ftp_proxy http_proxy no_proxy
- )) {
- unless (defined $CPAN::Config->{$_}){
- $miss++;
- CPAN->debug("undefined configuration parameter $_") if $CPAN::DEBUG;
+#-> sub CPAN::Module::inst_file ;
+sub inst_file {
+ my($self) = @_;
+ my($dir,@packpath);
+ @packpath = split /::/, $self->{ID};
+ $packpath[-1] .= ".pm";
+ foreach $dir (@INC) {
+ my $pmfile = CPAN->catfile($dir,@packpath);
+ if (-f $pmfile){
+ return $pmfile;
}
}
- return !$miss;
-}
-
-#-> sub CPAN::Config::unload ;
-sub unload {
- delete $INC{'CPAN/MyConfig.pm'};
- delete $INC{'CPAN/Config.pm'};
-}
-
-#-> sub CPAN::Config::cfile ;
-sub cfile {
- $INC{'CPAN/MyConfig.pm'} || $INC{'CPAN/Config.pm'};
}
-*h = \&help;
-#-> sub CPAN::Config::help ;
-sub help {
- print <<EOF;
-Known options:
- defaults reload default config values from disk
- commit commit session changes to disk
-
-You may edit key values in the follow fashion:
-
- o conf build_cache 15
-
- o conf build_dir "/foo/bar"
-
- o conf urllist shift
-
- o conf urllist unshift ftp://ftp.foo.bar/
-
-EOF
- undef; #don't reprint CPAN::Config
+#-> sub CPAN::Module::xs_file ;
+sub xs_file {
+ my($self) = @_;
+ my($dir,@packpath);
+ @packpath = split /::/, $self->{ID};
+ push @packpath, $packpath[-1];
+ $packpath[-1] .= "." . $Config::Config{'dlext'};
+ foreach $dir (@INC) {
+ my $xsfile = CPAN->catfile($dir,'auto',@packpath);
+ if (-f $xsfile){
+ return $xsfile;
+ }
+ }
}
-#-> sub CPAN::Config::complete ;
-sub complete {
- my($word,$line,$pos) = @_;
- $word ||= "";
- my(@words) = split " ", $line;
- my(@o_conf) = (sort keys %CPAN::Config::can, sort keys %$CPAN::Config);
- return (@o_conf) unless @words>2;
- if($words[2] =~ /->(.*)/) {
- my $meth = $1;
- my(@methods) = qw(shift unshift push pop splice);
- return @methods unless $meth;
- return sort grep /^\Q$meth\E/, @methods;
- }
- return sort grep /^\Q$word\E/, @o_conf;
+#-> sub CPAN::Module::inst_version ;
+sub inst_version {
+ my($self) = @_;
+ my $parsefile = $self->inst_file or return 0;
+ local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
+ my $have = MM->parse_version($parsefile);
+ $have ||= 0;
+ $have =~ s/\s+//g;
+ $have ||= 0;
+ $have;
}
1;
Any C<make>, C<test>, and C<readme> are run unconditionally. A
- C<install E<lt>distribution_fileE<gt>>
+ install <distribution_file>
also is run unconditionally. But for
- C<install E<lt>moduleE<gt>>
+ install <module>
CPAN checks if an install is actually needed for it and prints
I<Foo up to date> in case the module doesnE<39>t need to be updated.
projects / p5sagit/p5-mst-13.2.git / commitdiff