perl5.git.perl.org Git - perl5.git/blame_incremental

... / ...

Commit	Line	Data
	1	# -- Mode: cperl; coding: utf-8; cperl-indent-level: 4 --
	2	package CPAN;
	3	$VERSION = '1.59_56';
	4	# $Id: CPAN.pm,v 1.385 2001/02/09 21:37:57 k Exp $
	5
	6	# only used during development:
	7	$Revision = "";
	8	# $Revision = "[".substr(q$Revision: 1.385 $, 10)."]";
	9
	10	use Carp ();
	11	use Config ();
	12	use Cwd ();
	13	use DirHandle;
	14	use Exporter ();
	15	use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
	16	use File::Basename ();
	17	use File::Copy ();
	18	use File::Find;
	19	use File::Path ();
	20	use FileHandle ();
	21	use Safe ();
	22	use Text::ParseWords ();
	23	use Text::Wrap;
	24	use File::Spec;
	25	no lib "."; # we need to run chdir all over and we would get at wrong
	26	# libraries there
	27
	28	require Mac::BuildTools if $^O eq 'MacOS';
	29
	30	END { $End++; &cleanup; }
	31
	32	%CPAN::DEBUG = qw[
	33	CPAN 1
	34	Index 2
	35	InfoObj 4
	36	Author 8
	37	Distribution 16
	38	Bundle 32
	39	Module 64
	40	CacheMgr 128
	41	Complete 256
	42	FTP 512
	43	Shell 1024
	44	Eval 2048
	45	Config 4096
	46	Tarzip 8192
	47	Version 16384
	48	Queue 32768
	49	];
	50
	51	$CPAN::DEBUG \|\|= 0;
	52	$CPAN::Signal \|\|= 0;
	53	$CPAN::Frontend \|\|= "CPAN::Shell";
	54	$CPAN::Defaultsite \|\|= "ftp://ftp.perl.org/pub/CPAN";
	55
	56	package CPAN;
	57	use strict qw(vars);
	58
	59	use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term
	60	$Revision $Signal $End $Suppress_readline $Frontend
	61	$Defaultsite $Have_warned);
	62
	63	@CPAN::ISA = qw(CPAN::Debug Exporter);
	64
	65	@EXPORT = qw(
	66	autobundle bundle expand force get cvs_import
	67	install make readme recompile shell test clean
	68	);
	69
	70	#-> sub CPAN::AUTOLOAD ;
	71	sub AUTOLOAD {
	72	my($l) = $AUTOLOAD;
	73	$l =~ s/.*:://;
	74	my(%EXPORT);
	75	@EXPORT{@EXPORT} = '';
	76	CPAN::Config->load unless $CPAN::Config_loaded++;
	77	if (exists $EXPORT{$l}){
	78	CPAN::Shell->$l(@_);
	79	} else {
	80	$CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
	81	qq{Type ? for help.
	82	});
	83	}
	84	}
	85
	86	#-> sub CPAN::shell ;
	87	sub shell {
	88	my($self) = @_;
	89	$Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
	90	CPAN::Config->load unless $CPAN::Config_loaded++;
	91
	92	my $oprompt = shift \|\| "cpan> ";
	93	my $prompt = $oprompt;
	94	my $commandline = shift \|\| "";
	95
	96	local($^W) = 1;
	97	unless ($Suppress_readline) {
	98	require Term::ReadLine;
	99	if (! $term
	100	or
	101	$term->ReadLine eq "Term::ReadLine::Stub"
	102	) {
	103	$term = Term::ReadLine->new('CPAN Monitor');
	104	}
	105	if ($term->ReadLine eq "Term::ReadLine::Gnu") {
	106	my $attribs = $term->Attribs;
	107	$attribs->{attempted_completion_function} = sub {
	108	&CPAN::Complete::gnu_cpl;
	109	}
	110	} else {
	111	$readline::rl_completion_function =
	112	$readline::rl_completion_function = 'CPAN::Complete::cpl';
	113	}
	114	# $term->OUT is autoflushed anyway
	115	my $odef = select STDERR;
	116	$\| = 1;
	117	select STDOUT;
	118	$\| = 1;
	119	select $odef;
	120	}
	121
	122	# no strict; # I do not recall why no strict was here (2000-09-03)
	123	$META->checklock();
	124	my $cwd = CPAN::anycwd();
	125	my $try_detect_readline;
	126	$try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
	127	my $rl_avail = $Suppress_readline ? "suppressed" :
	128	($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
	129	"available (try 'install Bundle::CPAN')";
	130
	131	$CPAN::Frontend->myprint(
	132	sprintf qq{
	133	cpan shell -- CPAN exploration and modules installation (v%s%s)
	134	ReadLine support %s
	135
	136	},
	137	$CPAN::VERSION,
	138	$CPAN::Revision,
	139	$rl_avail
	140	)
	141	unless $CPAN::Config->{'inhibit_startup_message'} ;
	142	my($continuation) = "";
	143	SHELLCOMMAND: while () {
	144	if ($Suppress_readline) {
	145	print $prompt;
	146	last SHELLCOMMAND unless defined ($_ = <> );
	147	chomp;
	148	} else {
	149	last SHELLCOMMAND unless
	150	defined ($_ = $term->readline($prompt, $commandline));
	151	}
	152	$_ = "$continuation$_" if $continuation;
	153	s/^\s+//;
	154	next SHELLCOMMAND if /^$/;
	155	$_ = 'h' if /^\s*\?/;
	156	if (/^(?:q(?:uit)?\|bye\|exit)$/i) {
	157	last SHELLCOMMAND;
	158	} elsif (s/\\$//s) {
	159	chomp;
	160	$continuation = $_;
	161	$prompt = " > ";
	162	} elsif (/^\!/) {
	163	s/^\!//;
	164	my($eval) = $_;
	165	package CPAN::Eval;
	166	use vars qw($import_done);
	167	CPAN->import(':DEFAULT') unless $import_done++;
	168	CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
	169	eval($eval);
	170	warn $@ if $@;
	171	$continuation = "";
	172	$prompt = $oprompt;
	173	} elsif (/./) {
	174	my(@line);
	175	if ($] < 5.00322) { # parsewords had a bug until recently
	176	@line = split;
	177	} else {
	178	eval { @line = Text::ParseWords::shellwords($_) };
	179	warn($@), next SHELLCOMMAND if $@;
	180	warn("Text::Parsewords could not parse the line [$_]"),
	181	next SHELLCOMMAND unless @line;
	182	}
	183	$CPAN::META->debug("line[".join("\|",@line)."]") if $CPAN::DEBUG;
	184	my $command = shift @line;
	185	eval { CPAN::Shell->$command(@line) };
	186	warn $@ if $@;
	187	chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
	188	$CPAN::Frontend->myprint("\n");
	189	$continuation = "";
	190	$prompt = $oprompt;
	191	}
	192	} continue {
	193	$commandline = ""; # I do want to be able to pass a default to
	194	# shell, but on the second command I see no
	195	# use in that
	196	$Signal=0;
	197	CPAN::Queue->nullify_queue;
	198	if ($try_detect_readline) {
	199	if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
	200	\|\|
	201	$CPAN::META->has_inst("Term::ReadLine::Perl")
	202	) {
	203	delete $INC{"Term/ReadLine.pm"};
	204	my $redef = 0;
	205	local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
	206	require Term::ReadLine;
	207	$CPAN::Frontend->myprint("\n$redef subroutines in ".
	208	"Term::ReadLine redefined\n");
	209	@_ = ($oprompt,"");
	210	goto &shell;
	211	}
	212	}
	213	}
	214	chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
	215	}
	216
	217	package CPAN::CacheMgr;
	218	@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
	219	use File::Find;
	220
	221	package CPAN::Config;
	222	use vars qw(%can $dot_cpan);
	223
	224	%can = (
	225	'commit' => "Commit changes to disk",
	226	'defaults' => "Reload defaults from disk",
	227	'init' => "Interactive setting of all options",
	228	);
	229
	230	package CPAN::FTP;
	231	use vars qw($Ua $Thesite $Themethod);
	232	@CPAN::FTP::ISA = qw(CPAN::Debug);
	233
	234	package CPAN::LWP::UserAgent;
	235	use vars qw(@ISA $USER $PASSWD $SETUPDONE);
	236	# we delay requiring LWP::UserAgent and setting up inheritence until we need it
	237
	238	package CPAN::Complete;
	239	@CPAN::Complete::ISA = qw(CPAN::Debug);
	240	@CPAN::Complete::COMMANDS = sort qw(
	241	! a b d h i m o q r u autobundle clean dump
	242	make test install force readme reload look
	243	cvs_import ls
	244	) unless @CPAN::Complete::COMMANDS;
	245
	246	package CPAN::Index;
	247	use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
	248	@CPAN::Index::ISA = qw(CPAN::Debug);
	249	$LAST_TIME \|\|= 0;
	250	$DATE_OF_03 \|\|= 0;
	251	# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
	252	sub PROTOCOL { 2.0 }
	253
	254	package CPAN::InfoObj;
	255	@CPAN::InfoObj::ISA = qw(CPAN::Debug);
	256
	257	package CPAN::Author;
	258	@CPAN::Author::ISA = qw(CPAN::InfoObj);
	259
	260	package CPAN::Distribution;
	261	@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
	262
	263	package CPAN::Bundle;
	264	@CPAN::Bundle::ISA = qw(CPAN::Module);
	265
	266	package CPAN::Module;
	267	@CPAN::Module::ISA = qw(CPAN::InfoObj);
	268
	269	package CPAN::Shell;
	270	use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
	271	@CPAN::Shell::ISA = qw(CPAN::Debug);
	272	$COLOR_REGISTERED \|\|= 0;
	273	$PRINT_ORNAMENTING \|\|= 0;
	274
	275	#-> sub CPAN::Shell::AUTOLOAD ;
	276	sub AUTOLOAD {
	277	my($autoload) = $AUTOLOAD;
	278	my $class = shift(@_);
	279	# warn "autoload[$autoload] class[$class]";
	280	$autoload =~ s/.*:://;
	281	if ($autoload =~ /^w/) {
	282	if ($CPAN::META->has_inst('CPAN::WAIT')) {
	283	CPAN::WAIT->$autoload(@_);
	284	} else {
	285	$CPAN::Frontend->mywarn(qq{
	286	Commands starting with "w" require CPAN::WAIT to be installed.
	287	Please consider installing CPAN::WAIT to use the fulltext index.
	288	For this you just need to type
	289	install CPAN::WAIT
	290	});
	291	}
	292	} else {
	293	$CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
	294	qq{Type ? for help.
	295	});
	296	}
	297	}
	298
	299	package CPAN::Tarzip;
	300	use vars qw($AUTOLOAD @ISA $BUGHUNTING);
	301	@CPAN::Tarzip::ISA = qw(CPAN::Debug);
	302	$BUGHUNTING = 0; # released code must have turned off
	303
	304	package CPAN::Queue;
	305
	306	# One use of the queue is to determine if we should or shouldn't
	307	# announce the availability of a new CPAN module
	308
	309	# Now we try to use it for dependency tracking. For that to happen
	310	# we need to draw a dependency tree and do the leaves first. This can
	311	# easily be reached by running CPAN.pm recursively, but we don't want
	312	# to waste memory and run into deep recursion. So what we can do is
	313	# this:
	314
	315	# CPAN::Queue is the package where the queue is maintained. Dependencies
	316	# often have high priority and must be brought to the head of the queue,
	317	# possibly by jumping the queue if they are already there. My first code
	318	# attempt tried to be extremely correct. Whenever a module needed
	319	# immediate treatment, I either unshifted it to the front of the queue,
	320	# or, if it was already in the queue, I spliced and let it bypass the
	321	# others. This became a too correct model that made it impossible to put
	322	# an item more than once into the queue. Why would you need that? Well,
	323	# you need temporary duplicates as the manager of the queue is a loop
	324	# that
	325	#
	326	# (1) looks at the first item in the queue without shifting it off
	327	#
	328	# (2) cares for the item
	329	#
	330	# (3) removes the item from the queue, *even if its agenda failed and
	331	# even if the item isn't the first in the queue anymore* (that way
	332	# protecting against never ending queues)
	333	#
	334	# So if an item has prerequisites, the installation fails now, but we
	335	# want to retry later. That's easy if we have it twice in the queue.
	336	#
	337	# I also expect insane dependency situations where an item gets more
	338	# than two lives in the queue. Simplest example is triggered by 'install
	339	# Foo Foo Foo'. People make this kind of mistakes and I don't want to
	340	# get in the way. I wanted the queue manager to be a dumb servant, not
	341	# one that knows everything.
	342	#
	343	# Who would I tell in this model that the user wants to be asked before
	344	# processing? I can't attach that information to the module object,
	345	# because not modules are installed but distributions. So I'd have to
	346	# tell the distribution object that it should ask the user before
	347	# processing. Where would the question be triggered then? Most probably
	348	# in CPAN::Distribution::rematein.
	349	# Hope that makes sense, my head is a bit off:-) -- AK
	350
	351	use vars qw{ @All };
	352
	353	# CPAN::Queue::new ;
	354	sub new {
	355	my($class,$s) = @_;
	356	my $self = bless { qmod => $s }, $class;
	357	push @All, $self;
	358	return $self;
	359	}
	360
	361	# CPAN::Queue::first ;
	362	sub first {
	363	my $obj = $All[0];
	364	$obj->{qmod};
	365	}
	366
	367	# CPAN::Queue::delete_first ;
	368	sub delete_first {
	369	my($class,$what) = @_;
	370	my $i;
	371	for my $i (0..$#All) {
	372	if ( $All[$i]->{qmod} eq $what ) {
	373	splice @All, $i, 1;
	374	return;
	375	}
	376	}
	377	}
	378
	379	# CPAN::Queue::jumpqueue ;
	380	sub jumpqueue {
	381	my $class = shift;
	382	my @what = @_;
	383	CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
	384	join(",",map {$_->{qmod}} @All),
	385	join(",",@what)
	386	)) if $CPAN::DEBUG;
	387	WHAT: for my $what (reverse @what) {
	388	my $jumped = 0;
	389	for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
	390	CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG;
	391	if ($All[$i]->{qmod} eq $what){
	392	$jumped++;
	393	if ($jumped > 100) { # one's OK if e.g. just
	394	# processing now; more are OK if
	395	# user typed it several times
	396	$CPAN::Frontend->mywarn(
	397	qq{Object [$what] queued more than 100 times, ignoring}
	398	);
	399	next WHAT;
	400	}
	401	}
	402	}
	403	my $obj = bless { qmod => $what }, $class;
	404	unshift @All, $obj;
	405	}
	406	CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]",
	407	join(",",map {$_->{qmod}} @All),
	408	join(",",@what)
	409	)) if $CPAN::DEBUG;
	410	}
	411
	412	# CPAN::Queue::exists ;
	413	sub exists {
	414	my($self,$what) = @_;
	415	my @all = map { $_->{qmod} } @All;
	416	my $exists = grep { $_->{qmod} eq $what } @All;
	417	# warn "in exists what[$what] all[@all] exists[$exists]";
	418	$exists;
	419	}
	420
	421	# CPAN::Queue::delete ;
	422	sub delete {
	423	my($self,$mod) = @_;
	424	@All = grep { $_->{qmod} ne $mod } @All;
	425	}
	426
	427	# CPAN::Queue::nullify_queue ;
	428	sub nullify_queue {
	429	@All = ();
	430	}
	431
	432
	433
	434	package CPAN;
	435
	436	$META \|\|= CPAN->new; # In case we re-eval ourselves we need the \|\|
	437
	438	# from here on only subs.
	439	################################################################################
	440
	441	#-> sub CPAN::all_objects ;
	442	sub all_objects {
	443	my($mgr,$class) = @_;
	444	CPAN::Config->load unless $CPAN::Config_loaded++;
	445	CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
	446	CPAN::Index->reload;
	447	values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
	448	}
	449	*all = \&all_objects;
	450
	451	# Called by shell, not in batch mode. In batch mode I see no risk in
	452	# having many processes updating something as installations are
	453	# continually checked at runtime. In shell mode I suspect it is
	454	# unintentional to open more than one shell at a time
	455
	456	#-> sub CPAN::checklock ;
	457	sub checklock {
	458	my($self) = @_;
	459	my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
	460	if (-f $lockfile && -M _ > 0) {
	461	my $fh = FileHandle->new($lockfile) or
	462	$CPAN::Frontend->mydie("Could not open $lockfile: $!");
	463	my $other = <$fh>;
	464	$fh->close;
	465	if (defined $other && $other) {
	466	chomp $other;
	467	return if $$==$other; # should never happen
	468	$CPAN::Frontend->mywarn(
	469	qq{
	470	There seems to be running another CPAN process ($other). Contacting...
	471	});
	472	if (kill 0, $other) {
	473	$CPAN::Frontend->mydie(qq{Other job is running.
	474	You may want to kill it and delete the lockfile, maybe. On UNIX try:
	475	kill $other
	476	rm $lockfile
	477	});
	478	} elsif (-w $lockfile) {
	479	my($ans) =
	480	ExtUtils::MakeMaker::prompt
	481	(qq{Other job not responding. Shall I overwrite }.
	482	qq{the lockfile? (Y/N)},"y");
	483	$CPAN::Frontend->myexit("Ok, bye\n")
	484	unless $ans =~ /^y/i;
	485	} else {
	486	Carp::croak(
	487	qq{Lockfile $lockfile not writeable by you. }.
	488	qq{Cannot proceed.\n}.
	489	qq{ On UNIX try:\n}.
	490	qq{ rm $lockfile\n}.
	491	qq{ and then rerun us.\n}
	492	);
	493	}
	494	} else {
	495	$CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile ".
	496	"reports other process with ID ".
	497	"$other. Cannot proceed.\n"));
	498	}
	499	}
	500	my $dotcpan = $CPAN::Config->{cpan_home};
	501	eval { File::Path::mkpath($dotcpan);};
	502	if ($@) {
	503	# A special case at least for Jarkko.
	504	my $firsterror = $@;
	505	my $seconderror;
	506	my $symlinkcpan;
	507	if (-l $dotcpan) {
	508	$symlinkcpan = readlink $dotcpan;
	509	die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
	510	eval { File::Path::mkpath($symlinkcpan); };
	511	if ($@) {
	512	$seconderror = $@;
	513	} else {
	514	$CPAN::Frontend->mywarn(qq{
	515	Working directory $symlinkcpan created.
	516	});
	517	}
	518	}
	519	unless (-d $dotcpan) {
	520	my $diemess = qq{
	521	Your configuration suggests "$dotcpan" as your
	522	CPAN.pm working directory. I could not create this directory due
	523	to this error: $firsterror\n};
	524	$diemess .= qq{
	525	As "$dotcpan" is a symlink to "$symlinkcpan",
	526	I tried to create that, but I failed with this error: $seconderror
	527	} if $seconderror;
	528	$diemess .= qq{
	529	Please make sure the directory exists and is writable.
	530	};
	531	$CPAN::Frontend->mydie($diemess);
	532	}
	533	}
	534	my $fh;
	535	unless ($fh = FileHandle->new(">$lockfile")) {
	536	if ($! =~ /Permission/) {
	537	my $incc = $INC{'CPAN/Config.pm'};
	538	my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
	539	$CPAN::Frontend->myprint(qq{
	540
	541	Your configuration suggests that CPAN.pm should use a working
	542	directory of
	543	$CPAN::Config->{cpan_home}
	544	Unfortunately we could not create the lock file
	545	$lockfile
	546	due to permission problems.
	547
	548	Please make sure that the configuration variable
	549	\$CPAN::Config->{cpan_home}
	550	points to a directory where you can write a .lock file. You can set
	551	this variable in either
	552	$incc
	553	or
	554	$myincc
	555
	556	});
	557	}
	558	$CPAN::Frontend->mydie("Could not open >$lockfile: $!");
	559	}
	560	$fh->print($$, "\n");
	561	$self->{LOCK} = $lockfile;
	562	$fh->close;
	563	$SIG{TERM} = sub {
	564	&cleanup;
	565	$CPAN::Frontend->mydie("Got SIGTERM, leaving");
	566	};
	567	$SIG{INT} = sub {
	568	# no blocks!!!
	569	&cleanup if $Signal;
	570	$CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
	571	print "Caught SIGINT\n";
	572	$Signal++;
	573	};
	574
	575	# From: Larry Wall <larry@wall.org>
	576	# Subject: Re: deprecating SIGDIE
	577	# To: perl5-porters@perl.org
	578	# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
	579	#
	580	# The original intent of __DIE__ was only to allow you to substitute one
	581	# kind of death for another on an application-wide basis without respect
	582	# to whether you were in an eval or not. As a global backstop, it should
	583	# not be used any more lightly (or any more heavily :-) than class
	584	# UNIVERSAL. Any attempt to build a general exception model on it should
	585	# be politely squashed. Any bug that causes every eval {} to have to be
	586	# modified should be not so politely squashed.
	587	#
	588	# Those are my current opinions. It is also my optinion that polite
	589	# arguments degenerate to personal arguments far too frequently, and that
	590	# when they do, it's because both people wanted it to, or at least didn't
	591	# sufficiently want it not to.
	592	#
	593	# Larry
	594
	595	# global backstop to cleanup if we should really die
	596	$SIG{__DIE__} = \&cleanup;
	597	$self->debug("Signal handler set.") if $CPAN::DEBUG;
	598	}
	599
	600	#-> sub CPAN::DESTROY ;
	601	sub DESTROY {
	602	&cleanup; # need an eval?
	603	}
	604
	605	#-> sub CPAN::anycwd ;
	606	sub anycwd () {
	607	my $getcwd;
	608	$getcwd = $CPAN::Config->{'getcwd'} \|\| 'cwd';
	609	CPAN->$getcwd();
	610	}
	611
	612	#-> sub CPAN::cwd ;
	613	sub cwd {Cwd::cwd();}
	614
	615	#-> sub CPAN::getcwd ;
	616	sub getcwd {Cwd::getcwd();}
	617
	618	#-> sub CPAN::exists ;
	619	sub exists {
	620	my($mgr,$class,$id) = @_;
	621	CPAN::Config->load unless $CPAN::Config_loaded++;
	622	CPAN::Index->reload;
	623	### Carp::croak "exists called without class argument" unless $class;
	624	$id \|\|= "";
	625	exists $META->{readonly}{$class}{$id} or
	626	exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
	627	}
	628
	629	#-> sub CPAN::delete ;
	630	sub delete {
	631	my($mgr,$class,$id) = @_;
	632	delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
	633	delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
	634	}
	635
	636	#-> sub CPAN::has_usable
	637	# has_inst is sometimes too optimistic, we should replace it with this
	638	# has_usable whenever a case is given
	639	sub has_usable {
	640	my($self,$mod,$message) = @_;
	641	return 1 if $HAS_USABLE->{$mod};
	642	my $has_inst = $self->has_inst($mod,$message);
	643	return unless $has_inst;
	644	my $usable;
	645	$usable = {
	646	LWP => [ # we frequently had "Can't locate object
	647	# method "new" via package "LWP::UserAgent" at
	648	# (eval 69) line 2006
	649	sub {require LWP},
	650	sub {require LWP::UserAgent},
	651	sub {require HTTP::Request},
	652	sub {require URI::URL},
	653	],
	654	Net::FTP => [
	655	sub {require Net::FTP},
	656	sub {require Net::Config},
	657	]
	658	};
	659	if ($usable->{$mod}) {
	660	for my $c (0..$#{$usable->{$mod}}) {
	661	my $code = $usable->{$mod}[$c];
	662	my $ret = eval { &$code() };
	663	if ($@) {
	664	warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
	665	return;
	666	}
	667	}
	668	}
	669	return $HAS_USABLE->{$mod} = 1;
	670	}
	671
	672	#-> sub CPAN::has_inst
	673	sub has_inst {
	674	my($self,$mod,$message) = @_;
	675	Carp::croak("CPAN->has_inst() called without an argument")
	676	unless defined $mod;
	677	if (defined $message && $message eq "no"
	678	\|\|
	679	exists $CPAN::META->{dontload_hash}{$mod} # unsafe meta access, ok
	680	\|\|
	681	exists $CPAN::Config->{dontload_hash}{$mod}
	682	) {
	683	$CPAN::META->{dontload_hash}{$mod}\|\|=1; # unsafe meta access, ok
	684	return 0;
	685	}
	686	my $file = $mod;
	687	my $obj;
	688	$file =~ s\|::\|/\|g;
	689	$file =~ s\|/\|\\\|g if $^O eq 'MSWin32';
	690	$file .= ".pm";
	691	if ($INC{$file}) {
	692	# checking %INC is wrong, because $INC{LWP} may be true
	693	# although $INC{"URI/URL.pm"} may have failed. But as
	694	# I really want to say "bla loaded OK", I have to somehow
	695	# cache results.
	696	### warn "$file in %INC"; #debug
	697	return 1;
	698	} elsif (eval { require $file }) {
	699	# eval is good: if we haven't yet read the database it's
	700	# perfect and if we have installed the module in the meantime,
	701	# it tries again. The second require is only a NOOP returning
	702	# 1 if we had success, otherwise it's retrying
	703
	704	$CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
	705	if ($mod eq "CPAN::WAIT") {
	706	push @CPAN::Shell::ISA, CPAN::WAIT;
	707	}
	708	return 1;
	709	} elsif ($mod eq "Net::FTP") {
	710	$CPAN::Frontend->mywarn(qq{
	711	Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
	712	if you just type
	713	install Bundle::libnet
	714
	715	}) unless $Have_warned->{"Net::FTP"}++;
	716	sleep 3;
	717	} elsif ($mod eq "Digest::MD5"){
	718	$CPAN::Frontend->myprint(qq{
	719	CPAN: MD5 security checks disabled because Digest::MD5 not installed.
	720	Please consider installing the Digest::MD5 module.
	721
	722	});
	723	sleep 2;
	724	} else {
	725	delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
	726	}
	727	return 0;
	728	}
	729
	730	#-> sub CPAN::instance ;
	731	sub instance {
	732	my($mgr,$class,$id) = @_;
	733	CPAN::Index->reload;
	734	$id \|\|= "";
	735	# unsafe meta access, ok?
	736	return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
	737	$META->{readwrite}{$class}{$id} \|\|= $class->new(ID => $id);
	738	}
	739
	740	#-> sub CPAN::new ;
	741	sub new {
	742	bless {}, shift;
	743	}
	744
	745	#-> sub CPAN::cleanup ;
	746	sub cleanup {
	747	# warn "cleanup called with arg[@_] End[$End] Signal[$Signal]";
	748	local $SIG{__DIE__} = '';
	749	my($message) = @_;
	750	my $i = 0;
	751	my $ineval = 0;
	752	if (
	753	0 && # disabled, try reload cpan with it
	754	$] > 5.004_60 # thereabouts
	755	) {
	756	$ineval = $^S;
	757	} else {
	758	my($subroutine);
	759	while ((undef,undef,undef,$subroutine) = caller(++$i)) {
	760	$ineval = 1, last if
	761	$subroutine eq '(eval)';
	762	}
	763	}
	764	return if $ineval && !$End;
	765	return unless defined $META->{LOCK}; # unsafe meta access, ok
	766	return unless -f $META->{LOCK}; # unsafe meta access, ok
	767	unlink $META->{LOCK}; # unsafe meta access, ok
	768	# require Carp;
	769	# Carp::cluck("DEBUGGING");
	770	$CPAN::Frontend->mywarn("Lockfile removed.\n");
	771	}
	772
	773	package CPAN::CacheMgr;
	774
	775	#-> sub CPAN::CacheMgr::as_string ;
	776	sub as_string {
	777	eval { require Data::Dumper };
	778	if ($@) {
	779	return shift->SUPER::as_string;
	780	} else {
	781	return Data::Dumper::Dumper(shift);
	782	}
	783	}
	784
	785	#-> sub CPAN::CacheMgr::cachesize ;
	786	sub cachesize {
	787	shift->{DU};
	788	}
	789
	790	#-> sub CPAN::CacheMgr::tidyup ;
	791	sub tidyup {
	792	my($self) = @_;
	793	return unless -d $self->{ID};
	794	while ($self->{DU} > $self->{'MAX'} ) {
	795	my($toremove) = shift @{$self->{FIFO}};
	796	$CPAN::Frontend->myprint(sprintf(
	797	"Deleting from cache".
	798	": $toremove (%.1f>%.1f MB)\n",
	799	$self->{DU}, $self->{'MAX'})
	800	);
	801	return if $CPAN::Signal;
	802	$self->force_clean_cache($toremove);
	803	return if $CPAN::Signal;
	804	}
	805	}
	806
	807	#-> sub CPAN::CacheMgr::dir ;
	808	sub dir {
	809	shift->{ID};
	810	}
	811
	812	#-> sub CPAN::CacheMgr::entries ;
	813	sub entries {
	814	my($self,$dir) = @_;
	815	return unless defined $dir;
	816	$self->debug("reading dir[$dir]") if $CPAN::DEBUG;
	817	$dir \|\|= $self->{ID};
	818	my($cwd) = CPAN::anycwd();
	819	chdir $dir or Carp::croak("Can't chdir to $dir: $!");
	820	my $dh = DirHandle->new(File::Spec->curdir)
	821	or Carp::croak("Couldn't opendir $dir: $!");
	822	my(@entries);
	823	for ($dh->read) {
	824	next if $_ eq "." \|\| $_ eq "..";
	825	if (-f $_) {
	826	push @entries, MM->catfile($dir,$_);
	827	} elsif (-d _) {
	828	push @entries, MM->catdir($dir,$_);
	829	} else {
	830	$CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
	831	}
	832	}
	833	chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
	834	sort { -M $b <=> -M $a} @entries;
	835	}
	836
	837	#-> sub CPAN::CacheMgr::disk_usage ;
	838	sub disk_usage {
	839	my($self,$dir) = @_;
	840	return if exists $self->{SIZE}{$dir};
	841	return if $CPAN::Signal;
	842	my($Du) = 0;
	843	find(
	844	sub {
	845	$File::Find::prune++ if $CPAN::Signal;
	846	return if -l $_;
	847	if ($^O eq 'MacOS') {
	848	require Mac::Files;
	849	my $cat = Mac::Files::FSpGetCatInfo($_);
	850	$Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
	851	} else {
	852	$Du += (-s _);
	853	}
	854	},
	855	$dir
	856	);
	857	return if $CPAN::Signal;
	858	$self->{SIZE}{$dir} = $Du/1024/1024;
	859	push @{$self->{FIFO}}, $dir;
	860	$self->debug("measured $dir is $Du") if $CPAN::DEBUG;
	861	$self->{DU} += $Du/1024/1024;
	862	$self->{DU};
	863	}
	864
	865	#-> sub CPAN::CacheMgr::force_clean_cache ;
	866	sub force_clean_cache {
	867	my($self,$dir) = @_;
	868	return unless -e $dir;
	869	$self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
	870	if $CPAN::DEBUG;
	871	File::Path::rmtree($dir);
	872	$self->{DU} -= $self->{SIZE}{$dir};
	873	delete $self->{SIZE}{$dir};
	874	}
	875
	876	#-> sub CPAN::CacheMgr::new ;
	877	sub new {
	878	my $class = shift;
	879	my $time = time;
	880	my($debug,$t2);
	881	$debug = "";
	882	my $self = {
	883	ID => $CPAN::Config->{'build_dir'},
	884	MAX => $CPAN::Config->{'build_cache'},
	885	SCAN => $CPAN::Config->{'scan_cache'} \|\| 'atstart',
	886	DU => 0
	887	};
	888	File::Path::mkpath($self->{ID});
	889	my $dh = DirHandle->new($self->{ID});
	890	bless $self, $class;
	891	$self->scan_cache;
	892	$t2 = time;
	893	$debug .= "timing of CacheMgr->new: ".($t2 - $time);
	894	$time = $t2;
	895	CPAN->debug($debug) if $CPAN::DEBUG;
	896	$self;
	897	}
	898
	899	#-> sub CPAN::CacheMgr::scan_cache ;
	900	sub scan_cache {
	901	my $self = shift;
	902	return if $self->{SCAN} eq 'never';
	903	$CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
	904	unless $self->{SCAN} eq 'atstart';
	905	$CPAN::Frontend->myprint(
	906	sprintf("Scanning cache %s for sizes\n",
	907	$self->{ID}));
	908	my $e;
	909	for $e ($self->entries($self->{ID})) {
	910	next if $e eq ".." \|\| $e eq ".";
	911	$self->disk_usage($e);
	912	return if $CPAN::Signal;
	913	}
	914	$self->tidyup;
	915	}
	916
	917	package CPAN::Debug;
	918
	919	#-> sub CPAN::Debug::debug ;
	920	sub debug {
	921	my($self,$arg) = @_;
	922	my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
	923	# Complete, caller(1)
	924	# eg readline
	925	($caller) = caller(0);
	926	$caller =~ s/.*:://;
	927	$arg = "" unless defined $arg;
	928	my $rest = join "\|", map { defined $_ ? $_ : "UNDEF" } @rest;
	929	if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
	930	if ($arg and ref $arg) {
	931	eval { require Data::Dumper };
	932	if ($@) {
	933	$CPAN::Frontend->myprint($arg->as_string);
	934	} else {
	935	$CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
	936	}
	937	} else {
	938	$CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
	939	}
	940	}
	941	}
	942
	943	package CPAN::Config;
	944
	945	#-> sub CPAN::Config::edit ;
	946	# returns true on successful action
	947	sub edit {
	948	my($self,@args) = @_;
	949	return unless @args;
	950	CPAN->debug("self[$self]args[".join(" \| ",@args)."]");
	951	my($o,$str,$func,$args,$key_exists);
	952	$o = shift @args;
	953	if($can{$o}) {
	954	$self->$o(@args);
	955	return 1;
	956	} else {
	957	CPAN->debug("o[$o]") if $CPAN::DEBUG;
	958	if ($o =~ /list$/) {
	959	$func = shift @args;
	960	$func \|\|= "";
	961	CPAN->debug("func[$func]") if $CPAN::DEBUG;
	962	my $changed;
	963	# Let's avoid eval, it's easier to comprehend without.
	964	if ($func eq "push") {
	965	push @{$CPAN::Config->{$o}}, @args;
	966	$changed = 1;
	967	} elsif ($func eq "pop") {
	968	pop @{$CPAN::Config->{$o}};
	969	$changed = 1;
	970	} elsif ($func eq "shift") {
	971	shift @{$CPAN::Config->{$o}};
	972	$changed = 1;
	973	} elsif ($func eq "unshift") {
	974	unshift @{$CPAN::Config->{$o}}, @args;
	975	$changed = 1;
	976	} elsif ($func eq "splice") {
	977	splice @{$CPAN::Config->{$o}}, @args;
	978	$changed = 1;
	979	} elsif (@args) {
	980	$CPAN::Config->{$o} = [@args];
	981	$changed = 1;
	982	} else {
	983	$self->prettyprint($o);
	984	}
	985	if ($o eq "urllist" && $changed) {
	986	# reset the cached values
	987	undef $CPAN::FTP::Thesite;
	988	undef $CPAN::FTP::Themethod;
	989	}
	990	return $changed;
	991	} else {
	992	$CPAN::Config->{$o} = $args[0] if defined $args[0];
	993	$self->prettyprint($o);
	994	}
	995	}
	996	}
	997
	998	sub prettyprint {
	999	my($self,$k) = @_;
	1000	my $v = $CPAN::Config->{$k};
	1001	if (ref $v) {
	1002	my(@report) = ref $v eq "ARRAY" ?
	1003	@$v :
	1004	map { sprintf(" %-18s => %s\n",
	1005	$_,
	1006	defined $v->{$_} ? $v->{$_} : "UNDEFINED"
	1007	)} keys %$v;
	1008	$CPAN::Frontend->myprint(
	1009	join(
	1010	"",
	1011	sprintf(
	1012	" %-18s\n",
	1013	$k
	1014	),
	1015	map {"\t$_\n"} @report
	1016	)
	1017	);
	1018	} elsif (defined $v) {
	1019	$CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
	1020	} else {
	1021	$CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
	1022	}
	1023	}
	1024
	1025	#-> sub CPAN::Config::commit ;
	1026	sub commit {
	1027	my($self,$configpm) = @_;
	1028	unless (defined $configpm){
	1029	$configpm \|\|= $INC{"CPAN/MyConfig.pm"};
	1030	$configpm \|\|= $INC{"CPAN/Config.pm"};
	1031	$configpm \|\| Carp::confess(q{
	1032	CPAN::Config::commit called without an argument.
	1033	Please specify a filename where to save the configuration or try
	1034	"o conf init" to have an interactive course through configing.
	1035	});
	1036	}
	1037	my($mode);
	1038	if (-f $configpm) {
	1039	$mode = (stat $configpm)[2];
	1040	if ($mode && ! -w _) {
	1041	Carp::confess("$configpm is not writable");
	1042	}
	1043	}
	1044
	1045	my $msg;
	1046	$msg = <<EOF unless $configpm =~ /MyConfig/;
	1047
	1048	# This is CPAN.pm's systemwide configuration file. This file provides
	1049	# defaults for users, and the values can be changed in a per-user
	1050	# configuration file. The user-config file is being looked for as
	1051	# ~/.cpan/CPAN/MyConfig.pm.
	1052
	1053	EOF
	1054	$msg \|\|= "\n";
	1055	my($fh) = FileHandle->new;
	1056	rename $configpm, "$configpm~" if -f $configpm;
	1057	open $fh, ">$configpm" or
	1058	$CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
	1059	$fh->print(qq[$msg\$CPAN::Config = \{\n]);
	1060	foreach (sort keys %$CPAN::Config) {
	1061	$fh->print(
	1062	" '$_' => ",
	1063	ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
	1064	",\n"
	1065	);
	1066	}
	1067
	1068	$fh->print("};\n1;\n__END__\n");
	1069	close $fh;
	1070
	1071	#$mode = 0444 \| ( $mode & 0111 ? 0111 : 0 );
	1072	#chmod $mode, $configpm;
	1073	###why was that so? $self->defaults;
	1074	$CPAN::Frontend->myprint("commit: wrote $configpm\n");
	1075	1;
	1076	}
	1077
	1078	*default = \&defaults;
	1079	#-> sub CPAN::Config::defaults ;
	1080	sub defaults {
	1081	my($self) = @_;
	1082	$self->unload;
	1083	$self->load;
	1084	1;
	1085	}
	1086
	1087	sub init {
	1088	my($self) = @_;
	1089	undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
	1090	# have the least
	1091	# important
	1092	# variable
	1093	# undefined
	1094	$self->load;
	1095	1;
	1096	}
	1097
	1098	#-> sub CPAN::Config::load ;
	1099	sub load {
	1100	my($self) = shift;
	1101	my(@miss);
	1102	use Carp;
	1103	eval {require CPAN::Config;}; # We eval because of some
	1104	# MakeMaker problems
	1105	unless ($dot_cpan++){
	1106	unshift @INC, MM->catdir($ENV{HOME},".cpan");
	1107	eval {require CPAN::MyConfig;}; # where you can override
	1108	# system wide settings
	1109	shift @INC;
	1110	}
	1111	return unless @miss = $self->missing_config_data;
	1112
	1113	require CPAN::FirstTime;
	1114	my($configpm,$fh,$redo,$theycalled);
	1115	$redo \|\|= "";
	1116	$theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
	1117	if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
	1118	$configpm = $INC{"CPAN/Config.pm"};
	1119	$redo++;
	1120	} elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
	1121	$configpm = $INC{"CPAN/MyConfig.pm"};
	1122	$redo++;
	1123	} else {
	1124	my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
	1125	my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
	1126	my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
	1127	if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
	1128	if (-w $configpmtest) {
	1129	$configpm = $configpmtest;
	1130	} elsif (-w $configpmdir) {
	1131	#_#_# following code dumped core on me with 5.003_11, a.k.
	1132	unlink "$configpmtest.bak" if -f "$configpmtest.bak";
	1133	rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
	1134	my $fh = FileHandle->new;
	1135	if ($fh->open(">$configpmtest")) {
	1136	$fh->print("1;\n");
	1137	$configpm = $configpmtest;
	1138	} else {
	1139	# Should never happen
	1140	Carp::confess("Cannot open >$configpmtest");
	1141	}
	1142	}
	1143	}
	1144	unless ($configpm) {
	1145	$configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
	1146	File::Path::mkpath($configpmdir);
	1147	$configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
	1148	if (-w $configpmtest) {
	1149	$configpm = $configpmtest;
	1150	} elsif (-w $configpmdir) {
	1151	#_#_# following code dumped core on me with 5.003_11, a.k.
	1152	my $fh = FileHandle->new;
	1153	if ($fh->open(">$configpmtest")) {
	1154	$fh->print("1;\n");
	1155	$configpm = $configpmtest;
	1156	} else {
	1157	# Should never happen
	1158	Carp::confess("Cannot open >$configpmtest");
	1159	}
	1160	} else {
	1161	Carp::confess(qq{WARNING: CPAN.pm is unable to }.
	1162	qq{create a configuration file.});
	1163	}
	1164	}
	1165	}
	1166	local($") = ", ";
	1167	$CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
	1168	We have to reconfigure CPAN.pm due to following uninitialized parameters:
	1169
	1170	@miss
	1171	END
	1172	$CPAN::Frontend->myprint(qq{
	1173	$configpm initialized.
	1174	});
	1175	sleep 2;
	1176	CPAN::FirstTime::init($configpm);
	1177	}
	1178
	1179	#-> sub CPAN::Config::missing_config_data ;
	1180	sub missing_config_data {
	1181	my(@miss);
	1182	for (
	1183	"cpan_home", "keep_source_where", "build_dir", "build_cache",
	1184	"scan_cache", "index_expire", "gzip", "tar", "unzip", "make",
	1185	"pager",
	1186	"makepl_arg", "make_arg", "make_install_arg", "urllist",
	1187	"inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
	1188	"prerequisites_policy",
	1189	"cache_metadata",
	1190	) {
	1191	push @miss, $_ unless defined $CPAN::Config->{$_};
	1192	}
	1193	return @miss;
	1194	}
	1195
	1196	#-> sub CPAN::Config::unload ;
	1197	sub unload {
	1198	delete $INC{'CPAN/MyConfig.pm'};
	1199	delete $INC{'CPAN/Config.pm'};
	1200	}
	1201
	1202	#-> sub CPAN::Config::help ;
	1203	sub help {
	1204	$CPAN::Frontend->myprint(q[
	1205	Known options:
	1206	defaults reload default config values from disk
	1207	commit commit session changes to disk
	1208	init go through a dialog to set all parameters
	1209
	1210	You may edit key values in the follow fashion (the "o" is a literal
	1211	letter o):
	1212
	1213	o conf build_cache 15
	1214
	1215	o conf build_dir "/foo/bar"
	1216
	1217	o conf urllist shift
	1218
	1219	o conf urllist unshift ftp://ftp.foo.bar/
	1220
	1221	]);
	1222	undef; #don't reprint CPAN::Config
	1223	}
	1224
	1225	#-> sub CPAN::Config::cpl ;
	1226	sub cpl {
	1227	my($word,$line,$pos) = @_;
	1228	$word \|\|= "";
	1229	CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
	1230	my(@words) = split " ", substr($line,0,$pos+1);
	1231	if (
	1232	defined($words[2])
	1233	and
	1234	(
	1235	$words[2] =~ /list$/ && @words == 3
	1236	\|\|
	1237	$words[2] =~ /list$/ && @words == 4 && length($word)
	1238	)
	1239	) {
	1240	return grep /^\Q$word\E/, qw(splice shift unshift pop push);
	1241	} elsif (@words >= 4) {
	1242	return ();
	1243	}
	1244	my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
	1245	return grep /^\Q$word\E/, @o_conf;
	1246	}
	1247
	1248	package CPAN::Shell;
	1249
	1250	#-> sub CPAN::Shell::h ;
	1251	sub h {
	1252	my($class,$about) = @_;
	1253	if (defined $about) {
	1254	$CPAN::Frontend->myprint("Detailed help not yet implemented\n");
	1255	} else {
	1256	$CPAN::Frontend->myprint(q{
	1257	Display Information
	1258	command argument description
	1259	a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
	1260	i WORD or /REGEXP/ about anything of above
	1261	r NONE reinstall recommendations
	1262	ls AUTHOR about files in the author's directory
	1263
	1264	Download, Test, Make, Install...
	1265	get download
	1266	make make (implies get)
	1267	test MODULES, make test (implies make)
	1268	install DISTS, BUNDLES make install (implies test)
	1269	clean make clean
	1270	look open subshell in these dists' directories
	1271	readme display these dists' README files
	1272
	1273	Other
	1274	h,? display this menu ! perl-code eval a perl command
	1275	o conf [opt] set and query options q quit the cpan shell
	1276	reload cpan load CPAN.pm again reload index load newer indices
	1277	autobundle Snapshot force cmd unconditionally do cmd});
	1278	}
	1279	}
	1280
	1281	*help = \&h;
	1282
	1283	#-> sub CPAN::Shell::a ;
	1284	sub a {
	1285	my($self,@arg) = @_;
	1286	# authors are always UPPERCASE
	1287	for (@arg) {
	1288	$_ = uc $_ unless /=/;
	1289	}
	1290	$CPAN::Frontend->myprint($self->format_result('Author',@arg));
	1291	}
	1292
	1293	#-> sub CPAN::Shell::ls ;
	1294	sub ls {
	1295	my($self,@arg) = @_;
	1296	my @accept;
	1297	for (@arg) {
	1298	unless (/^[A-Z\-]+$/i) {
	1299	$CPAN::Frontend->mywarn("ls command rejects argument $_: not an author");
	1300	next;
	1301	}
	1302	push @accept, uc $_;
	1303	}
	1304	for my $a (@accept){
	1305	my $author = $self->expand('Author',$a) or die "No author found for $a";
	1306	$author->ls;
	1307	}
	1308	}
	1309
	1310	#-> sub CPAN::Shell::local_bundles ;
	1311	sub local_bundles {
	1312	my($self,@which) = @_;
	1313	my($incdir,$bdir,$dh);
	1314	foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
	1315	my @bbase = "Bundle";
	1316	while (my $bbase = shift @bbase) {
	1317	$bdir = MM->catdir($incdir,split /::/, $bbase);
	1318	CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
	1319	if ($dh = DirHandle->new($bdir)) { # may fail
	1320	my($entry);
	1321	for $entry ($dh->read) {
	1322	next if $entry =~ /^\./;
	1323	if (-d MM->catdir($bdir,$entry)){
	1324	push @bbase, "$bbase\::$entry";
	1325	} else {
	1326	next unless $entry =~ s/\.pm(?!\n)\Z//;
	1327	$CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
	1328	}
	1329	}
	1330	}
	1331	}
	1332	}
	1333	}
	1334
	1335	#-> sub CPAN::Shell::b ;
	1336	sub b {
	1337	my($self,@which) = @_;
	1338	CPAN->debug("which[@which]") if $CPAN::DEBUG;
	1339	$self->local_bundles;
	1340	$CPAN::Frontend->myprint($self->format_result('Bundle',@which));
	1341	}
	1342
	1343	#-> sub CPAN::Shell::d ;
	1344	sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
	1345
	1346	#-> sub CPAN::Shell::m ;
	1347	sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
	1348	$CPAN::Frontend->myprint(shift->format_result('Module',@_));
	1349	}
	1350
	1351	#-> sub CPAN::Shell::i ;
	1352	sub i {
	1353	my($self) = shift;
	1354	my(@args) = @_;
	1355	my(@type,$type,@m);
	1356	@type = qw/Author Bundle Distribution Module/;
	1357	@args = '/./' unless @args;
	1358	my(@result);
	1359	for $type (@type) {
	1360	push @result, $self->expand($type,@args);
	1361	}
	1362	my $result = @result == 1 ?
	1363	$result[0]->as_string :
	1364	@result == 0 ?
	1365	"No objects found of any type for argument @args\n" :
	1366	join("",
	1367	(map {$_->as_glimpse} @result),
	1368	scalar @result, " items found\n",
	1369	);
	1370	$CPAN::Frontend->myprint($result);
	1371	}
	1372
	1373	#-> sub CPAN::Shell::o ;
	1374
	1375	# CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
	1376	# should have been called set and 'o debug' maybe 'set debug'
	1377	sub o {
	1378	my($self,$o_type,@o_what) = @_;
	1379	$o_type \|\|= "";
	1380	CPAN->debug("o_type[$o_type] o_what[".join(" \| ",@o_what)."]\n");
	1381	if ($o_type eq 'conf') {
	1382	shift @o_what if @o_what && $o_what[0] eq 'help';
	1383	if (!@o_what) { # print all things, "o conf"
	1384	my($k,$v);
	1385	$CPAN::Frontend->myprint("CPAN::Config options");
	1386	if (exists $INC{'CPAN/Config.pm'}) {
	1387	$CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
	1388	}
	1389	if (exists $INC{'CPAN/MyConfig.pm'}) {
	1390	$CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
	1391	}
	1392	$CPAN::Frontend->myprint(":\n");
	1393	for $k (sort keys %CPAN::Config::can) {
	1394	$v = $CPAN::Config::can{$k};
	1395	$CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
	1396	}
	1397	$CPAN::Frontend->myprint("\n");
	1398	for $k (sort keys %$CPAN::Config) {
	1399	CPAN::Config->prettyprint($k);
	1400	}
	1401	$CPAN::Frontend->myprint("\n");
	1402	} elsif (!CPAN::Config->edit(@o_what)) {
	1403	$CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
	1404	qq{edit options\n\n});
	1405	}
	1406	} elsif ($o_type eq 'debug') {
	1407	my(%valid);
	1408	@o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
	1409	if (@o_what) {
	1410	while (@o_what) {
	1411	my($what) = shift @o_what;
	1412	if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
	1413	$CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
	1414	next;
	1415	}
	1416	if ( exists $CPAN::DEBUG{$what} ) {
	1417	$CPAN::DEBUG \|= $CPAN::DEBUG{$what};
	1418	} elsif ($what =~ /^\d/) {
	1419	$CPAN::DEBUG = $what;
	1420	} elsif (lc $what eq 'all') {
	1421	my($max) = 0;
	1422	for (values %CPAN::DEBUG) {
	1423	$max += $_;
	1424	}
	1425	$CPAN::DEBUG = $max;
	1426	} else {
	1427	my($known) = 0;
	1428	for (keys %CPAN::DEBUG) {
	1429	next unless lc($_) eq lc($what);
	1430	$CPAN::DEBUG \|= $CPAN::DEBUG{$_};
	1431	$known = 1;
	1432	}
	1433	$CPAN::Frontend->myprint("unknown argument [$what]\n")
	1434	unless $known;
	1435	}
	1436	}
	1437	} else {
	1438	my $raw = "Valid options for debug are ".
	1439	join(", ",sort(keys %CPAN::DEBUG), 'all').
	1440	qq{ or a number. Completion works on the options. }.
	1441	qq{Case is ignored.};
	1442	require Text::Wrap;
	1443	$CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
	1444	$CPAN::Frontend->myprint("\n\n");
	1445	}
	1446	if ($CPAN::DEBUG) {
	1447	$CPAN::Frontend->myprint("Options set for debugging:\n");
	1448	my($k,$v);
	1449	for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
	1450	$v = $CPAN::DEBUG{$k};
	1451	$CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
	1452	if $v & $CPAN::DEBUG;
	1453	}
	1454	} else {
	1455	$CPAN::Frontend->myprint("Debugging turned off completely.\n");
	1456	}
	1457	} else {
	1458	$CPAN::Frontend->myprint(qq{
	1459	Known options:
	1460	conf set or get configuration variables
	1461	debug set or get debugging options
	1462	});
	1463	}
	1464	}
	1465
	1466	sub paintdots_onreload {
	1467	my($ref) = shift;
	1468	sub {
	1469	if ( $_[0] =~ /[Ss]ubroutine (\w+) redefined/ ) {
	1470	my($subr) = $1;
	1471	++$$ref;
	1472	local($\|) = 1;
	1473	# $CPAN::Frontend->myprint(".($subr)");
	1474	$CPAN::Frontend->myprint(".");
	1475	return;
	1476	}
	1477	warn @_;
	1478	};
	1479	}
	1480
	1481	#-> sub CPAN::Shell::reload ;
	1482	sub reload {
	1483	my($self,$command,@arg) = @_;
	1484	$command \|\|= "";
	1485	$self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
	1486	if ($command =~ /cpan/i) {
	1487	CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
	1488	my $fh = FileHandle->new($INC{'CPAN.pm'});
	1489	local($/);
	1490	my $redef = 0;
	1491	local($SIG{__WARN__}) = paintdots_onreload(\$redef);
	1492	eval <$fh>;
	1493	warn $@ if $@;
	1494	$CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
	1495	} elsif ($command =~ /index/) {
	1496	CPAN::Index->force_reload;
	1497	} else {
	1498	$CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
	1499	index re-reads the index files\n});
	1500	}
	1501	}
	1502
	1503	#-> sub CPAN::Shell::_binary_extensions ;
	1504	sub _binary_extensions {
	1505	my($self) = shift @_;
	1506	my(@result,$module,%seen,%need,$headerdone);
	1507	for $module ($self->expand('Module','/./')) {
	1508	my $file = $module->cpan_file;
	1509	next if $file eq "N/A";
	1510	next if $file =~ /^Contact Author/;
	1511	my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
	1512	next if $dist->isa_perl;
	1513	next unless $module->xs_file;
	1514	local($\|) = 1;
	1515	$CPAN::Frontend->myprint(".");
	1516	push @result, $module;
	1517	}
	1518	# print join " \| ", @result;
	1519	$CPAN::Frontend->myprint("\n");
	1520	return @result;
	1521	}
	1522
	1523	#-> sub CPAN::Shell::recompile ;
	1524	sub recompile {
	1525	my($self) = shift @_;
	1526	my($module,@module,$cpan_file,%dist);
	1527	@module = $self->_binary_extensions();
	1528	for $module (@module){ # we force now and compile later, so we
	1529	# don't do it twice
	1530	$cpan_file = $module->cpan_file;
	1531	my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
	1532	$pack->force;
	1533	$dist{$cpan_file}++;
	1534	}
	1535	for $cpan_file (sort keys %dist) {
	1536	$CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
	1537	my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
	1538	$pack->install;
	1539	$CPAN::Signal = 0; # it's tempting to reset Signal, so we can
	1540	# stop a package from recompiling,
	1541	# e.g. IO-1.12 when we have perl5.003_10
	1542	}
	1543	}
	1544
	1545	#-> sub CPAN::Shell::_u_r_common ;
	1546	sub _u_r_common {
	1547	my($self) = shift @_;
	1548	my($what) = shift @_;
	1549	CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
	1550	Carp::croak "Usage: \$obj->_u_r_common(a\|r\|u)" unless
	1551	$what && $what =~ /^[aru]$/;
	1552	my(@args) = @_;
	1553	@args = '/./' unless @args;
	1554	my(@result,$module,%seen,%need,$headerdone,
	1555	$version_undefs,$version_zeroes);
	1556	$version_undefs = $version_zeroes = 0;
	1557	my $sprintf = "%s%-25s%s %9s %9s %s\n";
	1558	my @expand = $self->expand('Module',@args);
	1559	my $expand = scalar @expand;
	1560	if (0) { # Looks like noise to me, was very useful for debugging
	1561	# for metadata cache
	1562	$CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
	1563	}
	1564	for $module (@expand) {
	1565	my $file = $module->cpan_file;
	1566	next unless defined $file; # ??
	1567	my($latest) = $module->cpan_version;
	1568	my($inst_file) = $module->inst_file;
	1569	my($have);
	1570	return if $CPAN::Signal;
	1571	if ($inst_file){
	1572	if ($what eq "a") {
	1573	$have = $module->inst_version;
	1574	} elsif ($what eq "r") {
	1575	$have = $module->inst_version;
	1576	local($^W) = 0;
	1577	if ($have eq "undef"){
	1578	$version_undefs++;
	1579	} elsif ($have == 0){
	1580	$version_zeroes++;
	1581	}
	1582	next unless CPAN::Version->vgt($latest, $have);
	1583	# to be pedantic we should probably say:
	1584	# && !($have eq "undef" && $latest ne "undef" && $latest gt "");
	1585	# to catch the case where CPAN has a version 0 and we have a version undef
	1586	} elsif ($what eq "u") {
	1587	next;
	1588	}
	1589	} else {
	1590	if ($what eq "a") {
	1591	next;
	1592	} elsif ($what eq "r") {
	1593	next;
	1594	} elsif ($what eq "u") {
	1595	$have = "-";
	1596	}
	1597	}
	1598	return if $CPAN::Signal; # this is sometimes lengthy
	1599	$seen{$file} \|\|= 0;
	1600	if ($what eq "a") {
	1601	push @result, sprintf "%s %s\n", $module->id, $have;
	1602	} elsif ($what eq "r") {
	1603	push @result, $module->id;
	1604	next if $seen{$file}++;
	1605	} elsif ($what eq "u") {
	1606	push @result, $module->id;
	1607	next if $seen{$file}++;
	1608	next if $file =~ /^Contact/;
	1609	}
	1610	unless ($headerdone++){
	1611	$CPAN::Frontend->myprint("\n");
	1612	$CPAN::Frontend->myprint(sprintf(
	1613	$sprintf,
	1614	"",
	1615	"Package namespace",
	1616	"",
	1617	"installed",
	1618	"latest",
	1619	"in CPAN file"
	1620	));
	1621	}
	1622	my $color_on = "";
	1623	my $color_off = "";
	1624	if (
	1625	$COLOR_REGISTERED
	1626	&&
	1627	$CPAN::META->has_inst("Term::ANSIColor")
	1628	&&
	1629	$module->{RO}{description}
	1630	) {
	1631	$color_on = Term::ANSIColor::color("green");
	1632	$color_off = Term::ANSIColor::color("reset");
	1633	}
	1634	$CPAN::Frontend->myprint(sprintf $sprintf,
	1635	$color_on,
	1636	$module->id,
	1637	$color_off,
	1638	$have,
	1639	$latest,
	1640	$file);
	1641	$need{$module->id}++;
	1642	}
	1643	unless (%need) {
	1644	if ($what eq "u") {
	1645	$CPAN::Frontend->myprint("No modules found for @args\n");
	1646	} elsif ($what eq "r") {
	1647	$CPAN::Frontend->myprint("All modules are up to date for @args\n");
	1648	}
	1649	}
	1650	if ($what eq "r") {
	1651	if ($version_zeroes) {
	1652	my $s_has = $version_zeroes > 1 ? "s have" : " has";
	1653	$CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
	1654	qq{a version number of 0\n});
	1655	}
	1656	if ($version_undefs) {
	1657	my $s_has = $version_undefs > 1 ? "s have" : " has";
	1658	$CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
	1659	qq{parseable version number\n});
	1660	}
	1661	}
	1662	@result;
	1663	}
	1664
	1665	#-> sub CPAN::Shell::r ;
	1666	sub r {
	1667	shift->_u_r_common("r",@_);
	1668	}
	1669
	1670	#-> sub CPAN::Shell::u ;
	1671	sub u {
	1672	shift->_u_r_common("u",@_);
	1673	}
	1674
	1675	#-> sub CPAN::Shell::autobundle ;
	1676	sub autobundle {
	1677	my($self) = shift;
	1678	CPAN::Config->load unless $CPAN::Config_loaded++;
	1679	my(@bundle) = $self->_u_r_common("a",@_);
	1680	my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
	1681	File::Path::mkpath($todir);
	1682	unless (-d $todir) {
	1683	$CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
	1684	return;
	1685	}
	1686	my($y,$m,$d) = (localtime)[5,4,3];
	1687	$y+=1900;
	1688	$m++;
	1689	my($c) = 0;
	1690	my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
	1691	my($to) = MM->catfile($todir,"$me.pm");
	1692	while (-f $to) {
	1693	$me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
	1694	$to = MM->catfile($todir,"$me.pm");
	1695	}
	1696	my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
	1697	$fh->print(
	1698	"package Bundle::$me;\n\n",
	1699	"\$VERSION = '0.01';\n\n",
	1700	"1;\n\n",
	1701	"__END__\n\n",
	1702	"=head1 NAME\n\n",
	1703	"Bundle::$me - Snapshot of installation on ",
	1704	$Config::Config{'myhostname'},
	1705	" on ",
	1706	scalar(localtime),
	1707	"\n\n=head1 SYNOPSIS\n\n",
	1708	"perl -MCPAN -e 'install Bundle::$me'\n\n",
	1709	"=head1 CONTENTS\n\n",
	1710	join("\n", @bundle),
	1711	"\n\n=head1 CONFIGURATION\n\n",
	1712	Config->myconfig,
	1713	"\n\n=head1 AUTHOR\n\n",
	1714	"This Bundle has been generated automatically ",
	1715	"by the autobundle routine in CPAN.pm.\n",
	1716	);
	1717	$fh->close;
	1718	$CPAN::Frontend->myprint("\nWrote bundle file
	1719	$to\n\n");
	1720	}
	1721
	1722	#-> sub CPAN::Shell::expandany ;
	1723	sub expandany {
	1724	my($self,$s) = @_;
	1725	CPAN->debug("s[$s]") if $CPAN::DEBUG;
	1726	if ($s =~ m\|/\|) { # looks like a file
	1727	$s = CPAN::Distribution->normalize($s);
	1728	return $CPAN::META->instance('CPAN::Distribution',$s);
	1729	# Distributions spring into existence, not expand
	1730	} elsif ($s =~ m\|^Bundle::\|) {
	1731	$self->local_bundles; # scanning so late for bundles seems
	1732	# both attractive and crumpy: always
	1733	# current state but easy to forget
	1734	# somewhere
	1735	return $self->expand('Bundle',$s);
	1736	} else {
	1737	return $self->expand('Module',$s)
	1738	if $CPAN::META->exists('CPAN::Module',$s);
	1739	}
	1740	return;
	1741	}
	1742
	1743	#-> sub CPAN::Shell::expand ;
	1744	sub expand {
	1745	shift;
	1746	my($type,@args) = @_;
	1747	my($arg,@m);
	1748	CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
	1749	for $arg (@args) {
	1750	my($regex,$command);
	1751	if ($arg =~ m\|^/(.*)/$\|) {
	1752	$regex = $1;
	1753	} elsif ($arg =~ m/=/) {
	1754	$command = 1;
	1755	}
	1756	my $class = "CPAN::$type";
	1757	my $obj;
	1758	CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
	1759	$class,
	1760	defined $regex ? $regex : "UNDEFINED",
	1761	$command \|\| "UNDEFINED",
	1762	) if $CPAN::DEBUG;
	1763	if (defined $regex) {
	1764	for $obj (
	1765	sort
	1766	{$a->id cmp $b->id}
	1767	$CPAN::META->all_objects($class)
	1768	) {
	1769	unless ($obj->id){
	1770	# BUG, we got an empty object somewhere
	1771	require Data::Dumper;
	1772	CPAN->debug(sprintf(
	1773	"Bug in CPAN: Empty id on obj[%s][%s]",
	1774	$obj,
	1775	Data::Dumper::Dumper($obj)
	1776	)) if $CPAN::DEBUG;
	1777	next;
	1778	}
	1779	push @m, $obj
	1780	if $obj->id =~ /$regex/i
	1781	or
	1782	(
	1783	(
	1784	$] < 5.00303 ### provide sort of
	1785	### compatibility with 5.003
	1786	\|\|
	1787	$obj->can('name')
	1788	)
	1789	&&
	1790	$obj->name =~ /$regex/i
	1791	);
	1792	}
	1793	} elsif ($command) {
	1794	die "equal sign in command disabled (immature interface), ".
	1795	"you can set
	1796	! \$CPAN::Shell::ADVANCED_QUERY=1
	1797	to enable it. But please note, this is HIGHLY EXPERIMENTAL code
	1798	that may go away anytime.\n"
	1799	unless $ADVANCED_QUERY;
	1800	my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
	1801	my($matchcrit) = $criterion =~ m/^~(.+)/;
	1802	for my $self (
	1803	sort
	1804	{$a->id cmp $b->id}
	1805	$CPAN::META->all_objects($class)
	1806	) {
	1807	my $lhs = $self->$method() or next; # () for 5.00503
	1808	if ($matchcrit) {
	1809	push @m, $self if $lhs =~ m/$matchcrit/;
	1810	} else {
	1811	push @m, $self if $lhs eq $criterion;
	1812	}
	1813	}
	1814	} else {
	1815	my($xarg) = $arg;
	1816	if ( $type eq 'Bundle' ) {
	1817	$xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
	1818	} elsif ($type eq "Distribution") {
	1819	$xarg = CPAN::Distribution->normalize($arg);
	1820	}
	1821	if ($CPAN::META->exists($class,$xarg)) {
	1822	$obj = $CPAN::META->instance($class,$xarg);
	1823	} elsif ($CPAN::META->exists($class,$arg)) {
	1824	$obj = $CPAN::META->instance($class,$arg);
	1825	} else {
	1826	next;
	1827	}
	1828	push @m, $obj;
	1829	}
	1830	}
	1831	return wantarray ? @m : $m[0];
	1832	}
	1833
	1834	#-> sub CPAN::Shell::format_result ;
	1835	sub format_result {
	1836	my($self) = shift;
	1837	my($type,@args) = @_;
	1838	@args = '/./' unless @args;
	1839	my(@result) = $self->expand($type,@args);
	1840	my $result = @result == 1 ?
	1841	$result[0]->as_string :
	1842	@result == 0 ?
	1843	"No objects of type $type found for argument @args\n" :
	1844	join("",
	1845	(map {$_->as_glimpse} @result),
	1846	scalar @result, " items found\n",
	1847	);
	1848	$result;
	1849	}
	1850
	1851	# The only reason for this method is currently to have a reliable
	1852	# debugging utility that reveals which output is going through which
	1853	# channel. No, I don't like the colors ;-)
	1854
	1855	#-> sub CPAN::Shell::print_ornameted ;
	1856	sub print_ornamented {
	1857	my($self,$what,$ornament) = @_;
	1858	my $longest = 0;
	1859	return unless defined $what;
	1860
	1861	if ($CPAN::Config->{term_is_latin}){
	1862	# courtesy jhi:
	1863	$what
	1864	=~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0\|ord($2)&0x3F)}eg; #};
	1865	}
	1866	if ($PRINT_ORNAMENTING) {
	1867	unless (defined &color) {
	1868	if ($CPAN::META->has_inst("Term::ANSIColor")) {
	1869	import Term::ANSIColor "color";
	1870	} else {
	1871	*color = sub { return "" };
	1872	}
	1873	}
	1874	my $line;
	1875	for $line (split /\n/, $what) {
	1876	$longest = length($line) if length($line) > $longest;
	1877	}
	1878	my $sprintf = "%-" . $longest . "s";
	1879	while ($what){
	1880	$what =~ s/(.*\n?)//m;
	1881	my $line = $1;
	1882	last unless $line;
	1883	my($nl) = chomp $line ? "\n" : "";
	1884	# print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
	1885	print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
	1886	}
	1887	} else {
	1888	print $what;
	1889	}
	1890	}
	1891
	1892	sub myprint {
	1893	my($self,$what) = @_;
	1894
	1895	$self->print_ornamented($what, 'bold blue on_yellow');
	1896	}
	1897
	1898	sub myexit {
	1899	my($self,$what) = @_;
	1900	$self->myprint($what);
	1901	exit;
	1902	}
	1903
	1904	sub mywarn {
	1905	my($self,$what) = @_;
	1906	$self->print_ornamented($what, 'bold red on_yellow');
	1907	}
	1908
	1909	sub myconfess {
	1910	my($self,$what) = @_;
	1911	$self->print_ornamented($what, 'bold red on_white');
	1912	Carp::confess "died";
	1913	}
	1914
	1915	sub mydie {
	1916	my($self,$what) = @_;
	1917	$self->print_ornamented($what, 'bold red on_white');
	1918	die "\n";
	1919	}
	1920
	1921	sub setup_output {
	1922	return if -t STDOUT;
	1923	my $odef = select STDERR;
	1924	$\| = 1;
	1925	select STDOUT;
	1926	$\| = 1;
	1927	select $odef;
	1928	}
	1929
	1930	#-> sub CPAN::Shell::rematein ;
	1931	# RE-adme\|\|MA-ke\|\|TE-st\|\|IN-stall
	1932	sub rematein {
	1933	shift;
	1934	my($meth,@some) = @_;
	1935	my $pragma = "";
	1936	if ($meth eq 'force') {
	1937	$pragma = $meth;
	1938	$meth = shift @some;
	1939	}
	1940	setup_output();
	1941	CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
	1942
	1943	# Here is the place to set "test_count" on all involved parties to
	1944	# 0. We then can pass this counter on to the involved
	1945	# distributions and those can refuse to test if test_count > X. In
	1946	# the first stab at it we could use a 1 for "X".
	1947
	1948	# But when do I reset the distributions to start with 0 again?
	1949	# Jost suggested to have a random or cycling interaction ID that
	1950	# we pass through. But the ID is something that is just left lying
	1951	# around in addition to the counter, so I'd prefer to set the
	1952	# counter to 0 now, and repeat at the end of the loop. But what
	1953	# about dependencies? They appear later and are not reset, they
	1954	# enter the queue but not its copy. How do they get a sensible
	1955	# test_count?
	1956
	1957	# construct the queue
	1958	my($s,@s,@qcopy);
	1959	foreach $s (@some) {
	1960	my $obj;
	1961	if (ref $s) {
	1962	CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
	1963	$obj = $s;
	1964	} elsif ($s =~ m\|^/\|) { # looks like a regexp
	1965	$CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
	1966	"not supported\n");
	1967	sleep 2;
	1968	next;
	1969	} else {
	1970	CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
	1971	$obj = CPAN::Shell->expandany($s);
	1972	}
	1973	if (ref $obj) {
	1974	$obj->color_cmd_tmps(0,1);
	1975	CPAN::Queue->new($obj->id);
	1976	push @qcopy, $obj;
	1977	} elsif ($CPAN::META->exists('CPAN::Author',$s)) {
	1978	$obj = $CPAN::META->instance('CPAN::Author',$s);
	1979	if ($meth eq "dump") {
	1980	$obj->dump;
	1981	} else {
	1982	$CPAN::Frontend->myprint(
	1983	join "",
	1984	"Don't be silly, you can't $meth ",
	1985	$obj->fullname,
	1986	" ;-)\n"
	1987	);
	1988	sleep 2;
	1989	}
	1990	} else {
	1991	$CPAN::Frontend
	1992	->myprint(qq{Warning: Cannot $meth $s, }.
	1993	qq{don\'t know what it is.
	1994	Try the command
	1995
	1996	i /$s/
	1997
	1998	to find objects with matching identifiers.
	1999	});
	2000	sleep 2;
	2001	}
	2002	}
	2003
	2004	# queuerunner (please be warned: when I started to change the
	2005	# queue to hold objects instead of names, I made one or two
	2006	# mistakes and never found which. I reverted back instead)
	2007	while ($s = CPAN::Queue->first) {
	2008	my $obj;
	2009	if (ref $s) {
	2010	$obj = $s; # I do not believe, we would survive if this happened
	2011	} else {
	2012	$obj = CPAN::Shell->expandany($s);
	2013	}
	2014	if ($pragma
	2015	&&
	2016	($] < 5.00303 \|\| $obj->can($pragma))){
	2017	### compatibility with 5.003
	2018	$obj->$pragma($meth); # the pragma "force" in
	2019	# "CPAN::Distribution" must know
	2020	# what we are intending
	2021	}
	2022	if ($]>=5.00303 && $obj->can('called_for')) {
	2023	$obj->called_for($s);
	2024	}
	2025	CPAN->debug(
	2026	qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
	2027	$obj->as_string.
	2028	qq{\]}
	2029	) if $CPAN::DEBUG;
	2030
	2031	if ($obj->$meth()){
	2032	CPAN::Queue->delete($s);
	2033	} else {
	2034	CPAN->debug("failed");
	2035	}
	2036
	2037	$obj->undelay;
	2038	CPAN::Queue->delete_first($s);
	2039	}
	2040	for my $obj (@qcopy) {
	2041	$obj->color_cmd_tmps(0,0);
	2042	}
	2043	}
	2044
	2045	#-> sub CPAN::Shell::dump ;
	2046	sub dump { shift->rematein('dump',@_); }
	2047	#-> sub CPAN::Shell::force ;
	2048	sub force { shift->rematein('force',@_); }
	2049	#-> sub CPAN::Shell::get ;
	2050	sub get { shift->rematein('get',@_); }
	2051	#-> sub CPAN::Shell::readme ;
	2052	sub readme { shift->rematein('readme',@_); }
	2053	#-> sub CPAN::Shell::make ;
	2054	sub make { shift->rematein('make',@_); }
	2055	#-> sub CPAN::Shell::test ;
	2056	sub test { shift->rematein('test',@_); }
	2057	#-> sub CPAN::Shell::install ;
	2058	sub install { shift->rematein('install',@_); }
	2059	#-> sub CPAN::Shell::clean ;
	2060	sub clean { shift->rematein('clean',@_); }
	2061	#-> sub CPAN::Shell::look ;
	2062	sub look { shift->rematein('look',@_); }
	2063	#-> sub CPAN::Shell::cvs_import ;
	2064	sub cvs_import { shift->rematein('cvs_import',@_); }
	2065
	2066	package CPAN::LWP::UserAgent;
	2067
	2068	sub config {
	2069	return if $SETUPDONE;
	2070	if ($CPAN::META->has_usable('LWP::UserAgent')) {
	2071	require LWP::UserAgent;
	2072	@ISA = qw(Exporter LWP::UserAgent);
	2073	$SETUPDONE++;
	2074	} else {
	2075	$CPAN::Frontent->mywarn("LWP::UserAgent not available\n");
	2076	}
	2077	}
	2078
	2079	sub get_basic_credentials {
	2080	my($self, $realm, $uri, $proxy) = @_;
	2081	return unless $proxy;
	2082	if ($USER && $PASSWD) {
	2083	} elsif (defined $CPAN::Config->{proxy_user} &&
	2084	defined $CPAN::Config->{proxy_pass}) {
	2085	$USER = $CPAN::Config->{proxy_user};
	2086	$PASSWD = $CPAN::Config->{proxy_pass};
	2087	} else {
	2088	require ExtUtils::MakeMaker;
	2089	ExtUtils::MakeMaker->import(qw(prompt));
	2090	$USER = prompt("Proxy authentication needed!
	2091	(Note: to permanently configure username and password run
	2092	o conf proxy_user your_username
	2093	o conf proxy_pass your_password
	2094	)\nUsername:");
	2095	if ($CPAN::META->has_inst("Term::ReadKey")) {
	2096	Term::ReadKey::ReadMode("noecho");
	2097	} else {
	2098	$CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n");
	2099	}
	2100	$PASSWD = prompt("Password:");
	2101	if ($CPAN::META->has_inst("Term::ReadKey")) {
	2102	Term::ReadKey::ReadMode("restore");
	2103	}
	2104	$CPAN::Frontend->myprint("\n\n");
	2105	}
	2106	return($USER,$PASSWD);
	2107	}
	2108
	2109	sub mirror {
	2110	my($self,$url,$aslocal) = @_;
	2111	my $result = $self->SUPER::mirror($url,$aslocal);
	2112	if ($result->code == 407) {
	2113	undef $USER;
	2114	undef $PASSWD;
	2115	$result = $self->SUPER::mirror($url,$aslocal);
	2116	}
	2117	$result;
	2118	}
	2119
	2120	package CPAN::FTP;
	2121
	2122	#-> sub CPAN::FTP::ftp_get ;
	2123	sub ftp_get {
	2124	my($class,$host,$dir,$file,$target) = @_;
	2125	$class->debug(
	2126	qq[Going to fetch file [$file] from dir [$dir]
	2127	on host [$host] as local [$target]\n]
	2128	) if $CPAN::DEBUG;
	2129	my $ftp = Net::FTP->new($host);
	2130	return 0 unless defined $ftp;
	2131	$ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
	2132	$class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
	2133	unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
	2134	warn "Couldn't login on $host";
	2135	return;
	2136	}
	2137	unless ( $ftp->cwd($dir) ){
	2138	warn "Couldn't cwd $dir";
	2139	return;
	2140	}
	2141	$ftp->binary;
	2142	$class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
	2143	unless ( $ftp->get($file,$target) ){
	2144	warn "Couldn't fetch $file from $host\n";
	2145	return;
	2146	}
	2147	$ftp->quit; # it's ok if this fails
	2148	return 1;
	2149	}
	2150
	2151	# If more accuracy is wanted/needed, Chris Leach sent me this patch...
	2152
	2153	# > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
	2154	# > --- /tmp/cp Wed Sep 24 13:26:40 1997
	2155	# > ***************
	2156	# > * 1562,1567 **
	2157	# > --- 1562,1580 ----
	2158	# > return 1 if substr($url,0,4) eq "file";
	2159	# > return 1 unless $url =~ m\|://([^/]+)\|;
	2160	# > my $host = $1;
	2161	# > + my $proxy = $CPAN::Config->{'http_proxy'} \|\| $ENV{'http_proxy'};
	2162	# > + if ($proxy) {
	2163	# > + $proxy =~ m\|://([^/:]+)\|;
	2164	# > + $proxy = $1;
	2165	# > + my $noproxy = $CPAN::Config->{'no_proxy'} \|\| $ENV{'no_proxy'};
	2166	# > + if ($noproxy) {
	2167	# > + if ($host !~ /$noproxy$/) {
	2168	# > + $host = $proxy;
	2169	# > + }
	2170	# > + } else {
	2171	# > + $host = $proxy;
	2172	# > + }
	2173	# > + }
	2174	# > require Net::Ping;
	2175	# > return 1 unless $Net::Ping::VERSION >= 2;
	2176	# > my $p;
	2177
	2178
	2179	#-> sub CPAN::FTP::localize ;
	2180	sub localize {
	2181	my($self,$file,$aslocal,$force) = @_;
	2182	$force \|\|= 0;
	2183	Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
	2184	unless defined $aslocal;
	2185	$self->debug("file[$file] aslocal[$aslocal] force[$force]")
	2186	if $CPAN::DEBUG;
	2187
	2188	if ($^O eq 'MacOS') {
	2189	# Comment by AK on 2000-09-03: Uniq short filenames would be
	2190	# available in CHECKSUMS file
	2191	my($name, $path) = File::Basename::fileparse($aslocal, '');
	2192	if (length($name) > 31) {
	2193	$name =~ s/(
	2194	\.(
	2195	readme(\.(gz\|Z))? \|
	2196	(tar\.)?(gz\|Z) \|
	2197	tgz \|
	2198	zip \|
	2199	pm\.(gz\|Z)
	2200	)
	2201	)$//x;
	2202	my $suf = $1;
	2203	my $size = 31 - length($suf);
	2204	while (length($name) > $size) {
	2205	chop $name;
	2206	}
	2207	$name .= $suf;
	2208	$aslocal = File::Spec->catfile($path, $name);
	2209	}
	2210	}
	2211
	2212	return $aslocal if -f $aslocal && -r _ && !($force & 1);
	2213	my($restore) = 0;
	2214	if (-f $aslocal){
	2215	rename $aslocal, "$aslocal.bak";
	2216	$restore++;
	2217	}
	2218
	2219	my($aslocal_dir) = File::Basename::dirname($aslocal);
	2220	File::Path::mkpath($aslocal_dir);
	2221	$CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
	2222	qq{directory "$aslocal_dir".
	2223	I\'ll continue, but if you encounter problems, they may be due
	2224	to insufficient permissions.\n}) unless -w $aslocal_dir;
	2225
	2226	# Inheritance is not easier to manage than a few if/else branches
	2227	if ($CPAN::META->has_usable('LWP::UserAgent')) {
	2228	unless ($Ua) {
	2229	CPAN::LWP::UserAgent->config;
	2230	eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
	2231	if ($@) {
	2232	$CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@")
	2233	if $CPAN::DEBUG;
	2234	} else {
	2235	my($var);
	2236	$Ua->proxy('ftp', $var)
	2237	if $var = $CPAN::Config->{ftp_proxy} \|\| $ENV{ftp_proxy};
	2238	$Ua->proxy('http', $var)
	2239	if $var = $CPAN::Config->{http_proxy} \|\| $ENV{http_proxy};
	2240
	2241
	2242	# >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
	2243	#
	2244	# > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
	2245	# > use ones that require basic autorization.
	2246	#
	2247	# > Example of when I use it manually in my own stuff:
	2248	#
	2249	# > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
	2250	# > $req->proxy_authorization_basic("username","password");
	2251	# > $res = $ua->request($req);
	2252	#
	2253
	2254	$Ua->no_proxy($var)
	2255	if $var = $CPAN::Config->{no_proxy} \|\| $ENV{no_proxy};
	2256	}
	2257	}
	2258	}
	2259	$ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy};
	2260	$ENV{http_proxy} = $CPAN::Config->{http_proxy}
	2261	if $CPAN::Config->{http_proxy};
	2262	$ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy};
	2263
	2264	# Try the list of urls for each single object. We keep a record
	2265	# where we did get a file from
	2266	my(@reordered,$last);
	2267	$CPAN::Config->{urllist} \|\|= [];
	2268	$last = $#{$CPAN::Config->{urllist}};
	2269	if ($force & 2) { # local cpans probably out of date, don't reorder
	2270	@reordered = (0..$last);
	2271	} else {
	2272	@reordered =
	2273	sort {
	2274	(substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
	2275	<=>
	2276	(substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
	2277	or
	2278	defined($Thesite)
	2279	and
	2280	($b == $Thesite)
	2281	<=>
	2282	($a == $Thesite)
	2283	} 0..$last;
	2284	}
	2285	my(@levels);
	2286	if ($Themethod) {
	2287	@levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
	2288	} else {
	2289	@levels = qw/easy hard hardest/;
	2290	}
	2291	@levels = qw/easy/ if $^O eq 'MacOS';
	2292	my($levelno);
	2293	for $levelno (0..$#levels) {
	2294	my $level = $levels[$levelno];
	2295	my $method = "host$level";
	2296	my @host_seq = $level eq "easy" ?
	2297	@reordered : 0..$last; # reordered has CDROM up front
	2298	@host_seq = (0) unless @host_seq;
	2299	my $ret = $self->$method(\@host_seq,$file,$aslocal);
	2300	if ($ret) {
	2301	$Themethod = $level;
	2302	my $now = time;
	2303	# utime $now, $now, $aslocal; # too bad, if we do that, we
	2304	# might alter a local mirror
	2305	$self->debug("level[$level]") if $CPAN::DEBUG;
	2306	return $ret;
	2307	} else {
	2308	unlink $aslocal;
	2309	last if $CPAN::Signal; # need to cleanup
	2310	}
	2311	}
	2312	unless ($CPAN::Signal) {
	2313	my(@mess);
	2314	push @mess,
	2315	qq{Please check, if the URLs I found in your configuration file \(}.
	2316	join(", ", @{$CPAN::Config->{urllist}}).
	2317	qq{\) are valid. The urllist can be edited.},
	2318	qq{E.g. with 'o conf urllist push ftp://myurl/'};
	2319	$CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
	2320	sleep 2;
	2321	$CPAN::Frontend->myprint("Could not fetch $file\n");
	2322	}
	2323	if ($restore) {
	2324	rename "$aslocal.bak", $aslocal;
	2325	$CPAN::Frontend->myprint("Trying to get away with old file:\n" .
	2326	$self->ls($aslocal));
	2327	return $aslocal;
	2328	}
	2329	return;
	2330	}
	2331
	2332	sub hosteasy {
	2333	my($self,$host_seq,$file,$aslocal) = @_;
	2334	my($i);
	2335	HOSTEASY: for $i (@$host_seq) {
	2336	my $url = $CPAN::Config->{urllist}[$i] \|\| $CPAN::Defaultsite;
	2337	$url .= "/" unless substr($url,-1) eq "/";
	2338	$url .= $file;
	2339	$self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
	2340	if ($url =~ /^file:/) {
	2341	my $l;
	2342	if ($CPAN::META->has_inst('URI::URL')) {
	2343	my $u = URI::URL->new($url);
	2344	$l = $u->path;
	2345	} else { # works only on Unix, is poorly constructed, but
	2346	# hopefully better than nothing.
	2347	# RFC 1738 says fileurl BNF is
	2348	# fileurl = "file://" [ host \| "localhost" ] "/" fpath
	2349	# Thanks to "Mark D. Baushke" <mdb@cisco.com> for
	2350	# the code
	2351	($l = $url) =~ s\|^file://[^/]*/\|/\|; # discard the host part
	2352	$l =~ s\|^file:\|\|; # assume they
	2353	# meant
	2354	# file://localhost
	2355	$l =~ s\|^/\|\|s unless -f $l; # e.g. /P:
	2356	$self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG;
	2357	}
	2358	if ( -f $l && -r _) {
	2359	$Thesite = $i;
	2360	return $l;
	2361	}
	2362	# Maybe mirror has compressed it?
	2363	if (-f "$l.gz") {
	2364	$self->debug("found compressed $l.gz") if $CPAN::DEBUG;
	2365	CPAN::Tarzip->gunzip("$l.gz", $aslocal);
	2366	if ( -f $aslocal) {
	2367	$Thesite = $i;
	2368	return $aslocal;
	2369	}
	2370	}
	2371	}
	2372	if ($CPAN::META->has_usable('LWP')) {
	2373	$CPAN::Frontend->myprint("Fetching with LWP:
	2374	$url
	2375	");
	2376	unless ($Ua) {
	2377	CPAN::LWP::UserAgent->config;
	2378	eval { $Ua = CPAN::LWP::UserAgent->new; };
	2379	if ($@) {
	2380	$CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@");
	2381	}
	2382	}
	2383	my $res = $Ua->mirror($url, $aslocal);
	2384	if ($res->is_success) {
	2385	$Thesite = $i;
	2386	my $now = time;
	2387	utime $now, $now, $aslocal; # download time is more
	2388	# important than upload time
	2389	return $aslocal;
	2390	} elsif ($url !~ /\.gz(?!\n)\Z/) {
	2391	my $gzurl = "$url.gz";
	2392	$CPAN::Frontend->myprint("Fetching with LWP:
	2393	$gzurl
	2394	");
	2395	$res = $Ua->mirror($gzurl, "$aslocal.gz");
	2396	if ($res->is_success &&
	2397	CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
	2398	) {
	2399	$Thesite = $i;
	2400	return $aslocal;
	2401	}
	2402	} else {
	2403	$CPAN::Frontend->myprint(sprintf(
	2404	"LWP failed with code[%s] message[%s]\n",
	2405	$res->code,
	2406	$res->message,
	2407	));
	2408	# Alan Burlison informed me that in firewall environments
	2409	# Net::FTP can still succeed where LWP fails. So we do not
	2410	# skip Net::FTP anymore when LWP is available.
	2411	}
	2412	} else {
	2413	$CPAN::Frontend->myprint("LWP not available\n");
	2414	}
	2415	return if $CPAN::Signal;
	2416	if ($url =~ m\|^ftp://(.?)/(.)/(.*)\|) {
	2417	# that's the nice and easy way thanks to Graham
	2418	my($host,$dir,$getfile) = ($1,$2,$3);
	2419	if ($CPAN::META->has_usable('Net::FTP')) {
	2420	$dir =~ s\|/+\|/\|g;
	2421	$CPAN::Frontend->myprint("Fetching with Net::FTP:
	2422	$url
	2423	");
	2424	$self->debug("getfile[$getfile]dir[$dir]host[$host]" .
	2425	"aslocal[$aslocal]") if $CPAN::DEBUG;
	2426	if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
	2427	$Thesite = $i;
	2428	return $aslocal;
	2429	}
	2430	if ($aslocal !~ /\.gz(?!\n)\Z/) {
	2431	my $gz = "$aslocal.gz";
	2432	$CPAN::Frontend->myprint("Fetching with Net::FTP
	2433	$url.gz
	2434	");
	2435	if (CPAN::FTP->ftp_get($host,
	2436	$dir,
	2437	"$getfile.gz",
	2438	$gz) &&
	2439	CPAN::Tarzip->gunzip($gz,$aslocal)
	2440	){
	2441	$Thesite = $i;
	2442	return $aslocal;
	2443	}
	2444	}
	2445	# next HOSTEASY;
	2446	}
	2447	}
	2448	return if $CPAN::Signal;
	2449	}
	2450	}
	2451
	2452	sub hosthard {
	2453	my($self,$host_seq,$file,$aslocal) = @_;
	2454
	2455	# Came back if Net::FTP couldn't establish connection (or
	2456	# failed otherwise) Maybe they are behind a firewall, but they
	2457	# gave us a socksified (or other) ftp program...
	2458
	2459	my($i);
	2460	my($devnull) = $CPAN::Config->{devnull} \|\| "";
	2461	# < /dev/null ";
	2462	my($aslocal_dir) = File::Basename::dirname($aslocal);
	2463	File::Path::mkpath($aslocal_dir);
	2464	HOSTHARD: for $i (@$host_seq) {
	2465	my $url = $CPAN::Config->{urllist}[$i] \|\| $CPAN::Defaultsite;
	2466	$url .= "/" unless substr($url,-1) eq "/";
	2467	$url .= $file;
	2468	my($proto,$host,$dir,$getfile);
	2469
	2470	# Courtesy Mark Conty mark_conty@cargill.com change from
	2471	# if ($url =~ m\|^ftp://(.?)/(.)/(.*)\|) {
	2472	# to
	2473	if ($url =~ m\|^([^:]+)://(.?)/(.)/(.*)\|) {
	2474	# proto not yet used
	2475	($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
	2476	} else {
	2477	next HOSTHARD; # who said, we could ftp anything except ftp?
	2478	}
	2479	next HOSTHARD if $proto eq "file"; # file URLs would have had
	2480	# success above. Likely a bogus URL
	2481
	2482	$self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
	2483	my($f,$funkyftp);
	2484	for $f ('lynx','ncftpget','ncftp','wget') {
	2485	next unless exists $CPAN::Config->{$f};
	2486	$funkyftp = $CPAN::Config->{$f};
	2487	next unless defined $funkyftp;
	2488	next if $funkyftp =~ /^\s*$/;
	2489	my($asl_ungz, $asl_gz);
	2490	($asl_ungz = $aslocal) =~ s/\.gz//;
	2491	$asl_gz = "$asl_ungz.gz";
	2492	my($src_switch) = "";
	2493	if ($f eq "lynx"){
	2494	$src_switch = " -source";
	2495	} elsif ($f eq "ncftp"){
	2496	$src_switch = " -c";
	2497	} elsif ($f eq "wget"){
	2498	$src_switch = " -O -";
	2499	}
	2500	my($chdir) = "";
	2501	my($stdout_redir) = " > $asl_ungz";
	2502	if ($f eq "ncftpget"){
	2503	$chdir = "cd $aslocal_dir && ";
	2504	$stdout_redir = "";
	2505	}
	2506	$CPAN::Frontend->myprint(
	2507	qq[
	2508	Trying with "$funkyftp$src_switch" to get
	2509	$url
	2510	]);
	2511	my($system) =
	2512	"$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
	2513	$self->debug("system[$system]") if $CPAN::DEBUG;
	2514	my($wstatus);
	2515	if (($wstatus = system($system)) == 0
	2516	&&
	2517	($f eq "lynx" ?
	2518	-s $asl_ungz # lynx returns 0 when it fails somewhere
	2519	: 1
	2520	)
	2521	) {
	2522	if (-s $aslocal) {
	2523	# Looks good
	2524	} elsif ($asl_ungz ne $aslocal) {
	2525	# test gzip integrity
	2526	if (CPAN::Tarzip->gtest($asl_ungz)) {
	2527	# e.g. foo.tar is gzipped --> foo.tar.gz
	2528	rename $asl_ungz, $aslocal;
	2529	} else {
	2530	CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
	2531	}
	2532	}
	2533	$Thesite = $i;
	2534	return $aslocal;
	2535	} elsif ($url !~ /\.gz(?!\n)\Z/) {
	2536	unlink $asl_ungz if
	2537	-f $asl_ungz && -s _ == 0;
	2538	my $gz = "$aslocal.gz";
	2539	my $gzurl = "$url.gz";
	2540	$CPAN::Frontend->myprint(
	2541	qq[
	2542	Trying with "$funkyftp$src_switch" to get
	2543	$url.gz
	2544	]);
	2545	my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
	2546	$self->debug("system[$system]") if $CPAN::DEBUG;
	2547	my($wstatus);
	2548	if (($wstatus = system($system)) == 0
	2549	&&
	2550	-s $asl_gz
	2551	) {
	2552	# test gzip integrity
	2553	if (CPAN::Tarzip->gtest($asl_gz)) {
	2554	CPAN::Tarzip->gunzip($asl_gz,$aslocal);
	2555	} else {
	2556	# somebody uncompressed file for us?
	2557	rename $asl_ungz, $aslocal;
	2558	}
	2559	$Thesite = $i;
	2560	return $aslocal;
	2561	} else {
	2562	unlink $asl_gz if -f $asl_gz;
	2563	}
	2564	} else {
	2565	my $estatus = $wstatus >> 8;
	2566	my $size = -f $aslocal ?
	2567	", left\n$aslocal with size ".-s _ :
	2568	"\nWarning: expected file [$aslocal] doesn't exist";
	2569	$CPAN::Frontend->myprint(qq{
	2570	System call "$system"
	2571	returned status $estatus (wstat $wstatus)$size
	2572	});
	2573	}
	2574	return if $CPAN::Signal;
	2575	} # lynx,ncftpget,ncftp
	2576	} # host
	2577	}
	2578
	2579	sub hosthardest {
	2580	my($self,$host_seq,$file,$aslocal) = @_;
	2581
	2582	my($i);
	2583	my($aslocal_dir) = File::Basename::dirname($aslocal);
	2584	File::Path::mkpath($aslocal_dir);
	2585	HOSTHARDEST: for $i (@$host_seq) {
	2586	unless (length $CPAN::Config->{'ftp'}) {
	2587	$CPAN::Frontend->myprint("No external ftp command available\n\n");
	2588	last HOSTHARDEST;
	2589	}
	2590	my $url = $CPAN::Config->{urllist}[$i] \|\| $CPAN::Defaultsite;
	2591	$url .= "/" unless substr($url,-1) eq "/";
	2592	$url .= $file;
	2593	$self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
	2594	unless ($url =~ m\|^ftp://(.?)/(.)/(.*)\|) {
	2595	next;
	2596	}
	2597	my($host,$dir,$getfile) = ($1,$2,$3);
	2598	my $timestamp = 0;
	2599	my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
	2600	$ctime,$blksize,$blocks) = stat($aslocal);
	2601	$timestamp = $mtime \|\|= 0;
	2602	my($netrc) = CPAN::FTP::netrc->new;
	2603	my($netrcfile) = $netrc->netrc;
	2604	my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
	2605	my $targetfile = File::Basename::basename($aslocal);
	2606	my(@dialog);
	2607	push(
	2608	@dialog,
	2609	"lcd $aslocal_dir",
	2610	"cd /",
	2611	map("cd $_", split "/", $dir), # RFC 1738
	2612	"bin",
	2613	"get $getfile $targetfile",
	2614	"quit"
	2615	);
	2616	if (! $netrcfile) {
	2617	CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
	2618	} elsif ($netrc->hasdefault \|\| $netrc->contains($host)) {
	2619	CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
	2620	$netrc->hasdefault,
	2621	$netrc->contains($host))) if $CPAN::DEBUG;
	2622	if ($netrc->protected) {
	2623	$CPAN::Frontend->myprint(qq{
	2624	Trying with external ftp to get
	2625	$url
	2626	As this requires some features that are not thoroughly tested, we\'re
	2627	not sure, that we get it right....
	2628
	2629	}
	2630	);
	2631	$self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
	2632	@dialog);
	2633	($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
	2634	$atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
	2635	$mtime \|\|= 0;
	2636	if ($mtime > $timestamp) {
	2637	$CPAN::Frontend->myprint("GOT $aslocal\n");
	2638	$Thesite = $i;
	2639	return $aslocal;
	2640	} else {
	2641	$CPAN::Frontend->myprint("Hmm... Still failed!\n");
	2642	}
	2643	return if $CPAN::Signal;
	2644	} else {
	2645	$CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
	2646	qq{correctly protected.\n});
	2647	}
	2648	} else {
	2649	$CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
	2650	nor does it have a default entry\n");
	2651	}
	2652
	2653	# OK, they don't have a valid ~/.netrc. Use 'ftp -n'
	2654	# then and login manually to host, using e-mail as
	2655	# password.
	2656	$CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
	2657	unshift(
	2658	@dialog,
	2659	"open $host",
	2660	"user anonymous $Config::Config{'cf_email'}"
	2661	);
	2662	$self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
	2663	($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
	2664	$atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
	2665	$mtime \|\|= 0;
	2666	if ($mtime > $timestamp) {
	2667	$CPAN::Frontend->myprint("GOT $aslocal\n");
	2668	$Thesite = $i;
	2669	return $aslocal;
	2670	} else {
	2671	$CPAN::Frontend->myprint("Bad luck... Still failed!\n");
	2672	}
	2673	return if $CPAN::Signal;
	2674	$CPAN::Frontend->myprint("Can't access URL $url.\n\n");
	2675	sleep 2;
	2676	} # host
	2677	}
	2678
	2679	sub talk_ftp {
	2680	my($self,$command,@dialog) = @_;
	2681	my $fh = FileHandle->new;
	2682	$fh->open("\|$command") or die "Couldn't open ftp: $!";
	2683	foreach (@dialog) { $fh->print("$_\n") }
	2684	$fh->close; # Wait for process to complete
	2685	my $wstatus = $?;
	2686	my $estatus = $wstatus >> 8;
	2687	$CPAN::Frontend->myprint(qq{
	2688	Subprocess "\|$command"
	2689	returned status $estatus (wstat $wstatus)
	2690	}) if $wstatus;
	2691	}
	2692
	2693	# find2perl needs modularization, too, all the following is stolen
	2694	# from there
	2695	# CPAN::FTP::ls
	2696	sub ls {
	2697	my($self,$name) = @_;
	2698	my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
	2699	$atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
	2700
	2701	my($perms,%user,%group);
	2702	my $pname = $name;
	2703
	2704	if ($blocks) {
	2705	$blocks = int(($blocks + 1) / 2);
	2706	}
	2707	else {
	2708	$blocks = int(($sizemm + 1023) / 1024);
	2709	}
	2710
	2711	if (-f _) { $perms = '-'; }
	2712	elsif (-d _) { $perms = 'd'; }
	2713	elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
	2714	elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
	2715	elsif (-p _) { $perms = 'p'; }
	2716	elsif (-S _) { $perms = 's'; }
	2717	else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
	2718
	2719	my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
	2720	my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
	2721	my $tmpmode = $mode;
	2722	my $tmp = $rwx[$tmpmode & 7];
	2723	$tmpmode >>= 3;
	2724	$tmp = $rwx[$tmpmode & 7] . $tmp;
	2725	$tmpmode >>= 3;
	2726	$tmp = $rwx[$tmpmode & 7] . $tmp;
	2727	substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
	2728	substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
	2729	substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
	2730	$perms .= $tmp;
	2731
	2732	my $user = $user{$uid} \|\| $uid; # too lazy to implement lookup
	2733	my $group = $group{$gid} \|\| $gid;
	2734
	2735	my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
	2736	my($timeyear);
	2737	my($moname) = $moname[$mon];
	2738	if (-M _ > 365.25 / 2) {
	2739	$timeyear = $year + 1900;
	2740	}
	2741	else {
	2742	$timeyear = sprintf("%02d:%02d", $hour, $min);
	2743	}
	2744
	2745	sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
	2746	$ino,
	2747	$blocks,
	2748	$perms,
	2749	$nlink,
	2750	$user,
	2751	$group,
	2752	$sizemm,
	2753	$moname,
	2754	$mday,
	2755	$timeyear,
	2756	$pname;
	2757	}
	2758
	2759	package CPAN::FTP::netrc;
	2760
	2761	sub new {
	2762	my($class) = @_;
	2763	my $file = MM->catfile($ENV{HOME},".netrc");
	2764
	2765	my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
	2766	$atime,$mtime,$ctime,$blksize,$blocks)
	2767	= stat($file);
	2768	$mode \|\|= 0;
	2769	my $protected = 0;
	2770
	2771	my($fh,@machines,$hasdefault);
	2772	$hasdefault = 0;
	2773	$fh = FileHandle->new or die "Could not create a filehandle";
	2774
	2775	if($fh->open($file)){
	2776	$protected = ($mode & 077) == 0;
	2777	local($/) = "";
	2778	NETRC: while (<$fh>) {
	2779	my(@tokens) = split " ", $_;
	2780	TOKEN: while (@tokens) {
	2781	my($t) = shift @tokens;
	2782	if ($t eq "default"){
	2783	$hasdefault++;
	2784	last NETRC;
	2785	}
	2786	last TOKEN if $t eq "macdef";
	2787	if ($t eq "machine") {
	2788	push @machines, shift @tokens;
	2789	}
	2790	}
	2791	}
	2792	} else {
	2793	$file = $hasdefault = $protected = "";
	2794	}
	2795
	2796	bless {
	2797	'mach' => [@machines],
	2798	'netrc' => $file,
	2799	'hasdefault' => $hasdefault,
	2800	'protected' => $protected,
	2801	}, $class;
	2802	}
	2803
	2804	# CPAN::FTP::hasdefault;
	2805	sub hasdefault { shift->{'hasdefault'} }
	2806	sub netrc { shift->{'netrc'} }
	2807	sub protected { shift->{'protected'} }
	2808	sub contains {
	2809	my($self,$mach) = @_;
	2810	for ( @{$self->{'mach'}} ) {
	2811	return 1 if $_ eq $mach;
	2812	}
	2813	return 0;
	2814	}
	2815
	2816	package CPAN::Complete;
	2817
	2818	sub gnu_cpl {
	2819	my($text, $line, $start, $end) = @_;
	2820	my(@perlret) = cpl($text, $line, $start);
	2821	# find longest common match. Can anybody show me how to peruse
	2822	# T::R::Gnu to have this done automatically? Seems expensive.
	2823	return () unless @perlret;
	2824	my($newtext) = $text;
	2825	for (my $i = length($text)+1;;$i++) {
	2826	last unless length($perlret[0]) && length($perlret[0]) >= $i;
	2827	my $try = substr($perlret[0],0,$i);
	2828	my @tries = grep {substr($_,0,$i) eq $try} @perlret;
	2829	# warn "try[$try]tries[@tries]";
	2830	if (@tries == @perlret) {
	2831	$newtext = $try;
	2832	} else {
	2833	last;
	2834	}
	2835	}
	2836	($newtext,@perlret);
	2837	}
	2838
	2839	#-> sub CPAN::Complete::cpl ;
	2840	sub cpl {
	2841	my($word,$line,$pos) = @_;
	2842	$word \|\|= "";
	2843	$line \|\|= "";
	2844	$pos \|\|= 0;
	2845	CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
	2846	$line =~ s/^\s*//;
	2847	if ($line =~ s/^(force\s*)//) {
	2848	$pos -= length($1);
	2849	}
	2850	my @return;
	2851	if ($pos == 0) {
	2852	@return = grep /^$word/, @CPAN::Complete::COMMANDS;
	2853	} elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
	2854	@return = ();
	2855	} elsif ($line =~ /^(a\|ls)\s/) {
	2856	@return = cplx('CPAN::Author',uc($word));
	2857	} elsif ($line =~ /^b\s/) {
	2858	CPAN::Shell->local_bundles;
	2859	@return = cplx('CPAN::Bundle',$word);
	2860	} elsif ($line =~ /^d\s/) {
	2861	@return = cplx('CPAN::Distribution',$word);
	2862	} elsif ($line =~ m/^(
	2863	[mru]\|make\|clean\|dump\|get\|test\|install\|readme\|look\|cvs_import
	2864	)\s/x ) {
	2865	if ($word =~ /^Bundle::/) {
	2866	CPAN::Shell->local_bundles;
	2867	}
	2868	@return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
	2869	} elsif ($line =~ /^i\s/) {
	2870	@return = cpl_any($word);
	2871	} elsif ($line =~ /^reload\s/) {
	2872	@return = cpl_reload($word,$line,$pos);
	2873	} elsif ($line =~ /^o\s/) {
	2874	@return = cpl_option($word,$line,$pos);
	2875	} elsif ($line =~ m/^\S+\s/ ) {
	2876	# fallback for future commands and what we have forgotten above
	2877	@return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
	2878	} else {
	2879	@return = ();
	2880	}
	2881	return @return;
	2882	}
	2883
	2884	#-> sub CPAN::Complete::cplx ;
	2885	sub cplx {
	2886	my($class, $word) = @_;
	2887	# I believed for many years that this was sorted, today I
	2888	# realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
	2889	# make it sorted again. Maybe sort was dropped when GNU-readline
	2890	# support came in? The RCS file is difficult to read on that:-(
	2891	sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
	2892	}
	2893
	2894	#-> sub CPAN::Complete::cpl_any ;
	2895	sub cpl_any {
	2896	my($word) = shift;
	2897	return (
	2898	cplx('CPAN::Author',$word),
	2899	cplx('CPAN::Bundle',$word),
	2900	cplx('CPAN::Distribution',$word),
	2901	cplx('CPAN::Module',$word),
	2902	);
	2903	}
	2904
	2905	#-> sub CPAN::Complete::cpl_reload ;
	2906	sub cpl_reload {
	2907	my($word,$line,$pos) = @_;
	2908	$word \|\|= "";
	2909	my(@words) = split " ", $line;
	2910	CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
	2911	my(@ok) = qw(cpan index);
	2912	return @ok if @words == 1;
	2913	return grep /^\Q$word\E/, @ok if @words == 2 && $word;
	2914	}
	2915
	2916	#-> sub CPAN::Complete::cpl_option ;
	2917	sub cpl_option {
	2918	my($word,$line,$pos) = @_;
	2919	$word \|\|= "";
	2920	my(@words) = split " ", $line;
	2921	CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
	2922	my(@ok) = qw(conf debug);
	2923	return @ok if @words == 1;
	2924	return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
	2925	if (0) {
	2926	} elsif ($words[1] eq 'index') {
	2927	return ();
	2928	} elsif ($words[1] eq 'conf') {
	2929	return CPAN::Config::cpl(@_);
	2930	} elsif ($words[1] eq 'debug') {
	2931	return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
	2932	}
	2933	}
	2934
	2935	package CPAN::Index;
	2936
	2937	#-> sub CPAN::Index::force_reload ;
	2938	sub force_reload {
	2939	my($class) = @_;
	2940	$CPAN::Index::LAST_TIME = 0;
	2941	$class->reload(1);
	2942	}
	2943
	2944	#-> sub CPAN::Index::reload ;
	2945	sub reload {
	2946	my($cl,$force) = @_;
	2947	my $time = time;
	2948
	2949	# XXX check if a newer one is available. (We currently read it
	2950	# from time to time)
	2951	for ($CPAN::Config->{index_expire}) {
	2952	$_ = 0.001 unless $_ && $_ > 0.001;
	2953	}
	2954	unless (1 \|\| $CPAN::Have_warned->{readmetadatacache}++) {
	2955	# debug here when CPAN doesn't seem to read the Metadata
	2956	require Carp;
	2957	Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
	2958	}
	2959	unless ($CPAN::META->{PROTOCOL}) {
	2960	$cl->read_metadata_cache;
	2961	$CPAN::META->{PROTOCOL} \|\|= "1.0";
	2962	}
	2963	if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
	2964	# warn "Setting last_time to 0";
	2965	$LAST_TIME = 0; # No warning necessary
	2966	}
	2967	return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
	2968	and ! $force;
	2969	if (0) {
	2970	# IFF we are developing, it helps to wipe out the memory
	2971	# between reloads, otherwise it is not what a user expects.
	2972	undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
	2973	$CPAN::META = CPAN->new;
	2974	}
	2975	{
	2976	my($debug,$t2);
	2977	local $LAST_TIME = $time;
	2978	local $CPAN::META->{PROTOCOL} = PROTOCOL;
	2979
	2980	my $needshort = $^O eq "dos";
	2981
	2982	$cl->rd_authindex($cl
	2983	->reload_x(
	2984	"authors/01mailrc.txt.gz",
	2985	$needshort ?
	2986	File::Spec->catfile('authors', '01mailrc.gz') :
	2987	File::Spec->catfile('authors', '01mailrc.txt.gz'),
	2988	$force));
	2989	$t2 = time;
	2990	$debug = "timing reading 01[".($t2 - $time)."]";
	2991	$time = $t2;
	2992	return if $CPAN::Signal; # this is sometimes lengthy
	2993	$cl->rd_modpacks($cl
	2994	->reload_x(
	2995	"modules/02packages.details.txt.gz",
	2996	$needshort ?
	2997	File::Spec->catfile('modules', '02packag.gz') :
	2998	File::Spec->catfile('modules', '02packages.details.txt.gz'),
	2999	$force));
	3000	$t2 = time;
	3001	$debug .= "02[".($t2 - $time)."]";
	3002	$time = $t2;
	3003	return if $CPAN::Signal; # this is sometimes lengthy
	3004	$cl->rd_modlist($cl
	3005	->reload_x(
	3006	"modules/03modlist.data.gz",
	3007	$needshort ?
	3008	File::Spec->catfile('modules', '03mlist.gz') :
	3009	File::Spec->catfile('modules', '03modlist.data.gz'),
	3010	$force));
	3011	$cl->write_metadata_cache;
	3012	$t2 = time;
	3013	$debug .= "03[".($t2 - $time)."]";
	3014	$time = $t2;
	3015	CPAN->debug($debug) if $CPAN::DEBUG;
	3016	}
	3017	$LAST_TIME = $time;
	3018	$CPAN::META->{PROTOCOL} = PROTOCOL;
	3019	}
	3020
	3021	#-> sub CPAN::Index::reload_x ;
	3022	sub reload_x {
	3023	my($cl,$wanted,$localname,$force) = @_;
	3024	$force \|= 2; # means we're dealing with an index here
	3025	CPAN::Config->load; # we should guarantee loading wherever we rely
	3026	# on Config XXX
	3027	$localname \|\|= $wanted;
	3028	my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
	3029	$localname);
	3030	if (
	3031	-f $abs_wanted &&
	3032	-M $abs_wanted < $CPAN::Config->{'index_expire'} &&
	3033	!($force & 1)
	3034	) {
	3035	my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
	3036	$cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
	3037	qq{day$s. I\'ll use that.});
	3038	return $abs_wanted;
	3039	} else {
	3040	$force \|= 1; # means we're quite serious about it.
	3041	}
	3042	return CPAN::FTP->localize($wanted,$abs_wanted,$force);
	3043	}
	3044
	3045	#-> sub CPAN::Index::rd_authindex ;
	3046	sub rd_authindex {
	3047	my($cl, $index_target) = @_;
	3048	my @lines;
	3049	return unless defined $index_target;
	3050	$CPAN::Frontend->myprint("Going to read $index_target\n");
	3051	local(*FH);
	3052	tie *FH, CPAN::Tarzip, $index_target;
	3053	local($/) = "\n";
	3054	push @lines, split /\012/ while <FH>;
	3055	foreach (@lines) {
	3056	my($userid,$fullname,$email) =
	3057	m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
	3058	next unless $userid && $fullname && $email;
	3059
	3060	# instantiate an author object
	3061	my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
	3062	$userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
	3063	return if $CPAN::Signal;
	3064	}
	3065	}
	3066
	3067	sub userid {
	3068	my($self,$dist) = @_;
	3069	$dist = $self->{'id'} unless defined $dist;
	3070	my($ret) = $dist =~ m\|(?:\w/\w\w/)?([^/]+)/\|;
	3071	$ret;
	3072	}
	3073
	3074	#-> sub CPAN::Index::rd_modpacks ;
	3075	sub rd_modpacks {
	3076	my($self, $index_target) = @_;
	3077	my @lines;
	3078	return unless defined $index_target;
	3079	$CPAN::Frontend->myprint("Going to read $index_target\n");
	3080	my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
	3081	local($/) = "\n";
	3082	while ($_ = $fh->READLINE) {
	3083	s/\012/\n/g;
	3084	my @ls = map {"$_\n"} split /\n/, $_;
	3085	unshift @ls, "\n" x length($1) if /^(\n+)/;
	3086	push @lines, @ls;
	3087	}
	3088	# read header
	3089	my($line_count,$last_updated);
	3090	while (@lines) {
	3091	my $shift = shift(@lines);
	3092	last if $shift =~ /^\s*$/;
	3093	$shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
	3094	$shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
	3095	}
	3096	if (not defined $line_count) {
	3097
	3098	warn qq{Warning: Your $index_target does not contain a Line-Count header.
	3099	Please check the validity of the index file by comparing it to more
	3100	than one CPAN mirror. I'll continue but problems seem likely to
	3101	happen.\a
	3102	};
	3103
	3104	sleep 5;
	3105	} elsif ($line_count != scalar @lines) {
	3106
	3107	warn sprintf qq{Warning: Your %s
	3108	contains a Line-Count header of %d but I see %d lines there. Please
	3109	check the validity of the index file by comparing it to more than one
	3110	CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
	3111	$index_target, $line_count, scalar(@lines);
	3112
	3113	}
	3114	if (not defined $last_updated) {
	3115
	3116	warn qq{Warning: Your $index_target does not contain a Last-Updated header.
	3117	Please check the validity of the index file by comparing it to more
	3118	than one CPAN mirror. I'll continue but problems seem likely to
	3119	happen.\a
	3120	};
	3121
	3122	sleep 5;
	3123	} else {
	3124
	3125	$CPAN::Frontend
	3126	->myprint(sprintf qq{ Database was generated on %s\n},
	3127	$last_updated);
	3128	$DATE_OF_02 = $last_updated;
	3129
	3130	if ($CPAN::META->has_inst(HTTP::Date)) {
	3131	require HTTP::Date;
	3132	my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
	3133	if ($age > 30) {
	3134
	3135	$CPAN::Frontend
	3136	->mywarn(sprintf
	3137	qq{Warning: This index file is %d days old.
	3138	Please check the host you chose as your CPAN mirror for staleness.
	3139	I'll continue but problems seem likely to happen.\a\n},
	3140	$age);
	3141
	3142	}
	3143	} else {
	3144	$CPAN::Frontend->myprint(" HTTP::Date not available\n");
	3145	}
	3146	}
	3147
	3148
	3149	# A necessity since we have metadata_cache: delete what isn't
	3150	# there anymore
	3151	my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
	3152	CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
	3153	my(%exists);
	3154	foreach (@lines) {
	3155	chomp;
	3156	# before 1.56 we split into 3 and discarded the rest. From
	3157	# 1.57 we assign remaining text to $comment thus allowing to
	3158	# influence isa_perl
	3159	my($mod,$version,$dist,$comment) = split " ", $_, 4;
	3160	my($bundle,$id,$userid);
	3161
	3162	if ($mod eq 'CPAN' &&
	3163	! (
	3164	CPAN::Queue->exists('Bundle::CPAN') \|\|
	3165	CPAN::Queue->exists('CPAN')
	3166	)
	3167	) {
	3168	local($^W)= 0;
	3169	if ($version > $CPAN::VERSION){
	3170	$CPAN::Frontend->myprint(qq{
	3171	There's a new CPAN.pm version (v$version) available!
	3172	[Current version is v$CPAN::VERSION]
	3173	You might want to try
	3174	install Bundle::CPAN
	3175	reload cpan
	3176	without quitting the current session. It should be a seamless upgrade
	3177	while we are running...
	3178	}); #});
	3179	sleep 2;
	3180	$CPAN::Frontend->myprint(qq{\n});
	3181	}
	3182	last if $CPAN::Signal;
	3183	} elsif ($mod =~ /^Bundle::(.*)/) {
	3184	$bundle = $1;
	3185	}
	3186
	3187	if ($bundle){
	3188	$id = $CPAN::META->instance('CPAN::Bundle',$mod);
	3189	# Let's make it a module too, because bundles have so much
	3190	# in common with modules.
	3191
	3192	# Changed in 1.57_63: seems like memory bloat now without
	3193	# any value, so commented out
	3194
	3195	# $CPAN::META->instance('CPAN::Module',$mod);
	3196
	3197	} else {
	3198
	3199	# instantiate a module object
	3200	$id = $CPAN::META->instance('CPAN::Module',$mod);
	3201
	3202	}
	3203
	3204	if ($id->cpan_file ne $dist){ # update only if file is
	3205	# different. CPAN prohibits same
	3206	# name with different version
	3207	$userid = $self->userid($dist);
	3208	$id->set(
	3209	'CPAN_USERID' => $userid,
	3210	'CPAN_VERSION' => $version,
	3211	'CPAN_FILE' => $dist,
	3212	);
	3213	}
	3214
	3215	# instantiate a distribution object
	3216	if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
	3217	# we do not need CONTAINSMODS unless we do something with
	3218	# this dist, so we better produce it on demand.
	3219
	3220	## my $obj = $CPAN::META->instance(
	3221	## 'CPAN::Distribution' => $dist
	3222	## );
	3223	## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
	3224	} else {
	3225	$CPAN::META->instance(
	3226	'CPAN::Distribution' => $dist
	3227	)->set(
	3228	'CPAN_USERID' => $userid,
	3229	'CPAN_COMMENT' => $comment,
	3230	);
	3231	}
	3232	if ($secondtime) {
	3233	for my $name ($mod,$dist) {
	3234	CPAN->debug("exists name[$name]") if $CPAN::DEBUG;
	3235	$exists{$name} = undef;
	3236	}
	3237	}
	3238	return if $CPAN::Signal;
	3239	}
	3240	undef $fh;
	3241	if ($secondtime) {
	3242	for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
	3243	for my $o ($CPAN::META->all_objects($class)) {
	3244	next if exists $exists{$o->{ID}};
	3245	$CPAN::META->delete($class,$o->{ID});
	3246	CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
	3247	if $CPAN::DEBUG;
	3248	}
	3249	}
	3250	}
	3251	}
	3252
	3253	#-> sub CPAN::Index::rd_modlist ;
	3254	sub rd_modlist {
	3255	my($cl,$index_target) = @_;
	3256	return unless defined $index_target;
	3257	$CPAN::Frontend->myprint("Going to read $index_target\n");
	3258	my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
	3259	my @eval;
	3260	local($/) = "\n";
	3261	while ($_ = $fh->READLINE) {
	3262	s/\012/\n/g;
	3263	my @ls = map {"$_\n"} split /\n/, $_;
	3264	unshift @ls, "\n" x length($1) if /^(\n+)/;
	3265	push @eval, @ls;
	3266	}
	3267	while (@eval) {
	3268	my $shift = shift(@eval);
	3269	if ($shift =~ /^Date:\s+(.*)/){
	3270	return if $DATE_OF_03 eq $1;
	3271	($DATE_OF_03) = $1;
	3272	}
	3273	last if $shift =~ /^\s*$/;
	3274	}
	3275	undef $fh;
	3276	push @eval, q{CPAN::Modulelist->data;};
	3277	local($^W) = 0;
	3278	my($comp) = Safe->new("CPAN::Safe1");
	3279	my($eval) = join("", @eval);
	3280	my $ret = $comp->reval($eval);
	3281	Carp::confess($@) if $@;
	3282	return if $CPAN::Signal;
	3283	for (keys %$ret) {
	3284	my $obj = $CPAN::META->instance("CPAN::Module",$_);
	3285	delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
	3286	$obj->set(%{$ret->{$_}});
	3287	return if $CPAN::Signal;
	3288	}
	3289	}
	3290
	3291	#-> sub CPAN::Index::write_metadata_cache ;
	3292	sub write_metadata_cache {
	3293	my($self) = @_;
	3294	return unless $CPAN::Config->{'cache_metadata'};
	3295	return unless $CPAN::META->has_usable("Storable");
	3296	my $cache;
	3297	foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
	3298	CPAN::Distribution)) {
	3299	$cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
	3300	}
	3301	my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
	3302	$cache->{last_time} = $LAST_TIME;
	3303	$cache->{DATE_OF_02} = $DATE_OF_02;
	3304	$cache->{PROTOCOL} = PROTOCOL;
	3305	$CPAN::Frontend->myprint("Going to write $metadata_file\n");
	3306	eval { Storable::nstore($cache, $metadata_file) };
	3307	$CPAN::Frontend->mywarn($@) if $@;
	3308	}
	3309
	3310	#-> sub CPAN::Index::read_metadata_cache ;
	3311	sub read_metadata_cache {
	3312	my($self) = @_;
	3313	return unless $CPAN::Config->{'cache_metadata'};
	3314	return unless $CPAN::META->has_usable("Storable");
	3315	my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
	3316	return unless -r $metadata_file and -f $metadata_file;
	3317	$CPAN::Frontend->myprint("Going to read $metadata_file\n");
	3318	my $cache;
	3319	eval { $cache = Storable::retrieve($metadata_file) };
	3320	$CPAN::Frontend->mywarn($@) if $@;
	3321	if (!$cache \|\| ref $cache ne 'HASH'){
	3322	$LAST_TIME = 0;
	3323	return;
	3324	}
	3325	if (exists $cache->{PROTOCOL}) {
	3326	if (PROTOCOL > $cache->{PROTOCOL}) {
	3327	$CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
	3328	"with protocol v%s, requiring v%s",
	3329	$cache->{PROTOCOL},
	3330	PROTOCOL)
	3331	);
	3332	return;
	3333	}
	3334	} else {
	3335	$CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
	3336	"with protocol v1.0");
	3337	return;
	3338	}
	3339	my $clcnt = 0;
	3340	my $idcnt = 0;
	3341	while(my($class,$v) = each %$cache) {
	3342	next unless $class =~ /^CPAN::/;
	3343	$CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
	3344	while (my($id,$ro) = each %$v) {
	3345	$CPAN::META->{readwrite}{$class}{$id} \|\|=
	3346	$class->new(ID=>$id, RO=>$ro);
	3347	$idcnt++;
	3348	}
	3349	$clcnt++;
	3350	}
	3351	unless ($clcnt) { # sanity check
	3352	$CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
	3353	return;
	3354	}
	3355	if ($idcnt < 1000) {
	3356	$CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
	3357	"in $metadata_file\n");
	3358	return;
	3359	}
	3360	$CPAN::META->{PROTOCOL} \|\|=
	3361	$cache->{PROTOCOL}; # reading does not up or downgrade, but it
	3362	# does initialize to some protocol
	3363	$LAST_TIME = $cache->{last_time};
	3364	$DATE_OF_02 = $cache->{DATE_OF_02};
	3365	$CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
	3366	if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
	3367	return;
	3368	}
	3369
	3370	package CPAN::InfoObj;
	3371
	3372	# Accessors
	3373	sub cpan_userid { shift->{RO}{CPAN_USERID} }
	3374	sub id { shift->{ID}; }
	3375
	3376	#-> sub CPAN::InfoObj::new ;
	3377	sub new {
	3378	my $this = bless {}, shift;
	3379	%$this = @_;
	3380	$this
	3381	}
	3382
	3383	# The set method may only be used by code that reads index data or
	3384	# otherwise "objective" data from the outside world. All session
	3385	# related material may do anything else with instance variables but
	3386	# must not touch the hash under the RO attribute. The reason is that
	3387	# the RO hash gets written to Metadata file and is thus persistent.
	3388
	3389	#-> sub CPAN::InfoObj::set ;
	3390	sub set {
	3391	my($self,%att) = @_;
	3392	my $class = ref $self;
	3393
	3394	# This must be \|\|=, not \|\|, because only if we write an empty
	3395	# reference, only then the set method will write into the readonly
	3396	# area. But for Distributions that spring into existence, maybe
	3397	# because of a typo, we do not like it that they are written into
	3398	# the readonly area and made permanent (at least for a while) and
	3399	# that is why we do not "allow" other places to call ->set.
	3400	unless ($self->id) {
	3401	CPAN->debug("Bug? Empty ID, rejecting");
	3402	return;
	3403	}
	3404	my $ro = $self->{RO} =
	3405	$CPAN::META->{readonly}{$class}{$self->id} \|\|= {};
	3406
	3407	while (my($k,$v) = each %att) {
	3408	$ro->{$k} = $v;
	3409	}
	3410	}
	3411
	3412	#-> sub CPAN::InfoObj::as_glimpse ;
	3413	sub as_glimpse {
	3414	my($self) = @_;
	3415	my(@m);
	3416	my $class = ref($self);
	3417	$class =~ s/^CPAN:://;
	3418	push @m, sprintf "%-15s %s\n", $class, $self->{ID};
	3419	join "", @m;
	3420	}
	3421
	3422	#-> sub CPAN::InfoObj::as_string ;
	3423	sub as_string {
	3424	my($self) = @_;
	3425	my(@m);
	3426	my $class = ref($self);
	3427	$class =~ s/^CPAN:://;
	3428	push @m, $class, " id = $self->{ID}\n";
	3429	for (sort keys %{$self->{RO}}) {
	3430	# next if m/^(ID\|RO)$/;
	3431	my $extra = "";
	3432	if ($_ eq "CPAN_USERID") {
	3433	$extra .= " (".$self->author;
	3434	my $email; # old perls!
	3435	if ($email = $CPAN::META->instance("CPAN::Author",
	3436	$self->cpan_userid
	3437	)->email) {
	3438	$extra .= " <$email>";
	3439	} else {
	3440	$extra .= " <no email>";
	3441	}
	3442	$extra .= ")";
	3443	} elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
	3444	push @m, sprintf " %-12s %s\n", $_, $self->fullname;
	3445	next;
	3446	}
	3447	next unless defined $self->{RO}{$_};
	3448	push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
	3449	}
	3450	for (sort keys %$self) {
	3451	next if m/^(ID\|RO)$/;
	3452	if (ref($self->{$_}) eq "ARRAY") {
	3453	push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
	3454	} elsif (ref($self->{$_}) eq "HASH") {
	3455	push @m, sprintf(
	3456	" %-12s %s\n",
	3457	$_,
	3458	join(" ",keys %{$self->{$_}}),
	3459	);
	3460	} else {
	3461	push @m, sprintf " %-12s %s\n", $_, $self->{$_};
	3462	}
	3463	}
	3464	join "", @m, "\n";
	3465	}
	3466
	3467	#-> sub CPAN::InfoObj::author ;
	3468	sub author {
	3469	my($self) = @_;
	3470	$CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
	3471	}
	3472
	3473	#-> sub CPAN::InfoObj::dump ;
	3474	sub dump {
	3475	my($self) = @_;
	3476	require Data::Dumper;
	3477	print Data::Dumper::Dumper($self);
	3478	}
	3479
	3480	package CPAN::Author;
	3481
	3482	#-> sub CPAN::Author::id
	3483	sub id {
	3484	my $self = shift;
	3485	my $id = $self->{ID};
	3486	$CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
	3487	$id;
	3488	}
	3489
	3490	#-> sub CPAN::Author::as_glimpse ;
	3491	sub as_glimpse {
	3492	my($self) = @_;
	3493	my(@m);
	3494	my $class = ref($self);
	3495	$class =~ s/^CPAN:://;
	3496	push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
	3497	$class,
	3498	$self->{ID},
	3499	$self->fullname,
	3500	$self->email);
	3501	join "", @m;
	3502	}
	3503
	3504	#-> sub CPAN::Author::fullname ;
	3505	sub fullname {
	3506	shift->{RO}{FULLNAME};
	3507	}
	3508	*name = \&fullname;
	3509
	3510	#-> sub CPAN::Author::email ;
	3511	sub email { shift->{RO}{EMAIL}; }
	3512
	3513	#-> sub CPAN::Author::ls ;
	3514	sub ls {
	3515	my $self = shift;
	3516	my $id = $self->id;
	3517
	3518	# adapted from CPAN::Distribution::verifyMD5 ;
	3519	my(@csf); # chksumfile
	3520	@csf = $self->id =~ /(.)(.)(.*)/;
	3521	$csf[1] = join "", @csf[0,1];
	3522	$csf[2] = join "", @csf[1,2];
	3523	my(@dl);
	3524	@dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0);
	3525	unless (grep {$_->[2] eq $csf[1]} @dl) {
	3526	$CPAN::Frontend->myprint("No files in the directory of $id\n");
	3527	return;
	3528	}
	3529	@dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0);
	3530	unless (grep {$_->[2] eq $csf[2]} @dl) {
	3531	$CPAN::Frontend->myprint("No files in the directory of $id\n");
	3532	return;
	3533	}
	3534	@dl = $self->dir_listing([@csf,"CHECKSUMS"], 1);
	3535	$CPAN::Frontend->myprint(join "", map {
	3536	sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
	3537	} sort { $a->[2] cmp $b->[2] } @dl);
	3538	}
	3539
	3540	# returns an array of arrays, the latter contain (size,mtime,filename)
	3541	#-> sub CPAN::Author::dir_listing ;
	3542	sub dir_listing {
	3543	my $self = shift;
	3544	my $chksumfile = shift;
	3545	my $recursive = shift;
	3546	my $lc_want =
	3547	MM->catfile($CPAN::Config->{keep_source_where},
	3548	"authors", "id", @$chksumfile);
	3549	local($") = "/";
	3550	# connect "force" argument with "index_expire".
	3551	my $force = 0;
	3552	if (my @stat = stat $lc_want) {
	3553	$force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
	3554	}
	3555	my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
	3556	$lc_want,$force);
	3557	unless ($lc_file) {
	3558	$CPAN::Frontend->myprint("Trying $lc_want.gz\n");
	3559	$chksumfile->[-1] .= ".gz";
	3560	$lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
	3561	"$lc_want.gz",1);
	3562	if ($lc_file) {
	3563	$lc_file =~ s{\.gz(?!\n)\Z}{}; #};
	3564	CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
	3565	} else {
	3566	return;
	3567	}
	3568	}
	3569
	3570	# adapted from CPAN::Distribution::MD5_check_file ;
	3571	my $fh = FileHandle->new;
	3572	my($cksum);
	3573	if (open $fh, $lc_file){
	3574	local($/);
	3575	my $eval = <$fh>;
	3576	$eval =~ s/\015?\012/\n/g;
	3577	close $fh;
	3578	my($comp) = Safe->new();
	3579	$cksum = $comp->reval($eval);
	3580	if ($@) {
	3581	rename $lc_file, "$lc_file.bad";
	3582	Carp::confess($@) if $@;
	3583	}
	3584	} else {
	3585	Carp::carp "Could not open $lc_file for reading";
	3586	}
	3587	my(@result,$f);
	3588	for $f (sort keys %$cksum) {
	3589	if (exists $cksum->{$f}{isdir}) {
	3590	if ($recursive) {
	3591	my(@dir) = @$chksumfile;
	3592	pop @dir;
	3593	push @dir, $f, "CHECKSUMS";
	3594	push @result, map {
	3595	[$_->[0], $_->[1], "$f/$_->[2]"]
	3596	} $self->dir_listing(\@dir,1);
	3597	} else {
	3598	push @result, [ 0, "-", $f ];
	3599	}
	3600	} else {
	3601	push @result, [
	3602	($cksum->{$f}{"size"}\|\|0),
	3603	$cksum->{$f}{"mtime"}\|\|"---",
	3604	$f
	3605	];
	3606	}
	3607	}
	3608	@result;
	3609	}
	3610
	3611	package CPAN::Distribution;
	3612
	3613	# Accessors
	3614	sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
	3615
	3616	sub undelay {
	3617	my $self = shift;
	3618	delete $self->{later};
	3619	}
	3620
	3621	# CPAN::Distribution::normalize
	3622	sub normalize {
	3623	my($self,$s) = @_;
	3624	$s = $self->id unless defined $s;
	3625	if (
	3626	$s =~ tr\|/\|\| == 1
	3627	or
	3628	$s !~ m\|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/\|
	3629	) {
	3630	return $s if $s =~ m:^N/A\|^Contact Author: ;
	3631	$s =~ s\|^(.)(.)([^/]*/)(.+)$\|$1/$1$2/$1$2$3$4\| or
	3632	$CPAN::Frontend->mywarn("Strange distribution name [$s]");
	3633	CPAN->debug("s[$s]") if $CPAN::DEBUG;
	3634	}
	3635	$s;
	3636	}
	3637
	3638	#-> sub CPAN::Distribution::color_cmd_tmps ;
	3639	sub color_cmd_tmps {
	3640	my($self) = shift;
	3641	my($depth) = shift \|\| 0;
	3642	my($color) = shift \|\| 0;
	3643	# a distribution needs to recurse into its prereq_pms
	3644
	3645	return if exists $self->{incommandcolor}
	3646	&& $self->{incommandcolor}==$color;
	3647	$CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
	3648	"color_cmd_tmps depth[%s] self[%s] id[%s]",
	3649	$depth,
	3650	$self,
	3651	$self->id
	3652	)) if $depth>=100;
	3653	##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
	3654	my $prereq_pm = $self->prereq_pm;
	3655	if (defined $prereq_pm) {
	3656	for my $pre (keys %$prereq_pm) {
	3657	my $premo = CPAN::Shell->expand("Module",$pre);
	3658	$premo->color_cmd_tmps($depth+1,$color);
	3659	}
	3660	}
	3661	if ($color==0) {
	3662	delete $self->{sponsored_mods};
	3663	delete $self->{badtestcnt};
	3664	}
	3665	$self->{incommandcolor} = $color;
	3666	}
	3667
	3668	#-> sub CPAN::Distribution::as_string ;
	3669	sub as_string {
	3670	my $self = shift;
	3671	$self->containsmods;
	3672	$self->SUPER::as_string(@_);
	3673	}
	3674
	3675	#-> sub CPAN::Distribution::containsmods ;
	3676	sub containsmods {
	3677	my $self = shift;
	3678	return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
	3679	my $dist_id = $self->{ID};
	3680	for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
	3681	my $mod_file = $mod->cpan_file or next;
	3682	my $mod_id = $mod->{ID} or next;
	3683	# warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
	3684	# sleep 1;
	3685	$self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
	3686	}
	3687	keys %{$self->{CONTAINSMODS}};
	3688	}
	3689
	3690	#-> sub CPAN::Distribution::uptodate ;
	3691	sub uptodate {
	3692	my($self) = @_;
	3693	my $c;
	3694	foreach $c ($self->containsmods) {
	3695	my $obj = CPAN::Shell->expandany($c);
	3696	return 0 unless $obj->uptodate;
	3697	}
	3698	return 1;
	3699	}
	3700
	3701	#-> sub CPAN::Distribution::called_for ;
	3702	sub called_for {
	3703	my($self,$id) = @_;
	3704	$self->{CALLED_FOR} = $id if defined $id;
	3705	return $self->{CALLED_FOR};
	3706	}
	3707
	3708	#-> sub CPAN::Distribution::safe_chdir ;
	3709	sub safe_chdir {
	3710	my($self,$todir) = @_;
	3711	# we die if we cannot chdir and we are debuggable
	3712	Carp::confess("safe_chdir called without todir argument")
	3713	unless defined $todir and length $todir;
	3714	if (chdir $todir) {
	3715	$self->debug(sprintf "changed directory to %s", CPAN::anycwd())
	3716	if $CPAN::DEBUG;
	3717	} else {
	3718	my $cwd = CPAN::anycwd();
	3719	$CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
	3720	qq{to todir[$todir]: $!});
	3721	}
	3722	}
	3723
	3724	#-> sub CPAN::Distribution::get ;
	3725	sub get {
	3726	my($self) = @_;
	3727	EXCUSE: {
	3728	my @e;
	3729	exists $self->{'build_dir'} and push @e,
	3730	"Is already unwrapped into directory $self->{'build_dir'}";
	3731	$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
	3732	}
	3733	my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
	3734
	3735	#
	3736	# Get the file on local disk
	3737	#
	3738
	3739	my($local_file);
	3740	my($local_wanted) =
	3741	MM->catfile(
	3742	$CPAN::Config->{keep_source_where},
	3743	"authors",
	3744	"id",
	3745	split("/",$self->id)
	3746	);
	3747
	3748	$self->debug("Doing localize") if $CPAN::DEBUG;
	3749	unless ($local_file =
	3750	CPAN::FTP->localize("authors/id/$self->{ID}",
	3751	$local_wanted)) {
	3752	my $note = "";
	3753	if ($CPAN::Index::DATE_OF_02) {
	3754	$note = "Note: Current database in memory was generated ".
	3755	"on $CPAN::Index::DATE_OF_02\n";
	3756	}
	3757	$CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
	3758	}
	3759	$self->debug("local_file[$local_file]") if $CPAN::DEBUG;
	3760	$self->{localfile} = $local_file;
	3761	return if $CPAN::Signal;
	3762
	3763	#
	3764	# Check integrity
	3765	#
	3766	if ($CPAN::META->has_inst("Digest::MD5")) {
	3767	$self->debug("Digest::MD5 is installed, verifying");
	3768	$self->verifyMD5;
	3769	} else {
	3770	$self->debug("Digest::MD5 is NOT installed");
	3771	}
	3772	return if $CPAN::Signal;
	3773
	3774	#
	3775	# Create a clean room and go there
	3776	#
	3777	$CPAN::META->{cachemgr} \|\|= CPAN::CacheMgr->new(); # unsafe meta access, ok
	3778	my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
	3779	$self->safe_chdir($builddir);
	3780	$self->debug("Removing tmp") if $CPAN::DEBUG;
	3781	File::Path::rmtree("tmp");
	3782	mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
	3783	if ($CPAN::Signal){
	3784	$self->safe_chdir($sub_wd);
	3785	return;
	3786	}
	3787	$self->safe_chdir("tmp");
	3788
	3789	#
	3790	# Unpack the goods
	3791	#
	3792	if ($local_file =~ /(\.tar\.(gz\|Z)\|\.tgz)(?!\n)\Z/i){
	3793	$self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
	3794	$self->untar_me($local_file);
	3795	} elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
	3796	$self->unzip_me($local_file);
	3797	} elsif ( $local_file =~ /\.pm\.(gz\|Z)(?!\n)\Z/) {
	3798	$self->{was_uncompressed}++ unless CPAN::Tarzip->gtest($local_file);
	3799	$self->pm2dir_me($local_file);
	3800	} else {
	3801	$self->{archived} = "NO";
	3802	$self->safe_chdir($sub_wd);
	3803	return;
	3804	}
	3805
	3806	# we are still in the tmp directory!
	3807	# Let's check if the package has its own directory.
	3808	my $dh = DirHandle->new(File::Spec->curdir)
	3809	or Carp::croak("Couldn't opendir .: $!");
	3810	my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
	3811	$dh->close;
	3812	my ($distdir,$packagedir);
	3813	if (@readdir == 1 && -d $readdir[0]) {
	3814	$distdir = $readdir[0];
	3815	$packagedir = MM->catdir($builddir,$distdir);
	3816	$self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
	3817	if $CPAN::DEBUG;
	3818	-d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
	3819	"$packagedir\n");
	3820	File::Path::rmtree($packagedir);
	3821	rename($distdir,$packagedir) or
	3822	Carp::confess("Couldn't rename $distdir to $packagedir: $!");
	3823	$self->debug(sprintf("renamed distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
	3824	$distdir,
	3825	$packagedir,
	3826	-e $packagedir,
	3827	-d $packagedir,
	3828	)) if $CPAN::DEBUG;
	3829	} else {
	3830	my $userid = $self->cpan_userid;
	3831	unless ($userid) {
	3832	CPAN->debug("no userid? self[$self]");
	3833	$userid = "anon";
	3834	}
	3835	my $pragmatic_dir = $userid . '000';
	3836	$pragmatic_dir =~ s/\W_//g;
	3837	$pragmatic_dir++ while -d "../$pragmatic_dir";
	3838	$packagedir = MM->catdir($builddir,$pragmatic_dir);
	3839	$self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
	3840	File::Path::mkpath($packagedir);
	3841	my($f);
	3842	for $f (@readdir) { # is already without "." and ".."
	3843	my $to = MM->catdir($packagedir,$f);
	3844	rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
	3845	}
	3846	}
	3847	if ($CPAN::Signal){
	3848	$self->safe_chdir($sub_wd);
	3849	return;
	3850	}
	3851
	3852	$self->{'build_dir'} = $packagedir;
	3853	$self->safe_chdir(File::Spec->updir);
	3854	File::Path::rmtree("tmp");
	3855
	3856	my($mpl) = MM->catfile($packagedir,"Makefile.PL");
	3857	my($mpl_exists) = -f $mpl;
	3858	unless ($mpl_exists) {
	3859	# NFS has been reported to have racing problems after the
	3860	# renaming of a directory in some environments.
	3861	# This trick helps.
	3862	sleep 1;
	3863	my $mpldh = DirHandle->new($packagedir)
	3864	or Carp::croak("Couldn't opendir $packagedir: $!");
	3865	$mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
	3866	$mpldh->close;
	3867	}
	3868	unless ($mpl_exists) {
	3869	$self->debug(sprintf("makefilepl[%s]anycwd[%s]",
	3870	$mpl,
	3871	CPAN::anycwd(),
	3872	)) if $CPAN::DEBUG;
	3873	my($configure) = MM->catfile($packagedir,"Configure");
	3874	if (-f $configure) {
	3875	# do we have anything to do?
	3876	$self->{'configure'} = $configure;
	3877	} elsif (-f MM->catfile($packagedir,"Makefile")) {
	3878	$CPAN::Frontend->myprint(qq{
	3879	Package comes with a Makefile and without a Makefile.PL.
	3880	We\'ll try to build it with that Makefile then.
	3881	});
	3882	$self->{writemakefile} = "YES";
	3883	sleep 2;
	3884	} else {
	3885	my $cf = $self->called_for \|\| "unknown";
	3886	if ($cf =~ m\|/\|) {
	3887	$cf =~ s\|.*/\|\|;
	3888	$cf =~ s\|\W.*\|\|;
	3889	}
	3890	$cf =~ s\|[/\\:]\|\|g; # risk of filesystem damage
	3891	$cf = "unknown" unless length($cf);
	3892	$CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
	3893	(The test -f "$mpl" returned false.)
	3894	Writing one on our own (setting NAME to $cf)\a\n});
	3895	$self->{had_no_makefile_pl}++;
	3896	sleep 3;
	3897
	3898	# Writing our own Makefile.PL
	3899
	3900	my $fh = FileHandle->new;
	3901	$fh->open(">$mpl")
	3902	or Carp::croak("Could not open >$mpl: $!");
	3903	$fh->print(
	3904	qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
	3905	# because there was no Makefile.PL supplied.
	3906	# Autogenerated on: }.scalar localtime().qq{
	3907
	3908	use ExtUtils::MakeMaker;
	3909	WriteMakefile(NAME => q[$cf]);
	3910
	3911	});
	3912	$fh->close;
	3913	}
	3914	}
	3915
	3916	return $self;
	3917	}
	3918
	3919	# CPAN::Distribution::untar_me ;
	3920	sub untar_me {
	3921	my($self,$local_file) = @_;
	3922	$self->{archived} = "tar";
	3923	if (CPAN::Tarzip->untar($local_file)) {
	3924	$self->{unwrapped} = "YES";
	3925	} else {
	3926	$self->{unwrapped} = "NO";
	3927	}
	3928	}
	3929
	3930	# CPAN::Distribution::unzip_me ;
	3931	sub unzip_me {
	3932	my($self,$local_file) = @_;
	3933	$self->{archived} = "zip";
	3934	if (CPAN::Tarzip->unzip($local_file)) {
	3935	$self->{unwrapped} = "YES";
	3936	} else {
	3937	$self->{unwrapped} = "NO";
	3938	}
	3939	return;
	3940	}
	3941
	3942	sub pm2dir_me {
	3943	my($self,$local_file) = @_;
	3944	$self->{archived} = "pm";
	3945	my $to = File::Basename::basename($local_file);
	3946	$to =~ s/\.(gz\|Z)(?!\n)\Z//;
	3947	if (CPAN::Tarzip->gunzip($local_file,$to)) {
	3948	$self->{unwrapped} = "YES";
	3949	} else {
	3950	$self->{unwrapped} = "NO";
	3951	}
	3952	}
	3953
	3954	#-> sub CPAN::Distribution::new ;
	3955	sub new {
	3956	my($class,%att) = @_;
	3957
	3958	# $CPAN::META->{cachemgr} \|\|= CPAN::CacheMgr->new();
	3959
	3960	my $this = { %att };
	3961	return bless $this, $class;
	3962	}
	3963
	3964	#-> sub CPAN::Distribution::look ;
	3965	sub look {
	3966	my($self) = @_;
	3967
	3968	if ($^O eq 'MacOS') {
	3969	$self->Mac::BuildTools::look;
	3970	return;
	3971	}
	3972
	3973	if ( $CPAN::Config->{'shell'} ) {
	3974	$CPAN::Frontend->myprint(qq{
	3975	Trying to open a subshell in the build directory...
	3976	});
	3977	} else {
	3978	$CPAN::Frontend->myprint(qq{
	3979	Your configuration does not define a value for subshells.
	3980	Please define it with "o conf shell <your shell>"
	3981	});
	3982	return;
	3983	}
	3984	my $dist = $self->id;
	3985	my $dir;
	3986	unless ($dir = $self->dir) {
	3987	$self->get;
	3988	}
	3989	unless ($dir \|\|= $self->dir) {
	3990	$CPAN::Frontend->mywarn(qq{
	3991	Could not determine which directory to use for looking at $dist.
	3992	});
	3993	return;
	3994	}
	3995	my $pwd = CPAN::anycwd();
	3996	$self->safe_chdir($dir);
	3997	$CPAN::Frontend->myprint(qq{Working directory is $dir\n});
	3998	system($CPAN::Config->{'shell'}) == 0
	3999	or $CPAN::Frontend->mydie("Subprocess shell error");
	4000	$self->safe_chdir($pwd);
	4001	}
	4002
	4003	# CPAN::Distribution::cvs_import ;
	4004	sub cvs_import {
	4005	my($self) = @_;
	4006	$self->get;
	4007	my $dir = $self->dir;
	4008
	4009	my $package = $self->called_for;
	4010	my $module = $CPAN::META->instance('CPAN::Module', $package);
	4011	my $version = $module->cpan_version;
	4012
	4013	my $userid = $self->cpan_userid;
	4014
	4015	my $cvs_dir = (split '/', $dir)[-1];
	4016	$cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
	4017	my $cvs_root =
	4018	$CPAN::Config->{cvsroot} \|\| $ENV{CVSROOT};
	4019	my $cvs_site_perl =
	4020	$CPAN::Config->{cvs_site_perl} \|\| $ENV{CVS_SITE_PERL};
	4021	if ($cvs_site_perl) {
	4022	$cvs_dir = "$cvs_site_perl/$cvs_dir";
	4023	}
	4024	my $cvs_log = qq{"imported $package $version sources"};
	4025	$version =~ s/\./_/g;
	4026	my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
	4027	"$cvs_dir", $userid, "v$version");
	4028
	4029	my $pwd = CPAN::anycwd();
	4030	chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
	4031
	4032	$CPAN::Frontend->myprint(qq{Working directory is $dir\n});
	4033
	4034	$CPAN::Frontend->myprint(qq{@cmd\n});
	4035	system(@cmd) == 0 or
	4036	$CPAN::Frontend->mydie("cvs import failed");
	4037	chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
	4038	}
	4039
	4040	#-> sub CPAN::Distribution::readme ;
	4041	sub readme {
	4042	my($self) = @_;
	4043	my($dist) = $self->id;
	4044	my($sans,$suffix) = $dist =~ /(.+)\.(tgz\|tar[\._-]gz\|tar\.Z\|zip)$/;
	4045	$self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
	4046	my($local_file);
	4047	my($local_wanted) =
	4048	MM->catfile(
	4049	$CPAN::Config->{keep_source_where},
	4050	"authors",
	4051	"id",
	4052	split("/","$sans.readme"),
	4053	);
	4054	$self->debug("Doing localize") if $CPAN::DEBUG;
	4055	$local_file = CPAN::FTP->localize("authors/id/$sans.readme",
	4056	$local_wanted)
	4057	or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
	4058
	4059	if ($^O eq 'MacOS') {
	4060	Mac::BuildTools::launch_file($local_file);
	4061	return;
	4062	}
	4063
	4064	my $fh_pager = FileHandle->new;
	4065	local($SIG{PIPE}) = "IGNORE";
	4066	$fh_pager->open("\|$CPAN::Config->{'pager'}")
	4067	or die "Could not open pager $CPAN::Config->{'pager'}: $!";
	4068	my $fh_readme = FileHandle->new;
	4069	$fh_readme->open($local_file)
	4070	or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
	4071	$CPAN::Frontend->myprint(qq{
	4072	Displaying file
	4073	$local_file
	4074	with pager "$CPAN::Config->{'pager'}"
	4075	});
	4076	sleep 2;
	4077	$fh_pager->print(<$fh_readme>);
	4078	}
	4079
	4080	#-> sub CPAN::Distribution::verifyMD5 ;
	4081	sub verifyMD5 {
	4082	my($self) = @_;
	4083	EXCUSE: {
	4084	my @e;
	4085	$self->{MD5_STATUS} \|\|= "";
	4086	$self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
	4087	$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
	4088	}
	4089	my($lc_want,$lc_file,@local,$basename);
	4090	@local = split("/",$self->id);
	4091	pop @local;
	4092	push @local, "CHECKSUMS";
	4093	$lc_want =
	4094	MM->catfile($CPAN::Config->{keep_source_where},
	4095	"authors", "id", @local);
	4096	local($") = "/";
	4097	if (
	4098	-s $lc_want
	4099	&&
	4100	$self->MD5_check_file($lc_want)
	4101	) {
	4102	return $self->{MD5_STATUS} = "OK";
	4103	}
	4104	$lc_file = CPAN::FTP->localize("authors/id/@local",
	4105	$lc_want,1);
	4106	unless ($lc_file) {
	4107	$CPAN::Frontend->myprint("Trying $lc_want.gz\n");
	4108	$local[-1] .= ".gz";
	4109	$lc_file = CPAN::FTP->localize("authors/id/@local",
	4110	"$lc_want.gz",1);
	4111	if ($lc_file) {
	4112	$lc_file =~ s/\.gz(?!\n)\Z//;
	4113	CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
	4114	} else {
	4115	return;
	4116	}
	4117	}
	4118	$self->MD5_check_file($lc_file);
	4119	}
	4120
	4121	#-> sub CPAN::Distribution::MD5_check_file ;
	4122	sub MD5_check_file {
	4123	my($self,$chk_file) = @_;
	4124	my($cksum,$file,$basename);
	4125	$file = $self->{localfile};
	4126	$basename = File::Basename::basename($file);
	4127	my $fh = FileHandle->new;
	4128	if (open $fh, $chk_file){
	4129	local($/);
	4130	my $eval = <$fh>;
	4131	$eval =~ s/\015?\012/\n/g;
	4132	close $fh;
	4133	my($comp) = Safe->new();
	4134	$cksum = $comp->reval($eval);
	4135	if ($@) {
	4136	rename $chk_file, "$chk_file.bad";
	4137	Carp::confess($@) if $@;
	4138	}
	4139	} else {
	4140	Carp::carp "Could not open $chk_file for reading";
	4141	}
	4142
	4143	if (exists $cksum->{$basename}{md5}) {
	4144	$self->debug("Found checksum for $basename:" .
	4145	"$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
	4146
	4147	open($fh, $file);
	4148	binmode $fh;
	4149	my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
	4150	$fh->close;
	4151	$fh = CPAN::Tarzip->TIEHANDLE($file);
	4152
	4153	unless ($eq) {
	4154	# had to inline it, when I tied it, the tiedness got lost on
	4155	# the call to eq_MD5. (Jan 1998)
	4156	my $md5 = Digest::MD5->new;
	4157	my($data,$ref);
	4158	$ref = \$data;
	4159	while ($fh->READ($ref, 4096) > 0){
	4160	$md5->add($data);
	4161	}
	4162	my $hexdigest = $md5->hexdigest;
	4163	$eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
	4164	}
	4165
	4166	if ($eq) {
	4167	$CPAN::Frontend->myprint("Checksum for $file ok\n");
	4168	return $self->{MD5_STATUS} = "OK";
	4169	} else {
	4170	$CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
	4171	qq{distribution file. }.
	4172	qq{Please investigate.\n\n}.
	4173	$self->as_string,
	4174	$CPAN::META->instance(
	4175	'CPAN::Author',
	4176	$self->cpan_userid
	4177	)->as_string);
	4178
	4179	my $wrap = qq{I\'d recommend removing $file. Its MD5
	4180	checksum is incorrect. Maybe you have configured your 'urllist' with
	4181	a bad URL. Please check this array with 'o conf urllist', and
	4182	retry.};
	4183
	4184	$CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
	4185
	4186	# former versions just returned here but this seems a
	4187	# serious threat that deserves a die
	4188
	4189	# $CPAN::Frontend->myprint("\n\n");
	4190	# sleep 3;
	4191	# return;
	4192	}
	4193	# close $fh if fileno($fh);
	4194	} else {
	4195	$self->{MD5_STATUS} \|\|= "";
	4196	if ($self->{MD5_STATUS} eq "NIL") {
	4197	$CPAN::Frontend->mywarn(qq{
	4198	Warning: No md5 checksum for $basename in $chk_file.
	4199
	4200	The cause for this may be that the file is very new and the checksum
	4201	has not yet been calculated, but it may also be that something is
	4202	going awry right now.
	4203	});
	4204	my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
	4205	$answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.");
	4206	}
	4207	$self->{MD5_STATUS} = "NIL";
	4208	return;
	4209	}
	4210	}
	4211
	4212	#-> sub CPAN::Distribution::eq_MD5 ;
	4213	sub eq_MD5 {
	4214	my($self,$fh,$expectMD5) = @_;
	4215	my $md5 = Digest::MD5->new;
	4216	my($data);
	4217	while (read($fh, $data, 4096)){
	4218	$md5->add($data);
	4219	}
	4220	# $md5->addfile($fh);
	4221	my $hexdigest = $md5->hexdigest;
	4222	# warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
	4223	$hexdigest eq $expectMD5;
	4224	}
	4225
	4226	#-> sub CPAN::Distribution::force ;
	4227
	4228	# Both modules and distributions know if "force" is in effect by
	4229	# autoinspection, not by inspecting a global variable. One of the
	4230	# reason why this was chosen to work that way was the treatment of
	4231	# dependencies. They should not autpomatically inherit the force
	4232	# status. But this has the downside that ^C and die() will return to
	4233	# the prompt but will not be able to reset the force_update
	4234	# attributes. We try to correct for it currently in the read_metadata
	4235	# routine, and immediately before we check for a Signal. I hope this
	4236	# works out in one of v1.57_53ff
	4237
	4238	sub force {
	4239	my($self, $method) = @_;
	4240	for my $att (qw(
	4241	MD5_STATUS archived build_dir localfile make install unwrapped
	4242	writemakefile
	4243	)) {
	4244	delete $self->{$att};
	4245	}
	4246	if ($method && $method eq "install") {
	4247	$self->{"force_update"}++; # name should probably have been force_install
	4248	}
	4249	}
	4250
	4251	#-> sub CPAN::Distribution::unforce ;
	4252	sub unforce {
	4253	my($self) = @_;
	4254	delete $self->{'force_update'};
	4255	}
	4256
	4257	#-> sub CPAN::Distribution::isa_perl ;
	4258	sub isa_perl {
	4259	my($self) = @_;
	4260	my $file = File::Basename::basename($self->id);
	4261	if ($file =~ m{ ^ perl
	4262	-?
	4263	(5)
	4264	([._-])
	4265	(
	4266	\d{3}(_[0-4][0-9])?
	4267	\|
	4268	\d*[24680]\.\d+
	4269	)
	4270	\.tar[._-]gz
	4271	(?!\n)\Z
	4272	}xs){
	4273	return "$1.$3";
	4274	} elsif ($self->cpan_comment
	4275	&&
	4276	$self->cpan_comment =~ /isa_perl$.+?$/){
	4277	return $1;
	4278	}
	4279	}
	4280
	4281	#-> sub CPAN::Distribution::perl ;
	4282	sub perl {
	4283	my($self) = @_;
	4284	my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
	4285	my $pwd = CPAN::anycwd();
	4286	my $candidate = MM->catfile($pwd,$^X);
	4287	$perl \|\|= $candidate if MM->maybe_command($candidate);
	4288	unless ($perl) {
	4289	my ($component,$perl_name);
	4290	DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
	4291	PATH_COMPONENT: foreach $component (MM->path(),
	4292	$Config::Config{'binexp'}) {
	4293	next unless defined($component) && $component;
	4294	my($abs) = MM->catfile($component,$perl_name);
	4295	if (MM->maybe_command($abs)) {
	4296	$perl = $abs;
	4297	last DIST_PERLNAME;
	4298	}
	4299	}
	4300	}
	4301	}
	4302	$perl;
	4303	}
	4304
	4305	#-> sub CPAN::Distribution::make ;
	4306	sub make {
	4307	my($self) = @_;
	4308	$CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
	4309	# Emergency brake if they said install Pippi and get newest perl
	4310	if ($self->isa_perl) {
	4311	if (
	4312	$self->called_for ne $self->id &&
	4313	! $self->{force_update}
	4314	) {
	4315	# if we die here, we break bundles
	4316	$CPAN::Frontend->mywarn(sprintf qq{
	4317	The most recent version "%s" of the module "%s"
	4318	comes with the current version of perl (%s).
	4319	I\'ll build that only if you ask for something like
	4320	force install %s
	4321	or
	4322	install %s
	4323	},
	4324	$CPAN::META->instance(
	4325	'CPAN::Module',
	4326	$self->called_for
	4327	)->cpan_version,
	4328	$self->called_for,
	4329	$self->isa_perl,
	4330	$self->called_for,
	4331	$self->id);
	4332	sleep 5; return;
	4333	}
	4334	}
	4335	$self->get;
	4336	EXCUSE: {
	4337	my @e;
	4338	$self->{archived} eq "NO" and push @e,
	4339	"Is neither a tar nor a zip archive.";
	4340
	4341	$self->{unwrapped} eq "NO" and push @e,
	4342	"had problems unarchiving. Please build manually";
	4343
	4344	exists $self->{writemakefile} &&
	4345	$self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
	4346	$1 \|\| "Had some problem writing Makefile";
	4347
	4348	defined $self->{'make'} and push @e,
	4349	"Has already been processed within this session";
	4350
	4351	exists $self->{later} and length($self->{later}) and
	4352	push @e, $self->{later};
	4353
	4354	$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
	4355	}
	4356	$CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
	4357	my $builddir = $self->dir;
	4358	chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
	4359	$self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
	4360
	4361	if ($^O eq 'MacOS') {
	4362	Mac::BuildTools::make($self);
	4363	return;
	4364	}
	4365
	4366	my $system;
	4367	if ($self->{'configure'}) {
	4368	$system = $self->{'configure'};
	4369	} else {
	4370	my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
	4371	my $switch = "";
	4372	# This needs a handler that can be turned on or off:
	4373	# $switch = "-MExtUtils::MakeMaker ".
	4374	# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
	4375	# if $] > 5.00310;
	4376	$system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
	4377	}
	4378	unless (exists $self->{writemakefile}) {
	4379	local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
	4380	my($ret,$pid);
	4381	$@ = "";
	4382	if ($CPAN::Config->{inactivity_timeout}) {
	4383	eval {
	4384	alarm $CPAN::Config->{inactivity_timeout};
	4385	local $SIG{CHLD}; # = sub { wait };
	4386	if (defined($pid = fork)) {
	4387	if ($pid) { #parent
	4388	# wait;
	4389	waitpid $pid, 0;
	4390	} else { #child
	4391	# note, this exec isn't necessary if
	4392	# inactivity_timeout is 0. On the Mac I'd
	4393	# suggest, we set it always to 0.
	4394	exec $system;
	4395	}
	4396	} else {
	4397	$CPAN::Frontend->myprint("Cannot fork: $!");
	4398	return;
	4399	}
	4400	};
	4401	alarm 0;
	4402	if ($@){
	4403	kill 9, $pid;
	4404	waitpid $pid, 0;
	4405	$CPAN::Frontend->myprint($@);
	4406	$self->{writemakefile} = "NO $@";
	4407	$@ = "";
	4408	return;
	4409	}
	4410	} else {
	4411	$ret = system($system);
	4412	if ($ret != 0) {
	4413	$self->{writemakefile} = "NO Makefile.PL returned status $ret";
	4414	return;
	4415	}
	4416	}
	4417	if (-f "Makefile") {
	4418	$self->{writemakefile} = "YES";
	4419	delete $self->{make_clean}; # if cleaned before, enable next
	4420	} else {
	4421	$self->{writemakefile} =
	4422	qq{NO Makefile.PL refused to write a Makefile.};
	4423	# It's probably worth it to record the reason, so let's retry
	4424	# local $/;
	4425	# my $fh = IO::File->new("$system \|"); # STDERR? STDIN?
	4426	# $self->{writemakefile} .= <$fh>;
	4427	}
	4428	}
	4429	if ($CPAN::Signal){
	4430	delete $self->{force_update};
	4431	return;
	4432	}
	4433	if (my @prereq = $self->unsat_prereq){
	4434	return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
	4435	}
	4436	$system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
	4437	if (system($system) == 0) {
	4438	$CPAN::Frontend->myprint(" $system -- OK\n");
	4439	$self->{'make'} = "YES";
	4440	} else {
	4441	$self->{writemakefile} \|\|= "YES";
	4442	$self->{'make'} = "NO";
	4443	$CPAN::Frontend->myprint(" $system -- NOT OK\n");
	4444	}
	4445	}
	4446
	4447	sub follow_prereqs {
	4448	my($self) = shift;
	4449	my(@prereq) = @_;
	4450	my $id = $self->id;
	4451	$CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ".
	4452	"during [$id] -----\n");
	4453
	4454	for my $p (@prereq) {
	4455	$CPAN::Frontend->myprint(" $p\n");
	4456	}
	4457	my $follow = 0;
	4458	if ($CPAN::Config->{prerequisites_policy} eq "follow") {
	4459	$follow = 1;
	4460	} elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
	4461	require ExtUtils::MakeMaker;
	4462	my $answer = ExtUtils::MakeMaker::prompt(
	4463	"Shall I follow them and prepend them to the queue
	4464	of modules we are processing right now?", "yes");
	4465	$follow = $answer =~ /^\s*y/i;
	4466	} else {
	4467	local($") = ", ";
	4468	$CPAN::Frontend->
	4469	myprint(" Ignoring dependencies on modules @prereq\n");
	4470	}
	4471	if ($follow) {
	4472	# color them as dirty
	4473	for my $p (@prereq) {
	4474	CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
	4475	}
	4476	CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
	4477	$self->{later} = "Delayed until after prerequisites";
	4478	return 1; # signal success to the queuerunner
	4479	}
	4480	}
	4481
	4482	#-> sub CPAN::Distribution::unsat_prereq ;
	4483	sub unsat_prereq {
	4484	my($self) = @_;
	4485	my $prereq_pm = $self->prereq_pm or return;
	4486	my(@need);
	4487	NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
	4488	my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
	4489	# we were too demanding:
	4490	next if $nmo->uptodate;
	4491
	4492	# if they have not specified a version, we accept any installed one
	4493	if (not defined $need_version or
	4494	$need_version == 0 or
	4495	$need_version eq "undef") {
	4496	next if defined $nmo->inst_file;
	4497	}
	4498
	4499	# We only want to install prereqs if either they're not installed
	4500	# or if the installed version is too old. We cannot omit this
	4501	# check, because if 'force' is in effect, nobody else will check.
	4502	{
	4503	local($^W) = 0;
	4504	if (
	4505	defined $nmo->inst_file &&
	4506	! CPAN::Version->vgt($need_version, $nmo->inst_version)
	4507	){
	4508	CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]need_version[%s]",
	4509	$nmo->id,
	4510	$nmo->inst_file,
	4511	$nmo->inst_version,
	4512	CPAN::Version->readable($need_version)
	4513	);
	4514	next NEED;
	4515	}
	4516	}
	4517
	4518	if ($self->{sponsored_mods}{$need_module}++){
	4519	# We have already sponsored it and for some reason it's still
	4520	# not available. So we do nothing. Or what should we do?
	4521	# if we push it again, we have a potential infinite loop
	4522	next;
	4523	}
	4524	push @need, $need_module;
	4525	}
	4526	@need;
	4527	}
	4528
	4529	#-> sub CPAN::Distribution::prereq_pm ;
	4530	sub prereq_pm {
	4531	my($self) = @_;
	4532	return $self->{prereq_pm} if
	4533	exists $self->{prereq_pm_detected} && $self->{prereq_pm_detected};
	4534	return unless $self->{writemakefile}; # no need to have succeeded
	4535	# but we must have run it
	4536	my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
	4537	my $makefile = File::Spec->catfile($build_dir,"Makefile");
	4538	my(%p) = ();
	4539	my $fh;
	4540	if (-f $makefile
	4541	and
	4542	$fh = FileHandle->new("<$makefile\0")) {
	4543
	4544	local($/) = "\n";
	4545
	4546	# A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
	4547	while (<$fh>) {
	4548	last if /MakeMaker post_initialize section/;
	4549	my($p) = m{^[\#]
	4550	\s+PREREQ_PM\s+=>\s+(.+)
	4551	}x;
	4552	next unless $p;
	4553	# warn "Found prereq expr[$p]";
	4554
	4555	# Regexp modified by A.Speer to remember actual version of file
	4556	# PREREQ_PM hash key wants, then add to
	4557	while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
	4558	# In case a prereq is mentioned twice, complain.
	4559	if ( defined $p{$1} ) {
	4560	warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
	4561	}
	4562	$p{$1} = $2;
	4563	}
	4564	last;
	4565	}
	4566	}
	4567	$self->{prereq_pm_detected}++;
	4568	return $self->{prereq_pm} = \%p;
	4569	}
	4570
	4571	#-> sub CPAN::Distribution::test ;
	4572	sub test {
	4573	my($self) = @_;
	4574	$self->make;
	4575	if ($CPAN::Signal){
	4576	delete $self->{force_update};
	4577	return;
	4578	}
	4579	$CPAN::Frontend->myprint("Running make test\n");
	4580	if (my @prereq = $self->unsat_prereq){
	4581	return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
	4582	}
	4583	EXCUSE: {
	4584	my @e;
	4585	exists $self->{make} or exists $self->{later} or push @e,
	4586	"Make had some problems, maybe interrupted? Won't test";
	4587
	4588	exists $self->{'make'} and
	4589	$self->{'make'} eq 'NO' and
	4590	push @e, "Can't test without successful make";
	4591
	4592	exists $self->{build_dir} or push @e, "Has no own directory";
	4593	$self->{badtestcnt} \|\|= 0;
	4594	$self->{badtestcnt} > 0 and
	4595	push @e, "Won't repeat unsuccessful test during this command";
	4596
	4597	exists $self->{later} and length($self->{later}) and
	4598	push @e, $self->{later};
	4599
	4600	$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
	4601	}
	4602	chdir $self->{'build_dir'} or
	4603	Carp::croak("Couldn't chdir to $self->{'build_dir'}");
	4604	$self->debug("Changed directory to $self->{'build_dir'}")
	4605	if $CPAN::DEBUG;
	4606
	4607	if ($^O eq 'MacOS') {
	4608	Mac::BuildTools::make_test($self);
	4609	return;
	4610	}
	4611
	4612	my $system = join " ", $CPAN::Config->{'make'}, "test";
	4613	if (system($system) == 0) {
	4614	$CPAN::Frontend->myprint(" $system -- OK\n");
	4615	$self->{make_test} = "YES";
	4616	} else {
	4617	$self->{make_test} = "NO";
	4618	$self->{badtestcnt}++;
	4619	$CPAN::Frontend->myprint(" $system -- NOT OK\n");
	4620	}
	4621	}
	4622
	4623	#-> sub CPAN::Distribution::clean ;
	4624	sub clean {
	4625	my($self) = @_;
	4626	$CPAN::Frontend->myprint("Running make clean\n");
	4627	EXCUSE: {
	4628	my @e;
	4629	exists $self->{make_clean} and $self->{make_clean} eq "YES" and
	4630	push @e, "make clean already called once";
	4631	exists $self->{build_dir} or push @e, "Has no own directory";
	4632	$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
	4633	}
	4634	chdir $self->{'build_dir'} or
	4635	Carp::croak("Couldn't chdir to $self->{'build_dir'}");
	4636	$self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
	4637
	4638	if ($^O eq 'MacOS') {
	4639	Mac::BuildTools::make_clean($self);
	4640	return;
	4641	}
	4642
	4643	my $system = join " ", $CPAN::Config->{'make'}, "clean";
	4644	if (system($system) == 0) {
	4645	$CPAN::Frontend->myprint(" $system -- OK\n");
	4646
	4647	# $self->force;
	4648
	4649	# Jost Krieger pointed out that this "force" was wrong because
	4650	# it has the effect that the next "install" on this distribution
	4651	# will untar everything again. Instead we should bring the
	4652	# object's state back to where it is after untarring.
	4653
	4654	delete $self->{force_update};
	4655	delete $self->{install};
	4656	delete $self->{writemakefile};
	4657	delete $self->{make};
	4658	delete $self->{make_test}; # no matter if yes or no, tests must be redone
	4659	$self->{make_clean} = "YES";
	4660
	4661	} else {
	4662	# Hmmm, what to do if make clean failed?
	4663
	4664	$CPAN::Frontend->myprint(qq{ $system -- NOT OK
	4665
	4666	make clean did not succeed, marking directory as unusable for further work.
	4667	});
	4668	$self->force("make"); # so that this directory won't be used again
	4669
	4670	}
	4671	}
	4672
	4673	#-> sub CPAN::Distribution::install ;
	4674	sub install {
	4675	my($self) = @_;
	4676	$self->test;
	4677	if ($CPAN::Signal){
	4678	delete $self->{force_update};
	4679	return;
	4680	}
	4681	$CPAN::Frontend->myprint("Running make install\n");
	4682	EXCUSE: {
	4683	my @e;
	4684	exists $self->{build_dir} or push @e, "Has no own directory";
	4685
	4686	exists $self->{make} or exists $self->{later} or push @e,
	4687	"Make had some problems, maybe interrupted? Won't install";
	4688
	4689	exists $self->{'make'} and
	4690	$self->{'make'} eq 'NO' and
	4691	push @e, "make had returned bad status, install seems impossible";
	4692
	4693	push @e, "make test had returned bad status, ".
	4694	"won't install without force"
	4695	if exists $self->{'make_test'} and
	4696	$self->{'make_test'} eq 'NO' and
	4697	! $self->{'force_update'};
	4698
	4699	exists $self->{'install'} and push @e,
	4700	$self->{'install'} eq "YES" ?
	4701	"Already done" : "Already tried without success";
	4702
	4703	exists $self->{later} and length($self->{later}) and
	4704	push @e, $self->{later};
	4705
	4706	$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
	4707	}
	4708	chdir $self->{'build_dir'} or
	4709	Carp::croak("Couldn't chdir to $self->{'build_dir'}");
	4710	$self->debug("Changed directory to $self->{'build_dir'}")
	4711	if $CPAN::DEBUG;
	4712
	4713	if ($^O eq 'MacOS') {
	4714	Mac::BuildTools::make_install($self);
	4715	return;
	4716	}
	4717
	4718	my $system = join(" ", $CPAN::Config->{'make'},
	4719	"install", $CPAN::Config->{make_install_arg});
	4720	my($stderr) = $^O =~ /Win/i ? "" : " 2>&1 ";
	4721	my($pipe) = FileHandle->new("$system $stderr \|");
	4722	my($makeout) = "";
	4723	while (<$pipe>){
	4724	$CPAN::Frontend->myprint($_);
	4725	$makeout .= $_;
	4726	}
	4727	$pipe->close;
	4728	if ($?==0) {
	4729	$CPAN::Frontend->myprint(" $system -- OK\n");
	4730	return $self->{'install'} = "YES";
	4731	} else {
	4732	$self->{'install'} = "NO";
	4733	$CPAN::Frontend->myprint(" $system -- NOT OK\n");
	4734	if ($makeout =~ /permission/s && $> > 0) {
	4735	$CPAN::Frontend->myprint(qq{ You may have to su }.
	4736	qq{to root to install the package\n});
	4737	}
	4738	}
	4739	delete $self->{force_update};
	4740	}
	4741
	4742	#-> sub CPAN::Distribution::dir ;
	4743	sub dir {
	4744	shift->{'build_dir'};
	4745	}
	4746
	4747	package CPAN::Bundle;
	4748
	4749	sub undelay {
	4750	my $self = shift;
	4751	delete $self->{later};
	4752	for my $c ( $self->contains ) {
	4753	my $obj = CPAN::Shell->expandany($c) or next;
	4754	$obj->undelay;
	4755	}
	4756	}
	4757
	4758	#-> sub CPAN::Bundle::color_cmd_tmps ;
	4759	sub color_cmd_tmps {
	4760	my($self) = shift;
	4761	my($depth) = shift \|\| 0;
	4762	my($color) = shift \|\| 0;
	4763	# a module needs to recurse to its cpan_file, a distribution needs
	4764	# to recurse into its prereq_pms, a bundle needs to recurse into its modules
	4765
	4766	return if exists $self->{incommandcolor}
	4767	&& $self->{incommandcolor}==$color;
	4768	$CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
	4769	"color_cmd_tmps depth[%s] self[%s] id[%s]",
	4770	$depth,
	4771	$self,
	4772	$self->id
	4773	)) if $depth>=100;
	4774	##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
	4775
	4776	for my $c ( $self->contains ) {
	4777	my $obj = CPAN::Shell->expandany($c) or next;
	4778	CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
	4779	$obj->color_cmd_tmps($depth+1,$color);
	4780	}
	4781	if ($color==0) {
	4782	delete $self->{badtestcnt};
	4783	}
	4784	$self->{incommandcolor} = $color;
	4785	}
	4786
	4787	#-> sub CPAN::Bundle::as_string ;
	4788	sub as_string {
	4789	my($self) = @_;
	4790	$self->contains;
	4791	# following line must be "=", not "\|\|=" because we have a moving target
	4792	$self->{INST_VERSION} = $self->inst_version;
	4793	return $self->SUPER::as_string;
	4794	}
	4795
	4796	#-> sub CPAN::Bundle::contains ;
	4797	sub contains {
	4798	my($self) = @_;
	4799	my($inst_file) = $self->inst_file \|\| "";
	4800	my($id) = $self->id;
	4801	$self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
	4802	unless ($inst_file) {
	4803	# Try to get at it in the cpan directory
	4804	$self->debug("no inst_file") if $CPAN::DEBUG;
	4805	my $cpan_file;
	4806	$CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
	4807	$cpan_file = $self->cpan_file;
	4808	if ($cpan_file eq "N/A") {
	4809	$CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
	4810	Maybe stale symlink? Maybe removed during session? Giving up.\n");
	4811	}
	4812	my $dist = $CPAN::META->instance('CPAN::Distribution',
	4813	$self->cpan_file);
	4814	$dist->get;
	4815	$self->debug($dist->as_string) if $CPAN::DEBUG;
	4816	my($todir) = $CPAN::Config->{'cpan_home'};
	4817	my(@me,$from,$to,$me);
	4818	@me = split /::/, $self->id;
	4819	$me[-1] .= ".pm";
	4820	$me = MM->catfile(@me);
	4821	$from = $self->find_bundle_file($dist->{'build_dir'},$me);
	4822	$to = MM->catfile($todir,$me);
	4823	File::Path::mkpath(File::Basename::dirname($to));
	4824	File::Copy::copy($from, $to)
	4825	or Carp::confess("Couldn't copy $from to $to: $!");
	4826	$inst_file = $to;
	4827	}
	4828	my @result;
	4829	my $fh = FileHandle->new;
	4830	local $/ = "\n";
	4831	open($fh,$inst_file) or die "Could not open '$inst_file': $!";
	4832	my $in_cont = 0;
	4833	$self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
	4834	while (<$fh>) {
	4835	$in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
	4836	m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
	4837	next unless $in_cont;
	4838	next if /^=/;
	4839	s/\#.*//;
	4840	next if /^\s+$/;
	4841	chomp;
	4842	push @result, (split " ", $_, 2)[0];
	4843	}
	4844	close $fh;
	4845	delete $self->{STATUS};
	4846	$self->{CONTAINS} = \@result;
	4847	$self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
	4848	unless (@result) {
	4849	$CPAN::Frontend->mywarn(qq{
	4850	The bundle file "$inst_file" may be a broken
	4851	bundlefile. It seems not to contain any bundle definition.
	4852	Please check the file and if it is bogus, please delete it.
	4853	Sorry for the inconvenience.
	4854	});
	4855	}
	4856	@result;
	4857	}
	4858
	4859	#-> sub CPAN::Bundle::find_bundle_file
	4860	sub find_bundle_file {
	4861	my($self,$where,$what) = @_;
	4862	$self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
	4863	### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
	4864	### my $bu = MM->catfile($where,$what);
	4865	### return $bu if -f $bu;
	4866	my $manifest = MM->catfile($where,"MANIFEST");
	4867	unless (-f $manifest) {
	4868	require ExtUtils::Manifest;
	4869	my $cwd = CPAN::anycwd();
	4870	chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
	4871	ExtUtils::Manifest::mkmanifest();
	4872	chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
	4873	}
	4874	my $fh = FileHandle->new($manifest)
	4875	or Carp::croak("Couldn't open $manifest: $!");
	4876	local($/) = "\n";
	4877	my $what2 = $what;
	4878	if ($^O eq 'MacOS') {
	4879	$what =~ s/^://;
	4880	$what =~ tr\|:\|/\|;
	4881	$what2 =~ s/:Bundle://;
	4882	$what2 =~ tr\|:\|/\|;
	4883	} else {
	4884	$what2 =~ s\|Bundle[/\\]\|\|;
	4885	}
	4886	my $bu;
	4887	while (<$fh>) {
	4888	next if /^\s*\#/;
	4889	my($file) = /(\S+)/;
	4890	if ($file =~ m\|\Q$what\E$\|) {
	4891	$bu = $file;
	4892	# return MM->catfile($where,$bu); # bad
	4893	last;
	4894	}
	4895	# retry if she managed to
	4896	# have no Bundle directory
	4897	$bu = $file if $file =~ m\|\Q$what2\E$\|;
	4898	}
	4899	$bu =~ tr\|/\|:\| if $^O eq 'MacOS';
	4900	return MM->catfile($where, $bu) if $bu;
	4901	Carp::croak("Couldn't find a Bundle file in $where");
	4902	}
	4903
	4904	# needs to work quite differently from Module::inst_file because of
	4905	# cpan_home/Bundle/ directory and the possibility that we have
	4906	# shadowing effect. As it makes no sense to take the first in @INC for
	4907	# Bundles, we parse them all for $VERSION and take the newest.
	4908
	4909	#-> sub CPAN::Bundle::inst_file ;
	4910	sub inst_file {
	4911	my($self) = @_;
	4912	my($inst_file);
	4913	my(@me);
	4914	@me = split /::/, $self->id;
	4915	$me[-1] .= ".pm";
	4916	my($incdir,$bestv);
	4917	foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
	4918	my $bfile = MM->catfile($incdir, @me);
	4919	CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
	4920	next unless -f $bfile;
	4921	my $foundv = MM->parse_version($bfile);
	4922	if (!$bestv \|\| CPAN::Version->vgt($foundv,$bestv)) {
	4923	$self->{INST_FILE} = $bfile;
	4924	$self->{INST_VERSION} = $bestv = $foundv;
	4925	}
	4926	}
	4927	$self->{INST_FILE};
	4928	}
	4929
	4930	#-> sub CPAN::Bundle::inst_version ;
	4931	sub inst_version {
	4932	my($self) = @_;
	4933	$self->inst_file; # finds INST_VERSION as side effect
	4934	$self->{INST_VERSION};
	4935	}
	4936
	4937	#-> sub CPAN::Bundle::rematein ;
	4938	sub rematein {
	4939	my($self,$meth) = @_;
	4940	$self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
	4941	my($id) = $self->id;
	4942	Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
	4943	unless $self->inst_file \|\| $self->cpan_file;
	4944	my($s,%fail);
	4945	for $s ($self->contains) {
	4946	my($type) = $s =~ m\|/\| ? 'CPAN::Distribution' :
	4947	$s =~ m\|^Bundle::\| ? 'CPAN::Bundle' : 'CPAN::Module';
	4948	if ($type eq 'CPAN::Distribution') {
	4949	$CPAN::Frontend->mywarn(qq{
	4950	The Bundle }.$self->id.qq{ contains
	4951	explicitly a file $s.
	4952	});
	4953	sleep 3;
	4954	}
	4955	# possibly noisy action:
	4956	$self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
	4957	my $obj = $CPAN::META->instance($type,$s);
	4958	$obj->$meth();
	4959	if ($obj->isa(CPAN::Bundle)
	4960	&&
	4961	exists $obj->{install_failed}
	4962	&&
	4963	ref($obj->{install_failed}) eq "HASH"
	4964	) {
	4965	for (keys %{$obj->{install_failed}}) {
	4966	$self->{install_failed}{$_} = undef; # propagate faiure up
	4967	# to me in a
	4968	# recursive call
	4969	$fail{$s} = 1; # the bundle itself may have succeeded but
	4970	# not all children
	4971	}
	4972	} else {
	4973	my $success;
	4974	$success = $obj->can("uptodate") ? $obj->uptodate : 0;
	4975	$success \|\|= $obj->{'install'} && $obj->{'install'} eq "YES";
	4976	if ($success) {
	4977	delete $self->{install_failed}{$s};
	4978	} else {
	4979	$fail{$s} = 1;
	4980	}
	4981	}
	4982	}
	4983
	4984	# recap with less noise
	4985	if ( $meth eq "install" ) {
	4986	if (%fail) {
	4987	require Text::Wrap;
	4988	my $raw = sprintf(qq{Bundle summary:
	4989	The following items in bundle %s had installation problems:},
	4990	$self->id
	4991	);
	4992	$CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
	4993	$CPAN::Frontend->myprint("\n");
	4994	my $paragraph = "";
	4995	my %reported;
	4996	for $s ($self->contains) {
	4997	if ($fail{$s}){
	4998	$paragraph .= "$s ";
	4999	$self->{install_failed}{$s} = undef;
	5000	$reported{$s} = undef;
	5001	}
	5002	}
	5003	my $report_propagated;
	5004	for $s (sort keys %{$self->{install_failed}}) {
	5005	next if exists $reported{$s};
	5006	$paragraph .= "and the following items had problems
	5007	during recursive bundle calls: " unless $report_propagated++;
	5008	$paragraph .= "$s ";
	5009	}
	5010	$CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
	5011	$CPAN::Frontend->myprint("\n");
	5012	} else {
	5013	$self->{'install'} = 'YES';
	5014	}
	5015	}
	5016	}
	5017
	5018	#sub CPAN::Bundle::xs_file
	5019	sub xs_file {
	5020	# If a bundle contains another that contains an xs_file we have
	5021	# here, we just don't bother I suppose
	5022	return 0;
	5023	}
	5024
	5025	#-> sub CPAN::Bundle::force ;
	5026	sub force { shift->rematein('force',@_); }
	5027	#-> sub CPAN::Bundle::get ;
	5028	sub get { shift->rematein('get',@_); }
	5029	#-> sub CPAN::Bundle::make ;
	5030	sub make { shift->rematein('make',@_); }
	5031	#-> sub CPAN::Bundle::test ;
	5032	sub test {
	5033	my $self = shift;
	5034	$self->{badtestcnt} \|\|= 0;
	5035	$self->rematein('test',@_);
	5036	}
	5037	#-> sub CPAN::Bundle::install ;
	5038	sub install {
	5039	my $self = shift;
	5040	$self->rematein('install',@_);
	5041	}
	5042	#-> sub CPAN::Bundle::clean ;
	5043	sub clean { shift->rematein('clean',@_); }
	5044
	5045	#-> sub CPAN::Bundle::uptodate ;
	5046	sub uptodate {
	5047	my($self) = @_;
	5048	return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
	5049	my $c;
	5050	foreach $c ($self->contains) {
	5051	my $obj = CPAN::Shell->expandany($c);
	5052	return 0 unless $obj->uptodate;
	5053	}
	5054	return 1;
	5055	}
	5056
	5057	#-> sub CPAN::Bundle::readme ;
	5058	sub readme {
	5059	my($self) = @_;
	5060	my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
	5061	No File found for bundle } . $self->id . qq{\n}), return;
	5062	$self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
	5063	$CPAN::META->instance('CPAN::Distribution',$file)->readme;
	5064	}
	5065
	5066	package CPAN::Module;
	5067
	5068	# Accessors
	5069	# sub cpan_userid { shift->{RO}{CPAN_USERID} }
	5070	sub userid {
	5071	my $self = shift;
	5072	return unless exists $self->{RO}; # should never happen
	5073	return $self->{RO}{CPAN_USERID} \|\| $self->{RO}{userid};
	5074	}
	5075	sub description { shift->{RO}{description} }
	5076
	5077	sub undelay {
	5078	my $self = shift;
	5079	delete $self->{later};
	5080	if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
	5081	$dist->undelay;
	5082	}
	5083	}
	5084
	5085	#-> sub CPAN::Module::color_cmd_tmps ;
	5086	sub color_cmd_tmps {
	5087	my($self) = shift;
	5088	my($depth) = shift \|\| 0;
	5089	my($color) = shift \|\| 0;
	5090	# a module needs to recurse to its cpan_file
	5091
	5092	return if exists $self->{incommandcolor}
	5093	&& $self->{incommandcolor}==$color;
	5094	$CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
	5095	"color_cmd_tmps depth[%s] self[%s] id[%s]",
	5096	$depth,
	5097	$self,
	5098	$self->id
	5099	)) if $depth>=100;
	5100	##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
	5101
	5102	if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
	5103	$dist->color_cmd_tmps($depth+1,$color);
	5104	}
	5105	if ($color==0) {
	5106	delete $self->{badtestcnt};
	5107	}
	5108	$self->{incommandcolor} = $color;
	5109	}
	5110
	5111	#-> sub CPAN::Module::as_glimpse ;
	5112	sub as_glimpse {
	5113	my($self) = @_;
	5114	my(@m);
	5115	my $class = ref($self);
	5116	$class =~ s/^CPAN:://;
	5117	my $color_on = "";
	5118	my $color_off = "";
	5119	if (
	5120	$CPAN::Shell::COLOR_REGISTERED
	5121	&&
	5122	$CPAN::META->has_inst("Term::ANSIColor")
	5123	&&
	5124	$self->{RO}{description}
	5125	) {
	5126	$color_on = Term::ANSIColor::color("green");
	5127	$color_off = Term::ANSIColor::color("reset");
	5128	}
	5129	push @m, sprintf("%-15s %s%-15s%s (%s)\n",
	5130	$class,
	5131	$color_on,
	5132	$self->id,
	5133	$color_off,
	5134	$self->cpan_file);
	5135	join "", @m;
	5136	}
	5137
	5138	#-> sub CPAN::Module::as_string ;
	5139	sub as_string {
	5140	my($self) = @_;
	5141	my(@m);
	5142	CPAN->debug($self) if $CPAN::DEBUG;
	5143	my $class = ref($self);
	5144	$class =~ s/^CPAN:://;
	5145	local($^W) = 0;
	5146	push @m, $class, " id = $self->{ID}\n";
	5147	my $sprintf = " %-12s %s\n";
	5148	push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
	5149	if $self->description;
	5150	my $sprintf2 = " %-12s %s (%s)\n";
	5151	my($userid);
	5152	if ($userid = $self->cpan_userid \|\| $self->userid){
	5153	my $author;
	5154	if ($author = CPAN::Shell->expand('Author',$userid)) {
	5155	my $email = "";
	5156	my $m; # old perls
	5157	if ($m = $author->email) {
	5158	$email = " <$m>";
	5159	}
	5160	push @m, sprintf(
	5161	$sprintf2,
	5162	'CPAN_USERID',
	5163	$userid,
	5164	$author->fullname . $email
	5165	);
	5166	}
	5167	}
	5168	push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
	5169	if $self->cpan_version;
	5170	push @m, sprintf($sprintf, 'CPAN_FILE', $self->cpan_file)
	5171	if $self->cpan_file;
	5172	my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
	5173	my(%statd,%stats,%statl,%stati);
	5174	@statd{qw,? i c a b R M S,} = qw,unknown idea
	5175	pre-alpha alpha beta released mature standard,;
	5176	@stats{qw,? m d u n,} = qw,unknown mailing-list
	5177	developer comp.lang.perl.* none,;
	5178	@statl{qw,? p c + o h,} = qw,unknown perl C C++ other hybrid,;
	5179	@stati{qw,? f r O h,} = qw,unknown functions
	5180	references+ties object-oriented hybrid,;
	5181	$statd{' '} = 'unknown';
	5182	$stats{' '} = 'unknown';
	5183	$statl{' '} = 'unknown';
	5184	$stati{' '} = 'unknown';
	5185	push @m, sprintf(
	5186	$sprintf3,
	5187	'DSLI_STATUS',
	5188	$self->{RO}{statd},
	5189	$self->{RO}{stats},
	5190	$self->{RO}{statl},
	5191	$self->{RO}{stati},
	5192	$statd{$self->{RO}{statd}},
	5193	$stats{$self->{RO}{stats}},
	5194	$statl{$self->{RO}{statl}},
	5195	$stati{$self->{RO}{stati}}
	5196	) if $self->{RO}{statd};
	5197	my $local_file = $self->inst_file;
	5198	unless ($self->{MANPAGE}) {
	5199	if ($local_file) {
	5200	$self->{MANPAGE} = $self->manpage_headline($local_file);
	5201	} else {
	5202	# If we have already untarred it, we should look there
	5203	my $dist = $CPAN::META->instance('CPAN::Distribution',
	5204	$self->cpan_file);
	5205	# warn "dist[$dist]";
	5206	# mff=manifest file; mfh=manifest handle
	5207	my($mff,$mfh);
	5208	if (
	5209	$dist->{build_dir}
	5210	and
	5211	(-f ($mff = MM->catfile($dist->{build_dir}, "MANIFEST")))
	5212	and
	5213	$mfh = FileHandle->new($mff)
	5214	) {
	5215	CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
	5216	my $lfre = $self->id; # local file RE
	5217	$lfre =~ s/::/./g;
	5218	$lfre .= "\\.pm\$";
	5219	my($lfl); # local file file
	5220	local $/ = "\n";
	5221	my(@mflines) = <$mfh>;
	5222	for (@mflines) {
	5223	s/^\s+//;
	5224	s/\s.*//s;
	5225	}
	5226	while (length($lfre)>5 and !$lfl) {
	5227	($lfl) = grep /$lfre/, @mflines;
	5228	CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
	5229	$lfre =~ s/.+?\.//;
	5230	}
	5231	$lfl =~ s/\s.*//; # remove comments
	5232	$lfl =~ s/\s+//g; # chomp would maybe be too system-specific
	5233	my $lfl_abs = MM->catfile($dist->{build_dir},$lfl);
	5234	# warn "lfl_abs[$lfl_abs]";
	5235	if (-f $lfl_abs) {
	5236	$self->{MANPAGE} = $self->manpage_headline($lfl_abs);
	5237	}
	5238	}
	5239	}
	5240	}
	5241	my($item);
	5242	for $item (qw/MANPAGE/) {
	5243	push @m, sprintf($sprintf, $item, $self->{$item})
	5244	if exists $self->{$item};
	5245	}
	5246	for $item (qw/CONTAINS/) {
	5247	push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
	5248	if exists $self->{$item} && @{$self->{$item}};
	5249	}
	5250	push @m, sprintf($sprintf, 'INST_FILE',
	5251	$local_file \|\| "(not installed)");
	5252	push @m, sprintf($sprintf, 'INST_VERSION',
	5253	$self->inst_version) if $local_file;
	5254	join "", @m, "\n";
	5255	}
	5256
	5257	sub manpage_headline {
	5258	my($self,$local_file) = @_;
	5259	my(@local_file) = $local_file;
	5260	$local_file =~ s/\.pm(?!\n)\Z/.pod/;
	5261	push @local_file, $local_file;
	5262	my(@result,$locf);
	5263	for $locf (@local_file) {
	5264	next unless -f $locf;
	5265	my $fh = FileHandle->new($locf)
	5266	or $Carp::Frontend->mydie("Couldn't open $locf: $!");
	5267	my $inpod = 0;
	5268	local $/ = "\n";
	5269	while (<$fh>) {
	5270	$inpod = m/^=(?!head1\s+NAME)/ ? 0 :
	5271	m/^=head1\s+NAME/ ? 1 : $inpod;
	5272	next unless $inpod;
	5273	next if /^=/;
	5274	next if /^\s+$/;
	5275	chomp;
	5276	push @result, $_;
	5277	}
	5278	close $fh;
	5279	last if @result;
	5280	}
	5281	join " ", @result;
	5282	}
	5283
	5284	#-> sub CPAN::Module::cpan_file ;
	5285	# Note: also inherited by CPAN::Bundle
	5286	sub cpan_file {
	5287	my $self = shift;
	5288	CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
	5289	unless (defined $self->{RO}{CPAN_FILE}) {
	5290	CPAN::Index->reload;
	5291	}
	5292	if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
	5293	return $self->{RO}{CPAN_FILE};
	5294	} else {
	5295	my $userid = $self->userid;
	5296	if ( $userid ) {
	5297	if ($CPAN::META->exists("CPAN::Author",$userid)) {
	5298	my $author = $CPAN::META->instance("CPAN::Author",
	5299	$userid);
	5300	my $fullname = $author->fullname;
	5301	my $email = $author->email;
	5302	unless (defined $fullname && defined $email) {
	5303	return sprintf("Contact Author %s",
	5304	$userid,
	5305	);
	5306	}
	5307	return "Contact Author $fullname <$email>";
	5308	} else {
	5309	return "UserID $userid";
	5310	}
	5311	} else {
	5312	return "N/A";
	5313	}
	5314	}
	5315	}
	5316
	5317	#-> sub CPAN::Module::cpan_version ;
	5318	sub cpan_version {
	5319	my $self = shift;
	5320
	5321	$self->{RO}{CPAN_VERSION} = 'undef'
	5322	unless defined $self->{RO}{CPAN_VERSION};
	5323	# I believe this is always a bug in the index and should be reported
	5324	# as such, but usually I find out such an error and do not want to
	5325	# provoke too many bugreports
	5326
	5327	$self->{RO}{CPAN_VERSION};
	5328	}
	5329
	5330	#-> sub CPAN::Module::force ;
	5331	sub force {
	5332	my($self) = @_;
	5333	$self->{'force_update'}++;
	5334	}
	5335
	5336	#-> sub CPAN::Module::rematein ;
	5337	sub rematein {
	5338	my($self,$meth) = @_;
	5339	$CPAN::Frontend->myprint(sprintf("Running %s for module %s\n",
	5340	$meth,
	5341	$self->id));
	5342	my $cpan_file = $self->cpan_file;
	5343	if ($cpan_file eq "N/A" \|\| $cpan_file =~ /^Contact Author/){
	5344	$CPAN::Frontend->mywarn(sprintf qq{
	5345	The module %s isn\'t available on CPAN.
	5346
	5347	Either the module has not yet been uploaded to CPAN, or it is
	5348	temporary unavailable. Please contact the author to find out
	5349	more about the status. Try 'i %s'.
	5350	},
	5351	$self->id,
	5352	$self->id,
	5353	);
	5354	return;
	5355	}
	5356	my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
	5357	$pack->called_for($self->id);
	5358	$pack->force($meth) if exists $self->{'force_update'};
	5359	$pack->$meth();
	5360	$pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
	5361	delete $self->{'force_update'};
	5362	}
	5363
	5364	#-> sub CPAN::Module::readme ;
	5365	sub readme { shift->rematein('readme') }
	5366	#-> sub CPAN::Module::look ;
	5367	sub look { shift->rematein('look') }
	5368	#-> sub CPAN::Module::cvs_import ;
	5369	sub cvs_import { shift->rematein('cvs_import') }
	5370	#-> sub CPAN::Module::get ;
	5371	sub get { shift->rematein('get',@_); }
	5372	#-> sub CPAN::Module::make ;
	5373	sub make {
	5374	my $self = shift;
	5375	$self->rematein('make');
	5376	}
	5377	#-> sub CPAN::Module::test ;
	5378	sub test {
	5379	my $self = shift;
	5380	$self->{badtestcnt} \|\|= 0;
	5381	$self->rematein('test',@_);
	5382	}
	5383	#-> sub CPAN::Module::uptodate ;
	5384	sub uptodate {
	5385	my($self) = @_;
	5386	my($latest) = $self->cpan_version;
	5387	$latest \|\|= 0;
	5388	my($inst_file) = $self->inst_file;
	5389	my($have) = 0;
	5390	if (defined $inst_file) {
	5391	$have = $self->inst_version;
	5392	}
	5393	local($^W)=0;
	5394	if ($inst_file
	5395	&&
	5396	! CPAN::Version->vgt($latest, $have)
	5397	) {
	5398	CPAN->debug("returning uptodate. inst_file[$inst_file] ".
	5399	"latest[$latest] have[$have]") if $CPAN::DEBUG;
	5400	return 1;
	5401	}
	5402	return;
	5403	}
	5404	#-> sub CPAN::Module::install ;
	5405	sub install {
	5406	my($self) = @_;
	5407	my($doit) = 0;
	5408	if ($self->uptodate
	5409	&&
	5410	not exists $self->{'force_update'}
	5411	) {
	5412	$CPAN::Frontend->myprint( $self->id. " is up to date.\n");
	5413	} else {
	5414	$doit = 1;
	5415	}
	5416	$self->rematein('install') if $doit;
	5417	}
	5418	#-> sub CPAN::Module::clean ;
	5419	sub clean { shift->rematein('clean') }
	5420
	5421	#-> sub CPAN::Module::inst_file ;
	5422	sub inst_file {
	5423	my($self) = @_;
	5424	my($dir,@packpath);
	5425	@packpath = split /::/, $self->{ID};
	5426	$packpath[-1] .= ".pm";
	5427	foreach $dir (@INC) {
	5428	my $pmfile = MM->catfile($dir,@packpath);
	5429	if (-f $pmfile){
	5430	return $pmfile;
	5431	}
	5432	}
	5433	return;
	5434	}
	5435
	5436	#-> sub CPAN::Module::xs_file ;
	5437	sub xs_file {
	5438	my($self) = @_;
	5439	my($dir,@packpath);
	5440	@packpath = split /::/, $self->{ID};
	5441	push @packpath, $packpath[-1];
	5442	$packpath[-1] .= "." . $Config::Config{'dlext'};
	5443	foreach $dir (@INC) {
	5444	my $xsfile = MM->catfile($dir,'auto',@packpath);
	5445	if (-f $xsfile){
	5446	return $xsfile;
	5447	}
	5448	}
	5449	return;
	5450	}
	5451
	5452	#-> sub CPAN::Module::inst_version ;
	5453	sub inst_version {
	5454	my($self) = @_;
	5455	my $parsefile = $self->inst_file or return;
	5456	local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
	5457	my $have;
	5458
	5459	# there was a bug in 5.6.0 that let lots of unini warnings out of
	5460	# parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
	5461	# the following workaround after 5.6.1 is out.
	5462	local($SIG{__WARN__}) = sub { my $w = shift;
	5463	return if $w =~ /uninitialized/i;
	5464	warn $w;
	5465	};
	5466
	5467	$have = MM->parse_version($parsefile) \|\| "undef";
	5468	$have =~ s/^ //; # since the %vd hack these two lines here are needed
	5469	$have =~ s/ $//; # trailing whitespace happens all the time
	5470
	5471	# My thoughts about why %vd processing should happen here
	5472
	5473	# Alt1 maintain it as string with leading v:
	5474	# read index files do nothing
	5475	# compare it use utility for compare
	5476	# print it do nothing
	5477
	5478	# Alt2 maintain it as what is is
	5479	# read index files convert
	5480	# compare it use utility because there's still a ">" vs "gt" issue
	5481	# print it use CPAN::Version for print
	5482
	5483	# Seems cleaner to hold it in memory as a string starting with a "v"
	5484
	5485	# If the author of this module made a mistake and wrote a quoted
	5486	# "v1.13" instead of v1.13, we simply leave it at that with the
	5487	# effect that we will treat it like a v-tring while the rest of
	5488	# perl won't. Seems sensible when we consider that any action we
	5489	# could take now would just add complexity.
	5490
	5491	$have = CPAN::Version->readable($have);
	5492
	5493	$have =~ s/\s*//g; # stringify to float around floating point issues
	5494	$have; # no stringify needed, \s* above matches always
	5495	}
	5496
	5497	package CPAN::Tarzip;
	5498
	5499	# CPAN::Tarzip::gzip
	5500	sub gzip {
	5501	my($class,$read,$write) = @_;
	5502	if ($CPAN::META->has_inst("Compress::Zlib")) {
	5503	my($buffer,$fhw);
	5504	$fhw = FileHandle->new($read)
	5505	or $CPAN::Frontend->mydie("Could not open $read: $!");
	5506	my $gz = Compress::Zlib::gzopen($write, "wb")
	5507	or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
	5508	$gz->gzwrite($buffer)
	5509	while read($fhw,$buffer,4096) > 0 ;
	5510	$gz->gzclose() ;
	5511	$fhw->close;
	5512	return 1;
	5513	} else {
	5514	system("$CPAN::Config->{gzip} -c $read > $write")==0;
	5515	}
	5516	}
	5517
	5518
	5519	# CPAN::Tarzip::gunzip
	5520	sub gunzip {
	5521	my($class,$read,$write) = @_;
	5522	if ($CPAN::META->has_inst("Compress::Zlib")) {
	5523	my($buffer,$fhw);
	5524	$fhw = FileHandle->new(">$write")
	5525	or $CPAN::Frontend->mydie("Could not open >$write: $!");
	5526	my $gz = Compress::Zlib::gzopen($read, "rb")
	5527	or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
	5528	$fhw->print($buffer)
	5529	while $gz->gzread($buffer) > 0 ;
	5530	$CPAN::Frontend->mydie("Error reading from $read: $!\n")
	5531	if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
	5532	$gz->gzclose() ;
	5533	$fhw->close;
	5534	return 1;
	5535	} else {
	5536	system("$CPAN::Config->{gzip} -dc $read > $write")==0;
	5537	}
	5538	}
	5539
	5540
	5541	# CPAN::Tarzip::gtest
	5542	sub gtest {
	5543	my($class,$read) = @_;
	5544	# After I had reread the documentation in zlib.h, I discovered that
	5545	# uncompressed files do not lead to an gzerror (anymore?).
	5546	if ( $CPAN::META->has_inst("Compress::Zlib") ) {
	5547	my($buffer,$len);
	5548	$len = 0;
	5549	my $gz = Compress::Zlib::gzopen($read, "rb")
	5550	or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
	5551	$read,
	5552	$Compress::Zlib::gzerrno));
	5553	while ($gz->gzread($buffer) > 0 ){
	5554	$len += length($buffer);
	5555	$buffer = "";
	5556	}
	5557	my $err = $gz->gzerror;
	5558	my $success = ! $err \|\| $err == Compress::Zlib::Z_STREAM_END();
	5559	if ($len == -s $read){
	5560	$success = 0;
	5561	CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
	5562	}
	5563	$gz->gzclose();
	5564	CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
	5565	return $success;
	5566	} else {
	5567	return system("$CPAN::Config->{gzip} -dt $read")==0;
	5568	}
	5569	}
	5570
	5571
	5572	# CPAN::Tarzip::TIEHANDLE
	5573	sub TIEHANDLE {
	5574	my($class,$file) = @_;
	5575	my $ret;
	5576	$class->debug("file[$file]");
	5577	if ($CPAN::META->has_inst("Compress::Zlib")) {
	5578	my $gz = Compress::Zlib::gzopen($file,"rb") or
	5579	die "Could not gzopen $file";
	5580	$ret = bless {GZ => $gz}, $class;
	5581	} else {
	5582	my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $file \|";
	5583	my $fh = FileHandle->new($pipe) or die "Could not pipe[$pipe]: $!";
	5584	binmode $fh;
	5585	$ret = bless {FH => $fh}, $class;
	5586	}
	5587	$ret;
	5588	}
	5589
	5590
	5591	# CPAN::Tarzip::READLINE
	5592	sub READLINE {
	5593	my($self) = @_;
	5594	if (exists $self->{GZ}) {
	5595	my $gz = $self->{GZ};
	5596	my($line,$bytesread);
	5597	$bytesread = $gz->gzreadline($line);
	5598	return undef if $bytesread <= 0;
	5599	return $line;
	5600	} else {
	5601	my $fh = $self->{FH};
	5602	return scalar <$fh>;
	5603	}
	5604	}
	5605
	5606
	5607	# CPAN::Tarzip::READ
	5608	sub READ {
	5609	my($self,$ref,$length,$offset) = @_;
	5610	die "read with offset not implemented" if defined $offset;
	5611	if (exists $self->{GZ}) {
	5612	my $gz = $self->{GZ};
	5613	my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
	5614	return $byteread;
	5615	} else {
	5616	my $fh = $self->{FH};
	5617	return read($fh,$$ref,$length);
	5618	}
	5619	}
	5620
	5621
	5622	# CPAN::Tarzip::DESTROY
	5623	sub DESTROY {
	5624	my($self) = @_;
	5625	if (exists $self->{GZ}) {
	5626	my $gz = $self->{GZ};
	5627	$gz->gzclose() if defined $gz; # hard to say if it is allowed
	5628	# to be undef ever. AK, 2000-09
	5629	} else {
	5630	my $fh = $self->{FH};
	5631	$fh->close if defined $fh;
	5632	}
	5633	undef $self;
	5634	}
	5635
	5636
	5637	# CPAN::Tarzip::untar
	5638	sub untar {
	5639	my($class,$file) = @_;
	5640	my($prefer) = 0;
	5641
	5642	if (0) { # makes changing order easier
	5643	} elsif ($BUGHUNTING){
	5644	$prefer=2;
	5645	} elsif (MM->maybe_command($CPAN::Config->{gzip})
	5646	&&
	5647	MM->maybe_command($CPAN::Config->{'tar'})) {
	5648	# should be default until Archive::Tar is fixed
	5649	$prefer = 1;
	5650	} elsif (
	5651	$CPAN::META->has_inst("Archive::Tar")
	5652	&&
	5653	$CPAN::META->has_inst("Compress::Zlib") ) {
	5654	$prefer = 2;
	5655	} else {
	5656	$CPAN::Frontend->mydie(qq{
	5657	CPAN.pm needs either both external programs tar and gzip installed or
	5658	both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
	5659	is available. Can\'t continue.
	5660	});
	5661	}
	5662	if ($prefer==1) { # 1 => external gzip+tar
	5663	my($system);
	5664	my $is_compressed = $class->gtest($file);
	5665	if ($is_compressed) {
	5666	$system = "$CPAN::Config->{gzip} --decompress --stdout " .
	5667	"< $file \| $CPAN::Config->{tar} xvf -";
	5668	} else {
	5669	$system = "$CPAN::Config->{tar} xvf $file";
	5670	}
	5671	if (system($system) != 0) {
	5672	# people find the most curious tar binaries that cannot handle
	5673	# pipes
	5674	if ($is_compressed) {
	5675	(my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
	5676	if (CPAN::Tarzip->gunzip($file, $ungzf)) {
	5677	$CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
	5678	} else {
	5679	$CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
	5680	}
	5681	$file = $ungzf;
	5682	}
	5683	$system = "$CPAN::Config->{tar} xvf $file";
	5684	$CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
	5685	if (system($system)==0) {
	5686	$CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
	5687	} else {
	5688	$CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
	5689	}
	5690	return 1;
	5691	} else {
	5692	return 1;
	5693	}
	5694	} elsif ($prefer==2) { # 2 => modules
	5695	my $tar = Archive::Tar->new($file,1);
	5696	my $af; # archive file
	5697	my @af;
	5698	if ($BUGHUNTING) {
	5699	# RCS 1.337 had this code, it turned out unacceptable slow but
	5700	# it revealed a bug in Archive::Tar. Code is only here to hunt
	5701	# the bug again. It should never be enabled in published code.
	5702	# GDGraph3d-0.53 was an interesting case according to Larry
	5703	# Virden.
	5704	warn(">>>Bughunting code enabled<<< " x 20);
	5705	for $af ($tar->list_files) {
	5706	if ($af =~ m!^(/\|\.\./)!) {
	5707	$CPAN::Frontend->mydie("ALERT: Archive contains ".
	5708	"illegal member [$af]");
	5709	}
	5710	$CPAN::Frontend->myprint("$af\n");
	5711	$tar->extract($af); # slow but effective for finding the bug
	5712	return if $CPAN::Signal;
	5713	}
	5714	} else {
	5715	for $af ($tar->list_files) {
	5716	if ($af =~ m!^(/\|\.\./)!) {
	5717	$CPAN::Frontend->mydie("ALERT: Archive contains ".
	5718	"illegal member [$af]");
	5719	}
	5720	$CPAN::Frontend->myprint("$af\n");
	5721	push @af, $af;
	5722	return if $CPAN::Signal;
	5723	}
	5724	$tar->extract(@af);
	5725	}
	5726
	5727	Mac::BuildTools::convert_files([$tar->list_files], 1)
	5728	if ($^O eq 'MacOS');
	5729
	5730	return 1;
	5731	}
	5732	}
	5733
	5734	sub unzip {
	5735	my($class,$file) = @_;
	5736	if ($CPAN::META->has_inst("Archive::Zip")) {
	5737	# blueprint of the code from Archive::Zip::Tree::extractTree();
	5738	my $zip = Archive::Zip->new();
	5739	my $status;
	5740	$status = $zip->read($file);
	5741	die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
	5742	$CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
	5743	my @members = $zip->members();
	5744	for my $member ( @members ) {
	5745	my $af = $member->fileName();
	5746	if ($af =~ m!^(/\|\.\./)!) {
	5747	$CPAN::Frontend->mydie("ALERT: Archive contains ".
	5748	"illegal member [$af]");
	5749	}
	5750	my $status = $member->extractToFileNamed( $af );
	5751	$CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
	5752	die "Extracting of file[$af] from zipfile[$file] failed\n" if
	5753	$status != Archive::Zip::AZ_OK();
	5754	return if $CPAN::Signal;
	5755	}
	5756	return 1;
	5757	} else {
	5758	my $unzip = $CPAN::Config->{unzip} or
	5759	$CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
	5760	my @system = ($unzip, $file);
	5761	return system(@system) == 0;
	5762	}
	5763	}
	5764
	5765
	5766	package CPAN::Version;
	5767	# CPAN::Version::vcmp courtesy Jost Krieger
	5768	sub vcmp {
	5769	my($self,$l,$r) = @_;
	5770	local($^W) = 0;
	5771	CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
	5772
	5773	return 0 if $l eq $r; # short circuit for quicker success
	5774
	5775	if ($l=~/^v/ <=> $r=~/^v/) {
	5776	for ($l,$r) {
	5777	next if /^v/;
	5778	$_ = $self->float2vv($_);
	5779	}
	5780	}
	5781
	5782	return
	5783	($l ne "undef") <=> ($r ne "undef") \|\|
	5784	($] >= 5.006 &&
	5785	$l =~ /^v/ &&
	5786	$r =~ /^v/ &&
	5787	$self->vstring($l) cmp $self->vstring($r)) \|\|
	5788	$l <=> $r \|\|
	5789	$l cmp $r;
	5790	}
	5791
	5792	sub vgt {
	5793	my($self,$l,$r) = @_;
	5794	$self->vcmp($l,$r) > 0;
	5795	}
	5796
	5797	sub vstring {
	5798	my($self,$n) = @_;
	5799	$n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
	5800	pack "U*", split /\./, $n;
	5801	}
	5802
	5803	# vv => visible vstring
	5804	sub float2vv {
	5805	my($self,$n) = @_;
	5806	my($rev) = int($n);
	5807	$rev \|\|= 0;
	5808	my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
	5809	# architecture influence
	5810	$mantissa \|\|= 0;
	5811	$mantissa .= "0" while length($mantissa)%3;
	5812	my $ret = "v" . $rev;
	5813	while ($mantissa) {
	5814	$mantissa =~ s/(\d{1,3})// or
	5815	die "Panic: length>0 but not a digit? mantissa[$mantissa]";
	5816	$ret .= ".".int($1);
	5817	}
	5818	# warn "n[$n]ret[$ret]";
	5819	$ret;
	5820	}
	5821
	5822	sub readable {
	5823	my($self,$n) = @_;
	5824	$n =~ /^([\w\-\+\.]+)/;
	5825
	5826	return $1 if defined $1 && length($1)>0;
	5827	# if the first user reaches version v43, he will be treated as "+".
	5828	# We'll have to decide about a new rule here then, depending on what
	5829	# will be the prevailing versioning behavior then.
	5830
	5831	if ($] < 5.006) { # or whenever v-strings were introduced
	5832	# we get them wrong anyway, whatever we do, because 5.005 will
	5833	# have already interpreted 0.2.4 to be "0.24". So even if he
	5834	# indexer sends us something like "v0.2.4" we compare wrongly.
	5835
	5836	# And if they say v1.2, then the old perl takes it as "v12"
	5837
	5838	$CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
	5839	return $n;
	5840	}
	5841	my $better = sprintf "v%vd", $n;
	5842	CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
	5843	return $better;
	5844	}
	5845
	5846	package CPAN;
	5847
	5848	1;
	5849
	5850	__END__
	5851
	5852	=head1 NAME
	5853
	5854	CPAN - query, download and build perl modules from CPAN sites
	5855
	5856	=head1 SYNOPSIS
	5857
	5858	Interactive mode:
	5859
	5860	perl -MCPAN -e shell;
	5861
	5862	Batch mode:
	5863
	5864	use CPAN;
	5865
	5866	autobundle, clean, install, make, recompile, test
	5867
	5868	=head1 DESCRIPTION
	5869
	5870	The CPAN module is designed to automate the make and install of perl
	5871	modules and extensions. It includes some searching capabilities and
	5872	knows how to use Net::FTP or LWP (or lynx or an external ftp client)
	5873	to fetch the raw data from the net.
	5874
	5875	Modules are fetched from one or more of the mirrored CPAN
	5876	(Comprehensive Perl Archive Network) sites and unpacked in a dedicated
	5877	directory.
	5878
	5879	The CPAN module also supports the concept of named and versioned
	5880	I<bundles> of modules. Bundles simplify the handling of sets of
	5881	related modules. See Bundles below.
	5882
	5883	The package contains a session manager and a cache manager. There is
	5884	no status retained between sessions. The session manager keeps track
	5885	of what has been fetched, built and installed in the current
	5886	session. The cache manager keeps track of the disk space occupied by
	5887	the make processes and deletes excess space according to a simple FIFO
	5888	mechanism.
	5889
	5890	For extended searching capabilities there's a plugin for CPAN available,
	5891	L<C<CPAN::WAIT>\|CPAN::WAIT>. C<CPAN::WAIT> is a full-text search engine
	5892	that indexes all documents available in CPAN authors directories. If
	5893	C<CPAN::WAIT> is installed on your system, the interactive shell of
	5894	CPAN.pm will enable the C<wq>, C<wr>, C<wd>, C<wl>, and C<wh> commands
	5895	which send queries to the WAIT server that has been configured for your
	5896	installation.
	5897
	5898	All other methods provided are accessible in a programmer style and in an
	5899	interactive shell style.
	5900
	5901	=head2 Interactive Mode
	5902
	5903	The interactive mode is entered by running
	5904
	5905	perl -MCPAN -e shell
	5906
	5907	which puts you into a readline interface. You will have the most fun if
	5908	you install Term::ReadKey and Term::ReadLine to enjoy both history and
	5909	command completion.
	5910
	5911	Once you are on the command line, type 'h' and the rest should be
	5912	self-explanatory.
	5913
	5914	The function call C<shell> takes two optional arguments, one is the
	5915	prompt, the second is the default initial command line (the latter
	5916	only works if a real ReadLine interface module is installed).
	5917
	5918	The most common uses of the interactive modes are
	5919
	5920	=over 2
	5921
	5922	=item Searching for authors, bundles, distribution files and modules
	5923
	5924	There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
	5925	for each of the four categories and another, C<i> for any of the
	5926	mentioned four. Each of the four entities is implemented as a class
	5927	with slightly differing methods for displaying an object.
	5928
	5929	Arguments you pass to these commands are either strings exactly matching
	5930	the identification string of an object or regular expressions that are
	5931	then matched case-insensitively against various attributes of the
	5932	objects. The parser recognizes a regular expression only if you
	5933	enclose it between two slashes.
	5934
	5935	The principle is that the number of found objects influences how an
	5936	item is displayed. If the search finds one item, the result is
	5937	displayed with the rather verbose method C<as_string>, but if we find
	5938	more than one, we display each object with the terse method
	5939	<as_glimpse>.
	5940
	5941	=item make, test, install, clean modules or distributions
	5942
	5943	These commands take any number of arguments and investigate what is
	5944	necessary to perform the action. If the argument is a distribution
	5945	file name (recognized by embedded slashes), it is processed. If it is
	5946	a module, CPAN determines the distribution file in which this module
	5947	is included and processes that, following any dependencies named in
	5948	the module's Makefile.PL (this behavior is controlled by
	5949	I<prerequisites_policy>.)
	5950
	5951	Any C<make> or C<test> are run unconditionally. An
	5952
	5953	install <distribution_file>
	5954
	5955	also is run unconditionally. But for
	5956
	5957	install <module>
	5958
	5959	CPAN checks if an install is actually needed for it and prints
	5960	I<module up to date> in the case that the distribution file containing
	5961	the module doesn't need to be updated.
	5962
	5963	CPAN also keeps track of what it has done within the current session
	5964	and doesn't try to build a package a second time regardless if it
	5965	succeeded or not. The C<force> command takes as a first argument the
	5966	method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
	5967	command from scratch.
	5968
	5969	Example:
	5970
	5971	cpan> install OpenGL
	5972	OpenGL is up to date.
	5973	cpan> force install OpenGL
	5974	Running make
	5975	OpenGL-0.4/
	5976	OpenGL-0.4/COPYRIGHT
	5977	[...]
	5978
	5979	A C<clean> command results in a
	5980
	5981	make clean
	5982
	5983	being executed within the distribution file's working directory.
	5984
	5985	=item get, readme, look module or distribution
	5986
	5987	C<get> downloads a distribution file without further action. C<readme>
	5988	displays the README file of the associated distribution. C<Look> gets
	5989	and untars (if not yet done) the distribution file, changes to the
	5990	appropriate directory and opens a subshell process in that directory.
	5991
	5992	=item ls author
	5993
	5994	C<ls> lists all distribution files in and below an author's CPAN
	5995	directory. Only those files that contain modules are listed and if
	5996	there is more than one for any given module, only the most recent one
	5997	is listed.
	5998
	5999	=item Signals
	6000
	6001	CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
	6002	in the cpan-shell it is intended that you can press C<^C> anytime and
	6003	return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
	6004	to clean up and leave the shell loop. You can emulate the effect of a
	6005	SIGTERM by sending two consecutive SIGINTs, which usually means by
	6006	pressing C<^C> twice.
	6007
	6008	CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
	6009	SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
	6010
	6011	=back
	6012
	6013	=head2 CPAN::Shell
	6014
	6015	The commands that are available in the shell interface are methods in
	6016	the package CPAN::Shell. If you enter the shell command, all your
	6017	input is split by the Text::ParseWords::shellwords() routine which
	6018	acts like most shells do. The first word is being interpreted as the
	6019	method to be called and the rest of the words are treated as arguments
	6020	to this method. Continuation lines are supported if a line ends with a
	6021	literal backslash.
	6022
	6023	=head2 autobundle
	6024
	6025	C<autobundle> writes a bundle file into the
	6026	C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
	6027	a list of all modules that are both available from CPAN and currently
	6028	installed within @INC. The name of the bundle file is based on the
	6029	current date and a counter.
	6030
	6031	=head2 recompile
	6032
	6033	recompile() is a very special command in that it takes no argument and
	6034	runs the make/test/install cycle with brute force over all installed
	6035	dynamically loadable extensions (aka XS modules) with 'force' in
	6036	effect. The primary purpose of this command is to finish a network
	6037	installation. Imagine, you have a common source tree for two different
	6038	architectures. You decide to do a completely independent fresh
	6039	installation. You start on one architecture with the help of a Bundle
	6040	file produced earlier. CPAN installs the whole Bundle for you, but
	6041	when you try to repeat the job on the second architecture, CPAN
	6042	responds with a C<"Foo up to date"> message for all modules. So you
	6043	invoke CPAN's recompile on the second architecture and you're done.
	6044
	6045	Another popular use for C<recompile> is to act as a rescue in case your
	6046	perl breaks binary compatibility. If one of the modules that CPAN uses
	6047	is in turn depending on binary compatibility (so you cannot run CPAN
	6048	commands), then you should try the CPAN::Nox module for recovery.
	6049
	6050	=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
	6051
	6052	Although it may be considered internal, the class hierarchy does matter
	6053	for both users and programmer. CPAN.pm deals with above mentioned four
	6054	classes, and all those classes share a set of methods. A classical
	6055	single polymorphism is in effect. A metaclass object registers all
	6056	objects of all kinds and indexes them with a string. The strings
	6057	referencing objects have a separated namespace (well, not completely
	6058	separated):
	6059
	6060	Namespace Class
	6061
	6062	words containing a "/" (slash) Distribution
	6063	words starting with Bundle:: Bundle
	6064	everything else Module or Author
	6065
	6066	Modules know their associated Distribution objects. They always refer
	6067	to the most recent official release. Developers may mark their releases
	6068	as unstable development versions (by inserting an underbar into the
	6069	module version number which will also be reflected in the distribution
	6070	name when you run 'make dist'), so the really hottest and newest
	6071	distribution is not always the default. If a module Foo circulates
	6072	on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
	6073	way to install version 1.23 by saying
	6074
	6075	install Foo
	6076
	6077	This would install the complete distribution file (say
	6078	BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
	6079	like to install version 1.23_90, you need to know where the
	6080	distribution file resides on CPAN relative to the authors/id/
	6081	directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
	6082	so you would have to say
	6083
	6084	install BAR/Foo-1.23_90.tar.gz
	6085
	6086	The first example will be driven by an object of the class
	6087	CPAN::Module, the second by an object of class CPAN::Distribution.
	6088
	6089	=head2 Programmer's interface
	6090
	6091	If you do not enter the shell, the available shell commands are both
	6092	available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
	6093	functions in the calling package (C<install(...)>).
	6094
	6095	There's currently only one class that has a stable interface -
	6096	CPAN::Shell. All commands that are available in the CPAN shell are
	6097	methods of the class CPAN::Shell. Each of the commands that produce
	6098	listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
	6099	the IDs of all modules within the list.
	6100
	6101	=over 2
	6102
	6103	=item expand($type,@things)
	6104
	6105	The IDs of all objects available within a program are strings that can
	6106	be expanded to the corresponding real objects with the
	6107	C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
	6108	list of CPAN::Module objects according to the C<@things> arguments
	6109	given. In scalar context it only returns the first element of the
	6110	list.
	6111
	6112	=item expandany(@things)
	6113
	6114	Like expand, but returns objects of the appropriate type, i.e.
	6115	CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
	6116	CPAN::Distribution objects fro distributions.
	6117
	6118	=item Programming Examples
	6119
	6120	This enables the programmer to do operations that combine
	6121	functionalities that are available in the shell.
	6122
	6123	# install everything that is outdated on my disk:
	6124	perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
	6125
	6126	# install my favorite programs if necessary:
	6127	for $mod (qw(Net::FTP Digest::MD5 Data::Dumper)){
	6128	my $obj = CPAN::Shell->expand('Module',$mod);
	6129	$obj->install;
	6130	}
	6131
	6132	# list all modules on my disk that have no VERSION number
	6133	for $mod (CPAN::Shell->expand("Module","/./")){
	6134	next unless $mod->inst_file;
	6135	# MakeMaker convention for undefined $VERSION:
	6136	next unless $mod->inst_version eq "undef";
	6137	print "No VERSION in ", $mod->id, "\n";
	6138	}
	6139
	6140	# find out which distribution on CPAN contains a module:
	6141	print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
	6142
	6143	Or if you want to write a cronjob to watch The CPAN, you could list
	6144	all modules that need updating. First a quick and dirty way:
	6145
	6146	perl -e 'use CPAN; CPAN::Shell->r;'
	6147
	6148	If you don't want to get any output in the case that all modules are
	6149	up to date, you can parse the output of above command for the regular
	6150	expression //modules are up to date// and decide to mail the output
	6151	only if it doesn't match. Ick?
	6152
	6153	If you prefer to do it more in a programmer style in one single
	6154	process, maybe something like this suits you better:
	6155
	6156	# list all modules on my disk that have newer versions on CPAN
	6157	for $mod (CPAN::Shell->expand("Module","/./")){
	6158	next unless $mod->inst_file;
	6159	next if $mod->uptodate;
	6160	printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
	6161	$mod->id, $mod->inst_version, $mod->cpan_version;
	6162	}
	6163
	6164	If that gives you too much output every day, you maybe only want to
	6165	watch for three modules. You can write
	6166
	6167	for $mod (CPAN::Shell->expand("Module","/Apache\|LWP\|CGI/")){
	6168
	6169	as the first line instead. Or you can combine some of the above
	6170	tricks:
	6171
	6172	# watch only for a new mod_perl module
	6173	$mod = CPAN::Shell->expand("Module","mod_perl");
	6174	exit if $mod->uptodate;
	6175	# new mod_perl arrived, let me know all update recommendations
	6176	CPAN::Shell->r;
	6177
	6178	=back
	6179
	6180	=head2 Methods in the other Classes
	6181
	6182	The programming interface for the classes CPAN::Module,
	6183	CPAN::Distribution, CPAN::Bundle, and CPAN::Author is still considered
	6184	beta and partially even alpha. In the following paragraphs only those
	6185	methods are documented that have proven useful over a longer time and
	6186	thus are unlikely to change.
	6187
	6188	=over 4
	6189
	6190	=item CPAN::Author::as_glimpse()
	6191
	6192	Returns a one-line description of the author
	6193
	6194	=item CPAN::Author::as_string()
	6195
	6196	Returns a multi-line description of the author
	6197
	6198	=item CPAN::Author::email()
	6199
	6200	Returns the author's email address
	6201
	6202	=item CPAN::Author::fullname()
	6203
	6204	Returns the author's name
	6205
	6206	=item CPAN::Author::name()
	6207
	6208	An alias for fullname
	6209
	6210	=item CPAN::Bundle::as_glimpse()
	6211
	6212	Returns a one-line description of the bundle
	6213
	6214	=item CPAN::Bundle::as_string()
	6215
	6216	Returns a multi-line description of the bundle
	6217
	6218	=item CPAN::Bundle::clean()
	6219
	6220	Recursively runs the C<clean> method on all items contained in the bundle.
	6221
	6222	=item CPAN::Bundle::contains()
	6223
	6224	Returns a list of objects' IDs contained in a bundle. The associated
	6225	objects may be bundles, modules or distributions.
	6226
	6227	=item CPAN::Bundle::force($method,@args)
	6228
	6229	Forces CPAN to perform a task that normally would have failed. Force
	6230	takes as arguments a method name to be called and any number of
	6231	additional arguments that should be passed to the called method. The
	6232	internals of the object get the needed changes so that CPAN.pm does
	6233	not refuse to take the action. The C<force> is passed recursively to
	6234	all contained objects.
	6235
	6236	=item CPAN::Bundle::get()
	6237
	6238	Recursively runs the C<get> method on all items contained in the bundle
	6239
	6240	=item CPAN::Bundle::inst_file()
	6241
	6242	Returns the highest installed version of the bundle in either @INC or
	6243	C<$CPAN::Config->{cpan_home}>. Note that this is different from
	6244	CPAN::Module::inst_file.
	6245
	6246	=item CPAN::Bundle::inst_version()
	6247
	6248	Like CPAN::Bundle::inst_file, but returns the $VERSION
	6249
	6250	=item CPAN::Bundle::uptodate()
	6251
	6252	Returns 1 if the bundle itself and all its members are uptodate.
	6253
	6254	=item CPAN::Bundle::install()
	6255
	6256	Recursively runs the C<install> method on all items contained in the bundle
	6257
	6258	=item CPAN::Bundle::make()
	6259
	6260	Recursively runs the C<make> method on all items contained in the bundle
	6261
	6262	=item CPAN::Bundle::readme()
	6263
	6264	Recursively runs the C<readme> method on all items contained in the bundle
	6265
	6266	=item CPAN::Bundle::test()
	6267
	6268	Recursively runs the C<test> method on all items contained in the bundle
	6269
	6270	=item CPAN::Distribution::as_glimpse()
	6271
	6272	Returns a one-line description of the distribution
	6273
	6274	=item CPAN::Distribution::as_string()
	6275
	6276	Returns a multi-line description of the distribution
	6277
	6278	=item CPAN::Distribution::clean()
	6279
	6280	Changes to the directory where the distribution has been unpacked and
	6281	runs C<make clean> there.
	6282
	6283	=item CPAN::Distribution::containsmods()
	6284
	6285	Returns a list of IDs of modules contained in a distribution file.
	6286	Only works for distributions listed in the 02packages.details.txt.gz
	6287	file. This typically means that only the most recent version of a
	6288	distribution is covered.
	6289
	6290	=item CPAN::Distribution::cvs_import()
	6291
	6292	Changes to the directory where the distribution has been unpacked and
	6293	runs something like
	6294
	6295	cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
	6296
	6297	there.
	6298
	6299	=item CPAN::Distribution::dir()
	6300
	6301	Returns the directory into which this distribution has been unpacked.
	6302
	6303	=item CPAN::Distribution::force($method,@args)
	6304
	6305	Forces CPAN to perform a task that normally would have failed. Force
	6306	takes as arguments a method name to be called and any number of
	6307	additional arguments that should be passed to the called method. The
	6308	internals of the object get the needed changes so that CPAN.pm does
	6309	not refuse to take the action.
	6310
	6311	=item CPAN::Distribution::get()
	6312
	6313	Downloads the distribution from CPAN and unpacks it. Does nothing if
	6314	the distribution has already been downloaded and unpacked within the
	6315	current session.
	6316
	6317	=item CPAN::Distribution::install()
	6318
	6319	Changes to the directory where the distribution has been unpacked and
	6320	runs the external command C<make install> there. If C<make> has not
	6321	yet been run, it will be run first. A C<make test> will be issued in
	6322	any case and if this fails, the install will be cancelled. The
	6323	cancellation can be avoided by letting C<force> run the C<install> for
	6324	you.
	6325
	6326	=item CPAN::Distribution::isa_perl()
	6327
	6328	Returns 1 if this distribution file seems to be a perl distribution.
	6329	Normally this is derived from the file name only, but the index from
	6330	CPAN can contain a hint to achieve a return value of true for other
	6331	filenames too.
	6332
	6333	=item CPAN::Distribution::look()
	6334
	6335	Changes to the directory where the distribution has been unpacked and
	6336	opens a subshell there. Exiting the subshell returns.
	6337
	6338	=item CPAN::Distribution::make()
	6339
	6340	First runs the C<get> method to make sure the distribution is
	6341	downloaded and unpacked. Changes to the directory where the
	6342	distribution has been unpacked and runs the external commands C<perl
	6343	Makefile.PL> and C<make> there.
	6344
	6345	=item CPAN::Distribution::prereq_pm()
	6346
	6347	Returns the hash reference that has been announced by a distribution
	6348	as the PREREQ_PM hash in the Makefile.PL. Note: works only after an
	6349	attempt has been made to C<make> the distribution. Returns undef
	6350	otherwise.
	6351
	6352	=item CPAN::Distribution::readme()
	6353
	6354	Downloads the README file associated with a distribution and runs it
	6355	through the pager specified in C<$CPAN::Config->{pager}>.
	6356
	6357	=item CPAN::Distribution::test()
	6358
	6359	Changes to the directory where the distribution has been unpacked and
	6360	runs C<make test> there.
	6361
	6362	=item CPAN::Distribution::uptodate()
	6363
	6364	Returns 1 if all the modules contained in the distribution are
	6365	uptodate. Relies on containsmods.
	6366
	6367	=item CPAN::Index::force_reload()
	6368
	6369	Forces a reload of all indices.
	6370
	6371	=item CPAN::Index::reload()
	6372
	6373	Reloads all indices if they have been read more than
	6374	C<$CPAN::Config->{index_expire}> days.
	6375
	6376	=item CPAN::InfoObj::dump()
	6377
	6378	CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
	6379	inherit this method. It prints the data structure associated with an
	6380	object. Useful for debugging. Note: the data structure is considered
	6381	internal and thus subject to change without notice.
	6382
	6383	=item CPAN::Module::as_glimpse()
	6384
	6385	Returns a one-line description of the module
	6386
	6387	=item CPAN::Module::as_string()
	6388
	6389	Returns a multi-line description of the module
	6390
	6391	=item CPAN::Module::clean()
	6392
	6393	Runs a clean on the distribution associated with this module.
	6394
	6395	=item CPAN::Module::cpan_file()
	6396
	6397	Returns the filename on CPAN that is associated with the module.
	6398
	6399	=item CPAN::Module::cpan_version()
	6400
	6401	Returns the latest version of this module available on CPAN.
	6402
	6403	=item CPAN::Module::cvs_import()
	6404
	6405	Runs a cvs_import on the distribution associated with this module.
	6406
	6407	=item CPAN::Module::description()
	6408
	6409	Returns a 44 chracter description of this module. Only available for
	6410	modules listed in The Module List (CPAN/modules/00modlist.long.html
	6411	or 00modlist.long.txt.gz)
	6412
	6413	=item CPAN::Module::force($method,@args)
	6414
	6415	Forces CPAN to perform a task that normally would have failed. Force
	6416	takes as arguments a method name to be called and any number of
	6417	additional arguments that should be passed to the called method. The
	6418	internals of the object get the needed changes so that CPAN.pm does
	6419	not refuse to take the action.
	6420
	6421	=item CPAN::Module::get()
	6422
	6423	Runs a get on the distribution associated with this module.
	6424
	6425	=item CPAN::Module::inst_file()
	6426
	6427	Returns the filename of the module found in @INC. The first file found
	6428	is reported just like perl itself stops searching @INC when it finds a
	6429	module.
	6430
	6431	=item CPAN::Module::inst_version()
	6432
	6433	Returns the version number of the module in readable format.
	6434
	6435	=item CPAN::Module::install()
	6436
	6437	Runs an C<install> on the distribution associated with this module.
	6438
	6439	=item CPAN::Module::look()
	6440
	6441	Changes to the directory where the distribution assoicated with this
	6442	module has been unpacked and opens a subshell there. Exiting the
	6443	subshell returns.
	6444
	6445	=item CPAN::Module::make()
	6446
	6447	Runs a C<make> on the distribution associated with this module.
	6448
	6449	=item CPAN::Module::manpage_headline()
	6450
	6451	If module is installed, peeks into the module's manpage, reads the
	6452	headline and returns it. Moreover, if the module has been downloaded
	6453	within this session, does the equivalent on the downloaded module even
	6454	if it is not installed.
	6455
	6456	=item CPAN::Module::readme()
	6457
	6458	Runs a C<readme> on the distribution associated with this module.
	6459
	6460	=item CPAN::Module::test()
	6461
	6462	Runs a C<test> on the distribution associated with this module.
	6463
	6464	=item CPAN::Module::uptodate()
	6465
	6466	Returns 1 if the module is installed and up-to-date.
	6467
	6468	=item CPAN::Module::userid()
	6469
	6470	Returns the author's ID of the module.
	6471
	6472	=back
	6473
	6474	=head2 Cache Manager
	6475
	6476	Currently the cache manager only keeps track of the build directory
	6477	($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
	6478	deletes complete directories below C<build_dir> as soon as the size of
	6479	all directories there gets bigger than $CPAN::Config->{build_cache}
	6480	(in MB). The contents of this cache may be used for later
	6481	re-installations that you intend to do manually, but will never be
	6482	trusted by CPAN itself. This is due to the fact that the user might
	6483	use these directories for building modules on different architectures.
	6484
	6485	There is another directory ($CPAN::Config->{keep_source_where}) where
	6486	the original distribution files are kept. This directory is not
	6487	covered by the cache manager and must be controlled by the user. If
	6488	you choose to have the same directory as build_dir and as
	6489	keep_source_where directory, then your sources will be deleted with
	6490	the same fifo mechanism.
	6491
	6492	=head2 Bundles
	6493
	6494	A bundle is just a perl module in the namespace Bundle:: that does not
	6495	define any functions or methods. It usually only contains documentation.
	6496
	6497	It starts like a perl module with a package declaration and a $VERSION
	6498	variable. After that the pod section looks like any other pod with the
	6499	only difference being that I<one special pod section> exists starting with
	6500	(verbatim):
	6501
	6502	=head1 CONTENTS
	6503
	6504	In this pod section each line obeys the format
	6505
	6506	Module_Name [Version_String] [- optional text]
	6507
	6508	The only required part is the first field, the name of a module
	6509	(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
	6510	of the line is optional. The comment part is delimited by a dash just
	6511	as in the man page header.
	6512
	6513	The distribution of a bundle should follow the same convention as
	6514	other distributions.
	6515
	6516	Bundles are treated specially in the CPAN package. If you say 'install
	6517	Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
	6518	the modules in the CONTENTS section of the pod. You can install your
	6519	own Bundles locally by placing a conformant Bundle file somewhere into
	6520	your @INC path. The autobundle() command which is available in the
	6521	shell interface does that for you by including all currently installed
	6522	modules in a snapshot bundle file.
	6523
	6524	=head2 Prerequisites
	6525
	6526	If you have a local mirror of CPAN and can access all files with
	6527	"file:" URLs, then you only need a perl better than perl5.003 to run
	6528	this module. Otherwise Net::FTP is strongly recommended. LWP may be
	6529	required for non-UNIX systems or if your nearest CPAN site is
	6530	associated with an URL that is not C<ftp:>.
	6531
	6532	If you have neither Net::FTP nor LWP, there is a fallback mechanism
	6533	implemented for an external ftp command or for an external lynx
	6534	command.
	6535
	6536	=head2 Finding packages and VERSION
	6537
	6538	This module presumes that all packages on CPAN
	6539
	6540	=over 2
	6541
	6542	=item *
	6543
	6544	declare their $VERSION variable in an easy to parse manner. This
	6545	prerequisite can hardly be relaxed because it consumes far too much
	6546	memory to load all packages into the running program just to determine
	6547	the $VERSION variable. Currently all programs that are dealing with
	6548	version use something like this
	6549
	6550	perl -MExtUtils::MakeMaker -le \
	6551	'print MM->parse_version(shift)' filename
	6552
	6553	If you are author of a package and wonder if your $VERSION can be
	6554	parsed, please try the above method.
	6555
	6556	=item *
	6557
	6558	come as compressed or gzipped tarfiles or as zip files and contain a
	6559	Makefile.PL (well, we try to handle a bit more, but without much
	6560	enthusiasm).
	6561
	6562	=back
	6563
	6564	=head2 Debugging
	6565
	6566	The debugging of this module is a bit complex, because we have
	6567	interferences of the software producing the indices on CPAN, of the
	6568	mirroring process on CPAN, of packaging, of configuration, of
	6569	synchronicity, and of bugs within CPAN.pm.
	6570
	6571	For code debugging in interactive mode you can try "o debug" which
	6572	will list options for debugging the various parts of the code. You
	6573	should know that "o debug" has built-in completion support.
	6574
	6575	For data debugging there is the C<dump> command which takes the same
	6576	arguments as make/test/install and outputs the object's Data::Dumper
	6577	dump.
	6578
	6579	=head2 Floppy, Zip, Offline Mode
	6580
	6581	CPAN.pm works nicely without network too. If you maintain machines
	6582	that are not networked at all, you should consider working with file:
	6583	URLs. Of course, you have to collect your modules somewhere first. So
	6584	you might use CPAN.pm to put together all you need on a networked
	6585	machine. Then copy the $CPAN::Config->{keep_source_where} (but not
	6586	$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
	6587	of a personal CPAN. CPAN.pm on the non-networked machines works nicely
	6588	with this floppy. See also below the paragraph about CD-ROM support.
	6589
	6590	=head1 CONFIGURATION
	6591
	6592	When the CPAN module is installed, a site wide configuration file is
	6593	created as CPAN/Config.pm. The default values defined there can be
	6594	overridden in another configuration file: CPAN/MyConfig.pm. You can
	6595	store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
	6596	$HOME/.cpan is added to the search path of the CPAN module before the
	6597	use() or require() statements.
	6598
	6599	Currently the following keys in the hash reference $CPAN::Config are
	6600	defined:
	6601
	6602	build_cache size of cache for directories to build modules
	6603	build_dir locally accessible directory to build modules
	6604	index_expire after this many days refetch index files
	6605	cache_metadata use serializer to cache metadata
	6606	cpan_home local directory reserved for this package
	6607	dontload_hash anonymous hash: modules in the keys will not be
	6608	loaded by the CPAN::has_inst() routine
	6609	gzip location of external program gzip
	6610	inactivity_timeout breaks interactive Makefile.PLs after this
	6611	many seconds inactivity. Set to 0 to never break.
	6612	inhibit_startup_message
	6613	if true, does not print the startup message
	6614	keep_source_where directory in which to keep the source (if we do)
	6615	make location of external make program
	6616	make_arg arguments that should always be passed to 'make'
	6617	make_install_arg same as make_arg for 'make install'
	6618	makepl_arg arguments passed to 'perl Makefile.PL'
	6619	pager location of external program more (or any pager)
	6620	prerequisites_policy
	6621	what to do if you are missing module prerequisites
	6622	('follow' automatically, 'ask' me, or 'ignore')
	6623	proxy_user username for accessing an authenticating proxy
	6624	proxy_pass password for accessing an authenticating proxy
	6625	scan_cache controls scanning of cache ('atstart' or 'never')
	6626	tar location of external program tar
	6627	term_is_latin if true internal UTF-8 is translated to ISO-8859-1
	6628	(and nonsense for characters outside latin range)
	6629	unzip location of external program unzip
	6630	urllist arrayref to nearby CPAN sites (or equivalent locations)
	6631	wait_list arrayref to a wait server to try (See CPAN::WAIT)
	6632	ftp_proxy, } the three usual variables for configuring
	6633	http_proxy, } proxy requests. Both as CPAN::Config variables
	6634	no_proxy } and as environment variables configurable.
	6635
	6636	You can set and query each of these options interactively in the cpan
	6637	shell with the command set defined within the C<o conf> command:
	6638
	6639	=over 2
	6640
	6641	=item C<o conf E<lt>scalar optionE<gt>>
	6642
	6643	prints the current value of the I<scalar option>
	6644
	6645	=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
	6646
	6647	Sets the value of the I<scalar option> to I<value>
	6648
	6649	=item C<o conf E<lt>list optionE<gt>>
	6650
	6651	prints the current value of the I<list option> in MakeMaker's
	6652	neatvalue format.
	6653
	6654	=item C<o conf E<lt>list optionE<gt> [shift\|pop]>
	6655
	6656	shifts or pops the array in the I<list option> variable
	6657
	6658	=item C<o conf E<lt>list optionE<gt> [unshift\|push\|splice] E<lt>listE<gt>>
	6659
	6660	works like the corresponding perl commands.
	6661
	6662	=back
	6663
	6664	=head2 Note on urllist parameter's format
	6665
	6666	urllist parameters are URLs according to RFC 1738. We do a little
	6667	guessing if your URL is not compliant, but if you have problems with
	6668	file URLs, please try the correct format. Either:
	6669
	6670	file://localhost/whatever/ftp/pub/CPAN/
	6671
	6672	or
	6673
	6674	file:///home/ftp/pub/CPAN/
	6675
	6676	=head2 urllist parameter has CD-ROM support
	6677
	6678	The C<urllist> parameter of the configuration table contains a list of
	6679	URLs that are to be used for downloading. If the list contains any
	6680	C<file> URLs, CPAN always tries to get files from there first. This
	6681	feature is disabled for index files. So the recommendation for the
	6682	owner of a CD-ROM with CPAN contents is: include your local, possibly
	6683	outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
	6684
	6685	o conf urllist push file://localhost/CDROM/CPAN
	6686
	6687	CPAN.pm will then fetch the index files from one of the CPAN sites
	6688	that come at the beginning of urllist. It will later check for each
	6689	module if there is a local copy of the most recent version.
	6690
	6691	Another peculiarity of urllist is that the site that we could
	6692	successfully fetch the last file from automatically gets a preference
	6693	token and is tried as the first site for the next request. So if you
	6694	add a new site at runtime it may happen that the previously preferred
	6695	site will be tried another time. This means that if you want to disallow
	6696	a site for the next transfer, it must be explicitly removed from
	6697	urllist.
	6698
	6699	=head1 SECURITY
	6700
	6701	There's no strong security layer in CPAN.pm. CPAN.pm helps you to
	6702	install foreign, unmasked, unsigned code on your machine. We compare
	6703	to a checksum that comes from the net just as the distribution file
	6704	itself. If somebody has managed to tamper with the distribution file,
	6705	they may have as well tampered with the CHECKSUMS file. Future
	6706	development will go towards strong authentication.
	6707
	6708	=head1 EXPORT
	6709
	6710	Most functions in package CPAN are exported per default. The reason
	6711	for this is that the primary use is intended for the cpan shell or for
	6712	oneliners.
	6713
	6714	=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
	6715
	6716	Populating a freshly installed perl with my favorite modules is pretty
	6717	easy if you maintain a private bundle definition file. To get a useful
	6718	blueprint of a bundle definition file, the command autobundle can be used
	6719	on the CPAN shell command line. This command writes a bundle definition
	6720	file for all modules that are installed for the currently running perl
	6721	interpreter. It's recommended to run this command only once and from then
	6722	on maintain the file manually under a private name, say
	6723	Bundle/my_bundle.pm. With a clever bundle file you can then simply say
	6724
	6725	cpan> install Bundle::my_bundle
	6726
	6727	then answer a few questions and then go out for a coffee.
	6728
	6729	Maintaining a bundle definition file means keeping track of two
	6730	things: dependencies and interactivity. CPAN.pm sometimes fails on
	6731	calculating dependencies because not all modules define all MakeMaker
	6732	attributes correctly, so a bundle definition file should specify
	6733	prerequisites as early as possible. On the other hand, it's a bit
	6734	annoying that many distributions need some interactive configuring. So
	6735	what I try to accomplish in my private bundle file is to have the
	6736	packages that need to be configured early in the file and the gentle
	6737	ones later, so I can go out after a few minutes and leave CPAN.pm
	6738	untended.
	6739
	6740	=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
	6741
	6742	Thanks to Graham Barr for contributing the following paragraphs about
	6743	the interaction between perl, and various firewall configurations. For
	6744	further informations on firewalls, it is recommended to consult the
	6745	documentation that comes with the ncftp program. If you are unable to
	6746	go through the firewall with a simple Perl setup, it is very likely
	6747	that you can configure ncftp so that it works for your firewall.
	6748
	6749	=head2 Three basic types of firewalls
	6750
	6751	Firewalls can be categorized into three basic types.
	6752
	6753	=over 4
	6754
	6755	=item http firewall
	6756
	6757	This is where the firewall machine runs a web server and to access the
	6758	outside world you must do it via the web server. If you set environment
	6759	variables like http_proxy or ftp_proxy to a values beginning with http://
	6760	or in your web browser you have to set proxy information then you know
	6761	you are running a http firewall.
	6762
	6763	To access servers outside these types of firewalls with perl (even for
	6764	ftp) you will need to use LWP.
	6765
	6766	=item ftp firewall
	6767
	6768	This where the firewall machine runs a ftp server. This kind of
	6769	firewall will only let you access ftp servers outside the firewall.
	6770	This is usually done by connecting to the firewall with ftp, then
	6771	entering a username like "user@outside.host.com"
	6772
	6773	To access servers outside these type of firewalls with perl you
	6774	will need to use Net::FTP.
	6775
	6776	=item One way visibility
	6777
	6778	I say one way visibility as these firewalls try to make themselve look
	6779	invisible to the users inside the firewall. An FTP data connection is
	6780	normally created by sending the remote server your IP address and then
	6781	listening for the connection. But the remote server will not be able to
	6782	connect to you because of the firewall. So for these types of firewall
	6783	FTP connections need to be done in a passive mode.
	6784
	6785	There are two that I can think off.
	6786
	6787	=over 4
	6788
	6789	=item SOCKS
	6790
	6791	If you are using a SOCKS firewall you will need to compile perl and link
	6792	it with the SOCKS library, this is what is normally called a 'socksified'
	6793	perl. With this executable you will be able to connect to servers outside
	6794	the firewall as if it is not there.
	6795
	6796	=item IP Masquerade
	6797
	6798	This is the firewall implemented in the Linux kernel, it allows you to
	6799	hide a complete network behind one IP address. With this firewall no
	6800	special compiling is needed as you can access hosts directly.
	6801
	6802	=back
	6803
	6804	=back
	6805
	6806	=head2 Configuring lynx or ncftp for going through a firewall
	6807
	6808	If you can go through your firewall with e.g. lynx, presumably with a
	6809	command such as
	6810
	6811	/usr/local/bin/lynx -pscott:tiger
	6812
	6813	then you would configure CPAN.pm with the command
	6814
	6815	o conf lynx "/usr/local/bin/lynx -pscott:tiger"
	6816
	6817	That's all. Similarly for ncftp or ftp, you would configure something
	6818	like
	6819
	6820	o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
	6821
	6822	Your milage may vary...
	6823
	6824	=head1 FAQ
	6825
	6826	=over 4
	6827
	6828	=item 1)
	6829
	6830	I installed a new version of module X but CPAN keeps saying,
	6831	I have the old version installed
	6832
	6833	Most probably you B<do> have the old version installed. This can
	6834	happen if a module installs itself into a different directory in the
	6835	@INC path than it was previously installed. This is not really a
	6836	CPAN.pm problem, you would have the same problem when installing the
	6837	module manually. The easiest way to prevent this behaviour is to add
	6838	the argument C<UNINST=1> to the C<make install> call, and that is why
	6839	many people add this argument permanently by configuring
	6840
	6841	o conf make_install_arg UNINST=1
	6842
	6843	=item 2)
	6844
	6845	So why is UNINST=1 not the default?
	6846
	6847	Because there are people who have their precise expectations about who
	6848	may install where in the @INC path and who uses which @INC array. In
	6849	fine tuned environments C<UNINST=1> can cause damage.
	6850
	6851	=item 3)
	6852
	6853	I want to clean up my mess, and install a new perl along with
	6854	all modules I have. How do I go about it?
	6855
	6856	Run the autobundle command for your old perl and optionally rename the
	6857	resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
	6858	with the Configure option prefix, e.g.
	6859
	6860	./Configure -Dprefix=/usr/local/perl-5.6.78.9
	6861
	6862	Install the bundle file you produced in the first step with something like
	6863
	6864	cpan> install Bundle::mybundle
	6865
	6866	and you're done.
	6867
	6868	=item 4)
	6869
	6870	When I install bundles or multiple modules with one command
	6871	there is too much output to keep track of.
	6872
	6873	You may want to configure something like
	6874
	6875	o conf make_arg "\| tee -ai /root/.cpan/logs/make.out"
	6876	o conf make_install_arg "\| tee -ai /root/.cpan/logs/make_install.out"
	6877
	6878	so that STDOUT is captured in a file for later inspection.
	6879
	6880
	6881	=item 5)
	6882
	6883	I am not root, how can I install a module in a personal directory?
	6884
	6885	You will most probably like something like this:
	6886
	6887	o conf makepl_arg "LIB=~/myperl/lib \
	6888	INSTALLMAN1DIR=~/myperl/man/man1 \
	6889	INSTALLMAN3DIR=~/myperl/man/man3"
	6890	install Sybase::Sybperl
	6891
	6892	You can make this setting permanent like all C<o conf> settings with
	6893	C<o conf commit>.
	6894
	6895	You will have to add ~/myperl/man to the MANPATH environment variable
	6896	and also tell your perl programs to look into ~/myperl/lib, e.g. by
	6897	including
	6898
	6899	use lib "$ENV{HOME}/myperl/lib";
	6900
	6901	or setting the PERL5LIB environment variable.
	6902
	6903	Another thing you should bear in mind is that the UNINST parameter
	6904	should never be set if you are not root.
	6905
	6906	=item 6)
	6907
	6908	How to get a package, unwrap it, and make a change before building it?
	6909
	6910	look Sybase::Sybperl
	6911
	6912	=item 7)
	6913
	6914	I installed a Bundle and had a couple of fails. When I
	6915	retried, everything resolved nicely. Can this be fixed to work
	6916	on first try?
	6917
	6918	The reason for this is that CPAN does not know the dependencies of all
	6919	modules when it starts out. To decide about the additional items to
	6920	install, it just uses data found in the generated Makefile. An
	6921	undetected missing piece breaks the process. But it may well be that
	6922	your Bundle installs some prerequisite later than some depending item
	6923	and thus your second try is able to resolve everything. Please note,
	6924	CPAN.pm does not know the dependency tree in advance and cannot sort
	6925	the queue of things to install in a topologically correct order. It
	6926	resolves perfectly well IFF all modules declare the prerequisites
	6927	correctly with the PREREQ_PM attribute to MakeMaker. For bundles which
	6928	fail and you need to install often, it is recommended sort the Bundle
	6929	definition file manually. It is planned to improve the metadata
	6930	situation for dependencies on CPAN in general, but this will still
	6931	take some time.
	6932
	6933	=item 8)
	6934
	6935	In our intranet we have many modules for internal use. How
	6936	can I integrate these modules with CPAN.pm but without uploading
	6937	the modules to CPAN?
	6938
	6939	Have a look at the CPAN::Site module.
	6940
	6941	=item 9)
	6942
	6943	When I run CPAN's shell, I get error msg about line 1 to 4,
	6944	setting meta input/output via the /etc/inputrc file.
	6945
	6946	Some versions of readline are picky about capitalization in the
	6947	/etc/inputrc file and specifically RedHat 6.2 comes with a
	6948	/etc/inputrc that contains the word C<on> in lowercase. Change the
	6949	occurrences of C<on> to C<On> and the bug should disappear.
	6950
	6951	=item 10)
	6952
	6953	Some authors have strange characters in their names.
	6954
	6955	Internally CPAN.pm uses the UTF-8 charset. If your terminal is
	6956	expecting ISO-8859-1 charset, a converter can be activated by setting
	6957	term_is_latin to a true value in your config file. One way of doing so
	6958	would be
	6959
	6960	cpan> ! $CPAN::Config->{term_is_latin}=1
	6961
	6962	Extended support for converters will be made available as soon as perl
	6963	becomes stable with regard to charset issues.
	6964
	6965	=back
	6966
	6967	=head1 BUGS
	6968
	6969	We should give coverage for B<all> of the CPAN and not just the PAUSE
	6970	part, right? In this discussion CPAN and PAUSE have become equal --
	6971	but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
	6972	PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
	6973
	6974	Future development should be directed towards a better integration of
	6975	the other parts.
	6976
	6977	If a Makefile.PL requires special customization of libraries, prompts
	6978	the user for special input, etc. then you may find CPAN is not able to
	6979	build the distribution. In that case, you should attempt the
	6980	traditional method of building a Perl module package from a shell.
	6981
	6982	=head1 AUTHOR
	6983
	6984	Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
	6985
	6986	=head1 TRANSLATIONS
	6987
	6988	Kawai,Takanori provides a Japanese translation of this manpage at
	6989	http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
	6990
	6991	=head1 SEE ALSO
	6992
	6993	perl(1), CPAN::Nox(3)
	6994
	6995	=cut
	6996