# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN;
-$VERSION = '1.76_03';
+$VERSION = '1.76_60';
$VERSION = eval $VERSION;
-# $Id: CPAN.pm,v 1.412 2003/07/31 14:53:04 k Exp $
-
-# only used during development:
-$Revision = "";
-# $Revision = "[".substr(q$Revision: 1.412 $, 10)."]";
+use CPAN::Version;
use Carp ();
use Config ();
use Cwd ();
use Text::ParseWords ();
use Text::Wrap;
use File::Spec;
+use File::Temp ();
use Sys::Hostname;
no lib "."; # we need to run chdir all over and we would get at wrong
# libraries there
$CPAN::Frontend ||= "CPAN::Shell";
$CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
$CPAN::Perl ||= CPAN::find_perl();
+$CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
+$CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
package CPAN;
use strict qw(vars);
use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
- $Revision $Signal $End $Suppress_readline $Frontend
- $Defaultsite $Have_warned);
+ $Signal $End $Suppress_readline $Frontend
+ $Defaultsite $Have_warned $Defaultdocs $Defaultrecent
+ $Be_Silent );
@CPAN::ISA = qw(CPAN::Debug Exporter);
@EXPORT = qw(
- autobundle bundle expand force get cvs_import
+ autobundle bundle expand force notest get cvs_import
install make readme recompile shell test clean
+ perldoc recent
);
#-> sub CPAN::AUTOLOAD ;
if (exists $EXPORT{$l}){
CPAN::Shell->$l(@_);
} else {
- $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
+ $CPAN::Frontend->mywarn(qq{Unknown CPAN command "$AUTOLOAD". }.
qq{Type ? for help.
});
}
$CPAN::Frontend->myprint(
sprintf qq{
-cpan shell -- CPAN exploration and modules installation (v%s%s)
+cpan shell -- CPAN exploration and modules installation (v%s)
ReadLine support %s
},
$CPAN::VERSION,
- $CPAN::Revision,
$rl_avail
)
unless $CPAN::Config->{'inhibit_startup_message'} ;
use File::Find;
package CPAN::Config;
-use vars qw(%can $dot_cpan);
+use vars qw(%can %keys $dot_cpan);
%can = (
'commit' => "Commit changes to disk",
'init' => "Interactive setting of all options",
);
+%keys = map { $_ => undef } qw(
+ build_cache build_dir
+ cache_metadata cpan_home curl
+ dontload_hash
+ ftp ftp_proxy
+ getcwd gpg gzip
+ histfile histsize http_proxy
+ inactivity_timeout index_expire inhibit_startup_message
+ keep_source_where
+ lynx
+ make make_arg make_install_arg make_install_make_command makepl_arg
+ ncftp ncftpget no_proxy pager
+ prerequisites_policy
+ scan_cache shell show_upload_date
+ tar term_is_latin
+ unzip urllist
+ wait_list wget
+);
+
package CPAN::FTP;
use vars qw($Ua $Thesite $Themethod);
@CPAN::FTP::ISA = qw(CPAN::Debug);
@CPAN::Complete::COMMANDS = sort qw(
! a b d h i m o q r u autobundle clean dump
make test install force readme reload look
- cvs_import ls
+ cvs_import ls perldoc recent
) unless @CPAN::Complete::COMMANDS;
package CPAN::Index;
});
}
} else {
- $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
+ $CPAN::Frontend->mywarn(qq{Unknown shell command '$autoload'. }.
qq{Type ? for help.
});
}
});
sleep 2;
+ } elsif ($mod eq "Module::Signature"){
+ unless ($Have_warned->{"Module::Signature"}++) {
+ # No point in complaining unless the user can
+ # reasonably install and use it.
+ if (eval { require Crypt::OpenPGP; 1 } ||
+ defined $CPAN::Config->{'gpg'}) {
+ $CPAN::Frontend->myprint(qq{
+ CPAN: Module::Signature security checks disabled because Module::Signature
+ not installed. Please consider installing the Module::Signature module.
+ You may also need to be able to connect over the Internet to the public
+ keyservers like pgp.mit.edu (port 11371).
+
+});
+ sleep 2;
+ }
+ }
} else {
delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
}
return 1;
} else {
CPAN->debug("o[$o]") if $CPAN::DEBUG;
+ unless (exists $keys{$o}) {
+ $CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n");
+ }
if ($o =~ /list$/) {
$func = shift @args;
$func ||= "";
if (ref $v) {
my(@report) = ref $v eq "ARRAY" ?
@$v :
- map { sprintf(" %-18s => %s\n",
- $_,
+ map { sprintf(" %-18s => [%s]\n",
+ map { "[$_]" } $_,
defined $v->{$_} ? $v->{$_} : "UNDEFINED"
)} keys %$v;
$CPAN::Frontend->myprint(
" %-18s\n",
$k
),
- map {"\t$_\n"} @report
+ map {"\t[$_]\n"} @report
)
);
} elsif (defined $v) {
- $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
+ $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
} else {
- $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
+ $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, "UNDEFINED");
}
}
#_#_# following code dumped core on me with 5.003_11, a.k.
my $configpm_bak = "$configpmtest.bak";
unlink $configpm_bak if -f $configpm_bak;
- if( -f $configpmtest ) {
- if( rename $configpmtest, $configpm_bak ) {
- $CPAN::Frontend->mywarn(<<END)
+ if( -f $configpmtest ) {
+ if( rename $configpmtest, $configpm_bak ) {
+ $CPAN::Frontend->mywarn(<<END);
Old configuration file $configpmtest
moved to $configpm_bak
END
}
- }
+ }
my $fh = FileHandle->new;
if ($fh->open(">$configpmtest")) {
$fh->print("1;\n");
# Should never happen
Carp::confess("Cannot open >$configpmtest");
}
- } else { return }
+ } else { return }
}
#-> sub CPAN::Config::load ;
sub load {
- my($self) = shift;
+ my($self, %args) = [at]_;
+ $CPAN::Be_Silent++ if $args{be_silent};
+
my(@miss);
use Carp;
eval {require CPAN::Config;}; # We eval because of some
$configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
$configpm = _configpmtest($configpmdir,$configpmtest);
unless ($configpm) {
- Carp::confess(qq{WARNING: CPAN.pm is unable to }.
- qq{create a configuration file.});
+ my $text = qq{WARNING: CPAN.pm is unable to } .
+ qq{create a configuration file.};
+ output($text, 'confess');
}
}
}
$CPAN::Frontend->myprint(qq{
$configpm initialized.
});
+
sleep 2;
- CPAN::FirstTime::init($configpm);
+ CPAN::FirstTime::init($configpm, %args);
}
#-> sub CPAN::Config::missing_config_data ;
} elsif (@words >= 4) {
return ();
}
- my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
+ my %seen;
+ my(@o_conf) = sort grep { !$seen{$_}++ }
+ keys %CPAN::Config::can,
+ keys %$CPAN::Config,
+ keys %CPAN::Config::keys;
return grep /^\Q$word\E/, @o_conf;
}
i WORD or /REGEXP/ about any of the above
r NONE report updatable modules
ls AUTHOR about files in the author's directory
+ recent NONE latest CPAN uploads
Download, Test, Make, Install...
get download
clean make clean
look open subshell in these dists' directories
readme display these dists' README files
+ perldoc display module's POD documentation
Other
h,? display this menu ! perl-code eval a perl command
}
#-> sub CPAN::Shell::ls ;
-sub ls {
+sub ls {
my($self,@arg) = @_;
my @accept;
+ if ($arg[0] eq "*") {
+ @arg = map { $_->id } $self->expand('Author','/./');
+ }
for (@arg) {
- unless (/^[A-Z\-]+$/i) {
+ unless (/^[A-Z0-9\-]+$/i) {
$CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
next;
}
push @accept, uc $_;
}
+ my $silent = @accept>1;
+ my $last_alpha = "";
for my $a (@accept){
my $author = $self->expand('Author',$a) or die "No author found for $a";
- $author->ls;
+ $author->ls($silent); # silent if more than one author
+ if ($silent) {
+ my $alphadot = substr $author->id, 0, 1;
+ my $ad;
+ if ($alphadot eq $last_alpha) {
+ $ad = ".";
+ } else {
+ $ad = $alphadot;
+ $last_alpha = $alphadot;
+ }
+ $CPAN::Frontend->myprint($ad);
+ }
}
}
$CPAN::Frontend->myprint(":\n");
for $k (sort keys %CPAN::Config::can) {
$v = $CPAN::Config::can{$k};
- $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
+ $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
}
$CPAN::Frontend->myprint("\n");
for $k (sort keys %$CPAN::Config) {
if ($command =~ /cpan/i) {
for my $f (qw(CPAN.pm CPAN/FirstTime.pm)) {
next unless $INC{$f};
- CPAN->debug("reloading the whole $f") if $CPAN::DEBUG;
+ CPAN->debug("reloading the whole '$f' from '$INC{$f}' while pwd='$p
+wd'")
+ if $CPAN::DEBUG;
my $fh = FileHandle->new($INC{$f});
local($/);
my $redef = 0;
+ local $^W = 1;
local($SIG{__WARN__}) = paintdots_onreload(\$redef);
- eval <$fh>;
+ my $eval = <$fh>;
+ CPAN->debug("evaling '$eval'")
+ if $CPAN::DEBUG;
+ eval $eval;
warn $@ if $@;
$CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
}
# for metadata cache
$CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
}
- for $module (@expand) {
+ MODULE: for $module (@expand) {
my $file = $module->cpan_file;
- next unless defined $file; # ??
+ next MODULE unless defined $file; # ??
my($latest) = $module->cpan_version;
my($inst_file) = $module->inst_file;
my($have);
} elsif ($have == 0){
$version_zeroes++;
}
- next unless CPAN::Version->vgt($latest, $have);
+ next MODULE unless CPAN::Version->vgt($latest, $have);
# to be pedantic we should probably say:
# && !($have eq "undef" && $latest ne "undef" && $latest gt "");
# to catch the case where CPAN has a version 0 and we have a version undef
} elsif ($what eq "u") {
- next;
+ next MODULE;
}
} else {
if ($what eq "a") {
- next;
+ next MODULE;
} elsif ($what eq "r") {
- next;
+ next MODULE;
} elsif ($what eq "u") {
$have = "-";
}
push @result, sprintf "%s %s\n", $module->id, $have;
} elsif ($what eq "r") {
push @result, $module->id;
- next if $seen{$file}++;
+ next MODULE if $seen{$file}++;
} elsif ($what eq "u") {
push @result, $module->id;
- next if $seen{$file}++;
- next if $file =~ /^Contact/;
+ next MODULE if $seen{$file}++;
+ next MODULE if $file =~ /^Contact/;
}
unless ($headerdone++){
$CPAN::Frontend->myprint("\n");
$result;
}
+#-> sub CPAN::Shell::report_fh ;
+{
+ my $installation_report_fh;
+ my $previously_noticed = 0;
+
+ sub report_fh {
+ return $installation_report_fh if $installation_report_fh;
+ $installation_report_fh = File::Temp->new(
+ template => 'cpan_install_XXXX',
+ suffix => '.txt',
+ unlink => 0,
+ );
+ unless ( $installation_report_fh ) {
+ warn("Couldn't open installation report file; " .
+ "no report file will be generated."
+ ) unless $previously_noticed++;
+ }
+ }
+}
+
+
# The only reason for this method is currently to have a reliable
# debugging utility that reveals which output is going through which
# channel. No, I don't like the colors ;-)
my $longest = 0;
return unless defined $what;
+ local $| = 1; # Flush immediately
+ if ( $CPAN::Be_Silent ) {
+ print {report_fh()} $what;
+ return;
+ }
+
if ($CPAN::Config->{term_is_latin}){
# courtesy jhi:
$what
sub rematein {
shift;
my($meth,@some) = @_;
- my $pragma = "";
- if ($meth eq 'force') {
- $pragma = $meth;
+ my @pragma;
+ if ($meth =~ /^(force|notest)$/) {
+ push @pragma, $meth;
$meth = shift @some;
}
setup_output();
- CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
+ CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
# Here is the place to set "test_count" on all involved parties to
# 0. We then can pass this counter on to the involved
$obj->color_cmd_tmps(0,1);
CPAN::Queue->new($obj->id);
push @qcopy, $obj;
- } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
- $obj = $CPAN::META->instance('CPAN::Author',$s);
+ } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
+ $obj = $CPAN::META->instance('CPAN::Author',uc($s));
if ($meth =~ /^(dump|ls)$/) {
$obj->$meth();
} else {
} else {
$obj = CPAN::Shell->expandany($s);
}
- if ($pragma
- &&
- ($] < 5.00303 || $obj->can($pragma))){
- ### compatibility with 5.003
- $obj->$pragma($meth); # the pragma "force" in
- # "CPAN::Distribution" must know
- # what we are intending
+ for my $pragma (@pragma) {
+ if ($pragma
+ &&
+ ($] < 5.00303 || $obj->can($pragma))){
+ ### compatibility with 5.003
+ $obj->$pragma($meth); # the pragma "force" in
+ # "CPAN::Distribution" must know
+ # what we are intending
+ }
}
if ($]>=5.00303 && $obj->can('called_for')) {
$obj->called_for($s);
}
CPAN->debug(
- qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
+ qq{pragma[@pragma]meth[$meth]obj[$obj]as_string\[}.
$obj->as_string.
qq{\]}
) if $CPAN::DEBUG;
}
}
-#-> sub CPAN::Shell::dump ;
-sub dump { shift->rematein('dump',@_); }
-#-> sub CPAN::Shell::force ;
-sub force { shift->rematein('force',@_); }
-#-> sub CPAN::Shell::get ;
-sub get { shift->rematein('get',@_); }
-#-> sub CPAN::Shell::readme ;
-sub readme { shift->rematein('readme',@_); }
-#-> sub CPAN::Shell::make ;
-sub make { shift->rematein('make',@_); }
-#-> sub CPAN::Shell::test ;
-sub test { shift->rematein('test',@_); }
-#-> sub CPAN::Shell::install ;
-sub install { shift->rematein('install',@_); }
-#-> sub CPAN::Shell::clean ;
-sub clean { shift->rematein('clean',@_); }
-#-> sub CPAN::Shell::look ;
-sub look { shift->rematein('look',@_); }
-#-> sub CPAN::Shell::cvs_import ;
-sub cvs_import { shift->rematein('cvs_import',@_); }
+#-> sub CPAN::Shell::recent ;
+sub recent {
+ my($self) = [at]_;
+
+ CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
+ return;
+}
+
+{
+ # set up the dispatching methods
+ no strict "refs";
+ for my $command (qw(
+ clean cvs_import dump force get install look
+ make notest perldoc readme test
+ )) {
+ *$command = sub { shift->rematein($command, @_); };
+ }
+}
package CPAN::LWP::UserAgent;
# $USER and $PASSWD to give the get_basic_credentials routine another
# chance to set $USER and $PASSWD.
+# mirror(): Its purpose is to deal with proxy authentication. When we
+# call SUPER::mirror, we relly call the mirror method in
+# LWP::UserAgent. LWP::UserAgent will then call
+# $self->get_basic_credentials or some equivalent and this will be
+# $self->dispatched to our own get_basic_credentials method.
+
+# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
+
+# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
+# although we have gone through our get_basic_credentials, the proxy
+# server refuses to connect. This could be a case where the username or
+# password has changed in the meantime, so I'm trying once again without
+# $USER and $PASSWD to give the get_basic_credentials routine another
+# chance to set $USER and $PASSWD.
+
sub mirror {
my($self,$url,$aslocal) = @_;
my $result = $self->SUPER::mirror($url,$aslocal);
$asl_gz = "$asl_ungz.gz";
my($src_switch) = "";
+ my($chdir) = "";
+ my($stdout_redir) = " > $asl_ungz";
if ($f eq "lynx"){
$src_switch = " -source";
} elsif ($f eq "ncftp"){
$src_switch = " -c";
} elsif ($f eq "wget"){
- $src_switch = " -O -";
+ $src_switch = " -O $asl_ungz";
+ $stdout_redir = "";
} elsif ($f eq 'curl'){
$src_switch = ' -L';
}
- my($chdir) = "";
- my($stdout_redir) = " > $asl_ungz";
if ($f eq "ncftpget"){
$chdir = "cd $aslocal_dir && ";
$stdout_redir = "";
} elsif ($line =~ /^d\s/) {
@return = cplx('CPAN::Distribution',$word);
} elsif ($line =~ m/^(
- [mru]|make|clean|dump|get|test|install|readme|look|cvs_import
+ [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
)\s/x ) {
if ($word =~ /^Bundle::/) {
CPAN::Shell->local_bundles;
} elsif ($words[1] eq 'conf') {
return CPAN::Config::cpl(@_);
} elsif ($words[1] eq 'debug') {
- return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
+ return sort grep /^\Q$word\E/,
+ sort keys %CPAN::DEBUG, 'all';
}
}
#-> sub CPAN::Author::ls ;
sub ls {
my $self = shift;
+ my $silent = shift || 0;
my $id = $self->id;
# adapted from CPAN::Distribution::verifyMD5 ;
my(@csf); # chksumfile
@csf = $self->id =~ /(.)(.)(.*)/;
$csf[1] = join "", @csf[0,1];
- $csf[2] = join "", @csf[1,2];
+ $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
my(@dl);
- @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
+ @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
unless (grep {$_->[2] eq $csf[1]} @dl) {
- $CPAN::Frontend->myprint("No files in the directory of $id\n");
+ $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless
+$silent ;
return;
}
- @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
+ @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
unless (grep {$_->[2] eq $csf[2]} @dl) {
- $CPAN::Frontend->myprint("No files in the directory of $id\n");
+ $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $sil
+ent;
return;
}
- @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
+ @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
$CPAN::Frontend->myprint(join "", map {
sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
- } sort { $a->[2] cmp $b->[2] } @dl);
+ } sort { $a->[2] cmp $b->[2] } @dl) unless $silent;
}
# returns an array of arrays, the latter contain (size,mtime,filename)
my $self = shift;
my $chksumfile = shift;
my $recursive = shift;
+ my $may_ftp = shift;
my $lc_want =
File::Spec->catfile($CPAN::Config->{keep_source_where},
"authors", "id", @$chksumfile);
+
+ my $fh;
+
+ # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
+ # hazard. (Without GPG installed they are not that much better,
+ # though.)
+ $fh = FileHandle->new;
+ if (open($fh, $lc_want)) {
+ my $line = <$fh>; close $fh;
+ unlink($lc_want) unless $line =~ /PGP/;
+ }
local($") = "/";
# connect "force" argument with "index_expire".
my $force = 0;
if (my @stat = stat $lc_want) {
$force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
}
- my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
- $lc_want,$force);
- unless ($lc_file) {
- $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
- $chksumfile->[-1] .= ".gz";
- $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
- "$lc_want.gz",1);
- if ($lc_file) {
- $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
- CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
- } else {
- return;
- }
+ my $lc_file;
+ if ($may_ftp) {
+ $lc_file = CPAN::FTP->localize(
+ "authors/id/@$chksumfile",
+ $lc_want,
+ $force,
+ );
+ unless ($lc_file) {
+ $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
+ $chksumfile->[-1] .= ".gz";
+ $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
+ "$lc_want.gz",1);
+ if ($lc_file) {
+ $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
+ CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
+ } else {
+ return;
+ }
+ }
+ } else {
+ $lc_file = $lc_want;
+ # we *could* second-guess and if the user has a file: URL,
+ # then we could look there. But on the other hand, if they do
+ # have a file: URL, wy did they choose to set
+ # $CPAN::Config->{show_upload_date} to false?
}
# adapted from CPAN::Distribution::MD5_check_file ;
- my $fh = FileHandle->new;
+ $fh = FileHandle->new;
my($cksum);
if (open $fh, $lc_file){
local($/);
rename $lc_file, "$lc_file.bad";
Carp::confess($@) if $@;
}
+ } elsif ($may_ftp) {
+ Carp::carp "Could not open $lc_file for reading.";
} else {
- Carp::carp "Could not open $lc_file for reading";
+ # Maybe should warn: "You may want to set show_upload_date to a true value"
+ return;
}
my(@result,$f);
for $f (sort keys %$cksum) {
push @dir, $f, "CHECKSUMS";
push @result, map {
[$_->[0], $_->[1], "$f/$_->[2]"]
- } $self->dir_listing(\@dir,1);
+ } $self->dir_listing(\@dir,1,$may_ftp);
} else {
push @result, [ 0, "-", $f ];
}
sub as_string {
my $self = shift;
$self->containsmods;
+ $self->upload_date;
$self->SUPER::as_string(@_);
}
keys %{$self->{CONTAINSMODS}};
}
+#-> sub CPAN::Distribution::upload_date ;
+sub upload_date {
+ my $self = shift;
+ return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
+ my(@local_wanted) = split(/\//,$self->id);
+ my $filename = pop [at]local_wanted;
+ push [at]local_wanted, "CHECKSUMS";
+ my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
+ return unless $author;
+ my [at]dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
+ return unless [at]dl;
+ my($dirent) = grep { $_->[2] eq $filename } [at]dl;
+ # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
+ return unless $dirent->[1];
+ return $self->{UPLOAD_DATE} = $dirent->[1];
+}
+
#-> sub CPAN::Distribution::uptodate ;
sub uptodate {
my($self) = @_;
#
# Unpack the goods
#
+ $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
if ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
$self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
$self->untar_me($local_file);
} elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
$self->unzip_me($local_file);
- } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
+ } elsif ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/) {
$self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
+ $self->debug("calling pm2dir for local_file[$local_file]") if $CPAN::DEBUG;
$self->pm2dir_me($local_file);
} else {
$self->{archived} = "NO";
$self->safe_chdir($builddir);
File::Path::rmtree("tmp");
+ $self->safe_chdir($packagedir);
+ if ($CPAN::META->has_inst("Module::Signature")) {
+ if (-f "SIGNATURE") {
+ $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
+ my $rv = Module::Signature::verify();
+ if ($rv != Module::Signature::SIGNATURE_OK() and
+ $rv != Module::Signature::SIGNATURE_MISSING()) {
+ $CPAN::Frontend->myprint(
+ qq{\nSignature invalid for }.
+ qq{distribution file. }.
+ qq{Please investigate.\n\n}.
+ $self->as_string,
+ $CPAN::META->instance(
+ 'CPAN::Author',
+ $self->cpan_userid,
+ )->as_string
+ );
+
+ my $wrap = qq{I\'d recommend removing $self->{localfile}. Its signature
+is invalid. Maybe you have configured your 'urllist' with
+a bad URL. Please check this array with 'o conf urllist', and
+retry.};
+ $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
+ }
+ } else {
+ $CPAN::Frontend->myprint(qq{Package came without SIGNATURE\n\n});
+ }
+ } else {
+ $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
+ }
+ $self->safe_chdir($builddir);
+ return if $CPAN::Signal;
+
+
+
my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
my($mpl_exists) = -f $mpl;
unless ($mpl_exists) {
my($self,$local_file) = @_;
$self->{archived} = "pm";
my $to = File::Basename::basename($local_file);
- $to =~ s/\.(gz|Z)(?!\n)\Z//;
- if (CPAN::Tarzip->gunzip($local_file,$to)) {
- $self->{unwrapped} = "YES";
+ if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
+ if (CPAN::Tarzip->gunzip($local_file,$to)) {
+ $self->{unwrapped} = "YES";
+ } else {
+ $self->{unwrapped} = "NO";
+ }
} else {
- $self->{unwrapped} = "NO";
+ File::Copy::cp($local_file,".");
+ $self->{unwrapped} = "YES";
}
}
});
sleep 2;
$fh_pager->print(<$fh_readme>);
+ $fh_pager->close;
}
#-> sub CPAN::Distribution::verifyMD5 ;
$self->MD5_check_file($lc_file);
}
+sub SIG_check_file {
+ my($self,$chk_file) = @_;
+ my $rv = eval { Module::Signature::_verify($chk_file) };
+
+ if ($rv == Module::Signature::SIGNATURE_OK()) {
+ $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
+ return $self->{SIG_STATUS} = "OK";
+ } else {
+ $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
+ qq{distribution file. }.
+ qq{Please investigate.\n\n}.
+ $self->as_string,
+ $CPAN::META->instance(
+ 'CPAN::Author',
+ $self->cpan_userid
+ )->as_string);
+
+ my $wrap = qq{I\'d recommend removing $chk_file. Its signature
+is invalid. Maybe you have configured your 'urllist' with
+a bad URL. Please check this array with 'o conf urllist', and
+retry.};
+
+ $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
+ }
+}
+
#-> sub CPAN::Distribution::MD5_check_file ;
sub MD5_check_file {
my($self,$chk_file) = @_;
my($cksum,$file,$basename);
+
+ if ($CPAN::META->has_inst("Module::Signature") and Module::Signature->VERSION >= 0.26) {
+ $self->debug("Module::Signature is installed, verifying");
+ $self->SIG_check_file($chk_file);
+ } else {
+ $self->debug("Module::Signature is NOT installed");
+ }
+
$file = $self->{localfile};
$basename = File::Basename::basename($file);
my $fh = FileHandle->new;
}
}
+sub notest {
+ my($self, $method) = [at]_;
+ # warn "XDEBUG: set notest for $self $method";
+ $self->{"notest"}++; # name should probably have been force_install
+}
+
+sub unnotest {
+ my($self) = [at]_;
+ # warn "XDEBUG: deleting notest";
+ delete $self->{'notest'};
+}
+
#-> sub CPAN::Distribution::unforce ;
sub unforce {
my($self) = @_;
delete $self->{force_update};
return;
}
+ # warn "XDEBUG: checking for notest: $self->{notest} $self";
+ if ($self->{notest}) {
+ $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
+ return 1;
+ }
+
$CPAN::Frontend->myprint("Running make test\n");
if (my @prereq = $self->unsat_prereq){
return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
return;
}
- local $ENV{PERL5LIB} = $ENV{PERL5LIB} || "";
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+
$CPAN::META->set_perl5lib;
my $system = join " ", $CPAN::Config->{'make'}, "test";
if (system($system) == 0) {
return;
}
- my $system = join(" ", $CPAN::Config->{'make'},
- "install", $CPAN::Config->{make_install_arg});
+ my($make_install_make_command) = $CPAN::Config->{'make_install_make_command'} ||
+ $CPAN::Config->{'make'};
+
+ my($system) = join(" ",
+ $make_install_make_command,
+ "install",
+ $CPAN::Config->{make_install_arg},
+ );
my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
my($pipe) = FileHandle->new("$system $stderr |");
my($makeout) = "";
} else {
$self->{'install'} = "NO";
$CPAN::Frontend->myprint(" $system -- NOT OK\n");
- if ($makeout =~ /permission/s && $> > 0) {
- $CPAN::Frontend->myprint(qq{ You may have to su }.
- qq{to root to install the package\n});
+ if (
+ $makeout =~ /permission/s
+ && $> > 0
+ && (
+ ! $CPAN::Config->{make_install_make_command}
+ || $CPAN::Config->{make_install_make_command} eq $CPAN::Config->{make}
+ )
+ ) {
+ $CPAN::Frontend->myprint(
+ qq{----\n}.
+ qq{ You may have to su }.
+ qq{to root to install the package\n}.
+ qq{ (Or you may want to run something like\n}.
+ qq{ o conf make_install_make_command 'sudo make'\n}.
+ qq{ to raise your permissions.}
+ );
}
}
delete $self->{force_update};
shift->{'build_dir'};
}
+#-> sub CPAN::Distribution::perldoc ;
+sub perldoc {
+ my($self) = [at]_;
+
+ my($dist) = $self->id;
+ my $package = $self->called_for;
+
+ $self->_display_url( $CPAN::Defaultdocs . $package );
+}
+
+#-> sub CPAN::Distribution::_check_binary ;
+sub _check_binary {
+ my ($dist,$shell,$binary) = [at]_;
+ my ($pid,$readme,$out);
+
+ $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
+ if $CPAN::DEBUG;
+
+ $pid = open $readme, "-|", "which", $binary
+ or $CPAN::Frontend->mydie(qq{Could not fork $binary: $!});
+ while (<$readme>) {
+ $out .= $_;
+ }
+ close $readme;
+
+ $CPAN::Frontend->myprint(qq{ + $out \n})
+ if $CPAN::DEBUG && $out;
+
+ return $out;
+}
+
+#-> sub CPAN::Distribution::_display_url ;
+sub _display_url {
+ my($self,$url) = [at]_;
+ my($res,$saved_file,$pid,$readme,$out);
+
+ $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
+ if $CPAN::DEBUG;
+
+ # should we define it in the config instead?
+ my $html_converter = "html2text";
+
+ my $web_browser = $CPAN::Config->{'lynx'} || undef;
+ my $web_browser_out = $web_browser
+ ? CPAN::Distribution->_check_binary($self,$web_browser)
+ : undef;
+
+ my ($tmpout,$tmperr);
+ if (not $web_browser_out) {
+ # web browser not found, let's try text only
+ my $html_converter_out =
+ CPAN::Distribution->_check_binary($self,$html_converter);
+
+ if ($html_converter_out ) {
+ # html2text found, run it
+ $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
+ $CPAN::Frontend->myprint(qq{ERROR: problems while getting $url, $!\n})
+ unless defined($saved_file);
+
+ $pid = open $readme, "-|", $html_converter, $saved_file
+ or $CPAN::Frontend->mydie(qq{
+Could not fork $html_converter $saved_file: $!});
+ my $fh = File::Temp->new(
+ template => 'cpan_htmlconvert_XXXX',
+ suffix => '.txt',
+ unlink => 0,
+ );
+ while (<$readme>) {
+ $fh->print($_);
+ }
+ close $readme
+ or $CPAN::Frontend->mydie(qq{Could not close file handle: $!});
+ my $tmpin = $fh->filename;
+ $CPAN::Frontend->myprint(sprintf(qq{
+Run '%s %s' and
+saved output to %s\n},
+ $html_converter,
+ $saved_file,
+ $tmpin,
+ )) if $CPAN::DEBUG;
+ close $fh; undef $fh;
+ open $fh, $tmpin
+ or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
+ my $fh_pager = FileHandle->new;
+ local($SIG{PIPE}) = "IGNORE";
+ $fh_pager->open("|$CPAN::Config->{'pager'}")
+ or $CPAN::Frontend->mydie(qq{
+Could not open pager $CPAN::Config->{'pager'}: $!});
+ $CPAN::Frontend->myprint(qq{
+Displaying URL
+ $url
+with pager "$CPAN::Config->{'pager'}"
+});
+ sleep 2;
+ $fh_pager->print(<$fh>);
+ $fh_pager->close;
+ } else {
+ # coldn't find the web browser or html converter
+ $CPAN::Frontend->myprint(qq{
+You need to install lynx or $html_converter to use this feature.});
+ }
+ } else {
+ # web browser found, run the action
+ my $browser = $CPAN::Config->{'lynx'};
+ $CPAN::Frontend->myprint(qq{system[$browser $url]})
+ if $CPAN::DEBUG;
+ $CPAN::Frontend->myprint(qq{
+Displaying URL
+ $url
+with browser $browser
+});
+ sleep 2;
+ system("$browser $url");
+ if ($saved_file) { 1 while unlink($saved_file) }
+ }
+}
+
+#-> sub CPAN::Distribution::_getsave_url ;
+sub _getsave_url {
+ my($dist, $shell, $url) = [at]_;
+
+ $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
+ if $CPAN::DEBUG;
+
+ my $fh = File::Temp->new(
+ template => "cpan_getsave_url_XXXX",
+ suffix => ".html",
+ unlink => 0,
+ );
+ my $tmpin = $fh->filename;
+ if ($CPAN::META->has_usable('LWP')) {
+ $CPAN::Frontend->myprint("Fetching with LWP:
+ $url
+");
+ my $Ua;
+ CPAN::LWP::UserAgent->config;
+ eval { $Ua = CPAN::LWP::UserAgent->new; };
+ if ($@) {
+ $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
+ return;
+ } else {
+ my($var);
+ $Ua->proxy('http', $var)
+ if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
+ $Ua->no_proxy($var)
+ if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
+ }
+
+ my $req = HTTP::Request->new(GET => $url);
+ $req->header('Accept' => 'text/html');
+ my $res = $Ua->request($req);
+ if ($res->is_success) {
+ $CPAN::Frontend->myprint(" + request successful.\n")
+ if $CPAN::DEBUG;
+ print $fh $res->content;
+ close $fh;
+ $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
+ if $CPAN::DEBUG;
+ return $tmpin;
+ } else {
+ $CPAN::Frontend->myprint(sprintf(
+ "LWP failed with code[%s], message[%s]\n",
+ $res->code,
+ $res->message,
+ ));
+ return;
+ }
+ } else {
+ $CPAN::Frontend->myprint("LWP not available\n");
+ return;
+ }
+}
+
package CPAN::Bundle;
sub look {
#-> sub CPAN::Bundle::force ;
sub force { shift->rematein('force',@_); }
+#-> sub CPAN::Bundle::notest ;
+sub notest { shift->rematein('notest',@_); }
#-> sub CPAN::Bundle::get ;
sub get { shift->rematein('get',@_); }
#-> sub CPAN::Bundle::make ;
}
push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
if $self->cpan_version;
- push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
- if $self->cpan_file;
+ if (my $cpan_file = $self->cpan_file){
+ push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
+ if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
+ my $upload_date = $dist->upload_date;
+ if ($upload_date) {
+ push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
+ }
+ }
+ }
my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
my(%statd,%stats,%statl,%stati);
@statd{qw,? i c a b R M S,} = qw,unknown idea
$self->{'force_update'}++;
}
+sub notest {
+ my($self) = [at]_;
+ # warn "XDEBUG: set notest for Module";
+ $self->{'notest'}++;
+}
+
#-> sub CPAN::Module::rematein ;
sub rematein {
my($self,$meth) = @_;
my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
$pack->called_for($self->id);
$pack->force($meth) if exists $self->{'force_update'};
- $pack->$meth();
+ $pack->notest($meth) if exists $self->{'notest'};
+ eval {
+ $pack->$meth();
+ };
+ my $err = $@;
$pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
+ $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
delete $self->{'force_update'};
+ delete $self->{'notest'};
+ if ($err) {
+ die $err;
+ }
}
+#-> sub CPAN::Module::perldoc ;
+sub perldoc { shift->rematein('perldoc') }
#-> sub CPAN::Module::readme ;
-sub readme { shift->rematein('readme') }
+sub readme { shift->rematein('readme') }
#-> sub CPAN::Module::look ;
-sub look { shift->rematein('look') }
+sub look { shift->rematein('look') }
#-> sub CPAN::Module::cvs_import ;
sub cvs_import { shift->rematein('cvs_import') }
#-> sub CPAN::Module::get ;
-sub get { shift->rematein('get',@_); }
+sub get { shift->rematein('get',@_) }
#-> sub CPAN::Module::make ;
-sub make {
- my $self = shift;
- $self->rematein('make');
-}
+sub make { shift->rematein('make') }
#-> sub CPAN::Module::test ;
sub test {
my $self = shift;
my($buffer,$fhw);
$fhw = FileHandle->new($read)
or $CPAN::Frontend->mydie("Could not open $read: $!");
+ my $cwd = `pwd`;
my $gz = Compress::Zlib::gzopen($write, "wb")
- or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
+ or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
$gz->gzwrite($buffer)
while read($fhw,$buffer,4096) > 0 ;
$gz->gzclose() ;
}
}
-
-package CPAN::Version;
-# CPAN::Version::vcmp courtesy Jost Krieger
-sub vcmp {
- my($self,$l,$r) = @_;
- local($^W) = 0;
- CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
-
- return 0 if $l eq $r; # short circuit for quicker success
-
- if ($l=~/^v/ <=> $r=~/^v/) {
- for ($l,$r) {
- next if /^v/;
- $_ = $self->float2vv($_);
- }
- }
-
- return
- ($l ne "undef") <=> ($r ne "undef") ||
- ($] >= 5.006 &&
- $l =~ /^v/ &&
- $r =~ /^v/ &&
- $self->vstring($l) cmp $self->vstring($r)) ||
- $l <=> $r ||
- $l cmp $r;
-}
-
-sub vgt {
- my($self,$l,$r) = @_;
- $self->vcmp($l,$r) > 0;
-}
-
-sub vstring {
- my($self,$n) = @_;
- $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
- pack "U*", split /\./, $n;
-}
-
-# vv => visible vstring
-sub float2vv {
- my($self,$n) = @_;
- my($rev) = int($n);
- $rev ||= 0;
- my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
- # architecture influence
- $mantissa ||= 0;
- $mantissa .= "0" while length($mantissa)%3;
- my $ret = "v" . $rev;
- while ($mantissa) {
- $mantissa =~ s/(\d{1,3})// or
- die "Panic: length>0 but not a digit? mantissa[$mantissa]";
- $ret .= ".".int($1);
- }
- # warn "n[$n]ret[$ret]";
- $ret;
-}
-
-sub readable {
- my($self,$n) = @_;
- $n =~ /^([\w\-\+\.]+)/;
-
- return $1 if defined $1 && length($1)>0;
- # if the first user reaches version v43, he will be treated as "+".
- # We'll have to decide about a new rule here then, depending on what
- # will be the prevailing versioning behavior then.
-
- if ($] < 5.006) { # or whenever v-strings were introduced
- # we get them wrong anyway, whatever we do, because 5.005 will
- # have already interpreted 0.2.4 to be "0.24". So even if he
- # indexer sends us something like "v0.2.4" we compare wrongly.
-
- # And if they say v1.2, then the old perl takes it as "v12"
-
- $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
- return $n;
- }
- my $better = sprintf "v%vd", $n;
- CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
- return $better;
-}
-
package CPAN;
1;
CPAN also keeps track of what it has done within the current session
and doesn't try to build a package a second time regardless if it
-succeeded or not. The C<force> command takes as a first argument the
-method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
+succeeded or not. The C<force> pragma may precede another command
+(currently: C<make>, C<test>, or C<install>) and executes the
command from scratch.
Example:
OpenGL-0.4/COPYRIGHT
[...]
+The C<notest> pragma may be set to skip the test part in the build
+process.
+
+Example:
+
+ cpan> notest install Tk
+
A C<clean> command results in a
make clean
being executed within the distribution file's working directory.
-=item get, readme, look module or distribution
+=item get, readme, perldoc, look module or distribution
C<get> downloads a distribution file without further action. C<readme>
displays the README file of the associated distribution. C<Look> gets
and untars (if not yet done) the distribution file, changes to the
appropriate directory and opens a subshell process in that directory.
+C<perldoc> displays the pod documentation of the module in html or
+plain text format.
=item ls author
Downloads the README file associated with a distribution and runs it
through the pager specified in C<$CPAN::Config->{pager}>.
+=item CPAN::Distribution::perldoc()
+
+Downloads the pod documentation of the file associated with a
+distribution (in html format) and runs it through the external
+command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
+isn't available, it converts it to plain text with external
+command html2text and runs it through the pager specified
+in C<$CPAN::Config->{pager}>
+
=item CPAN::Distribution::test()
Changes to the directory where the distribution has been unpacked and
Runs a C<readme> on the distribution associated with this module.
+=item CPAN::Module::perldoc()
+
+Runs a C<perldoc> on this module.
+
=item CPAN::Module::test()
Runs a C<test> on the distribution associated with this module.
keep_source_where directory in which to keep the source (if we do)
make location of external make program
make_arg arguments that should always be passed to 'make'
+ make_install_make_command
+ the make command for running 'make install', for
+ example 'sudo make'
make_install_arg same as make_arg for 'make install'
makepl_arg arguments passed to 'perl Makefile.PL'
pager location of external program more (or any pager)
Your mileage may vary...
+=head1 Cryptographically signed modules
+
+Since release 1.77 CPAN.pm has been able to verify cryptographically
+signed module distributions using Module::Signature. The CPAN modules
+can be signed by their authors, thus giving more security. The simple
+unsigned MD5 checksums that were used before by CPAN protect mainly
+against accidental file corruption.
+
+You will need to have Module::Signature installed, which in turn
+requires that you have at least one of Crypt::OpenPGP module or the
+command-line F<gpg> tool installed.
+
+You will also need to be able to connect over the Internet to the public
+keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
+
=head1 FAQ
=over 4
I am not root, how can I install a module in a personal directory?
+First of all, you will want to use your own configuration, not the one
+that your root user installed. The following command sequence is a
+possible approach:
+
+ % mkdir -p $HOME/.cpan/CPAN
+ % echo '$CPAN::Config={ };' > $HOME/.cpan/CPAN/MyConfig.pm
+ % cpan
+ [...answer all questions...]
+
You will most probably like something like this:
o conf makepl_arg "LIB=~/myperl/lib \
INSTALLMAN1DIR=~/myperl/man/man1 \
INSTALLMAN3DIR=~/myperl/man/man3"
- install Sybase::Sybperl
You can make this setting permanent like all C<o conf> settings with
C<o conf commit>.
the queue of things to install in a topologically correct order. It
resolves perfectly well IFF all modules declare the prerequisites
correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
-fail and you need to install often, it is recommended sort the Bundle
+fail and you need to install often, it is recommended to sort the Bundle
definition file manually. It is planned to improve the metadata
situation for dependencies on CPAN in general, but this will still
take some time.
Extended support for converters will be made available as soon as perl
becomes stable with regard to charset issues.
+=item 11)
+
+When an install fails for some reason and then I correct the error
+condition and retry, CPAN.pm refuses to install the module, saying
+C<Already tried without success>.
+
+Use the force pragma like so
+
+ force install Foo::Bar
+
+This does a bit more than really needed because it untars the
+distribution again and runs make and test and only then install.
+
+Or you can use
+
+ look Foo::Bar
+
+and then 'make install' directly in the subshell.
+
+Or you leave the CPAN shell and start it again.
+
+For the really curious, by accessing internals directly, you I<could>
+
+ ! delete CPAN::Shell->expand("Distribution", \
+ CPAN::Shell->expand("Module","Foo::Bar") \
+ ->{RO}{CPAN_FILE})->{install}
+
+but this is neither guaranteed to work in the future nor is it a
+decent command.
+
=back
=head1 BUGS
use File::Path ();
use File::Spec;
use vars qw($VERSION);
-$VERSION = substr q$Revision: 1.60_01 $, 10;
+our $VERSION = sprintf "%.3f", 2 + substr(q$Rev: 147 $,4)/1000;
=head1 NAME
=cut
-
sub init {
- my($configpm) = @_;
+ my($configpm, %args) = @_;
+
use Config;
+
unless ($CPAN::VERSION) {
require CPAN::Nox;
}
];
- my $manual_conf = prompt("Are you ready for manual configuration?", "yes");
+ my $manual_conf;
+
+ local *_real_prompt = \&ExtUtils::MakeMaker::prompt;
+ if ( $args{autoconfig} ) {
+ $manual_conf = "no";
+ } else {
+ $manual_conf = prompt("Are you ready for manual configuration?", "yes");
+ }
my $fastread;
{
if ($manual_conf =~ /^y/i) {
*_real_prompt = sub ($;$) {
my($q,$a) = @_;
my($ret) = defined $a ? $a : "";
- printf qq{%s [%s]\n\n}, $q, $ret;
-
+ $CPAN::Frontend->myprint(sprintf qq{%s [%s]\n\n}, $q, $ret);
+ eval { require Time::HiRes };
+ unless ($@) {
+ Time::HiRes::sleep(0.1);
+ }
$ret;
};
}
}
- print qq{
+ $CPAN::Frontend->myprint(qq{
The following questions are intended to help you with the
configuration. The CPAN module needs a directory of its own to cache
important index files and maybe keep a temporary mirror of CPAN files.
This may be a site-wide directory or a personal directory.
-};
+});
my $cpan_home = $CPAN::Config->{cpan_home} || File::Spec->catdir($ENV{HOME}, ".cpan");
if (-d $cpan_home) {
- print qq{
+ $CPAN::Frontend->myprint(qq{
I see you already have a directory
$cpan_home
Shall we use it as the general CPAN build and cache directory?
-};
+});
} else {
- print qq{
+ $CPAN::Frontend->myprint(qq{
First of all, I\'d like to create this directory. Where?
-};
+});
}
$default = $cpan_home;
}
$CPAN::Config->{cpan_home} = $ans;
- print qq{
+ $CPAN::Frontend->myprint( qq{
-If you want, I can keep the source files after a build in the cpan
-home directory. If you choose so then future builds will take the
-files from there. If you don\'t want to keep them, answer 0 to the
-next question.
+If you like, I can cache the source files after I build them. Doing
+so means that, if you ever rebuild that module in the future, the
+files will be taken from the cache. The tradeoff is that it takes up
+space. How much space would you like to allocate to this cache? (If
+you don\'t want me to keep a cache, answer 0.)
-};
+});
$CPAN::Config->{keep_source_where} = File::Spec->catdir($CPAN::Config->{cpan_home},"sources");
$CPAN::Config->{build_dir} = File::Spec->catdir($CPAN::Config->{cpan_home},"build");
# Cache size, Index expire
#
- print qq{
+ $CPAN::Frontend->myprint( qq{
How big should the disk cache be for keeping the build directories
with all the intermediate files\?
-};
+});
- $default = $CPAN::Config->{build_cache} || 10;
+ $default = $CPAN::Config->{build_cache} || 100; # large enough to
+ # build large
+ # dists like Tk
$ans = prompt("Cache size for build directory (in MB)?", $default);
$CPAN::Config->{build_cache} = $ans;
# XXX This the time when we refetch the index files (in days)
$CPAN::Config->{'index_expire'} = 1;
- print qq{
+ $CPAN::Frontend->myprint( qq{
-By default, each time the CPAN module is started, cache scanning
-is performed to keep the cache size in sync. To prevent from this,
-disable the cache scanning with 'never'.
+By default, each time the CPAN module is started, cache scanning is
+performed to keep the cache size in sync. To prevent this, answer
+'never'.
-};
+});
$default = $CPAN::Config->{scan_cache} || 'atstart';
do {
#
# cache_metadata
#
- print qq{
+ $CPAN::Frontend->myprint( qq{
To considerably speed up the initial CPAN shell startup, it is
possible to use Storable to create a cache of metadata. If Storable
is not available, the normal index mechanism will be used.
-};
+});
defined($default = $CPAN::Config->{cache_metadata}) or $default = 1;
do {
#
# term_is_latin
#
- print qq{
+ $CPAN::Frontend->myprint( qq{
-The next option deals with the charset your terminal supports. In
-general CPAN is English speaking territory, thus the charset does not
-matter much, but some of the aliens out there who upload their
-software to CPAN bear names that are outside the ASCII range. If your
-terminal supports UTF-8, you say no to the next question, if it
-supports ISO-8859-1 (also known as LATIN1) then you say yes, and if it
-supports neither nor, your answer does not matter, you will not be
-able to read the names of some authors anyway. If you answer no, names
-will be output in UTF-8.
+The next option deals with the charset (aka character set) your
+terminal supports. In general, CPAN is English speaking territory, so
+the charset does not matter much, but some of the aliens out there who
+upload their software to CPAN bear names that are outside the ASCII
+range. If your terminal supports UTF-8, you should say no to the next
+question. If it supports ISO-8859-1 (also known as LATIN1) then you
+should say yes. If it supports neither, your answer does not matter
+because you will not be able to read the names of some authors
+anyway. If you answer no, names will be output in UTF-8.
-};
+});
defined($default = $CPAN::Config->{term_is_latin}) or $default = 1;
do {
#
# save history in file histfile
#
- print qq{
+ $CPAN::Frontend->myprint( qq{
If you have one of the readline packages (Term::ReadLine::Perl,
Term::ReadLine::Gnu, possibly others) installed, the interactive CPAN
filename of the history file and with its size. If you do not want to
set this variable, please hit SPACE RETURN to the following question.
-};
+});
defined($default = $CPAN::Config->{histfile}) or
$default = File::Spec->catfile($CPAN::Config->{cpan_home},"histfile");
}
#
+ # do an ls on the m or the d command
+ #
+ $CPAN::Frontend->myprint( qq{
+
+The 'd' and the 'm' command normally only show you information they
+have in their in-memory database and thus will never connect to the
+internet. If you set the 'show_upload_date' variable to true, 'm' and
+'d' will additionally show you the upload date of the module or
+distribution. Per default this feature is off because it may require a
+net connection to get at the upload date.
+
+});
+
+ defined($default = $CPAN::Config->{show_upload_date}) or
+ $default = 0;
+ $ans = prompt("Always try to show upload date with 'd' and 'm' command?", $default);
+ $CPAN::Config->{show_upload_date} = $ans;
+
+ #
# prerequisites_policy
# Do we follow PREREQ_PM?
#
- print qq{
+ $CPAN::Frontend->myprint( qq{
-The CPAN module can detect when a module that which you are trying to
-build depends on prerequisites. If this happens, it can build the
+The CPAN module can detect when a module which you are trying to build
+depends on prerequisites. If this happens, it can build the
prerequisites for you automatically ('follow'), ask you for
confirmation ('ask'), or just ignore them ('ignore'). Please set your
policy to one of the three values.
-};
+});
$default = $CPAN::Config->{prerequisites_policy} || 'ask';
do {
# External programs
#
- print qq{
+ $CPAN::Frontend->myprint(qq{
The CPAN module will need a few external programs to work properly.
Please correct me, if I guess the wrong path for a program. Don\'t
disable the use of a download program, you can type a space followed
by ENTER.
-};
+});
my $old_warn = $^W;
local $^W if $^O eq 'MacOS';
my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'};
local $^W = $old_warn;
my $progname;
- for $progname (qw/gzip tar unzip make
- curl lynx wget ncftpget ncftp ftp
+ for $progname (qw/gzip tar unzip make
+ curl lynx wget ncftpget ncftp ftp
gpg/)
{
if ($^O eq 'MacOS') {
}
$path ||= find_exe($progcall,[@path]);
- warn "Warning: $progcall not found in PATH\n" unless
+ $CPAN::Frontend->mywarn("Warning: $progcall not found in PATH\n") unless
$path; # not -e $path, because find_exe already checked that
$ans = prompt("Where is your $progname program?",$path) || $path;
$CPAN::Config->{$progname} = $ans;
# Arguments to make etc.
#
- print qq{
+ $CPAN::Frontend->myprint( qq{
Every Makefile.PL is run by perl in a separate process. Likewise we
-run \'make\' and \'make install\' in processes. If you have any
-parameters \(e.g. PREFIX, LIB, UNINST or the like\) you want to pass
-to the calls, please specify them here.
+run \'make\' and \'make install\' in separate processes. If you have
+any parameters \(e.g. PREFIX, LIB, UNINST or the like\) you want to
+pass to the calls, please specify them here.
If you don\'t understand this question, just press ENTER.
-};
+});
$default = $CPAN::Config->{makepl_arg} || "";
$CPAN::Config->{makepl_arg} =
Your choice: ",$default);
+ $default = $CPAN::Config->{make_install_make_command} || $CPAN::Config->{make} || "";
+ $CPAN::Config->{make_install_make_command} =
+ prompt("Do you want to use a different make command for 'make install'?
+Cautious people will probably prefer:
+
+ sudo make
+or
+ /path1/to/sudo -u admin_account /path2/to/make
+
+or some such. Your choice: ",$default);
+
$default = $CPAN::Config->{make_install_arg} || $CPAN::Config->{make_arg} || "";
$CPAN::Config->{make_install_arg} =
prompt("Parameters for the 'make install' command?
# Alarm period
#
- print qq{
+ $CPAN::Frontend->myprint( qq{
Sometimes you may wish to leave the processes run by CPAN alone
-without caring about them. As sometimes the Makefile.PL contains
+without caring about them. Because the Makefile.PL sometimes contains
question you\'re expected to answer, you can set a timer that will
kill a 'perl Makefile.PL' process after the specified time in seconds.
If you set this value to 0, these processes will wait forever. This is
the default and recommended setting.
-};
+});
$default = $CPAN::Config->{inactivity_timeout} || 0;
$CPAN::Config->{inactivity_timeout} =
# Proxies
- print qq{
+ $CPAN::Frontend->myprint( qq{
If you\'re accessing the net via proxies, you can specify them in the
CPAN configuration or via environment variables. The variable in
the \$CPAN::Config takes precedence.
-};
+});
for (qw/ftp_proxy http_proxy no_proxy/) {
$default = $CPAN::Config->{$_} || $ENV{$_};
if ($CPAN::Config->{ftp_proxy} ||
$CPAN::Config->{http_proxy}) {
$default = $CPAN::Config->{proxy_user} || $CPAN::LWP::UserAgent::USER;
- print qq{
+ $CPAN::Frontend->myprint( qq{
If your proxy is an authenticating proxy, you can store your username
permanently. If you do not want that, just press RETURN. You will then
be asked for your username in every future session.
-};
+});
if ($CPAN::Config->{proxy_user} = prompt("Your proxy user id?",$default)) {
- print qq{
+ $CPAN::Frontend->myprint( qq{
Your password for the authenticating proxy can also be stored
permanently on disk. If this violates your security policy, just press
RETURN. You will then be asked for the password in every future
session.
-};
+});
if ($CPAN::META->has_inst("Term::ReadKey")) {
Term::ReadKey::ReadMode("noecho");
} else {
- print qq{
+ $CPAN::Frontend->myprint( qq{
Warning: Term::ReadKey seems not to be available, your password will
be echoed to the terminal!
-};
+});
}
$CPAN::Config->{proxy_pass} = prompt_no_strip("Your proxy password?");
if ($CPAN::META->has_inst("Term::ReadKey")) {
$CPAN::Config->{'inhibit_startup_message'} = 0;
$CPAN::Config->{'getcwd'} = 'cwd';
- print "\n\n";
+ $CPAN::Frontend->myprint("\n\n");
CPAN::Config->commit($configpm);
}
}
-*_real_prompt = \*ExtUtils::MakeMaker::prompt;
-
-
1;
projects / p5sagit/p5-mst-13.2.git / commitdiff