diff options
| author | Chris Williams <chris@bingosnet.co.uk> | 2009-09-08 11:02:09 +0100 |
|---|---|---|
| committer | Chris Williams <chris@bingosnet.co.uk> | 2009-09-08 11:02:40 +0100 |
| commit | 087f1bf3a29bd837d3103a3637ea69e4499ca06b (patch) | |
| tree | b078f6dae5d32df12ffa5d57eb144011f5c4a577 /lib | |
| parent | 78aea6ff0e955611046c1fb2753712ada736b2e7 (diff) | |
| download | perl-087f1bf3a29bd837d3103a3637ea69e4499ca06b.tar.gz | |
Move CPAN from lib/ to ext/
Diffstat (limited to 'lib')
44 files changed, 43 insertions, 19229 deletions
diff --git a/lib/.gitignore b/lib/.gitignore index 32377b66eb..85422de1e3 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -15,6 +15,49 @@ /Config_git.pl /CGI /CGI.pm +/CPAN.pm +/CPAN +/CPAN/API +/CPAN/API/HOWTO.pod +/CPAN/Author.pm +/CPAN/Bundle.pm +/CPAN/CacheMgr.pm +/CPAN/Complete.pm +/CPAN/Debug.pm +/CPAN/DeferredCode.pm +/CPAN/Distribution.pm +/CPAN/Distroprefs.pm +/CPAN/Distrostatus.pm +/CPAN/Exception +/CPAN/Exception/RecursiveDependency.pm +/CPAN/Exception/blocked_urllist.pm +/CPAN/Exception/yaml_not_installed.pm +/CPAN/FTP.pm +/CPAN/FTP +/CPAN/FTP/netrc.pm +/CPAN/FirstTime.pm +/CPAN/HandleConfig.pm +/CPAN/Index.pm +/CPAN/InfoObj.pm +/CPAN/Kwalify.pm +/CPAN/Kwalify +/CPAN/Kwalify/distroprefs.dd +/CPAN/Kwalify/distroprefs.yml +/CPAN/LWP +/CPAN/LWP/UserAgent.pm +/CPAN/Module.pm +/CPAN/Nox.pm +/CPAN/PAUSE2003.pub +/CPAN/PAUSE2005.pub +/CPAN/PAUSE2007.pub +/CPAN/PAUSE2009.pub +/CPAN/Prompt.pm +/CPAN/Queue.pm +/CPAN/SIGNATURE +/CPAN/Shell.pm +/CPAN/Tarzip.pm +/CPAN/URL.pm +/CPAN/Version.pm /CPANPLUS.pm /CPANPLUS/Backend.pm /CPANPLUS/Backend diff --git a/lib/CPAN.pm b/lib/CPAN.pm deleted file mode 100644 index 1196cb0fcf..0000000000 --- a/lib/CPAN.pm +++ /dev/null @@ -1,3717 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -use strict; -package CPAN; -$CPAN::VERSION = '1.9402'; -$CPAN::VERSION =~ s/_//; - -# we need to run chdir all over and we would get at wrong libraries -# there -use File::Spec (); -BEGIN { - if (File::Spec->can("rel2abs")) { - for my $inc (@INC) { - $inc = File::Spec->rel2abs($inc) unless ref $inc; - } - } -} -use CPAN::Author; -use CPAN::HandleConfig; -use CPAN::Version; -use CPAN::Bundle; -use CPAN::CacheMgr; -use CPAN::Complete; -use CPAN::Debug; -use CPAN::Distribution; -use CPAN::Distrostatus; -use CPAN::FTP; -use CPAN::Index 1.93; # https://rt.cpan.org/Ticket/Display.html?id=43349 -use CPAN::InfoObj; -use CPAN::Module; -use CPAN::Prompt; -use CPAN::URL; -use CPAN::Queue; -use CPAN::Tarzip; -use CPAN::DeferredCode; -use CPAN::Shell; -use CPAN::LWP::UserAgent; -use CPAN::Exception::RecursiveDependency; -use CPAN::Exception::yaml_not_installed; - -use Carp (); -use Config (); -use Cwd qw(chdir); -use DirHandle (); -use Exporter (); -use ExtUtils::MakeMaker qw(prompt); # for some unknown reason, - # 5.005_04 does not work without - # this -use File::Basename (); -use File::Copy (); -use File::Find; -use File::Path (); -use FileHandle (); -use Fcntl qw(:flock); -use Safe (); -use Sys::Hostname qw(hostname); -use Text::ParseWords (); -use Text::Wrap (); - -# protect against "called too early" -sub find_perl (); -sub anycwd (); -sub _uniq; - -no lib "."; - -require Mac::BuildTools if $^O eq 'MacOS'; -if ($ENV{PERL5_CPAN_IS_RUNNING} && $$ != $ENV{PERL5_CPAN_IS_RUNNING}) { - $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} ||= $ENV{PERL5_CPAN_IS_RUNNING}; - my @rec = _uniq split(/,/, $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION}), $$; - $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} = join ",", @rec; - # warn "# Note: Recursive call of CPAN.pm detected\n"; - my $w = sprintf "# Note: CPAN.pm is running in process %d now", pop @rec; - my %sleep = ( - 5 => 30, - 6 => 60, - 7 => 120, - ); - my $sleep = @rec > 7 ? 300 : ($sleep{scalar @rec}||0); - my $verbose = @rec >= 4; - while (@rec) { - $w .= sprintf " which has been called by process %d", pop @rec; - } - if ($sleep) { - $w .= ".\n\n# Sleeping $sleep seconds to protect other processes\n"; - } - if ($verbose) { - warn $w; - } - local $| = 1; - while ($sleep > 0) { - printf "\r#%5d", --$sleep; - sleep 1; - } - print "\n"; -} -$ENV{PERL5_CPAN_IS_RUNNING}=$$; -$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735 - -END { $CPAN::End++; &cleanup; } - -$CPAN::Signal ||= 0; -$CPAN::Frontend ||= "CPAN::Shell"; -unless (@CPAN::Defaultsites) { - @CPAN::Defaultsites = map { - CPAN::URL->new(TEXT => $_, FROM => "DEF") - } - "http://www.perl.org/CPAN/", - "ftp://ftp.perl.org/pub/CPAN/"; -} -# $CPAN::iCwd (i for initial) -$CPAN::iCwd ||= CPAN::anycwd(); -$CPAN::Perl ||= CPAN::find_perl(); -$CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?"; -$CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf"; -$CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml"; - -# our globals are getting a mess -use vars qw( - $AUTOLOAD - $Be_Silent - $CONFIG_DIRTY - $Defaultdocs - $Echo_readline - $Frontend - $GOTOSHELL - $HAS_USABLE - $Have_warned - $MAX_RECURSION - $META - $RUN_DEGRADED - $Signal - $SQLite - $Suppress_readline - $VERSION - $autoload_recursion - $term - @Defaultsites - @EXPORT - ); - -$MAX_RECURSION = 32; - -@CPAN::ISA = qw(CPAN::Debug Exporter); - -# note that these functions live in CPAN::Shell and get executed via -# AUTOLOAD when called directly -@EXPORT = qw( - autobundle - bundle - clean - cvs_import - expand - force - fforce - get - install - install_tested - is_tested - make - mkmyconfig - notest - perldoc - readme - recent - recompile - report - shell - smoke - test - upgrade - ); - -sub soft_chdir_with_alternatives ($); - -{ - $autoload_recursion ||= 0; - - #-> sub CPAN::AUTOLOAD ; - sub AUTOLOAD { ## no critic - $autoload_recursion++; - my($l) = $AUTOLOAD; - $l =~ s/.*:://; - if ($CPAN::Signal) { - warn "Refusing to autoload '$l' while signal pending"; - $autoload_recursion--; - return; - } - if ($autoload_recursion > 1) { - my $fullcommand = join " ", map { "'$_'" } $l, @_; - warn "Refusing to autoload $fullcommand in recursion\n"; - $autoload_recursion--; - return; - } - my(%export); - @export{@EXPORT} = ''; - CPAN::HandleConfig->load unless $CPAN::Config_loaded++; - if (exists $export{$l}) { - CPAN::Shell->$l(@_); - } else { - die(qq{Unknown CPAN command "$AUTOLOAD". }. - qq{Type ? for help.\n}); - } - $autoload_recursion--; - } -} - -{ - my $x = *SAVEOUT; # avoid warning - open($x,">&STDOUT") or die "dup failed"; - my $redir = 0; - sub _redirect(@) { - #die if $redir; - local $_; - push(@_,undef); - while(defined($_=shift)) { - if (s/^\s*>//){ - my ($m) = s/^>// ? ">" : ""; - s/\s+//; - $_=shift unless length; - die "no dest" unless defined; - open(STDOUT,">$m$_") or die "open:$_:$!\n"; - $redir=1; - } elsif ( s/^\s*\|\s*// ) { - my $pipe="| $_"; - while(defined($_[0])){ - $pipe .= ' ' . shift; - } - open(STDOUT,$pipe) or die "open:$pipe:$!\n"; - $redir=1; - } else { - push(@_,$_); - } - } - return @_; - } - sub _unredirect { - return unless $redir; - $redir = 0; - ## redirect: unredirect and propagate errors. explicit close to wait for pipe. - close(STDOUT); - open(STDOUT,">&SAVEOUT"); - die "$@" if "$@"; - ## redirect: done - } -} - -sub _uniq { - my(@list) = @_; - my %seen; - return grep { !$seen{$_}++ } @list; -} - -#-> sub CPAN::shell ; -sub shell { - my($self) = @_; - $Suppress_readline = ! -t STDIN unless defined $Suppress_readline; - CPAN::HandleConfig->load unless $CPAN::Config_loaded++; - - my $oprompt = shift || CPAN::Prompt->new; - my $prompt = $oprompt; - my $commandline = shift || ""; - $CPAN::CurrentCommandId ||= 1; - - local($^W) = 1; - unless ($Suppress_readline) { - require Term::ReadLine; - if (! $term - or - $term->ReadLine eq "Term::ReadLine::Stub" - ) { - $term = Term::ReadLine->new('CPAN Monitor'); - } - if ($term->ReadLine eq "Term::ReadLine::Gnu") { - my $attribs = $term->Attribs; - $attribs->{attempted_completion_function} = sub { - &CPAN::Complete::gnu_cpl; - } - } else { - $readline::rl_completion_function = - $readline::rl_completion_function = 'CPAN::Complete::cpl'; - } - if (my $histfile = $CPAN::Config->{'histfile'}) {{ - unless ($term->can("AddHistory")) { - $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n"); - last; - } - $META->readhist($term,$histfile); - }} - for ($CPAN::Config->{term_ornaments}) { # alias - local $Term::ReadLine::termcap_nowarn = 1; - $term->ornaments($_) if defined; - } - # $term->OUT is autoflushed anyway - my $odef = select STDERR; - $| = 1; - select STDOUT; - $| = 1; - select $odef; - } - - $META->checklock(); - my @cwd = grep { defined $_ and length $_ } - CPAN::anycwd(), - File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (), - File::Spec->rootdir(); - my $try_detect_readline; - $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term; - unless ($CPAN::Config->{inhibit_startup_message}) { - my $rl_avail = $Suppress_readline ? "suppressed" : - ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : - "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)"; - $CPAN::Frontend->myprint( - sprintf qq{ -cpan shell -- CPAN exploration and modules installation (v%s) -Enter 'h' for help. - -}, - $CPAN::VERSION, - $rl_avail - ) - } - my($continuation) = ""; - my $last_term_ornaments; - SHELLCOMMAND: while () { - if ($Suppress_readline) { - if ($Echo_readline) { - $|=1; - } - print $prompt; - last SHELLCOMMAND unless defined ($_ = <> ); - if ($Echo_readline) { - # backdoor: I could not find a way to record sessions - print $_; - } - chomp; - } else { - last SHELLCOMMAND unless - defined ($_ = $term->readline($prompt, $commandline)); - } - $_ = "$continuation$_" if $continuation; - s/^\s+//; - next SHELLCOMMAND if /^$/; - s/^\s*\?\s*/help /; - if (/^(?:q(?:uit)?|bye|exit)$/i) { - last SHELLCOMMAND; - } elsif (s/\\$//s) { - chomp; - $continuation = $_; - $prompt = " > "; - } elsif (/^\!/) { - s/^\!//; - my($eval) = $_; - package - CPAN::Eval; # hide from the indexer - use strict; - use vars qw($import_done); - CPAN->import(':DEFAULT') unless $import_done++; - CPAN->debug("eval[$eval]") if $CPAN::DEBUG; - eval($eval); - warn $@ if $@; - $continuation = ""; - $prompt = $oprompt; - } elsif (/./) { - my(@line); - eval { @line = Text::ParseWords::shellwords($_) }; - warn($@), next SHELLCOMMAND if $@; - warn("Text::Parsewords could not parse the line [$_]"), - next SHELLCOMMAND unless @line; - $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; - my $command = shift @line; - eval { - local (*STDOUT)=*STDOUT; - @line = _redirect(@line); - CPAN::Shell->$command(@line) - }; - my $command_error = $@; - _unredirect; - my $reported_error; - if ($command_error) { - my $err = $command_error; - if (ref $err and $err->isa('CPAN::Exception::blocked_urllist')) { - $CPAN::Frontend->mywarn("Client not fully configured, please proceed with configuring.$err"); - $reported_error = ref $err; - } else { - # I'd prefer never to arrive here and make all errors exception objects - if ($err =~ /\S/) { - require Carp; - require Dumpvalue; - my $dv = Dumpvalue->new(tick => '"'); - Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err)); - } - } - } - if ($command =~ /^( - # classic commands - make - |test - |install - |clean - - # pragmas for classic commands - |ff?orce - |notest - - # compounds - |report - |smoke - |upgrade - )$/x) { - # only commands that tell us something about failed distros - # eval necessary for people without an urllist - eval {CPAN::Shell->failed($CPAN::CurrentCommandId,1);}; - if (my $err = $@) { - unless (ref $err and $reported_error eq ref $err) { - die $@; - } - } - } - soft_chdir_with_alternatives(\@cwd); - $CPAN::Frontend->myprint("\n"); - $continuation = ""; - $CPAN::CurrentCommandId++; - $prompt = $oprompt; - } - } continue { - $commandline = ""; # I do want to be able to pass a default to - # shell, but on the second command I see no - # use in that - $Signal=0; - CPAN::Queue->nullify_queue; - if ($try_detect_readline) { - if ($CPAN::META->has_inst("Term::ReadLine::Gnu") - || - $CPAN::META->has_inst("Term::ReadLine::Perl") - ) { - delete $INC{"Term/ReadLine.pm"}; - my $redef = 0; - local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef); - require Term::ReadLine; - $CPAN::Frontend->myprint("\n$redef subroutines in ". - "Term::ReadLine redefined\n"); - $GOTOSHELL = 1; - } - } - if ($term and $term->can("ornaments")) { - for ($CPAN::Config->{term_ornaments}) { # alias - if (defined $_) { - if (not defined $last_term_ornaments - or $_ != $last_term_ornaments - ) { - local $Term::ReadLine::termcap_nowarn = 1; - $term->ornaments($_); - $last_term_ornaments = $_; - } - } else { - undef $last_term_ornaments; - } - } - } - for my $class (qw(Module Distribution)) { - # again unsafe meta access? - for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) { - next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor}; - CPAN->debug("BUG: $class '$dm' was in command state, resetting"); - delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor}; - } - } - if ($GOTOSHELL) { - $GOTOSHELL = 0; # not too often - $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory"); - @_ = ($oprompt,""); - goto &shell; - } - } - soft_chdir_with_alternatives(\@cwd); -} - -#-> CPAN::soft_chdir_with_alternatives ; -sub soft_chdir_with_alternatives ($) { - my($cwd) = @_; - unless (@$cwd) { - my $root = File::Spec->rootdir(); - $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to! -Trying '$root' as temporary haven. -}); - push @$cwd, $root; - } - while () { - if (chdir $cwd->[0]) { - return; - } else { - if (@$cwd>1) { - $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $! -Trying to chdir to "$cwd->[1]" instead. -}); - shift @$cwd; - } else { - $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!}); - } - } - } -} - -sub _flock { - my($fh,$mode) = @_; - if ( $Config::Config{d_flock} || $Config::Config{d_fcntl_can_lock} ) { - return flock $fh, $mode; - } elsif (!$Have_warned->{"d_flock"}++) { - $CPAN::Frontend->mywarn("Your OS does not seem to support locking; continuing and ignoring all locking issues\n"); - $CPAN::Frontend->mysleep(5); - return 1; - } else { - return 1; - } -} - -sub _yaml_module () { - my $yaml_module = $CPAN::Config->{yaml_module} || "YAML"; - if ( - $yaml_module ne "YAML" - && - !$CPAN::META->has_inst($yaml_module) - ) { - # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n"); - $yaml_module = "YAML"; - } - if ($yaml_module eq "YAML" - && - $CPAN::META->has_inst($yaml_module) - && - $YAML::VERSION < 0.60 - && - !$Have_warned->{"YAML"}++ - ) { - $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n". - "I'll continue but problems are *very* likely to happen.\n" - ); - $CPAN::Frontend->mysleep(5); - } - return $yaml_module; -} - -# CPAN::_yaml_loadfile -sub _yaml_loadfile { - my($self,$local_file) = @_; - return +[] unless -s $local_file; - my $yaml_module = _yaml_module; - if ($CPAN::META->has_inst($yaml_module)) { - # temporarly enable yaml code deserialisation - no strict 'refs'; - # 5.6.2 could not do the local() with the reference - # so we do it manually instead - my $old_loadcode = ${"$yaml_module\::LoadCode"}; - ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0; - - my ($code, @yaml); - if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) { - eval { @yaml = $code->($local_file); }; - if ($@) { - # this shall not be done by the frontend - die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@); - } - } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) { - local *FH; - open FH, $local_file or die "Could not open '$local_file': $!"; - local $/; - my $ystream = <FH>; - eval { @yaml = $code->($ystream); }; - if ($@) { - # this shall not be done by the frontend - die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@); - } - } - ${"$yaml_module\::LoadCode"} = $old_loadcode; - return \@yaml; - } else { - # this shall not be done by the frontend - die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse"); - } - return +[]; -} - -# CPAN::_yaml_dumpfile -sub _yaml_dumpfile { - my($self,$local_file,@what) = @_; - my $yaml_module = _yaml_module; - if ($CPAN::META->has_inst($yaml_module)) { - my $code; - if (UNIVERSAL::isa($local_file, "FileHandle")) { - $code = UNIVERSAL::can($yaml_module, "Dump"); - eval { print $local_file $code->(@what) }; - } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) { - eval { $code->($local_file,@what); }; - } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) { - local *FH; - open FH, ">$local_file" or die "Could not open '$local_file': $!"; - print FH $code->(@what); - } - if ($@) { - die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@); - } - } else { - if (UNIVERSAL::isa($local_file, "FileHandle")) { - # I think this case does not justify a warning at all - } else { - die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump"); - } - } -} - -sub _init_sqlite () { - unless ($CPAN::META->has_inst("CPAN::SQLite")) { - $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n}) - unless $Have_warned->{"CPAN::SQLite"}++; - return; - } - require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17 - $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META); -} - -{ - my $negative_cache = {}; - sub _sqlite_running { - if ($negative_cache->{time} && time < $negative_cache->{time} + 60) { - # need to cache the result, otherwise too slow - return $negative_cache->{fact}; - } else { - $negative_cache = {}; # reset - } - my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite()); - return $ret if $ret; # fast anyway - $negative_cache->{time} = time; - return $negative_cache->{fact} = $ret; - } -} - -$META ||= CPAN->new; # In case we re-eval ourselves we need the || - -# from here on only subs. -################################################################################ - -sub _perl_fingerprint { - my($self,$other_fingerprint) = @_; - my $dll = eval {OS2::DLLname()}; - my $mtime_dll = 0; - if (defined $dll) { - $mtime_dll = (-f $dll ? (stat(_))[9] : '-1'); - } - my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1'); - my $this_fingerprint = { - '$^X' => CPAN::find_perl, - sitearchexp => $Config::Config{sitearchexp}, - 'mtime_$^X' => $mtime_perl, - 'mtime_dll' => $mtime_dll, - }; - if ($other_fingerprint) { - if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57 - $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9]; - } - # mandatory keys since 1.88_57 - for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) { - return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key}; - } - return 1; - } else { - return $this_fingerprint; - } -} - -sub suggest_myconfig () { - SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) { - $CPAN::Frontend->myprint("You don't seem to have a user ". - "configuration (MyConfig.pm) yet.\n"); - my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ". - "user configuration now? (Y/n)", - "yes"); - if($new =~ m{^y}i) { - CPAN::Shell->mkmyconfig(); - return &checklock; - } else { - $CPAN::Frontend->mydie("OK, giving up."); - } - } -} - -#-> sub CPAN::all_objects ; -sub all_objects { - my($mgr,$class) = @_; - CPAN::HandleConfig->load unless $CPAN::Config_loaded++; - CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG; - CPAN::Index->reload; - values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok -} - -# Called by shell, not in batch mode. In batch mode I see no risk in -# having many processes updating something as installations are -# continually checked at runtime. In shell mode I suspect it is -# unintentional to open more than one shell at a time - -#-> sub CPAN::checklock ; -sub checklock { - my($self) = @_; - my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock"); - if (-f $lockfile && -M _ > 0) { - my $fh = FileHandle->new($lockfile) or - $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!"); - my $otherpid = <$fh>; - my $otherhost = <$fh>; - $fh->close; - if (defined $otherpid && $otherpid) { - chomp $otherpid; - } - if (defined $otherhost && $otherhost) { - chomp $otherhost; - } - my $thishost = hostname(); - if (defined $otherhost && defined $thishost && - $otherhost ne '' && $thishost ne '' && - $otherhost ne $thishost) { - $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n". - "reports other host $otherhost and other ". - "process $otherpid.\n". - "Cannot proceed.\n")); - } elsif ($RUN_DEGRADED) { - $CPAN::Frontend->mywarn("Running in downgraded mode (experimental)\n"); - } elsif (defined $otherpid && $otherpid) { - return if $$ == $otherpid; # should never happen - $CPAN::Frontend->mywarn( - qq{ -There seems to be running another CPAN process (pid $otherpid). Contacting... -}); - if (kill 0, $otherpid or $!{EPERM}) { - $CPAN::Frontend->mywarn(qq{Other job is running.\n}); - my($ans) = - CPAN::Shell::colorable_makemaker_prompt - (qq{Shall I try to run in downgraded }. - qq{mode? (Y/n)},"y"); - if ($ans =~ /^y/i) { - $CPAN::Frontend->mywarn("Running in downgraded mode (experimental). -Please report if something unexpected happens\n"); - $RUN_DEGRADED = 1; - for ($CPAN::Config) { - # XXX - # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that? - $_->{commandnumber_in_prompt} = 0; # visibility - $_->{histfile} = ""; # who should win otherwise? - $_->{cache_metadata} = 0; # better would be a lock? - $_->{use_sqlite} = 0; # better would be a write lock! - $_->{auto_commit} = 0; # we are violent, do not persist - $_->{test_report} = 0; # Oliver Paukstadt had sent wrong reports in degraded mode - } - } else { - $CPAN::Frontend->mydie(" -You may want to kill the other job and delete the lockfile. On UNIX try: - kill $otherpid - rm $lockfile -"); - } - } elsif (-w $lockfile) { - my($ans) = - CPAN::Shell::colorable_makemaker_prompt - (qq{Other job not responding. Shall I overwrite }. - qq{the lockfile '$lockfile'? (Y/n)},"y"); - $CPAN::Frontend->myexit("Ok, bye\n") - unless $ans =~ /^y/i; - } else { - Carp::croak( - qq{Lockfile '$lockfile' not writable by you. }. - qq{Cannot proceed.\n}. - qq{ On UNIX try:\n}. - qq{ rm '$lockfile'\n}. - qq{ and then rerun us.\n} - ); - } - } else { - $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ". - "'$lockfile', please remove. Cannot proceed.\n")); - } - } - my $dotcpan = $CPAN::Config->{cpan_home}; - eval { File::Path::mkpath($dotcpan);}; - if ($@) { - # A special case at least for Jarkko. - my $firsterror = $@; - my $seconderror; - my $symlinkcpan; - if (-l $dotcpan) { - $symlinkcpan = readlink $dotcpan; - die "readlink $dotcpan failed: $!" unless defined $symlinkcpan; - eval { File::Path::mkpath($symlinkcpan); }; - if ($@) { - $seconderror = $@; - } else { - $CPAN::Frontend->mywarn(qq{ -Working directory $symlinkcpan created. -}); - } - } - unless (-d $dotcpan) { - my $mess = qq{ -Your configuration suggests "$dotcpan" as your -CPAN.pm working directory. I could not create this directory due -to this error: $firsterror\n}; - $mess .= qq{ -As "$dotcpan" is a symlink to "$symlinkcpan", -I tried to create that, but I failed with this error: $seconderror -} if $seconderror; - $mess .= qq{ -Please make sure the directory exists and is writable. -}; - $CPAN::Frontend->mywarn($mess); - return suggest_myconfig; - } - } # $@ after eval mkpath $dotcpan - if (0) { # to test what happens when a race condition occurs - for (reverse 1..10) { - print $_, "\n"; - sleep 1; - } - } - # locking - if (!$RUN_DEGRADED && !$self->{LOCKFH}) { - my $fh; - unless ($fh = FileHandle->new("+>>$lockfile")) { - if ($! =~ /Permission/) { - $CPAN::Frontend->mywarn(qq{ - -Your configuration suggests that CPAN.pm should use a working -directory of - $CPAN::Config->{cpan_home} -Unfortunately we could not create the lock file - $lockfile -due to permission problems. - -Please make sure that the configuration variable - \$CPAN::Config->{cpan_home} -points to a directory where you can write a .lock file. You can set -this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your -\@INC path; -}); - return suggest_myconfig; - } - } - my $sleep = 1; - while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) { - if ($sleep>10) { - $CPAN::Frontend->mydie("Giving up\n"); - } - $CPAN::Frontend->mysleep($sleep++); - $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n"); - } - - seek $fh, 0, 0; - truncate $fh, 0; - $fh->autoflush(1); - $fh->print($$, "\n"); - $fh->print(hostname(), "\n"); - $self->{LOCK} = $lockfile; - $self->{LOCKFH} = $fh; - } - $SIG{TERM} = sub { - my $sig = shift; - &cleanup; - $CPAN::Frontend->mydie("Got SIG$sig, leaving"); - }; - $SIG{INT} = sub { - # no blocks!!! - my $sig = shift; - &cleanup if $Signal; - die "Got yet another signal" if $Signal > 1; - $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal; - $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n"); - $Signal++; - }; - -# From: Larry Wall <larry@wall.org> -# Subject: Re: deprecating SIGDIE -# To: perl5-porters@perl.org -# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT) -# -# The original intent of __DIE__ was only to allow you to substitute one -# kind of death for another on an application-wide basis without respect -# to whether you were in an eval or not. As a global backstop, it should -# not be used any more lightly (or any more heavily :-) than class -# UNIVERSAL. Any attempt to build a general exception model on it should -# be politely squashed. Any bug that causes every eval {} to have to be -# modified should be not so politely squashed. -# -# Those are my current opinions. It is also my optinion that polite -# arguments degenerate to personal arguments far too frequently, and that -# when they do, it's because both people wanted it to, or at least didn't -# sufficiently want it not to. -# -# Larry - - # global backstop to cleanup if we should really die - $SIG{__DIE__} = \&cleanup; - $self->debug("Signal handler set.") if $CPAN::DEBUG; -} - -#-> sub CPAN::DESTROY ; -sub DESTROY { - &cleanup; # need an eval? -} - -#-> sub CPAN::anycwd ; -sub anycwd () { - my $getcwd; - $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; - CPAN->$getcwd(); -} - -#-> sub CPAN::cwd ; -sub cwd {Cwd::cwd();} - -#-> sub CPAN::getcwd ; -sub getcwd {Cwd::getcwd();} - -#-> sub CPAN::fastcwd ; -sub fastcwd {Cwd::fastcwd();} - -#-> sub CPAN::backtickcwd ; -sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd} - -#-> sub CPAN::find_perl ; -sub find_perl () { - my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : ""; - unless ($perl) { - my $candidate = File::Spec->catfile($CPAN::iCwd,$^X); - $^X = $perl = $candidate if MM->maybe_command($candidate); - } - unless ($perl) { - my ($component,$perl_name); - DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") { - PATH_COMPONENT: foreach $component (File::Spec->path(), - $Config::Config{'binexp'}) { - next unless defined($component) && $component; - my($abs) = File::Spec->catfile($component,$perl_name); - if (MM->maybe_command($abs)) { - $^X = $perl = $abs; - last DIST_PERLNAME; - } - } - } - } - return $perl; -} - - -#-> sub CPAN::exists ; -sub exists { - my($mgr,$class,$id) = @_; - CPAN::HandleConfig->load unless $CPAN::Config_loaded++; - CPAN::Index->reload; - ### Carp::croak "exists called without class argument" unless $class; - $id ||= ""; - $id =~ s/:+/::/g if $class eq "CPAN::Module"; - my $exists; - if (CPAN::_sqlite_running) { - $exists = (exists $META->{readonly}{$class}{$id} or - $CPAN::SQLite->set($class, $id)); - } else { - $exists = exists $META->{readonly}{$class}{$id}; - } - $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok -} - -#-> sub CPAN::delete ; -sub delete { - my($mgr,$class,$id) = @_; - delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok - delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok -} - -#-> sub CPAN::has_usable -# has_inst is sometimes too optimistic, we should replace it with this -# has_usable whenever a case is given -sub has_usable { - my($self,$mod,$message) = @_; - return 1 if $HAS_USABLE->{$mod}; - my $has_inst = $self->has_inst($mod,$message); - return unless $has_inst; - my $usable; - $usable = { - LWP => [ # we frequently had "Can't locate object - # method "new" via package "LWP::UserAgent" at - # (eval 69) line 2006 - sub {require LWP}, - sub {require LWP::UserAgent}, - sub {require HTTP::Request}, - sub {require URI::URL}, - ], - 'Net::FTP' => [ - sub {require Net::FTP}, - sub {require Net::Config}, - ], - 'File::HomeDir' => [ - sub {require File::HomeDir; - unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) { - for ("Will not use File::HomeDir, need 0.52\n") { - $CPAN::Frontend->mywarn($_); - die $_; - } - } - }, - ], - 'Archive::Tar' => [ - sub {require Archive::Tar; - unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.50)) { - for ("Will not use Archive::Tar, need 1.00\n") { - $CPAN::Frontend->mywarn($_); - die $_; - } - } - unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.50)) { - my $atv = Archive::Tar->VERSION; - $CPAN::Frontend->mywarn("You have Archive::Tar $atv, but 1.50 or later is recommended. Please upgrade.\n"); - } - }, - ], - 'File::Temp' => [ - # XXX we should probably delete from - # %INC too so we can load after we - # installed a new enough version -- - # I'm not sure. - sub {require File::Temp; - unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) { - for ("Will not use File::Temp, need 0.16\n") { - $CPAN::Frontend->mywarn($_); - die $_; - } - } - }, - ] - }; - if ($usable->{$mod}) { - for my $c (0..$#{$usable->{$mod}}) { - my $code = $usable->{$mod}[$c]; - my $ret = eval { &$code() }; - $ret = "" unless defined $ret; - if ($@) { - # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]"; - return; - } - } - } - return $HAS_USABLE->{$mod} = 1; -} - -#-> sub CPAN::has_inst -sub has_inst { - my($self,$mod,$message) = @_; - Carp::croak("CPAN->has_inst() called without an argument") - unless defined $mod; - my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}}, - keys %{$CPAN::Config->{dontload_hash}||{}}, - @{$CPAN::Config->{dontload_list}||[]}; - if (defined $message && $message eq "no" # afair only used by Nox - || - $dont{$mod} - ) { - $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok - return 0; - } - my $file = $mod; - my $obj; - $file =~ s|::|/|g; - $file .= ".pm"; - if ($INC{$file}) { - # checking %INC is wrong, because $INC{LWP} may be true - # although $INC{"URI/URL.pm"} may have failed. But as - # I really want to say "bla loaded OK", I have to somehow - # cache results. - ### warn "$file in %INC"; #debug - return 1; - } elsif (eval { require $file }) { - # eval is good: if we haven't yet read the database it's - # perfect and if we have installed the module in the meantime, - # it tries again. The second require is only a NOOP returning - # 1 if we had success, otherwise it's retrying - - my $mtime = (stat $INC{$file})[9]; - # privileged files loaded by has_inst; Note: we use $mtime - # as a proxy for a checksum. - $CPAN::Shell::reload->{$file} = $mtime; - my $v = eval "\$$mod\::VERSION"; - $v = $v ? " (v$v)" : ""; - CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n"); - if ($mod eq "CPAN::WAIT") { - push @CPAN::Shell::ISA, 'CPAN::WAIT'; - } - return 1; - } elsif ($mod eq "Net::FTP") { - $CPAN::Frontend->mywarn(qq{ - Please, install Net::FTP as soon as possible. CPAN.pm installs it for you - if you just type - install Bundle::libnet - -}) unless $Have_warned->{"Net::FTP"}++; - $CPAN::Frontend->mysleep(3); - } elsif ($mod eq "Digest::SHA") { - if ($Have_warned->{"Digest::SHA"}++) { - $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }. - qq{because Digest::SHA not installed.\n}); - } else { - $CPAN::Frontend->mywarn(qq{ - CPAN: checksum security checks disabled because Digest::SHA not installed. - Please consider installing the Digest::SHA module. - -}); - $CPAN::Frontend->mysleep(2); - } - } elsif ($mod eq "Module::Signature") { - # NOT prefs_lookup, we are not a distro - my $check_sigs = $CPAN::Config->{check_sigs}; - if (not $check_sigs) { - # they do not want us:-( - } elsif (not $Have_warned->{"Module::Signature"}++) { - # No point in complaining unless the user can - # reasonably install and use it. - if (eval { require Crypt::OpenPGP; 1 } || - ( - defined $CPAN::Config->{'gpg'} - && - $CPAN::Config->{'gpg'} =~ /\S/ - ) - ) { - $CPAN::Frontend->mywarn(qq{ - CPAN: Module::Signature security checks disabled because Module::Signature - not installed. Please consider installing the Module::Signature module. - You may also need to be able to connect over the Internet to the public - keyservers like pgp.mit.edu (port 11371). - -}); - $CPAN::Frontend->mysleep(2); - } - } - } else { - delete $INC{$file}; # if it inc'd LWP but failed during, say, URI - } - return 0; -} - -#-> sub CPAN::instance ; -sub instance { - my($mgr,$class,$id) = @_; - CPAN::Index->reload; - $id ||= ""; - # unsafe meta access, ok? - return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id}; - $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id); -} - -#-> sub CPAN::new ; -sub new { - bless {}, shift; -} - -#-> sub CPAN::cleanup ; -sub cleanup { - # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]"; - local $SIG{__DIE__} = ''; - my($message) = @_; - my $i = 0; - my $ineval = 0; - my($subroutine); - while ((undef,undef,undef,$subroutine) = caller(++$i)) { - $ineval = 1, last if - $subroutine eq '(eval)'; - } - return if $ineval && !$CPAN::End; - return unless defined $META->{LOCK}; - return unless -f $META->{LOCK}; - $META->savehist; - close $META->{LOCKFH}; - unlink $META->{LOCK}; - # require Carp; - # Carp::cluck("DEBUGGING"); - if ( $CPAN::CONFIG_DIRTY ) { - $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n"); - } - $CPAN::Frontend->myprint("Lockfile removed.\n"); -} - -#-> sub CPAN::readhist -sub readhist { - my($self,$term,$histfile) = @_; - my $histsize = $CPAN::Config->{'histsize'} || 100; - $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'})); - my($fh) = FileHandle->new; - open $fh, "<$histfile" or return; - local $/ = "\n"; - while (<$fh>) { - chomp; - $term->AddHistory($_); - } - close $fh; -} - -#-> sub CPAN::savehist -sub savehist { - my($self) = @_; - my($histfile,$histsize); - unless ($histfile = $CPAN::Config->{'histfile'}) { - $CPAN::Frontend->mywarn("No history written (no histfile specified).\n"); - return; - } - $histsize = $CPAN::Config->{'histsize'} || 100; - if ($CPAN::term) { - unless ($CPAN::term->can("GetHistory")) { - $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n"); - return; - } - } else { - return; - } - my @h = $CPAN::term->GetHistory; - splice @h, 0, @h-$histsize if @h>$histsize; - my($fh) = FileHandle->new; - open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!"); - local $\ = local $, = "\n"; - print $fh @h; - close $fh; -} - -#-> sub CPAN::is_tested -sub is_tested { - my($self,$what,$when) = @_; - unless ($what) { - Carp::cluck("DEBUG: empty what"); - return; - } - $self->{is_tested}{$what} = $when; -} - -#-> sub CPAN::reset_tested -# forget all distributions tested -- resets what gets included in PERL5LIB -sub reset_tested { - my ($self) = @_; - $self->{is_tested} = {}; -} - -#-> sub CPAN::is_installed -# unsets the is_tested flag: as soon as the thing is installed, it is -# not needed in set_perl5lib anymore -sub is_installed { - my($self,$what) = @_; - delete $self->{is_tested}{$what}; -} - -sub _list_sorted_descending_is_tested { - my($self) = @_; - sort - { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) } - keys %{$self->{is_tested}} -} - -#-> sub CPAN::set_perl5lib -# Notes on max environment variable length: -# - Win32 : XP or later, 8191; Win2000 or NT4, 2047 -{ -my $fh; -sub set_perl5lib { - my($self,$for) = @_; - unless ($for) { - (undef,undef,undef,$for) = caller(1); - $for =~ s/.*://; - } - $self->{is_tested} ||= {}; - return unless %{$self->{is_tested}}; - my $env = $ENV{PERL5LIB}; - $env = $ENV{PERLLIB} unless defined $env; - my @env; - push @env, split /\Q$Config::Config{path_sep}\E/, $env if defined $env and length $env; - #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}}; - #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n"); - - my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested; - return if !@dirs; - - if (@dirs < 12) { - $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n"); - $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; - } elsif (@dirs < 24 ) { - my @d = map {my $cp = $_; - $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/; - $cp - } @dirs; - $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ". - "%BUILDDIR%=$CPAN::Config->{build_dir} ". - "for '$for'\n" - ); - $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; - } else { - my $cnt = keys %{$self->{is_tested}}; - $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ". - "$cnt build dirs to PERL5LIB; ". - "for '$for'\n" - ); - $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; - } -}} - - -1; - - -__END__ - -=head1 NAME - -CPAN - query, download and build perl modules from CPAN sites - -=head1 SYNOPSIS - -Interactive mode: - - perl -MCPAN -e shell - ---or-- - - cpan - -Basic commands: - - # Modules: - - cpan> install Acme::Meta # in the shell - - CPAN::Shell->install("Acme::Meta"); # in perl - - # Distributions: - - cpan> install NWCLARK/Acme-Meta-0.02.tar.gz # in the shell - - CPAN::Shell-> - install("NWCLARK/Acme-Meta-0.02.tar.gz"); # in perl - - # module objects: - - $mo = CPAN::Shell->expandany($mod); - $mo = CPAN::Shell->expand("Module",$mod); # same thing - - # distribution objects: - - $do = CPAN::Shell->expand("Module",$mod)->distribution; - $do = CPAN::Shell->expandany($distro); # same thing - $do = CPAN::Shell->expand("Distribution", - $distro); # same thing - -=head1 DESCRIPTION - -The CPAN module automates or at least simplifies the make and install -of perl modules and extensions. It includes some primitive searching -capabilities and knows how to use Net::FTP, LWP, and certain external -download clients to fetch distributions from the net. - -These are fetched from one or more mirrored CPAN (Comprehensive -Perl Archive Network) sites and unpacked in a dedicated directory. - -The CPAN module also supports named and versioned -I<bundles> of modules. Bundles simplify handling of sets of -related modules. See Bundles below. - -The package contains a session manager and a cache manager. The -session manager keeps track of what has been fetched, built, and -installed in the current session. The cache manager keeps track of the -disk space occupied by the make processes and deletes excess space -using a simple FIFO mechanism. - -All methods provided are accessible in a programmer style and in an -interactive shell style. - -=head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode - -Enter interactive mode by running - - perl -MCPAN -e shell - -or - - cpan - -which puts you into a readline interface. If C<Term::ReadKey> and -either of C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed, -history and command completion are supported. - -Once at the command line, type C<h> for one-page help -screen; the rest should be self-explanatory. - -The function call C<shell> takes two optional arguments: one the -prompt, the second the default initial command line (the latter -only works if a real ReadLine interface module is installed). - -The most common uses of the interactive modes are - -=over 2 - -=item Searching for authors, bundles, distribution files and modules - -There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m> -for each of the four categories and another, C<i> for any of the -mentioned four. Each of the four entities is implemented as a class -with slightly differing methods for displaying an object. - -Arguments to these commands are either strings exactly matching -the identification string of an object, or regular expressions -matched case-insensitively against various attributes of the -objects. The parser only recognizes a regular expression when you -enclose it with slashes. - -The principle is that the number of objects found influences how an -item is displayed. If the search finds one item, the result is -displayed with the rather verbose method C<as_string>, but if -more than one is found, each object is displayed with the terse method -C<as_glimpse>. - -Examples: - - cpan> m Acme::MetaSyntactic - Module id = Acme::MetaSyntactic - CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>) - CPAN_VERSION 0.99 - CPAN_FILE B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz - UPLOAD_DATE 2006-11-06 - MANPAGE Acme::MetaSyntactic - Themed metasyntactic variables names - INST_FILE /usr/local/lib/perl/5.10.0/Acme/MetaSyntactic.pm - INST_VERSION 0.99 - cpan> a BOOK - Author id = BOOK - EMAIL [...] - FULLNAME Philippe Bruhat (BooK) - cpan> d BOOK/Acme-MetaSyntactic-0.99.tar.gz - Distribution id = B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz - CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>) - CONTAINSMODS Acme::MetaSyntactic Acme::MetaSyntactic::Alias [...] - UPLOAD_DATE 2006-11-06 - cpan> m /lorem/ - Module = Acme::MetaSyntactic::loremipsum (BOOK/Acme-MetaSyntactic-0.99.tar.gz) - Module Text::Lorem (ADEOLA/Text-Lorem-0.3.tar.gz) - Module Text::Lorem::More (RKRIMEN/Text-Lorem-More-0.12.tar.gz) - Module Text::Lorem::More::Source (RKRIMEN/Text-Lorem-More-0.12.tar.gz) - cpan> i /berlin/ - Distribution BEATNIK/Filter-NumberLines-0.02.tar.gz - Module = DateTime::TimeZone::Europe::Berlin (DROLSKY/DateTime-TimeZone-0.7904.tar.gz) - Module Filter::NumberLines (BEATNIK/Filter-NumberLines-0.02.tar.gz) - Author [...] - -The examples illustrate several aspects: the first three queries -target modules, authors, or distros directly and yield exactly one -result. The last two use regular expressions and yield several -results. The last one targets all of bundles, modules, authors, and -distros simultaneously. When more than one result is available, they -are printed in one-line format. - -=item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions - -These commands take any number of arguments and investigate what is -necessary to perform the action. If the argument is a distribution -file name (recognized by embedded slashes), it is processed. If it is -a module, CPAN determines the distribution file in which this module -is included and processes that, following any dependencies named in -the module's META.yml or Makefile.PL (this behavior is controlled by -the configuration parameter C<prerequisites_policy>.) - -C<get> downloads a distribution file and untars or unzips it, C<make> -builds it, C<test> runs the test suite, and C<install> installs it. - -Any C<make> or C<test> is run unconditionally. An - - install <distribution_file> - -is also run unconditionally. But for - - install <module> - -CPAN checks whether an install is needed and prints -I<module up to date> if the distribution file containing -the module doesn't need updating. - -CPAN also keeps track of what it has done within the current session -and doesn't try to build a package a second time regardless of whether it -succeeded or not. It does not repeat a test run if the test -has been run successfully before. Same for install runs. - -The C<force> pragma may precede another command (currently: C<get>, -C<make>, C<test>, or C<install>) to execute the command from scratch -and attempt to continue past certain errors. See the section below on -the C<force> and the C<fforce> pragma. - -The C<notest> pragma skips the test part in the build -process. - -Example: - - cpan> notest install Tk - -A C<clean> command results in a - - make clean - -being executed within the distribution file's working directory. - -=item C<readme>, C<perldoc>, C<look> module or distribution - -C<readme> displays the README file of the associated distribution. -C<Look> gets and untars (if not yet done) the distribution file, -changes to the appropriate directory and opens a subshell process in -that directory. C<perldoc> displays the module's pod documentation -in html or plain text format. - -=item C<ls> author - -=item C<ls> globbing_expression - -The first form lists all distribution files in and below an author's -CPAN directory as stored in the CHECKUMS files distributed on -CPAN. The listing recurses into subdirectories. - -The second form limits or expands the output with shell -globbing as in the following examples: - - ls JV/make* - ls GSAR/*make* - ls */*make* - -The last example is very slow and outputs extra progress indicators -that break the alignment of the result. - -Note that globbing only lists directories explicitly asked for, for -example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be -regarded as a bug that may be changed in some future version. - -=item C<failed> - -The C<failed> command reports all distributions that failed on one of -C<make>, C<test> or C<install> for some reason in the currently -running shell session. - -=item Persistence between sessions - -If the C<YAML> or the C<YAML::Syck> module is installed a record of -the internal state of all modules is written to disk after each step. -The files contain a signature of the currently running perl version -for later perusal. - -If the configurations variable C<build_dir_reuse> is set to a true -value, then CPAN.pm reads the collected YAML files. If the stored -signature matches the currently running perl, the stored state is -loaded into memory such that persistence between sessions -is effectively established. - -=item The C<force> and the C<fforce> pragma - -To speed things up in complex installation scenarios, CPAN.pm keeps -track of what it has already done and refuses to do some things a -second time. A C<get>, a C<make>, and an C<install> are not repeated. -A C<test> is repeated only if the previous test was unsuccessful. The -diagnostic message when CPAN.pm refuses to do something a second time -is one of I<Has already been >C<unwrapped|made|tested successfully> or -something similar. Another situation where CPAN refuses to act is an -C<install> if the corresponding C<test> was not successful. - -In all these cases, the user can override this stubborn behaviour by -prepending the command with the word force, for example: - - cpan> force get Foo - cpan> force make AUTHOR/Bar-3.14.tar.gz - cpan> force test Baz - cpan> force install Acme::Meta - -Each I<forced> command is executed with the corresponding part of its -memory erased. - -The C<fforce> pragma is a variant that emulates a C<force get> which -erases the entire memory followed by the action specified, effectively -restarting the whole get/make/test/install procedure from scratch. - -=item Lockfile - -Interactive sessions maintain a lockfile, by default C<~/.cpan/.lock>. -Batch jobs can run without a lockfile and not disturb each other. - -The shell offers to run in I<downgraded mode> when another process is -holding the lockfile. This is an experimental feature that is not yet -tested very well. This second shell then does not write the history -file, does not use the metadata file, and has a different prompt. - -=item Signals - -CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are -in the cpan-shell, it is intended that you can press C<^C> anytime and -return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell -to clean up and leave the shell loop. You can emulate the effect of a -SIGTERM by sending two consecutive SIGINTs, which usually means by -pressing C<^C> twice. - -CPAN.pm ignores SIGPIPE. If the user sets C<inactivity_timeout>, a -SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl -Build.PL> subprocess. - -=back - -=head2 CPAN::Shell - -The commands available in the shell interface are methods in -the package CPAN::Shell. If you enter the shell command, your -input is split by the Text::ParseWords::shellwords() routine, which -acts like most shells do. The first word is interpreted as the -method to be invoked, and the rest of the words are treated as the method's arguments. -Continuation lines are supported by ending a line with a -literal backslash. - -=head2 autobundle - -C<autobundle> writes a bundle file into the -C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains -a list of all modules that are both available from CPAN and currently -installed within @INC. The name of the bundle file is based on the -current date and a counter. - -=head2 hosts - -Note: this feature is still in alpha state and may change in future -versions of CPAN.pm - -This commands provides a statistical overview over recent download -activities. The data for this is collected in the YAML file -C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is -configured or YAML not installed, no stats are provided. - -=head2 mkmyconfig - -mkmyconfig() writes your own CPAN::MyConfig file into your C<~/.cpan/> -directory so that you can save your own preferences instead of the -system-wide ones. - -=head2 recent ***EXPERIMENTAL COMMAND*** - -The C<recent> command downloads a list of recent uploads to CPAN and -displays them I<slowly>. While the command is running, a $SIG{INT} -exits the loop after displaying the current item. - -B<Note>: This command requires XML::LibXML installed. - -B<Note>: This whole command currently is just a hack and will -probably change in future versions of CPAN.pm, but the general -approach will likely remain. - -B<Note>: See also L<smoke> - -=head2 recompile - -recompile() is a special command that takes no argument and -runs the make/test/install cycle with brute force over all installed -dynamically loadable extensions (aka XS modules) with 'force' in -effect. The primary purpose of this command is to finish a network -installation. Imagine you have a common source tree for two different -architectures. You decide to do a completely independent fresh -installation. You start on one architecture with the help of a Bundle -file produced earlier. CPAN installs the whole Bundle for you, but -when you try to repeat the job on the second architecture, CPAN -responds with a C<"Foo up to date"> message for all modules. So you -invoke CPAN's recompile on the second architecture and you're done. - -Another popular use for C<recompile> is to act as a rescue in case your -perl breaks binary compatibility. If one of the modules that CPAN uses -is in turn depending on binary compatibility (so you cannot run CPAN -commands), then you should try the CPAN::Nox module for recovery. - -=head2 report Bundle|Distribution|Module - -The C<report> command temporarily turns on the C<test_report> config -variable, then runs the C<force test> command with the given -arguments. The C<force> pragma reruns the tests and repeats -every step that might have failed before. - -=head2 smoke ***EXPERIMENTAL COMMAND*** - -B<*** WARNING: this command downloads and executes software from CPAN to -your computer of completely unknown status. You should never do -this with your normal account and better have a dedicated well -separated and secured machine to do this. ***> - -The C<smoke> command takes the list of recent uploads to CPAN as -provided by the C<recent> command and tests them all. While the -command is running $SIG{INT} is defined to mean that the current item -shall be skipped. - -B<Note>: This whole command currently is just a hack and will -probably change in future versions of CPAN.pm, but the general -approach will likely remain. - -B<Note>: See also L<recent> - -=head2 upgrade [Module|/Regex/]... - -The C<upgrade> command first runs an C<r> command with the given -arguments and then installs the newest versions of all modules that -were listed by that. - -=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution - -Although it may be considered internal, the class hierarchy does matter -for both users and programmer. CPAN.pm deals with the four -classes mentioned above, and those classes all share a set of methods. Classical -single polymorphism is in effect. A metaclass object registers all -objects of all kinds and indexes them with a string. The strings -referencing objects have a separated namespace (well, not completely -separated): - - Namespace Class - - words containing a "/" (slash) Distribution - words starting with Bundle:: Bundle - everything else Module or Author - -Modules know their associated Distribution objects. They always refer -to the most recent official release. Developers may mark their releases -as unstable development versions (by inserting an underbar into the -module version number which will also be reflected in the distribution -name when you run 'make dist'), so the really hottest and newest -distribution is not always the default. If a module Foo circulates -on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient -way to install version 1.23 by saying - - install Foo - -This would install the complete distribution file (say -BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would -like to install version 1.23_90, you need to know where the -distribution file resides on CPAN relative to the authors/id/ -directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz; -so you would have to say - - install BAR/Foo-1.23_90.tar.gz - -The first example will be driven by an object of the class -CPAN::Module, the second by an object of class CPAN::Distribution. - -=head2 Integrating local directories - -Note: this feature is still in alpha state and may change in future -versions of CPAN.pm - -Distribution objects are normally distributions from the CPAN, but -there is a slightly degenerate case for Distribution objects, too, of -projects held on the local disk. These distribution objects have the -same name as the local directory and end with a dot. A dot by itself -is also allowed for the current directory at the time CPAN.pm was -used. All actions such as C<make>, C<test>, and C<install> are applied -directly to that directory. This gives the command C<cpan .> an -interesting touch: while the normal mantra of installing a CPAN module -without CPAN.pm is one of - - perl Makefile.PL perl Build.PL - ( go and get prerequisites ) - make ./Build - make test ./Build test - make install ./Build install - -the command C<cpan .> does all of this at once. It figures out which -of the two mantras is appropriate, fetches and installs all -prerequisites, takes care of them recursively, and finally finishes the -installation of the module in the current directory, be it a CPAN -module or not. - -The typical usage case is for private modules or working copies of -projects from remote repositories on the local disk. - -=head2 Redirection - -The usual shell redirection symbols C< | > and C<< > >> are recognized -by the cpan shell B<only when surrounded by whitespace>. So piping to -pager or redirecting output into a file works somewhat as in a normal -shell, with the stipulation that you must type extra spaces. - -=head1 CONFIGURATION - -When the CPAN module is used for the first time, a configuration -dialogue tries to determine a couple of site specific options. The -result of the dialog is stored in a hash reference C< $CPAN::Config > -in a file CPAN/Config.pm. - -Default values defined in the CPAN/Config.pm file can be -overridden in a user specific file: CPAN/MyConfig.pm. Such a file is -best placed in C<$HOME/.cpan/CPAN/MyConfig.pm>, because C<$HOME/.cpan> is -added to the search path of the CPAN module before the use() or -require() statements. The mkmyconfig command writes this file for you. - -The C<o conf> command has various bells and whistles: - -=over - -=item completion support - -If you have a ReadLine module installed, you can hit TAB at any point -of the commandline and C<o conf> will offer you completion for the -built-in subcommands and/or config variable names. - -=item displaying some help: o conf help - -Displays a short help - -=item displaying current values: o conf [KEY] - -Displays the current value(s) for this config variable. Without KEY, -displays all subcommands and config variables. - -Example: - - o conf shell - -If KEY starts and ends with a slash, the string in between is -treated as a regular expression and only keys matching this regex -are displayed - -Example: - - o conf /color/ - -=item changing of scalar values: o conf KEY VALUE - -Sets the config variable KEY to VALUE. The empty string can be -specified as usual in shells, with C<''> or C<""> - -Example: - - o conf wget /usr/bin/wget - -=item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST - -If a config variable name ends with C<list>, it is a list. C<o conf -KEY shift> removes the first element of the list, C<o conf KEY pop> -removes the last element of the list. C<o conf KEYS unshift LIST> -prepends a list of values to the list, C<o conf KEYS push LIST> -appends a list of valued to the list. - -Likewise, C<o conf KEY splice LIST> passes the LIST to the corresponding -splice command. - -Finally, any other list of arguments is taken as a new list value for -the KEY variable discarding the previous value. - -Examples: - - o conf urllist unshift http://cpan.dev.local/CPAN - o conf urllist splice 3 1 - o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org - -=item reverting to saved: o conf defaults - -Reverts all config variables to the state in the saved config file. - -=item saving the config: o conf commit - -Saves all config variables to the current config file (CPAN/Config.pm -or CPAN/MyConfig.pm that was loaded at start). - -=back - -The configuration dialog can be started any time later again by -issuing the command C< o conf init > in the CPAN shell. A subset of -the configuration dialog can be run by issuing C<o conf init WORD> -where WORD is any valid config variable or a regular expression. - -=head2 Config Variables - -The following keys in the hash reference $CPAN::Config are -currently defined: - - applypatch path to external prg - auto_commit commit all changes to config variables to disk - build_cache size of cache for directories to build modules - build_dir locally accessible directory to build modules - build_dir_reuse boolean if distros in build_dir are persistent - build_requires_install_policy - to install or not to install when a module is - only needed for building. yes|no|ask/yes|ask/no - bzip2 path to external prg - cache_metadata use serializer to cache metadata - check_sigs if signatures should be verified - colorize_debug Term::ANSIColor attributes for debugging output - colorize_output boolean if Term::ANSIColor should colorize output - colorize_print Term::ANSIColor attributes for normal output - colorize_warn Term::ANSIColor attributes for warnings - commandnumber_in_prompt - boolean if you want to see current command number - commands_quote preferred character to use for quoting external - commands when running them. Defaults to double - quote on Windows, single tick everywhere else; - can be set to space to disable quoting - connect_to_internet_ok - whether to ask if opening a connection is ok before - urllist is specified - cpan_home local directory reserved for this package - curl path to external prg - dontload_hash DEPRECATED - dontload_list arrayref: modules in the list will not be - loaded by the CPAN::has_inst() routine - ftp path to external prg - ftp_passive if set, the envariable FTP_PASSIVE is set for downloads - ftp_proxy proxy host for ftp requests - ftpstats_period max number of days to keep download statistics - ftpstats_size max number of items to keep in the download statistics - getcwd see below - gpg path to external prg - gzip location of external program gzip - halt_on_failure stop processing after the first failure of queued - items or dependencies - histfile file to maintain history between sessions - histsize maximum number of lines to keep in histfile - http_proxy proxy host for http requests - inactivity_timeout breaks interactive Makefile.PLs or Build.PLs - after this many seconds inactivity. Set to 0 to - disable timeouts. - index_expire refetch index files after this many days - inhibit_startup_message - if true, suppress the startup message - keep_source_where directory in which to keep the source (if we do) - load_module_verbosity - report loading of optional modules used by CPAN.pm - lynx path to external prg - make location of external make program - make_arg arguments that should always be passed to 'make' - make_install_make_command - the make command for running 'make install', for - example 'sudo make' - make_install_arg same as make_arg for 'make install' - makepl_arg arguments passed to 'perl Makefile.PL' - mbuild_arg arguments passed to './Build' - mbuild_install_arg arguments passed to './Build install' - mbuild_install_build_command - command to use instead of './Build' when we are - in the install stage, for example 'sudo ./Build' - mbuildpl_arg arguments passed to 'perl Build.PL' - ncftp path to external prg - ncftpget path to external prg - no_proxy don't proxy to these hosts/domains (comma separated list) - pager location of external program more (or any pager) - password your password if you CPAN server wants one - patch path to external prg - patches_dir local directory containing patch files - perl5lib_verbosity verbosity level for PERL5LIB additions - prefer_installer legal values are MB and EUMM: if a module comes - with both a Makefile.PL and a Build.PL, use the - former (EUMM) or the latter (MB); if the module - comes with only one of the two, that one will be - used no matter the setting - prerequisites_policy - what to do if you are missing module prerequisites - ('follow' automatically, 'ask' me, or 'ignore') - prefs_dir local directory to store per-distro build options - proxy_user username for accessing an authenticating proxy - proxy_pass password for accessing an authenticating proxy - randomize_urllist add some randomness to the sequence of the urllist - scan_cache controls scanning of cache ('atstart' or 'never') - shell your favorite shell - show_unparsable_versions - boolean if r command tells which modules are versionless - show_upload_date boolean if commands should try to determine upload date - show_zero_versions boolean if r command tells for which modules $version==0 - tar location of external program tar - tar_verbosity verbosity level for the tar command - term_is_latin deprecated: if true Unicode is translated to ISO-8859-1 - (and nonsense for characters outside latin range) - term_ornaments boolean to turn ReadLine ornamenting on/off - test_report email test reports (if CPAN::Reporter is installed) - trust_test_report_history - skip testing when previously tested ok (according to - CPAN::Reporter history) - unzip location of external program unzip - urllist arrayref to nearby CPAN sites (or equivalent locations) - use_sqlite use CPAN::SQLite for metadata storage (fast and lean) - username your username if you CPAN server wants one - wait_list arrayref to a wait server to try (See CPAN::WAIT) - wget path to external prg - yaml_load_code enable YAML code deserialisation via CPAN::DeferredCode - yaml_module which module to use to read/write YAML files - -You can set and query each of these options interactively in the cpan -shell with the C<o conf> or the C<o conf init> command as specified below. - -=over 2 - -=item C<o conf E<lt>scalar optionE<gt>> - -prints the current value of the I<scalar option> - -=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>> - -Sets the value of the I<scalar option> to I<value> - -=item C<o conf E<lt>list optionE<gt>> - -prints the current value of the I<list option> in MakeMaker's -neatvalue format. - -=item C<o conf E<lt>list optionE<gt> [shift|pop]> - -shifts or pops the array in the I<list option> variable - -=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>> - -works like the corresponding perl commands. - -=item interactive editing: o conf init [MATCH|LIST] - -Runs an interactive configuration dialog for matching variables. -Without argument runs the dialog over all supported config variables. -To specify a MATCH the argument must be enclosed by slashes. - -Examples: - - o conf init ftp_passive ftp_proxy - o conf init /color/ - -Note: this method of setting config variables often provides more -explanation about the functioning of a variable than the manpage. - -=back - -=head2 CPAN::anycwd($path): Note on config variable getcwd - -CPAN.pm changes the current working directory often and needs to -determine its own current working directory. By default it uses -Cwd::cwd, but if for some reason this doesn't work on your system, -configure alternatives according to the following table: - -=over 4 - -=item cwd - -Calls Cwd::cwd - -=item getcwd - -Calls Cwd::getcwd - -=item fastcwd - -Calls Cwd::fastcwd - -=item backtickcwd - -Calls the external command cwd. - -=back - -=head2 Note on the format of the urllist parameter - -urllist parameters are URLs according to RFC 1738. We do a little -guessing if your URL is not compliant, but if you have problems with -C<file> URLs, please try the correct format. Either: - - file://localhost/whatever/ftp/pub/CPAN/ - -or - - file:///home/ftp/pub/CPAN/ - -=head2 The urllist parameter has CD-ROM support - -The C<urllist> parameter of the configuration table contains a list of -URLs used for downloading. If the list contains any -C<file> URLs, CPAN always tries there first. This -feature is disabled for index files. So the recommendation for the -owner of a CD-ROM with CPAN contents is: include your local, possibly -outdated CD-ROM as a C<file> URL at the end of urllist, e.g. - - o conf urllist push file://localhost/CDROM/CPAN - -CPAN.pm will then fetch the index files from one of the CPAN sites -that come at the beginning of urllist. It will later check for each -module to see whether there is a local copy of the most recent version. - -Another peculiarity of urllist is that the site that we could -successfully fetch the last file from automatically gets a preference -token and is tried as the first site for the next request. So if you -add a new site at runtime it may happen that the previously preferred -site will be tried another time. This means that if you want to disallow -a site for the next transfer, it must be explicitly removed from -urllist. - -=head2 Maintaining the urllist parameter - -If you have YAML.pm (or some other YAML module configured in -C<yaml_module>) installed, CPAN.pm collects a few statistical data -about recent downloads. You can view the statistics with the C<hosts> -command or inspect them directly by looking into the C<FTPstats.yml> -file in your C<cpan_home> directory. - -To get some interesting statistics, it is recommended that -C<randomize_urllist> be set; this introduces some amount of -randomness into the URL selection. - -=head2 The C<requires> and C<build_requires> dependency declarations - -Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by -a distribution are treated differently depending on the config -variable C<build_requires_install_policy>. By setting -C<build_requires_install_policy> to C<no>, such a module is not -installed. It is only built and tested, and then kept in the list of -tested but uninstalled modules. As such, it is available during the -build of the dependent module by integrating the path to the -C<blib/arch> and C<blib/lib> directories in the environment variable -PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then -both modules declared as C<requires> and those declared as -C<build_requires> are treated alike. By setting to C<ask/yes> or -C<ask/no>, CPAN.pm asks the user and sets the default accordingly. - -=head2 Configuration for individual distributions (I<Distroprefs>) - -(B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is -still considered beta quality) - -Distributions on CPAN usually behave according to what we call the -CPAN mantra. Or since the advent of Module::Build we should talk about -two mantras: - - perl Makefile.PL perl Build.PL - make ./Build - make test ./Build test - make install ./Build install - -But some modules cannot be built with this mantra. They try to get -some extra data from the user via the environment, extra arguments, or -interactively--thus disturbing the installation of large bundles like -Phalanx100 or modules with many dependencies like Plagger. - -The distroprefs system of C<CPAN.pm> addresses this problem by -allowing the user to specify extra informations and recipes in YAML -files to either - -=over - -=item - -pass additional arguments to one of the four commands, - -=item - -set environment variables - -=item - -instantiate an Expect object that reads from the console, waits for -some regular expressions and enters some answers - -=item - -temporarily override assorted C<CPAN.pm> configuration variables - -=item - -specify dependencies the original maintainer forgot - -=item - -disable the installation of an object altogether - -=back - -See the YAML and Data::Dumper files that come with the C<CPAN.pm> -distribution in the C<distroprefs/> directory for examples. - -=head2 Filenames - -The YAML files themselves must have the C<.yml> extension; all other -files are ignored (for two exceptions see I<Fallback Data::Dumper and -Storable> below). The containing directory can be specified in -C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init -prefs_dir> in the CPAN shell to set and activate the distroprefs -system. - -Every YAML file may contain arbitrary documents according to the YAML -specification, and every document is treated as an entity that -can specify the treatment of a single distribution. - -Filenames can be picked arbitrarily; C<CPAN.pm> always reads -all files (in alphabetical order) and takes the key C<match> (see -below in I<Language Specs>) as a hashref containing match criteria -that determine if the current distribution matches the YAML document -or not. - -=head2 Fallback Data::Dumper and Storable - -If neither your configured C<yaml_module> nor YAML.pm is installed, -CPAN.pm falls back to using Data::Dumper and Storable and looks for -files with the extensions C<.dd> or C<.st> in the C<prefs_dir> -directory. These files are expected to contain one or more hashrefs. -For Data::Dumper generated files, this is expected to be done with by -defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these -with the command - - ysh < somefile.yml > somefile.dd - -For Storable files the rule is that they must be constructed such that -C<Storable::retrieve(file)> returns an array reference and the array -elements represent one distropref object each. The conversion from -YAML would look like so: - - perl -MYAML=LoadFile -MStorable=nstore -e ' - @y=LoadFile(shift); - nstore(\@y, shift)' somefile.yml somefile.st - -In bootstrapping situations it is usually sufficient to translate only -a few YAML files to Data::Dumper for crucial modules like -C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable -over Data::Dumper, remember to pull out a Storable version that writes -an older format than all the other Storable versions that will need to -read them. - -=head2 Blueprint - -The following example contains all supported keywords and structures -with the exception of C<eexpect> which can be used instead of -C<expect>. - - --- - comment: "Demo" - match: - module: "Dancing::Queen" - distribution: "^CHACHACHA/Dancing-" - not_distribution: "\.zip$" - perl: "/usr/local/cariba-perl/bin/perl" - perlconfig: - archname: "freebsd" - not_cc: "gcc" - env: - DANCING_FLOOR: "Shubiduh" - disabled: 1 - cpanconfig: - make: gmake - pl: - args: - - "--somearg=specialcase" - - env: {} - - expect: - - "Which is your favorite fruit" - - "apple\n" - - make: - args: - - all - - extra-all - - env: {} - - expect: [] - - commendline: "echo SKIPPING make" - - test: - args: [] - - env: {} - - expect: [] - - install: - args: [] - - env: - WANT_TO_INSTALL: YES - - expect: - - "Do you really want to install" - - "y\n" - - patches: - - "ABCDE/Fedcba-3.14-ABCDE-01.patch" - - depends: - configure_requires: - LWP: 5.8 - build_requires: - Test::Exception: 0.25 - requires: - Spiffy: 0.30 - - -=head2 Language Specs - -Every YAML document represents a single hash reference. The valid keys -in this hash are as follows: - -=over - -=item comment [scalar] - -A comment - -=item cpanconfig [hash] - -Temporarily override assorted C<CPAN.pm> configuration variables. - -Supported are: C<build_requires_install_policy>, C<check_sigs>, -C<make>, C<make_install_make_command>, C<prefer_installer>, -C<test_report>. Please report as a bug when you need another one -supported. - -=item depends [hash] *** EXPERIMENTAL FEATURE *** - -All three types, namely C<configure_requires>, C<build_requires>, and -C<requires> are supported in the way specified in the META.yml -specification. The current implementation I<merges> the specified -dependencies with those declared by the package maintainer. In a -future implementation this may be changed to override the original -declaration. - -=item disabled [boolean] - -Specifies that this distribution shall not be processed at all. - -=item features [array] *** EXPERIMENTAL FEATURE *** - -Experimental implementation to deal with optional_features from -META.yml. Still needs coordination with installer software and -currently works only for META.yml declaring C<dynamic_config=0>. Use -with caution. - -=item goto [string] - -The canonical name of a delegate distribution to install -instead. Useful when a new version, although it tests OK itself, -breaks something else or a developer release or a fork is already -uploaded that is better than the last released version. - -=item install [hash] - -Processing instructions for the C<make install> or C<./Build install> -phase of the CPAN mantra. See below under I<Processing Instructions>. - -=item make [hash] - -Processing instructions for the C<make> or C<./Build> phase of the -CPAN mantra. See below under I<Processing Instructions>. - -=item match [hash] - -A hashref with one or more of the keys C<distribution>, C<modules>, -C<perl>, C<perlconfig>, and C<env> that specify whether a document is -targeted at a specific CPAN distribution or installation. -Keys prefixed with C<not_> negates the corresponding match. - -The corresponding values are interpreted as regular expressions. The -C<distribution> related one will be matched against the canonical -distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz". - -The C<module> related one will be matched against I<all> modules -contained in the distribution until one module matches. - -The C<perl> related one will be matched against C<$^X> (but with the -absolute path). - -The value associated with C<perlconfig> is itself a hashref that is -matched against corresponding values in the C<%Config::Config> hash -living in the C<Config.pm> module. -Keys prefixed with C<not_> negates the corresponding match. - -The value associated with C<env> is itself a hashref that is -matched against corresponding values in the C<%ENV> hash. -Keys prefixed with C<not_> negates the corresponding match. - -If more than one restriction of C<module>, C<distribution>, etc. is -specified, the results of the separately computed match values must -all match. If so, the hashref represented by the -YAML document is returned as the preference structure for the current -distribution. - -=item patches [array] - -An array of patches on CPAN or on the local disk to be applied in -order via an external patch program. If the value for the C<-p> -parameter is C<0> or C<1> is determined by reading the patch -beforehand. The path to each patch is either an absolute path on the -local filesystem or relative to a patch directory specified in the -C<patches_dir> configuration variable or in the format of a canonical -distroname. For examples please consult the distroprefs/ directory in -the CPAN.pm distribution (these examples are not installed by -default). - -Note: if the C<applypatch> program is installed and C<CPAN::Config> -knows about it B<and> a patch is written by the C<makepatch> program, -then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch> -and C<applypatch> are available from CPAN in the C<JV/makepatch-*> -distribution. - -=item pl [hash] - -Processing instructions for the C<perl Makefile.PL> or C<perl -Build.PL> phase of the CPAN mantra. See below under I<Processing -Instructions>. - -=item test [hash] - -Processing instructions for the C<make test> or C<./Build test> phase -of the CPAN mantra. See below under I<Processing Instructions>. - -=back - -=head2 Processing Instructions - -=over - -=item args [array] - -Arguments to be added to the command line - -=item commandline - -A full commandline to run via C<system()>. -During execution, the environment variable PERL is set -to $^X (but with an absolute path). If C<commandline> is specified, -C<args> is not used. - -=item eexpect [hash] - -Extended C<expect>. This is a hash reference with four allowed keys, -C<mode>, C<timeout>, C<reuse>, and C<talk>. - -C<mode> may have the values C<deterministic> for the case where all -questions come in the order written down and C<anyorder> for the case -where the questions may come in any order. The default mode is -C<deterministic>. - -C<timeout> denotes a timeout in seconds. Floating-point timeouts are -OK. With C<mode=deterministic>, the timeout denotes the -timeout per question; with C<mode=anyorder> it denotes the -timeout per byte received from the stream or questions. - -C<talk> is a reference to an array that contains alternating questions -and answers. Questions are regular expressions and answers are literal -strings. The Expect module watches the stream from the -execution of the external program (C<perl Makefile.PL>, C<perl -Build.PL>, C<make>, etc.). - -For C<mode=deterministic>, the CPAN.pm injects the -corresponding answer as soon as the stream matches the regular expression. - -For C<mode=anyorder> CPAN.pm answers a question as soon -as the timeout is reached for the next byte in the input stream. In -this mode you can use the C<reuse> parameter to decide what will -happen with a question-answer pair after it has been used. In the -default case (reuse=0) it is removed from the array, avoiding being -used again accidentally. If you want to answer the -question C<Do you really want to do that> several times, then it must -be included in the array at least as often as you want this answer to -be given. Setting the parameter C<reuse> to 1 makes this repetition -unnecessary. - -=item env [hash] - -Environment variables to be set during the command - -=item expect [array] - -C<< expect: <array> >> is a short notation for - -eexpect: - mode: deterministic - timeout: 15 - talk: <array> - -=back - -=head2 Schema verification with C<Kwalify> - -If you have the C<Kwalify> module installed (which is part of the -Bundle::CPANxxl), then all your distroprefs files are checked for -syntactic correctness. - -=head2 Example Distroprefs Files - -C<CPAN.pm> comes with a collection of example YAML files. Note that these -are really just examples and should not be used without care because -they cannot fit everybody's purpose. After all, the authors of the -packages that ask questions had a need to ask, so you should watch -their questions and adjust the examples to your environment and your -needs. You have been warned:-) - -=head1 PROGRAMMER'S INTERFACE - -If you do not enter the shell, shell commands are -available both as methods (C<CPAN::Shell-E<gt>install(...)>) and as -functions in the calling package (C<install(...)>). Before calling low-level -commands, it makes sense to initialize components of CPAN you need, e.g.: - - CPAN::HandleConfig->load; - CPAN::Shell::setup_output; - CPAN::Index->reload; - -High-level commands do such initializations automatically. - -There's currently only one class that has a stable interface - -CPAN::Shell. All commands that are available in the CPAN shell are -methods of the class CPAN::Shell. Each of the commands that produce -listings of modules (C<r>, C<autobundle>, C<u>) also return a list of -the IDs of all modules within the list. - -=over 2 - -=item expand($type,@things) - -The IDs of all objects available within a program are strings that can -be expanded to the corresponding real objects with the -C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a -list of CPAN::Module objects according to the C<@things> arguments -given. In scalar context, it returns only the first element of the -list. - -=item expandany(@things) - -Like expand, but returns objects of the appropriate type, i.e. -CPAN::Bundle objects for bundles, CPAN::Module objects for modules, and -CPAN::Distribution objects for distributions. Note: it does not expand -to CPAN::Author objects. - -=item Programming Examples - -This enables the programmer to do operations that combine -functionalities that are available in the shell. - - # install everything that is outdated on my disk: - perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)' - - # install my favorite programs if necessary: - for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) { - CPAN::Shell->install($mod); - } - - # list all modules on my disk that have no VERSION number - for $mod (CPAN::Shell->expand("Module","/./")) { - next unless $mod->inst_file; - # MakeMaker convention for undefined $VERSION: - next unless $mod->inst_version eq "undef"; - print "No VERSION in ", $mod->id, "\n"; - } - - # find out which distribution on CPAN contains a module: - print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file - -Or if you want to schedule a I<cron> job to watch CPAN, you could list -all modules that need updating. First a quick and dirty way: - - perl -e 'use CPAN; CPAN::Shell->r;' - -If you don't want any output should all modules be -up to date, parse the output of above command for the regular -expression C</modules are up to date/> and decide to mail the output -only if it doesn't match. - -If you prefer to do it more in a programmerish style in one single -process, something like this may better suit you: - - # list all modules on my disk that have newer versions on CPAN - for $mod (CPAN::Shell->expand("Module","/./")) { - next unless $mod->inst_file; - next if $mod->uptodate; - printf "Module %s is installed as %s, could be updated to %s from CPAN\n", - $mod->id, $mod->inst_version, $mod->cpan_version; - } - -If that gives too much output every day, you may want to -watch only for three modules. You can write - - for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) { - -as the first line instead. Or you can combine some of the above -tricks: - - # watch only for a new mod_perl module - $mod = CPAN::Shell->expand("Module","mod_perl"); - exit if $mod->uptodate; - # new mod_perl arrived, let me know all update recommendations - CPAN::Shell->r; - -=back - -=head2 Methods in the other Classes - -=over 4 - -=item CPAN::Author::as_glimpse() - -Returns a one-line description of the author - -=item CPAN::Author::as_string() - -Returns a multi-line description of the author - -=item CPAN::Author::email() - -Returns the author's email address - -=item CPAN::Author::fullname() - -Returns the author's name - -=item CPAN::Author::name() - -An alias for fullname - -=item CPAN::Bundle::as_glimpse() - -Returns a one-line description of the bundle - -=item CPAN::Bundle::as_string() - -Returns a multi-line description of the bundle - -=item CPAN::Bundle::clean() - -Recursively runs the C<clean> method on all items contained in the bundle. - -=item CPAN::Bundle::contains() - -Returns a list of objects' IDs contained in a bundle. The associated -objects may be bundles, modules or distributions. - -=item CPAN::Bundle::force($method,@args) - -Forces CPAN to perform a task that it normally would have refused to -do. Force takes as arguments a method name to be called and any number -of additional arguments that should be passed to the called method. -The internals of the object get the needed changes so that CPAN.pm -does not refuse to take the action. The C<force> is passed recursively -to all contained objects. See also the section above on the C<force> -and the C<fforce> pragma. - -=item CPAN::Bundle::get() - -Recursively runs the C<get> method on all items contained in the bundle - -=item CPAN::Bundle::inst_file() - -Returns the highest installed version of the bundle in either @INC or -C<$CPAN::Config->{cpan_home}>. Note that this is different from -CPAN::Module::inst_file. - -=item CPAN::Bundle::inst_version() - -Like CPAN::Bundle::inst_file, but returns the $VERSION - -=item CPAN::Bundle::uptodate() - -Returns 1 if the bundle itself and all its members are uptodate. - -=item CPAN::Bundle::install() - -Recursively runs the C<install> method on all items contained in the bundle - -=item CPAN::Bundle::make() - -Recursively runs the C<make> method on all items contained in the bundle - -=item CPAN::Bundle::readme() - -Recursively runs the C<readme> method on all items contained in the bundle - -=item CPAN::Bundle::test() - -Recursively runs the C<test> method on all items contained in the bundle - -=item CPAN::Distribution::as_glimpse() - -Returns a one-line description of the distribution - -=item CPAN::Distribution::as_string() - -Returns a multi-line description of the distribution - -=item CPAN::Distribution::author - -Returns the CPAN::Author object of the maintainer who uploaded this -distribution - -=item CPAN::Distribution::pretty_id() - -Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the -author's PAUSE ID and TARBALL is the distribution filename. - -=item CPAN::Distribution::base_id() - -Returns the distribution filename without any archive suffix. E.g -"Foo-Bar-0.01" - -=item CPAN::Distribution::clean() - -Changes to the directory where the distribution has been unpacked and -runs C<make clean> there. - -=item CPAN::Distribution::containsmods() - -Returns a list of IDs of modules contained in a distribution file. -Works only for distributions listed in the 02packages.details.txt.gz -file. This typically means that just most recent version of a -distribution is covered. - -=item CPAN::Distribution::cvs_import() - -Changes to the directory where the distribution has been unpacked and -runs something like - - cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version - -there. - -=item CPAN::Distribution::dir() - -Returns the directory into which this distribution has been unpacked. - -=item CPAN::Distribution::force($method,@args) - -Forces CPAN to perform a task that it normally would have refused to -do. Force takes as arguments a method name to be called and any number -of additional arguments that should be passed to the called method. -The internals of the object get the needed changes so that CPAN.pm -does not refuse to take the action. See also the section above on the -C<force> and the C<fforce> pragma. - -=item CPAN::Distribution::get() - -Downloads the distribution from CPAN and unpacks it. Does nothing if -the distribution has already been downloaded and unpacked within the -current session. - -=item CPAN::Distribution::install() - -Changes to the directory where the distribution has been unpacked and -runs the external command C<make install> there. If C<make> has not -yet been run, it will be run first. A C<make test> is issued in -any case and if this fails, the install is cancelled. The -cancellation can be avoided by letting C<force> run the C<install> for -you. - -This install method only has the power to install the distribution if -there are no dependencies in the way. To install an object along with all -its dependencies, use CPAN::Shell->install. - -Note that install() gives no meaningful return value. See uptodate(). - -=item CPAN::Distribution::install_tested() - -Install all distributions that have tested sucessfully but -not yet installed. See also C<is_tested>. - -=item CPAN::Distribution::isa_perl() - -Returns 1 if this distribution file seems to be a perl distribution. -Normally this is derived from the file name only, but the index from -CPAN can contain a hint to achieve a return value of true for other -filenames too. - -=item CPAN::Distribution::look() - -Changes to the directory where the distribution has been unpacked and -opens a subshell there. Exiting the subshell returns. - -=item CPAN::Distribution::make() - -First runs the C<get> method to make sure the distribution is -downloaded and unpacked. Changes to the directory where the -distribution has been unpacked and runs the external commands C<perl -Makefile.PL> or C<perl Build.PL> and C<make> there. - -=item CPAN::Distribution::perldoc() - -Downloads the pod documentation of the file associated with a -distribution (in HTML format) and runs it through the external -command I<lynx> specified in C<$CPAN::Config->{lynx}>. If I<lynx> -isn't available, it converts it to plain text with the external -command I<html2text> and runs it through the pager specified -in C<$CPAN::Config->{pager}> - -=item CPAN::Distribution::prefs() - -Returns the hash reference from the first matching YAML file that the -user has deposited in the C<prefs_dir/> directory. The first -succeeding match wins. The files in the C<prefs_dir/> are processed -alphabetically, and the canonical distroname (e.g. -AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions -stored in the $root->{match}{distribution} attribute value. -Additionally all module names contained in a distribution are matched -against the regular expressions in the $root->{match}{module} attribute -value. The two match values are ANDed together. Each of the two -attributes are optional. - -=item CPAN::Distribution::prereq_pm() - -Returns the hash reference that has been announced by a distribution -as the C<requires> and C<build_requires> elements. These can be -declared either by the C<META.yml> (if authoritative) or can be -deposited after the run of C<Build.PL> in the file C<./_build/prereqs> -or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in -a comment in the produced C<Makefile>. I<Note>: this method only works -after an attempt has been made to C<make> the distribution. Returns -undef otherwise. - -=item CPAN::Distribution::readme() - -Downloads the README file associated with a distribution and runs it -through the pager specified in C<$CPAN::Config->{pager}>. - -=item CPAN::Distribution::reports() - -Downloads report data for this distribution from www.cpantesters.org -and displays a subset of them. - -=item CPAN::Distribution::read_yaml() - -Returns the content of the META.yml of this distro as a hashref. Note: -works only after an attempt has been made to C<make> the distribution. -Returns undef otherwise. Also returns undef if the content of META.yml -is not authoritative. (The rules about what exactly makes the content -authoritative are still in flux.) - -=item CPAN::Distribution::test() - -Changes to the directory where the distribution has been unpacked and -runs C<make test> there. - -=item CPAN::Distribution::uptodate() - -Returns 1 if all the modules contained in the distribution are -uptodate. Relies on containsmods. - -=item CPAN::Index::force_reload() - -Forces a reload of all indices. - -=item CPAN::Index::reload() - -Reloads all indices if they have not been read for more than -C<$CPAN::Config->{index_expire}> days. - -=item CPAN::InfoObj::dump() - -CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution -inherit this method. It prints the data structure associated with an -object. Useful for debugging. Note: the data structure is considered -internal and thus subject to change without notice. - -=item CPAN::Module::as_glimpse() - -Returns a one-line description of the module in four columns: The -first column contains the word C<Module>, the second column consists -of one character: an equals sign if this module is already installed -and uptodate, a less-than sign if this module is installed but can be -upgraded, and a space if the module is not installed. The third column -is the name of the module and the fourth column gives maintainer or -distribution information. - -=item CPAN::Module::as_string() - -Returns a multi-line description of the module - -=item CPAN::Module::clean() - -Runs a clean on the distribution associated with this module. - -=item CPAN::Module::cpan_file() - -Returns the filename on CPAN that is associated with the module. - -=item CPAN::Module::cpan_version() - -Returns the latest version of this module available on CPAN. - -=item CPAN::Module::cvs_import() - -Runs a cvs_import on the distribution associated with this module. - -=item CPAN::Module::description() - -Returns a 44 character description of this module. Only available for -modules listed in The Module List (CPAN/modules/00modlist.long.html -or 00modlist.long.txt.gz) - -=item CPAN::Module::distribution() - -Returns the CPAN::Distribution object that contains the current -version of this module. - -=item CPAN::Module::dslip_status() - -Returns a hash reference. The keys of the hash are the letters C<D>, -C<S>, C<L>, C<I>, and <P>, for development status, support level, -language, interface and public licence respectively. The data for the -DSLIP status are collected by pause.perl.org when authors register -their namespaces. The values of the 5 hash elements are one-character -words whose meaning is described in the table below. There are also 5 -hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more -verbose value of the 5 status variables. - -Where the 'DSLIP' characters have the following meanings: - - D - Development Stage (Note: *NO IMPLIED TIMESCALES*): - i - Idea, listed to gain consensus or as a placeholder - c - under construction but pre-alpha (not yet released) - a/b - Alpha/Beta testing - R - Released - M - Mature (no rigorous definition) - S - Standard, supplied with Perl 5 - - S - Support Level: - m - Mailing-list - d - Developer - u - Usenet newsgroup comp.lang.perl.modules - n - None known, try comp.lang.perl.modules - a - abandoned; volunteers welcome to take over maintainance - - L - Language Used: - p - Perl-only, no compiler needed, should be platform independent - c - C and perl, a C compiler will be needed - h - Hybrid, written in perl with optional C code, no compiler needed - + - C++ and perl, a C++ compiler will be needed - o - perl and another language other than C or C++ - - I - Interface Style - f - plain Functions, no references used - h - hybrid, object and function interfaces available - n - no interface at all (huh?) - r - some use of unblessed References or ties - O - Object oriented using blessed references and/or inheritance - - P - Public License - p - Standard-Perl: user may choose between GPL and Artistic - g - GPL: GNU General Public License - l - LGPL: "GNU Lesser General Public License" (previously known as - "GNU Library General Public License") - b - BSD: The BSD License - a - Artistic license alone - 2 - Artistic license 2.0 or later - o - open source: appoved by www.opensource.org - d - allows distribution without restrictions - r - restricted distribtion - n - no license at all - -=item CPAN::Module::force($method,@args) - -Forces CPAN to perform a task it would normally refuse to -do. Force takes as arguments a method name to be invoked and any number -of additional arguments to pass that method. -The internals of the object get the needed changes so that CPAN.pm -does not refuse to take the action. See also the section above on the -C<force> and the C<fforce> pragma. - -=item CPAN::Module::get() - -Runs a get on the distribution associated with this module. - -=item CPAN::Module::inst_file() - -Returns the filename of the module found in @INC. The first file found -is reported, just as perl itself stops searching @INC once it finds a -module. - -=item CPAN::Module::available_file() - -Returns the filename of the module found in PERL5LIB or @INC. The -first file found is reported. The advantage of this method over -C<inst_file> is that modules that have been tested but not yet -installed are included because PERL5LIB keeps track of tested modules. - -=item CPAN::Module::inst_version() - -Returns the version number of the installed module in readable format. - -=item CPAN::Module::available_version() - -Returns the version number of the available module in readable format. - -=item CPAN::Module::install() - -Runs an C<install> on the distribution associated with this module. - -=item CPAN::Module::look() - -Changes to the directory where the distribution associated with this -module has been unpacked and opens a subshell there. Exiting the -subshell returns. - -=item CPAN::Module::make() - -Runs a C<make> on the distribution associated with this module. - -=item CPAN::Module::manpage_headline() - -If module is installed, peeks into the module's manpage, reads the -headline, and returns it. Moreover, if the module has been downloaded -within this session, does the equivalent on the downloaded module even -if it hasn't been installed yet. - -=item CPAN::Module::perldoc() - -Runs a C<perldoc> on this module. - -=item CPAN::Module::readme() - -Runs a C<readme> on the distribution associated with this module. - -=item CPAN::Module::reports() - -Calls the reports() method on the associated distribution object. - -=item CPAN::Module::test() - -Runs a C<test> on the distribution associated with this module. - -=item CPAN::Module::uptodate() - -Returns 1 if the module is installed and up-to-date. - -=item CPAN::Module::userid() - -Returns the author's ID of the module. - -=back - -=head2 Cache Manager - -Currently the cache manager only keeps track of the build directory -($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that -deletes complete directories below C<build_dir> as soon as the size of -all directories there gets bigger than $CPAN::Config->{build_cache} -(in MB). The contents of this cache may be used for later -re-installations that you intend to do manually, but will never be -trusted by CPAN itself. This is due to the fact that the user might -use these directories for building modules on different architectures. - -There is another directory ($CPAN::Config->{keep_source_where}) where -the original distribution files are kept. This directory is not -covered by the cache manager and must be controlled by the user. If -you choose to have the same directory as build_dir and as -keep_source_where directory, then your sources will be deleted with -the same fifo mechanism. - -=head2 Bundles - -A bundle is just a perl module in the namespace Bundle:: that does not -define any functions or methods. It usually only contains documentation. - -It starts like a perl module with a package declaration and a $VERSION -variable. After that the pod section looks like any other pod with the -only difference being that I<one special pod section> exists starting with -(verbatim): - - =head1 CONTENTS - -In this pod section each line obeys the format - - Module_Name [Version_String] [- optional text] - -The only required part is the first field, the name of a module -(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest -of the line is optional. The comment part is delimited by a dash just -as in the man page header. - -The distribution of a bundle should follow the same convention as -other distributions. - -Bundles are treated specially in the CPAN package. If you say 'install -Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all -the modules in the CONTENTS section of the pod. You can install your -own Bundles locally by placing a conformant Bundle file somewhere into -your @INC path. The autobundle() command which is available in the -shell interface does that for you by including all currently installed -modules in a snapshot bundle file. - -=head1 PREREQUISITES - -If you have a local mirror of CPAN and can access all files with -"file:" URLs, then you only need a perl later than perl5.003 to run -this module. Otherwise Net::FTP is strongly recommended. LWP may be -required for non-UNIX systems, or if your nearest CPAN site is -associated with a URL that is not C<ftp:>. - -If you have neither Net::FTP nor LWP, there is a fallback mechanism -implemented for an external ftp command or for an external lynx -command. - -=head1 UTILITIES - -=head2 Finding packages and VERSION - -This module presumes that all packages on CPAN - -=over 2 - -=item * - -declare their $VERSION variable in an easy to parse manner. This -prerequisite can hardly be relaxed because it consumes far too much -memory to load all packages into the running program just to determine -the $VERSION variable. Currently all programs that are dealing with -version use something like this - - perl -MExtUtils::MakeMaker -le \ - 'print MM->parse_version(shift)' filename - -If you are author of a package and wonder if your $VERSION can be -parsed, please try the above method. - -=item * - -come as compressed or gzipped tarfiles or as zip files and contain a -C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but -with little enthusiasm). - -=back - -=head2 Debugging - -Debugging this module is more than a bit complex due to interference from -the software producing the indices on CPAN, the mirroring process on CPAN, -packaging, configuration, synchronicity, and even (gasp!) due to bugs -within the CPAN.pm module itself. - -For debugging the code of CPAN.pm itself in interactive mode, some -debugging aid can be turned on for most packages within -CPAN.pm with one of - -=over 2 - -=item o debug package... - -sets debug mode for packages. - -=item o debug -package... - -unsets debug mode for packages. - -=item o debug all - -turns debugging on for all packages. - -=item o debug number - -=back - -which sets the debugging packages directly. Note that C<o debug 0> -turns debugging off. - -What seems a successful strategy is the combination of C<reload -cpan> and the debugging switches. Add a new debug statement while -running in the shell and then issue a C<reload cpan> and see the new -debugging messages immediately without losing the current context. - -C<o debug> without an argument lists the valid package names and the -current set of packages in debugging mode. C<o debug> has built-in -completion support. - -For debugging of CPAN data there is the C<dump> command which takes -the same arguments as make/test/install and outputs each object's -Data::Dumper dump. If an argument looks like a perl variable and -contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to -Data::Dumper directly. - -=head2 Floppy, Zip, Offline Mode - -CPAN.pm works nicely without network access, too. If you maintain machines -that are not networked at all, you should consider working with C<file:> -URLs. You'll have to collect your modules somewhere first. So -you might use CPAN.pm to put together all you need on a networked -machine. Then copy the $CPAN::Config->{keep_source_where} (but not -$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind -of a personal CPAN. CPAN.pm on the non-networked machines works nicely -with this floppy. See also below the paragraph about CD-ROM support. - -=head2 Basic Utilities for Programmers - -=over 2 - -=item has_inst($module) - -Returns true if the module is installed. Used to load all modules into -the running CPAN.pm that are considered optional. The config variable -C<dontload_list> intercepts the C<has_inst()> call such -that an optional module is not loaded despite being available. For -example, the following command will prevent C<YAML.pm> from being -loaded: - - cpan> o conf dontload_list push YAML - -See the source for details. - -=item has_usable($module) - -Returns true if the module is installed and in a usable state. Only -useful for a handful of modules that are used internally. See the -source for details. - -=item instance($module) - -The constructor for all the singletons used to represent modules, -distributions, authors, and bundles. If the object already exists, this -method returns the object; otherwise, it calls the constructor. - -=back - -=head1 SECURITY - -There's no strong security layer in CPAN.pm. CPAN.pm helps you to -install foreign, unmasked, unsigned code on your machine. We compare -to a checksum that comes from the net just as the distribution file -itself. But we try to make it easy to add security on demand: - -=head2 Cryptographically signed modules - -Since release 1.77, CPAN.pm has been able to verify cryptographically -signed module distributions using Module::Signature. The CPAN modules -can be signed by their authors, thus giving more security. The simple -unsigned MD5 checksums that were used before by CPAN protect mainly -against accidental file corruption. - -You will need to have Module::Signature installed, which in turn -requires that you have at least one of Crypt::OpenPGP module or the -command-line F<gpg> tool installed. - -You will also need to be able to connect over the Internet to the public -keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol). - -The configuration parameter check_sigs is there to turn signature -checking on or off. - -=head1 EXPORT - -Most functions in package CPAN are exported by default. The reason -for this is that the primary use is intended for the cpan shell or for -one-liners. - -=head1 ENVIRONMENT - -When the CPAN shell enters a subshell via the look command, it sets -the environment CPAN_SHELL_LEVEL to 1, or increments that variable if it is -already set. - -When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING -to the ID of the running process. It also sets -PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could -happen with older versions of Module::Install. - -When running C<perl Makefile.PL>, the environment variable -C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the -C<Makefile.PL> that is being executed. This prevents runaway processes -with newer versions of Module::Install. - -When the config variable ftp_passive is set, all downloads will be run -with the environment variable FTP_PASSIVE set to this value. This is -in general a good idea as it influences both Net::FTP and LWP based -connections. The same effect can be achieved by starting the cpan -shell with this environment variable set. For Net::FTP alone, one can -also always set passive mode by running libnetcfg. - -=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES - -Populating a freshly installed perl with one's favorite modules is pretty -easy if you maintain a private bundle definition file. To get a useful -blueprint of a bundle definition file, the command autobundle can be used -on the CPAN shell command line. This command writes a bundle definition -file for all modules installed for the current perl -interpreter. It's recommended to run this command once only, and from then -on maintain the file manually under a private name, say -Bundle/my_bundle.pm. With a clever bundle file you can then simply say - - cpan> install Bundle::my_bundle - -then answer a few questions and go out for coffee (possibly -even in a different city). - -Maintaining a bundle definition file means keeping track of two -things: dependencies and interactivity. CPAN.pm sometimes fails on -calculating dependencies because not all modules define all MakeMaker -attributes correctly, so a bundle definition file should specify -prerequisites as early as possible. On the other hand, it's -annoying that so many distributions need some interactive configuring. So -what you can try to accomplish in your private bundle file is to have the -packages that need to be configured early in the file and the gentle -ones later, so you can go out for cofeee after a few minutes and leave CPAN.pm -to churn away untended. - -=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS - -Thanks to Graham Barr for contributing the following paragraphs about -the interaction between perl, and various firewall configurations. For -further information on firewalls, it is recommended to consult the -documentation that comes with the I<ncftp> program. If you are unable to -go through the firewall with a simple Perl setup, it is likely -that you can configure I<ncftp> so that it works through your firewall. - -=head2 Three basic types of firewalls - -Firewalls can be categorized into three basic types. - -=over 4 - -=item http firewall - -This is when the firewall machine runs a web server, and to access the -outside world, you must do so via that web server. If you set environment -variables like http_proxy or ftp_proxy to values beginning with http://, -or in your web browser you've proxy information set, then you know -you are running behind an http firewall. - -To access servers outside these types of firewalls with perl (even for -ftp), you need LWP. - -=item ftp firewall - -This where the firewall machine runs an ftp server. This kind of -firewall will only let you access ftp servers outside the firewall. -This is usually done by connecting to the firewall with ftp, then -entering a username like "user@outside.host.com". - -To access servers outside these type of firewalls with perl, you -need Net::FTP. - -=item One-way visibility - -One-way visibility means these firewalls try to make themselves -invisible to users inside the firewall. An FTP data connection is -normally created by sending your IP address to the remote server and then -listening for the return connection. But the remote server will not be able to -connect to you because of the firewall. For these types of firewall, -FTP connections need to be done in a passive mode. - -There are two that I can think off. - -=over 4 - -=item SOCKS - -If you are using a SOCKS firewall, you will need to compile perl and link -it with the SOCKS library. This is what is normally called a 'socksified' -perl. With this executable you will be able to connect to servers outside -the firewall as if it were not there. - -=item IP Masquerade - -This is when the firewall implemented in the kernel (via NAT, or networking -address translation), it allows you to hide a complete network behind one -IP address. With this firewall no special compiling is needed as you can -access hosts directly. - -For accessing ftp servers behind such firewalls you usually need to -set the environment variable C<FTP_PASSIVE> or the config variable -ftp_passive to a true value. - -=back - -=back - -=head2 Configuring lynx or ncftp for going through a firewall - -If you can go through your firewall with e.g. lynx, presumably with a -command such as - - /usr/local/bin/lynx -pscott:tiger - -then you would configure CPAN.pm with the command - - o conf lynx "/usr/local/bin/lynx -pscott:tiger" - -That's all. Similarly for ncftp or ftp, you would configure something -like - - o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg" - -Your mileage may vary... - -=head1 FAQ - -=over 4 - -=item 1) - -I installed a new version of module X but CPAN keeps saying, -I have the old version installed - -Probably you B<do> have the old version installed. This can -happen if a module installs itself into a different directory in the -@INC path than it was previously installed. This is not really a -CPAN.pm problem, you would have the same problem when installing the -module manually. The easiest way to prevent this behaviour is to add -the argument C<UNINST=1> to the C<make install> call, and that is why -many people add this argument permanently by configuring - - o conf make_install_arg UNINST=1 - -=item 2) - -So why is UNINST=1 not the default? - -Because there are people who have their precise expectations about who -may install where in the @INC path and who uses which @INC array. In -fine tuned environments C<UNINST=1> can cause damage. - -=item 3) - -I want to clean up my mess, and install a new perl along with -all modules I have. How do I go about it? - -Run the autobundle command for your old perl and optionally rename the -resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl -with the Configure option prefix, e.g. - - ./Configure -Dprefix=/usr/local/perl-5.6.78.9 - -Install the bundle file you produced in the first step with something like - - cpan> install Bundle::mybundle - -and you're done. - -=item 4) - -When I install bundles or multiple modules with one command -there is too much output to keep track of. - -You may want to configure something like - - o conf make_arg "| tee -ai /root/.cpan/logs/make.out" - o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out" - -so that STDOUT is captured in a file for later inspection. - - -=item 5) - -I am not root, how can I install a module in a personal directory? - -First of all, you will want to use your own configuration, not the one -that your root user installed. If you do not have permission to write -in the cpan directory that root has configured, you will be asked if -you want to create your own config. Answering "yes" will bring you into -CPAN's configuration stage, using the system config for all defaults except -things that have to do with CPAN's work directory, saving your choices to -your MyConfig.pm file. - -You can also manually initiate this process with the following command: - - % perl -MCPAN -e 'mkmyconfig' - -or by running - - mkmyconfig - -from the CPAN shell. - -You will most probably also want to configure something like this: - - o conf makepl_arg "LIB=~/myperl/lib \ - INSTALLMAN1DIR=~/myperl/man/man1 \ - INSTALLMAN3DIR=~/myperl/man/man3 \ - INSTALLSCRIPT=~/myperl/bin \ - INSTALLBIN=~/myperl/bin" - -and then the equivalent command for Module::Build, which is - - o conf mbuildpl_arg "--lib=~/myperl/lib \ - --installman1dir=~/myperl/man/man1 \ - --installman3dir=~/myperl/man/man3 \ - --installscript=~/myperl/bin \ - --installbin=~/myperl/bin" - -You can make this setting permanent like all C<o conf> settings with -C<o conf commit> or by setting C<auto_commit> beforehand. - -You will have to add ~/myperl/man to the MANPATH environment variable -and also tell your perl programs to look into ~/myperl/lib, e.g. by -including - - use lib "$ENV{HOME}/myperl/lib"; - -or setting the PERL5LIB environment variable. - -While we're speaking about $ENV{HOME}, it might be worth mentioning, -that for Windows we use the File::HomeDir module that provides an -equivalent to the concept of the home directory on Unix. - -Another thing you should bear in mind is that the UNINST parameter can -be dangerous when you are installing into a private area because you -might accidentally remove modules that other people depend on that are -not using the private area. - -=item 6) - -How to get a package, unwrap it, and make a change before building it? - -Have a look at the C<look> (!) command. - -=item 7) - -I installed a Bundle and had a couple of fails. When I -retried, everything resolved nicely. Can this be fixed to work -on first try? - -The reason for this is that CPAN does not know the dependencies of all -modules when it starts out. To decide about the additional items to -install, it just uses data found in the META.yml file or the generated -Makefile. An undetected missing piece breaks the process. But it may -well be that your Bundle installs some prerequisite later than some -depending item and thus your second try is able to resolve everything. -Please note, CPAN.pm does not know the dependency tree in advance and -cannot sort the queue of things to install in a topologically correct -order. It resolves perfectly well B<if> all modules declare the -prerequisites correctly with the PREREQ_PM attribute to MakeMaker or -the C<requires> stanza of Module::Build. For bundles which fail and -you need to install often, it is recommended to sort the Bundle -definition file manually. - -=item 8) - -In our intranet, we have many modules for internal use. How -can I integrate these modules with CPAN.pm but without uploading -the modules to CPAN? - -Have a look at the CPAN::Site module. - -=item 9) - -When I run CPAN's shell, I get an error message about things in my -C</etc/inputrc> (or C<~/.inputrc>) file. - -These are readline issues and can only be fixed by studying readline -configuration on your architecture and adjusting the referenced file -accordingly. Please make a backup of the C</etc/inputrc> or C<~/.inputrc> -and edit them. Quite often harmless changes like uppercasing or -lowercasing some arguments solves the problem. - -=item 10) - -Some authors have strange characters in their names. - -Internally CPAN.pm uses the UTF-8 charset. If your terminal is -expecting ISO-8859-1 charset, a converter can be activated by setting -term_is_latin to a true value in your config file. One way of doing so -would be - - cpan> o conf term_is_latin 1 - -If other charset support is needed, please file a bugreport against -CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend -the support or maybe UTF-8 terminals become widely available. - -Note: this config variable is deprecated and will be removed in a -future version of CPAN.pm. It will be replaced with the conventions -around the family of $LANG and $LC_* environment variables. - -=item 11) - -When an install fails for some reason and then I correct the error -condition and retry, CPAN.pm refuses to install the module, saying -C<Already tried without success>. - -Use the force pragma like so - - force install Foo::Bar - -Or you can use - - look Foo::Bar - -and then C<make install> directly in the subshell. - -=item 12) - -How do I install a "DEVELOPER RELEASE" of a module? - -By default, CPAN will install the latest non-developer release of a -module. If you want to install a dev release, you have to specify the -partial path starting with the author id to the tarball you wish to -install, like so: - - cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz - -Note that you can use the C<ls> command to get this path listed. - -=item 13) - -How do I install a module and all its dependencies from the commandline, -without being prompted for anything, despite my CPAN configuration -(or lack thereof)? - -CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so -if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be -asked any questions at all (assuming the modules you are installing are -nice about obeying that variable as well): - - % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module' - -=item 14) - -How do I create a Module::Build based Build.PL derived from an -ExtUtils::MakeMaker focused Makefile.PL? - -http://search.cpan.org/search?query=Module::Build::Convert - -http://www.refcnt.org/papers/module-build-convert - -=item 15) - -I'm frequently irritated with the CPAN shell's inability to help me -select a good mirror. - -The urllist config parameter is yours. You can add and remove sites at -will. You should find out which sites have the best uptodateness, -bandwidth, reliability, etc. and are topologically close to you. Some -people prefer fast downloads, others uptodateness, others reliability. -You decide which to try in which order. - -Henk P. Penning maintains a site that collects data about CPAN sites: - - http://www.cs.uu.nl/people/henkp/mirmon/cpan.html - -Also, feel free to play with experimental features. Run - - o conf init randomize_urllist ftpstats_period ftpstats_size - -and choose your favorite parameters. After a few downloads running the -C<hosts> command will probably assist you in choosing the best mirror -sites. - -=item 16) - -Why do I get asked the same questions every time I start the shell? - -You can make your configuration changes permanent by calling the -command C<o conf commit>. Alternatively set the C<auto_commit> -variable to true by running C<o conf init auto_commit> and answering -the following question with yes. - -=item 17) - -Older versions of CPAN.pm had the original root directory of all -tarballs in the build directory. Now there are always random -characters appended to these directory names. Why was this done? - -The random characters are provided by File::Temp and ensure that each -module's individual build directory is unique. This makes running -CPAN.pm in concurrent processes simultaneously safe. - -=item 18) - -Speaking of the build directory. Do I have to clean it up myself? - -You have the choice to set the config variable C<scan_cache> to -C<never>. Then you must clean it up yourself. The other possible -value, C<atstart> only cleans up the build directory when you start -the CPAN shell. If you never start up the CPAN shell, you probably -also have to clean up the build directory yourself. - -=back - -=head1 COMPATIBILITY - -=head2 OLD PERL VERSIONS - -CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted -newer versions. It is getting more and more difficult to get the -minimal prerequisites working on older perls. It is close to -impossible to get the whole Bundle::CPAN working there. If you're in -the position to have only these old versions, be advised that CPAN is -designed to work fine without the Bundle::CPAN installed. - -To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is -compatible with ancient perls and that File::Temp is listed as a -prerequisite but CPAN has reasonable workarounds if it is missing. - -=head2 CPANPLUS - -This module and its competitor, the CPANPLUS module, are both much -cooler than the other. CPAN.pm is older. CPANPLUS was designed to be -more modular, but it was never intended to be compatible with CPAN.pm. - -=head1 SECURITY ADVICE - -This software enables you to upgrade software on your computer and so -is inherently dangerous because the newly installed software may -contain bugs and may alter the way your computer works or even make it -unusable. Please consider backing up your data before every upgrade. - -=head1 BUGS - -Please report bugs via L<http://rt.cpan.org/> - -Before submitting a bug, please make sure that the traditional method -of building a Perl module package from a shell by following the -installation instructions of that package still works in your -environment. - -=head1 AUTHOR - -Andreas Koenig C<< <andk@cpan.org> >> - -=head1 LICENSE - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See L<http://www.perl.com/perl/misc/Artistic.html> - -=head1 TRANSLATIONS - -Kawai,Takanori provides a Japanese translation of this manpage at -L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm> - -=head1 SEE ALSO - -L<cpan>, L<CPAN::Nox>, L<CPAN::Version> - -=cut diff --git a/lib/CPAN/API/HOWTO.pod b/lib/CPAN/API/HOWTO.pod deleted file mode 100644 index e65a4bc931..0000000000 --- a/lib/CPAN/API/HOWTO.pod +++ /dev/null @@ -1,44 +0,0 @@ -=head1 NAME - -CPAN::API::HOWTO - a recipe book for programming with CPAN.pm - -=head1 RECIPES - -All of these recipes assume that you have put "use CPAN" at the top of -your program. - -=head2 What distribution contains a particular module? - - my $distribution = CPAN::Shell->expand( - "Module", "Data::UUID" - )->distribution()->pretty_id(); - -This returns a string of the form "AUTHORID/TARBALL". If you want the -full path and filename to this distribution on a CPAN mirror, then it is -C<.../authors/id/A/AU/AUTHORID/TARBALL>. - -=head2 What modules does a particular distribution contain? - - CPAN::Index->reload(); - my @modules = CPAN::Shell->expand( - "Distribution", "JHI/Graph-0.83.tar.gz" - )->containsmods(); - -You may also refer to a distribution in the form A/AU/AUTHORID/TARBALL. - -=head1 SEE ALSO - -the main CPAN.pm documentation - -=head1 LICENSE - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See L<http://www.perl.com/perl/misc/Artistic.html> - -=head1 AUTHOR - -David Cantrell - -=cut diff --git a/lib/CPAN/Author.pm b/lib/CPAN/Author.pm deleted file mode 100644 index 14ef2ef633..0000000000 --- a/lib/CPAN/Author.pm +++ /dev/null @@ -1,228 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::Author; -use strict; - -use CPAN::InfoObj; -@CPAN::Author::ISA = qw(CPAN::InfoObj); -use vars qw( - $VERSION -); -$VERSION = "5.5"; - -package CPAN::Author; -use strict; - -#-> sub CPAN::Author::force -sub force { - my $self = shift; - $self->{force}++; -} - -#-> sub CPAN::Author::force -sub unforce { - my $self = shift; - delete $self->{force}; -} - -#-> sub CPAN::Author::id -sub id { - my $self = shift; - my $id = $self->{ID}; - $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/; - $id; -} - -#-> sub CPAN::Author::as_glimpse ; -sub as_glimpse { - my($self) = @_; - my(@m); - my $class = ref($self); - $class =~ s/^CPAN:://; - push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n}, - $class, - $self->{ID}, - $self->fullname, - $self->email); - join "", @m; -} - -#-> sub CPAN::Author::fullname ; -sub fullname { - shift->ro->{FULLNAME}; -} -*name = \&fullname; - -#-> sub CPAN::Author::email ; -sub email { shift->ro->{EMAIL}; } - -#-> sub CPAN::Author::ls ; -sub ls { - my $self = shift; - my $glob = shift || ""; - my $silent = shift || 0; - my $id = $self->id; - - # adapted from CPAN::Distribution::verifyCHECKSUM ; - my(@csf); # chksumfile - @csf = $self->id =~ /(.)(.)(.*)/; - $csf[1] = join "", @csf[0,1]; - $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK") - my(@dl); - @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1); - unless (grep {$_->[2] eq $csf[1]} @dl) { - $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ; - return; - } - @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1); - unless (grep {$_->[2] eq $csf[2]} @dl) { - $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent; - return; - } - @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1); - if ($glob) { - if ($CPAN::META->has_inst("Text::Glob")) { - $glob =~ s|/$|/*|; - my $rglob = Text::Glob::glob_to_regex($glob); - CPAN->debug("glob[$glob]rglob[$rglob]dl[@dl]") if $CPAN::DEBUG; - my @tmpdl = grep { $_->[2] =~ /$rglob/ } @dl; - if (1==@tmpdl && $tmpdl[0][0]==0) { - $rglob = Text::Glob::glob_to_regex("$glob/*"); - @dl = grep { $_->[2] =~ /$rglob/ } @dl; - } else { - @dl = @tmpdl; - } - CPAN->debug("rglob[$rglob]dl[@dl]") if $CPAN::DEBUG; - } else { - $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed"); - } - } - unless ($silent >= 2) { - $CPAN::Frontend->myprint - ( - join "", - map { - sprintf - ( - "%8d %10s %s/%s%s\n", - $_->[0], - $_->[1], - $id, - $_->[2], - 0==$_->[0]?"/":"", - ) - } sort { $a->[2] cmp $b->[2] } @dl - ); - } - @dl; -} - -# returns an array of arrays, the latter contain (size,mtime,filename) -#-> sub CPAN::Author::dir_listing ; -sub dir_listing { - my $self = shift; - my $chksumfile = shift; - my $recursive = shift; - my $may_ftp = shift; - - my $lc_want = - File::Spec->catfile($CPAN::Config->{keep_source_where}, - "authors", "id", @$chksumfile); - - my $fh; - - CPAN->debug("chksumfile[@$chksumfile]recursive[$recursive]may_ftp[$may_ftp]") if $CPAN::DEBUG; - # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security - # hazard. (Without GPG installed they are not that much better, - # though.) - $fh = FileHandle->new; - if (open($fh, $lc_want)) { - my $line = <$fh>; close $fh; - unlink($lc_want) unless $line =~ /PGP/; - } - - local($") = "/"; - # connect "force" argument with "index_expire". - my $force = $self->{force}; - if (my @stat = stat $lc_want) { - $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time; - } - my $lc_file; - if ($may_ftp) { - $lc_file = CPAN::FTP->localize( - "authors/id/@$chksumfile", - $lc_want, - $force, - ); - unless ($lc_file) { - $CPAN::Frontend->myprint("Trying $lc_want.gz\n"); - $chksumfile->[-1] .= ".gz"; - $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile", - "$lc_want.gz",1); - if ($lc_file) { - $lc_file =~ s{\.gz(?!\n)\Z}{}; #}; - eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)}; - } else { - return; - } - } - } else { - $lc_file = $lc_want; - # we *could* second-guess and if the user has a file: URL, - # then we could look there. But on the other hand, if they do - # have a file: URL, wy did they choose to set - # $CPAN::Config->{show_upload_date} to false? - } - - # adapted from CPAN::Distribution::CHECKSUM_check_file ; - $fh = FileHandle->new; - my($cksum); - if (open $fh, $lc_file) { - local($/); - my $eval = <$fh>; - $eval =~ s/\015?\012/\n/g; - close $fh; - my($compmt) = Safe->new(); - $cksum = $compmt->reval($eval); - if ($@) { - rename $lc_file, "$lc_file.bad"; - Carp::confess($@) if $@; - } - } elsif ($may_ftp) { - Carp::carp ("Could not open '$lc_file' for reading."); - } else { - # Maybe should warn: "You may want to set show_upload_date to a true value" - return; - } - my(@result,$f); - for $f (sort keys %$cksum) { - if (exists $cksum->{$f}{isdir}) { - if ($recursive) { - my(@dir) = @$chksumfile; - pop @dir; - push @dir, $f, "CHECKSUMS"; - push @result, [ 0, "-", $f ]; - push @result, map { - [$_->[0], $_->[1], "$f/$_->[2]"] - } $self->dir_listing(\@dir,1,$may_ftp); - } else { - push @result, [ 0, "-", $f ]; - } - } else { - push @result, [ - ($cksum->{$f}{"size"}||0), - $cksum->{$f}{"mtime"}||"---", - $f - ]; - } - } - @result; -} - -#-> sub CPAN::Author::reports -sub reports { - $CPAN::Frontend->mywarn("reports on authors not implemented. -Please file a bugreport if you need this.\n"); -} - -1; diff --git a/lib/CPAN/Bundle.pm b/lib/CPAN/Bundle.pm deleted file mode 100644 index e7360f8048..0000000000 --- a/lib/CPAN/Bundle.pm +++ /dev/null @@ -1,287 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::Bundle; -use strict; -use CPAN::Module; -@CPAN::Bundle::ISA = qw(CPAN::Module); - -use vars qw( - $VERSION -); -$VERSION = "5.5"; - -sub look { - my $self = shift; - $CPAN::Frontend->myprint($self->as_string); -} - -#-> CPAN::Bundle::undelay -sub undelay { - my $self = shift; - delete $self->{later}; - for my $c ( $self->contains ) { - my $obj = CPAN::Shell->expandany($c) or next; - $obj->undelay; - } -} - -# mark as dirty/clean -#-> sub CPAN::Bundle::color_cmd_tmps ; -sub color_cmd_tmps { - my($self) = shift; - my($depth) = shift || 0; - my($color) = shift || 0; - my($ancestors) = shift || []; - # a module needs to recurse to its cpan_file, a distribution needs - # to recurse into its prereq_pms, a bundle needs to recurse into its modules - - return if exists $self->{incommandcolor} - && $color==1 - && $self->{incommandcolor}==$color; - if ($depth>=$CPAN::MAX_RECURSION) { - die(CPAN::Exception::RecursiveDependency->new($ancestors)); - } - # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; - - for my $c ( $self->contains ) { - my $obj = CPAN::Shell->expandany($c) or next; - CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG; - $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); - } - # never reached code? - #if ($color==0) { - #delete $self->{badtestcnt}; - #} - $self->{incommandcolor} = $color; -} - -#-> sub CPAN::Bundle::as_string ; -sub as_string { - my($self) = @_; - $self->contains; - # following line must be "=", not "||=" because we have a moving target - $self->{INST_VERSION} = $self->inst_version; - return $self->SUPER::as_string; -} - -#-> sub CPAN::Bundle::contains ; -sub contains { - my($self) = @_; - my($inst_file) = $self->inst_file || ""; - my($id) = $self->id; - $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG; - if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) { - undef $inst_file; - } - unless ($inst_file) { - # Try to get at it in the cpan directory - $self->debug("no inst_file") if $CPAN::DEBUG; - my $cpan_file; - $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless - $cpan_file = $self->cpan_file; - if ($cpan_file eq "N/A") { - $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN. - Maybe stale symlink? Maybe removed during session? Giving up.\n"); - } - my $dist = $CPAN::META->instance('CPAN::Distribution', - $self->cpan_file); - $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG; - $dist->get; - $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG; - my($todir) = $CPAN::Config->{'cpan_home'}; - my(@me,$from,$to,$me); - @me = split /::/, $self->id; - $me[-1] .= ".pm"; - $me = File::Spec->catfile(@me); - $from = $self->find_bundle_file($dist->{build_dir},join('/',@me)); - $to = File::Spec->catfile($todir,$me); - File::Path::mkpath(File::Basename::dirname($to)); - File::Copy::copy($from, $to) - or Carp::confess("Couldn't copy $from to $to: $!"); - $inst_file = $to; - } - my @result; - my $fh = FileHandle->new; - local $/ = "\n"; - open($fh,$inst_file) or die "Could not open '$inst_file': $!"; - my $in_cont = 0; - $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG; - while (<$fh>) { - $in_cont = m/^=(?!head1\s+(?i-xsm:CONTENTS))/ ? 0 : - m/^=head1\s+(?i-xsm:CONTENTS)/ ? 1 : $in_cont; - next unless $in_cont; - next if /^=/; - s/\#.*//; - next if /^\s+$/; - chomp; - push @result, (split " ", $_, 2)[0]; - } - close $fh; - delete $self->{STATUS}; - $self->{CONTAINS} = \@result; - $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; - unless (@result) { - $CPAN::Frontend->mywarn(qq{ -The bundle file "$inst_file" may be a broken -bundlefile. It seems not to contain any bundle definition. -Please check the file and if it is bogus, please delete it. -Sorry for the inconvenience. -}); - } - @result; -} - -#-> sub CPAN::Bundle::find_bundle_file -# $where is in local format, $what is in unix format -sub find_bundle_file { - my($self,$where,$what) = @_; - $self->debug("where[$where]what[$what]") if $CPAN::DEBUG; -### The following two lines let CPAN.pm become Bundle/CPAN.pm :-( -### my $bu = File::Spec->catfile($where,$what); -### return $bu if -f $bu; - my $manifest = File::Spec->catfile($where,"MANIFEST"); - unless (-f $manifest) { - require ExtUtils::Manifest; - my $cwd = CPAN::anycwd(); - $self->safe_chdir($where); - ExtUtils::Manifest::mkmanifest(); - $self->safe_chdir($cwd); - } - my $fh = FileHandle->new($manifest) - or Carp::croak("Couldn't open $manifest: $!"); - local($/) = "\n"; - my $bundle_filename = $what; - $bundle_filename =~ s|Bundle.*/||; - my $bundle_unixpath; - while (<$fh>) { - next if /^\s*\#/; - my($file) = /(\S+)/; - if ($file =~ m|\Q$what\E$|) { - $bundle_unixpath = $file; - # return File::Spec->catfile($where,$bundle_unixpath); # bad - last; - } - # retry if she managed to have no Bundle directory - $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|; - } - return File::Spec->catfile($where, split /\//, $bundle_unixpath) - if $bundle_unixpath; - Carp::croak("Couldn't find a Bundle file in $where"); -} - -# needs to work quite differently from Module::inst_file because of -# cpan_home/Bundle/ directory and the possibility that we have -# shadowing effect. As it makes no sense to take the first in @INC for -# Bundles, we parse them all for $VERSION and take the newest. - -#-> sub CPAN::Bundle::inst_file ; -sub inst_file { - my($self) = @_; - my($inst_file); - my(@me); - @me = split /::/, $self->id; - $me[-1] .= ".pm"; - my($incdir,$bestv); - foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { - my $parsefile = File::Spec->catfile($incdir, @me); - CPAN->debug("parsefile[$parsefile]") if $CPAN::DEBUG; - next unless -f $parsefile; - my $have = eval { MM->parse_version($parsefile); }; - if ($@) { - $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n"); - } - if (!$bestv || CPAN::Version->vgt($have,$bestv)) { - $self->{INST_FILE} = $parsefile; - $self->{INST_VERSION} = $bestv = $have; - } - } - $self->{INST_FILE}; -} - -#-> sub CPAN::Bundle::inst_version ; -sub inst_version { - my($self) = @_; - $self->inst_file; # finds INST_VERSION as side effect - $self->{INST_VERSION}; -} - -#-> sub CPAN::Bundle::rematein ; -sub rematein { - my($self,$meth) = @_; - $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG; - my($id) = $self->id; - Carp::croak( "Can't $meth $id, don't have an associated bundle file. :-(\n" ) - unless $self->inst_file || $self->cpan_file; - my($s,%fail); - for $s ($self->contains) { - my($type) = $s =~ m|/| ? 'CPAN::Distribution' : - $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module'; - if ($type eq 'CPAN::Distribution') { - $CPAN::Frontend->mywarn(qq{ -The Bundle }.$self->id.qq{ contains -explicitly a file '$s'. -Going to $meth that. -}); - $CPAN::Frontend->mysleep(5); - } - # possibly noisy action: - $self->debug("type[$type] s[$s]") if $CPAN::DEBUG; - my $obj = $CPAN::META->instance($type,$s); - $obj->{reqtype} = $self->{reqtype}; - $obj->$meth(); - } -} - -# If a bundle contains another that contains an xs_file we have here, -# we just don't bother I suppose -#-> sub CPAN::Bundle::xs_file -sub xs_file { - return 0; -} - -#-> sub CPAN::Bundle::force ; -sub fforce { shift->rematein('fforce',@_); } -#-> sub CPAN::Bundle::force ; -sub force { shift->rematein('force',@_); } -#-> sub CPAN::Bundle::notest ; -sub notest { shift->rematein('notest',@_); } -#-> sub CPAN::Bundle::get ; -sub get { shift->rematein('get',@_); } -#-> sub CPAN::Bundle::make ; -sub make { shift->rematein('make',@_); } -#-> sub CPAN::Bundle::test ; -sub test { - my $self = shift; - # $self->{badtestcnt} ||= 0; - $self->rematein('test',@_); -} -#-> sub CPAN::Bundle::install ; -sub install { - my $self = shift; - $self->rematein('install',@_); -} -#-> sub CPAN::Bundle::clean ; -sub clean { shift->rematein('clean',@_); } - -#-> sub CPAN::Bundle::uptodate ; -sub uptodate { - my($self) = @_; - return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def - my $c; - foreach $c ($self->contains) { - my $obj = CPAN::Shell->expandany($c); - return 0 unless $obj->uptodate; - } - return 1; -} - -#-> sub CPAN::Bundle::readme ; -sub readme { - my($self) = @_; - my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{ -No File found for bundle } . $self->id . qq{\n}), return; - $self->debug("self[$self] file[$file]") if $CPAN::DEBUG; - $CPAN::META->instance('CPAN::Distribution',$file)->readme; -} - -1; diff --git a/lib/CPAN/CacheMgr.pm b/lib/CPAN/CacheMgr.pm deleted file mode 100644 index 827baeaefd..0000000000 --- a/lib/CPAN/CacheMgr.pm +++ /dev/null @@ -1,246 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::CacheMgr; -use strict; -use CPAN::InfoObj; -@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN); -use Cwd qw(chdir); -use File::Find; - -use vars qw( - $VERSION -); -$VERSION = "5.5"; - -package CPAN::CacheMgr; -use strict; - -#-> sub CPAN::CacheMgr::as_string ; -sub as_string { - eval { require Data::Dumper }; - if ($@) { - return shift->SUPER::as_string; - } else { - return Data::Dumper::Dumper(shift); - } -} - -#-> sub CPAN::CacheMgr::cachesize ; -sub cachesize { - shift->{DU}; -} - -#-> sub CPAN::CacheMgr::tidyup ; -sub tidyup { - my($self) = @_; - return unless $CPAN::META->{LOCK}; - return unless -d $self->{ID}; - my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}}; - for my $current (0..$#toremove) { - my $toremove = $toremove[$current]; - $CPAN::Frontend->myprint(sprintf( - "DEL(%d/%d): %s \n", - $current+1, - scalar @toremove, - $toremove, - ) - ); - return if $CPAN::Signal; - $self->_clean_cache($toremove); - return if $CPAN::Signal; - } -} - -#-> sub CPAN::CacheMgr::dir ; -sub dir { - shift->{ID}; -} - -#-> sub CPAN::CacheMgr::entries ; -sub entries { - my($self,$dir) = @_; - return unless defined $dir; - $self->debug("reading dir[$dir]") if $CPAN::DEBUG; - $dir ||= $self->{ID}; - my($cwd) = CPAN::anycwd(); - chdir $dir or Carp::croak("Can't chdir to $dir: $!"); - my $dh = DirHandle->new(File::Spec->curdir) - or Carp::croak("Couldn't opendir $dir: $!"); - my(@entries); - for ($dh->read) { - next if $_ eq "." || $_ eq ".."; - if (-f $_) { - push @entries, File::Spec->catfile($dir,$_); - } elsif (-d _) { - push @entries, File::Spec->catdir($dir,$_); - } else { - $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n"); - } - } - chdir $cwd or Carp::croak("Can't chdir to $cwd: $!"); - sort { -M $a <=> -M $b} @entries; -} - -#-> sub CPAN::CacheMgr::disk_usage ; -sub disk_usage { - my($self,$dir,$fast) = @_; - return if exists $self->{SIZE}{$dir}; - return if $CPAN::Signal; - my($Du) = 0; - if (-e $dir) { - if (-d $dir) { - unless (-x $dir) { - unless (chmod 0755, $dir) { - $CPAN::Frontend->mywarn("I have neither the -x permission nor the ". - "permission to change the permission; cannot ". - "estimate disk usage of '$dir'\n"); - $CPAN::Frontend->mysleep(5); - return; - } - } - } elsif (-f $dir) { - # nothing to say, no matter what the permissions - } - } else { - $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n"); - return; - } - if ($fast) { - $Du = 0; # placeholder - } else { - find( - sub { - $File::Find::prune++ if $CPAN::Signal; - return if -l $_; - if ($^O eq 'MacOS') { - require Mac::Files; - my $cat = Mac::Files::FSpGetCatInfo($_); - $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat; - } else { - if (-d _) { - unless (-x _) { - unless (chmod 0755, $_) { - $CPAN::Frontend->mywarn("I have neither the -x permission nor ". - "the permission to change the permission; ". - "can only partially estimate disk usage ". - "of '$_'\n"); - $CPAN::Frontend->mysleep(5); - return; - } - } - } else { - $Du += (-s _); - } - } - }, - $dir - ); - } - return if $CPAN::Signal; - $self->{SIZE}{$dir} = $Du/1024/1024; - unshift @{$self->{FIFO}}, $dir; - $self->debug("measured $dir is $Du") if $CPAN::DEBUG; - $self->{DU} += $Du/1024/1024; - $self->{DU}; -} - -#-> sub CPAN::CacheMgr::_clean_cache ; -sub _clean_cache { - my($self,$dir) = @_; - return unless -e $dir; - unless (File::Spec->canonpath(File::Basename::dirname($dir)) - eq File::Spec->canonpath($CPAN::Config->{build_dir})) { - $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ". - "will not remove\n"); - $CPAN::Frontend->mysleep(5); - return; - } - $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") - if $CPAN::DEBUG; - File::Path::rmtree($dir); - my $id_deleted = 0; - if ($dir !~ /\.yml$/ && -f "$dir.yml") { - my $yaml_module = CPAN::_yaml_module(); - if ($CPAN::META->has_inst($yaml_module)) { - my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); }; - if ($@) { - $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)"); - unlink "$dir.yml" or - $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)"); - return; - } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) { - $CPAN::META->delete("CPAN::Distribution", $id); - - # XXX we should restore the state NOW, otherise this - # distro does not exist until we read an index. BUG ALERT(?) - - # $CPAN::Frontend->mywarn (" +++\n"); - $id_deleted++; - } - } - unlink "$dir.yml"; # may fail - unless ($id_deleted) { - CPAN->debug("no distro found associated with '$dir'"); - } - } - $self->{DU} -= $self->{SIZE}{$dir}; - delete $self->{SIZE}{$dir}; -} - -#-> sub CPAN::CacheMgr::new ; -sub new { - my $class = shift; - my $time = time; - my($debug,$t2); - $debug = ""; - my $self = { - ID => $CPAN::Config->{build_dir}, - MAX => $CPAN::Config->{'build_cache'}, - SCAN => $CPAN::Config->{'scan_cache'} || 'atstart', - DU => 0 - }; - File::Path::mkpath($self->{ID}); - my $dh = DirHandle->new($self->{ID}); - bless $self, $class; - $self->scan_cache; - $t2 = time; - $debug .= "timing of CacheMgr->new: ".($t2 - $time); - $time = $t2; - CPAN->debug($debug) if $CPAN::DEBUG; - $self; -} - -#-> sub CPAN::CacheMgr::scan_cache ; -sub scan_cache { - my $self = shift; - return if $self->{SCAN} eq 'never'; - $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}") - unless $self->{SCAN} eq 'atstart'; - return unless $CPAN::META->{LOCK}; - $CPAN::Frontend->myprint( - sprintf("Scanning cache %s for sizes\n", - $self->{ID})); - my $e; - my @entries = $self->entries($self->{ID}); - my $i = 0; - my $painted = 0; - for $e (@entries) { - my $symbol = "."; - if ($self->{DU} > $self->{MAX}) { - $symbol = "-"; - $self->disk_usage($e,1); - } else { - $self->disk_usage($e); - } - $i++; - while (($painted/76) < ($i/@entries)) { - $CPAN::Frontend->myprint($symbol); - $painted++; - } - return if $CPAN::Signal; - } - $CPAN::Frontend->myprint("DONE\n"); - $self->tidyup; -} - -1; diff --git a/lib/CPAN/Complete.pm b/lib/CPAN/Complete.pm deleted file mode 100644 index e1fe896d4a..0000000000 --- a/lib/CPAN/Complete.pm +++ /dev/null @@ -1,175 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::Complete; -use strict; -@CPAN::Complete::ISA = qw(CPAN::Debug); -# Q: where is the "How do I add a new command" HOWTO? -# A: svn diff -r 1048:1049 where andk added the report command -@CPAN::Complete::COMMANDS = sort qw( - ? ! a b d h i m o q r u - autobundle - bye - clean - cvs_import - dump - exit - failed - force - fforce - hosts - install - install_tested - is_tested - look - ls - make - mkmyconfig - notest - perldoc - quit - readme - recent - recompile - reload - report - reports - scripts - smoke - test - upgrade -); - -use vars qw( - $VERSION -); -$VERSION = "5.5"; - -package CPAN::Complete; -use strict; - -sub gnu_cpl { - my($text, $line, $start, $end) = @_; - my(@perlret) = cpl($text, $line, $start); - # find longest common match. Can anybody show me how to peruse - # T::R::Gnu to have this done automatically? Seems expensive. - return () unless @perlret; - my($newtext) = $text; - for (my $i = length($text)+1;;$i++) { - last unless length($perlret[0]) && length($perlret[0]) >= $i; - my $try = substr($perlret[0],0,$i); - my @tries = grep {substr($_,0,$i) eq $try} @perlret; - # warn "try[$try]tries[@tries]"; - if (@tries == @perlret) { - $newtext = $try; - } else { - last; - } - } - ($newtext,@perlret); -} - -#-> sub CPAN::Complete::cpl ; -sub cpl { - my($word,$line,$pos) = @_; - $word ||= ""; - $line ||= ""; - $pos ||= 0; - CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG; - $line =~ s/^\s*//; - if ($line =~ s/^((?:notest|f?force)\s*)//) { - $pos -= length($1); - } - my @return; - if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) { - @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS; - } elsif ( $line !~ /^[\!abcdghimorutl]/ ) { - @return = (); - } elsif ($line =~ /^a\s/) { - @return = cplx('CPAN::Author',uc($word)); - } elsif ($line =~ /^ls\s/) { - my($author,$rest) = $word =~ m|([^/]+)/?(.*)|; - @return = $rest ? () : map {"$_/"} cplx('CPAN::Author',uc($author||"")); - if (0 && 1==@return) { # XXX too slow and even wrong when there is a * already - @return = grep /^\Q$word\E/, map {"$author/$_->[2]"} CPAN::Shell->expand("Author",$author)->ls("$rest*","2"); - } - } elsif ($line =~ /^b\s/) { - CPAN::Shell->local_bundles; - @return = cplx('CPAN::Bundle',$word); - } elsif ($line =~ /^d\s/) { - @return = cplx('CPAN::Distribution',$word); - } elsif ($line =~ m/^( - [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent - )\s/x ) { - if ($word =~ /^Bundle::/) { - CPAN::Shell->local_bundles; - } - @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); - } elsif ($line =~ /^i\s/) { - @return = cpl_any($word); - } elsif ($line =~ /^reload\s/) { - @return = cpl_reload($word,$line,$pos); - } elsif ($line =~ /^o\s/) { - @return = cpl_option($word,$line,$pos); - } elsif ($line =~ m/^\S+\s/ ) { - # fallback for future commands and what we have forgotten above - @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); - } else { - @return = (); - } - return @return; -} - -#-> sub CPAN::Complete::cplx ; -sub cplx { - my($class, $word) = @_; - if (CPAN::_sqlite_running()) { - $CPAN::SQLite->search($class, "^\Q$word\E"); - } - my $method = "id"; - $method = "pretty_id" if $class eq "CPAN::Distribution"; - sort grep /^\Q$word\E/, map { $_->$method() } $CPAN::META->all_objects($class); -} - -#-> sub CPAN::Complete::cpl_any ; -sub cpl_any { - my($word) = shift; - return ( - cplx('CPAN::Author',$word), - cplx('CPAN::Bundle',$word), - cplx('CPAN::Distribution',$word), - cplx('CPAN::Module',$word), - ); -} - -#-> sub CPAN::Complete::cpl_reload ; -sub cpl_reload { - my($word,$line,$pos) = @_; - $word ||= ""; - my(@words) = split " ", $line; - CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; - my(@ok) = qw(cpan index); - return @ok if @words == 1; - return grep /^\Q$word\E/, @ok if @words == 2 && $word; -} - -#-> sub CPAN::Complete::cpl_option ; -sub cpl_option { - my($word,$line,$pos) = @_; - $word ||= ""; - my(@words) = split " ", $line; - CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; - my(@ok) = qw(conf debug); - return @ok if @words == 1; - return grep /^\Q$word\E/, @ok if @words == 2 && length($word); - if (0) { - } elsif ($words[1] eq 'index') { - return (); - } elsif ($words[1] eq 'conf') { - return CPAN::HandleConfig::cpl(@_); - } elsif ($words[1] eq 'debug') { - return sort grep /^\Q$word\E/i, - sort keys %CPAN::DEBUG, 'all'; - } -} - -1; diff --git a/lib/CPAN/Debug.pm b/lib/CPAN/Debug.pm deleted file mode 100644 index 926b0d79b4..0000000000 --- a/lib/CPAN/Debug.pm +++ /dev/null @@ -1,79 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -package CPAN::Debug; -use strict; -use vars qw($VERSION); - -$VERSION = "5.5"; -# module is internal to CPAN.pm - -%CPAN::DEBUG = qw[ - CPAN 1 - Index 2 - InfoObj 4 - Author 8 - Distribution 16 - Bundle 32 - Module 64 - CacheMgr 128 - Complete 256 - FTP 512 - Shell 1024 - Eval 2048 - HandleConfig 4096 - Tarzip 8192 - Version 16384 - Queue 32768 - FirstTime 65536 -]; - -$CPAN::DEBUG ||= 0; - -#-> sub CPAN::Debug::debug ; -sub debug { - my($self,$arg) = @_; - - my @caller; - my $i = 0; - while () { - my(@c) = (caller($i))[0 .. ($i ? 3 : 2)]; - last unless defined $c[0]; - push @caller, \@c; - for (0,3) { - last if $_ > $#c; - $c[$_] =~ s/.*:://; - } - for (1) { - $c[$_] =~ s|.*/||; - } - last if ++$i>=3; - } - pop @caller; - if ($CPAN::DEBUG{$caller[0][0]} & $CPAN::DEBUG) { - if ($arg and ref $arg) { - eval { require Data::Dumper }; - if ($@) { - $CPAN::Frontend->myprint($arg->as_string); - } else { - $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg)); - } - } else { - my $outer = ""; - local $" = ","; - if (@caller>1) { - $outer = ",[@{$caller[1]}]"; - } - $CPAN::Frontend->myprint("Debug(@{$caller[0]}$outer): $arg\n"); - } - } -} - -1; - -__END__ - -=head1 LICENSE - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/lib/CPAN/DeferredCode.pm b/lib/CPAN/DeferredCode.pm deleted file mode 100644 index 0db37a6485..0000000000 --- a/lib/CPAN/DeferredCode.pm +++ /dev/null @@ -1,16 +0,0 @@ -package CPAN::DeferredCode; - -use strict; -use vars qw/$VERSION/; - -use overload fallback => 1, map { ($_ => 'run') } qw/ - bool "" 0+ -/; - -$VERSION = "5.50"; - -sub run { - $_[0]->(); -} - -1; diff --git a/lib/CPAN/Distribution.pm b/lib/CPAN/Distribution.pm deleted file mode 100644 index 45192bdb9d..0000000000 --- a/lib/CPAN/Distribution.pm +++ /dev/null @@ -1,3840 +0,0 @@ -package CPAN::Distribution; -use strict; -use Cwd qw(chdir); -use CPAN::Distroprefs; -use CPAN::InfoObj; -@CPAN::Distribution::ISA = qw(CPAN::InfoObj); -use vars qw($VERSION); -$VERSION = "1.93"; - -# Accessors -sub cpan_comment { - my $self = shift; - my $ro = $self->ro or return; - $ro->{CPAN_COMMENT} -} - -#-> CPAN::Distribution::undelay -sub undelay { - my $self = shift; - for my $delayer ( - "configure_requires_later", - "configure_requires_later_for", - "later", - "later_for", - ) { - delete $self->{$delayer}; - } -} - -#-> CPAN::Distribution::is_dot_dist -sub is_dot_dist { - my($self) = @_; - return substr($self->id,-1,1) eq "."; -} - -# add the A/AN/ stuff -#-> CPAN::Distribution::normalize -sub normalize { - my($self,$s) = @_; - $s = $self->id unless defined $s; - if (substr($s,-1,1) eq ".") { - # using a global because we are sometimes called as static method - if (!$CPAN::META->{LOCK} - && !$CPAN::Have_warned->{"$s is unlocked"}++ - ) { - $CPAN::Frontend->mywarn("You are visiting the local directory - '$s' - without lock, take care that concurrent processes do not do likewise.\n"); - $CPAN::Frontend->mysleep(1); - } - if ($s eq ".") { - $s = "$CPAN::iCwd/."; - } elsif (File::Spec->file_name_is_absolute($s)) { - } elsif (File::Spec->can("rel2abs")) { - $s = File::Spec->rel2abs($s); - } else { - $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec"); - } - CPAN->debug("s[$s]") if $CPAN::DEBUG; - unless ($CPAN::META->exists("CPAN::Distribution", $s)) { - for ($CPAN::META->instance("CPAN::Distribution", $s)) { - $_->{build_dir} = $s; - $_->{archived} = "local_directory"; - $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory"); - } - } - } elsif ( - $s =~ tr|/|| == 1 - or - $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/| - ) { - return $s if $s =~ m:^N/A|^Contact Author: ; - $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4|; - CPAN->debug("s[$s]") if $CPAN::DEBUG; - } - $s; -} - -#-> sub CPAN::Distribution::author ; -sub author { - my($self) = @_; - my($authorid); - if (substr($self->id,-1,1) eq ".") { - $authorid = "LOCAL"; - } else { - ($authorid) = $self->pretty_id =~ /^([\w\-]+)/; - } - CPAN::Shell->expand("Author",$authorid); -} - -# tries to get the yaml from CPAN instead of the distro itself: -# EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels -sub fast_yaml { - my($self) = @_; - my $meta = $self->pretty_id; - $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/; - my(@ls) = CPAN::Shell->globls($meta); - my $norm = $self->normalize($meta); - - my($local_file); - my($local_wanted) = - File::Spec->catfile( - $CPAN::Config->{keep_source_where}, - "authors", - "id", - split(/\//,$norm) - ); - $self->debug("Doing localize") if $CPAN::DEBUG; - unless ($local_file = - CPAN::FTP->localize("authors/id/$norm", - $local_wanted)) { - $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n"); - } - my $yaml = CPAN->_yaml_loadfile($local_file)->[0]; -} - -#-> sub CPAN::Distribution::cpan_userid -sub cpan_userid { - my $self = shift; - if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) { - return $1; - } - return $self->SUPER::cpan_userid; -} - -#-> sub CPAN::Distribution::pretty_id -sub pretty_id { - my $self = shift; - my $id = $self->id; - return $id unless $id =~ m|^./../|; - substr($id,5); -} - -#-> sub CPAN::Distribution::base_id -sub base_id { - my $self = shift; - my $id = $self->pretty_id(); - my $base_id = File::Basename::basename($id); - $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; - return $base_id; -} - -#-> sub CPAN::Distribution::tested_ok_but_not_installed -sub tested_ok_but_not_installed { - my $self = shift; - return ( - $self->{make_test} - && $self->{build_dir} - && (UNIVERSAL::can($self->{make_test},"failed") ? - ! $self->{make_test}->failed : - $self->{make_test} =~ /^YES/ - ) - && ( - !$self->{install} - || - $self->{install}->failed - ) - ); -} - - -# mark as dirty/clean for the sake of recursion detection. $color=1 -# means "in use", $color=0 means "not in use anymore". $color=2 means -# we have determined prereqs now and thus insist on passing this -# through (at least) once again. - -#-> sub CPAN::Distribution::color_cmd_tmps ; -sub color_cmd_tmps { - my($self) = shift; - my($depth) = shift || 0; - my($color) = shift || 0; - my($ancestors) = shift || []; - # a distribution needs to recurse into its prereq_pms - - return if exists $self->{incommandcolor} - && $color==1 - && $self->{incommandcolor}==$color; - if ($depth>=$CPAN::MAX_RECURSION) { - die(CPAN::Exception::RecursiveDependency->new($ancestors)); - } - # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; - my $prereq_pm = $self->prereq_pm; - if (defined $prereq_pm) { - PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}}, - keys %{$prereq_pm->{build_requires}||{}}) { - next PREREQ if $pre eq "perl"; - my $premo; - unless ($premo = CPAN::Shell->expand("Module",$pre)) { - $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n"); - $CPAN::Frontend->mysleep(2); - next PREREQ; - } - $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); - } - } - if ($color==0) { - delete $self->{sponsored_mods}; - - # as we are at the end of a command, we'll give up this - # reminder of a broken test. Other commands may test this guy - # again. Maybe 'badtestcnt' should be renamed to - # 'make_test_failed_within_command'? - delete $self->{badtestcnt}; - } - $self->{incommandcolor} = $color; -} - -#-> sub CPAN::Distribution::as_string ; -sub as_string { - my $self = shift; - $self->containsmods; - $self->upload_date; - $self->SUPER::as_string(@_); -} - -#-> sub CPAN::Distribution::containsmods ; -sub containsmods { - my $self = shift; - return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS}; - my $dist_id = $self->{ID}; - for my $mod ($CPAN::META->all_objects("CPAN::Module")) { - my $mod_file = $mod->cpan_file or next; - my $mod_id = $mod->{ID} or next; - # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]"; - # sleep 1; - if ($CPAN::Signal) { - delete $self->{CONTAINSMODS}; - return; - } - $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id; - } - keys %{$self->{CONTAINSMODS}||={}}; -} - -#-> sub CPAN::Distribution::upload_date ; -sub upload_date { - my $self = shift; - return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE}; - my(@local_wanted) = split(/\//,$self->id); - my $filename = pop @local_wanted; - push @local_wanted, "CHECKSUMS"; - my $author = CPAN::Shell->expand("Author",$self->cpan_userid); - return unless $author; - my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date}); - return unless @dl; - my($dirent) = grep { $_->[2] eq $filename } @dl; - # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id; - return unless $dirent->[1]; - return $self->{UPLOAD_DATE} = $dirent->[1]; -} - -#-> sub CPAN::Distribution::uptodate ; -sub uptodate { - my($self) = @_; - my $c; - foreach $c ($self->containsmods) { - my $obj = CPAN::Shell->expandany($c); - unless ($obj->uptodate) { - my $id = $self->pretty_id; - $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG; - return 0; - } - } - return 1; -} - -#-> sub CPAN::Distribution::called_for ; -sub called_for { - my($self,$id) = @_; - $self->{CALLED_FOR} = $id if defined $id; - return $self->{CALLED_FOR}; -} - -#-> sub CPAN::Distribution::get ; -sub get { - my($self) = @_; - $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG; - if (my $goto = $self->prefs->{goto}) { - $CPAN::Frontend->mywarn - (sprintf( - "delegating to '%s' as specified in prefs file '%s' doc %d\n", - $goto, - $self->{prefs_file}, - $self->{prefs_file_doc}, - )); - return $self->goto($goto); - } - local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) - ? $ENV{PERL5LIB} - : ($ENV{PERLLIB} || ""); - local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; - $CPAN::META->set_perl5lib; - local $ENV{MAKEFLAGS}; # protect us from outer make calls - - EXCUSE: { - my @e; - my $goodbye_message; - $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG; - if ($self->prefs->{disabled} && ! $self->{force_update}) { - my $why = sprintf( - "Disabled via prefs file '%s' doc %d", - $self->{prefs_file}, - $self->{prefs_file_doc}, - ); - push @e, $why; - $self->{unwrapped} = CPAN::Distrostatus->new("NO $why"); - $goodbye_message = "[disabled] -- NA $why"; - # note: not intended to be persistent but at least visible - # during this session - } else { - if (exists $self->{build_dir} && -d $self->{build_dir} - && ($self->{modulebuild}||$self->{writemakefile}) - ) { - # this deserves print, not warn: - $CPAN::Frontend->myprint(" Has already been unwrapped into directory ". - "$self->{build_dir}\n" - ); - return 1; - } - - # although we talk about 'force' we shall not test on - # force directly. New model of force tries to refrain from - # direct checking of force. - exists $self->{unwrapped} and ( - UNIVERSAL::can($self->{unwrapped},"failed") ? - $self->{unwrapped}->failed : - $self->{unwrapped} =~ /^NO/ - ) - and push @e, "Unwrapping had some problem, won't try again without force"; - } - if (@e) { - $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e); - if ($goodbye_message) { - $self->goodbye($goodbye_message); - } - return; - } - } - my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible - - my($local_file); - unless ($self->{build_dir} && -d $self->{build_dir}) { - $self->get_file_onto_local_disk; - return if $CPAN::Signal; - $self->check_integrity; - return if $CPAN::Signal; - (my $packagedir,$local_file) = $self->run_preps_on_packagedir; - if (exists $self->{writemakefile} && ref $self->{writemakefile} - && $self->{writemakefile}->can("failed") && - $self->{writemakefile}->failed) { - return; - } - $packagedir ||= $self->{build_dir}; - $self->{build_dir} = $packagedir; - } - - if ($CPAN::Signal) { - $self->safe_chdir($sub_wd); - return; - } - return $self->choose_MM_or_MB($local_file); -} - -#-> CPAN::Distribution::get_file_onto_local_disk -sub get_file_onto_local_disk { - my($self) = @_; - - return if $self->is_dot_dist; - my($local_file); - my($local_wanted) = - File::Spec->catfile( - $CPAN::Config->{keep_source_where}, - "authors", - "id", - split(/\//,$self->id) - ); - - $self->debug("Doing localize") if $CPAN::DEBUG; - unless ($local_file = - CPAN::FTP->localize("authors/id/$self->{ID}", - $local_wanted)) { - my $note = ""; - if ($CPAN::Index::DATE_OF_02) { - $note = "Note: Current database in memory was generated ". - "on $CPAN::Index::DATE_OF_02\n"; - } - $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note"); - } - - $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG; - $self->{localfile} = $local_file; -} - - -#-> CPAN::Distribution::check_integrity -sub check_integrity { - my($self) = @_; - - return if $self->is_dot_dist; - if ($CPAN::META->has_inst("Digest::SHA")) { - $self->debug("Digest::SHA is installed, verifying"); - $self->verifyCHECKSUM; - } else { - $self->debug("Digest::SHA is NOT installed"); - } -} - -#-> CPAN::Distribution::run_preps_on_packagedir -sub run_preps_on_packagedir { - my($self) = @_; - return if $self->is_dot_dist; - - $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok - my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok - $self->safe_chdir($builddir); - $self->debug("Removing tmp-$$") if $CPAN::DEBUG; - File::Path::rmtree("tmp-$$"); - unless (mkdir "tmp-$$", 0755) { - $CPAN::Frontend->unrecoverable_error(<<EOF); -Couldn't mkdir '$builddir/tmp-$$': $! - -Cannot continue: Please find the reason why I cannot make the -directory -$builddir/tmp-$$ -and fix the problem, then retry. - -EOF - } - if ($CPAN::Signal) { - return; - } - $self->safe_chdir("tmp-$$"); - - # - # Unpack the goods - # - my $local_file = $self->{localfile}; - my $ct = eval{CPAN::Tarzip->new($local_file)}; - unless ($ct) { - $self->{unwrapped} = CPAN::Distrostatus->new("NO"); - delete $self->{build_dir}; - return; - } - if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) { - $self->{was_uncompressed}++ unless eval{$ct->gtest()}; - $self->untar_me($ct); - } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) { - $self->unzip_me($ct); - } else { - $self->{was_uncompressed}++ unless $ct->gtest(); - $local_file = $self->handle_singlefile($local_file); - } - - # we are still in the tmp directory! - # Let's check if the package has its own directory. - my $dh = DirHandle->new(File::Spec->curdir) - or Carp::croak("Couldn't opendir .: $!"); - my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC?? - if (grep { $_ eq "pax_global_header" } @readdir) { - $CPAN::Frontend->mywarn("Your (un)tar seems to have extracted a file named 'pax_global_header' -from the tarball '$local_file'. -This is almost certainly an error. Please upgrade your tar. -I'll ignore this file for now. -See also http://rt.cpan.org/Ticket/Display.html?id=38932\n"); - $CPAN::Frontend->mysleep(5); - @readdir = grep { $_ ne "pax_global_header" } @readdir; - } - $dh->close; - my ($packagedir); - # XXX here we want in each branch File::Temp to protect all build_dir directories - if (CPAN->has_usable("File::Temp")) { - my $tdir_base; - my $from_dir; - my @dirents; - if (@readdir == 1 && -d $readdir[0]) { - $tdir_base = $readdir[0]; - $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]); - my $dh2; - unless ($dh2 = DirHandle->new($from_dir)) { - my($mode) = (stat $from_dir)[2]; - my $why = sprintf - ( - "Couldn't opendir '%s', mode '%o': %s", - $from_dir, - $mode, - $!, - ); - $CPAN::Frontend->mywarn("$why\n"); - $self->{writemakefile} = CPAN::Distrostatus->new("NO -- $why"); - return; - } - @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC?? - } else { - my $userid = $self->cpan_userid; - CPAN->debug("userid[$userid]"); - if (!$userid or $userid eq "N/A") { - $userid = "anon"; - } - $tdir_base = $userid; - $from_dir = File::Spec->curdir; - @dirents = @readdir; - } - $packagedir = File::Temp::tempdir( - "$tdir_base-XXXXXX", - DIR => $builddir, - CLEANUP => 0, - ); - chmod 0777 &~ umask, $packagedir; # may fail - my $f; - for $f (@dirents) { # is already without "." and ".." - my $from = File::Spec->catdir($from_dir,$f); - my $to = File::Spec->catdir($packagedir,$f); - unless (File::Copy::move($from,$to)) { - my $err = $!; - $from = File::Spec->rel2abs($from); - Carp::confess("Couldn't move $from to $to: $err"); - } - } - } else { # older code below, still better than nothing when there is no File::Temp - my($distdir); - if (@readdir == 1 && -d $readdir[0]) { - $distdir = $readdir[0]; - $packagedir = File::Spec->catdir($builddir,$distdir); - $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]") - if $CPAN::DEBUG; - -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ". - "$packagedir\n"); - File::Path::rmtree($packagedir); - unless (File::Copy::move($distdir,$packagedir)) { - $CPAN::Frontend->unrecoverable_error(<<EOF); -Couldn't move '$distdir' to '$packagedir': $! - -Cannot continue: Please find the reason why I cannot move -$builddir/tmp-$$/$distdir -to -$packagedir -and fix the problem, then retry - -EOF - } - $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]", - $distdir, - $packagedir, - -e $packagedir, - -d $packagedir, - )) if $CPAN::DEBUG; - } else { - my $userid = $self->cpan_userid; - CPAN->debug("userid[$userid]") if $CPAN::DEBUG; - if (!$userid or $userid eq "N/A") { - $userid = "anon"; - } - my $pragmatic_dir = $userid . '000'; - $pragmatic_dir =~ s/\W_//g; - $pragmatic_dir++ while -d "../$pragmatic_dir"; - $packagedir = File::Spec->catdir($builddir,$pragmatic_dir); - $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG; - File::Path::mkpath($packagedir); - my($f); - for $f (@readdir) { # is already without "." and ".." - my $to = File::Spec->catdir($packagedir,$f); - File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!"); - } - } - } - $self->{build_dir} = $packagedir; - $self->safe_chdir($builddir); - File::Path::rmtree("tmp-$$"); - - $self->safe_chdir($packagedir); - $self->_signature_business(); - $self->safe_chdir($builddir); - - return($packagedir,$local_file); -} - -#-> sub CPAN::Distribution::parse_meta_yml ; -sub parse_meta_yml { - my($self) = @_; - my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir"; - my $yaml = File::Spec->catfile($build_dir,"META.yml"); - $self->debug("yaml[$yaml]") if $CPAN::DEBUG; - return unless -f $yaml; - my $early_yaml; - eval { - require Parse::CPAN::Meta; - $early_yaml = Parse::CPAN::Meta::LoadFile($yaml)->[0]; - }; - unless ($early_yaml) { - eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; }; - } - unless ($early_yaml) { - return; - } - return $early_yaml; -} - -#-> sub CPAN::Distribution::satisfy_requires ; -sub satisfy_requires { - my ($self) = @_; - if (my @prereq = $self->unsat_prereq("later")) { - if ($prereq[0][0] eq "perl") { - my $need = "requires perl '$prereq[0][1]'"; - my $id = $self->pretty_id; - $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n"); - $self->{make} = CPAN::Distrostatus->new("NO $need"); - $self->store_persistent_state; - die "[prereq] -- NOT OK\n"; - } else { - my $follow = eval { $self->follow_prereqs("later",@prereq); }; - if (0) { - } elsif ($follow) { - # signal success to the queuerunner - return 1; - } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) { - $CPAN::Frontend->mywarn($@); - die "[depend] -- NOT OK\n"; - } - } - } -} - -#-> sub CPAN::Distribution::satisfy_configure_requires ; -sub satisfy_configure_requires { - my($self) = @_; - my $enable_configure_requires = 1; - if (!$enable_configure_requires) { - return 1; - # if we return 1 here, everything is as before we introduced - # configure_requires that means, things with - # configure_requires simply fail, all others succeed - } - my @prereq = $self->unsat_prereq("configure_requires_later") or return 1; - if ($self->{configure_requires_later}) { - for my $k (keys %{$self->{configure_requires_later_for}||{}}) { - if ($self->{configure_requires_later_for}{$k}>1) { - # we must not come here a second time - $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate..."); - require YAML::Syck; - $CPAN::Frontend->mydie - ( - YAML::Syck::Dump - ({self=>$self, prereq=>\@prereq}) - ); - } - } - } - if ($prereq[0][0] eq "perl") { - my $need = "requires perl '$prereq[0][1]'"; - my $id = $self->pretty_id; - $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n"); - $self->{make} = CPAN::Distrostatus->new("NO $need"); - $self->store_persistent_state; - return $self->goodbye("[prereq] -- NOT OK"); - } else { - my $follow = eval { - $self->follow_prereqs("configure_requires_later", @prereq); - }; - if (0) { - } elsif ($follow) { - return; - } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) { - $CPAN::Frontend->mywarn($@); - return $self->goodbye("[depend] -- NOT OK"); - } - } - die "never reached"; -} - -#-> sub CPAN::Distribution::choose_MM_or_MB ; -sub choose_MM_or_MB { - my($self,$local_file) = @_; - $self->satisfy_configure_requires() or return; - my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL"); - my($mpl_exists) = -f $mpl; - unless ($mpl_exists) { - # NFS has been reported to have racing problems after the - # renaming of a directory in some environments. - # This trick helps. - $CPAN::Frontend->mysleep(1); - my $mpldh = DirHandle->new($self->{build_dir}) - or Carp::croak("Couldn't opendir $self->{build_dir}: $!"); - $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read; - $mpldh->close; - } - my $prefer_installer = "eumm"; # eumm|mb - if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) { - if ($mpl_exists) { # they *can* choose - if ($CPAN::META->has_inst("Module::Build")) { - $prefer_installer = CPAN::HandleConfig->prefs_lookup($self, - q{prefer_installer}); - } - } else { - $prefer_installer = "mb"; - } - } - return unless $self->patch; - if (lc($prefer_installer) eq "rand") { - $prefer_installer = rand()<.5 ? "eumm" : "mb"; - } - if (lc($prefer_installer) eq "mb") { - $self->{modulebuild} = 1; - } elsif ($self->{archived} eq "patch") { - # not an edge case, nothing to install for sure - my $why = "A patch file cannot be installed"; - $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n"); - $self->{writemakefile} = CPAN::Distrostatus->new("NO $why"); - } elsif (! $mpl_exists) { - $self->_edge_cases($mpl,$local_file); - } - if ($self->{build_dir} - && - $CPAN::Config->{build_dir_reuse} - ) { - $self->store_persistent_state; - } - return $self; -} - -#-> CPAN::Distribution::store_persistent_state -sub store_persistent_state { - my($self) = @_; - my $dir = $self->{build_dir}; - unless (File::Spec->canonpath(File::Basename::dirname($dir)) - eq File::Spec->canonpath($CPAN::Config->{build_dir})) { - $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ". - "will not store persistent state\n"); - return; - } - my $file = sprintf "%s.yml", $dir; - my $yaml_module = CPAN::_yaml_module(); - if ($CPAN::META->has_inst($yaml_module)) { - CPAN->_yaml_dumpfile( - $file, - { - time => time, - perl => CPAN::_perl_fingerprint(), - distribution => $self, - } - ); - } else { - $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ". - "will not store persistent state\n"); - } -} - -#-> CPAN::Distribution::try_download -sub try_download { - my($self,$patch) = @_; - my $norm = $self->normalize($patch); - my($local_wanted) = - File::Spec->catfile( - $CPAN::Config->{keep_source_where}, - "authors", - "id", - split(/\//,$norm), - ); - $self->debug("Doing localize") if $CPAN::DEBUG; - return CPAN::FTP->localize("authors/id/$norm", - $local_wanted); -} - -{ - my $stdpatchargs = ""; - #-> CPAN::Distribution::patch - sub patch { - my($self) = @_; - $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG; - my $patches = $self->prefs->{patches}; - $patches ||= ""; - $self->debug("patches[$patches]") if $CPAN::DEBUG; - if ($patches) { - return unless @$patches; - $self->safe_chdir($self->{build_dir}); - CPAN->debug("patches[$patches]") if $CPAN::DEBUG; - my $patchbin = $CPAN::Config->{patch}; - unless ($patchbin && length $patchbin) { - $CPAN::Frontend->mydie("No external patch command configured\n\n". - "Please run 'o conf init /patch/'\n\n"); - } - unless (MM->maybe_command($patchbin)) { - $CPAN::Frontend->mydie("No external patch command available\n\n". - "Please run 'o conf init /patch/'\n\n"); - } - $patchbin = CPAN::HandleConfig->safe_quote($patchbin); - local $ENV{PATCH_GET} = 0; # formerly known as -g0 - unless ($stdpatchargs) { - my $system = "$patchbin --version |"; - local *FH; - open FH, $system or die "Could not fork '$system': $!"; - local $/ = "\n"; - my $pversion; - PARSEVERSION: while (<FH>) { - if (/^patch\s+([\d\.]+)/) { - $pversion = $1; - last PARSEVERSION; - } - } - if ($pversion) { - $stdpatchargs = "-N --fuzz=3"; - } else { - $stdpatchargs = "-N"; - } - } - my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches"); - $CPAN::Frontend->myprint("Going to apply $countedpatches:\n"); - my $patches_dir = $CPAN::Config->{patches_dir}; - for my $patch (@$patches) { - if ($patches_dir && !File::Spec->file_name_is_absolute($patch)) { - my $f = File::Spec->catfile($patches_dir, $patch); - $patch = $f if -f $f; - } - unless (-f $patch) { - if (my $trydl = $self->try_download($patch)) { - $patch = $trydl; - } else { - my $fail = "Could not find patch '$patch'"; - $CPAN::Frontend->mywarn("$fail; cannot continue\n"); - $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail"); - delete $self->{build_dir}; - return; - } - } - $CPAN::Frontend->myprint(" $patch\n"); - my $readfh = CPAN::Tarzip->TIEHANDLE($patch); - - my $pcommand; - my $ppp = $self->_patch_p_parameter($readfh); - if ($ppp eq "applypatch") { - $pcommand = "$CPAN::Config->{applypatch} -verbose"; - } else { - my $thispatchargs = join " ", $stdpatchargs, $ppp; - $pcommand = "$patchbin $thispatchargs"; - } - - $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again - my $writefh = FileHandle->new; - $CPAN::Frontend->myprint(" $pcommand\n"); - unless (open $writefh, "|$pcommand") { - my $fail = "Could not fork '$pcommand'"; - $CPAN::Frontend->mywarn("$fail; cannot continue\n"); - $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail"); - delete $self->{build_dir}; - return; - } - binmode($writefh); - while (my $x = $readfh->READLINE) { - print $writefh $x; - } - unless (close $writefh) { - my $fail = "Could not apply patch '$patch'"; - $CPAN::Frontend->mywarn("$fail; cannot continue\n"); - $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail"); - delete $self->{build_dir}; - return; - } - } - $self->{patched}++; - } - return 1; - } -} - -sub _patch_p_parameter { - my($self,$fh) = @_; - my $cnt_files = 0; - my $cnt_p0files = 0; - local($_); - while ($_ = $fh->READLINE) { - if ( - $CPAN::Config->{applypatch} - && - /\#\#\#\# ApplyPatch data follows \#\#\#\#/ - ) { - return "applypatch" - } - next unless /^[\*\+]{3}\s(\S+)/; - my $file = $1; - $cnt_files++; - $cnt_p0files++ if -f $file; - CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]") - if $CPAN::DEBUG; - } - return "-p1" unless $cnt_files; - return $cnt_files==$cnt_p0files ? "-p0" : "-p1"; -} - -#-> sub CPAN::Distribution::_edge_cases -# with "configure" or "Makefile" or single file scripts -sub _edge_cases { - my($self,$mpl,$local_file) = @_; - $self->debug(sprintf("makefilepl[%s]anycwd[%s]", - $mpl, - CPAN::anycwd(), - )) if $CPAN::DEBUG; - my $build_dir = $self->{build_dir}; - my($configure) = File::Spec->catfile($build_dir,"Configure"); - if (-f $configure) { - # do we have anything to do? - $self->{configure} = $configure; - } elsif (-f File::Spec->catfile($build_dir,"Makefile")) { - $CPAN::Frontend->mywarn(qq{ -Package comes with a Makefile and without a Makefile.PL. -We\'ll try to build it with that Makefile then. -}); - $self->{writemakefile} = CPAN::Distrostatus->new("YES"); - $CPAN::Frontend->mysleep(2); - } else { - my $cf = $self->called_for || "unknown"; - if ($cf =~ m|/|) { - $cf =~ s|.*/||; - $cf =~ s|\W.*||; - } - $cf =~ s|[/\\:]||g; # risk of filesystem damage - $cf = "unknown" unless length($cf); - if (my $crud = $self->_contains_crud($build_dir)) { - my $why = qq{Package contains $crud; not recognized as a perl package, giving up}; - $CPAN::Frontend->mywarn("$why\n"); - $self->{writemakefile} = CPAN::Distrostatus->new(qq{NO -- $why}); - return; - } - $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL. - (The test -f "$mpl" returned false.) - Writing one on our own (setting NAME to $cf)\a\n}); - $self->{had_no_makefile_pl}++; - $CPAN::Frontend->mysleep(3); - - # Writing our own Makefile.PL - - my $exefile_stanza = ""; - if ($self->{archived} eq "maybe_pl") { - $exefile_stanza = $self->_exefile_stanza($build_dir,$local_file); - } - - my $fh = FileHandle->new; - $fh->open(">$mpl") - or Carp::croak("Could not open >$mpl: $!"); - $fh->print( - qq{# This Makefile.PL has been autogenerated by the module CPAN.pm -# because there was no Makefile.PL supplied. -# Autogenerated on: }.scalar localtime().qq{ - -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => q[$cf],$exefile_stanza - ); -}); - $fh->close; - } -} - -#-> CPAN;:Distribution::_contains_crud -sub _contains_crud { - my($self,$dir) = @_; - my(@dirs, $dh, @files); - opendir $dh, $dir or return; - my $dirent; - for $dirent (readdir $dh) { - next if $dirent =~ /^\.\.?$/; - my $path = File::Spec->catdir($dir,$dirent); - if (-d $path) { - push @dirs, $dirent; - } elsif (-f $path) { - push @files, $dirent; - } - } - if (@dirs && @files) { - return "both files[@files] and directories[@dirs]"; - } elsif (@files > 2) { - return "several files[@files] but no Makefile.PL or Build.PL"; - } - return; -} - -#-> CPAN;:Distribution::_exefile_stanza -sub _exefile_stanza { - my($self,$build_dir,$local_file) = @_; - - my $fh = FileHandle->new; - my $script_file = File::Spec->catfile($build_dir,$local_file); - $fh->open($script_file) - or Carp::croak("Could not open script '$script_file': $!"); - local $/ = "\n"; - # name parsen und prereq - my($state) = "poddir"; - my($name, $prereq) = ("", ""); - while (<$fh>) { - if ($state eq "poddir" && /^=head\d\s+(\S+)/) { - if ($1 eq 'NAME') { - $state = "name"; - } elsif ($1 eq 'PREREQUISITES') { - $state = "prereq"; - } - } elsif ($state =~ m{^(name|prereq)$}) { - if (/^=/) { - $state = "poddir"; - } elsif (/^\s*$/) { - # nop - } elsif ($state eq "name") { - if ($name eq "") { - ($name) = /^(\S+)/; - $state = "poddir"; - } - } elsif ($state eq "prereq") { - $prereq .= $_; - } - } elsif (/^=cut\b/) { - last; - } - } - $fh->close; - - for ($name) { - s{.*<}{}; # strip X<...> - s{>.*}{}; - } - chomp $prereq; - $prereq = join " ", split /\s+/, $prereq; - my($PREREQ_PM) = join("\n", map { - s{.*<}{}; # strip X<...> - s{>.*}{}; - if (/[\s\'\"]/) { # prose? - } else { - s/[^\w:]$//; # period? - " "x28 . "'$_' => 0,"; - } - } split /\s*,\s*/, $prereq); - - if ($name) { - my $to_file = File::Spec->catfile($build_dir, $name); - rename $script_file, $to_file - or die "Can't rename $script_file to $to_file: $!"; - } - - return " - EXE_FILES => ['$name'], - PREREQ_PM => { -$PREREQ_PM - }, -"; -} - -#-> CPAN::Distribution::_signature_business -sub _signature_business { - my($self) = @_; - my $check_sigs = CPAN::HandleConfig->prefs_lookup($self, - q{check_sigs}); - if ($check_sigs) { - if ($CPAN::META->has_inst("Module::Signature")) { - if (-f "SIGNATURE") { - $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG; - my $rv = Module::Signature::verify(); - if ($rv != Module::Signature::SIGNATURE_OK() and - $rv != Module::Signature::SIGNATURE_MISSING()) { - $CPAN::Frontend->mywarn( - qq{\nSignature invalid for }. - qq{distribution file. }. - qq{Please investigate.\n\n} - ); - - my $wrap = - sprintf(qq{I'd recommend removing %s. Some error occurred }. - qq{while checking its signature, so it could }. - qq{be invalid. Maybe you have configured }. - qq{your 'urllist' with a bad URL. Please check this }. - qq{array with 'o conf urllist' and retry. Or }. - qq{examine the distribution in a subshell. Try - look %s -and run - cpansign -v -}, - $self->{localfile}, - $self->pretty_id, - ); - $self->{signature_verify} = CPAN::Distrostatus->new("NO"); - $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap)); - $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep"); - } else { - $self->{signature_verify} = CPAN::Distrostatus->new("YES"); - $self->debug("Module::Signature has verified") if $CPAN::DEBUG; - } - } else { - $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n}); - } - } else { - $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG; - } - } -} - -#-> CPAN::Distribution::untar_me ; -sub untar_me { - my($self,$ct) = @_; - $self->{archived} = "tar"; - my $result = eval { $ct->untar() }; - if ($result) { - $self->{unwrapped} = CPAN::Distrostatus->new("YES"); - } else { - $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed"); - } -} - -# CPAN::Distribution::unzip_me ; -sub unzip_me { - my($self,$ct) = @_; - $self->{archived} = "zip"; - if ($ct->unzip()) { - $self->{unwrapped} = CPAN::Distrostatus->new("YES"); - } else { - $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed"); - } - return; -} - -sub handle_singlefile { - my($self,$local_file) = @_; - - if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) { - $self->{archived} = "pm"; - } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) { - $self->{archived} = "patch"; - } else { - $self->{archived} = "maybe_pl"; - } - - my $to = File::Basename::basename($local_file); - if ($to =~ s/\.(gz|Z)(?!\n)\Z//) { - if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) { - $self->{unwrapped} = CPAN::Distrostatus->new("YES"); - } else { - $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed"); - } - } else { - if (File::Copy::cp($local_file,".")) { - $self->{unwrapped} = CPAN::Distrostatus->new("YES"); - } else { - $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed"); - } - } - return $to; -} - -#-> sub CPAN::Distribution::new ; -sub new { - my($class,%att) = @_; - - # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); - - my $this = { %att }; - return bless $this, $class; -} - -#-> sub CPAN::Distribution::look ; -sub look { - my($self) = @_; - - if ($^O eq 'MacOS') { - $self->Mac::BuildTools::look; - return; - } - - if ( $CPAN::Config->{'shell'} ) { - $CPAN::Frontend->myprint(qq{ -Trying to open a subshell in the build directory... -}); - } else { - $CPAN::Frontend->myprint(qq{ -Your configuration does not define a value for subshells. -Please define it with "o conf shell <your shell>" -}); - return; - } - my $dist = $self->id; - my $dir; - unless ($dir = $self->dir) { - $self->get; - } - unless ($dir ||= $self->dir) { - $CPAN::Frontend->mywarn(qq{ -Could not determine which directory to use for looking at $dist. -}); - return; - } - my $pwd = CPAN::anycwd(); - $self->safe_chdir($dir); - $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); - { - local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0; - $ENV{CPAN_SHELL_LEVEL} += 1; - my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'}); - - local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) - ? $ENV{PERL5LIB} - : ($ENV{PERLLIB} || ""); - - local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; - $CPAN::META->set_perl5lib; - local $ENV{MAKEFLAGS}; # protect us from outer make calls - - unless (system($shell) == 0) { - my $code = $? >> 8; - $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n"); - } - } - $self->safe_chdir($pwd); -} - -# CPAN::Distribution::cvs_import ; -sub cvs_import { - my($self) = @_; - $self->get; - my $dir = $self->dir; - - my $package = $self->called_for; - my $module = $CPAN::META->instance('CPAN::Module', $package); - my $version = $module->cpan_version; - - my $userid = $self->cpan_userid; - - my $cvs_dir = (split /\//, $dir)[-1]; - $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//; - my $cvs_root = - $CPAN::Config->{cvsroot} || $ENV{CVSROOT}; - my $cvs_site_perl = - $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL}; - if ($cvs_site_perl) { - $cvs_dir = "$cvs_site_perl/$cvs_dir"; - } - my $cvs_log = qq{"imported $package $version sources"}; - $version =~ s/\./_/g; - # XXX cvs: undocumented and unclear how it was meant to work - my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log, - "$cvs_dir", $userid, "v$version"); - - my $pwd = CPAN::anycwd(); - chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!}); - - $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); - - $CPAN::Frontend->myprint(qq{@cmd\n}); - system(@cmd) == 0 or - # XXX cvs - $CPAN::Frontend->mydie("cvs import failed"); - chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!}); -} - -#-> sub CPAN::Distribution::readme ; -sub readme { - my($self) = @_; - my($dist) = $self->id; - my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/; - $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG; - my($local_file); - my($local_wanted) = - File::Spec->catfile( - $CPAN::Config->{keep_source_where}, - "authors", - "id", - split(/\//,"$sans.readme"), - ); - $self->debug("Doing localize") if $CPAN::DEBUG; - $local_file = CPAN::FTP->localize("authors/id/$sans.readme", - $local_wanted) - or $CPAN::Frontend->mydie(qq{No $sans.readme found});; - - if ($^O eq 'MacOS') { - Mac::BuildTools::launch_file($local_file); - return; - } - - my $fh_pager = FileHandle->new; - local($SIG{PIPE}) = "IGNORE"; - my $pager = $CPAN::Config->{'pager'} || "cat"; - $fh_pager->open("|$pager") - or die "Could not open pager $pager\: $!"; - my $fh_readme = FileHandle->new; - $fh_readme->open($local_file) - or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!}); - $CPAN::Frontend->myprint(qq{ -Displaying file - $local_file -with pager "$pager" -}); - $fh_pager->print(<$fh_readme>); - $fh_pager->close; -} - -#-> sub CPAN::Distribution::verifyCHECKSUM ; -sub verifyCHECKSUM { - my($self) = @_; - EXCUSE: { - my @e; - $self->{CHECKSUM_STATUS} ||= ""; - $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok"; - $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; - } - my($lc_want,$lc_file,@local,$basename); - @local = split(/\//,$self->id); - pop @local; - push @local, "CHECKSUMS"; - $lc_want = - File::Spec->catfile($CPAN::Config->{keep_source_where}, - "authors", "id", @local); - local($") = "/"; - if (my $size = -s $lc_want) { - $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG; - if ($self->CHECKSUM_check_file($lc_want,1)) { - return $self->{CHECKSUM_STATUS} = "OK"; - } - } - $lc_file = CPAN::FTP->localize("authors/id/@local", - $lc_want,1); - unless ($lc_file) { - $CPAN::Frontend->myprint("Trying $lc_want.gz\n"); - $local[-1] .= ".gz"; - $lc_file = CPAN::FTP->localize("authors/id/@local", - "$lc_want.gz",1); - if ($lc_file) { - $lc_file =~ s/\.gz(?!\n)\Z//; - eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)}; - } else { - return; - } - } - if ($self->CHECKSUM_check_file($lc_file)) { - return $self->{CHECKSUM_STATUS} = "OK"; - } -} - -#-> sub CPAN::Distribution::SIG_check_file ; -sub SIG_check_file { - my($self,$chk_file) = @_; - my $rv = eval { Module::Signature::_verify($chk_file) }; - - if ($rv == Module::Signature::SIGNATURE_OK()) { - $CPAN::Frontend->myprint("Signature for $chk_file ok\n"); - return $self->{SIG_STATUS} = "OK"; - } else { - $CPAN::Frontend->myprint(qq{\nSignature invalid for }. - qq{distribution file. }. - qq{Please investigate.\n\n}. - $self->as_string, - $CPAN::META->instance( - 'CPAN::Author', - $self->cpan_userid - )->as_string); - - my $wrap = qq{I\'d recommend removing $chk_file. Its signature -is invalid. Maybe you have configured your 'urllist' with -a bad URL. Please check this array with 'o conf urllist', and -retry.}; - - $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap)); - } -} - -#-> sub CPAN::Distribution::CHECKSUM_check_file ; - -# sloppy is 1 when we have an old checksums file that maybe is good -# enough - -sub CHECKSUM_check_file { - my($self,$chk_file,$sloppy) = @_; - my($cksum,$file,$basename); - - $sloppy ||= 0; - $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG; - my $check_sigs = CPAN::HandleConfig->prefs_lookup($self, - q{check_sigs}); - if ($check_sigs) { - if ($CPAN::META->has_inst("Module::Signature")) { - $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG; - $self->SIG_check_file($chk_file); - } else { - $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG; - } - } - - $file = $self->{localfile}; - $basename = File::Basename::basename($file); - my $fh = FileHandle->new; - if (open $fh, $chk_file) { - local($/); - my $eval = <$fh>; - $eval =~ s/\015?\012/\n/g; - close $fh; - my($compmt) = Safe->new(); - $cksum = $compmt->reval($eval); - if ($@) { - rename $chk_file, "$chk_file.bad"; - Carp::confess($@) if $@; - } - } else { - Carp::carp "Could not open $chk_file for reading"; - } - - if (! ref $cksum or ref $cksum ne "HASH") { - $CPAN::Frontend->mywarn(qq{ -Warning: checksum file '$chk_file' broken. - -When trying to read that file I expected to get a hash reference -for further processing, but got garbage instead. -}); - my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no"); - $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n"); - $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken"; - return; - } elsif (exists $cksum->{$basename}{sha256}) { - $self->debug("Found checksum for $basename:" . - "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG; - - open($fh, $file); - binmode $fh; - my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256}); - $fh->close; - $fh = CPAN::Tarzip->TIEHANDLE($file); - - unless ($eq) { - my $dg = Digest::SHA->new(256); - my($data,$ref); - $ref = \$data; - while ($fh->READ($ref, 4096) > 0) { - $dg->add($data); - } - my $hexdigest = $dg->hexdigest; - $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'}; - } - - if ($eq) { - $CPAN::Frontend->myprint("Checksum for $file ok\n"); - return $self->{CHECKSUM_STATUS} = "OK"; - } else { - $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }. - qq{distribution file. }. - qq{Please investigate.\n\n}. - $self->as_string, - $CPAN::META->instance( - 'CPAN::Author', - $self->cpan_userid - )->as_string); - - my $wrap = qq{I\'d recommend removing $file. Its -checksum is incorrect. Maybe you have configured your 'urllist' with -a bad URL. Please check this array with 'o conf urllist', and -retry.}; - - $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap)); - - # former versions just returned here but this seems a - # serious threat that deserves a die - - # $CPAN::Frontend->myprint("\n\n"); - # sleep 3; - # return; - } - # close $fh if fileno($fh); - } else { - return if $sloppy; - unless ($self->{CHECKSUM_STATUS}) { - $CPAN::Frontend->mywarn(qq{ -Warning: No checksum for $basename in $chk_file. - -The cause for this may be that the file is very new and the checksum -has not yet been calculated, but it may also be that something is -going awry right now. -}); - my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes"); - $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n"); - } - $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file"; - return; - } -} - -#-> sub CPAN::Distribution::eq_CHECKSUM ; -sub eq_CHECKSUM { - my($self,$fh,$expect) = @_; - if ($CPAN::META->has_inst("Digest::SHA")) { - my $dg = Digest::SHA->new(256); - my($data); - while (read($fh, $data, 4096)) { - $dg->add($data); - } - my $hexdigest = $dg->hexdigest; - # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]"; - return $hexdigest eq $expect; - } - return 1; -} - -#-> sub CPAN::Distribution::force ; - -# Both CPAN::Modules and CPAN::Distributions know if "force" is in -# effect by autoinspection, not by inspecting a global variable. One -# of the reason why this was chosen to work that way was the treatment -# of dependencies. They should not automatically inherit the force -# status. But this has the downside that ^C and die() will return to -# the prompt but will not be able to reset the force_update -# attributes. We try to correct for it currently in the read_metadata -# routine, and immediately before we check for a Signal. I hope this -# works out in one of v1.57_53ff - -# "Force get forgets previous error conditions" - -#-> sub CPAN::Distribution::fforce ; -sub fforce { - my($self, $method) = @_; - $self->force($method,1); -} - -#-> sub CPAN::Distribution::force ; -sub force { - my($self, $method,$fforce) = @_; - my %phase_map = ( - get => [ - "unwrapped", - "build_dir", - "archived", - "localfile", - "CHECKSUM_STATUS", - "signature_verify", - "prefs", - "prefs_file", - "prefs_file_doc", - ], - make => [ - "writemakefile", - "make", - "modulebuild", - "prereq_pm", - "prereq_pm_detected", - ], - test => [ - "badtestcnt", - "make_test", - ], - install => [ - "install", - ], - unknown => [ - "reqtype", - "yaml_content", - ], - ); - my $methodmatch = 0; - my $ldebug = 0; - PHASE: for my $phase (qw(unknown get make test install)) { # order matters - $methodmatch = 1 if $fforce || $phase eq $method; - next unless $methodmatch; - ATTRIBUTE: for my $att (@{$phase_map{$phase}}) { - if ($phase eq "get") { - if (substr($self->id,-1,1) eq "." - && $att =~ /(unwrapped|build_dir|archived)/ ) { - # cannot be undone for local distros - next ATTRIBUTE; - } - if ($att eq "build_dir" - && $self->{build_dir} - && $CPAN::META->{is_tested} - ) { - delete $CPAN::META->{is_tested}{$self->{build_dir}}; - } - } elsif ($phase eq "test") { - if ($att eq "make_test" - && $self->{make_test} - && $self->{make_test}{COMMANDID} - && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId - ) { - # endless loop too likely - next ATTRIBUTE; - } - } - delete $self->{$att}; - if ($ldebug || $CPAN::DEBUG) { - # local $CPAN::DEBUG = 16; # Distribution - CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att); - } - } - } - if ($method && $method =~ /make|test|install/) { - $self->{force_update} = 1; # name should probably have been force_install - } -} - -#-> sub CPAN::Distribution::notest ; -sub notest { - my($self, $method) = @_; - # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method"); - $self->{"notest"}++; # name should probably have been force_install -} - -#-> sub CPAN::Distribution::unnotest ; -sub unnotest { - my($self) = @_; - # warn "XDEBUG: deleting notest"; - delete $self->{notest}; -} - -#-> sub CPAN::Distribution::unforce ; -sub unforce { - my($self) = @_; - delete $self->{force_update}; -} - -#-> sub CPAN::Distribution::isa_perl ; -sub isa_perl { - my($self) = @_; - my $file = File::Basename::basename($self->id); - if ($file =~ m{ ^ perl - -? - (5) - ([._-]) - ( - \d{3}(_[0-4][0-9])? - | - \d+\.\d+ - ) - \.tar[._-](?:gz|bz2) - (?!\n)\Z - }xs) { - return "$1.$3"; - } elsif ($self->cpan_comment - && - $self->cpan_comment =~ /isa_perl\(.+?\)/) { - return $1; - } -} - - -#-> sub CPAN::Distribution::perl ; -sub perl { - my ($self) = @_; - if (! $self) { - use Carp qw(carp); - carp __PACKAGE__ . "::perl was called without parameters."; - } - return CPAN::HandleConfig->safe_quote($CPAN::Perl); -} - - -#-> sub CPAN::Distribution::make ; -sub make { - my($self) = @_; - if (my $goto = $self->prefs->{goto}) { - return $self->goto($goto); - } - my $make = $self->{modulebuild} ? "Build" : "make"; - # Emergency brake if they said install Pippi and get newest perl - if ($self->isa_perl) { - if ( - $self->called_for ne $self->id && - ! $self->{force_update} - ) { - # if we die here, we break bundles - $CPAN::Frontend - ->mywarn(sprintf( - qq{The most recent version "%s" of the module "%s" -is part of the perl-%s distribution. To install that, you need to run - force install %s --or-- - install %s -}, - $CPAN::META->instance( - 'CPAN::Module', - $self->called_for - )->cpan_version, - $self->called_for, - $self->isa_perl, - $self->called_for, - $self->id, - )); - $self->{make} = CPAN::Distrostatus->new("NO isa perl"); - $CPAN::Frontend->mysleep(1); - return; - } - } - $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id); - $self->get; - return if $self->prefs->{disabled} && ! $self->{force_update}; - if ($self->{configure_requires_later}) { - return; - } - local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) - ? $ENV{PERL5LIB} - : ($ENV{PERLLIB} || ""); - local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; - $CPAN::META->set_perl5lib; - local $ENV{MAKEFLAGS}; # protect us from outer make calls - - if ($CPAN::Signal) { - delete $self->{force_update}; - return; - } - - my $builddir; - EXCUSE: { - my @e; - if (!$self->{archived} || $self->{archived} eq "NO") { - push @e, "Is neither a tar nor a zip archive."; - } - - if (!$self->{unwrapped} - || ( - UNIVERSAL::can($self->{unwrapped},"failed") ? - $self->{unwrapped}->failed : - $self->{unwrapped} =~ /^NO/ - )) { - push @e, "Had problems unarchiving. Please build manually"; - } - - unless ($self->{force_update}) { - exists $self->{signature_verify} and - ( - UNIVERSAL::can($self->{signature_verify},"failed") ? - $self->{signature_verify}->failed : - $self->{signature_verify} =~ /^NO/ - ) - and push @e, "Did not pass the signature test."; - } - - if (exists $self->{writemakefile} && - ( - UNIVERSAL::can($self->{writemakefile},"failed") ? - $self->{writemakefile}->failed : - $self->{writemakefile} =~ /^NO/ - )) { - # XXX maybe a retry would be in order? - my $err = UNIVERSAL::can($self->{writemakefile},"text") ? - $self->{writemakefile}->text : - $self->{writemakefile}; - $err =~ s/^NO\s*(--\s+)?//; - $err ||= "Had some problem writing Makefile"; - $err .= ", won't make"; - push @e, $err; - } - - if (defined $self->{make}) { - if (UNIVERSAL::can($self->{make},"failed") ? - $self->{make}->failed : - $self->{make} =~ /^NO/) { - if ($self->{force_update}) { - # Trying an already failed 'make' (unless somebody else blocks) - } else { - # introduced for turning recursion detection into a distrostatus - my $error = length $self->{make}>3 - ? substr($self->{make},3) : "Unknown error"; - $CPAN::Frontend->mywarn("Could not make: $error\n"); - $self->store_persistent_state; - return; - } - } else { - push @e, "Has already been made"; - my $wait_for_prereqs = eval { $self->satisfy_requires }; - return 1 if $wait_for_prereqs; # tells queuerunner to continue - return $self->goodbye($@) if $@; # tells queuerunner to stop - } - } - - my $later = $self->{later} || $self->{configure_requires_later}; - if ($later) { # see also undelay - if ($later) { - push @e, $later; - } - } - - $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; - $builddir = $self->dir or - $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n"); - unless (chdir $builddir) { - push @e, "Couldn't chdir to '$builddir': $!"; - } - $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; - } - if ($CPAN::Signal) { - delete $self->{force_update}; - return; - } - $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n"); - $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; - - if ($^O eq 'MacOS') { - Mac::BuildTools::make($self); - return; - } - - my %env; - while (my($k,$v) = each %ENV) { - next unless defined $v; - $env{$k} = $v; - } - local %ENV = %env; - my $system; - my $pl_commandline; - if ($self->prefs->{pl}) { - $pl_commandline = $self->prefs->{pl}{commandline}; - } - if ($pl_commandline) { - $system = $pl_commandline; - $ENV{PERL} = $^X; - } elsif ($self->{'configure'}) { - $system = $self->{'configure'}; - } elsif ($self->{modulebuild}) { - my($perl) = $self->perl or die "Couldn\'t find executable perl\n"; - $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}"; - } else { - my($perl) = $self->perl or die "Couldn\'t find executable perl\n"; - my $switch = ""; -# This needs a handler that can be turned on or off: -# $switch = "-MExtUtils::MakeMaker ". -# "-Mops=:default,:filesys_read,:filesys_open,require,chdir" -# if $] > 5.00310; - my $makepl_arg = $self->_make_phase_arg("pl"); - $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir}, - "Makefile.PL"); - $system = sprintf("%s%s Makefile.PL%s", - $perl, - $switch ? " $switch" : "", - $makepl_arg ? " $makepl_arg" : "", - ); - } - my $pl_env; - if ($self->prefs->{pl}) { - $pl_env = $self->prefs->{pl}{env}; - } - if ($pl_env) { - for my $e (keys %$pl_env) { - $ENV{$e} = $pl_env->{$e}; - } - } - if (exists $self->{writemakefile}) { - } else { - local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" }; - my($ret,$pid,$output); - $@ = ""; - my $go_via_alarm; - if ($CPAN::Config->{inactivity_timeout}) { - require Config; - if ($Config::Config{d_alarm} - && - $Config::Config{d_alarm} eq "define" - ) { - $go_via_alarm++ - } else { - $CPAN::Frontend->mywarn("Warning: you have configured the config ". - "variable 'inactivity_timeout' to ". - "'$CPAN::Config->{inactivity_timeout}'. But ". - "on this machine the system call 'alarm' ". - "isn't available. This means that we cannot ". - "provide the feature of intercepting long ". - "waiting code and will turn this feature off.\n" - ); - $CPAN::Config->{inactivity_timeout} = 0; - } - } - if ($go_via_alarm) { - if ( $self->_should_report('pl') ) { - ($output, $ret) = CPAN::Reporter::record_command( - $system, - $CPAN::Config->{inactivity_timeout}, - ); - CPAN::Reporter::grade_PL( $self, $system, $output, $ret ); - } - else { - eval { - alarm $CPAN::Config->{inactivity_timeout}; - local $SIG{CHLD}; # = sub { wait }; - if (defined($pid = fork)) { - if ($pid) { #parent - # wait; - waitpid $pid, 0; - } else { #child - # note, this exec isn't necessary if - # inactivity_timeout is 0. On the Mac I'd - # suggest, we set it always to 0. - exec $system; - } - } else { - $CPAN::Frontend->myprint("Cannot fork: $!"); - return; - } - }; - alarm 0; - if ($@) { - kill 9, $pid; - waitpid $pid, 0; - my $err = "$@"; - $CPAN::Frontend->myprint($err); - $self->{writemakefile} = CPAN::Distrostatus->new("NO $err"); - $@ = ""; - $self->store_persistent_state; - return $self->goodbye("$system -- TIMED OUT"); - } - } - } else { - if (my $expect_model = $self->_prefs_with_expect("pl")) { - # XXX probably want to check _should_report here and warn - # about not being able to use CPAN::Reporter with expect - $ret = $self->_run_via_expect($system,'writemakefile',$expect_model); - if (! defined $ret - && $self->{writemakefile} - && $self->{writemakefile}->failed) { - # timeout - return; - } - } - elsif ( $self->_should_report('pl') ) { - ($output, $ret) = CPAN::Reporter::record_command($system); - CPAN::Reporter::grade_PL( $self, $system, $output, $ret ); - } - else { - $ret = system($system); - } - if ($ret != 0) { - $self->{writemakefile} = CPAN::Distrostatus - ->new("NO '$system' returned status $ret"); - $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n"); - $self->store_persistent_state; - return $self->goodbye("$system -- NOT OK"); - } - } - if (-f "Makefile" || -f "Build") { - $self->{writemakefile} = CPAN::Distrostatus->new("YES"); - delete $self->{make_clean}; # if cleaned before, enable next - } else { - my $makefile = $self->{modulebuild} ? "Build" : "Makefile"; - my $why = "No '$makefile' created"; - $CPAN::Frontend->mywarn($why); - $self->{writemakefile} = CPAN::Distrostatus - ->new(qq{NO -- $why\n}); - $self->store_persistent_state; - return $self->goodbye("$system -- NOT OK"); - } - } - if ($CPAN::Signal) { - delete $self->{force_update}; - return; - } - my $wait_for_prereqs = eval { $self->satisfy_requires }; - return 1 if $wait_for_prereqs; # tells queuerunner to continue - return $self->goodbye($@) if $@; # tells queuerunner to stop - if ($CPAN::Signal) { - delete $self->{force_update}; - return; - } - my $make_commandline; - if ($self->prefs->{make}) { - $make_commandline = $self->prefs->{make}{commandline}; - } - if ($make_commandline) { - $system = $make_commandline; - $ENV{PERL} = CPAN::find_perl(); - } else { - if ($self->{modulebuild}) { - unless (-f "Build") { - my $cwd = CPAN::anycwd(); - $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'". - " in cwd[$cwd]. Danger, Will Robinson!\n"); - $CPAN::Frontend->mysleep(5); - } - $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg}; - } else { - $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg}; - } - $system =~ s/\s+$//; - my $make_arg = $self->_make_phase_arg("make"); - $system = sprintf("%s%s", - $system, - $make_arg ? " $make_arg" : "", - ); - } - my $make_env; - if ($self->prefs->{make}) { - $make_env = $self->prefs->{make}{env}; - } - if ($make_env) { # overriding the local ENV of PL, not the outer - # ENV, but unlikely to be a risk - for my $e (keys %$make_env) { - $ENV{$e} = $make_env->{$e}; - } - } - my $expect_model = $self->_prefs_with_expect("make"); - my $want_expect = 0; - if ( $expect_model && @{$expect_model->{talk}} ) { - my $can_expect = $CPAN::META->has_inst("Expect"); - if ($can_expect) { - $want_expect = 1; - } else { - $CPAN::Frontend->mywarn("Expect not installed, falling back to ". - "system()\n"); - } - } - my $system_ok; - if ($want_expect) { - # XXX probably want to check _should_report here and - # warn about not being able to use CPAN::Reporter with expect - $system_ok = $self->_run_via_expect($system,'make',$expect_model) == 0; - } - elsif ( $self->_should_report('make') ) { - my ($output, $ret) = CPAN::Reporter::record_command($system); - CPAN::Reporter::grade_make( $self, $system, $output, $ret ); - $system_ok = ! $ret; - } - else { - $system_ok = system($system) == 0; - } - $self->introduce_myself; - if ( $system_ok ) { - $CPAN::Frontend->myprint(" $system -- OK\n"); - $self->{make} = CPAN::Distrostatus->new("YES"); - } else { - $self->{writemakefile} ||= CPAN::Distrostatus->new("YES"); - $self->{make} = CPAN::Distrostatus->new("NO"); - $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); - } - $self->store_persistent_state; -} - -# CPAN::Distribution::goodbye ; -sub goodbye { - my($self,$goodbye) = @_; - my $id = $self->pretty_id; - $CPAN::Frontend->mywarn(" $id\n $goodbye\n"); - return; -} - -# CPAN::Distribution::_run_via_expect ; -sub _run_via_expect { - my($self,$system,$phase,$expect_model) = @_; - CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG; - if ($CPAN::META->has_inst("Expect")) { - my $expo = Expect->new; # expo Expect object; - $expo->spawn($system); - $expect_model->{mode} ||= "deterministic"; - if ($expect_model->{mode} eq "deterministic") { - return $self->_run_via_expect_deterministic($expo,$phase,$expect_model); - } elsif ($expect_model->{mode} eq "anyorder") { - return $self->_run_via_expect_anyorder($expo,$phase,$expect_model); - } else { - die "Panic: Illegal expect mode: $expect_model->{mode}"; - } - } else { - $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n"); - return system($system); - } -} - -sub _run_via_expect_anyorder { - my($self,$expo,$phase,$expect_model) = @_; - my $timeout = $expect_model->{timeout} || 5; - my $reuse = $expect_model->{reuse}; - my @expectacopy = @{$expect_model->{talk}}; # we trash it! - my $but = ""; - my $timeout_start = time; - EXPECT: while () { - my($eof,$ran_into_timeout); - # XXX not up to the full power of expect. one could certainly - # wrap all of the talk pairs into a single expect call and on - # success tweak it and step ahead to the next question. The - # current implementation unnecessarily limits itself to a - # single match. - my @match = $expo->expect(1, - [ eof => sub { - $eof++; - } ], - [ timeout => sub { - $ran_into_timeout++; - } ], - -re => eval"qr{.}", - ); - if ($match[2]) { - $but .= $match[2]; - } - $but .= $expo->clear_accum; - if ($eof) { - $expo->soft_close; - return $expo->exitstatus(); - } elsif ($ran_into_timeout) { - # warn "DEBUG: they are asking a question, but[$but]"; - for (my $i = 0; $i <= $#expectacopy; $i+=2) { - my($next,$send) = @expectacopy[$i,$i+1]; - my $regex = eval "qr{$next}"; - # warn "DEBUG: will compare with regex[$regex]."; - if ($but =~ /$regex/) { - # warn "DEBUG: will send send[$send]"; - $expo->send($send); - # never allow reusing an QA pair unless they told us - splice @expectacopy, $i, 2 unless $reuse; - next EXPECT; - } - } - my $have_waited = time - $timeout_start; - if ($have_waited < $timeout) { - # warn "DEBUG: have_waited[$have_waited]timeout[$timeout]"; - next EXPECT; - } - my $why = "could not answer a question during the dialog"; - $CPAN::Frontend->mywarn("Failing: $why\n"); - $self->{$phase} = - CPAN::Distrostatus->new("NO $why"); - return 0; - } - } -} - -sub _run_via_expect_deterministic { - my($self,$expo,$phase,$expect_model) = @_; - my $ran_into_timeout; - my $ran_into_eof; - my $timeout = $expect_model->{timeout} || 15; # currently unsettable - my $expecta = $expect_model->{talk}; - EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) { - my($re,$send) = @$expecta[$i,$i+1]; - CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG; - my $regex = eval "qr{$re}"; - $expo->expect($timeout, - [ eof => sub { - my $but = $expo->clear_accum; - $CPAN::Frontend->mywarn("EOF (maybe harmless) -expected[$regex]\nbut[$but]\n\n"); - $ran_into_eof++; - } ], - [ timeout => sub { - my $but = $expo->clear_accum; - $CPAN::Frontend->mywarn("TIMEOUT -expected[$regex]\nbut[$but]\n\n"); - $ran_into_timeout++; - } ], - -re => $regex); - if ($ran_into_timeout) { - # note that the caller expects 0 for success - $self->{$phase} = - CPAN::Distrostatus->new("NO timeout during expect dialog"); - return 0; - } elsif ($ran_into_eof) { - last EXPECT; - } - $expo->send($send); - } - $expo->soft_close; - return $expo->exitstatus(); -} - -#-> CPAN::Distribution::_validate_distropref -sub _validate_distropref { - my($self,@args) = @_; - if ( - $CPAN::META->has_inst("CPAN::Kwalify") - && - $CPAN::META->has_inst("Kwalify") - ) { - eval {CPAN::Kwalify::_validate("distroprefs",@args);}; - if ($@) { - $CPAN::Frontend->mywarn($@); - } - } else { - CPAN->debug("not validating '@args'") if $CPAN::DEBUG; - } -} - -#-> CPAN::Distribution::_find_prefs -sub _find_prefs { - my($self) = @_; - my $distroid = $self->pretty_id; - #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG; - my $prefs_dir = $CPAN::Config->{prefs_dir}; - return if $prefs_dir =~ /^\s*$/; - eval { File::Path::mkpath($prefs_dir); }; - if ($@) { - $CPAN::Frontend->mydie("Cannot create directory $prefs_dir"); - } - my $yaml_module = CPAN::_yaml_module(); - my $ext_map = {}; - my @extensions; - if ($CPAN::META->has_inst($yaml_module)) { - $ext_map->{yml} = 'CPAN'; - } else { - my @fallbacks; - if ($CPAN::META->has_inst("Data::Dumper")) { - push @fallbacks, $ext_map->{dd} = 'Data::Dumper'; - } - if ($CPAN::META->has_inst("Storable")) { - push @fallbacks, $ext_map->{st} = 'Storable'; - } - if (@fallbacks) { - local $" = " and "; - unless ($self->{have_complained_about_missing_yaml}++) { - $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ". - "to @fallbacks to read prefs '$prefs_dir'\n"); - } - } else { - unless ($self->{have_complained_about_missing_yaml}++) { - $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ". - "read prefs '$prefs_dir'\n"); - } - } - } - my $finder = CPAN::Distroprefs->find($prefs_dir, $ext_map); - DIRENT: while (my $result = $finder->next) { - if ($result->is_warning) { - $CPAN::Frontend->mywarn($result->as_string); - $CPAN::Frontend->mysleep(1); - next DIRENT; - } elsif ($result->is_fatal) { - $CPAN::Frontend->mydie($result->as_string); - } - - my @prefs = @{ $result->prefs }; - - ELEMENT: for my $y (0..$#prefs) { - my $pref = $prefs[$y]; - $self->_validate_distropref($pref->data, $result->abs, $y); - - # I don't know why we silently skip when there's no match, but - # complain if there's an empty match hashref, and there's no - # comment explaining why -- hdp, 2008-03-18 - unless ($pref->has_any_match) { - next ELEMENT; - } - - unless ($pref->has_valid_subkeys) { - $CPAN::Frontend->mydie(sprintf - "Nonconforming .%s file '%s': " . - "missing match/* subattribute. " . - "Please remove, cannot continue.", - $result->ext, $result->abs, - ); - } - - my $arg = { - env => \%ENV, - distribution => $distroid, - perl => \&CPAN::find_perl, - perlconfig => \%Config::Config, - module => sub { [ $self->containsmods ] }, - }; - - if ($pref->matches($arg)) { - return { - prefs => $pref->data, - prefs_file => $result->abs, - prefs_file_doc => $y, - }; - } - - } - } - return; -} - -# CPAN::Distribution::prefs -sub prefs { - my($self) = @_; - if (exists $self->{negative_prefs_cache} - && - $self->{negative_prefs_cache} != $CPAN::CurrentCommandId - ) { - delete $self->{negative_prefs_cache}; - delete $self->{prefs}; - } - if (exists $self->{prefs}) { - return $self->{prefs}; # XXX comment out during debugging - } - if ($CPAN::Config->{prefs_dir}) { - CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG; - my $prefs = $self->_find_prefs(); - $prefs ||= ""; # avoid warning next line - CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG; - if ($prefs) { - for my $x (qw(prefs prefs_file prefs_file_doc)) { - $self->{$x} = $prefs->{$x}; - } - my $bs = sprintf( - "%s[%s]", - File::Basename::basename($self->{prefs_file}), - $self->{prefs_file_doc}, - ); - my $filler1 = "_" x 22; - my $filler2 = int(66 - length($bs))/2; - $filler2 = 0 if $filler2 < 0; - $filler2 = " " x $filler2; - $CPAN::Frontend->myprint(" -$filler1 D i s t r o P r e f s $filler1 -$filler2 $bs $filler2 -"); - $CPAN::Frontend->mysleep(1); - return $self->{prefs}; - } - } - $self->{negative_prefs_cache} = $CPAN::CurrentCommandId; - return $self->{prefs} = +{}; -} - -# CPAN::Distribution::_make_phase_arg -sub _make_phase_arg { - my($self, $phase) = @_; - my $_make_phase_arg; - my $prefs = $self->prefs; - if ( - $prefs - && exists $prefs->{$phase} - && exists $prefs->{$phase}{args} - && $prefs->{$phase}{args} - ) { - $_make_phase_arg = join(" ", - map {CPAN::HandleConfig - ->safe_quote($_)} @{$prefs->{$phase}{args}}, - ); - } - -# cpan[2]> o conf make[TAB] -# make make_install_make_command -# make_arg makepl_arg -# make_install_arg -# cpan[2]> o conf mbuild[TAB] -# mbuild_arg mbuild_install_build_command -# mbuild_install_arg mbuildpl_arg - - my $mantra; # must switch make/mbuild here - if ($self->{modulebuild}) { - $mantra = "mbuild"; - } else { - $mantra = "make"; - } - my %map = ( - pl => "pl_arg", - make => "_arg", - test => "_test_arg", # does not really exist but maybe - # will some day and now protects - # us from unini warnings - install => "_install_arg", - ); - my $phase_underscore_meshup = $map{$phase}; - my $what = sprintf "%s%s", $mantra, $phase_underscore_meshup; - - $_make_phase_arg ||= $CPAN::Config->{$what}; - return $_make_phase_arg; -} - -# CPAN::Distribution::_make_command -sub _make_command { - my ($self) = @_; - if ($self) { - return - CPAN::HandleConfig - ->safe_quote( - CPAN::HandleConfig->prefs_lookup($self, - q{make}) - || $Config::Config{make} - || 'make' - ); - } else { - # Old style call, without object. Deprecated - Carp::confess("CPAN::_make_command() used as function. Don't Do That."); - return - safe_quote(undef, - CPAN::HandleConfig->prefs_lookup($self,q{make}) - || $CPAN::Config->{make} - || $Config::Config{make} - || 'make'); - } -} - -#-> sub CPAN::Distribution::follow_prereqs ; -sub follow_prereqs { - my($self) = shift; - my($slot) = shift; - my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_; - return unless @prereq_tuples; - my(@good_prereq_tuples); - for my $p (@prereq_tuples) { - # XXX watch out for foul ones - push @good_prereq_tuples, $p; - } - my $pretty_id = $self->pretty_id; - my %map = ( - b => "build_requires", - r => "requires", - c => "commandline", - ); - my($filler1,$filler2,$filler3,$filler4); - my $unsat = "Unsatisfied dependencies detected during"; - my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id); - { - my $r = int(($w - length($unsat))/2); - my $l = $w - length($unsat) - $r; - $filler1 = "-"x4 . " "x$l; - $filler2 = " "x$r . "-"x4 . "\n"; - } - { - my $r = int(($w - length($pretty_id))/2); - my $l = $w - length($pretty_id) - $r; - $filler3 = "-"x4 . " "x$l; - $filler4 = " "x$r . "-"x4 . "\n"; - } - $CPAN::Frontend-> - myprint("$filler1 $unsat $filler2". - "$filler3 $pretty_id $filler4". - join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @good_prereq_tuples), - ); - my $follow = 0; - if ($CPAN::Config->{prerequisites_policy} eq "follow") { - $follow = 1; - } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") { - my $answer = CPAN::Shell::colorable_makemaker_prompt( -"Shall I follow them and prepend them to the queue -of modules we are processing right now?", "yes"); - $follow = $answer =~ /^\s*y/i; - } else { - my @prereq = map { $_=>[0] } @good_prereq_tuples; - local($") = ", "; - $CPAN::Frontend-> - myprint(" Ignoring dependencies on modules @prereq\n"); - } - if ($follow) { - my $id = $self->id; - # color them as dirty - for my $gp (@good_prereq_tuples) { - # warn "calling color_cmd_tmps(0,1)"; - my $p = $gp->[0]; - my $any = CPAN::Shell->expandany($p); - $self->{$slot . "_for"}{$any->id}++; - if ($any) { - $any->color_cmd_tmps(0,2); - } else { - $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n"); - $CPAN::Frontend->mysleep(2); - } - } - # queue them and re-queue yourself - CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}}, - map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @good_prereq_tuples); - $self->{$slot} = "Delayed until after prerequisites"; - return 1; # signal success to the queuerunner - } - return; -} - -sub _feature_depends { - my($self) = @_; - my $meta_yml = $self->parse_meta_yml(); - my $optf = $meta_yml->{optional_features} or return; - if (!ref $optf or ref $optf ne "HASH"){ - $CPAN::Frontend->mywarn("The content of optional_features is not a HASH reference. Cannot use it.\n"); - $optf = {}; - } - my $wantf = $self->prefs->{features} or return; - if (!ref $wantf or ref $wantf ne "ARRAY"){ - $CPAN::Frontend->mywarn("The content of 'features' is not an ARRAY reference. Cannot use it.\n"); - $wantf = []; - } - my $dep = +{}; - for my $wf (@$wantf) { - if (my $f = $optf->{$wf}) { - $CPAN::Frontend->myprint("Found the demanded feature '$wf' that ". - "is accompanied by this description:\n". - $f->{description}. - "\n\n" - ); - # configure_requires currently not in the spec, unlikely to be useful anyway - for my $reqtype (qw(configure_requires build_requires requires)) { - my $reqhash = $f->{$reqtype} or next; - while (my($k,$v) = each %$reqhash) { - $dep->{$reqtype}{$k} = $v; - } - } - } else { - $CPAN::Frontend->mywarn("The demanded feature '$wf' was not ". - "found in the META.yml file". - "\n\n" - ); - } - } - $dep; -} - -#-> sub CPAN::Distribution::unsat_prereq ; -# return ([Foo,"r"],[Bar,"b"]) for normal modules -# return ([perl=>5.008]) if we need a newer perl than we are running under -# (sorry for the inconsistency, it was an accident) -sub unsat_prereq { - my($self,$slot) = @_; - my(%merged,$prereq_pm); - my $prefs_depends = $self->prefs->{depends}||{}; - my $feature_depends = $self->_feature_depends(); - if ($slot eq "configure_requires_later") { - my $meta_yml = $self->parse_meta_yml(); - if (defined $meta_yml && (! ref $meta_yml || ref $meta_yml ne "HASH")) { - $CPAN::Frontend->mywarn("The content of META.yml is defined but not a HASH reference. Cannot use it.\n"); - $meta_yml = +{}; - } - %merged = ( - %{$meta_yml->{configure_requires}||{}}, - %{$prefs_depends->{configure_requires}||{}}, - %{$feature_depends->{configure_requires}||{}}, - ); - $prereq_pm = {}; # configure_requires defined as "b" - } elsif ($slot eq "later") { - my $prereq_pm_0 = $self->prereq_pm || {}; - for my $reqtype (qw(requires build_requires)) { - $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it - for my $dep ($prefs_depends,$feature_depends) { - for my $k (keys %{$dep->{$reqtype}||{}}) { - $prereq_pm->{$reqtype}{$k} = $dep->{$reqtype}{$k}; - } - } - } - %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}}); - } else { - die "Panic: illegal slot '$slot'"; - } - my(@need); - my @merged = %merged; - CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG; - NEED: while (my($need_module, $need_version) = each %merged) { - my($available_version,$available_file,$nmo); - if ($need_module eq "perl") { - $available_version = $]; - $available_file = CPAN::find_perl(); - } else { - if (CPAN::_sqlite_running()) { - CPAN::Index->reload; - $CPAN::SQLite->search("CPAN::Module",$need_module); - } - $nmo = $CPAN::META->instance("CPAN::Module",$need_module); - next if $nmo->uptodate; - $available_file = $nmo->available_file; - - # if they have not specified a version, we accept any installed one - if (defined $available_file - and ( # a few quick shortcurcuits - not defined $need_version - or $need_version eq '0' # "==" would trigger warning when not numeric - or $need_version eq "undef" - )) { - next NEED; - } - - $available_version = $nmo->available_version; - } - - # We only want to install prereqs if either they're not installed - # or if the installed version is too old. We cannot omit this - # check, because if 'force' is in effect, nobody else will check. - if (defined $available_file) { - my $fulfills_all_version_rqs = $self->_fulfills_all_version_rqs - ($need_module,$available_file,$available_version,$need_version); - next NEED if $fulfills_all_version_rqs; - } - - if ($need_module eq "perl") { - return ["perl", $need_version]; - } - $self->{sponsored_mods}{$need_module} ||= 0; - CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG; - if (my $sponsoring = $self->{sponsored_mods}{$need_module}++) { - # We have already sponsored it and for some reason it's still - # not available. So we do ... what?? - - # if we push it again, we have a potential infinite loop - - # The following "next" was a very problematic construct. - # It helped a lot but broke some day and had to be - # replaced. - - # We must be able to deal with modules that come again and - # again as a prereq and have themselves prereqs and the - # queue becomes long but finally we would find the correct - # order. The RecursiveDependency check should trigger a - # die when it's becoming too weird. Unfortunately removing - # this next breaks many other things. - - # The bug that brought this up is described in Todo under - # "5.8.9 cannot install Compress::Zlib" - - # next; # this is the next that had to go away - - # The following "next NEED" are fine and the error message - # explains well what is going on. For example when the DBI - # fails and consequently DBD::SQLite fails and now we are - # processing CPAN::SQLite. Then we must have a "next" for - # DBD::SQLite. How can we get it and how can we identify - # all other cases we must identify? - - my $do = $nmo->distribution; - next NEED unless $do; # not on CPAN - if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){ - $CPAN::Frontend->mywarn("Warning: Prerequisite ". - "'$need_module => $need_version' ". - "for '$self->{ID}' seems ". - "not available according to the indices\n" - ); - next NEED; - } - NOSAYER: for my $nosayer ( - "unwrapped", - "writemakefile", - "signature_verify", - "make", - "make_test", - "install", - "make_clean", - ) { - if ($do->{$nosayer}) { - my $selfid = $self->pretty_id; - my $did = $do->pretty_id; - if (UNIVERSAL::can($do->{$nosayer},"failed") ? - $do->{$nosayer}->failed : - $do->{$nosayer} =~ /^NO/) { - if ($nosayer eq "make_test" - && - $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId - ) { - next NOSAYER; - } - $CPAN::Frontend->mywarn("Warning: Prerequisite ". - "'$need_module => $need_version' ". - "for '$selfid' failed when ". - "processing '$did' with ". - "'$nosayer => $do->{$nosayer}'. Continuing, ". - "but chances to succeed are limited.\n" - ); - $CPAN::Frontend->mysleep($sponsoring/10); - next NEED; - } else { # the other guy succeeded - if ($nosayer =~ /^(install|make_test)$/) { - # we had this with - # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz - # in 2007-03 for 'make install' - # and 2008-04: #30464 (for 'make test') - $CPAN::Frontend->mywarn("Warning: Prerequisite ". - "'$need_module => $need_version' ". - "for '$selfid' already built ". - "but the result looks suspicious. ". - "Skipping another build attempt, ". - "to prevent looping endlessly.\n" - ); - next NEED; - } - } - } - } - } - my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b"; - push @need, [$need_module,$needed_as]; - } - my @unfolded = map { "[".join(",",@$_)."]" } @need; - CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG; - @need; -} - -sub _fulfills_all_version_rqs { - my($self,$need_module,$available_file,$available_version,$need_version) = @_; - my(@all_requirements) = split /\s*,\s*/, $need_version; - local($^W) = 0; - my $ok = 0; - RQ: for my $rq (@all_requirements) { - if ($rq =~ s|>=\s*||) { - } elsif ($rq =~ s|>\s*||) { - # 2005-12: one user - if (CPAN::Version->vgt($available_version,$rq)) { - $ok++; - } - next RQ; - } elsif ($rq =~ s|!=\s*||) { - # 2005-12: no user - if (CPAN::Version->vcmp($available_version,$rq)) { - $ok++; - next RQ; - } else { - last RQ; - } - } elsif ($rq =~ m|<=?\s*|) { - # 2005-12: no user - $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n"); - $ok++; - next RQ; - } - if (! CPAN::Version->vgt($rq, $available_version)) { - $ok++; - } - CPAN->debug(sprintf("need_module[%s]available_file[%s]". - "available_version[%s]rq[%s]ok[%d]", - $need_module, - $available_file, - $available_version, - CPAN::Version->readable($rq), - $ok, - )) if $CPAN::DEBUG; - } - return $ok == @all_requirements; -} - -#-> sub CPAN::Distribution::read_yaml ; -sub read_yaml { - my($self) = @_; - return $self->{yaml_content} if exists $self->{yaml_content}; - my $build_dir; - unless ($build_dir = $self->{build_dir}) { - # maybe permission on build_dir was missing - $CPAN::Frontend->mywarn("Warning: cannot determine META.yml without a build_dir.\n"); - return; - } - # if MYMETA.yml exists, that takes precedence over META.yml - my $meta = File::Spec->catfile($build_dir,"META.yml"); - my $mymeta = File::Spec->catfile($build_dir,"MYMETA.yml"); - my $yaml = -f $mymeta ? $mymeta : $meta; - $self->debug("yaml[$yaml]") if $CPAN::DEBUG; - return unless -f $yaml; - eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; }; - if ($@) { - $CPAN::Frontend->mywarn("Could not read ". - "'$yaml'. Falling back to other ". - "methods to determine prerequisites\n"); - return $self->{yaml_content} = undef; # if we die, then we - # cannot read YAML's own - # META.yml - } - # not "authoritative" - for ($self->{yaml_content}) { - if (defined $_ && (! ref $_ || ref $_ ne "HASH")) { - $CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n"); - $self->{yaml_content} = +{}; - } - } - # MYMETA.yml is not dynamic by definition - if ( $yaml ne $mymeta && - ( not exists $self->{yaml_content}{dynamic_config} - or $self->{yaml_content}{dynamic_config} - ) - ) { - $self->{yaml_content} = undef; - } - $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF") - if $CPAN::DEBUG; - return $self->{yaml_content}; -} - -#-> sub CPAN::Distribution::prereq_pm ; -sub prereq_pm { - my($self) = @_; - $self->{prereq_pm_detected} ||= 0; - CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG; - return $self->{prereq_pm} if $self->{prereq_pm_detected}; - return unless $self->{writemakefile} # no need to have succeeded - # but we must have run it - || $self->{modulebuild}; - unless ($self->{build_dir}) { - return; - } - CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]", - $self->{writemakefile}||"", - $self->{modulebuild}||"", - ) if $CPAN::DEBUG; - my($req,$breq); - if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here - $req = $yaml->{requires} || {}; - $breq = $yaml->{build_requires} || {}; - undef $req unless ref $req eq "HASH" && %$req; - if ($req) { - if ($yaml->{generated_by} && - $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) { - my $eummv = do { local $^W = 0; $1+0; }; - if ($eummv < 6.2501) { - # thanks to Slaven for digging that out: MM before - # that could be wrong because it could reflect a - # previous release - undef $req; - } - } - my $areq; - my $do_replace; - while (my($k,$v) = each %{$req||{}}) { - if ($v =~ /\d/) { - $areq->{$k} = $v; - } elsif ($k =~ /[A-Za-z]/ && - $v =~ /[A-Za-z]/ && - $CPAN::META->exists("CPAN::Module",$v) - ) { - $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ". - "requires hash: $k => $v; I'll take both ". - "key and value as a module name\n"); - $CPAN::Frontend->mysleep(1); - $areq->{$k} = 0; - $areq->{$v} = 0; - $do_replace++; - } - } - $req = $areq if $do_replace; - } - } - unless ($req || $breq) { - my $build_dir; - unless ( $build_dir = $self->{build_dir} ) { - return; - } - my $makefile = File::Spec->catfile($build_dir,"Makefile"); - my $fh; - if (-f $makefile - and - $fh = FileHandle->new("<$makefile\0")) { - CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG; - local($/) = "\n"; - while (<$fh>) { - last if /MakeMaker post_initialize section/; - my($p) = m{^[\#] - \s+PREREQ_PM\s+=>\s+(.+) - }x; - next unless $p; - # warn "Found prereq expr[$p]"; - - # Regexp modified by A.Speer to remember actual version of file - # PREREQ_PM hash key wants, then add to - while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) { - # In case a prereq is mentioned twice, complain. - if ( defined $req->{$1} ) { - warn "Warning: PREREQ_PM mentions $1 more than once, ". - "last mention wins"; - } - my($m,$n) = ($1,$2); - if ($n =~ /^q\[(.*?)\]$/) { - $n = $1; - } - $req->{$m} = $n; - } - last; - } - } - } - unless ($req || $breq) { - my $build_dir = $self->{build_dir} or die "Panic: no build_dir?"; - my $buildfile = File::Spec->catfile($build_dir,"Build"); - if (-f $buildfile) { - CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG; - my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs"); - if (-f $build_prereqs) { - CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG; - my $content = do { local *FH; - open FH, $build_prereqs - or $CPAN::Frontend->mydie("Could not open ". - "'$build_prereqs': $!"); - local $/; - <FH>; - }; - my $bphash = eval $content; - if ($@) { - } else { - $req = $bphash->{requires} || +{}; - $breq = $bphash->{build_requires} || +{}; - } - } - } - } - if (-f "Build.PL" - && ! -f "Makefile.PL" - && ! exists $req->{"Module::Build"} - && ! $CPAN::META->has_inst("Module::Build")) { - $CPAN::Frontend->mywarn(" Warning: CPAN.pm discovered Module::Build as ". - "undeclared prerequisite.\n". - " Adding it now as such.\n" - ); - $CPAN::Frontend->mysleep(5); - $req->{"Module::Build"} = 0; - delete $self->{writemakefile}; - } - if ($req || $breq) { - $self->{prereq_pm_detected}++; - return $self->{prereq_pm} = { requires => $req, build_requires => $breq }; - } -} - -#-> sub CPAN::Distribution::test ; -sub test { - my($self) = @_; - if (my $goto = $self->prefs->{goto}) { - return $self->goto($goto); - } - $self->make; - return if $self->prefs->{disabled} && ! $self->{force_update}; - if ($CPAN::Signal) { - delete $self->{force_update}; - return; - } - # warn "XDEBUG: checking for notest: $self->{notest} $self"; - if ($self->{notest}) { - $CPAN::Frontend->myprint("Skipping test because of notest pragma\n"); - return 1; - } - - my $make = $self->{modulebuild} ? "Build" : "make"; - - local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) - ? $ENV{PERL5LIB} - : ($ENV{PERLLIB} || ""); - - local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; - $CPAN::META->set_perl5lib; - local $ENV{MAKEFLAGS}; # protect us from outer make calls - - $CPAN::Frontend->myprint("Running $make test\n"); - - EXCUSE: { - my @e; - if ($self->{make} or $self->{later}) { - # go ahead - } else { - push @e, - "Make had some problems, won't test"; - } - - exists $self->{make} and - ( - UNIVERSAL::can($self->{make},"failed") ? - $self->{make}->failed : - $self->{make} =~ /^NO/ - ) and push @e, "Can't test without successful make"; - $self->{badtestcnt} ||= 0; - if ($self->{badtestcnt} > 0) { - require Data::Dumper; - CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG; - push @e, "Won't repeat unsuccessful test during this command"; - } - - push @e, $self->{later} if $self->{later}; - push @e, $self->{configure_requires_later} if $self->{configure_requires_later}; - - if (exists $self->{build_dir}) { - if (exists $self->{make_test}) { - if ( - UNIVERSAL::can($self->{make_test},"failed") ? - $self->{make_test}->failed : - $self->{make_test} =~ /^NO/ - ) { - if ( - UNIVERSAL::can($self->{make_test},"commandid") - && - $self->{make_test}->commandid == $CPAN::CurrentCommandId - ) { - push @e, "Has already been tested within this command"; - } - } else { - push @e, "Has already been tested successfully"; - # if global "is_tested" has been cleared, we need to mark this to - # be added to PERL5LIB if not already installed - if ($self->tested_ok_but_not_installed) { - $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME}); - } - } - } - } elsif (!@e) { - push @e, "Has no own directory"; - } - $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; - unless (chdir $self->{build_dir}) { - push @e, "Couldn't chdir to '$self->{build_dir}': $!"; - } - $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; - } - $self->debug("Changed directory to $self->{build_dir}") - if $CPAN::DEBUG; - - if ($^O eq 'MacOS') { - Mac::BuildTools::make_test($self); - return; - } - - if ($self->{modulebuild}) { - my $thm = CPAN::Shell->expand("Module","Test::Harness"); - my $v = $thm->inst_version; - if (CPAN::Version->vlt($v,2.62)) { - # XXX Eric Wilhelm reported this as a bug: klapperl: - # Test::Harness 3.0 self-tests, so that should be 'unless - # installing Test::Harness' - unless ($self->id eq $thm->distribution->id) { - $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only - '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n}); - $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old"); - return; - } - } - } - - if ( ! $self->{force_update} ) { - # bypass actual tests if "trust_test_report_history" and have a report - my $have_tested_fcn; - if ( $CPAN::Config->{trust_test_report_history} - && $CPAN::META->has_inst("CPAN::Reporter::History") - && ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) { - if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) { - # Do nothing if grade was DISCARD - if ( $reports[-1]->{grade} =~ /^(?:PASS|UNKNOWN)$/ ) { - $self->{make_test} = CPAN::Distrostatus->new("YES"); - # if global "is_tested" has been cleared, we need to mark this to - # be added to PERL5LIB if not already installed - if ($self->tested_ok_but_not_installed) { - $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME}); - } - $CPAN::Frontend->myprint("Found prior test report -- OK\n"); - return; - } - elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) { - $self->{make_test} = CPAN::Distrostatus->new("NO"); - $self->{badtestcnt}++; - $CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n"); - return; - } - } - } - } - - my $system; - my $prefs_test = $self->prefs->{test}; - if (my $commandline - = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") { - $system = $commandline; - $ENV{PERL} = CPAN::find_perl(); - } elsif ($self->{modulebuild}) { - $system = sprintf "%s test", $self->_build_command(); - unless (-e "Build") { - my $id = $self->pretty_id; - $CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'"); - } - } else { - $system = join " ", $self->_make_command(), "test"; - } - my $make_test_arg = $self->_make_phase_arg("test"); - $system = sprintf("%s%s", - $system, - $make_test_arg ? " $make_test_arg" : "", - ); - my($tests_ok); - my %env; - while (my($k,$v) = each %ENV) { - next unless defined $v; - $env{$k} = $v; - } - local %ENV = %env; - my $test_env; - if ($self->prefs->{test}) { - $test_env = $self->prefs->{test}{env}; - } - if ($test_env) { - for my $e (keys %$test_env) { - $ENV{$e} = $test_env->{$e}; - } - } - my $expect_model = $self->_prefs_with_expect("test"); - my $want_expect = 0; - if ( $expect_model && @{$expect_model->{talk}} ) { - my $can_expect = $CPAN::META->has_inst("Expect"); - if ($can_expect) { - $want_expect = 1; - } else { - $CPAN::Frontend->mywarn("Expect not installed, falling back to ". - "testing without\n"); - } - } - if ($want_expect) { - if ($self->_should_report('test')) { - $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ". - "not supported when distroprefs specify ". - "an interactive test\n"); - } - $tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0; - } elsif ( $self->_should_report('test') ) { - $tests_ok = CPAN::Reporter::test($self, $system); - } else { - $tests_ok = system($system) == 0; - } - $self->introduce_myself; - if ( $tests_ok ) { - { - my @prereq; - - # local $CPAN::DEBUG = 16; # Distribution - for my $m (keys %{$self->{sponsored_mods}}) { - next unless $self->{sponsored_mods}{$m} > 0; - my $m_obj = CPAN::Shell->expand("Module",$m) or next; - # XXX we need available_version which reflects - # $ENV{PERL5LIB} so that already tested but not yet - # installed modules are counted. - my $available_version = $m_obj->available_version; - my $available_file = $m_obj->available_file; - if ($available_version && - !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m}) - ) { - CPAN->debug("m[$m] good enough available_version[$available_version]") - if $CPAN::DEBUG; - } elsif ($available_file - && ( - !$self->{prereq_pm}{$m} - || - $self->{prereq_pm}{$m} == 0 - ) - ) { - # lex Class::Accessor::Chained::Fast which has no $VERSION - CPAN->debug("m[$m] have available_file[$available_file]") - if $CPAN::DEBUG; - } else { - push @prereq, $m; - } - } - if (@prereq) { - my $cnt = @prereq; - my $which = join ",", @prereq; - my $but = $cnt == 1 ? "one dependency not OK ($which)" : - "$cnt dependencies missing ($which)"; - $CPAN::Frontend->mywarn("Tests succeeded but $but\n"); - $self->{make_test} = CPAN::Distrostatus->new("NO $but"); - $self->store_persistent_state; - return $self->goodbye("[dependencies] -- NA"); - } - } - - $CPAN::Frontend->myprint(" $system -- OK\n"); - $self->{make_test} = CPAN::Distrostatus->new("YES"); - $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME}); - # probably impossible to need the next line because badtestcnt - # has a lifespan of one command - delete $self->{badtestcnt}; - } else { - $self->{make_test} = CPAN::Distrostatus->new("NO"); - $self->{badtestcnt}++; - $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); - CPAN::Shell->optprint - ("hint", - sprintf - ("//hint// to see the cpan-testers results for installing this module, try: - reports %s\n", - $self->pretty_id)); - } - $self->store_persistent_state; -} - -sub _prefs_with_expect { - my($self,$where) = @_; - return unless my $prefs = $self->prefs; - return unless my $where_prefs = $prefs->{$where}; - if ($where_prefs->{expect}) { - return { - mode => "deterministic", - timeout => 15, - talk => $where_prefs->{expect}, - }; - } elsif ($where_prefs->{"eexpect"}) { - return $where_prefs->{"eexpect"}; - } - return; -} - -#-> sub CPAN::Distribution::clean ; -sub clean { - my($self) = @_; - my $make = $self->{modulebuild} ? "Build" : "make"; - $CPAN::Frontend->myprint("Running $make clean\n"); - unless (exists $self->{archived}) { - $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped". - "/untarred, nothing done\n"); - return 1; - } - unless (exists $self->{build_dir}) { - $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n"); - return 1; - } - if (exists $self->{writemakefile} - and $self->{writemakefile}->failed - ) { - $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n"); - return 1; - } - EXCUSE: { - my @e; - exists $self->{make_clean} and $self->{make_clean} eq "YES" and - push @e, "make clean already called once"; - $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; - } - chdir $self->{build_dir} or - Carp::confess("Couldn't chdir to $self->{build_dir}: $!"); - $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG; - - if ($^O eq 'MacOS') { - Mac::BuildTools::make_clean($self); - return; - } - - my $system; - if ($self->{modulebuild}) { - unless (-f "Build") { - my $cwd = CPAN::anycwd(); - $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}". - " in cwd[$cwd]. Danger, Will Robinson!"); - $CPAN::Frontend->mysleep(5); - } - $system = sprintf "%s clean", $self->_build_command(); - } else { - $system = join " ", $self->_make_command(), "clean"; - } - my $system_ok = system($system) == 0; - $self->introduce_myself; - if ( $system_ok ) { - $CPAN::Frontend->myprint(" $system -- OK\n"); - - # $self->force; - - # Jost Krieger pointed out that this "force" was wrong because - # it has the effect that the next "install" on this distribution - # will untar everything again. Instead we should bring the - # object's state back to where it is after untarring. - - for my $k (qw( - force_update - install - writemakefile - make - make_test - )) { - delete $self->{$k}; - } - $self->{make_clean} = CPAN::Distrostatus->new("YES"); - - } else { - # Hmmm, what to do if make clean failed? - - $self->{make_clean} = CPAN::Distrostatus->new("NO"); - $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n}); - - # 2006-02-27: seems silly to me to force a make now - # $self->force("make"); # so that this directory won't be used again - - } - $self->store_persistent_state; -} - -#-> sub CPAN::Distribution::goto ; -sub goto { - my($self,$goto) = @_; - $goto = $self->normalize($goto); - my $why = sprintf( - "Goto '$goto' via prefs file '%s' doc %d", - $self->{prefs_file}, - $self->{prefs_file_doc}, - ); - $self->{unwrapped} = CPAN::Distrostatus->new("NO $why"); - # 2007-07-16 akoenig : Better than NA would be if we could inherit - # the status of the $goto distro but given the exceptional nature - # of 'goto' I feel reluctant to implement it - my $goodbye_message = "[goto] -- NA $why"; - $self->goodbye($goodbye_message); - - # inject into the queue - - CPAN::Queue->delete($self->id); - CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}}); - - # and run where we left off - - my($method) = (caller(1))[3]; - CPAN->instance("CPAN::Distribution",$goto)->$method(); - CPAN::Queue->delete_first($goto); -} - -#-> sub CPAN::Distribution::install ; -sub install { - my($self) = @_; - if (my $goto = $self->prefs->{goto}) { - return $self->goto($goto); - } - unless ($self->{badtestcnt}) { - $self->test; - } - if ($CPAN::Signal) { - delete $self->{force_update}; - return; - } - my $make = $self->{modulebuild} ? "Build" : "make"; - $CPAN::Frontend->myprint("Running $make install\n"); - EXCUSE: { - my @e; - if ($self->{make} or $self->{later}) { - # go ahead - } else { - push @e, - "Make had some problems, won't install"; - } - - exists $self->{make} and - ( - UNIVERSAL::can($self->{make},"failed") ? - $self->{make}->failed : - $self->{make} =~ /^NO/ - ) and - push @e, "Make had returned bad status, install seems impossible"; - - if (exists $self->{build_dir}) { - } elsif (!@e) { - push @e, "Has no own directory"; - } - - if (exists $self->{make_test} and - ( - UNIVERSAL::can($self->{make_test},"failed") ? - $self->{make_test}->failed : - $self->{make_test} =~ /^NO/ - )) { - if ($self->{force_update}) { - $self->{make_test}->text("FAILED but failure ignored because ". - "'force' in effect"); - } else { - push @e, "make test had returned bad status, ". - "won't install without force" - } - } - if (exists $self->{install}) { - if (UNIVERSAL::can($self->{install},"text") ? - $self->{install}->text eq "YES" : - $self->{install} =~ /^YES/ - ) { - $CPAN::Frontend->myprint(" Already done\n"); - $CPAN::META->is_installed($self->{build_dir}); - return 1; - } else { - # comment in Todo on 2006-02-11; maybe retry? - push @e, "Already tried without success"; - } - } - - push @e, $self->{later} if $self->{later}; - push @e, $self->{configure_requires_later} if $self->{configure_requires_later}; - - $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; - unless (chdir $self->{build_dir}) { - push @e, "Couldn't chdir to '$self->{build_dir}': $!"; - } - $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; - } - $self->debug("Changed directory to $self->{build_dir}") - if $CPAN::DEBUG; - - if ($^O eq 'MacOS') { - Mac::BuildTools::make_install($self); - return; - } - - my $system; - if (my $commandline = $self->prefs->{install}{commandline}) { - $system = $commandline; - $ENV{PERL} = CPAN::find_perl(); - } elsif ($self->{modulebuild}) { - my($mbuild_install_build_command) = - exists $CPAN::HandleConfig::keys{mbuild_install_build_command} && - $CPAN::Config->{mbuild_install_build_command} ? - $CPAN::Config->{mbuild_install_build_command} : - $self->_build_command(); - $system = sprintf("%s install %s", - $mbuild_install_build_command, - $CPAN::Config->{mbuild_install_arg}, - ); - } else { - my($make_install_make_command) = - CPAN::HandleConfig->prefs_lookup($self, - q{make_install_make_command}) - || $self->_make_command(); - $system = sprintf("%s install %s", - $make_install_make_command, - $CPAN::Config->{make_install_arg}, - ); - } - - my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 "; - my $brip = CPAN::HandleConfig->prefs_lookup($self, - q{build_requires_install_policy}); - $brip ||="ask/yes"; - my $id = $self->id; - my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command - my $want_install = "yes"; - if ($reqtype eq "b") { - if ($brip eq "no") { - $want_install = "no"; - } elsif ($brip =~ m|^ask/(.+)|) { - my $default = $1; - $default = "yes" unless $default =~ /^(y|n)/i; - $want_install = - CPAN::Shell::colorable_makemaker_prompt - ("$id is just needed temporarily during building or testing. ". - "Do you want to install it permanently?", - $default); - } - } - unless ($want_install =~ /^y/i) { - my $is_only = "is only 'build_requires'"; - $CPAN::Frontend->mywarn("Not installing because $is_only\n"); - $self->{install} = CPAN::Distrostatus->new("NO -- $is_only"); - delete $self->{force_update}; - return; - } - local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) - ? $ENV{PERL5LIB} - : ($ENV{PERLLIB} || ""); - - local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; - $CPAN::META->set_perl5lib; - my($pipe) = FileHandle->new("$system $stderr |") || Carp::croak -("Can't execute $system: $!"); - my($makeout) = ""; - while (<$pipe>) { - print $_; # intentionally NOT use Frontend->myprint because it - # looks irritating when we markup in color what we - # just pass through from an external program - $makeout .= $_; - } - $pipe->close; - my $close_ok = $? == 0; - $self->introduce_myself; - if ( $close_ok ) { - $CPAN::Frontend->myprint(" $system -- OK\n"); - $CPAN::META->is_installed($self->{build_dir}); - $self->{install} = CPAN::Distrostatus->new("YES"); - } else { - $self->{install} = CPAN::Distrostatus->new("NO"); - $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); - my $mimc = - CPAN::HandleConfig->prefs_lookup($self, - q{make_install_make_command}); - if ( - $makeout =~ /permission/s - && $> > 0 - && ( - ! $mimc - || $mimc eq (CPAN::HandleConfig->prefs_lookup($self, - q{make})) - ) - ) { - $CPAN::Frontend->myprint( - qq{----\n}. - qq{ You may have to su }. - qq{to root to install the package\n}. - qq{ (Or you may want to run something like\n}. - qq{ o conf make_install_make_command 'sudo make'\n}. - qq{ to raise your permissions.} - ); - } - } - delete $self->{force_update}; - $self->store_persistent_state; -} - -sub introduce_myself { - my($self) = @_; - $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id)); -} - -#-> sub CPAN::Distribution::dir ; -sub dir { - shift->{build_dir}; -} - -#-> sub CPAN::Distribution::perldoc ; -sub perldoc { - my($self) = @_; - - my($dist) = $self->id; - my $package = $self->called_for; - - if ($CPAN::META->has_inst("Pod::Perldocs")) { - my($perl) = $self->perl - or $CPAN::Frontend->mydie("Couldn't find executable perl\n"); - my @args = ($perl, q{-MPod::Perldocs}, q{-e}, - q{Pod::Perldocs->run()}, $package); - my($wstatus); - unless ( ($wstatus = system(@args)) == 0 ) { - my $estatus = $wstatus >> 8; - $CPAN::Frontend->myprint(qq{ - Function system("@args") - returned status $estatus (wstat $wstatus) - }); - } - } - else { - $self->_display_url( $CPAN::Defaultdocs . $package ); - } -} - -#-> sub CPAN::Distribution::_check_binary ; -sub _check_binary { - my ($dist,$shell,$binary) = @_; - my ($pid,$out); - - $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n}) - if $CPAN::DEBUG; - - if ($CPAN::META->has_inst("File::Which")) { - return File::Which::which($binary); - } else { - local *README; - $pid = open README, "which $binary|" - or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n}); - return unless $pid; - while (<README>) { - $out .= $_; - } - close README - or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n") - and return; - } - - $CPAN::Frontend->myprint(qq{ + $out \n}) - if $CPAN::DEBUG && $out; - - return $out; -} - -#-> sub CPAN::Distribution::_display_url ; -sub _display_url { - my($self,$url) = @_; - my($res,$saved_file,$pid,$out); - - $CPAN::Frontend->myprint(qq{ + _display_url($url)\n}) - if $CPAN::DEBUG; - - # should we define it in the config instead? - my $html_converter = "html2text.pl"; - - my $web_browser = $CPAN::Config->{'lynx'} || undef; - my $web_browser_out = $web_browser - ? CPAN::Distribution->_check_binary($self,$web_browser) - : undef; - - if ($web_browser_out) { - # web browser found, run the action - my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'}); - $CPAN::Frontend->myprint(qq{system[$browser $url]}) - if $CPAN::DEBUG; - $CPAN::Frontend->myprint(qq{ -Displaying URL - $url -with browser $browser -}); - $CPAN::Frontend->mysleep(1); - system("$browser $url"); - if ($saved_file) { 1 while unlink($saved_file) } - } else { - # web browser not found, let's try text only - my $html_converter_out = - CPAN::Distribution->_check_binary($self,$html_converter); - $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out); - - if ($html_converter_out ) { - # html2text found, run it - $saved_file = CPAN::Distribution->_getsave_url( $self, $url ); - $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n}) - unless defined($saved_file); - - local *README; - $pid = open README, "$html_converter $saved_file |" - or $CPAN::Frontend->mydie(qq{ -Could not fork '$html_converter $saved_file': $!}); - my($fh,$filename); - if ($CPAN::META->has_usable("File::Temp")) { - $fh = File::Temp->new( - dir => File::Spec->tmpdir, - template => 'cpan_htmlconvert_XXXX', - suffix => '.txt', - unlink => 0, - ); - $filename = $fh->filename; - } else { - $filename = "cpan_htmlconvert_$$.txt"; - $fh = FileHandle->new(); - open $fh, ">$filename" or die; - } - while (<README>) { - $fh->print($_); - } - close README or - $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!}); - my $tmpin = $fh->filename; - $CPAN::Frontend->myprint(sprintf(qq{ -Run '%s %s' and -saved output to %s\n}, - $html_converter, - $saved_file, - $tmpin, - )) if $CPAN::DEBUG; - close $fh; - local *FH; - open FH, $tmpin - or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!}); - my $fh_pager = FileHandle->new; - local($SIG{PIPE}) = "IGNORE"; - my $pager = $CPAN::Config->{'pager'} || "cat"; - $fh_pager->open("|$pager") - or $CPAN::Frontend->mydie(qq{ -Could not open pager '$pager': $!}); - $CPAN::Frontend->myprint(qq{ -Displaying URL - $url -with pager "$pager" -}); - $CPAN::Frontend->mysleep(1); - $fh_pager->print(<FH>); - $fh_pager->close; - } else { - # coldn't find the web browser or html converter - $CPAN::Frontend->myprint(qq{ -You need to install lynx or $html_converter to use this feature.}); - } - } -} - -#-> sub CPAN::Distribution::_getsave_url ; -sub _getsave_url { - my($dist, $shell, $url) = @_; - - $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n}) - if $CPAN::DEBUG; - - my($fh,$filename); - if ($CPAN::META->has_usable("File::Temp")) { - $fh = File::Temp->new( - dir => File::Spec->tmpdir, - template => "cpan_getsave_url_XXXX", - suffix => ".html", - unlink => 0, - ); - $filename = $fh->filename; - } else { - $fh = FileHandle->new; - $filename = "cpan_getsave_url_$$.html"; - } - my $tmpin = $filename; - if ($CPAN::META->has_usable('LWP')) { - $CPAN::Frontend->myprint("Fetching with LWP: - $url -"); - my $Ua; - CPAN::LWP::UserAgent->config; - eval { $Ua = CPAN::LWP::UserAgent->new; }; - if ($@) { - $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n"); - return; - } else { - my($var); - $Ua->proxy('http', $var) - if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy}; - $Ua->no_proxy($var) - if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy}; - } - - my $req = HTTP::Request->new(GET => $url); - $req->header('Accept' => 'text/html'); - my $res = $Ua->request($req); - if ($res->is_success) { - $CPAN::Frontend->myprint(" + request successful.\n") - if $CPAN::DEBUG; - print $fh $res->content; - close $fh; - $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n}) - if $CPAN::DEBUG; - return $tmpin; - } else { - $CPAN::Frontend->myprint(sprintf( - "LWP failed with code[%s], message[%s]\n", - $res->code, - $res->message, - )); - return; - } - } else { - $CPAN::Frontend->mywarn(" LWP not available\n"); - return; - } -} - -#-> sub CPAN::Distribution::_build_command -sub _build_command { - my($self) = @_; - if ($^O eq "MSWin32") { # special code needed at least up to - # Module::Build 0.2611 and 0.2706; a fix - # in M:B has been promised 2006-01-30 - my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n"); - return "$perl ./Build"; - } - return "./Build"; -} - -#-> sub CPAN::Distribution::_should_report -sub _should_report { - my($self, $phase) = @_; - die "_should_report() requires a 'phase' argument" - if ! defined $phase; - - # configured - my $test_report = CPAN::HandleConfig->prefs_lookup($self, - q{test_report}); - return unless $test_report; - - # don't repeat if we cached a result - return $self->{should_report} - if exists $self->{should_report}; - - # don't report if we generated a Makefile.PL - if ( $self->{had_no_makefile_pl} ) { - $CPAN::Frontend->mywarn( - "Will not send CPAN Testers report with generated Makefile.PL.\n" - ); - return $self->{should_report} = 0; - } - - # available - if ( ! $CPAN::META->has_inst("CPAN::Reporter")) { - $CPAN::Frontend->mywarn( - "CPAN::Reporter not installed. No reports will be sent.\n" - ); - return $self->{should_report} = 0; - } - - # capable - my $crv = CPAN::Reporter->VERSION; - if ( CPAN::Version->vlt( $crv, 0.99 ) ) { - # don't cache $self->{should_report} -- need to check each phase - if ( $phase eq 'test' ) { - return 1; - } - else { - $CPAN::Frontend->mywarn( - "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" . - "you only have version $crv\. Only 'test' phase reports will be sent.\n" - ); - return; - } - } - - # appropriate - if ($self->is_dot_dist) { - $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ". - "for local directories\n"); - return $self->{should_report} = 0; - } - if ($self->prefs->{patches} - && - @{$self->prefs->{patches}} - && - $self->{patched} - ) { - $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ". - "when the source has been patched\n"); - return $self->{should_report} = 0; - } - - # proceed and cache success - return $self->{should_report} = 1; -} - -#-> sub CPAN::Distribution::reports -sub reports { - my($self) = @_; - my $pathname = $self->id; - $CPAN::Frontend->myprint("Distribution: $pathname\n"); - - unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) { - $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue"); - } - unless ($CPAN::META->has_usable("LWP")) { - $CPAN::Frontend->mydie("LWP not installed; cannot continue"); - } - unless ($CPAN::META->has_usable("File::Temp")) { - $CPAN::Frontend->mydie("File::Temp not installed; cannot continue"); - } - - my $d = CPAN::DistnameInfo->new($pathname); - - my $dist = $d->dist; # "CPAN-DistnameInfo" - my $version = $d->version; # "0.02" - my $maturity = $d->maturity; # "released" - my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz" - my $cpanid = $d->cpanid; # "GBARR" - my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02" - - my $url = sprintf "http://www.cpantesters.org/show/%s.yaml", $dist; - - CPAN::LWP::UserAgent->config; - my $Ua; - eval { $Ua = CPAN::LWP::UserAgent->new; }; - if ($@) { - $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n"); - } - $CPAN::Frontend->myprint("Fetching '$url'..."); - my $resp = $Ua->get($url); - unless ($resp->is_success) { - $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code); - } - $CPAN::Frontend->myprint("DONE\n\n"); - my $yaml = $resp->content; - # was fuer ein Umweg! - my $fh = File::Temp->new( - dir => File::Spec->tmpdir, - template => 'cpan_reports_XXXX', - suffix => '.yaml', - unlink => 0, - ); - my $tfilename = $fh->filename; - print $fh $yaml; - close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!"); - my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0]; - unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!"); - my %other_versions; - my $this_version_seen; - for my $rep (@$unserialized) { - my $rversion = $rep->{version}; - if ($rversion eq $version) { - unless ($this_version_seen++) { - $CPAN::Frontend->myprint ("$rep->{version}:\n"); - } - my $arch = $rep->{archname} || $rep->{platform} || '????'; - my $grade = $rep->{action} || $rep->{status} || '????'; - my $ostext = $rep->{ostext} || ucfirst($rep->{osname}) || '????'; - $CPAN::Frontend->myprint - (sprintf("%1s%1s%-4s %s on %s %s (%s)\n", - $arch eq $Config::Config{archname}?"*":"", - $grade eq "PASS"?"+":$grade eq"FAIL"?"-":"", - $grade, - $rep->{perl}, - $ostext, - $rep->{osvers}, - $arch, - )); - } else { - $other_versions{$rep->{version}}++; - } - } - unless ($this_version_seen) { - $CPAN::Frontend->myprint("No reports found for version '$version' -Reports for other versions:\n"); - for my $v (sort keys %other_versions) { - $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n"); - } - } - $url =~ s/\.yaml/.html/; - $CPAN::Frontend->myprint("See $url for details\n"); -} - -1; diff --git a/lib/CPAN/Distroprefs.pm b/lib/CPAN/Distroprefs.pm deleted file mode 100644 index e1be9cdf74..0000000000 --- a/lib/CPAN/Distroprefs.pm +++ /dev/null @@ -1,451 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: - -use strict; -package CPAN::Distroprefs; - -use vars qw($VERSION); -$VERSION = '6'; - -package CPAN::Distroprefs::Result; - -use File::Spec; - -sub new { bless $_[1] || {} => $_[0] } - -sub abs { File::Spec->catfile($_[0]->dir, $_[0]->file) } - -sub __cloner { - my ($class, $name, $newclass) = @_; - $newclass = 'CPAN::Distroprefs::Result::' . $newclass; - no strict 'refs'; - *{$class . '::' . $name} = sub { - $newclass->new({ - %{ $_[0] }, - %{ $_[1] }, - }); - }; -} -BEGIN { __PACKAGE__->__cloner(as_warning => 'Warning') } -BEGIN { __PACKAGE__->__cloner(as_fatal => 'Fatal') } -BEGIN { __PACKAGE__->__cloner(as_success => 'Success') } - -sub __accessor { - my ($class, $key) = @_; - no strict 'refs'; - *{$class . '::' . $key} = sub { $_[0]->{$key} }; -} -BEGIN { __PACKAGE__->__accessor($_) for qw(type file ext dir) } - -sub is_warning { 0 } -sub is_fatal { 0 } -sub is_success { 0 } - -package CPAN::Distroprefs::Result::Error; -use vars qw(@ISA); -BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic -BEGIN { __PACKAGE__->__accessor($_) for qw(msg) } - -sub as_string { - my ($self) = @_; - if ($self->msg) { - return sprintf $self->fmt_reason, $self->file, $self->msg; - } else { - return sprintf $self->fmt_unknown, $self->file; - } -} - -package CPAN::Distroprefs::Result::Warning; -use vars qw(@ISA); -BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic -sub is_warning { 1 } -sub fmt_reason { "Error reading distroprefs file %s, skipping: %s" } -sub fmt_unknown { "Unknown error reading distroprefs file %s, skipping." } - -package CPAN::Distroprefs::Result::Fatal; -use vars qw(@ISA); -BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic -sub is_fatal { 1 } -sub fmt_reason { "Error reading distroprefs file %s: %s" } -sub fmt_unknown { "Unknown error reading distroprefs file %s." } - -package CPAN::Distroprefs::Result::Success; -use vars qw(@ISA); -BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic -BEGIN { __PACKAGE__->__accessor($_) for qw(prefs extension) } -sub is_success { 1 } - -package CPAN::Distroprefs::Iterator; - -sub new { bless $_[1] => $_[0] } - -sub next { $_[0]->() } - -package CPAN::Distroprefs; - -use Carp (); -use DirHandle; - -sub _load_method { - my ($self, $loader, $result) = @_; - return '_load_yaml' if $loader eq 'CPAN' or $loader =~ /^YAML(::|$)/; - return '_load_' . $result->ext; -} - -sub _load_yaml { - my ($self, $loader, $result) = @_; - my $data = eval { - $loader eq 'CPAN' - ? $loader->_yaml_loadfile($result->abs) - : [ $loader->can('LoadFile')->($result->abs) ] - }; - if (my $err = $@) { - die $result->as_warning({ - msg => $err, - }); - } elsif (!$data) { - die $result->as_warning; - } else { - return @$data; - } -} - -sub _load_dd { - my ($self, $loader, $result) = @_; - my @data; - { - package CPAN::Eval; - # this caused a die in CPAN.pm, and I am leaving it 'fatal', though I'm - # not sure why we wouldn't just skip the file as we do for all other - # errors. -- hdp - my $abs = $result->abs; - open FH, "<$abs" or die $result->as_fatal(msg => "$!"); - local $/; - my $eval = <FH>; - close FH; - no strict; - eval $eval; - if (my $err = $@) { - die $result->as_warning({ msg => $err }); - } - my $i = 1; - while (${"VAR$i"}) { - push @data, ${"VAR$i"}; - $i++; - } - } - return @data; -} - -sub _load_st { - my ($self, $loader, $result) = @_; - # eval because Storable is never forward compatible - my @data = eval { @{scalar $loader->can('retrieve')->($result->abs) } }; - if (my $err = $@) { - die $result->as_warning({ msg => $err }); - } - return @data; -} - -sub find { - my ($self, $dir, $ext_map) = @_; - - my $dh = DirHandle->new($dir) or Carp::croak("Couldn't open '$dir': $!"); - my @files = sort $dh->read; - - # label the block so that we can use redo in the middle - return CPAN::Distroprefs::Iterator->new(sub { LOOP: { - return unless %$ext_map; - - local $_ = shift @files; - return unless defined; - redo if $_ eq '.' || $_ eq '..'; - - my $possible_ext = join "|", map { quotemeta } keys %$ext_map; - my ($ext) = /\.($possible_ext)$/ or redo; - my $loader = $ext_map->{$ext}; - - my $result = CPAN::Distroprefs::Result->new({ - file => $_, ext => $ext, dir => $dir - }); - # copied from CPAN.pm; is this ever actually possible? - redo unless -f $result->abs; - - my $load_method = $self->_load_method($loader, $result); - my @prefs = eval { $self->$load_method($loader, $result) }; - if (my $err = $@) { - if (ref($err) && eval { $err->isa('CPAN::Distroprefs::Result') }) { - return $err; - } - # rethrow any exceptions that we did not generate - die $err; - } elsif (!@prefs) { - # the loader should have handled this, but just in case: - return $result->as_warning; - } - return $result->as_success({ - prefs => [ - map { CPAN::Distroprefs::Pref->new({ data => $_ }) } @prefs - ], - }); - } }); -} - -package CPAN::Distroprefs::Pref; - -use Carp (); - -sub new { bless $_[1] => $_[0] } - -sub data { shift->{data} } - -sub has_any_match { $_[0]->data->{match} ? 1 : 0 } - -sub has_match { - my $match = $_[0]->data->{match} || return 0; - exists $match->{$_[1]} || exists $match->{"not_$_[1]"} -} - -sub has_valid_subkeys { - grep { exists $_[0]->data->{match}{$_} } - map { $_, "not_$_" } - $_[0]->match_attributes -} - -sub _pattern { - my $re = shift; - my $p = eval sprintf 'qr{%s}', $re; - if ($@) { - $@ =~ s/\n$//; - die "Error in Distroprefs pattern qr{$re}\n$@"; - } - return $p; -} - -sub _match_scalar { - my ($match, $data) = @_; - my $qr = _pattern($match); - return $data =~ /$qr/; -} - -sub _match_hash { - my ($match, $data) = @_; - for my $mkey (keys %$match) { - (my $dkey = $mkey) =~ s/^not_//; - my $val = defined $data->{$dkey} ? $data->{$dkey} : ''; - if (_match_scalar($match->{$mkey}, $val)) { - return 0 if $mkey =~ /^not_/; - } - else { - return 0 if $mkey !~ /^not_/; - } - } - return 1; -} - -sub _match { - my ($self, $key, $data, $matcher) = @_; - my $m = $self->data->{match}; - if (exists $m->{$key}) { - return 0 unless $matcher->($m->{$key}, $data); - } - if (exists $m->{"not_$key"}) { - return 0 if $matcher->($m->{"not_$key"}, $data); - } - return 1; -} - -sub _scalar_match { - my ($self, $key, $data) = @_; - return $self->_match($key, $data, \&_match_scalar); -} - -sub _hash_match { - my ($self, $key, $data) = @_; - return $self->_match($key, $data, \&_match_hash); -} - -# do not take the order of C<keys %$match> because "module" is by far the -# slowest -sub match_attributes { qw(env distribution perl perlconfig module) } - -sub match_module { - my ($self, $modules) = @_; - return $self->_match("module", $modules, sub { - my($match, $data) = @_; - my $qr = _pattern($match); - for my $module (@$data) { - return 1 if $module =~ /$qr/; - } - return 0; - }); -} - -sub match_distribution { shift->_scalar_match(distribution => @_) } -sub match_perl { shift->_scalar_match(perl => @_) } - -sub match_perlconfig { shift->_hash_match(perlconfig => @_) } -sub match_env { shift->_hash_match(env => @_) } - -sub matches { - my ($self, $arg) = @_; - - my $default_match = 0; - for my $key (grep { $self->has_match($_) } $self->match_attributes) { - unless (exists $arg->{$key}) { - Carp::croak "Can't match pref: missing argument key $key"; - } - $default_match = 1; - my $val = $arg->{$key}; - # make it possible to avoid computing things until we have to - if (ref($val) eq 'CODE') { $val = $val->() } - my $meth = "match_$key"; - return 0 unless $self->$meth($val); - } - - return $default_match; -} - -1; - -__END__ - -=head1 NAME - -CPAN::Distroprefs -- read and match distroprefs - -=head1 SYNOPSIS - - use CPAN::Distroprefs; - - my %info = (... distribution/environment info ...); - - my $finder = CPAN::Distroprefs->find($prefs_dir, \%ext_map); - - while (my $result = $finder->next) { - - die $result->as_string if $result->is_fatal; - - warn($result->as_string), next if $result->is_warning; - - for my $pref (@{ $result->prefs }) { - if ($pref->matches(\%info)) { - return $pref; - } - } - } - - -=head1 DESCRIPTION - -This module encapsulates reading L<Distroprefs|CPAN> and matching them against CPAN distributions. - -=head1 INTERFACE - - my $finder = CPAN::Distroprefs->find($dir, \%ext_map); - - while (my $result = $finder->next) { ... } - -Build an iterator which finds distroprefs files in the given directory. - -C<%ext_map> is a hashref whose keys are file extensions and whose values are -modules used to load matching files: - - { - 'yml' => 'YAML::Syck', - 'dd' => 'Data::Dumper', - ... - } - -Each time C<< $finder->next >> is called, the iterator returns one of two -possible values: - -=over - -=item * a CPAN::Distroprefs::Result object - -=item * C<undef>, indicating that no prefs files remain to be found - -=back - -=head1 RESULTS - -L<C<find()>|/INTERFACE> returns CPAN::Distroprefs::Result objects to -indicate success or failure when reading a prefs file. - -=head2 Common - -All results share some common attributes: - -=head3 type - -C<success>, C<warning>, or C<fatal> - -=head3 file - -the file from which these prefs were read, or to which this error refers (relative filename) - -=head3 ext - -the file's extension, which determines how to load it - -=head3 dir - -the directory the file was read from - -=head3 abs - -the absolute path to the file - -=head2 Errors - -Error results (warning and fatal) contain: - -=head3 msg - -the error message (usually either C<$!> or a YAML error) - -=head2 Successes - -Success results contain: - -=head3 prefs - -an arrayref of CPAN::Distroprefs::Pref objects - -=head1 PREFS - -CPAN::Distroprefs::Pref objects represent individual distroprefs documents. -They are constructed automatically as part of C<success> results from C<find()>. - -=head3 data - -the pref information as a hashref, suitable for e.g. passing to Kwalify - -=head3 match_attributes - -returns a list of the valid match attributes (see the Distroprefs section in L<CPAN>) - -currently: C<env perl perlconfig distribution module> - -=head3 has_any_match - -true if this pref has a 'match' attribute at all - -=head3 has_valid_subkeys - -true if this pref has a 'match' attribute and at least one valid match attribute - -=head3 matches - - if ($pref->matches(\%arg)) { ... } - -true if this pref matches the passed-in hashref, which must have a value for -each of the C<match_attributes> (above) - -=head1 LICENSE - -This program is free software; you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut diff --git a/lib/CPAN/Distrostatus.pm b/lib/CPAN/Distrostatus.pm deleted file mode 100644 index 0cc6cc9a79..0000000000 --- a/lib/CPAN/Distrostatus.pm +++ /dev/null @@ -1,45 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::Distrostatus; -use overload '""' => "as_string", - fallback => 1; -use vars qw($something_has_failed_at); -use vars qw( - $VERSION -); -$VERSION = "5.5"; - - -sub new { - my($class,$arg) = @_; - my $failed = substr($arg,0,2) eq "NO"; - if ($failed) { - $something_has_failed_at = $CPAN::CurrentCommandId; - } - bless { - TEXT => $arg, - FAILED => $failed, - COMMANDID => $CPAN::CurrentCommandId, - TIME => time, - }, $class; -} -sub something_has_just_failed () { - defined $something_has_failed_at && - $something_has_failed_at == $CPAN::CurrentCommandId; -} -sub commandid { shift->{COMMANDID} } -sub failed { shift->{FAILED} } -sub text { - my($self,$set) = @_; - if (defined $set) { - $self->{TEXT} = $set; - } - $self->{TEXT}; -} -sub as_string { - my($self) = @_; - $self->text; -} - - -1; diff --git a/lib/CPAN/Exception/RecursiveDependency.pm b/lib/CPAN/Exception/RecursiveDependency.pm deleted file mode 100644 index b928ad74e3..0000000000 --- a/lib/CPAN/Exception/RecursiveDependency.pm +++ /dev/null @@ -1,85 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::Exception::RecursiveDependency; -use strict; -use overload '""' => "as_string"; - -use vars qw( - $VERSION -); -$VERSION = "5.5"; - -# a module sees its distribution (no version) -# a distribution sees its prereqs (which are module names) (usually with versions) -# a bundle sees its module names and/or its distributions (no version) - -sub new { - my($class) = shift; - my($deps_arg) = shift; - my (@deps,%seen,$loop_starts_with); - DCHAIN: for my $dep (@$deps_arg) { - push @deps, {name => $dep, display_as => $dep}; - if ($seen{$dep}++) { - $loop_starts_with = $dep; - last DCHAIN; - } - } - my $in_loop = 0; - for my $i (0..$#deps) { - my $x = $deps[$i]{name}; - $in_loop ||= $loop_starts_with && $x eq $loop_starts_with; - my $xo = CPAN::Shell->expandany($x) or next; - if ($xo->isa("CPAN::Module")) { - my $have = $xo->inst_version || "N/A"; - my($want,$d,$want_type); - if ($i>0 and $d = $deps[$i-1]{name}) { - my $do = CPAN::Shell->expandany($d); - $want = $do->{prereq_pm}{requires}{$x}; - if (defined $want) { - $want_type = "requires: "; - } else { - $want = $do->{prereq_pm}{build_requires}{$x}; - if (defined $want) { - $want_type = "build_requires: "; - } else { - $want_type = "unknown status"; - $want = "???"; - } - } - } else { - $want = $xo->cpan_version; - $want_type = "want: "; - } - $deps[$i]{have} = $have; - $deps[$i]{want_type} = $want_type; - $deps[$i]{want} = $want; - $deps[$i]{display_as} = "$x (have: $have; $want_type$want)"; - } elsif ($xo->isa("CPAN::Distribution")) { - $deps[$i]{display_as} = $xo->pretty_id; - if ($in_loop) { - $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency"); - } else { - $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency"); - } - $xo->store_persistent_state; # otherwise I will not reach - # all involved parties for - # the next session - } - } - bless { deps => \@deps, loop_starts_with => $loop_starts_with }, $class; -} - -sub as_string { - my($self) = shift; - my $deps = $self->{deps}; - my $loop_starts_with = $self->{loop_starts_with}; - unless ($loop_starts_with) { - return "--not a recursive/circular dependency--"; - } - my $ret = "\nRecursive dependency detected:\n "; - $ret .= join("\n => ", map {$_->{display_as}} @$deps); - $ret .= ".\nCannot resolve.\n"; - $ret; -} - -1; diff --git a/lib/CPAN/Exception/blocked_urllist.pm b/lib/CPAN/Exception/blocked_urllist.pm deleted file mode 100644 index 102c194e61..0000000000 --- a/lib/CPAN/Exception/blocked_urllist.pm +++ /dev/null @@ -1,46 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::Exception::blocked_urllist; -use strict; -use overload '""' => "as_string"; - -use vars qw( - $VERSION -); -$VERSION = "1.0"; - - -sub new { - my($class) = @_; - bless {}, $class; -} - -sub as_string { - my($self) = shift; - if ($CPAN::Config->{connect_to_internet_ok}) { - return qq{ - -You have not configured a urllist for CPAN mirrors. Configure it with - - o conf init urllist - -}; - } else { - return qq{ - -You have not configured a urllist and do not allow connections to the -internet to get a list of mirrors. If you wish to get a list of CPAN -mirrors to pick from, use this command - - o conf init connect_to_internet_ok urllist - -If you do not wish to get a list of mirrors and would prefer to set -your urllist manually, use just this command instead - - o conf init urllist - -}; - } -} - -1; diff --git a/lib/CPAN/Exception/yaml_not_installed.pm b/lib/CPAN/Exception/yaml_not_installed.pm deleted file mode 100644 index e1259e5397..0000000000 --- a/lib/CPAN/Exception/yaml_not_installed.pm +++ /dev/null @@ -1,73 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::Exception::yaml_not_installed; -use strict; -use overload '""' => "as_string"; - -use vars qw( - $VERSION -); -$VERSION = "5.5"; - - -sub new { - my($class,$module,$file,$during) = @_; - bless { module => $module, file => $file, during => $during }, $class; -} - -sub as_string { - my($self) = shift; - "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n"; -} - -package CPAN::Exception::yaml_process_error; -use strict; -use overload '""' => "as_string"; - -use vars qw( - $VERSION -); -$VERSION = "5.5"; - - -sub new { - my($class,$module,$file,$during,$error) = @_; - # my $at = Carp::longmess(""); # XXX find something more beautiful - bless { module => $module, - file => $file, - during => $during, - error => $error, - # at => $at, - }, $class; -} - -sub as_string { - my($self) = shift; - if ($self->{during}) { - if ($self->{file}) { - if ($self->{module}) { - if ($self->{error}) { - return "Alert: While trying to '$self->{during}' YAML file\n". - " '$self->{file}'\n". - "with '$self->{module}' the following error was encountered:\n". - " $self->{error}\n"; - } else { - return "Alert: While trying to '$self->{during}' YAML file\n". - " '$self->{file}'\n". - "with '$self->{module}' some unknown error was encountered\n"; - } - } else { - return "Alert: While trying to '$self->{during}' YAML file\n". - " '$self->{file}'\n". - "some unknown error was encountered\n"; - } - } else { - return "Alert: While trying to '$self->{during}' some YAML file\n". - "some unknown error was encountered\n"; - } - } else { - return "Alert: unknown error encountered\n"; - } -} - -1; diff --git a/lib/CPAN/FTP.pm b/lib/CPAN/FTP.pm deleted file mode 100644 index fab3d123ef..0000000000 --- a/lib/CPAN/FTP.pm +++ /dev/null @@ -1,1090 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::FTP; -use strict; - -use Fcntl qw(:flock); -use File::Basename qw(dirname); -use File::Path qw(mkpath); -use CPAN::FTP::netrc; -use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod); -@CPAN::FTP::ISA = qw(CPAN::Debug); - -use vars qw( - $VERSION -); -$VERSION = "5.5001"; - -#-> sub CPAN::FTP::ftp_statistics -# if they want to rewrite, they need to pass in a filehandle -sub _ftp_statistics { - my($self,$fh) = @_; - my $locktype = $fh ? LOCK_EX : LOCK_SH; - $fh ||= FileHandle->new; - my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml"); - mkpath dirname $file; - open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!"); - my $sleep = 1; - my $waitstart; - while (!CPAN::_flock($fh, $locktype|LOCK_NB)) { - $waitstart ||= localtime(); - if ($sleep>3) { - $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n"); - } - $CPAN::Frontend->mysleep($sleep); - if ($sleep <= 3) { - $sleep+=0.33; - } elsif ($sleep <=6) { - $sleep+=0.11; - } - } - my $stats = eval { CPAN->_yaml_loadfile($file); }; - if ($@) { - if (ref $@) { - if (ref $@ eq "CPAN::Exception::yaml_not_installed") { - $CPAN::Frontend->myprint("Warning (usually harmless): $@"); - return; - } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") { - $CPAN::Frontend->mydie($@); - } - } else { - $CPAN::Frontend->mydie($@); - } - } - return $stats->[0]; -} - -#-> sub CPAN::FTP::_mytime -sub _mytime () { - if (CPAN->has_inst("Time::HiRes")) { - return Time::HiRes::time(); - } else { - return time; - } -} - -#-> sub CPAN::FTP::_new_stats -sub _new_stats { - my($self,$file) = @_; - my $ret = { - file => $file, - attempts => [], - start => _mytime, - }; - $ret; -} - -#-> sub CPAN::FTP::_add_to_statistics -sub _add_to_statistics { - my($self,$stats) = @_; - my $yaml_module = CPAN::_yaml_module(); - $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG; - if ($CPAN::META->has_inst($yaml_module)) { - $stats->{thesiteurl} = $ThesiteURL; - $stats->{end} = CPAN::FTP::_mytime(); - my $fh = FileHandle->new; - my $time = time; - my $sdebug = 0; - my @debug; - @debug = $time if $sdebug; - my $fullstats = $self->_ftp_statistics($fh); - close $fh; - $fullstats->{history} ||= []; - push @debug, scalar @{$fullstats->{history}} if $sdebug; - push @debug, time if $sdebug; - push @{$fullstats->{history}}, $stats; - # YAML.pm 0.62 is unacceptably slow with 999; - # YAML::Syck 0.82 has no noticable performance problem with 999; - my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99; - my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14; - while ( - @{$fullstats->{history}} > $ftpstats_size - || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period - ) { - shift @{$fullstats->{history}} - } - push @debug, scalar @{$fullstats->{history}} if $sdebug; - push @debug, time if $sdebug; - push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug; - # need no eval because if this fails, it is serious - my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml"); - CPAN->_yaml_dumpfile("$sfile.$$",$fullstats); - if ( $sdebug ) { - local $CPAN::DEBUG = 512; # FTP - push @debug, time; - CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]". - "after[%d]at[%d]oldest[%s]dumped backat[%d]", - @debug, - )); - } - # Win32 cannot rename a file to an existing filename - unlink($sfile) if ($^O eq 'MSWin32'); - _copy_stat($sfile, "$sfile.$$") if -e $sfile; - rename "$sfile.$$", $sfile - or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n"); - } -} - -# Copy some stat information (owner, group, mode and) from one file to -# another. -# This is a utility function which might be moved to a utility repository. -#-> sub CPAN::FTP::_copy_stat -sub _copy_stat { - my($src, $dest) = @_; - my @stat = stat($src); - if (!@stat) { - $CPAN::Frontend->mywarn("Can't stat '$src': $!\n"); - return; - } - - eval { - chmod $stat[2], $dest - or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n"); - }; - warn $@ if $@; - eval { - chown $stat[4], $stat[5], $dest - or do { - my $save_err = $!; # otherwise it's lost in the get... calls - $CPAN::Frontend->mywarn("Can't chown '$dest' to " . - (getpwuid($stat[4]))[0] . "/" . - (getgrgid($stat[5]))[0] . ": $save_err\n" - ); - }; - }; - warn $@ if $@; -} - -# if file is CHECKSUMS, suggest the place where we got the file to be -# checked from, maybe only for young files? -#-> sub CPAN::FTP::_recommend_url_for -sub _recommend_url_for { - my($self, $file) = @_; - my $urllist = $self->_get_urllist; - if ($file =~ s|/CHECKSUMS(.gz)?$||) { - my $fullstats = $self->_ftp_statistics(); - my $history = $fullstats->{history} || []; - while (my $last = pop @$history) { - last if $last->{end} - time > 3600; # only young results are interesting - next unless $last->{file}; # dirname of nothing dies! - next unless $file eq dirname($last->{file}); - return $last->{thesiteurl}; - } - } - if ($CPAN::Config->{randomize_urllist} - && - rand(1) < $CPAN::Config->{randomize_urllist} - ) { - $urllist->[int rand scalar @$urllist]; - } else { - return (); - } -} - -#-> sub CPAN::FTP::_get_urllist -sub _get_urllist { - my($self) = @_; - $CPAN::Config->{urllist} ||= []; - unless (ref $CPAN::Config->{urllist} eq 'ARRAY') { - $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n"); - $CPAN::Config->{urllist} = []; - } - my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}}; - for my $u (@urllist) { - CPAN->debug("u[$u]") if $CPAN::DEBUG; - if (UNIVERSAL::can($u,"text")) { - $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/"; - } else { - $u .= "/" unless substr($u,-1) eq "/"; - $u = CPAN::URL->new(TEXT => $u, FROM => "USER"); - } - } - \@urllist; -} - -#-> sub CPAN::FTP::ftp_get ; -sub ftp_get { - my($class,$host,$dir,$file,$target) = @_; - $class->debug( - qq[Going to fetch file [$file] from dir [$dir] - on host [$host] as local [$target]\n] - ) if $CPAN::DEBUG; - my $ftp = Net::FTP->new($host); - unless ($ftp) { - $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n"); - return; - } - return 0 unless defined $ftp; - $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; - $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]); - unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) { - my $msg = $ftp->message; - $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg"); - return; - } - unless ( $ftp->cwd($dir) ) { - my $msg = $ftp->message; - $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg"); - return; - } - $ftp->binary; - $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; - unless ( $ftp->get($file,$target) ) { - my $msg = $ftp->message; - $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg"); - return; - } - $ftp->quit; # it's ok if this fails - return 1; -} - -# If more accuracy is wanted/needed, Chris Leach sent me this patch... - - # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997 - # > --- /tmp/cp Wed Sep 24 13:26:40 1997 - # > *************** - # > *** 1562,1567 **** - # > --- 1562,1580 ---- - # > return 1 if substr($url,0,4) eq "file"; - # > return 1 unless $url =~ m|://([^/]+)|; - # > my $host = $1; - # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'}; - # > + if ($proxy) { - # > + $proxy =~ m|://([^/:]+)|; - # > + $proxy = $1; - # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'}; - # > + if ($noproxy) { - # > + if ($host !~ /$noproxy$/) { - # > + $host = $proxy; - # > + } - # > + } else { - # > + $host = $proxy; - # > + } - # > + } - # > require Net::Ping; - # > return 1 unless $Net::Ping::VERSION >= 2; - # > my $p; - - -#-> sub CPAN::FTP::localize ; -sub localize { - my($self,$file,$aslocal,$force) = @_; - $force ||= 0; - Carp::croak( "Usage: ->localize(cpan_file,as_local_file[,$force])" ) - unless defined $aslocal; - if ($CPAN::DEBUG){ - require Carp; - my $longmess = Carp::longmess(); - $self->debug("file[$file] aslocal[$aslocal] force[$force] carplongmess[$longmess]"); - } - if ($^O eq 'MacOS') { - # Comment by AK on 2000-09-03: Uniq short filenames would be - # available in CHECKSUMS file - my($name, $path) = File::Basename::fileparse($aslocal, ''); - if (length($name) > 31) { - $name =~ s/( - \.( - readme(\.(gz|Z))? | - (tar\.)?(gz|Z) | - tgz | - zip | - pm\.(gz|Z) - ) - )$//x; - my $suf = $1; - my $size = 31 - length($suf); - while (length($name) > $size) { - chop $name; - } - $name .= $suf; - $aslocal = File::Spec->catfile($path, $name); - } - } - - if (-f $aslocal && -r _ && !($force & 1)) { - my $size; - if ($size = -s $aslocal) { - $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG; - return $aslocal; - } else { - # empty file from a previous unsuccessful attempt to download it - unlink $aslocal or - $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ". - "could not remove."); - } - } - my($maybe_restore) = 0; - if (-f $aslocal) { - rename $aslocal, "$aslocal.bak$$"; - $maybe_restore++; - } - - my($aslocal_dir) = dirname($aslocal); - # Inheritance is not easier to manage than a few if/else branches - if ($CPAN::META->has_usable('LWP::UserAgent')) { - unless ($Ua) { - CPAN::LWP::UserAgent->config; - eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough? - if ($@) { - $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n") - if $CPAN::DEBUG; - } else { - my($var); - $Ua->proxy('ftp', $var) - if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy}; - $Ua->proxy('http', $var) - if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy}; - $Ua->no_proxy($var) - if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy}; - } - } - } - for my $prx (qw(ftp_proxy http_proxy no_proxy)) { - $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx}; - } - - # Try the list of urls for each single object. We keep a record - # where we did get a file from - my(@reordered,$last); - my $ccurllist = $self->_get_urllist; - $last = $#$ccurllist; - if ($force & 2) { # local cpans probably out of date, don't reorder - @reordered = (0..$last); - } else { - @reordered = - sort { - (substr($ccurllist->[$b],0,4) eq "file") - <=> - (substr($ccurllist->[$a],0,4) eq "file") - or - defined($ThesiteURL) - and - ($ccurllist->[$b] eq $ThesiteURL) - <=> - ($ccurllist->[$a] eq $ThesiteURL) - } 0..$last; - } - my(@levels); - $Themethod ||= ""; - $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG; - my @all_levels = ( - ["dleasy", "file"], - ["dleasy"], - ["dlhard"], - ["dlhardest"], - ["dleasy", "http","defaultsites"], - ["dlhard", "http","defaultsites"], - ["dleasy", "ftp", "defaultsites"], - ["dlhard", "ftp", "defaultsites"], - ["dlhardest","", "defaultsites"], - ); - if ($Themethod) { - @levels = grep {$_->[0] eq $Themethod} @all_levels; - push @levels, grep {$_->[0] ne $Themethod} @all_levels; - } else { - @levels = @all_levels; - } - @levels = qw/dleasy/ if $^O eq 'MacOS'; - my($levelno); - local $ENV{FTP_PASSIVE} = - exists $CPAN::Config->{ftp_passive} ? - $CPAN::Config->{ftp_passive} : 1; - my $ret; - my $stats = $self->_new_stats($file); - for ($CPAN::Config->{connect_to_internet_ok}) { - $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_; - } - LEVEL: for $levelno (0..$#levels) { - my $level_tuple = $levels[$levelno]; - my($level,$scheme,$sitetag) = @$level_tuple; - $self->mymkpath($aslocal_dir) unless $scheme && "file" eq $scheme; - my $defaultsites = $sitetag && $sitetag eq "defaultsites"; - my @urllist; - if ($defaultsites) { - unless (defined $connect_to_internet_ok) { - $CPAN::Frontend->myprint(sprintf qq{ -I would like to connect to one of the following sites to get '%s': - -%s -}, - $file, - join("",map { " ".$_->text."\n" } @CPAN::Defaultsites), - ); - my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes"); - if ($answer =~ /^y/i) { - $connect_to_internet_ok = 1; - } else { - $connect_to_internet_ok = 0; - } - } - if ($connect_to_internet_ok) { - @urllist = @CPAN::Defaultsites; - } else { - my $sleep = 2; - # the tricky thing about dying here is that everybody - # believes that calls to exists() or all_objects() are - # safe. - require CPAN::Exception::blocked_urllist; - die CPAN::Exception::blocked_urllist->new; - } - } else { - my @host_seq = $level =~ /dleasy/ ? - @reordered : 0..$last; # reordered has file and $Thesiteurl first - @urllist = map { $ccurllist->[$_] } @host_seq; - } - $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG; - my $aslocal_tempfile = $aslocal . ".tmp" . $$; - if (my $recommend = $self->_recommend_url_for($file)) { - @urllist = grep { $_ ne $recommend } @urllist; - unshift @urllist, $recommend; - } - $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG; - $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats); - if ($ret) { - CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG; - if ($ret eq $aslocal_tempfile) { - # if we got it exactly as we asked for, only then we - # want to rename - rename $aslocal_tempfile, $aslocal - or $CPAN::Frontend->mydie("Error while trying to rename ". - "'$ret' to '$aslocal': $!"); - $ret = $aslocal; - } - $Themethod = $level; - my $now = time; - # utime $now, $now, $aslocal; # too bad, if we do that, we - # might alter a local mirror - $self->debug("level[$level]") if $CPAN::DEBUG; - last LEVEL; - } else { - unlink $aslocal_tempfile; - last if $CPAN::Signal; # need to cleanup - } - } - if ($ret) { - $stats->{filesize} = -s $ret; - } - $self->debug("before _add_to_statistics") if $CPAN::DEBUG; - $self->_add_to_statistics($stats); - $self->debug("after _add_to_statistics") if $CPAN::DEBUG; - if ($ret) { - unlink "$aslocal.bak$$"; - return $ret; - } - unless ($CPAN::Signal) { - my(@mess); - local $" = " "; - if (@{$CPAN::Config->{urllist}}) { - push @mess, - qq{Please check, if the URLs I found in your configuration file \(}. - join(", ", @{$CPAN::Config->{urllist}}). - qq{\) are valid.}; - } else { - push @mess, qq{Your urllist is empty!}; - } - push @mess, qq{The urllist can be edited.}, - qq{E.g. with 'o conf urllist push ftp://myurl/'}; - $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n"); - $CPAN::Frontend->mydie("Could not fetch $file\n"); - } - if ($maybe_restore) { - rename "$aslocal.bak$$", $aslocal; - $CPAN::Frontend->myprint("Trying to get away with old file:\n" . - $self->ls($aslocal)); - return $aslocal; - } - return; -} - -sub mymkpath { - my($self, $aslocal_dir) = @_; - mkpath($aslocal_dir); - $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }. - qq{directory "$aslocal_dir". - I\'ll continue, but if you encounter problems, they may be due - to insufficient permissions.\n}) unless -w $aslocal_dir; -} - -sub hostdlxxx { - my $self = shift; - my $level = shift; - my $scheme = shift; - my $h = shift; - $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme; - my $method = "host$level"; - $self->$method($h, @_); -} - -sub _set_attempt { - my($self,$stats,$method,$url) = @_; - push @{$stats->{attempts}}, { - method => $method, - start => _mytime, - url => $url, - }; -} - -# package CPAN::FTP; -sub hostdleasy { #called from hostdlxxx - my($self,$host_seq,$file,$aslocal,$stats) = @_; - my($ro_url); - HOSTEASY: for $ro_url (@$host_seq) { - $self->_set_attempt($stats,"dleasy",$ro_url); - my $url .= "$ro_url$file"; - $self->debug("localizing perlish[$url]") if $CPAN::DEBUG; - if ($url =~ /^file:/) { - my $l; - if ($CPAN::META->has_inst('URI::URL')) { - my $u = URI::URL->new($url); - $l = $u->path; - } else { # works only on Unix, is poorly constructed, but - # hopefully better than nothing. - # RFC 1738 says fileurl BNF is - # fileurl = "file://" [ host | "localhost" ] "/" fpath - # Thanks to "Mark D. Baushke" <mdb@cisco.com> for - # the code - ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part - $l =~ s|^file:||; # assume they - # meant - # file://localhost - $l =~ s|^/||s - if ! -f $l && $l =~ m|^/\w:|; # e.g. /P: - } - $self->debug("local file[$l]") if $CPAN::DEBUG; - if ( -f $l && -r _) { - $ThesiteURL = $ro_url; - return $l; - } - if ($l =~ /(.+)\.gz$/) { - my $ungz = $1; - if ( -f $ungz && -r _) { - $ThesiteURL = $ro_url; - return $ungz; - } - } - # Maybe mirror has compressed it? - if (-f "$l.gz") { - $self->debug("found compressed $l.gz") if $CPAN::DEBUG; - eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) }; - if ( -f $aslocal) { - $ThesiteURL = $ro_url; - return $aslocal; - } - } - $CPAN::Frontend->mywarn("Could not find '$l'\n"); - } - $self->debug("it was not a file URL") if $CPAN::DEBUG; - if ($CPAN::META->has_usable('LWP')) { - $CPAN::Frontend->myprint("Fetching with LWP: - $url -"); - unless ($Ua) { - CPAN::LWP::UserAgent->config; - eval { $Ua = CPAN::LWP::UserAgent->new; }; - if ($@) { - $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n"); - } - } - my $res = $Ua->mirror($url, $aslocal); - if ($res->is_success) { - $ThesiteURL = $ro_url; - my $now = time; - utime $now, $now, $aslocal; # download time is more - # important than upload - # time - return $aslocal; - } elsif ($url !~ /\.gz(?!\n)\Z/) { - my $gzurl = "$url.gz"; - $CPAN::Frontend->myprint("Fetching with LWP: - $gzurl -"); - $res = $Ua->mirror($gzurl, "$aslocal.gz"); - if ($res->is_success) { - if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) { - $ThesiteURL = $ro_url; - return $aslocal; - } - } - } else { - $CPAN::Frontend->myprint(sprintf( - "LWP failed with code[%s] message[%s]\n", - $res->code, - $res->message, - )); - # Alan Burlison informed me that in firewall environments - # Net::FTP can still succeed where LWP fails. So we do not - # skip Net::FTP anymore when LWP is available. - } - } else { - $CPAN::Frontend->mywarn(" LWP not available\n"); - } - return if $CPAN::Signal; - if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { - # that's the nice and easy way thanks to Graham - $self->debug("recognized ftp") if $CPAN::DEBUG; - my($host,$dir,$getfile) = ($1,$2,$3); - if ($CPAN::META->has_usable('Net::FTP')) { - $dir =~ s|/+|/|g; - $CPAN::Frontend->myprint("Fetching with Net::FTP: - $url -"); - $self->debug("getfile[$getfile]dir[$dir]host[$host]" . - "aslocal[$aslocal]") if $CPAN::DEBUG; - if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) { - $ThesiteURL = $ro_url; - return $aslocal; - } - if ($aslocal !~ /\.gz(?!\n)\Z/) { - my $gz = "$aslocal.gz"; - $CPAN::Frontend->myprint("Fetching with Net::FTP - $url.gz -"); - if (CPAN::FTP->ftp_get($host, - $dir, - "$getfile.gz", - $gz) && - eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)} - ) { - $ThesiteURL = $ro_url; - return $aslocal; - } - } - # next HOSTEASY; - } else { - CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG; - } - } - if ( - UNIVERSAL::can($ro_url,"text") - and - $ro_url->{FROM} eq "USER" - ) { - ##address #17973: default URLs should not try to override - ##user-defined URLs just because LWP is not available - my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats); - return $ret if $ret; - } - return if $CPAN::Signal; - } -} - -# package CPAN::FTP; -sub hostdlhard { - my($self,$host_seq,$file,$aslocal,$stats) = @_; - - # Came back if Net::FTP couldn't establish connection (or - # failed otherwise) Maybe they are behind a firewall, but they - # gave us a socksified (or other) ftp program... - - my($ro_url); - my($devnull) = $CPAN::Config->{devnull} || ""; - # < /dev/null "; - my($aslocal_dir) = dirname($aslocal); - mkpath($aslocal_dir); - my $some_dl_success = 0; - HOSTHARD: for $ro_url (@$host_seq) { - $self->_set_attempt($stats,"dlhard",$ro_url); - my $url = "$ro_url$file"; - my($proto,$host,$dir,$getfile); - - # Courtesy Mark Conty mark_conty@cargill.com change from - # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { - # to - if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) { - # proto not yet used - ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4); - } else { - next HOSTHARD; # who said, we could ftp anything except ftp? - } - next HOSTHARD if $proto eq "file"; # file URLs would have had - # success above. Likely a bogus URL - - $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; - - # Try the most capable first and leave ncftp* for last as it only - # does FTP. - my $proxy_vars = $self->_proxy_vars($ro_url); - DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) { - my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f}); - next DLPRG unless defined $funkyftp; - next DLPRG if $funkyftp =~ /^\s*$/; - - my($asl_ungz, $asl_gz); - ($asl_ungz = $aslocal) =~ s/\.gz//; - $asl_gz = "$asl_ungz.gz"; - - my($src_switch) = ""; - my($chdir) = ""; - my($stdout_redir) = " > $asl_ungz"; - if ($f eq "lynx") { - $src_switch = " -source"; - } elsif ($f eq "ncftp") { - $src_switch = " -c"; - } elsif ($f eq "wget") { - $src_switch = " -O $asl_ungz"; - $stdout_redir = ""; - } elsif ($f eq 'curl') { - $src_switch = ' -L -f -s -S --netrc-optional'; - if ($proxy_vars->{http_proxy}) { - $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"}; - } - } - - if ($f eq "ncftpget") { - $chdir = "cd $aslocal_dir && "; - $stdout_redir = ""; - } - $CPAN::Frontend->myprint( - qq[ -Trying with "$funkyftp$src_switch" to get - "$url" -]); - my($system) = - "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir"; - $self->debug("system[$system]") if $CPAN::DEBUG; - my($wstatus) = system($system); - if ($f eq "lynx") { - # lynx returns 0 when it fails somewhere - if (-s $asl_ungz) { - my $content = do { local *FH; - open FH, $asl_ungz or die; - local $/; - <FH> }; - if ($content =~ /^<.*(<title>[45]|Error [45])/si) { - $CPAN::Frontend->mywarn(qq{ -No success, the file that lynx has downloaded looks like an error message: -$content -}); - $CPAN::Frontend->mysleep(1); - next DLPRG; - } - $some_dl_success++; - } else { - $CPAN::Frontend->myprint(qq{ -No success, the file that lynx has downloaded is an empty file. -}); - next DLPRG; - } - } - if ($wstatus == 0) { - if (-s $aslocal) { - # Looks good - $some_dl_success++; - } elsif ($asl_ungz ne $aslocal) { - # test gzip integrity - if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) { - # e.g. foo.tar is gzipped --> foo.tar.gz - rename $asl_ungz, $aslocal; - $some_dl_success++; - } else { - eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)}; - if ($@) { - warn "Warning: $@"; - } else { - $some_dl_success++; - } - } - } - $ThesiteURL = $ro_url; - return $aslocal; - } elsif ($url !~ /\.gz(?!\n)\Z/) { - unlink $asl_ungz if - -f $asl_ungz && -s _ == 0; - my $gz = "$aslocal.gz"; - my $gzurl = "$url.gz"; - $CPAN::Frontend->myprint( - qq[ - Trying with "$funkyftp$src_switch" to get - "$url.gz" - ]); - my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz"; - $self->debug("system[$system]") if $CPAN::DEBUG; - my($wstatus); - if (($wstatus = system($system)) == 0 - && - -s $asl_gz - ) { - # test gzip integrity - my $ct = eval{CPAN::Tarzip->new($asl_gz)}; - if ($ct && $ct->gtest) { - $ct->gunzip($aslocal); - } else { - # somebody uncompressed file for us? - rename $asl_ungz, $aslocal; - } - $ThesiteURL = $ro_url; - return $aslocal; - } else { - unlink $asl_gz if -f $asl_gz; - } - } else { - my $estatus = $wstatus >> 8; - my $size = -f $aslocal ? - ", left\n$aslocal with size ".-s _ : - "\nWarning: expected file [$aslocal] doesn't exist"; - $CPAN::Frontend->myprint(qq{ - Function system("$system") - returned status $estatus (wstat $wstatus)$size - }); - } - return if $CPAN::Signal; - } # download/transfer programs (DLPRG) - } # host - require Carp; - if ($some_dl_success) { - Carp::carp("Warning: doesn't seem we had substantial success downloading '$aslocal'. Don't know how to proceed."); - } else { - Carp::carp("Warning: no success downloading '$aslocal'. Giving up on it."); - } - $CPAN::Frontend->mysleep(5); - return; -} - -#-> CPAN::FTP::_proxy_vars -sub _proxy_vars { - my($self,$url) = @_; - my $ret = +{}; - my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'}; - if ($http_proxy) { - my($host) = $url =~ m|://([^/:]+)|; - my $want_proxy = 1; - my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || ""; - my @noproxy = split /\s*,\s*/, $noproxy; - if ($host) { - DOMAIN: for my $domain (@noproxy) { - if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent - $want_proxy = 0; - last DOMAIN; - } - } - } else { - $CPAN::Frontend->mywarn(" Could not determine host from http_proxy '$http_proxy'\n"); - } - if ($want_proxy) { - my($user, $pass) = - &CPAN::LWP::UserAgent::get_proxy_credentials(); - $ret = { - proxy_user => $user, - proxy_pass => $pass, - http_proxy => $http_proxy - }; - } - } - return $ret; -} - -# package CPAN::FTP; -sub hostdlhardest { - my($self,$host_seq,$file,$aslocal,$stats) = @_; - - return unless @$host_seq; - my($ro_url); - my($aslocal_dir) = dirname($aslocal); - mkpath($aslocal_dir); - my $ftpbin = $CPAN::Config->{ftp}; - unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) { - $CPAN::Frontend->myprint("No external ftp command available\n\n"); - return; - } - $CPAN::Frontend->mywarn(qq{ -As a last resort we now switch to the external ftp command '$ftpbin' -to get '$aslocal'. - -Doing so often leads to problems that are hard to diagnose. - -If you're the victim of such problems, please consider unsetting the -ftp config variable with - - o conf ftp "" - o conf commit - -}); - $CPAN::Frontend->mysleep(2); - HOSTHARDEST: for $ro_url (@$host_seq) { - $self->_set_attempt($stats,"dlhardest",$ro_url); - my $url = "$ro_url$file"; - $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG; - unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { - next; - } - my($host,$dir,$getfile) = ($1,$2,$3); - my $timestamp = 0; - my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime, - $ctime,$blksize,$blocks) = stat($aslocal); - $timestamp = $mtime ||= 0; - my($netrc) = CPAN::FTP::netrc->new; - my($netrcfile) = $netrc->netrc; - my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : ""; - my $targetfile = File::Basename::basename($aslocal); - my(@dialog); - push( - @dialog, - "lcd $aslocal_dir", - "cd /", - map("cd $_", split /\//, $dir), # RFC 1738 - "bin", - "get $getfile $targetfile", - "quit" - ); - if (! $netrcfile) { - CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG; - } elsif ($netrc->hasdefault || $netrc->contains($host)) { - CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]", - $netrc->hasdefault, - $netrc->contains($host))) if $CPAN::DEBUG; - if ($netrc->protected) { - my $dialog = join "", map { " $_\n" } @dialog; - my $netrc_explain; - if ($netrc->contains($host)) { - $netrc_explain = "Relying that your .netrc entry for '$host' ". - "manages the login"; - } else { - $netrc_explain = "Relying that your default .netrc entry ". - "manages the login"; - } - $CPAN::Frontend->myprint(qq{ - Trying with external ftp to get - '$url' - $netrc_explain - Going to send the dialog -$dialog -} - ); - $self->talk_ftp("$ftpbin$verbose $host", - @dialog); - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); - $mtime ||= 0; - if ($mtime > $timestamp) { - $CPAN::Frontend->myprint("GOT $aslocal\n"); - $ThesiteURL = $ro_url; - return $aslocal; - } else { - $CPAN::Frontend->myprint("Hmm... Still failed!\n"); - } - return if $CPAN::Signal; - } else { - $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }. - qq{correctly protected.\n}); - } - } else { - $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host - nor does it have a default entry\n"); - } - - # OK, they don't have a valid ~/.netrc. Use 'ftp -n' - # then and login manually to host, using e-mail as - # password. - $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n}); - unshift( - @dialog, - "open $host", - "user anonymous $Config::Config{'cf_email'}" - ); - my $dialog = join "", map { " $_\n" } @dialog; - $CPAN::Frontend->myprint(qq{ - Trying with external ftp to get - $url - Going to send the dialog -$dialog -} - ); - $self->talk_ftp("$ftpbin$verbose -n", @dialog); - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); - $mtime ||= 0; - if ($mtime > $timestamp) { - $CPAN::Frontend->myprint("GOT $aslocal\n"); - $ThesiteURL = $ro_url; - return $aslocal; - } else { - $CPAN::Frontend->myprint("Bad luck... Still failed!\n"); - } - return if $CPAN::Signal; - $CPAN::Frontend->mywarn("Can't access URL $url.\n\n"); - $CPAN::Frontend->mysleep(2); - } # host -} - -# package CPAN::FTP; -sub talk_ftp { - my($self,$command,@dialog) = @_; - my $fh = FileHandle->new; - $fh->open("|$command") or die "Couldn't open ftp: $!"; - foreach (@dialog) { $fh->print("$_\n") } - $fh->close; # Wait for process to complete - my $wstatus = $?; - my $estatus = $wstatus >> 8; - $CPAN::Frontend->myprint(qq{ -Subprocess "|$command" - returned status $estatus (wstat $wstatus) -}) if $wstatus; -} - -# find2perl needs modularization, too, all the following is stolen -# from there -# CPAN::FTP::ls -sub ls { - my($self,$name) = @_; - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm, - $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name); - - my($perms,%user,%group); - my $pname = $name; - - if ($blocks) { - $blocks = int(($blocks + 1) / 2); - } - else { - $blocks = int(($sizemm + 1023) / 1024); - } - - if (-f _) { $perms = '-'; } - elsif (-d _) { $perms = 'd'; } - elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; } - elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; } - elsif (-p _) { $perms = 'p'; } - elsif (-S _) { $perms = 's'; } - else { $perms = 'l'; $pname .= ' -> ' . readlink($_); } - - my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx'); - my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); - my $tmpmode = $mode; - my $tmp = $rwx[$tmpmode & 7]; - $tmpmode >>= 3; - $tmp = $rwx[$tmpmode & 7] . $tmp; - $tmpmode >>= 3; - $tmp = $rwx[$tmpmode & 7] . $tmp; - substr($tmp,2,1) =~ tr/-x/Ss/ if -u _; - substr($tmp,5,1) =~ tr/-x/Ss/ if -g _; - substr($tmp,8,1) =~ tr/-x/Tt/ if -k _; - $perms .= $tmp; - - my $user = $user{$uid} || $uid; # too lazy to implement lookup - my $group = $group{$gid} || $gid; - - my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime); - my($timeyear); - my($moname) = $moname[$mon]; - if (-M _ > 365.25 / 2) { - $timeyear = $year + 1900; - } - else { - $timeyear = sprintf("%02d:%02d", $hour, $min); - } - - sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n", - $ino, - $blocks, - $perms, - $nlink, - $user, - $group, - $sizemm, - $moname, - $mday, - $timeyear, - $pname; -} - -1; diff --git a/lib/CPAN/FTP/netrc.pm b/lib/CPAN/FTP/netrc.pm deleted file mode 100644 index c05405e7ef..0000000000 --- a/lib/CPAN/FTP/netrc.pm +++ /dev/null @@ -1,63 +0,0 @@ -package CPAN::FTP::netrc; -use strict; - -$CPAN::FTP::netrc::VERSION = $CPAN::FTP::netrc::VERSION = "1.00"; - -# package CPAN::FTP::netrc; -sub new { - my($class) = @_; - my $home = CPAN::HandleConfig::home(); - my $file = File::Spec->catfile($home,".netrc"); - - my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, - $atime,$mtime,$ctime,$blksize,$blocks) - = stat($file); - $mode ||= 0; - my $protected = 0; - - my($fh,@machines,$hasdefault); - $hasdefault = 0; - $fh = FileHandle->new or die "Could not create a filehandle"; - - if($fh->open($file)) { - $protected = ($mode & 077) == 0; - local($/) = ""; - NETRC: while (<$fh>) { - my(@tokens) = split " ", $_; - TOKEN: while (@tokens) { - my($t) = shift @tokens; - if ($t eq "default") { - $hasdefault++; - last NETRC; - } - last TOKEN if $t eq "macdef"; - if ($t eq "machine") { - push @machines, shift @tokens; - } - } - } - } else { - $file = $hasdefault = $protected = ""; - } - - bless { - 'mach' => [@machines], - 'netrc' => $file, - 'hasdefault' => $hasdefault, - 'protected' => $protected, - }, $class; -} - -# CPAN::FTP::netrc::hasdefault; -sub hasdefault { shift->{'hasdefault'} } -sub netrc { shift->{'netrc'} } -sub protected { shift->{'protected'} } -sub contains { - my($self,$mach) = @_; - for ( @{$self->{'mach'}} ) { - return 1 if $_ eq $mach; - } - return 0; -} - -1; diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm deleted file mode 100644 index 50bebc349a..0000000000 --- a/lib/CPAN/FirstTime.pm +++ /dev/null @@ -1,1738 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -package CPAN::Mirrored::By; -use strict; - -sub new { - my($self,@arg) = @_; - bless [@arg], $self; -} -sub continent { shift->[0] } -sub country { shift->[1] } -sub url { shift->[2] } - -package CPAN::FirstTime; -use strict; - -use ExtUtils::MakeMaker (); -use FileHandle (); -use File::Basename (); -use File::Path (); -use File::Spec (); -use vars qw($VERSION $urllist); -$VERSION = "5.53"; - -=head1 NAME - -CPAN::FirstTime - Utility for CPAN::Config file Initialization - -=head1 SYNOPSIS - -CPAN::FirstTime::init() - -=head1 DESCRIPTION - -The init routine asks a few questions and writes a CPAN/Config.pm or -CPAN/MyConfig.pm file (depending on what it is currently using). - -In the following all questions and explanations regarding config -variables are collected. - -=cut - -# down until the next =back the manpage must be parsed by the program -# because the text is used in the init dialogues. - -my @podpara = split /\n\n/, <<'=back'; - -=over 2 - -=item auto_commit - -Normally CPAN.pm keeps config variables in memory and changes need to -be saved in a separate 'o conf commit' command to make them permanent -between sessions. If you set the 'auto_commit' option to true, changes -to a config variable are always automatically committed to disk. - -Always commit changes to config variables to disk? - -=item build_cache - -CPAN.pm can limit the size of the disk area for keeping the build -directories with all the intermediate files. - -Cache size for build directory (in MB)? - -=item build_dir - -Directory where the build process takes place? - -=item build_dir_reuse - -Until version 1.88 CPAN.pm never trusted the contents of the build_dir -directory between sessions. Since 1.88_58 CPAN.pm has a YAML-based -mechanism that makes it possible to share the contents of the -build_dir/ directory between different sessions with the same version -of perl. People who prefer to test things several days before -installing will like this feature because it safes a lot of time. - -If you say yes to the following question, CPAN will try to store -enough information about the build process so that it can pick up in -future sessions at the same state of affairs as it left a previous -session. - -Store and re-use state information about distributions between -CPAN.pm sessions? - -=item build_requires_install_policy - -When a module declares another one as a 'build_requires' prerequisite -this means that the other module is only needed for building or -testing the module but need not be installed permanently. In this case -you may wish to install that other module nonetheless or just keep it -in the 'build_dir' directory to have it available only temporarily. -Installing saves time on future installations but makes the perl -installation bigger. - -You can choose if you want to always install (yes), never install (no) -or be always asked. In the latter case you can set the default answer -for the question to yes (ask/yes) or no (ask/no). - -Policy on installing 'build_requires' modules (yes, no, ask/yes, -ask/no)? - -=item cache_metadata - -To considerably speed up the initial CPAN shell startup, it is -possible to use Storable to create a cache of metadata. If Storable is -not available, the normal index mechanism will be used. - -Note: this mechanism is not used when use_sqlite is on and SQLLite is -running. - -Cache metadata (yes/no)? - -=item check_sigs - -CPAN packages can be digitally signed by authors and thus verified -with the security provided by strong cryptography. The exact mechanism -is defined in the Module::Signature module. While this is generally -considered a good thing, it is not always convenient to the end user -to install modules that are signed incorrectly or where the key of the -author is not available or where some prerequisite for -Module::Signature has a bug and so on. - -With the check_sigs parameter you can turn signature checking on and -off. The default is off for now because the whole tool chain for the -functionality is not yet considered mature by some. The author of -CPAN.pm would recommend setting it to true most of the time and -turning it off only if it turns out to be annoying. - -Note that if you do not have Module::Signature installed, no signature -checks will be performed at all. - -Always try to check and verify signatures if a SIGNATURE file is in -the package and Module::Signature is installed (yes/no)? - -=item colorize_output - -When you have Term::ANSIColor installed, you can turn on colorized -output to have some visual differences between normal CPAN.pm output, -warnings, debugging output, and the output of the modules being -installed. Set your favorite colors after some experimenting with the -Term::ANSIColor module. - -Do you want to turn on colored output? - -=item colorize_print - -Color for normal output? - -=item colorize_warn - -Color for warnings? - -=item colorize_debug - -Color for debugging messages? - -=item commandnumber_in_prompt - -The prompt of the cpan shell can contain the current command number -for easier tracking of the session or be a plain string. - -Do you want the command number in the prompt (yes/no)? - -=item connect_to_internet_ok - -If you have never defined your own C<urllist> in your configuration -then C<CPAN.pm> will be hesitant to use the built in default sites for -downloading. It will ask you once per session if a connection to the -internet is OK and only if you say yes, it will try to connect. But to -avoid this question, you can choose your favorite download sites once -and get away with it. Or, if you have no favorite download sites -answer yes to the following question. - -If no urllist has been chosen yet, would you prefer CPAN.pm to connect -to the built-in default sites without asking? (yes/no)? - -=item ftp_passive - -Shall we always set the FTP_PASSIVE environment variable when dealing -with ftp download (yes/no)? - -=item ftpstats_period - -Statistics about downloads are truncated by size and period -simultaneously. - -How many days shall we keep statistics about downloads? - -=item ftpstats_size - -Statistics about downloads are truncated by size and period -simultaneously. - -How many items shall we keep in the statistics about downloads? - -=item getcwd - -CPAN.pm changes the current working directory often and needs to -determine its own current working directory. Per default it uses -Cwd::cwd but if this doesn't work on your system for some reason, -alternatives can be configured according to the following table: - - cwd Cwd::cwd - getcwd Cwd::getcwd - fastcwd Cwd::fastcwd - backtickcwd external command cwd - -Preferred method for determining the current working directory? - -=item halt_on_failure - -Normaly, CPAN.pm continues processing the full list of targets and -dependencies, even if one of them fails. However, you can specify -that CPAN should halt after the first failure. - -Do you want to halt on failure (yes/no)? - -=item histfile - -If you have one of the readline packages (Term::ReadLine::Perl, -Term::ReadLine::Gnu, possibly others) installed, the interactive CPAN -shell will have history support. The next two questions deal with the -filename of the history file and with its size. If you do not want to -set this variable, please hit SPACE RETURN to the following question. - -File to save your history? - -=item histsize - -Number of lines to save? - -=item inactivity_timeout - -Sometimes you may wish to leave the processes run by CPAN alone -without caring about them. Because the Makefile.PL or the Build.PL -sometimes contains question you're expected to answer, you can set a -timer that will kill a 'perl Makefile.PL' process after the specified -time in seconds. - -If you set this value to 0, these processes will wait forever. This is -the default and recommended setting. - -Timeout for inactivity during {Makefile,Build}.PL? - -=item index_expire - -The CPAN indexes are usually rebuilt once or twice per hour, but the -typical CPAN mirror mirrors only once or twice per day. Depending on -the quality of your mirror and your desire to be on the bleeding edge, -you may want to set the following value to more or less than one day -(which is the default). It determines after how many days CPAN.pm -downloads new indexes. - -Let the index expire after how many days? - -=item inhibit_startup_message - -When the CPAN shell is started it normally displays a greeting message -that contains the running version and the status of readline support. - -Do you want to turn this message off? - -=item keep_source_where - -Unless you are accessing the CPAN on your filesystem via a file: URL, -CPAN.pm needs to keep the source files it downloads somewhere. Please -supply a directory where the downloaded files are to be kept. - -Download target directory? - -=item load_module_verbosity - -When CPAN.pm loads a module it needs for some optional feature, it -usually reports about module name and version. Choose 'v' to get this -message, 'none' to suppress it. - -Verbosity level for loading modules (none or v)? - -=item makepl_arg - -Every Makefile.PL is run by perl in a separate process. Likewise we -run 'make' and 'make install' in separate processes. If you have -any parameters (e.g. PREFIX, UNINST or the like) you want to -pass to the calls, please specify them here. - -If you don't understand this question, just press ENTER. - -Typical frequently used settings: - - PREFIX=~/perl # non-root users (please see manual for more hints) - -Parameters for the 'perl Makefile.PL' command? - -=item make_arg - -Parameters for the 'make' command? Typical frequently used setting: - - -j3 # dual processor system (on GNU make) - -Your choice: - -=item make_install_arg - -Parameters for the 'make install' command? -Typical frequently used setting: - - UNINST=1 # to always uninstall potentially conflicting files - -Your choice: - -=item make_install_make_command - -Do you want to use a different make command for 'make install'? -Cautious people will probably prefer: - - su root -c make - or - sudo make - or - /path1/to/sudo -u admin_account /path2/to/make - -or some such. Your choice: - -=item mbuildpl_arg - -A Build.PL is run by perl in a separate process. Likewise we run -'./Build' and './Build install' in separate processes. If you have any -parameters you want to pass to the calls, please specify them here. - -Typical frequently used settings: - - --install_base /home/xxx # different installation directory - -Parameters for the 'perl Build.PL' command? - -=item mbuild_arg - -Parameters for the './Build' command? Setting might be: - - --extra_linker_flags -L/usr/foo/lib # non-standard library location - -Your choice: - -=item mbuild_install_arg - -Parameters for the './Build install' command? Typical frequently used -setting: - - --uninst 1 # uninstall conflicting files - -Your choice: - -=item mbuild_install_build_command - -Do you want to use a different command for './Build install'? Sudo -users will probably prefer: - - su root -c ./Build - or - sudo ./Build - or - /path1/to/sudo -u admin_account ./Build - -or some such. Your choice: - -=item pager - -What is your favorite pager program? - -=item prefer_installer - -When you have Module::Build installed and a module comes with both a -Makefile.PL and a Build.PL, which shall have precedence? - -The main two standard installer modules are the old and well -established ExtUtils::MakeMaker (for short: EUMM) which uses the -Makefile.PL. And the next generation installer Module::Build (MB) -which works with the Build.PL (and often comes with a Makefile.PL -too). If a module comes only with one of the two we will use that one -but if both are supplied then a decision must be made between EUMM and -MB. See also http://rt.cpan.org/Ticket/Display.html?id=29235 for a -discussion about the right default. - -Or, as a third option you can choose RAND which will make a random -decision (something regular CPAN testers will enjoy). - -In case you can choose between running a Makefile.PL or a Build.PL, -which installer would you prefer (EUMM or MB or RAND)? - -=item prefs_dir - -CPAN.pm can store customized build environments based on regular -expressions for distribution names. These are YAML files where the -default options for CPAN.pm and the environment can be overridden and -dialog sequences can be stored that can later be executed by an -Expect.pm object. The CPAN.pm distribution comes with some prefab YAML -files that cover sample distributions that can be used as blueprints -to store one own prefs. Please check out the distroprefs/ directory of -the CPAN.pm distribution to get a quick start into the prefs system. - -Directory where to store default options/environment/dialogs for -building modules that need some customization? - -=item prerequisites_policy - -The CPAN module can detect when a module which you are trying to build -depends on prerequisites. If this happens, it can build the -prerequisites for you automatically ('follow'), ask you for -confirmation ('ask'), or just ignore them ('ignore'). Please set your -policy to one of the three values. - -Policy on building prerequisites (follow, ask or ignore)? - -=item randomize_urllist - -CPAN.pm can introduce some randomness when using hosts for download -that are configured in the urllist parameter. Enter a numeric value -between 0 and 1 to indicate how often you want to let CPAN.pm try a -random host from the urllist. A value of one specifies to always use a -random host as the first try. A value of zero means no randomness at -all. Anything in between specifies how often, on average, a random -host should be tried first. - -Randomize parameter - -=item scan_cache - -By default, each time the CPAN module is started, cache scanning is -performed to keep the cache size in sync. To prevent this, answer -'never'. - -Perform cache scanning (atstart or never)? - -=item shell - -What is your favorite shell? - -=item show_unparsable_versions - -During the 'r' command CPAN.pm finds modules without version number. -When the command finishes, it prints a report about this. If you -want this report to be very verbose, say yes to the following -variable. - -Show all individual modules that have no $VERSION? - -=item show_upload_date - -The 'd' and the 'm' command normally only show you information they -have in their in-memory database and thus will never connect to the -internet. If you set the 'show_upload_date' variable to true, 'm' and -'d' will additionally show you the upload date of the module or -distribution. Per default this feature is off because it may require a -net connection to get at the upload date. - -Always try to show upload date with 'd' and 'm' command (yes/no)? - -=item show_zero_versions - -During the 'r' command CPAN.pm finds modules with a version number of -zero. When the command finishes, it prints a report about this. If you -want this report to be very verbose, say yes to the following -variable. - -Show all individual modules that have a $VERSION of zero? - -=item tar_verbosity - -When CPAN.pm uses the tar command, which switch for the verbosity -shall be used? Choose 'none' for quiet operation, 'v' for file -name listing, 'vv' for full listing. - -Tar command verbosity level (none or v or vv)? - -=item term_is_latin - -The next option deals with the charset (aka character set) your -terminal supports. In general, CPAN is English speaking territory, so -the charset does not matter much but some CPAN have names that are -outside the ASCII range. If your terminal supports UTF-8, you should -say no to the next question. If it expects ISO-8859-1 (also known as -LATIN1) then you should say yes. If it supports neither, your answer -does not matter because you will not be able to read the names of some -authors anyway. If you answer no, names will be output in UTF-8. - -Your terminal expects ISO-8859-1 (yes/no)? - -=item term_ornaments - -When using Term::ReadLine, you can turn ornaments on so that your -input stands out against the output from CPAN.pm. - -Do you want to turn ornaments on? - -=item test_report - -The goal of the CPAN Testers project (http://testers.cpan.org/) is to -test as many CPAN packages as possible on as many platforms as -possible. This provides valuable feedback to module authors and -potential users to identify bugs or platform compatibility issues and -improves the overall quality and value of CPAN. - -One way you can contribute is to send test results for each module -that you install. If you install the CPAN::Reporter module, you have -the option to automatically generate and email test reports to CPAN -Testers whenever you run tests on a CPAN package. - -See the CPAN::Reporter documentation for additional details and -configuration settings. If your firewall blocks outgoing email, -you will need to configure CPAN::Reporter before sending reports. - -Email test reports if CPAN::Reporter is installed (yes/no)? - -=item perl5lib_verbosity - -When CPAN.pm extends @INC via PERL5LIB, it prints a list of -directories added (or a summary of how many directories are -added). Choose 'v' to get this message, 'none' to suppress it. - -Verbosity level for PERL5LIB changes (none or v)? - -=item trust_test_report_history - -When a distribution has already been tested by CPAN::Reporter on -this machine, CPAN can skip the test phase and just rely on the -test report history instead. - -Note that this will not apply to distributions that failed tests -because of missing dependencies. Also, tests can be run -regardless of the history using "force". - -Do you want to rely on the test report history (yes/no)? - -=item use_sqlite - -CPAN::SQLite is a layer between the index files that are downloaded -from the CPAN and CPAN.pm that speeds up metadata queries and reduces -memory consumption of CPAN.pm considerably. - -Use CPAN::SQLite if available? (yes/no)? - -=item yaml_load_code - -Both YAML.pm and YAML::Syck are capable of deserialising code. As this -requires a string eval, which might be a security risk, you can use -this option to enable or disable the deserialisation of code via -CPAN::DeferredCode. (Note: This does not work under perl 5.6) - -Do you want to enable code deserialisation (yes/no)? - -=item yaml_module - -At the time of this writing (2009-03) there are three YAML -implementations working: YAML, YAML::Syck, and YAML::XS. The latter -two are faster but need a C compiler installed on your system. There -may be more alternative YAML conforming modules. When I tried two -other players, YAML::Tiny and YAML::Perl, they seemed not powerful -enough to work with CPAN.pm. This may have changed in the meantime. - -Which YAML implementation would you prefer? - -=back - -=head1 LICENSE - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut - -use vars qw( %prompts ); - -{ - - my @prompts = ( - -manual_config => qq[ - -CPAN is the world-wide archive of perl resources. It consists of about -300 sites that all replicate the same contents around the globe. Many -countries have at least one CPAN site already. The resources found on -CPAN are easily accessible with the CPAN.pm module. If you want to use -CPAN.pm, lots of things have to be configured. Fortunately, most of -them can be determined automatically. If you prefer the automatic -configuration, answer 'yes' below. - -If you prefer to enter a dialog instead, you can answer 'no' to this -question and I'll let you configure in small steps one thing after the -other. (Note: you can revisit this dialog anytime later by typing 'o -conf init' at the cpan prompt.) -], - -config_intro => qq{ - -The following questions are intended to help you with the -configuration. The CPAN module needs a directory of its own to cache -important index files and maybe keep a temporary mirror of CPAN files. -This may be a site-wide or a personal directory. - -}, - -# cpan_home => qq{ }, - -cpan_home_where => qq{ - -First of all, I'd like to create this directory. Where? - -}, - -external_progs => qq{ - -The CPAN module will need a few external programs to work properly. -Please correct me, if I guess the wrong path for a program. Don't -panic if you do not have some of them, just press ENTER for those. To -disable the use of a program, you can type a space followed by ENTER. - -}, - -proxy_intro => qq{ - -If you're accessing the net via proxies, you can specify them in the -CPAN configuration or via environment variables. The variable in -the \$CPAN::Config takes precedence. - -}, - -proxy_user => qq{ - -If your proxy is an authenticating proxy, you can store your username -permanently. If you do not want that, just press RETURN. You will then -be asked for your username in every future session. - -}, - -proxy_pass => qq{ - -Your password for the authenticating proxy can also be stored -permanently on disk. If this violates your security policy, just press -RETURN. You will then be asked for the password in every future -session. - -}, - -urls_intro => qq{ - -Now we need to know where your favorite CPAN sites are located. Push -a few sites onto the array (just in case the first on the array won\'t -work). If you are mirroring CPAN to your local workstation, specify a -file: URL. - -First, pick a nearby continent and country by typing in the number(s) -in front of the item(s) you want to select. You can pick several of -each, separated by spaces. Then, you will be presented with a list of -URLs of CPAN mirrors in the countries you selected, along with -previously selected URLs. Select some of those URLs, or just keep the -old list. Finally, you will be prompted for any extra URLs -- file:, -ftp:, or http: -- that host a CPAN mirror. - -}, - -password_warn => qq{ - -Warning: Term::ReadKey seems not to be available, your password will -be echoed to the terminal! - -}, - - ); - - die "Coding error in \@prompts declaration. Odd number of elements, above" - if (@prompts % 2); - - %prompts = @prompts; - - if (scalar(keys %prompts) != scalar(@prompts)/2) { - my %already; - for my $item (0..$#prompts) { - next if $item % 2; - die "$prompts[$item] is duplicated\n" if $already{$prompts[$item]}++; - } - } - - shift @podpara; - while (@podpara) { - warn "Alert: cannot parse my own manpage for init dialog" unless $podpara[0] =~ s/^=item\s+//; - my $name = shift @podpara; - my @para; - while (@podpara && $podpara[0] !~ /^=item/) { - push @para, shift @podpara; - } - $prompts{$name} = pop @para; - if (@para) { - $prompts{$name . "_intro"} = join "", map { "$_\n\n" } @para; - } - } - -} - -sub init { - my($configpm, %args) = @_; - use Config; - # extra args after 'o conf init' - my $matcher = $args{args} && @{$args{args}} ? $args{args}[0] : ''; - if ($matcher =~ /^\/(.*)\/$/) { - # case /regex/ => take the first, ignore the rest - $matcher = $1; - shift @{$args{args}}; - if (@{$args{args}}) { - local $" = " "; - $CPAN::Frontend->mywarn("Ignoring excessive arguments '@{$args{args}}'"); - $CPAN::Frontend->mysleep(2); - } - } elsif (0 == length $matcher) { - } elsif (0 && $matcher eq "~") { # extremely buggy, but a nice idea - my @unconfigured = grep { not exists $CPAN::Config->{$_} - or not defined $CPAN::Config->{$_} - or not length $CPAN::Config->{$_} - } keys %$CPAN::Config; - $matcher = "\\b(".join("|", @unconfigured).")\\b"; - $CPAN::Frontend->mywarn("matcher[$matcher]"); - } else { - # case WORD... => all arguments must be valid - for my $arg (@{$args{args}}) { - unless (exists $CPAN::HandleConfig::keys{$arg}) { - $CPAN::Frontend->mywarn("'$arg' is not a valid configuration variable\n"); - return; - } - } - $matcher = "\\b(".join("|",@{$args{args}}).")\\b"; - } - CPAN->debug("matcher[$matcher]") if $CPAN::DEBUG; - - unless ($CPAN::VERSION) { - require CPAN::Nox; - } - require CPAN::HandleConfig; - CPAN::HandleConfig::require_myconfig_or_config(); - $CPAN::Config ||= {}; - local($/) = "\n"; - local($\) = ""; - local($|) = 1; - - my($ans,$default); # why so half global? - - # - #= Files, directories - # - - unless ($matcher) { - $CPAN::Frontend->myprint($prompts{manual_config}); - } - - my $manual_conf; - - local *_real_prompt; - if ( $args{autoconfig} ) { - $manual_conf = "no"; - } elsif ($matcher) { - $manual_conf = "yes"; - } else { - my $_conf = prompt("Would you like me to configure as much as possible ". - "automatically?", "yes"); - $manual_conf = ($_conf and $_conf =~ /^y/i) ? "no" : "yes"; - } - CPAN->debug("manual_conf[$manual_conf]") if $CPAN::DEBUG; - my $fastread; - { - if ($manual_conf =~ /^y/i) { - $fastread = 0; - } else { - $fastread = 1; - $CPAN::Config->{urllist} ||= []; - $CPAN::Config->{connect_to_internet_ok} ||= 1; - - local $^W = 0; - # prototype should match that of &MakeMaker::prompt - my $current_second = time; - my $current_second_count = 0; - my $i_am_mad = 0; - *_real_prompt = sub { - my($q,$a) = @_; - my($ret) = defined $a ? $a : ""; - $CPAN::Frontend->myprint(sprintf qq{%s [%s]\n\n}, $q, $ret); - eval { require Time::HiRes }; - unless ($@) { - if (time == $current_second) { - $current_second_count++; - if ($current_second_count > 20) { - # I don't like more than 20 prompts per second - $i_am_mad++; - } - } else { - $current_second = time; - $current_second_count = 0; - $i_am_mad-- if $i_am_mad>0; - } - if ($i_am_mad>0) { - #require Carp; - #Carp::cluck("SLEEEEEEEEPIIIIIIIIIIINGGGGGGGGGGG"); - Time::HiRes::sleep(0.1); - } - } - $ret; - }; - } - } - - if (!$matcher or q{ - build_dir - build_dir_reuse - cpan_home - keep_source_where - prefs_dir - } =~ /$matcher/) { - $CPAN::Frontend->myprint($prompts{config_intro}); - - init_cpan_home($matcher); - - my_dflt_prompt("keep_source_where", - File::Spec->catdir($CPAN::Config->{cpan_home},"sources"), - $matcher, - ); - my_dflt_prompt("build_dir", - File::Spec->catdir($CPAN::Config->{cpan_home},"build"), - $matcher - ); - my_yn_prompt(build_dir_reuse => 0, $matcher); - my_dflt_prompt("prefs_dir", - File::Spec->catdir($CPAN::Config->{cpan_home},"prefs"), - $matcher - ); - } - - # - #= Config: auto_commit - # - - my_yn_prompt(auto_commit => 0, $matcher); - - # - #= Cache size, Index expire - # - my_dflt_prompt(build_cache => 100, $matcher); - - my_dflt_prompt(index_expire => 1, $matcher); - my_prompt_loop(scan_cache => 'atstart', $matcher, 'atstart|never'); - - # - #= cache_metadata - # - - my_yn_prompt(cache_metadata => 1, $matcher); - my_yn_prompt(use_sqlite => 0, $matcher); - - # - #= Do we follow PREREQ_PM? - # - - my_prompt_loop(prerequisites_policy => 'ask', $matcher, - 'follow|ask|ignore'); - my_prompt_loop(build_requires_install_policy => 'ask/yes', $matcher, - 'yes|no|ask/yes|ask/no'); - - # - #= Module::Signature - # - my_yn_prompt(check_sigs => 0, $matcher); - - # - #= CPAN::Reporter - # - if (!$matcher or 'test_report' =~ /$matcher/) { - my_yn_prompt(test_report => 0, $matcher); - if ( - $CPAN::Config->{test_report} && - $CPAN::META->has_inst("CPAN::Reporter") && - CPAN::Reporter->can('configure') - ) { - $CPAN::Frontend->myprint("\nProceeding to configure CPAN::Reporter.\n"); - CPAN::Reporter::configure(); - $CPAN::Frontend->myprint("\nReturning to CPAN configuration.\n"); - } - } - - my_yn_prompt(trust_test_report_history => 0, $matcher); - - # - #= YAML vs. YAML::Syck - # - if (!$matcher or "yaml_module" =~ /$matcher/) { - my_dflt_prompt(yaml_module => "YAML", $matcher); - unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module})) { - $CPAN::Frontend->mywarn - ("Warning (maybe harmless): '$CPAN::Config->{yaml_module}' not installed.\n"); - $CPAN::Frontend->mysleep(3); - } - } - - # - #= YAML code deserialisation - # - my_yn_prompt(yaml_load_code => 0, $matcher); - - # - #= External programs - # - my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'}; - _init_external_progs($matcher,\@path); - - { - my $path = $CPAN::Config->{'pager'} || - $ENV{PAGER} || find_exe("less",\@path) || - find_exe("more",\@path) || ($^O eq 'MacOS' ? $ENV{EDITOR} : 0 ) - || "more"; - my_dflt_prompt(pager => $path, $matcher); - } - - { - my $path = $CPAN::Config->{'shell'}; - if ($path && File::Spec->file_name_is_absolute($path)) { - $CPAN::Frontend->mywarn("Warning: configured $path does not exist\n") - unless -e $path; - $path = ""; - } - $path ||= $ENV{SHELL}; - $path ||= $ENV{COMSPEC} if $^O eq "MSWin32"; - if ($^O eq 'MacOS') { - $CPAN::Config->{'shell'} = 'not_here'; - } else { - $path =~ s,\\,/,g if $^O eq 'os2'; # Cosmetic only - my_dflt_prompt(shell => $path, $matcher); - } - } - - # - # verbosity - # - - my_prompt_loop(tar_verbosity => 'v', $matcher, - 'none|v|vv'); - my_prompt_loop(load_module_verbosity => 'v', $matcher, - 'none|v'); - my_prompt_loop(perl5lib_verbosity => 'v', $matcher, - 'none|v'); - my_yn_prompt(inhibit_startup_message => 0, $matcher); - - # - #= Installer, arguments to make etc. - # - - my_prompt_loop(prefer_installer => 'MB', $matcher, 'MB|EUMM|RAND'); - - if (!$matcher or 'makepl_arg make_arg' =~ /$matcher/) { - my_dflt_prompt(makepl_arg => "", $matcher); - my_dflt_prompt(make_arg => "", $matcher); - if ( $CPAN::Config->{makepl_arg} =~ /LIBS=|INC=/ ) { - $CPAN::Frontend->mywarn( - "Warning: Using LIBS or INC in makepl_arg will likely break distributions\n" . - "that specify their own LIBS or INC options in Makefile.PL.\n" - ); - } - - } - - require CPAN::HandleConfig; - if (exists $CPAN::HandleConfig::keys{make_install_make_command}) { - # as long as Windows needs $self->_build_command, we cannot - # support sudo on windows :-) - my_dflt_prompt(make_install_make_command => $CPAN::Config->{make} || "", - $matcher); - } - - my_dflt_prompt(make_install_arg => $CPAN::Config->{make_arg} || "", - $matcher); - - my_dflt_prompt(mbuildpl_arg => "", $matcher); - my_dflt_prompt(mbuild_arg => "", $matcher); - - if (exists $CPAN::HandleConfig::keys{mbuild_install_build_command} - and $^O ne "MSWin32") { - # as long as Windows needs $self->_build_command, we cannot - # support sudo on windows :-) - my_dflt_prompt(mbuild_install_build_command => "./Build", $matcher); - } - - my_dflt_prompt(mbuild_install_arg => "", $matcher); - - # - #= Alarm period - # - - my_dflt_prompt(inactivity_timeout => 0, $matcher); - - # - #== halt_on_failure - # - my_yn_prompt(halt_on_failure => 0, $matcher); - - # - #= Proxies - # - - my @proxy_vars = qw/ftp_proxy http_proxy no_proxy/; - my @proxy_user_vars = qw/proxy_user proxy_pass/; - if (!$matcher or "@proxy_vars @proxy_user_vars" =~ /$matcher/) { - $CPAN::Frontend->myprint($prompts{proxy_intro}); - - for (@proxy_vars) { - $prompts{$_} = "Your $_?"; - my_dflt_prompt($_ => $ENV{$_}||"", $matcher); - } - - if ($CPAN::Config->{ftp_proxy} || - $CPAN::Config->{http_proxy}) { - - $default = $CPAN::Config->{proxy_user} || $CPAN::LWP::UserAgent::USER || ""; - - $CPAN::Frontend->myprint($prompts{proxy_user}); - - if ($CPAN::Config->{proxy_user} = prompt("Your proxy user id?",$default)) { - $CPAN::Frontend->myprint($prompts{proxy_pass}); - - if ($CPAN::META->has_inst("Term::ReadKey")) { - Term::ReadKey::ReadMode("noecho"); - } else { - $CPAN::Frontend->myprint($prompts{password_warn}); - } - $CPAN::Config->{proxy_pass} = prompt_no_strip("Your proxy password?"); - if ($CPAN::META->has_inst("Term::ReadKey")) { - Term::ReadKey::ReadMode("restore"); - } - $CPAN::Frontend->myprint("\n\n"); - } - } - } - - # - #= how FTP works - # - - my_yn_prompt(ftp_passive => 1, $matcher); - - # - #= how cwd works - # - - my_prompt_loop(getcwd => 'cwd', $matcher, - 'cwd|getcwd|fastcwd|backtickcwd'); - - # - #= the CPAN shell itself (prompt, color) - # - - my_yn_prompt(commandnumber_in_prompt => 1, $matcher); - my_yn_prompt(term_ornaments => 1, $matcher); - if ("colorize_output colorize_print colorize_warn colorize_debug" =~ $matcher) { - my_yn_prompt(colorize_output => 0, $matcher); - if ($CPAN::Config->{colorize_output}) { - if ($CPAN::META->has_inst("Term::ANSIColor")) { - my $T="gYw"; - print " on_ on_y ". - " on_ma on_\n"; - print " on_black on_red green ellow ". - "on_blue genta on_cyan white\n"; - - for my $FG ("", "bold", - map {$_,"bold $_"} "black","red","green", - "yellow","blue", - "magenta", - "cyan","white") { - printf "%12s ", $FG; - for my $BG ("",map {"on_$_"} qw(black red green yellow - blue magenta cyan white)) { - print $FG||$BG ? - Term::ANSIColor::colored(" $T ","$FG $BG") : " $T "; - } - print "\n"; - } - print "\n"; - } - for my $tuple ( - ["colorize_print", "bold blue on_white"], - ["colorize_warn", "bold red on_white"], - ["colorize_debug", "black on_cyan"], - ) { - my_dflt_prompt($tuple->[0] => $tuple->[1], $matcher); - if ($CPAN::META->has_inst("Term::ANSIColor")) { - eval { Term::ANSIColor::color($CPAN::Config->{$tuple->[0]})}; - if ($@) { - $CPAN::Config->{$tuple->[0]} = $tuple->[1]; - $CPAN::Frontend->mywarn($@."setting to default '$tuple->[1]'\n"); - } - } - } - } - } - - # - #== term_is_latin - # - - my_yn_prompt(term_is_latin => 1, $matcher); - - # - #== save history in file 'histfile' - # - - if (!$matcher or 'histfile histsize' =~ /$matcher/) { - $CPAN::Frontend->myprint($prompts{histfile_intro}); - defined($default = $CPAN::Config->{histfile}) or - $default = File::Spec->catfile($CPAN::Config->{cpan_home},"histfile"); - my_dflt_prompt(histfile => $default, $matcher); - - if ($CPAN::Config->{histfile}) { - defined($default = $CPAN::Config->{histsize}) or $default = 100; - my_dflt_prompt(histsize => $default, $matcher); - } - } - - # - #== do an ls on the m or the d command - # - my_yn_prompt(show_upload_date => 0, $matcher); - - # - #== verbosity at the end of the r command - # - if (!$matcher - or 'show_unparsable_versions' =~ /$matcher/ - or 'show_zero_versions' =~ /$matcher/ - ) { - $CPAN::Frontend->myprint($prompts{show_unparsable_or_zero_versions_intro}); - my_yn_prompt(show_unparsable_versions => 0, $matcher); - my_yn_prompt(show_zero_versions => 0, $matcher); - } - - # - #= MIRRORED.BY and conf_sites() - # - - # remember, this is only triggered if no urllist is given, so 0 is - # fair and protects the default site from being overloaded and - # gives the user more chances to select his own urllist. - my_yn_prompt("connect_to_internet_ok" => 0, $matcher); - if ($matcher) { - if ("urllist" =~ $matcher) { - # conf_sites would go into endless loop with the smash prompt - local *_real_prompt; - *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt; - conf_sites(); - } - if ("randomize_urllist" =~ $matcher) { - my_dflt_prompt(randomize_urllist => 0, $matcher); - } - if ("ftpstats_size" =~ $matcher) { - my_dflt_prompt(ftpstats_size => 99, $matcher); - } - if ("ftpstats_period" =~ $matcher) { - my_dflt_prompt(ftpstats_period => 14, $matcher); - } - } elsif ($fastread) { - $CPAN::Frontend->myprint("Autoconfigured everything but 'urllist'.\n". - "Please call 'o conf init urllist' to configure ". - "your CPAN server(s) now!\n\n"); - } else { - conf_sites(); - } - - $CPAN::Frontend->myprint("\n\n"); - if ($matcher && !$CPAN::Config->{auto_commit}) { - $CPAN::Frontend->myprint("Please remember to call 'o conf commit' to ". - "make the config permanent!\n\n"); - } else { - CPAN::HandleConfig->commit($configpm); - } -} - -sub _init_external_progs { - my($matcher,$PATH) = @_; - my @external_progs = qw/bzip2 gzip tar unzip - - make - - curl lynx wget ncftpget ncftp ftp - - gpg - - patch applypatch - /; - if (!$matcher or "@external_progs" =~ /$matcher/) { - $CPAN::Frontend->myprint($prompts{external_progs}); - - my $old_warn = $^W; - local $^W if $^O eq 'MacOS'; - local $^W = $old_warn; - my $progname; - for $progname (@external_progs) { - next if $matcher && $progname !~ /$matcher/; - if ($^O eq 'MacOS') { - $CPAN::Config->{$progname} = 'not_here'; - next; - } - - my $progcall = $progname; - unless ($matcher) { - # we really don't need ncftp if we have ncftpget, but - # if they chose this dialog via matcher, they shall have it - next if $progname eq "ncftp" && $CPAN::Config->{ncftpget} gt " "; - } - my $path = $CPAN::Config->{$progname} - || $Config::Config{$progname} - || ""; - if (File::Spec->file_name_is_absolute($path)) { - # testing existence is not good enough, some have these exe - # extensions - - # warn "Warning: configured $path does not exist\n" unless -e $path; - # $path = ""; - } elsif ($path =~ /^\s+$/) { - # preserve disabled programs - } else { - $path = ''; - } - unless ($path) { - # e.g. make -> nmake - $progcall = $Config::Config{$progname} if $Config::Config{$progname}; - } - - $path ||= find_exe($progcall,$PATH); - unless ($path) { # not -e $path, because find_exe already checked that - local $"=";"; - $CPAN::Frontend->mywarn("Warning: $progcall not found in PATH[@$PATH]\n"); - if ($progname eq "make") { - $CPAN::Frontend->mywarn("ALERT: 'make' is an essential tool for ". - "building perl Modules. Please make sure you ". - "have 'make' (or some equivalent) ". - "working.\n" - ); - if ($^O eq "MSWin32") { - $CPAN::Frontend->mywarn(" -Windows users may want to follow this procedure when back in the CPAN shell: - - look YVES/scripts/alien_nmake.pl - perl alien_nmake.pl - -This will install nmake on your system which can be used as a 'make' -substitute. You can then revisit this dialog with - - o conf init make - -"); - } - } - } - $prompts{$progname} = "Where is your $progname program?"; - my_dflt_prompt($progname,$path,$matcher); - } - } -} - -sub init_cpan_home { - my($matcher) = @_; - if (!$matcher or 'cpan_home' =~ /$matcher/) { - my $cpan_home = $CPAN::Config->{cpan_home} - || File::Spec->catdir(CPAN::HandleConfig::home(), ".cpan"); - - if (-d $cpan_home) { - $CPAN::Frontend->myprint(qq{ - -I see you already have a directory - $cpan_home -Shall we use it as the general CPAN build and cache directory? - -}); - } else { - # no cpan-home, must prompt and get one - $CPAN::Frontend->myprint($prompts{cpan_home_where}); - } - - my $default = $cpan_home; - my $loop = 0; - my($last_ans,$ans); - $CPAN::Frontend->myprint(" <cpan_home>\n"); - PROMPT: while ($ans = prompt("CPAN build and cache directory?",$default)) { - print "\n"; - if (File::Spec->file_name_is_absolute($ans)) { - my @cpan_home = split /[\/\\]/, $ans; - DIR: for my $dir (@cpan_home) { - if ($dir =~ /^~/ and (!$last_ans or $ans ne $last_ans)) { - $CPAN::Frontend - ->mywarn("Warning: a tilde in the path will be ". - "taken as a literal tilde. Please ". - "confirm again if you want to keep it\n"); - $last_ans = $default = $ans; - next PROMPT; - } - } - } else { - require Cwd; - my $cwd = Cwd::cwd(); - my $absans = File::Spec->catdir($cwd,$ans); - $CPAN::Frontend->mywarn("The path '$ans' is not an ". - "absolute path. Please specify ". - "an absolute path\n"); - $default = $absans; - next PROMPT; - } - eval { File::Path::mkpath($ans); }; # dies if it can't - if ($@) { - $CPAN::Frontend->mywarn("Couldn't create directory $ans.\n". - "Please retry.\n"); - next PROMPT; - } - if (-d $ans && -w _) { - last PROMPT; - } else { - $CPAN::Frontend->mywarn("Couldn't find directory $ans\n". - "or directory is not writable. Please retry.\n"); - if (++$loop > 5) { - $CPAN::Frontend->mydie("Giving up"); - } - } - } - $CPAN::Config->{cpan_home} = $ans; - } -} - -sub my_dflt_prompt { - my ($item, $dflt, $m) = @_; - my $default = $CPAN::Config->{$item} || $dflt; - - if (!$m || $item =~ /$m/) { - if (my $intro = $prompts{$item . "_intro"}) { - $CPAN::Frontend->myprint($intro); - } - $CPAN::Frontend->myprint(" <$item>\n"); - $CPAN::Config->{$item} = prompt($prompts{$item}, $default); - print "\n"; - } else { - $CPAN::Config->{$item} = $default; - } -} - -sub my_yn_prompt { - my ($item, $dflt, $m) = @_; - my $default; - defined($default = $CPAN::Config->{$item}) or $default = $dflt; - - # $DB::single = 1; - if (!$m || $item =~ /$m/) { - if (my $intro = $prompts{$item . "_intro"}) { - $CPAN::Frontend->myprint($intro); - } - $CPAN::Frontend->myprint(" <$item>\n"); - my $ans = prompt($prompts{$item}, $default ? 'yes' : 'no'); - $CPAN::Config->{$item} = ($ans =~ /^[y1]/i ? 1 : 0); - print "\n"; - } else { - $CPAN::Config->{$item} = $default; - } -} - -sub my_prompt_loop { - my ($item, $dflt, $m, $ok) = @_; - my $default = $CPAN::Config->{$item} || $dflt; - my $ans; - - if (!$m || $item =~ /$m/) { - $CPAN::Frontend->myprint($prompts{$item . "_intro"}); - $CPAN::Frontend->myprint(" <$item>\n"); - do { $ans = prompt($prompts{$item}, $default); - } until $ans =~ /$ok/; - $CPAN::Config->{$item} = $ans; - print "\n"; - } else { - $CPAN::Config->{$item} = $default; - } -} - - -sub conf_sites { - my $m = 'MIRRORED.BY'; - my $use_mby; - my $mby = File::Spec->catfile($CPAN::Config->{keep_source_where},$m); - File::Path::mkpath(File::Basename::dirname($mby)); - if (-f $mby && -f $m && -M $m < -M $mby) { - $use_mby = 1; - require File::Copy; - File::Copy::copy($m,$mby) or die "Could not update $mby: $!"; - } - local $^T = time; - my $overwrite_local = 0; - if ($mby && -f $mby && -M _ <= 60 && -s _ > 0) { - $use_mby = 1; - my $mtime = localtime((stat _)[9]); - my $prompt = qq{Found $mby as of $mtime - -I'd use that as a database of CPAN sites. If that is OK for you, -please answer 'y', but if you want me to get a new database from the -internet now, please answer 'n' to the following question. - -Shall I use the local database in $mby?}; - my $ans = prompt($prompt,"y"); - if ($ans =~ /^y/i) { - $CPAN::Config->{connect_to_internet_ok} = 1; - } else { - $overwrite_local = 1; - } - } - local $urllist = $CPAN::Config->{urllist}; - my $better_mby; - LOOP: while () { # multiple errors possible - if ($use_mby - or (defined $CPAN::Config->{connect_to_internet_ok} - and $CPAN::Config->{connect_to_internet_ok})){ - if ($overwrite_local) { - $CPAN::Frontend->myprint(qq{Trying to overwrite $mby\n}); - $better_mby = CPAN::FTP->localize($m,$mby,3); - $overwrite_local = 0; - $use_mby=1 if $mby; - } elsif ( ! -f $mby ) { - $CPAN::Frontend->myprint(qq{You have no $mby\n I'm trying to fetch one\n}); - $better_mby = CPAN::FTP->localize($m,$mby,3); - $use_mby=1 if $mby; - } elsif ( -M $mby > 60 ) { - $CPAN::Frontend->myprint(qq{Your $mby is older than 60 days,\n I'm trying }. - qq{to fetch a new one\n}); - $better_mby = CPAN::FTP->localize($m,$mby,3); - $use_mby=1 if $mby; - } elsif (-s $mby == 0) { - $CPAN::Frontend->myprint(qq{You have an empty $mby,\n I'm trying to fetch a better one\n}); - $better_mby = CPAN::FTP->localize($m,$mby,3); - $use_mby=1 if $mby; - } else { - last LOOP; - } - if ($better_mby) { - $mby = $better_mby; - } - } elsif (not @{$urllist||[]} - and (not defined $CPAN::Config->{connect_to_internet_ok} - or not $CPAN::Config->{connect_to_internet_ok})) { - $CPAN::Frontend->myprint(qq{CPAN needs access to at least one CPAN mirror. - -As you did not allow me to connect to the internet you need to supply -a valid CPAN URL now.\n\n}); - - my @default = map {"file://$_"} grep {-e} "/home/ftp/pub/CPAN", "/home/ftp/pub/PAUSE"; - my $ans = prompt("Please enter the URL of your CPAN mirror",shift @default); - if ($ans) { - push @$urllist, $ans; - next LOOP; - } - } else { - last LOOP; - } - } - if ($use_mby){ - read_mirrored_by($mby); - } else { - if (not defined $CPAN::Config->{connect_to_internet_ok} - or not $CPAN::Config->{connect_to_internet_ok}) { - $CPAN::Frontend->myprint("Configuration does not allow connecting to the internet.\n"); - } - $CPAN::Frontend->myprint("Current set of CPAN URLs:\n"); - map { $CPAN::Frontend->myprint(" $_\n") } @$urllist; - } - bring_your_own(); - $CPAN::Config->{urllist} = $urllist; -} - -sub find_exe { - my($exe,$path) = @_; - my($dir); - #warn "in find_exe exe[$exe] path[@$path]"; - for $dir (@$path) { - my $abs = File::Spec->catfile($dir,$exe); - if (($abs = MM->maybe_command($abs))) { - return $abs; - } - } -} - -sub picklist { - my($items,$prompt,$default,$require_nonempty,$empty_warning)=@_; - CPAN->debug("picklist('$items','$prompt','$default','$require_nonempty',". - "'$empty_warning')") if $CPAN::DEBUG; - $default ||= ''; - - my $pos = 0; - - my @nums; - SELECTION: while (1) { - - # display, at most, 15 items at a time - my $limit = $#{ $items } - $pos; - $limit = 15 if $limit > 15; - - # show the next $limit items, get the new position - $pos = display_some($items, $limit, $pos, $default); - $pos = 0 if $pos >= @$items; - - my $num = prompt($prompt,$default); - - @nums = split (' ', $num); - { - my %seen; - @nums = grep { !$seen{$_}++ } @nums; - } - my $i = scalar @$items; - unrangify(\@nums); - if (0 == @nums) { - # cannot allow nothing because nothing means paging! - # return; - } elsif (grep (/\D/ || $_ < 1 || $_ > $i, @nums)) { - $CPAN::Frontend->mywarn("invalid items entered, try again\n"); - if ("@nums" =~ /\D/) { - $CPAN::Frontend->mywarn("(we are expecting only numbers between 1 and $i)\n"); - } - next SELECTION; - } - if ($require_nonempty && !@nums) { - $CPAN::Frontend->mywarn("$empty_warning\n"); - } - $CPAN::Frontend->myprint("\n"); - - # a blank line continues... - unless (@nums){ - $CPAN::Frontend->mysleep(0.1); # prevent hot spinning process on the next bug - next SELECTION; - } - last; - } - for (@nums) { $_-- } - @{$items}[@nums]; -} - -sub unrangify ($) { - my($nums) = $_[0]; - my @nums2 = (); - while (@{$nums||[]}) { - my $n = shift @$nums; - if ($n =~ /^(\d+)-(\d+)$/) { - my @range = $1 .. $2; - # warn "range[@range]"; - push @nums2, @range; - } else { - push @nums2, $n; - } - } - push @$nums, @nums2; -} - -sub display_some { - my ($items, $limit, $pos, $default) = @_; - $pos ||= 0; - - my @displayable = @$items[$pos .. ($pos + $limit)]; - for my $item (@displayable) { - $CPAN::Frontend->myprint(sprintf "(%d) %s\n", ++$pos, $item); - } - my $hit_what = $default ? "SPACE RETURN" : "RETURN"; - $CPAN::Frontend->myprint(sprintf("%d more items, hit %s to show them\n", - (@$items - $pos), - $hit_what, - )) - if $pos < @$items; - return $pos; -} - -sub read_mirrored_by { - my $local = shift or return; - my(%all,$url,$expected_size,$default,$ans,$host, - $dst,$country,$continent,@location); - my $fh = FileHandle->new; - $fh->open($local) or die "Couldn't open $local: $!"; - local $/ = "\012"; - while (<$fh>) { - ($host) = /^([\w\.\-]+)/ unless defined $host; - next unless defined $host; - next unless /\s+dst_(dst|location)/; - /location\s+=\s+\"([^\"]+)/ and @location = (split /\s*,\s*/, $1) and - ($continent, $country) = @location[-1,-2]; - $continent =~ s/\s\(.*//; - $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude - /dst_dst\s+=\s+\"([^\"]+)/ and $dst = $1; - next unless $host && $dst && $continent && $country; - $all{$continent}{$country}{$dst} = CPAN::Mirrored::By->new($continent,$country,$dst); - undef $host; - $dst=$continent=$country=""; - } - $fh->close; - $CPAN::Config->{urllist} ||= []; - my @previous_urls = @{$CPAN::Config->{urllist}}; - - $CPAN::Frontend->myprint($prompts{urls_intro}); - - my (@cont, $cont, %cont, @countries, @urls, %seen); - my $no_previous_warn = - "Sorry! since you don't have any existing picks, you must make a\n" . - "geographic selection."; - my $offer_cont = [sort keys %all]; - if (@previous_urls) { - push @$offer_cont, "(edit previous picks)"; - $default = @$offer_cont; - } else { - # cannot allow nothing because nothing means paging! - # push @$offer_cont, "(none of the above)"; - } - @cont = picklist($offer_cont, - "Select your continent (or several nearby continents)", - $default, - ! @previous_urls, - $no_previous_warn); - # cannot allow nothing because nothing means paging! - # return unless @cont; - - foreach $cont (@cont) { - my @c = sort keys %{$all{$cont}}; - @cont{@c} = map ($cont, 0..$#c); - @c = map ("$_ ($cont)", @c) if @cont > 1; - push (@countries, @c); - } - if (@previous_urls && @countries) { - push @countries, "(edit previous picks)"; - $default = @countries; - } - - if (@countries) { - @countries = picklist (\@countries, - "Select your country (or several nearby countries)", - $default, - ! @previous_urls, - $no_previous_warn); - %seen = map (($_ => 1), @previous_urls); - # hmmm, should take list of defaults from CPAN::Config->{'urllist'}... - foreach $country (@countries) { - next if $country =~ /edit previous picks/; - (my $bare_country = $country) =~ s/ \(.*\)//; - my @u = sort keys %{$all{$cont{$bare_country}}{$bare_country}}; - @u = grep (! $seen{$_}, @u); - @u = map ("$_ ($bare_country)", @u) - if @countries > 1; - push (@urls, @u); - } - } - push (@urls, map ("$_ (previous pick)", @previous_urls)); - my $prompt = "Select as many URLs as you like (by number), -put them on one line, separated by blanks, hyphenated ranges allowed - e.g. '1 4 5' or '7 1-4 8'"; - if (@previous_urls) { - $default = join (' ', ((scalar @urls) - (scalar @previous_urls) + 1) .. - (scalar @urls)); - $prompt .= "\n(or just hit RETURN to keep your previous picks)"; - } - - @urls = picklist (\@urls, $prompt, $default); - foreach (@urls) { s/ \(.*\)//; } - if (@urls) { - $urllist = \@urls; - } else { - push @$urllist, @urls; - } -} - -sub bring_your_own { - my %seen = map (($_ => 1), @$urllist); - my($ans,@urls); - my $eacnt = 0; # empty answers - do { - my $prompt = "Enter another URL or RETURN to quit:"; - unless (%seen) { - $prompt = qq{CPAN.pm needs at least one URL where it can fetch CPAN files from. - -Please enter your CPAN site:}; - } - $ans = prompt ($prompt, ""); - - if ($ans) { - $ans =~ s|/?\z|/|; # has to end with one slash - $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file: - if ($ans =~ /^\w+:\/./) { - push @urls, $ans unless $seen{$ans}++; - } else { - $CPAN::Frontend-> - myprint(sprintf(qq{"%s" doesn\'t look like an URL at first sight. -I\'ll ignore it for now. -You can add it to your %s -later if you\'re sure it\'s right.\n}, - $ans, - $INC{'CPAN/MyConfig.pm'} - || $INC{'CPAN/Config.pm'} - || "configuration file", - )); - } - } else { - if (++$eacnt >= 5) { - $CPAN::Frontend-> - mywarn("Giving up.\n"); - $CPAN::Frontend->mysleep(5); - return; - } - } - } while $ans || !%seen; - - @$urllist = CPAN::_uniq(@$urllist, @urls); - $CPAN::Config->{urllist} = $urllist; - # xxx delete or comment these out when you're happy that it works - $CPAN::Frontend->myprint("New urllist\n"); - for ( @$urllist ) { $CPAN::Frontend->myprint(" $_\n") }; -} - - -sub _strip_spaces { - $_[0] =~ s/^\s+//; # no leading spaces - $_[0] =~ s/\s+\z//; # no trailing spaces -} - -sub prompt ($;$) { - unless (defined &_real_prompt) { - *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt; - } - my $ans = _real_prompt(@_); - - _strip_spaces($ans); - - return $ans; -} - - -sub prompt_no_strip ($;$) { - return _real_prompt(@_); -} - - - -1; diff --git a/lib/CPAN/HandleConfig.pm b/lib/CPAN/HandleConfig.pm deleted file mode 100644 index 903b414464..0000000000 --- a/lib/CPAN/HandleConfig.pm +++ /dev/null @@ -1,734 +0,0 @@ -package CPAN::HandleConfig; -use strict; -use vars qw(%can %keys $loading $VERSION); - -$VERSION = "5.5"; - -%can = ( - commit => "Commit changes to disk", - defaults => "Reload defaults from disk", - help => "Short help about 'o conf' usage", - init => "Interactive setting of all options", -); - -# Q: where is the "How do I add a new config option" HOWTO? -# A1: svn diff -r 757:758 # where dagolden added test_report -# A2: svn diff -r 985:986 # where andk added yaml_module -# A3: 1. add new config option to %keys below -# 2. add a Pod description in CPAN::FirstTime; it should include a -# prompt line; see others for examples -# 3. add a "matcher" section in CPAN::FirstTime::init that includes -# a prompt function; see others for examples -# 4. add config option to documentation section in CPAN.pm - -%keys = map { $_ => undef } - ( - "applypatch", - "auto_commit", - "build_cache", - "build_dir", - "build_dir_reuse", - "build_requires_install_policy", - "bzip2", - "cache_metadata", - "check_sigs", - "colorize_debug", - "colorize_output", - "colorize_print", - "colorize_warn", - "commandnumber_in_prompt", - "commands_quote", - "connect_to_internet_ok", - "cpan_home", - "curl", - "dontload_hash", # deprecated after 1.83_68 (rev. 581) - "dontload_list", - "ftp", - "ftp_passive", - "ftp_proxy", - "ftpstats_size", - "ftpstats_period", - "getcwd", - "gpg", - "gzip", - "halt_on_failure", - "histfile", - "histsize", - "http_proxy", - "inactivity_timeout", - "index_expire", - "inhibit_startup_message", - "keep_source_where", - "load_module_verbosity", - "lynx", - "make", - "make_arg", - "make_install_arg", - "make_install_make_command", - "makepl_arg", - "mbuild_arg", - "mbuild_install_arg", - "mbuild_install_build_command", - "mbuildpl_arg", - "ncftp", - "ncftpget", - "no_proxy", - "pager", - "password", - "patch", - "patches_dir", - "perl5lib_verbosity", - "prefer_installer", - "prefs_dir", - "prerequisites_policy", - "proxy_pass", - "proxy_user", - "randomize_urllist", - "scan_cache", - "shell", - "show_unparsable_versions", - "show_upload_date", - "show_zero_versions", - "tar", - "tar_verbosity", - "term_is_latin", - "term_ornaments", - "test_report", - "trust_test_report_history", - "unzip", - "urllist", - "use_sqlite", - "username", - "wait_list", - "wget", - "yaml_load_code", - "yaml_module", - ); - -my %prefssupport = map { $_ => 1 } - ( - "build_requires_install_policy", - "check_sigs", - "make", - "make_install_make_command", - "prefer_installer", - "test_report", - ); - -# returns true on successful action -sub edit { - my($self,@args) = @_; - return unless @args; - CPAN->debug("self[$self]args[".join(" | ",@args)."]"); - my($o,$str,$func,$args,$key_exists); - $o = shift @args; - if($can{$o}) { - my $success = $self->$o(args => \@args); # o conf init => sub init => sub load - unless ($success) { - die "Panic: could not configure CPAN.pm for args [@args]. Giving up."; - } - } else { - CPAN->debug("o[$o]") if $CPAN::DEBUG; - unless (exists $keys{$o}) { - $CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n"); - } - my $changed; - - - # one day I used randomize_urllist for a boolean, so we must - # list them explicitly --ak - if (0) { - } elsif ($o =~ /^(wait_list|urllist|dontload_list)$/) { - - # - # ARRAYS - # - - $func = shift @args; - $func ||= ""; - CPAN->debug("func[$func]args[@args]") if $CPAN::DEBUG; - # Let's avoid eval, it's easier to comprehend without. - if ($func eq "push") { - push @{$CPAN::Config->{$o}}, @args; - $changed = 1; - } elsif ($func eq "pop") { - pop @{$CPAN::Config->{$o}}; - $changed = 1; - } elsif ($func eq "shift") { - shift @{$CPAN::Config->{$o}}; - $changed = 1; - } elsif ($func eq "unshift") { - unshift @{$CPAN::Config->{$o}}, @args; - $changed = 1; - } elsif ($func eq "splice") { - my $offset = shift @args || 0; - my $length = shift @args || 0; - splice @{$CPAN::Config->{$o}}, $offset, $length, @args; # may warn - $changed = 1; - } elsif ($func) { - $CPAN::Config->{$o} = [$func, @args]; - $changed = 1; - } else { - $self->prettyprint($o); - } - if ($changed) { - if ($o eq "urllist") { - # reset the cached values - undef $CPAN::FTP::Thesite; - undef $CPAN::FTP::Themethod; - $CPAN::Index::LAST_TIME = 0; - } elsif ($o eq "dontload_list") { - # empty it, it will be built up again - $CPAN::META->{dontload_hash} = {}; - } - } - } elsif ($o =~ /_hash$/) { - - # - # HASHES - # - - if (@args==1 && $args[0] eq "") { - @args = (); - } elsif (@args % 2) { - push @args, ""; - } - $CPAN::Config->{$o} = { @args }; - $changed = 1; - } else { - - # - # SCALARS - # - - if (defined $args[0]) { - $CPAN::CONFIG_DIRTY = 1; - $CPAN::Config->{$o} = $args[0]; - $changed = 1; - } - $self->prettyprint($o) - if exists $keys{$o} or defined $CPAN::Config->{$o}; - } - if ($changed) { - if ($CPAN::Config->{auto_commit}) { - $self->commit; - } else { - $CPAN::CONFIG_DIRTY = 1; - $CPAN::Frontend->myprint("Please use 'o conf commit' to ". - "make the config permanent!\n\n"); - } - } - } -} - -sub prettyprint { - my($self,$k) = @_; - my $v = $CPAN::Config->{$k}; - if (ref $v) { - my(@report); - if (ref $v eq "ARRAY") { - @report = map {"\t$_ \[$v->[$_]]\n"} 0..$#$v; - } else { - @report = map - { - sprintf "\t%-18s => %s\n", - "[$_]", - defined $v->{$_} ? "[$v->{$_}]" : "undef" - } keys %$v; - } - $CPAN::Frontend->myprint( - join( - "", - sprintf( - " %-18s\n", - $k - ), - @report - ) - ); - } elsif (defined $v) { - $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v); - } else { - $CPAN::Frontend->myprint(sprintf " %-18s undef\n", $k); - } -} - -sub commit { - my($self,@args) = @_; - CPAN->debug("args[@args]") if $CPAN::DEBUG; - if ($CPAN::RUN_DEGRADED) { - $CPAN::Frontend->mydie( - "'o conf commit' disabled in ". - "degraded mode. Maybe try\n". - " !undef \$CPAN::RUN_DEGRADED\n" - ); - } - my $configpm; - if (@args) { - if ($args[0] eq "args") { - # we have not signed that contract - } else { - $configpm = $args[0]; - } - } - unless (defined $configpm) { - $configpm ||= $INC{"CPAN/MyConfig.pm"}; - $configpm ||= $INC{"CPAN/Config.pm"}; - $configpm || Carp::confess(q{ -CPAN::Config::commit called without an argument. -Please specify a filename where to save the configuration or try -"o conf init" to have an interactive course through configing. -}); - } - my($mode); - if (-f $configpm) { - $mode = (stat $configpm)[2]; - if ($mode && ! -w _) { - Carp::confess("$configpm is not writable"); - } - } - - my $msg; - my $home = home(); - $msg = <<EOF unless $configpm =~ /MyConfig/; - -# This is CPAN.pm's systemwide configuration file. This file provides -# defaults for users, and the values can be changed in a per-user -# configuration file. The user-config file is being looked for as -# $home/.cpan/CPAN/MyConfig.pm. - -EOF - $msg ||= "\n"; - my($fh) = FileHandle->new; - rename $configpm, "$configpm~" if -f $configpm; - open $fh, ">$configpm" or - $CPAN::Frontend->mydie("Couldn't open >$configpm: $!"); - $fh->print(qq[$msg\$CPAN::Config = \{\n]); - foreach (sort keys %$CPAN::Config) { - unless (exists $keys{$_}) { - # do not drop them: forward compatibility! - $CPAN::Frontend->mywarn("Unknown config variable '$_'\n"); - next; - } - $fh->print( - " '$_' => ", - $self->neatvalue($CPAN::Config->{$_}), - ",\n" - ); - } - - $fh->print("};\n1;\n__END__\n"); - close $fh; - - #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); - #chmod $mode, $configpm; -###why was that so? $self->defaults; - $CPAN::Frontend->myprint("commit: wrote '$configpm'\n"); - $CPAN::CONFIG_DIRTY = 0; - 1; -} - -# stolen from MakeMaker; not taking the original because it is buggy; -# bugreport will have to say: keys of hashes remain unquoted and can -# produce syntax errors -sub neatvalue { - my($self, $v) = @_; - return "undef" unless defined $v; - my($t) = ref $v; - unless ($t) { - $v =~ s/\\/\\\\/g; - return "q[$v]"; - } - if ($t eq 'ARRAY') { - my(@m, @neat); - push @m, "["; - foreach my $elem (@$v) { - push @neat, "q[$elem]"; - } - push @m, join ", ", @neat; - push @m, "]"; - return join "", @m; - } - return "$v" unless $t eq 'HASH'; - my(@m, $key, $val); - while (($key,$val) = each %$v) { - last unless defined $key; # cautious programming in case (undef,undef) is true - push(@m,"q[$key]=>".$self->neatvalue($val)) ; - } - return "{ ".join(', ',@m)." }"; -} - -sub defaults { - my($self) = @_; - if ($CPAN::RUN_DEGRADED) { - $CPAN::Frontend->mydie( - "'o conf defaults' disabled in ". - "degraded mode. Maybe try\n". - " !undef \$CPAN::RUN_DEGRADED\n" - ); - } - my $done; - for my $config (qw(CPAN/MyConfig.pm CPAN/Config.pm)) { - if ($INC{$config}) { - CPAN->debug("INC{'$config'}[$INC{$config}]") if $CPAN::DEBUG; - CPAN::Shell->_reload_this($config,{reloforce => 1}); - $CPAN::Frontend->myprint("'$INC{$config}' reread\n"); - last; - } - } - $CPAN::CONFIG_DIRTY = 0; - 1; -} - -=head2 C<< CLASS->safe_quote ITEM >> - -Quotes an item to become safe against spaces -in shell interpolation. An item is enclosed -in double quotes if: - - - the item contains spaces in the middle - - the item does not start with a quote - -This happens to avoid shell interpolation -problems when whitespace is present in -directory names. - -This method uses C<commands_quote> to determine -the correct quote. If C<commands_quote> is -a space, no quoting will take place. - - -if it starts and ends with the same quote character: leave it as it is - -if it contains no whitespace: leave it as it is - -if it contains whitespace, then - -if it contains quotes: better leave it as it is - -else: quote it with the correct quote type for the box we're on - -=cut - -{ - # Instead of patching the guess, set commands_quote - # to the right value - my ($quotes,$use_quote) - = $^O eq 'MSWin32' - ? ('"', '"') - : (q{"'}, "'") - ; - - sub safe_quote { - my ($self, $command) = @_; - # Set up quote/default quote - my $quote = $CPAN::Config->{commands_quote} || $quotes; - - if ($quote ne ' ' - and defined($command ) - and $command =~ /\s/ - and $command !~ /[$quote]/) { - return qq<$use_quote$command$use_quote> - } - return $command; - } -} - -sub init { - my($self,@args) = @_; - CPAN->debug("self[$self]args[".join(",",@args)."]"); - $self->load(doit => 1, @args); - 1; -} - -# This is a piece of repeated code that is abstracted here for -# maintainability. RMB -# -sub _configpmtest { - my($configpmdir, $configpmtest) = @_; - if (-w $configpmtest) { - return $configpmtest; - } elsif (-w $configpmdir) { - #_#_# following code dumped core on me with 5.003_11, a.k. - my $configpm_bak = "$configpmtest.bak"; - unlink $configpm_bak if -f $configpm_bak; - if( -f $configpmtest ) { - if( rename $configpmtest, $configpm_bak ) { - $CPAN::Frontend->mywarn(<<END); -Old configuration file $configpmtest - moved to $configpm_bak -END - } - } - my $fh = FileHandle->new; - if ($fh->open(">$configpmtest")) { - $fh->print("1;\n"); - return $configpmtest; - } else { - # Should never happen - Carp::confess("Cannot open >$configpmtest"); - } - } else { return } -} - -sub require_myconfig_or_config () { - return if $INC{"CPAN/MyConfig.pm"}; - local @INC = @INC; - my $home = home(); - unshift @INC, File::Spec->catdir($home,'.cpan'); - eval { require CPAN::MyConfig }; - my $err_myconfig = $@; - if ($err_myconfig and $err_myconfig !~ m#locate CPAN/MyConfig\.pm#) { - die "Error while requiring CPAN::MyConfig:\n$err_myconfig"; - } - unless ($INC{"CPAN/MyConfig.pm"}) { # this guy has settled his needs already - eval {require CPAN::Config;}; # not everybody has one - my $err_config = $@; - if ($err_config and $err_config !~ m#locate CPAN/Config\.pm#) { - die "Error while requiring CPAN::Config:\n$err_config"; - } - } -} - -sub home () { - my $home; - # Suppress load messages until we load the config and know whether - # load messages are desired. Otherwise, it's unexpected and odd - # why one load message pops up even when verbosity is turned off. - # This means File::HomeDir load messages are never seen, but I - # think that's probably OK -- DAGOLDEN - - # 5.6.2 seemed to segfault localizing a value in a hashref - # so do it manually instead - my $old_v = $CPAN::Config->{load_module_verbosity}; - $CPAN::Config->{load_module_verbosity} = q[none]; - if ($CPAN::META->has_usable("File::HomeDir")) { - $home = File::HomeDir->can('my_dot_config') - ? File::HomeDir->my_dot_config - : File::HomeDir->my_data; - unless (defined $home) { - $home = File::HomeDir->my_home - } - } - unless (defined $home) { - $home = $ENV{HOME}; - } - $CPAN::Config->{load_module_verbosity} = $old_v; - $home; -} - -sub load { - my($self, %args) = @_; - $CPAN::Be_Silent++ if $args{be_silent}; - my $doit; - $doit = delete $args{doit}; - - use Carp; - require_myconfig_or_config; - my @miss = $self->missing_config_data; - CPAN->debug("doit[$doit]loading[$loading]miss[@miss]") if $CPAN::DEBUG; - return unless $doit || @miss; - return if $loading; - $loading++; - - require CPAN::FirstTime; - my($configpm,$fh,$redo); - $redo ||= ""; - if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) { - $configpm = $INC{"CPAN/Config.pm"}; - $redo++; - } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) { - $configpm = $INC{"CPAN/MyConfig.pm"}; - $redo++; - } else { - my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"}); - my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN"); - my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm"); - my $inc_key; - if (-d $configpmdir or File::Path::mkpath($configpmdir)) { - $configpm = _configpmtest($configpmdir,$configpmtest); - $inc_key = "CPAN/Config.pm"; - } - unless ($configpm) { - $configpmdir = File::Spec->catdir(home,".cpan","CPAN"); - File::Path::mkpath($configpmdir); - $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm"); - $configpm = _configpmtest($configpmdir,$configpmtest); - $inc_key = "CPAN/MyConfig.pm"; - } - if ($configpm) { - $INC{$inc_key} = $configpm; - } else { - my $text = qq{WARNING: CPAN.pm is unable to } . - qq{create a configuration file.}; - output($text, 'confess'); - } - - } - local($") = ", "; - if ($redo && !$doit) { - $CPAN::Frontend->myprint(<<END); -Sorry, we have to rerun the configuration dialog for CPAN.pm due to -some missing parameters... - -END - $args{args} = \@miss; - } - my $initialized = CPAN::FirstTime::init($configpm, %args); - $loading--; - return $initialized; -} - - -# returns mandatory but missing entries in the Config -sub missing_config_data { - my(@miss); - for ( - "auto_commit", - "build_cache", - "build_dir", - "cache_metadata", - "cpan_home", - "ftp_proxy", - #"gzip", - "http_proxy", - "index_expire", - #"inhibit_startup_message", - "keep_source_where", - #"make", - "make_arg", - "make_install_arg", - "makepl_arg", - "mbuild_arg", - "mbuild_install_arg", - ($^O eq "MSWin32" ? "" : "mbuild_install_build_command"), - "mbuildpl_arg", - "no_proxy", - #"pager", - "prerequisites_policy", - "scan_cache", - #"tar", - #"unzip", - "urllist", - ) { - next unless exists $keys{$_}; - push @miss, $_ unless defined $CPAN::Config->{$_}; - } - return @miss; -} - -sub help { - $CPAN::Frontend->myprint(q[ -Known options: - commit commit session changes to disk - defaults reload default config values from disk - help this help - init enter a dialog to set all or a set of parameters - -Edit key values as in the following (the "o" is a literal letter o): - o conf build_cache 15 - o conf build_dir "/foo/bar" - o conf urllist shift - o conf urllist unshift ftp://ftp.foo.bar/ - o conf inhibit_startup_message 1 - -]); - undef; #don't reprint CPAN::Config -} - -sub cpl { - my($word,$line,$pos) = @_; - $word ||= ""; - CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; - my(@words) = split " ", substr($line,0,$pos+1); - if ( - defined($words[2]) - and - $words[2] =~ /list$/ - and - ( - @words == 3 - || - @words == 4 && length($word) - ) - ) { - return grep /^\Q$word\E/, qw(splice shift unshift pop push); - } elsif (defined($words[2]) - and - $words[2] eq "init" - and - ( - @words == 3 - || - @words >= 4 && length($word) - )) { - return sort grep /^\Q$word\E/, keys %keys; - } elsif (@words >= 4) { - return (); - } - my %seen; - my(@o_conf) = sort grep { !$seen{$_}++ } - keys %can, - keys %$CPAN::Config, - keys %keys; - return grep /^\Q$word\E/, @o_conf; -} - -sub prefs_lookup { - my($self,$distro,$what) = @_; - - if ($prefssupport{$what}) { - return $CPAN::Config->{$what} unless - $distro - and $distro->prefs - and $distro->prefs->{cpanconfig} - and defined $distro->prefs->{cpanconfig}{$what}; - return $distro->prefs->{cpanconfig}{$what}; - } else { - $CPAN::Frontend->mywarn("Warning: $what not yet officially ". - "supported for distroprefs, doing a normal lookup"); - return $CPAN::Config->{$what}; - } -} - - -{ - package - CPAN::Config; ####::###### #hide from indexer - # note: J. Nick Koston wrote me that they are using - # CPAN::Config->commit although undocumented. I suggested - # CPAN::Shell->o("conf","commit") even when ugly it is at least - # documented - - # that's why I added the CPAN::Config class with autoload and - # deprecated warning - - use strict; - use vars qw($AUTOLOAD $VERSION); - $VERSION = "5.5"; - - # formerly CPAN::HandleConfig was known as CPAN::Config - sub AUTOLOAD { ## no critic - my $class = shift; # e.g. in dh-make-perl: CPAN::Config - my($l) = $AUTOLOAD; - $CPAN::Frontend->mywarn("Dispatching deprecated method '$l' to CPAN::HandleConfig\n"); - $l =~ s/.*:://; - CPAN::HandleConfig->$l(@_); - } -} - -1; - -__END__ - -=head1 LICENSE - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut - -# Local Variables: -# mode: cperl -# cperl-indent-level: 4 -# End: diff --git a/lib/CPAN/Index.pm b/lib/CPAN/Index.pm deleted file mode 100644 index 3fa9e60229..0000000000 --- a/lib/CPAN/Index.pm +++ /dev/null @@ -1,619 +0,0 @@ -package CPAN::Index; -use strict; -use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION); -$VERSION = "1.93"; -@CPAN::Index::ISA = qw(CPAN::Debug); -$LAST_TIME ||= 0; -$DATE_OF_03 ||= 0; -# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57 -sub PROTOCOL { 2.0 } - -#-> sub CPAN::Index::force_reload ; -sub force_reload { - my($class) = @_; - $CPAN::Index::LAST_TIME = 0; - $class->reload(1); -} - -my @indexbundle = - ( - { - reader => "rd_authindex", - dir => "authors", - remotefile => '01mailrc.txt.gz', - shortlocalfile => '01mailrc.gz', - }, - { - reader => "rd_modpacks", - dir => "modules", - remotefile => '02packages.details.txt.gz', - shortlocalfile => '02packag.gz', - }, - { - reader => "rd_modlist", - dir => "modules", - remotefile => '03modlist.data.gz', - shortlocalfile => '03mlist.gz', - }, - ); - -#-> sub CPAN::Index::reload ; -sub reload { - my($self,$force) = @_; - my $time = time; - - # XXX check if a newer one is available. (We currently read it - # from time to time) - for ($CPAN::Config->{index_expire}) { - $_ = 0.001 unless $_ && $_ > 0.001; - } - unless (1 || $CPAN::Have_warned->{readmetadatacache}++) { - # debug here when CPAN doesn't seem to read the Metadata - require Carp; - Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]"); - } - unless ($CPAN::META->{PROTOCOL}) { - $self->read_metadata_cache; - $CPAN::META->{PROTOCOL} ||= "1.0"; - } - if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) { - # warn "Setting last_time to 0"; - $LAST_TIME = 0; # No warning necessary - } - if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time - and ! $force) { - # called too often - # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]"); - } elsif (0) { - # IFF we are developing, it helps to wipe out the memory - # between reloads, otherwise it is not what a user expects. - undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274) - $CPAN::META = CPAN->new; - } else { - my($debug,$t2); - local $LAST_TIME = $time; - local $CPAN::META->{PROTOCOL} = PROTOCOL; - - my $needshort = $^O eq "dos"; - - INX: for my $indexbundle (@indexbundle) { - my $reader = $indexbundle->{reader}; - my $localfile = $needshort ? $indexbundle->{shortlocalfile} : $indexbundle->{remotefile}; - my $localpath = File::Spec->catfile($indexbundle->{dir}, $localfile); - my $remote = join "/", $indexbundle->{dir}, $indexbundle->{remotefile}; - my $localized = $self->reload_x($remote, $localpath, $force); - $self->$reader($localized); # may die but we let the shell catch it - if ($CPAN::DEBUG){ - $t2 = time; - $debug = "timing reading 01[".($t2 - $time)."]"; - $time = $t2; - } - return if $CPAN::Signal; # this is sometimes lengthy - } - $self->write_metadata_cache; - if ($CPAN::DEBUG){ - $t2 = time; - $debug .= "03[".($t2 - $time)."]"; - $time = $t2; - } - CPAN->debug($debug) if $CPAN::DEBUG; - } - if ($CPAN::Config->{build_dir_reuse}) { - $self->reanimate_build_dir; - } - if (CPAN::_sqlite_running()) { - $CPAN::SQLite->reload(time => $time, force => $force) - if not $LAST_TIME; - } - $LAST_TIME = $time; - $CPAN::META->{PROTOCOL} = PROTOCOL; -} - -#-> sub CPAN::Index::reanimate_build_dir ; -sub reanimate_build_dir { - my($self) = @_; - unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) { - return; - } - return if $HAVE_REANIMATED++; - my $d = $CPAN::Config->{build_dir}; - my $dh = DirHandle->new; - opendir $dh, $d or return; # does not exist - my $dirent; - my $i = 0; - my $painted = 0; - my $restored = 0; - my @candidates = map { $_->[0] } - sort { $b->[1] <=> $a->[1] } - map { [ $_, -M File::Spec->catfile($d,$_) ] } - grep {/\.yml$/} readdir $dh; - unless (@candidates) { - $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n"); - return; - } - $CPAN::Frontend->myprint - (sprintf("Going to read %d yaml file%s from %s/\n", - scalar @candidates, - @candidates==1 ? "" : "s", - $CPAN::Config->{build_dir} - )); - my $start = CPAN::FTP::_mytime(); - DISTRO: for $i (0..$#candidates) { - my $dirent = $candidates[$i]; - my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))}; - if ($@) { - warn "Error while parsing file '$dirent'; error: '$@'"; - next DISTRO; - } - my $c = $y->[0]; - if ($c && $c->{perl} && $c->{distribution} && CPAN->_perl_fingerprint($c->{perl})) { - my $key = $c->{distribution}{ID}; - for my $k (keys %{$c->{distribution}}) { - if ($c->{distribution}{$k} - && ref $c->{distribution}{$k} - && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) { - $c->{distribution}{$k}{COMMANDID} = $i - @candidates; - } - } - - #we tried to restore only if element already - #exists; but then we do not work with metadata - #turned off. - my $do - = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key} - = $c->{distribution}; - for my $skipper (qw( - badtestcnt - configure_requires_later - configure_requires_later_for - force_update - later - later_for - notest - should_report - sponsored_mods - prefs - negative_prefs_cache - )) { - delete $do->{$skipper}; - } - if ($do->can("tested_ok_but_not_installed")) { - if ($do->tested_ok_but_not_installed) { - $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME}); - } else { - next DISTRO; - } - } - $restored++; - } - $i++; - while (($painted/76) < ($i/@candidates)) { - $CPAN::Frontend->myprint("."); - $painted++; - } - } - my $took = CPAN::FTP::_mytime() - $start; - $CPAN::Frontend->myprint(sprintf( - "DONE\nRestored the state of %s (in %.4f secs)\n", - $restored || "none", - $took, - )); -} - - -#-> sub CPAN::Index::reload_x ; -sub reload_x { - my($cl,$wanted,$localname,$force) = @_; - $force |= 2; # means we're dealing with an index here - CPAN::HandleConfig->load; # we should guarantee loading wherever - # we rely on Config XXX - $localname ||= $wanted; - my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'}, - $localname); - if ( - -f $abs_wanted && - -M $abs_wanted < $CPAN::Config->{'index_expire'} && - !($force & 1) - ) { - my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s"; - $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }. - qq{day$s. I\'ll use that.}); - return $abs_wanted; - } else { - $force |= 1; # means we're quite serious about it. - } - return CPAN::FTP->localize($wanted,$abs_wanted,$force); -} - -#-> sub CPAN::Index::rd_authindex ; -sub rd_authindex { - my($cl, $index_target) = @_; - return unless defined $index_target; - return if CPAN::_sqlite_running(); - my @lines; - $CPAN::Frontend->myprint("Going to read '$index_target'\n"); - local(*FH); - tie *FH, 'CPAN::Tarzip', $index_target; - local($/) = "\n"; - local($_); - push @lines, split /\012/ while <FH>; - my $i = 0; - my $painted = 0; - foreach (@lines) { - my($userid,$fullname,$email) = - m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/; - $fullname ||= $email; - if ($userid && $fullname && $email) { - my $userobj = $CPAN::META->instance('CPAN::Author',$userid); - $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email); - } else { - CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG; - } - $i++; - while (($painted/76) < ($i/@lines)) { - $CPAN::Frontend->myprint("."); - $painted++; - } - return if $CPAN::Signal; - } - $CPAN::Frontend->myprint("DONE\n"); -} - -sub userid { - my($self,$dist) = @_; - $dist = $self->{'id'} unless defined $dist; - my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|; - $ret; -} - -#-> sub CPAN::Index::rd_modpacks ; -sub rd_modpacks { - my($self, $index_target) = @_; - return unless defined $index_target; - return if CPAN::_sqlite_running(); - $CPAN::Frontend->myprint("Going to read '$index_target'\n"); - my $fh = CPAN::Tarzip->TIEHANDLE($index_target); - local $_; - CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG; - my $slurp = ""; - my $chunk; - while (my $bytes = $fh->READ(\$chunk,8192)) { - $slurp.=$chunk; - } - my @lines = split /\012/, $slurp; - CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG; - undef $fh; - # read header - my($line_count,$last_updated); - while (@lines) { - my $shift = shift(@lines); - last if $shift =~ /^\s*$/; - $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1; - $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1; - } - CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG; - if (not defined $line_count) { - - $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header. -Please check the validity of the index file by comparing it to more -than one CPAN mirror. I'll continue but problems seem likely to -happen.\a -}); - - $CPAN::Frontend->mysleep(5); - } elsif ($line_count != scalar @lines) { - - $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s -contains a Line-Count header of %d but I see %d lines there. Please -check the validity of the index file by comparing it to more than one -CPAN mirror. I'll continue but problems seem likely to happen.\a\n}, -$index_target, $line_count, scalar(@lines)); - - } - if (not defined $last_updated) { - - $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header. -Please check the validity of the index file by comparing it to more -than one CPAN mirror. I'll continue but problems seem likely to -happen.\a -}); - - $CPAN::Frontend->mysleep(5); - } else { - - $CPAN::Frontend - ->myprint(sprintf qq{ Database was generated on %s\n}, - $last_updated); - $DATE_OF_02 = $last_updated; - - my $age = time; - if ($CPAN::META->has_inst('HTTP::Date')) { - require HTTP::Date; - $age -= HTTP::Date::str2time($last_updated); - } else { - $CPAN::Frontend->mywarn(" HTTP::Date not available\n"); - require Time::Local; - my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /; - $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4; - $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0; - } - $age /= 3600*24; - if ($age > 30) { - - $CPAN::Frontend - ->mywarn(sprintf - qq{Warning: This index file is %d days old. - Please check the host you chose as your CPAN mirror for staleness. - I'll continue but problems seem likely to happen.\a\n}, - $age); - - } elsif ($age < -1) { - - $CPAN::Frontend - ->mywarn(sprintf - qq{Warning: Your system date is %d days behind this index file! - System time: %s - Timestamp index file: %s - Please fix your system time, problems with the make command expected.\n}, - -$age, - scalar gmtime, - $DATE_OF_02, - ); - - } - } - - - # A necessity since we have metadata_cache: delete what isn't - # there anymore - my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN"); - CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG; - my(%exists); - my $i = 0; - my $painted = 0; - foreach (@lines) { - # before 1.56 we split into 3 and discarded the rest. From - # 1.57 we assign remaining text to $comment thus allowing to - # influence isa_perl - my($mod,$version,$dist,$comment) = split " ", $_, 4; - unless ($mod && defined $version && $dist) { - $CPAN::Frontend->mywarn("Could not split line[$_]\n"); - next; - } - my($bundle,$id,$userid); - - if ($mod eq 'CPAN' && - ! ( - CPAN::Queue->exists('Bundle::CPAN') || - CPAN::Queue->exists('CPAN') - ) - ) { - local($^W)= 0; - if ($version > $CPAN::VERSION) { - $CPAN::Frontend->mywarn(qq{ - New CPAN.pm version (v$version) available. - [Currently running version is v$CPAN::VERSION] - You might want to try - install CPAN - reload cpan - to both upgrade CPAN.pm and run the new version without leaving - the current session. - -}); #}); - $CPAN::Frontend->mysleep(2); - $CPAN::Frontend->myprint(qq{\n}); - } - last if $CPAN::Signal; - } elsif ($mod =~ /^Bundle::(.*)/) { - $bundle = $1; - } - - if ($bundle) { - $id = $CPAN::META->instance('CPAN::Bundle',$mod); - # Let's make it a module too, because bundles have so much - # in common with modules. - - # Changed in 1.57_63: seems like memory bloat now without - # any value, so commented out - - # $CPAN::META->instance('CPAN::Module',$mod); - - } else { - - # instantiate a module object - $id = $CPAN::META->instance('CPAN::Module',$mod); - - } - - # Although CPAN prohibits same name with different version the - # indexer may have changed the version for the same distro - # since the last time ("Force Reindexing" feature) - if ($id->cpan_file ne $dist - || - $id->cpan_version ne $version - ) { - $userid = $id->userid || $self->userid($dist); - $id->set( - 'CPAN_USERID' => $userid, - 'CPAN_VERSION' => $version, - 'CPAN_FILE' => $dist, - ); - } - - # instantiate a distribution object - if ($CPAN::META->exists('CPAN::Distribution',$dist)) { - # we do not need CONTAINSMODS unless we do something with - # this dist, so we better produce it on demand. - - ## my $obj = $CPAN::META->instance( - ## 'CPAN::Distribution' => $dist - ## ); - ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental - } else { - $CPAN::META->instance( - 'CPAN::Distribution' => $dist - )->set( - 'CPAN_USERID' => $userid, - 'CPAN_COMMENT' => $comment, - ); - } - if ($secondtime) { - for my $name ($mod,$dist) { - # $self->debug("exists name[$name]") if $CPAN::DEBUG; - $exists{$name} = undef; - } - } - $i++; - while (($painted/76) < ($i/@lines)) { - $CPAN::Frontend->myprint("."); - $painted++; - } - return if $CPAN::Signal; - } - $CPAN::Frontend->myprint("DONE\n"); - if ($secondtime) { - for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) { - for my $o ($CPAN::META->all_objects($class)) { - next if exists $exists{$o->{ID}}; - $CPAN::META->delete($class,$o->{ID}); - # CPAN->debug("deleting ID[$o->{ID}] in class[$class]") - # if $CPAN::DEBUG; - } - } - } -} - -#-> sub CPAN::Index::rd_modlist ; -sub rd_modlist { - my($cl,$index_target) = @_; - return unless defined $index_target; - return if CPAN::_sqlite_running(); - $CPAN::Frontend->myprint("Going to read '$index_target'\n"); - my $fh = CPAN::Tarzip->TIEHANDLE($index_target); - local $_; - my $slurp = ""; - my $chunk; - while (my $bytes = $fh->READ(\$chunk,8192)) { - $slurp.=$chunk; - } - my @eval2 = split /\012/, $slurp; - - while (@eval2) { - my $shift = shift(@eval2); - if ($shift =~ /^Date:\s+(.*)/) { - if ($DATE_OF_03 eq $1) { - $CPAN::Frontend->myprint("Unchanged.\n"); - return; - } - ($DATE_OF_03) = $1; - } - last if $shift =~ /^\s*$/; - } - push @eval2, q{CPAN::Modulelist->data;}; - local($^W) = 0; - my($compmt) = Safe->new("CPAN::Safe1"); - my($eval2) = join("\n", @eval2); - CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG; - my $ret = $compmt->reval($eval2); - Carp::confess($@) if $@; - return if $CPAN::Signal; - my $i = 0; - my $until = keys(%$ret); - my $painted = 0; - CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG; - for (keys %$ret) { - my $obj = $CPAN::META->instance("CPAN::Module",$_); - delete $ret->{$_}{modid}; # not needed here, maybe elsewhere - $obj->set(%{$ret->{$_}}); - $i++; - while (($painted/76) < ($i/$until)) { - $CPAN::Frontend->myprint("."); - $painted++; - } - return if $CPAN::Signal; - } - $CPAN::Frontend->myprint("DONE\n"); -} - -#-> sub CPAN::Index::write_metadata_cache ; -sub write_metadata_cache { - my($self) = @_; - return unless $CPAN::Config->{'cache_metadata'}; - return if CPAN::_sqlite_running(); - return unless $CPAN::META->has_usable("Storable"); - my $cache; - foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module - CPAN::Distribution)) { - $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok - } - my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata"); - $cache->{last_time} = $LAST_TIME; - $cache->{DATE_OF_02} = $DATE_OF_02; - $cache->{PROTOCOL} = PROTOCOL; - $CPAN::Frontend->myprint("Going to write $metadata_file\n"); - eval { Storable::nstore($cache, $metadata_file) }; - $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ?? -} - -#-> sub CPAN::Index::read_metadata_cache ; -sub read_metadata_cache { - my($self) = @_; - return unless $CPAN::Config->{'cache_metadata'}; - return if CPAN::_sqlite_running(); - return unless $CPAN::META->has_usable("Storable"); - my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata"); - return unless -r $metadata_file and -f $metadata_file; - $CPAN::Frontend->myprint("Going to read '$metadata_file'\n"); - my $cache; - eval { $cache = Storable::retrieve($metadata_file) }; - $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ?? - if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) { - $LAST_TIME = 0; - return; - } - if (exists $cache->{PROTOCOL}) { - if (PROTOCOL > $cache->{PROTOCOL}) { - $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ". - "with protocol v%s, requiring v%s\n", - $cache->{PROTOCOL}, - PROTOCOL) - ); - return; - } - } else { - $CPAN::Frontend->mywarn("Ignoring Metadata cache written ". - "with protocol v1.0\n"); - return; - } - my $clcnt = 0; - my $idcnt = 0; - while(my($class,$v) = each %$cache) { - next unless $class =~ /^CPAN::/; - $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok - while (my($id,$ro) = each %$v) { - $CPAN::META->{readwrite}{$class}{$id} ||= - $class->new(ID=>$id, RO=>$ro); - $idcnt++; - } - $clcnt++; - } - unless ($clcnt) { # sanity check - $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n"); - return; - } - if ($idcnt < 1000) { - $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ". - "in $metadata_file\n"); - return; - } - $CPAN::META->{PROTOCOL} ||= - $cache->{PROTOCOL}; # reading does not up or downgrade, but it - # does initialize to some protocol - $LAST_TIME = $cache->{last_time}; - $DATE_OF_02 = $cache->{DATE_OF_02}; - $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n") - if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02 - return; -} - -1; diff --git a/lib/CPAN/InfoObj.pm b/lib/CPAN/InfoObj.pm deleted file mode 100644 index 9198316c69..0000000000 --- a/lib/CPAN/InfoObj.pm +++ /dev/null @@ -1,224 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::InfoObj; -use strict; - -use CPAN::Debug; -@CPAN::InfoObj::ISA = qw(CPAN::Debug); - -use Cwd qw(chdir); - -use vars qw( - $VERSION -); -$VERSION = "5.5"; - -sub ro { - my $self = shift; - exists $self->{RO} and return $self->{RO}; -} - -#-> sub CPAN::InfoObj::cpan_userid -sub cpan_userid { - my $self = shift; - my $ro = $self->ro; - if ($ro) { - return $ro->{CPAN_USERID} || "N/A"; - } else { - $self->debug("ID[$self->{ID}]"); - # N/A for bundles found locally - return "N/A"; - } -} - -sub id { shift->{ID}; } - -#-> sub CPAN::InfoObj::new ; -sub new { - my $this = bless {}, shift; - %$this = @_; - $this -} - -# The set method may only be used by code that reads index data or -# otherwise "objective" data from the outside world. All session -# related material may do anything else with instance variables but -# must not touch the hash under the RO attribute. The reason is that -# the RO hash gets written to Metadata file and is thus persistent. - -#-> sub CPAN::InfoObj::safe_chdir ; -sub safe_chdir { - my($self,$todir) = @_; - # we die if we cannot chdir and we are debuggable - Carp::confess("safe_chdir called without todir argument") - unless defined $todir and length $todir; - if (chdir $todir) { - $self->debug(sprintf "changed directory to %s", CPAN::anycwd()) - if $CPAN::DEBUG; - } else { - if (-e $todir) { - unless (-x $todir) { - unless (chmod 0755, $todir) { - my $cwd = CPAN::anycwd(); - $CPAN::Frontend->mywarn("I have neither the -x permission nor the ". - "permission to change the permission; cannot ". - "chdir to '$todir'\n"); - $CPAN::Frontend->mysleep(5); - $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }. - qq{to todir[$todir]: $!}); - } - } - } else { - $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n"); - } - if (chdir $todir) { - $self->debug(sprintf "changed directory to %s", CPAN::anycwd()) - if $CPAN::DEBUG; - } else { - my $cwd = CPAN::anycwd(); - $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }. - qq{to todir[$todir] (a chmod has been issued): $!}); - } - } -} - -#-> sub CPAN::InfoObj::set ; -sub set { - my($self,%att) = @_; - my $class = ref $self; - - # This must be ||=, not ||, because only if we write an empty - # reference, only then the set method will write into the readonly - # area. But for Distributions that spring into existence, maybe - # because of a typo, we do not like it that they are written into - # the readonly area and made permanent (at least for a while) and - # that is why we do not "allow" other places to call ->set. - unless ($self->id) { - CPAN->debug("Bug? Empty ID, rejecting"); - return; - } - my $ro = $self->{RO} = - $CPAN::META->{readonly}{$class}{$self->id} ||= {}; - - while (my($k,$v) = each %att) { - $ro->{$k} = $v; - } -} - -#-> sub CPAN::InfoObj::as_glimpse ; -sub as_glimpse { - my($self) = @_; - my(@m); - my $class = ref($self); - $class =~ s/^CPAN:://; - my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID}; - push @m, sprintf "%-15s %s\n", $class, $id; - join "", @m; -} - -#-> sub CPAN::InfoObj::as_string ; -sub as_string { - my($self) = @_; - my(@m); - my $class = ref($self); - $class =~ s/^CPAN:://; - push @m, $class, " id = $self->{ID}\n"; - my $ro; - unless ($ro = $self->ro) { - if (substr($self->{ID},-1,1) eq ".") { # directory - $ro = +{}; - } else { - $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n"); - $CPAN::Frontend->mysleep(5); - return; - } - } - for (sort keys %$ro) { - # next if m/^(ID|RO)$/; - my $extra = ""; - if ($_ eq "CPAN_USERID") { - $extra .= " ("; - $extra .= $self->fullname; - my $email; # old perls! - if ($email = $CPAN::META->instance("CPAN::Author", - $self->cpan_userid - )->email) { - $extra .= " <$email>"; - } else { - $extra .= " <no email>"; - } - $extra .= ")"; - } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion - push @m, sprintf " %-12s %s\n", $_, $self->fullname; - next; - } - next unless defined $ro->{$_}; - push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra; - } - KEY: for (sort keys %$self) { - next if m/^(ID|RO)$/; - unless (defined $self->{$_}) { - delete $self->{$_}; - next KEY; - } - if (ref($self->{$_}) eq "ARRAY") { - push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}"; - } elsif (ref($self->{$_}) eq "HASH") { - my $value; - if (/^CONTAINSMODS$/) { - $value = join(" ",sort keys %{$self->{$_}}); - } elsif (/^prereq_pm$/) { - my @value; - my $v = $self->{$_}; - for my $x (sort keys %$v) { - my @svalue; - for my $y (sort keys %{$v->{$x}}) { - push @svalue, "$y=>$v->{$x}{$y}"; - } - push @value, "$x\:" . join ",", @svalue if @svalue; - } - $value = join ";", @value; - } else { - $value = $self->{$_}; - } - push @m, sprintf( - " %-12s %s\n", - $_, - $value, - ); - } else { - push @m, sprintf " %-12s %s\n", $_, $self->{$_}; - } - } - join "", @m, "\n"; -} - -#-> sub CPAN::InfoObj::fullname ; -sub fullname { - my($self) = @_; - $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname; -} - -#-> sub CPAN::InfoObj::dump ; -sub dump { - my($self, $what) = @_; - unless ($CPAN::META->has_inst("Data::Dumper")) { - $CPAN::Frontend->mydie("dump command requires Data::Dumper installed"); - } - local $Data::Dumper::Sortkeys; - $Data::Dumper::Sortkeys = 1; - my $out = Data::Dumper::Dumper($what ? eval $what : $self); - if (length $out > 100000) { - my $fh_pager = FileHandle->new; - local($SIG{PIPE}) = "IGNORE"; - my $pager = $CPAN::Config->{'pager'} || "cat"; - $fh_pager->open("|$pager") - or die "Could not open pager $pager\: $!"; - $fh_pager->print($out); - close $fh_pager; - } else { - $CPAN::Frontend->myprint($out); - } -} - -1; diff --git a/lib/CPAN/Kwalify.pm b/lib/CPAN/Kwalify.pm deleted file mode 100644 index 3cade90b91..0000000000 --- a/lib/CPAN/Kwalify.pm +++ /dev/null @@ -1,136 +0,0 @@ -=head1 NAME - -CPAN::Kwalify - Interface between CPAN.pm and Kwalify.pm - -=head1 SYNOPSIS - - use CPAN::Kwalify; - validate($schema_name, $data, $file, $doc); - -=head1 DESCRIPTION - -=over - -=item _validate($schema_name, $data, $file, $doc) - -$schema_name is the name of a supported schema. Currently only -C<distroprefs> is supported. $data is the data to be validated. $file -is the absolute path to the file the data are coming from. $doc is the -index of the document within $doc that is to be validated. The last -two arguments are only there for better error reporting. - -Relies on being called from within CPAN.pm. - -Dies if something fails. Does not return anything useful. - -=item yaml($schema_name) - -Returns the YAML text of that schema. Dies if something fails. - -=back - -=head1 AUTHOR - -Andreas Koenig C<< <andk@cpan.org> >> - -=head1 LICENSE - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See L<http://www.perl.com/perl/misc/Artistic.html> - - - -=cut - - -use strict; - -package CPAN::Kwalify; -use vars qw($VERSION $VAR1); -$VERSION = "5.50"; - -use File::Spec (); - -my %vcache = (); - -my $schema_loaded = {}; - -sub _validate { - my($schema_name,$data,$abs,$y) = @_; - my $yaml_module = CPAN->_yaml_module; - if ( - $CPAN::META->has_inst($yaml_module) - && - $CPAN::META->has_inst("Kwalify") - ) { - my $load = UNIVERSAL::can($yaml_module,"Load"); - unless ($schema_loaded->{$schema_name}) { - eval { - my $schema_yaml = yaml($schema_name); - $schema_loaded->{$schema_name} = $load->($schema_yaml); - }; - if ($@) { - # we know that YAML.pm 0.62 cannot parse the schema, - # so we try a fallback - my $content = do { - my $path = __FILE__; - $path =~ s/\.pm$//; - $path = File::Spec->catfile($path, "$schema_name.dd"); - local *FH; - open FH, $path or die "Could not open '$path': $!"; - local $/; - <FH>; - }; - $VAR1 = undef; - eval $content; - if (my $err = $@) { - die "parsing of '$schema_name.dd' failed: $err"; - } - $schema_loaded->{$schema_name} = $VAR1; - } - } - } - if (my $schema = $schema_loaded->{$schema_name}) { - my $mtime = (stat $abs)[9]; - for my $k (keys %{$vcache{$abs}}) { - delete $vcache{$abs}{$k} unless $k eq $mtime; - } - return if $vcache{$abs}{$mtime}{$y}++; - eval { Kwalify::validate($schema, $data) }; - if (my $err = $@) { - my $info = {}; yaml($schema_name, info => $info); - die "validation of distropref '$abs'[$y] against schema '$info->{path}' failed: $err"; - } - } -} - -sub _clear_cache { - %vcache = (); -} - -sub yaml { - my($schema_name, %opt) = @_; - my $content = do { - my $path = __FILE__; - $path =~ s/\.pm$//; - $path = File::Spec->catfile($path, "$schema_name.yml"); - if ($opt{info}) { - $opt{info}{path} = $path; - } - local *FH; - open FH, $path or die "Could not open '$path': $!"; - local $/; - <FH>; - }; - return $content; -} - -1; - -# Local Variables: -# mode: cperl -# cperl-indent-level: 4 -# End: - diff --git a/lib/CPAN/Kwalify/distroprefs.dd b/lib/CPAN/Kwalify/distroprefs.dd deleted file mode 100644 index fd046271b8..0000000000 --- a/lib/CPAN/Kwalify/distroprefs.dd +++ /dev/null @@ -1,150 +0,0 @@ -$VAR1 = { - "mapping" => { - "comment" => { - "type" => "text" - }, - "cpanconfig" => { - "mapping" => { - "=" => { - "type" => "text" - } - }, - "type" => "map" - }, - "depends" => { - "mapping" => { - "build_requires" => { - "mapping" => { - "=" => { - "type" => "text" - } - }, - "type" => "map" - }, - "configure_requires" => {}, - "requires" => {} - }, - "type" => "map" - }, - "disabled" => { - "enum" => [ - 0, - 1 - ], - "type" => "int" - }, - "features" => { - "sequence" => [ - { - "type" => "text" - } - ], - "type" => "seq" - }, - "goto" => { - "type" => "text" - }, - "install" => { - "mapping" => { - "args" => { - "sequence" => [ - { - "type" => "text" - } - ], - "type" => "seq" - }, - "commandline" => { - "type" => "text" - }, - "eexpect" => { - "mapping" => { - "mode" => { - "enum" => [ - "deterministic", - "anyorder" - ], - "type" => "text" - }, - "reuse" => { - "type" => "int" - }, - "talk" => { - "sequence" => [ - { - "type" => "text" - } - ], - "type" => "seq" - }, - "timeout" => { - "type" => "number" - } - }, - "type" => "map" - }, - "env" => { - "mapping" => { - "=" => { - "type" => "text" - } - }, - "type" => "map" - }, - "expect" => { - "sequence" => [ - { - "type" => "text" - } - ], - "type" => "seq" - } - }, - "type" => "map" - }, - "make" => {}, - "match" => { - "mapping" => { - "distribution" => { - "type" => "text" - }, - "env" => { - "mapping" => { - "=" => { - "type" => "text" - } - }, - "type" => "map" - }, - "module" => { - "type" => "text" - }, - "perl" => { - "type" => "text" - }, - "perlconfig" => {} - }, - "type" => "map" - }, - "patches" => { - "sequence" => [ - { - "type" => "text" - } - ], - "type" => "seq" - }, - "pl" => {}, - "reminder" => { - "type" => "text" - }, - "test" => {} - }, - "type" => "map" -}; -$VAR1->{"mapping"}{"depends"}{"mapping"}{"configure_requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"}; -$VAR1->{"mapping"}{"depends"}{"mapping"}{"requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"}; -$VAR1->{"mapping"}{"make"} = $VAR1->{"mapping"}{"install"}; -$VAR1->{"mapping"}{"match"}{"mapping"}{"perlconfig"} = $VAR1->{"mapping"}{"match"}{"mapping"}{"env"}; -$VAR1->{"mapping"}{"pl"} = $VAR1->{"mapping"}{"install"}; -$VAR1->{"mapping"}{"test"} = $VAR1->{"mapping"}{"install"}; diff --git a/lib/CPAN/Kwalify/distroprefs.yml b/lib/CPAN/Kwalify/distroprefs.yml deleted file mode 100644 index 431f174276..0000000000 --- a/lib/CPAN/Kwalify/distroprefs.yml +++ /dev/null @@ -1,92 +0,0 @@ ---- -type: map -mapping: - comment: - type: text - depends: - type: map - mapping: - configure_requires: - &requires_common - type: map - mapping: - =: - type: text - build_requires: *requires_common - requires: *requires_common - match: - type: map - mapping: - distribution: - type: text - module: - type: text - perl: - type: text - perlconfig: - &matchhash_common - type: map - mapping: - =: - type: text - env: *matchhash_common - install: - &args_env_expect - type: map - mapping: - args: - type: seq - sequence: - - type: text - commandline: - type: text - env: - type: map - mapping: - =: - type: text - expect: - type: seq - sequence: - - type: text - eexpect: - type: map - mapping: - mode: - type: text - enum: - - deterministic - - anyorder - timeout: - type: number - reuse: - type: int - talk: - type: seq - sequence: - - type: text - make: *args_env_expect - pl: *args_env_expect - test: *args_env_expect - patches: - type: seq - sequence: - - type: text - disabled: - type: int - enum: - - 0 - - 1 - goto: - type: text - cpanconfig: - type: map - mapping: - =: - type: text - features: - type: seq - sequence: - - type: text - reminder: - type: text diff --git a/lib/CPAN/LWP/UserAgent.pm b/lib/CPAN/LWP/UserAgent.pm deleted file mode 100644 index 8a5d8447e6..0000000000 --- a/lib/CPAN/LWP/UserAgent.pm +++ /dev/null @@ -1,135 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::LWP::UserAgent; -use strict; -use vars qw(@ISA $USER $PASSWD $SETUPDONE); -# we delay requiring LWP::UserAgent and setting up inheritance until we need it - -$CPAN::LWP::UserAgent::VERSION = $CPAN::LWP::UserAgent::VERSION = "1.00"; - -sub config { - return if $SETUPDONE; - if ($CPAN::META->has_usable('LWP::UserAgent')) { - require LWP::UserAgent; - @ISA = qw(Exporter LWP::UserAgent); ## no critic - $SETUPDONE++; - } else { - $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n"); - } -} - -sub get_basic_credentials { - my($self, $realm, $uri, $proxy) = @_; - if ($USER && $PASSWD) { - return ($USER, $PASSWD); - } - if ( $proxy ) { - ($USER,$PASSWD) = $self->get_proxy_credentials(); - } else { - ($USER,$PASSWD) = $self->get_non_proxy_credentials(); - } - return($USER,$PASSWD); -} - -sub get_proxy_credentials { - my $self = shift; - my ($user, $password); - if ( defined $CPAN::Config->{proxy_user} ) { - $user = $CPAN::Config->{proxy_user}; - $password = $CPAN::Config->{proxy_pass} || ""; - return ($user, $password); - } - my $username_prompt = "\nProxy authentication needed! - (Note: to permanently configure username and password run - o conf proxy_user your_username - o conf proxy_pass your_password - )\nUsername:"; - ($user, $password) = - _get_username_and_password_from_user($username_prompt); - return ($user,$password); -} - -sub get_non_proxy_credentials { - my $self = shift; - my ($user,$password); - if ( defined $CPAN::Config->{username} ) { - $user = $CPAN::Config->{username}; - $password = $CPAN::Config->{password} || ""; - return ($user, $password); - } - my $username_prompt = "\nAuthentication needed! - (Note: to permanently configure username and password run - o conf username your_username - o conf password your_password - )\nUsername:"; - - ($user, $password) = - _get_username_and_password_from_user($username_prompt); - return ($user,$password); -} - -sub _get_username_and_password_from_user { - my $username_message = shift; - my ($username,$password); - - ExtUtils::MakeMaker->import(qw(prompt)); - $username = prompt($username_message); - if ($CPAN::META->has_inst("Term::ReadKey")) { - Term::ReadKey::ReadMode("noecho"); - } - else { - $CPAN::Frontend->mywarn( - "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n" - ); - } - $password = prompt("Password:"); - - if ($CPAN::META->has_inst("Term::ReadKey")) { - Term::ReadKey::ReadMode("restore"); - } - $CPAN::Frontend->myprint("\n\n"); - return ($username,$password); -} - -# mirror(): Its purpose is to deal with proxy authentication. When we -# call SUPER::mirror, we relly call the mirror method in -# LWP::UserAgent. LWP::UserAgent will then call -# $self->get_basic_credentials or some equivalent and this will be -# $self->dispatched to our own get_basic_credentials method. - -# Our own get_basic_credentials sets $USER and $PASSWD, two globals. - -# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means -# although we have gone through our get_basic_credentials, the proxy -# server refuses to connect. This could be a case where the username or -# password has changed in the meantime, so I'm trying once again without -# $USER and $PASSWD to give the get_basic_credentials routine another -# chance to set $USER and $PASSWD. - -# mirror(): Its purpose is to deal with proxy authentication. When we -# call SUPER::mirror, we relly call the mirror method in -# LWP::UserAgent. LWP::UserAgent will then call -# $self->get_basic_credentials or some equivalent and this will be -# $self->dispatched to our own get_basic_credentials method. - -# Our own get_basic_credentials sets $USER and $PASSWD, two globals. - -# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means -# although we have gone through our get_basic_credentials, the proxy -# server refuses to connect. This could be a case where the username or -# password has changed in the meantime, so I'm trying once again without -# $USER and $PASSWD to give the get_basic_credentials routine another -# chance to set $USER and $PASSWD. - -sub mirror { - my($self,$url,$aslocal) = @_; - my $result = $self->SUPER::mirror($url,$aslocal); - if ($result->code == 407) { - undef $USER; - undef $PASSWD; - $result = $self->SUPER::mirror($url,$aslocal); - } - $result; -} - -1; diff --git a/lib/CPAN/Module.pm b/lib/CPAN/Module.pm deleted file mode 100644 index eae5a73aaa..0000000000 --- a/lib/CPAN/Module.pm +++ /dev/null @@ -1,681 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::Module; -use strict; -@CPAN::Module::ISA = qw(CPAN::InfoObj); - -use vars qw( - $VERSION -); -$VERSION = "5.5"; - -# Accessors -#-> sub CPAN::Module::userid -sub userid { - my $self = shift; - my $ro = $self->ro; - return unless $ro; - return $ro->{userid} || $ro->{CPAN_USERID}; -} -#-> sub CPAN::Module::description -sub description { - my $self = shift; - my $ro = $self->ro or return ""; - $ro->{description} -} - -#-> sub CPAN::Module::distribution -sub distribution { - my($self) = @_; - CPAN::Shell->expand("Distribution",$self->cpan_file); -} - -#-> sub CPAN::Module::_is_representative_module -sub _is_representative_module { - my($self) = @_; - return $self->{_is_representative_module} if defined $self->{_is_representative_module}; - my $pm = $self->cpan_file or return $self->{_is_representative_module} = 0; - $pm =~ s|.+/||; - $pm =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; # see base_id - $pm =~ s|-\d+\.\d+.+$||; - $pm =~ s|-[\d\.]+$||; - $pm =~ s/-/::/g; - $self->{_is_representative_module} = $pm eq $self->{ID} ? 1 : 0; - # warn "DEBUG: $pm eq $self->{ID} => $self->{_is_representative_module}"; - $self->{_is_representative_module}; -} - -#-> sub CPAN::Module::undelay -sub undelay { - my $self = shift; - delete $self->{later}; - if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) { - $dist->undelay; - } -} - -# mark as dirty/clean -#-> sub CPAN::Module::color_cmd_tmps ; -sub color_cmd_tmps { - my($self) = shift; - my($depth) = shift || 0; - my($color) = shift || 0; - my($ancestors) = shift || []; - # a module needs to recurse to its cpan_file - - return if exists $self->{incommandcolor} - && $color==1 - && $self->{incommandcolor}==$color; - return if $color==0 && !$self->{incommandcolor}; - if ($color>=1) { - if ( $self->uptodate ) { - $self->{incommandcolor} = $color; - return; - } elsif (my $have_version = $self->available_version) { - # maybe what we have is good enough - if (@$ancestors) { - my $who_asked_for_me = $ancestors->[-1]; - my $obj = CPAN::Shell->expandany($who_asked_for_me); - if (0) { - } elsif ($obj->isa("CPAN::Bundle")) { - # bundles cannot specify a minimum version - return; - } elsif ($obj->isa("CPAN::Distribution")) { - if (my $prereq_pm = $obj->prereq_pm) { - for my $k (keys %$prereq_pm) { - if (my $want_version = $prereq_pm->{$k}{$self->id}) { - if (CPAN::Version->vcmp($have_version,$want_version) >= 0) { - $self->{incommandcolor} = $color; - return; - } - } - } - } - } - } - } - } else { - $self->{incommandcolor} = $color; # set me before recursion, - # so we can break it - } - if ($depth>=$CPAN::MAX_RECURSION) { - die(CPAN::Exception::RecursiveDependency->new($ancestors)); - } - # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; - - if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) { - $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); - } - # unreached code? - # if ($color==0) { - # delete $self->{badtestcnt}; - # } - $self->{incommandcolor} = $color; -} - -#-> sub CPAN::Module::as_glimpse ; -sub as_glimpse { - my($self) = @_; - my(@m); - my $class = ref($self); - $class =~ s/^CPAN:://; - my $color_on = ""; - my $color_off = ""; - if ( - $CPAN::Shell::COLOR_REGISTERED - && - $CPAN::META->has_inst("Term::ANSIColor") - && - $self->description - ) { - $color_on = Term::ANSIColor::color("green"); - $color_off = Term::ANSIColor::color("reset"); - } - my $uptodateness = " "; - unless ($class eq "Bundle") { - my $u = $self->uptodate; - $uptodateness = $u ? "=" : "<" if defined $u; - }; - my $id = do { - my $d = $self->distribution; - $d ? $d -> pretty_id : $self->cpan_userid; - }; - push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n", - $class, - $uptodateness, - $color_on, - $self->id, - $color_off, - $id, - ); - join "", @m; -} - -#-> sub CPAN::Module::dslip_status -sub dslip_status { - my($self) = @_; - my($stat); - # development status - @{$stat->{D}}{qw,i c a b R M S,} = qw,idea - pre-alpha alpha beta released - mature standard,; - # support level - @{$stat->{S}}{qw,m d u n a,} = qw,mailing-list - developer comp.lang.perl.* - none abandoned,; - # language - @{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,; - # interface - @{$stat->{I}}{qw,f r O p h n,} = qw,functions - references+ties - object-oriented pragma - hybrid none,; - # public licence - @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl - GPL LGPL - BSD Artistic Artistic_2 - open-source - distribution_allowed - restricted_distribution - no_licence,; - for my $x (qw(d s l i p)) { - $stat->{$x}{' '} = 'unknown'; - $stat->{$x}{'?'} = 'unknown'; - } - my $ro = $self->ro; - return +{} unless $ro && $ro->{statd}; - return { - D => $ro->{statd}, - S => $ro->{stats}, - L => $ro->{statl}, - I => $ro->{stati}, - P => $ro->{statp}, - DV => $stat->{D}{$ro->{statd}}, - SV => $stat->{S}{$ro->{stats}}, - LV => $stat->{L}{$ro->{statl}}, - IV => $stat->{I}{$ro->{stati}}, - PV => $stat->{P}{$ro->{statp}}, - }; -} - -#-> sub CPAN::Module::as_string ; -sub as_string { - my($self) = @_; - my(@m); - CPAN->debug("$self entering as_string") if $CPAN::DEBUG; - my $class = ref($self); - $class =~ s/^CPAN:://; - local($^W) = 0; - push @m, $class, " id = $self->{ID}\n"; - my $sprintf = " %-12s %s\n"; - push @m, sprintf($sprintf, 'DESCRIPTION', $self->description) - if $self->description; - my $sprintf2 = " %-12s %s (%s)\n"; - my($userid); - $userid = $self->userid; - if ( $userid ) { - my $author; - if ($author = CPAN::Shell->expand('Author',$userid)) { - my $email = ""; - my $m; # old perls - if ($m = $author->email) { - $email = " <$m>"; - } - push @m, sprintf( - $sprintf2, - 'CPAN_USERID', - $userid, - $author->fullname . $email - ); - } - } - push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version) - if $self->cpan_version; - if (my $cpan_file = $self->cpan_file) { - push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file); - if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) { - my $upload_date = $dist->upload_date; - if ($upload_date) { - push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date); - } - } - } - my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n"; - my $dslip = $self->dslip_status; - push @m, sprintf( - $sprintf3, - 'DSLIP_STATUS', - @{$dslip}{qw(D S L I P DV SV LV IV PV)}, - ) if $dslip->{D}; - my $local_file = $self->inst_file; - unless ($self->{MANPAGE}) { - my $manpage; - if ($local_file) { - $manpage = $self->manpage_headline($local_file); - } else { - # If we have already untarred it, we should look there - my $dist = $CPAN::META->instance('CPAN::Distribution', - $self->cpan_file); - # warn "dist[$dist]"; - # mff=manifest file; mfh=manifest handle - my($mff,$mfh); - if ( - $dist->{build_dir} - and - (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST"))) - and - $mfh = FileHandle->new($mff) - ) { - CPAN->debug("mff[$mff]") if $CPAN::DEBUG; - my $lfre = $self->id; # local file RE - $lfre =~ s/::/./g; - $lfre .= "\\.pm\$"; - my($lfl); # local file file - local $/ = "\n"; - my(@mflines) = <$mfh>; - for (@mflines) { - s/^\s+//; - s/\s.*//s; - } - while (length($lfre)>5 and !$lfl) { - ($lfl) = grep /$lfre/, @mflines; - CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG; - $lfre =~ s/.+?\.//; - } - $lfl =~ s/\s.*//; # remove comments - $lfl =~ s/\s+//g; # chomp would maybe be too system-specific - my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl); - # warn "lfl_abs[$lfl_abs]"; - if (-f $lfl_abs) { - $manpage = $self->manpage_headline($lfl_abs); - } - } - } - $self->{MANPAGE} = $manpage if $manpage; - } - my($item); - for $item (qw/MANPAGE/) { - push @m, sprintf($sprintf, $item, $self->{$item}) - if exists $self->{$item}; - } - for $item (qw/CONTAINS/) { - push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}})) - if exists $self->{$item} && @{$self->{$item}}; - } - push @m, sprintf($sprintf, 'INST_FILE', - $local_file || "(not installed)"); - push @m, sprintf($sprintf, 'INST_VERSION', - $self->inst_version) if $local_file; - if (%{$CPAN::META->{is_tested}||{}}) { # XXX needs to be methodified somehow - my $available_file = $self->available_file; - if ($available_file && $available_file ne $local_file) { - push @m, sprintf($sprintf, 'AVAILABLE_FILE', $available_file); - push @m, sprintf($sprintf, 'AVAILABLE_VERSION', $self->available_version); - } - } - join "", @m, "\n"; -} - -#-> sub CPAN::Module::manpage_headline -sub manpage_headline { - my($self,$local_file) = @_; - my(@local_file) = $local_file; - $local_file =~ s/\.pm(?!\n)\Z/.pod/; - push @local_file, $local_file; - my(@result,$locf); - for $locf (@local_file) { - next unless -f $locf; - my $fh = FileHandle->new($locf) - or $Carp::Frontend->mydie("Couldn't open $locf: $!"); - my $inpod = 0; - local $/ = "\n"; - while (<$fh>) { - $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 : - m/^=head1\s+NAME\s*$/ ? 1 : $inpod; - next unless $inpod; - next if /^=/; - next if /^\s+$/; - chomp; - push @result, $_; - } - close $fh; - last if @result; - } - for (@result) { - s/^\s+//; - s/\s+$//; - } - join " ", @result; -} - -#-> sub CPAN::Module::cpan_file ; -# Note: also inherited by CPAN::Bundle -sub cpan_file { - my $self = shift; - # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG; - unless ($self->ro) { - CPAN::Index->reload; - } - my $ro = $self->ro; - if ($ro && defined $ro->{CPAN_FILE}) { - return $ro->{CPAN_FILE}; - } else { - my $userid = $self->userid; - if ( $userid ) { - if ($CPAN::META->exists("CPAN::Author",$userid)) { - my $author = $CPAN::META->instance("CPAN::Author", - $userid); - my $fullname = $author->fullname; - my $email = $author->email; - unless (defined $fullname && defined $email) { - return sprintf("Contact Author %s", - $userid, - ); - } - return "Contact Author $fullname <$email>"; - } else { - return "Contact Author $userid (Email address not available)"; - } - } else { - return "N/A"; - } - } -} - -#-> sub CPAN::Module::cpan_version ; -sub cpan_version { - my $self = shift; - - my $ro = $self->ro; - unless ($ro) { - # Can happen with modules that are not on CPAN - $ro = {}; - } - $ro->{CPAN_VERSION} = 'undef' - unless defined $ro->{CPAN_VERSION}; - $ro->{CPAN_VERSION}; -} - -#-> sub CPAN::Module::force ; -sub force { - my($self) = @_; - $self->{force_update} = 1; -} - -#-> sub CPAN::Module::fforce ; -sub fforce { - my($self) = @_; - $self->{force_update} = 2; -} - -#-> sub CPAN::Module::notest ; -sub notest { - my($self) = @_; - # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module"); - $self->{notest}++; -} - -#-> sub CPAN::Module::rematein ; -sub rematein { - my($self,$meth) = @_; - $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n", - $meth, - $self->id)); - my $cpan_file = $self->cpan_file; - if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) { - $CPAN::Frontend->mywarn(sprintf qq{ - The module %s isn\'t available on CPAN. - - Either the module has not yet been uploaded to CPAN, or it is - temporary unavailable. Please contact the author to find out - more about the status. Try 'i %s'. -}, - $self->id, - $self->id, - ); - return; - } - my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); - $pack->called_for($self->id); - if (exists $self->{force_update}) { - if ($self->{force_update} == 2) { - $pack->fforce($meth); - } else { - $pack->force($meth); - } - } - $pack->notest($meth) if exists $self->{notest} && $self->{notest}; - - $pack->{reqtype} ||= ""; - CPAN->debug("dist-reqtype[$pack->{reqtype}]". - "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG; - if ($pack->{reqtype}) { - if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) { - $pack->{reqtype} = $self->{reqtype}; - if ( - exists $pack->{install} - && - ( - UNIVERSAL::can($pack->{install},"failed") ? - $pack->{install}->failed : - $pack->{install} =~ /^NO/ - ) - ) { - delete $pack->{install}; - $CPAN::Frontend->mywarn - ("Promoting $pack->{ID} from 'build_requires' to 'requires'"); - } - } - } else { - $pack->{reqtype} = $self->{reqtype}; - } - - my $success = eval { - $pack->$meth(); - }; - my $err = $@; - $pack->unforce if $pack->can("unforce") && exists $self->{force_update}; - $pack->unnotest if $pack->can("unnotest") && exists $self->{notest}; - delete $self->{force_update}; - delete $self->{notest}; - if ($err) { - die $err; - } - return $success; -} - -#-> sub CPAN::Module::perldoc ; -sub perldoc { shift->rematein('perldoc') } -#-> sub CPAN::Module::readme ; -sub readme { shift->rematein('readme') } -#-> sub CPAN::Module::look ; -sub look { shift->rematein('look') } -#-> sub CPAN::Module::cvs_import ; -sub cvs_import { shift->rematein('cvs_import') } -#-> sub CPAN::Module::get ; -sub get { shift->rematein('get',@_) } -#-> sub CPAN::Module::make ; -sub make { shift->rematein('make') } -#-> sub CPAN::Module::test ; -sub test { - my $self = shift; - # $self->{badtestcnt} ||= 0; - $self->rematein('test',@_); -} - -#-> sub CPAN::Module::uptodate ; -sub uptodate { - my ($self) = @_; - local ($_); - my $inst = $self->inst_version or return undef; - my $cpan = $self->cpan_version; - local ($^W) = 0; - CPAN::Version->vgt($cpan,$inst) and return 0; - my $inst_file = $self->inst_file; - # trying to support deprecated.pm by Nicholas 2009-02 - my $in_priv_or_arch = ""; - my $isa_perl = ""; - if ($] >= 5.011) { # probably harmful when distros say INSTALLDIRS=perl? - if (0 == CPAN::Version->vcmp($cpan,$inst)) { - if ($in_priv_or_arch = $self->_in_priv_or_arch($inst_file)) { - if (my $distribution = $self->distribution) { - unless ($isa_perl = $distribution->isa_perl) { - return 0; - } - } - } - } - } - CPAN->debug - (join - ("", - "returning uptodate. ", - "inst_file[$inst_file]", - "cpan[$cpan]inst[$inst]", - "in_priv_or_arch[$in_priv_or_arch]", - "isa_perl[$isa_perl]", - )) if $CPAN::DEBUG; - return 1; -} - -# returns true if installed in privlib or archlib -sub _in_priv_or_arch { - my($self,$inst_file) = @_; - for my $confdirname (qw(archlibexp privlibexp)) { - my $confdir = $Config::Config{$confdirname}; - if ($confdir eq substr($inst_file,0,length($confdir))) { - return 1; - } - } - return 0; -} - -#-> sub CPAN::Module::install ; -sub install { - my($self) = @_; - my($doit) = 0; - if ($self->uptodate - && - not exists $self->{force_update} - ) { - $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n", - $self->id, - $self->inst_version, - )); - } else { - $doit = 1; - } - my $ro = $self->ro; - if ($ro && $ro->{stats} && $ro->{stats} eq "a") { - $CPAN::Frontend->mywarn(qq{ -\n\n\n ***WARNING*** - The module $self->{ID} has no active maintainer.\n\n\n -}); - $CPAN::Frontend->mysleep(5); - } - return $doit ? $self->rematein('install') : 1; -} -#-> sub CPAN::Module::clean ; -sub clean { shift->rematein('clean') } - -#-> sub CPAN::Module::inst_file ; -sub inst_file { - my($self) = @_; - $self->_file_in_path([@INC]); -} - -#-> sub CPAN::Module::available_file ; -sub available_file { - my($self) = @_; - my $sep = $Config::Config{path_sep}; - my $perllib = $ENV{PERL5LIB}; - $perllib = $ENV{PERLLIB} unless defined $perllib; - my @perllib = split(/$sep/,$perllib) if defined $perllib; - my @cpan_perl5inc; - if ($CPAN::Perl5lib_tempfile) { - my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile); - @cpan_perl5inc = @{$yaml->[0]{inc} || []}; - } - $self->_file_in_path([@cpan_perl5inc,@perllib,@INC]); -} - -#-> sub CPAN::Module::file_in_path ; -sub _file_in_path { - my($self,$path) = @_; - my($dir,@packpath); - @packpath = split /::/, $self->{ID}; - $packpath[-1] .= ".pm"; - if (@packpath == 1 && $packpath[0] eq "readline.pm") { - unshift @packpath, "Term", "ReadLine"; # historical reasons - } - foreach $dir (@$path) { - my $pmfile = File::Spec->catfile($dir,@packpath); - if (-f $pmfile) { - return $pmfile; - } - } - return; -} - -#-> sub CPAN::Module::xs_file ; -sub xs_file { - my($self) = @_; - my($dir,@packpath); - @packpath = split /::/, $self->{ID}; - push @packpath, $packpath[-1]; - $packpath[-1] .= "." . $Config::Config{'dlext'}; - foreach $dir (@INC) { - my $xsfile = File::Spec->catfile($dir,'auto',@packpath); - if (-f $xsfile) { - return $xsfile; - } - } - return; -} - -#-> sub CPAN::Module::inst_version ; -sub inst_version { - my($self) = @_; - my $parsefile = $self->inst_file or return; - my $have = $self->parse_version($parsefile); - $have; -} - -#-> sub CPAN::Module::inst_version ; -sub available_version { - my($self) = @_; - my $parsefile = $self->available_file or return; - my $have = $self->parse_version($parsefile); - $have; -} - -#-> sub CPAN::Module::parse_version ; -sub parse_version { - my($self,$parsefile) = @_; - alarm(10); - my $have = eval { - local $SIG{ALRM} = sub { die "alarm\n" }; - MM->parse_version($parsefile); - }; - if ($@) { - $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n"); - } - alarm(0); - my $leastsanity = eval { defined $have && length $have; }; - $have = "undef" unless $leastsanity; - $have =~ s/^ //; # since the %vd hack these two lines here are needed - $have =~ s/ $//; # trailing whitespace happens all the time - - $have = CPAN::Version->readable($have); - - $have =~ s/\s*//g; # stringify to float around floating point issues - $have; # no stringify needed, \s* above matches always -} - -#-> sub CPAN::Module::reports -sub reports { - my($self) = @_; - $self->distribution->reports; -} - -1; diff --git a/lib/CPAN/Nox.pm b/lib/CPAN/Nox.pm deleted file mode 100644 index 5fe5a25ae6..0000000000 --- a/lib/CPAN/Nox.pm +++ /dev/null @@ -1,51 +0,0 @@ -package CPAN::Nox; -use strict; -use vars qw($VERSION @EXPORT); - -BEGIN{ - $CPAN::Suppress_readline=1 unless defined $CPAN::term; -} - -use base 'Exporter'; -use CPAN; - -$VERSION = "5.50"; -$CPAN::META->has_inst('Digest::MD5','no'); -$CPAN::META->has_inst('LWP','no'); -$CPAN::META->has_inst('Compress::Zlib','no'); -@EXPORT = @CPAN::EXPORT; - -*AUTOLOAD = \&CPAN::AUTOLOAD; - -1; - -__END__ - -=head1 NAME - -CPAN::Nox - Wrapper around CPAN.pm without using any XS module - -=head1 SYNOPSIS - -Interactive mode: - - perl -MCPAN::Nox -e shell; - -=head1 DESCRIPTION - -This package has the same functionality as CPAN.pm, but tries to -prevent the usage of compiled extensions during its own -execution. Its primary purpose is a rescue in case you upgraded perl -and broke binary compatibility somehow. - -=head1 LICENSE - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=head1 SEE ALSO - -L<CPAN> - -=cut - diff --git a/lib/CPAN/PAUSE2003.pub b/lib/CPAN/PAUSE2003.pub deleted file mode 100644 index 7817562962..0000000000 --- a/lib/CPAN/PAUSE2003.pub +++ /dev/null @@ -1,31 +0,0 @@ ------BEGIN PGP PUBLIC KEY BLOCK----- -Version: OpenKeyServer v1.2 -Comment: Extracted from belgium.keyserver.net - -mQGiBD4+cJARBACxOByY0SJBBuJoFrH2hoqRFny423gY6V3jq1uTgGY/PPaxP+Sq -r3RzxPct4vJcsoo48pwBsMHLrWfORq26zb6eKgmMq/CQo2gzaRbeRxCi3ke4KBmu -aREi6RjaZSU94yABtDmspUBrpYV8zfZMv5ZIQlg9W1Tu66BFOUrrNeDpKwCgosCp -9dtNAMhHkzxs8UJH5i3Uzb0D/0VLoAE8sOfUXqjc38rxiHuGBFSNC70Ih4mzGUCJ -MGT4z1X3K6uUawnXMoc8XqPaYnEgOzztMymydtr+urjUwcGnuXDSpV6nulE5irxh -zlikSTJy/42QzTMcrdRynffmJo9PRgymMI8GgWaYG5g3zzGAhi5BA6G8JKfC93IV -xiRPBACXJpLBYQljqJY9UDNJuq8nHhKiWHBXdZzrC3LM0FSF3PKuP/ugc+KBIKXm -clNPNFKla/SRbH6dMHsGIy8wnGPI5AtTS0roNQrttv3/ghRT7+OKXrGmBxZ/KHVr -v3PVgiRA5MDr1mIsovfuc9WQnFu2TkgnN/F3pDcrVVSi5b+rZLQzUEFVU0UgQmF0 -Y2ggU2lnbmluZyBLZXkgMjAwMyA8cGF1c2VAcGF1c2UucGVybC5vcmc+iF8EExEC -AB8FAj4+cJAFCQPCZwAECwcDAgMVAgMDFgIBAh4BAheAAAoJEDKNqGdFD4nsd4sA -n3gYvr37VkUycx61wm5t4BoSO904AJ9dkl/zU5BbDnXEPKk0FNWFSnwnxbkCDQQ+ -PnCyEAgAjAKDcvpogvJvSrg3rkstDhxP4O+JZvfxzrdL9Qk0FPBlb31ECxPMBf2z -KObrwGKwxgD3+lSb/y9SgOYnAsuwztn6BqjQ8AVKiI0MFDTa+tLrtY5860X7TxJD -9bzMx/A4gEsYoFZYR4s/alGAzcqFcdQ2IiFnKE4KPtNXEMQ67lCEw5zdYSoJta9J -UKsCX3KI/DOne1NnjNZL2dQadqjsEc8mjvUOTXSG1sCawzTP5tNoPHg13GeyJ0XG -HbHY35BbF33yr9kP76+zQFaiMyLDUnyQAU/0P+rm/I6Ts6q4OZwKK/tC5LD0SPDe -08uAzkb4krRqxheo6seHdT7HjdDbKwADBgf/RGpQhhZc+F9o79S9aLV4XnY5CFev -4EJvUqq6TF9V0rvZg148mbO/b8EtOfcBSdvAfo3H8w6wcC7X8Kt/6Pl69UZKuQOt -354092gTrjJyg1uZBK9Ey/LSh0k+BNCfIw04+6W8ijARkpdoBrU3CwDKTyroWYkS -FDkkzLvJRTkMpVpqyI0xIEExPXZTf67Abv1dzceTDciblLJfQcsfDyWYv8D12ELE -zLYQnFM1s6yD6Q51Xk/XQ6MJ59bB3uuFO8VpkCMEvqIxZXsLjgqyQgo73y1qFizs -KnFG+TTvooBdG3yqSt9OsLSoRrJkZbMX3PKpbT0ceWL8dULc1v2ol4fJGohMBBgR -AgAMBQI+PnCyBQkDwmcAAAoJEDKNqGdFD4nsS44An14sFX5E2jJc87HFJeqPmeas -hdayAKCCmOqjo0CW5uepN19pXdP7BujUOw== -=ocE3 ------END PGP PUBLIC KEY BLOCK----- diff --git a/lib/CPAN/PAUSE2005.pub b/lib/CPAN/PAUSE2005.pub deleted file mode 100644 index 8b3324773c..0000000000 --- a/lib/CPAN/PAUSE2005.pub +++ /dev/null @@ -1,46 +0,0 @@ ------BEGIN PGP PUBLIC KEY BLOCK----- -Version: GnuPG v1.4.1 (GNU/Linux) - -mQGiBD4+cJARBACxOByY0SJBBuJoFrH2hoqRFny423gY6V3jq1uTgGY/PPaxP+Sq -r3RzxPct4vJcsoo48pwBsMHLrWfORq26zb6eKgmMq/CQo2gzaRbeRxCi3ke4KBmu -aREi6RjaZSU94yABtDmspUBrpYV8zfZMv5ZIQlg9W1Tu66BFOUrrNeDpKwCgosCp -9dtNAMhHkzxs8UJH5i3Uzb0D/0VLoAE8sOfUXqjc38rxiHuGBFSNC70Ih4mzGUCJ -MGT4z1X3K6uUawnXMoc8XqPaYnEgOzztMymydtr+urjUwcGnuXDSpV6nulE5irxh -zlikSTJy/42QzTMcrdRynffmJo9PRgymMI8GgWaYG5g3zzGAhi5BA6G8JKfC93IV -xiRPBACXJpLBYQljqJY9UDNJuq8nHhKiWHBXdZzrC3LM0FSF3PKuP/ugc+KBIKXm -clNPNFKla/SRbH6dMHsGIy8wnGPI5AtTS0roNQrttv3/ghRT7+OKXrGmBxZ/KHVr -v3PVgiRA5MDr1mIsovfuc9WQnFu2TkgnN/F3pDcrVVSi5b+rZLQzUEFVU0UgQmF0 -Y2ggU2lnbmluZyBLZXkgMjAwMyA8cGF1c2VAcGF1c2UucGVybC5vcmc+iF8EExEC -AB8ECwcDAgMVAgMDFgIBAh4BAheABQJB4aBfBQkHp4HPAAoJEDKNqGdFD4nsZVQA -ni9ZYmebwXfO9NgBzoDHk7g+zkiLAJ9iTRgd9ts62eNkSd9zirqRS5Rbi7QzUEFV -U0UgQmF0Y2ggU2lnbmluZyBLZXkgMjAwNSA8cGF1c2VAcGF1c2UucGVybC5vcmc+ -iGQEExECACQFAkHhoIQCGwMFCQengc8GCwkIBwMCAxUCAwMWAgECHgECF4AACgkQ -Mo2oZ0UPiezRGwCeJ4J/wVG7Vs1Uf4zlkrHcGsA5O3kAnj+9Fz0WZJWpqCqY6r75 -Fe0NlDg3uQINBD4+cLIQCACMAoNy+miC8m9KuDeuSy0OHE/g74lm9/HOt0v1CTQU -8GVvfUQLE8wF/bMo5uvAYrDGAPf6VJv/L1KA5icCy7DO2foGqNDwBUqIjQwUNNr6 -0uu1jnzrRftPEkP1vMzH8DiASxigVlhHiz9qUYDNyoVx1DYiIWcoTgo+01cQxDru -UITDnN1hKgm1r0lQqwJfcoj8M6d7U2eM1kvZ1Bp2qOwRzyaO9Q5NdIbWwJrDNM/m -02g8eDXcZ7InRcYdsdjfkFsXffKv2Q/vr7NAVqIzIsNSfJABT/Q/6ub8jpOzqrg5 -nAor+0LksPRI8N7Ty4DORviStGrGF6jqx4d1PseN0NsrAAMGB/9EalCGFlz4X2jv -1L1otXhedjkIV6/gQm9SqrpMX1XSu9mDXjyZs79vwS059wFJ28B+jcfzDrBwLtfw -q3/o+Xr1Rkq5A63fnjT3aBOuMnKDW5kEr0TL8tKHST4E0J8jDTj7pbyKMBGSl2gG -tTcLAMpPKuhZiRIUOSTMu8lFOQylWmrIjTEgQTE9dlN/rsBu/V3Nx5MNyJuUsl9B -yx8PJZi/wPXYQsTMthCcUzWzrIPpDnVeT9dDownn1sHe64U7xWmQIwS+ojFlewuO -CrJCCjvfLWoWLOwqcUb5NO+igF0bfKpK306wtKhGsmRlsxfc8qltPRx5Yvx1QtzW -/aiXh8kaiEwEGBECAAwFAj4+cLIFCQPCZwAACgkQMo2oZ0UPiexLjgCfXiwVfkTa -MlzzscUl6o+Z5qyF1rIAoIKY6qOjQJbm56k3X2ld0/sG6NQ7uQINBEHhoKMQCADR -OlH7Qrmle54v34l8wqpfjLFOoIpYdwQ/5y8dKBc6sEHxjSP80oww+PZMh/gj55yu -UimS5IaNeu6tPQZjWkzNCxZmvr+BEiTPKekJpCVy5j2b1CTZC56mIjdrqDxj2SiO -TlWP8JO7Ga0qt5AjOliLC6hy9K/20o0P8wb0yxgl0azLbwxaHPgiDyOGI9EL0p2m -k4KZmj4otFcYfGyvEi1D2fQ20u9M+S9Z//cxL+lgJFJTAe5dQaq+fVBPo7ZGVtxh -eikCVkTKsyYbpTAuW2rI12lSaKDT8QI6tIdQFYp2W49QjPFav9QdjrJOUb9QC16c -snhOiz1172aZ8TmkIb9vAAMFCACdKhFlosy6l2GzXUmWdKqdY6G/5waMKylaNY1f -lHK1D/zYJELYgOjPMmRjjUsao8dCQQ7jg/0SgBhUsc1eDOr/XuxiVwDJ0k5a/92y -Nxop35ADLcmZiRl0J7LOcXvq0sAz/s0x4C90DZreosT6SQFghOm9wD6dlmPoopaI -2TUJf6xhU9M+34uBfAa4d98gyvUKhLGHGnsapJwzZ40TLwt7HTnAcLlKv/e5x0dD -XDHEf+GlhnPpDVsgz9sU5ihO0WDZyu+NG0xLh64/YP58EIinTNvPI2VzD5TyJywa -mnQlXuQbXVdCe2DRSICkDXxC/CifwbtKW8YwLzQD4bNQp2oQiE8EGBECAA8FAkHh -oKMCGwwFCQQEUgAACgkQMo2oZ0UPiezhPgCfWjFgFrRrtruhD2+gooDofopH4WsA -n0LcYsCHZxfSskeJ5vvanfeJXv9M -=TCMr ------END PGP PUBLIC KEY BLOCK----- diff --git a/lib/CPAN/PAUSE2007.pub b/lib/CPAN/PAUSE2007.pub deleted file mode 100644 index 49ab2dca93..0000000000 --- a/lib/CPAN/PAUSE2007.pub +++ /dev/null @@ -1,62 +0,0 @@ ------BEGIN PGP PUBLIC KEY BLOCK----- -Version: GnuPG v1.4.6 (GNU/Linux) - -mQGiBD4+cJARBACxOByY0SJBBuJoFrH2hoqRFny423gY6V3jq1uTgGY/PPaxP+Sq -r3RzxPct4vJcsoo48pwBsMHLrWfORq26zb6eKgmMq/CQo2gzaRbeRxCi3ke4KBmu -aREi6RjaZSU94yABtDmspUBrpYV8zfZMv5ZIQlg9W1Tu66BFOUrrNeDpKwCgosCp -9dtNAMhHkzxs8UJH5i3Uzb0D/0VLoAE8sOfUXqjc38rxiHuGBFSNC70Ih4mzGUCJ -MGT4z1X3K6uUawnXMoc8XqPaYnEgOzztMymydtr+urjUwcGnuXDSpV6nulE5irxh -zlikSTJy/42QzTMcrdRynffmJo9PRgymMI8GgWaYG5g3zzGAhi5BA6G8JKfC93IV -xiRPBACXJpLBYQljqJY9UDNJuq8nHhKiWHBXdZzrC3LM0FSF3PKuP/ugc+KBIKXm -clNPNFKla/SRbH6dMHsGIy8wnGPI5AtTS0roNQrttv3/ghRT7+OKXrGmBxZ/KHVr -v3PVgiRA5MDr1mIsovfuc9WQnFu2TkgnN/F3pDcrVVSi5b+rZLQzUEFVU0UgQmF0 -Y2ggU2lnbmluZyBLZXkgMjAwNSA8cGF1c2VAcGF1c2UucGVybC5vcmc+iGQEExEC -ACQCGwMGCwkIBwMCAxUCAwMWAgECHgECF4AFAkWZglsFCQwMGEsACgkQMo2oZ0UP -iezv0gCePbUh5lK3Y2g47X+D68Pm2o5xvNQAnjvyfWafKbhDY3dNNPeuyed51x2+ -tDNQQVVTRSBCYXRjaCBTaWduaW5nIEtleSAyMDAzIDxwYXVzZUBwYXVzZS5wZXJs -Lm9yZz6IXwQTEQIAHwQLBwMCAxUCAwMWAgECHgECF4AFAkWZglsFCQwMGEsACgkQ -Mo2oZ0UPieyRJwCgjG/zr1XJhZG1O+z1RdRVbAKa7FkAoJ0z9N3AWDhv8+JGW00n -+/Asy5NUtDNQQVVTRSBCYXRjaCBTaWduaW5nIEtleSAyMDA3IDxwYXVzZUBwYXVz -ZS5wZXJsLm9yZz6IZgQTEQIAJgUCRZmClAIbAwUJDAwYSwYLCQgHAwIEFQIIAwQW -AgMBAh4BAheAAAoJEDKNqGdFD4nsSroAoIR0lnjwlXdUBv+xzI8zzwuYZryvAJ4o -d9kQPAYFcY/t68AEkzGqpGE7BrkCDQQ+PnCyEAgAjAKDcvpogvJvSrg3rkstDhxP -4O+JZvfxzrdL9Qk0FPBlb31ECxPMBf2zKObrwGKwxgD3+lSb/y9SgOYnAsuwztn6 -BqjQ8AVKiI0MFDTa+tLrtY5860X7TxJD9bzMx/A4gEsYoFZYR4s/alGAzcqFcdQ2 -IiFnKE4KPtNXEMQ67lCEw5zdYSoJta9JUKsCX3KI/DOne1NnjNZL2dQadqjsEc8m -jvUOTXSG1sCawzTP5tNoPHg13GeyJ0XGHbHY35BbF33yr9kP76+zQFaiMyLDUnyQ -AU/0P+rm/I6Ts6q4OZwKK/tC5LD0SPDe08uAzkb4krRqxheo6seHdT7HjdDbKwAD -Bgf/RGpQhhZc+F9o79S9aLV4XnY5CFev4EJvUqq6TF9V0rvZg148mbO/b8EtOfcB -SdvAfo3H8w6wcC7X8Kt/6Pl69UZKuQOt354092gTrjJyg1uZBK9Ey/LSh0k+BNCf -Iw04+6W8ijARkpdoBrU3CwDKTyroWYkSFDkkzLvJRTkMpVpqyI0xIEExPXZTf67A -bv1dzceTDciblLJfQcsfDyWYv8D12ELEzLYQnFM1s6yD6Q51Xk/XQ6MJ59bB3uuF -O8VpkCMEvqIxZXsLjgqyQgo73y1qFizsKnFG+TTvooBdG3yqSt9OsLSoRrJkZbMX -3PKpbT0ceWL8dULc1v2ol4fJGohMBBgRAgAMBQI+PnCyBQkDwmcAAAoJEDKNqGdF -D4nsS44An14sFX5E2jJc87HFJeqPmeashdayAKCCmOqjo0CW5uepN19pXdP7BujU -O7kCDQRB4aCjEAgA0TpR+0K5pXueL9+JfMKqX4yxTqCKWHcEP+cvHSgXOrBB8Y0j -/NKMMPj2TIf4I+ecrlIpkuSGjXrurT0GY1pMzQsWZr6/gRIkzynpCaQlcuY9m9Qk -2QuepiI3a6g8Y9kojk5Vj/CTuxmtKreQIzpYiwuocvSv9tKND/MG9MsYJdGsy28M -Whz4Ig8jhiPRC9KdppOCmZo+KLRXGHxsrxItQ9n0NtLvTPkvWf/3MS/pYCRSUwHu -XUGqvn1QT6O2RlbcYXopAlZEyrMmG6UwLltqyNdpUmig0/ECOrSHUBWKdluPUIzx -Wr/UHY6yTlG/UAtenLJ4Tos9de9mmfE5pCG/bwADBQgAnSoRZaLMupdhs11JlnSq -nWOhv+cGjCspWjWNX5RytQ/82CRC2IDozzJkY41LGqPHQkEO44P9EoAYVLHNXgzq -/17sYlcAydJOWv/dsjcaKd+QAy3JmYkZdCeyznF76tLAM/7NMeAvdA2a3qLE+kkB -YITpvcA+nZZj6KKWiNk1CX+sYVPTPt+LgXwGuHffIMr1CoSxhxp7GqScM2eNEy8L -ex05wHC5Sr/3ucdHQ1wxxH/hpYZz6Q1bIM/bFOYoTtFg2crvjRtMS4euP2D+fBCI -p0zbzyNlcw+U8icsGpp0JV7kG11XQntg0UiApA18Qvwon8G7SlvGMC80A+GzUKdq -EIhPBBgRAgAPBQJB4aCjAhsMBQkEBFIAAAoJEDKNqGdFD4ns4T4An1oxYBa0a7a7 -oQ9voKKA6H6KR+FrAJ9C3GLAh2cX0rJHieb72p33iV7/TLkCDQRFmYK5EAgA7pV2 -du4vVF/P6R6UPEWHgFh0LgiNhxoyP+nWSC/6F2etZBaaaS4DvoaVBGfiQ3SjCP5a -UrsdeBckhN4F+sO42ZX1+ioAXQYrZ3i80NS9LbwEzeFhgCA+u5MnF+HzapwSI7dQ -EJchlgbOeAIA5EfS3lbgG4jxUbfMBgvTWeKi/c6S9IFo9KPaRm9GyScOcGqdZAFR -JN3NUKMOPiVdiUxJdl/K1434Vcs9DSMPY3nOb56PJhjSWK+k1IjcV/zOTxSXNJVK -nzS9+eybSpgBIkwJYfKxPZQndmEdR4btgwZdD6FJ21h2YlPJBc8BpFSoIal2Ulz/ -3d1KbCoE1GmduMDGDwADBwgAu1P2QBZ7uDREdcowhYX6OR/JeMkdV92ueoCTLUnV -Zv//tNOL5sVVtGB9l4ZbsFaJ41YlUs4CIQu2nGemAKm6fAztVpZoJZ0gNbqIZ2BJ -mK1ALvR4clBqax1QudZDEcvz5C+ej9cMIzmnnk1PDSE/iH/jBXxVi+QQncd0mpFq -YZvCeAUsH/GZwAEwqFDbM3kN+Z+ED9Fy3xOYpBmfUpMCH+i+P49dNeCvNFyRtPEl -Q/BsRbVdUJy8xZUMT2NZpfR/cLrlWMN6TNPRgAYHeLIlPLYsYsje95/ZSzEXeDP5 -2HAjCVlXTMdhbvQams3Ozvmj+/+pqcB7q6OmzZpbLMcCBohPBBgRAgAPBQJFmYK5 -AhsMBQkEsQaAAAoJEDKNqGdFD4ns+ZMAoIthsa+zF8MlnHDtmFpDKTJoH4FDAJ9N -eBWYgAgj15TYGkXTsXm08udw4Q== -=t3xm ------END PGP PUBLIC KEY BLOCK----- diff --git a/lib/CPAN/PAUSE2009.pub b/lib/CPAN/PAUSE2009.pub deleted file mode 100644 index fd76ec618c..0000000000 --- a/lib/CPAN/PAUSE2009.pub +++ /dev/null @@ -1,78 +0,0 @@ ------BEGIN PGP PUBLIC KEY BLOCK----- -Version: GnuPG v1.4.6 (GNU/Linux) - -mQGiBD4+cJARBACxOByY0SJBBuJoFrH2hoqRFny423gY6V3jq1uTgGY/PPaxP+Sq -r3RzxPct4vJcsoo48pwBsMHLrWfORq26zb6eKgmMq/CQo2gzaRbeRxCi3ke4KBmu -aREi6RjaZSU94yABtDmspUBrpYV8zfZMv5ZIQlg9W1Tu66BFOUrrNeDpKwCgosCp -9dtNAMhHkzxs8UJH5i3Uzb0D/0VLoAE8sOfUXqjc38rxiHuGBFSNC70Ih4mzGUCJ -MGT4z1X3K6uUawnXMoc8XqPaYnEgOzztMymydtr+urjUwcGnuXDSpV6nulE5irxh -zlikSTJy/42QzTMcrdRynffmJo9PRgymMI8GgWaYG5g3zzGAhi5BA6G8JKfC93IV -xiRPBACXJpLBYQljqJY9UDNJuq8nHhKiWHBXdZzrC3LM0FSF3PKuP/ugc+KBIKXm -clNPNFKla/SRbH6dMHsGIy8wnGPI5AtTS0roNQrttv3/ghRT7+OKXrGmBxZ/KHVr -v3PVgiRA5MDr1mIsovfuc9WQnFu2TkgnN/F3pDcrVVSi5b+rZLQzUEFVU0UgQmF0 -Y2ggU2lnbmluZyBLZXkgMjAwNyA8cGF1c2VAcGF1c2UucGVybC5vcmc+iGYEExEC -ACYCGwMGCwkIBwMCBBUCCAMEFgIDAQIeAQIXgAUCSXjfkAUJD850gAAKCRAyjahn -RQ+J7CnPAJ9gnTiIu532a8hxfBiSXfifTbSxaQCfXrrAg8QnRrpr//n7anf4Cife -2D20M1BBVVNFIEJhdGNoIFNpZ25pbmcgS2V5IDIwMDUgPHBhdXNlQHBhdXNlLnBl -cmwub3JnPohkBBMRAgAkAhsDBgsJCAcDAgMVAgMDFgIBAh4BAheABQJJeN+QBQkP -znSAAAoJEDKNqGdFD4nsRTMAn1ZQRTgeyvxMjP5jFnih3xOqmmLQAJwKbkN5e52T -aU5sFKRdg7rL1g9Ad7QzUEFVU0UgQmF0Y2ggU2lnbmluZyBLZXkgMjAwMyA8cGF1 -c2VAcGF1c2UucGVybC5vcmc+iF8EExECAB8ECwcDAgMVAgMDFgIBAh4BAheABQJJ -eN+QBQkPznSAAAoJEDKNqGdFD4nshpwAn0DDhprbvctI9hGxBQ7qYZDZzD50AJ0Z -vNSi4hFXgEtXii2GfPEhlHyObrQzUEFVU0UgQmF0Y2ggU2lnbmluZyBLZXkgMjAw -OSA8cGF1c2VAcGF1c2UucGVybC5vcmc+iGYEExECACYFAkl43/ECGwMFCQ/OdIAG -CwkIBwMCBBUCCAMEFgIDAQIeAQIXgAAKCRAyjahnRQ+J7IDEAJ40F0fyg6NTAZ2n -Wizs/C/RSPYPsgCfSqnVpaqF6k0H/5AabfdNbcS2Wm65Ag0EPj5wshAIAIwCg3L6 -aILyb0q4N65LLQ4cT+DviWb38c63S/UJNBTwZW99RAsTzAX9syjm68BisMYA9/pU -m/8vUoDmJwLLsM7Z+gao0PAFSoiNDBQ02vrS67WOfOtF+08SQ/W8zMfwOIBLGKBW -WEeLP2pRgM3KhXHUNiIhZyhOCj7TVxDEOu5QhMOc3WEqCbWvSVCrAl9yiPwzp3tT -Z4zWS9nUGnao7BHPJo71Dk10htbAmsM0z+bTaDx4NdxnsidFxh2x2N+QWxd98q/Z -D++vs0BWojMiw1J8kAFP9D/q5vyOk7OquDmcCiv7QuSw9Ejw3tPLgM5G+JK0asYX -qOrHh3U+x43Q2ysAAwYH/0RqUIYWXPhfaO/UvWi1eF52OQhXr+BCb1KqukxfVdK7 -2YNePJmzv2/BLTn3AUnbwH6Nx/MOsHAu1/Crf+j5evVGSrkDrd+eNPdoE64ycoNb -mQSvRMvy0odJPgTQnyMNOPulvIowEZKXaAa1NwsAyk8q6FmJEhQ5JMy7yUU5DKVa -asiNMSBBMT12U3+uwG79Xc3Hkw3Im5SyX0HLHw8lmL/A9dhCxMy2EJxTNbOsg+kO -dV5P10OjCefWwd7rhTvFaZAjBL6iMWV7C44KskIKO98tahYs7CpxRvk076KAXRt8 -qkrfTrC0qEayZGWzF9zyqW09HHli/HVC3Nb9qJeHyRqITAQYEQIADAUCPj5wsgUJ -A8JnAAAKCRAyjahnRQ+J7EuOAJ9eLBV+RNoyXPOxxSXqj5nmrIXWsgCggpjqo6NA -lubnqTdfaV3T+wbo1Du5Ag0EQeGgoxAIANE6UftCuaV7ni/fiXzCql+MsU6gilh3 -BD/nLx0oFzqwQfGNI/zSjDD49kyH+CPnnK5SKZLkho167q09BmNaTM0LFma+v4ES -JM8p6QmkJXLmPZvUJNkLnqYiN2uoPGPZKI5OVY/wk7sZrSq3kCM6WIsLqHL0r/bS -jQ/zBvTLGCXRrMtvDFoc+CIPI4Yj0QvSnaaTgpmaPii0Vxh8bK8SLUPZ9DbS70z5 -L1n/9zEv6WAkUlMB7l1Bqr59UE+jtkZW3GF6KQJWRMqzJhulMC5basjXaVJooNPx -Ajq0h1AVinZbj1CM8Vq/1B2Osk5Rv1ALXpyyeE6LPXXvZpnxOaQhv28AAwUIAJ0q -EWWizLqXYbNdSZZ0qp1job/nBowrKVo1jV+UcrUP/NgkQtiA6M8yZGONSxqjx0JB -DuOD/RKAGFSxzV4M6v9e7GJXAMnSTlr/3bI3GinfkAMtyZmJGXQnss5xe+rSwDP+ -zTHgL3QNmt6ixPpJAWCE6b3APp2WY+iilojZNQl/rGFT0z7fi4F8Brh33yDK9QqE -sYcaexqknDNnjRMvC3sdOcBwuUq/97nHR0NcMcR/4aWGc+kNWyDP2xTmKE7RYNnK -740bTEuHrj9g/nwQiKdM288jZXMPlPInLBqadCVe5BtdV0J7YNFIgKQNfEL8KJ/B -u0pbxjAvNAPhs1CnahCITwQYEQIADwUCQeGgowIbDAUJBARSAAAKCRAyjahnRQ+J -7OE+AJ9aMWAWtGu2u6EPb6CigOh+ikfhawCfQtxiwIdnF9KyR4nm+9qd94le/0y5 -Ag0ERZmCuRAIAO6VdnbuL1Rfz+kelDxFh4BYdC4IjYcaMj/p1kgv+hdnrWQWmmku -A76GlQRn4kN0owj+WlK7HXgXJITeBfrDuNmV9foqAF0GK2d4vNDUvS28BM3hYYAg -PruTJxfh82qcEiO3UBCXIZYGzngCAORH0t5W4BuI8VG3zAYL01niov3OkvSBaPSj -2kZvRsknDnBqnWQBUSTdzVCjDj4lXYlMSXZfyteN+FXLPQ0jD2N5zm+ejyYY0liv -pNSI3Ff8zk8UlzSVSp80vfnsm0qYASJMCWHysT2UJ3ZhHUeG7YMGXQ+hSdtYdmJT -yQXPAaRUqCGpdlJc/93dSmwqBNRpnbjAxg8AAwcIALtT9kAWe7g0RHXKMIWF+jkf -yXjJHVfdrnqAky1J1Wb//7TTi+bFVbRgfZeGW7BWieNWJVLOAiELtpxnpgCpunwM -7VaWaCWdIDW6iGdgSZitQC70eHJQamsdULnWQxHL8+Qvno/XDCM5p55NTw0hP4h/ -4wV8VYvkEJ3HdJqRamGbwngFLB/xmcABMKhQ2zN5DfmfhA/Rct8TmKQZn1KTAh/o -vj+PXTXgrzRckbTxJUPwbEW1XVCcvMWVDE9jWaX0f3C65VjDekzT0YAGB3iyJTy2 -LGLI3vef2UsxF3gz+dhwIwlZV0zHYW70GprNzs75o/v/qanAe6ujps2aWyzHAgaI -TwQYEQIADwUCRZmCuQIbDAUJBLEGgAAKCRAyjahnRQ+J7PmTAKCLYbGvsxfDJZxw -7ZhaQykyaB+BQwCfTXgVmIAII9eU2BpF07F5tPLncOG5Ag0ESXjgRxAIANNFPYOO -sVGbMk7D420WQHC0Sbs+DVRP6U254nAdNQNQw9PbyFB0vwkfWddsFEA/g9OLVlQV -uSsIVgAiDNuKIxRT3GApZwtFYz5M4Hfc923HP9+Co50kNwYKbgoB43RkZB+1/pFs -ncH73vXg7G9BK/EsZ3uMV/LVhxu6+xR8rnxyfh4F/11XVvrnZ6e/b1Nn6YkZDtEv -MpkF5jAyfJyCy/UPT8s5kQFSKF5+bB7m7Thlvcd+Z6ucQ7XJHeqEyWY3XRBsUk21 -Zu8IzkL4hCLdkhXnRjbHPpIrZQ7ALlIXjAUX4sizSiHK9MqiL2lkAne+jQgse8La -tut0jI8MsUOwNTMAAwUH/jzhcmsEAcYpICwZ3z5vyynrTYAkSfYByrKVXLPFpChZ -rAVCfgKu0oPqsdzEWj47eNR2aZv/DX8w2/PbvqAZgqP8GSQy41/K1g9KIiPUuUlq -wujm0OVZ+DEAhBh0J3HJLinR+HSuxQqjb7CkSPz7Em8GP1MfnQPTngHxHQuQ39Sb -u06VM8IofmzgsvR61OMS0c+yc43xRflTrWSaiu6hnGdrIs0WKH0OZQafkeHwzg8w -tw+nwYj4o3F9TFDWeVB/GSD1yUCJ7TTfAjwR7pgToQ45BLhf7RMEW2U1Wn8VFBWj -f9wI34+aOrvLWxlEhAyosHBOf10xNQVWyeYcjJ299k6ITwQYEQIADwUCSXjgRwIb -DAUJBJQFgAAKCRAyjahnRQ+J7FyoAJ4pjYHpZnaaLnTTjygCTZO4COljpQCdHkqE -cVHe2u7+E3qfdy9iNsdAqww= -=Aadt ------END PGP PUBLIC KEY BLOCK----- diff --git a/lib/CPAN/Prompt.pm b/lib/CPAN/Prompt.pm deleted file mode 100644 index 7a4e2d81e1..0000000000 --- a/lib/CPAN/Prompt.pm +++ /dev/null @@ -1,29 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::Prompt; -use overload '""' => "as_string"; -use vars qw($prompt); -use vars qw( - $VERSION -); -$VERSION = "5.5"; - - -$prompt = "cpan> "; -$CPAN::CurrentCommandId ||= 0; -sub new { - bless {}, shift; -} -sub as_string { - my $word = "cpan"; - unless ($CPAN::META->{LOCK}) { - $word = "nolock_cpan"; - } - if ($CPAN::Config->{commandnumber_in_prompt}) { - sprintf "$word\[%d]> ", $CPAN::CurrentCommandId; - } else { - "$word> "; - } -} - -1; diff --git a/lib/CPAN/Queue.pm b/lib/CPAN/Queue.pm deleted file mode 100644 index b60f57c1cf..0000000000 --- a/lib/CPAN/Queue.pm +++ /dev/null @@ -1,198 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -use strict; -package CPAN::Queue::Item; - -# CPAN::Queue::Item::new ; -sub new { - my($class,@attr) = @_; - my $self = bless { @attr }, $class; - return $self; -} - -sub as_string { - my($self) = @_; - $self->{qmod}; -} - -# r => requires, b => build_requires, c => commandline -sub reqtype { - my($self) = @_; - $self->{reqtype}; -} - -package CPAN::Queue; - -# One use of the queue is to determine if we should or shouldn't -# announce the availability of a new CPAN module - -# Now we try to use it for dependency tracking. For that to happen -# we need to draw a dependency tree and do the leaves first. This can -# easily be reached by running CPAN.pm recursively, but we don't want -# to waste memory and run into deep recursion. So what we can do is -# this: - -# CPAN::Queue is the package where the queue is maintained. Dependencies -# often have high priority and must be brought to the head of the queue, -# possibly by jumping the queue if they are already there. My first code -# attempt tried to be extremely correct. Whenever a module needed -# immediate treatment, I either unshifted it to the front of the queue, -# or, if it was already in the queue, I spliced and let it bypass the -# others. This became a too correct model that made it impossible to put -# an item more than once into the queue. Why would you need that? Well, -# you need temporary duplicates as the manager of the queue is a loop -# that -# -# (1) looks at the first item in the queue without shifting it off -# -# (2) cares for the item -# -# (3) removes the item from the queue, *even if its agenda failed and -# even if the item isn't the first in the queue anymore* (that way -# protecting against never ending queues) -# -# So if an item has prerequisites, the installation fails now, but we -# want to retry later. That's easy if we have it twice in the queue. -# -# I also expect insane dependency situations where an item gets more -# than two lives in the queue. Simplest example is triggered by 'install -# Foo Foo Foo'. People make this kind of mistakes and I don't want to -# get in the way. I wanted the queue manager to be a dumb servant, not -# one that knows everything. -# -# Who would I tell in this model that the user wants to be asked before -# processing? I can't attach that information to the module object, -# because not modules are installed but distributions. So I'd have to -# tell the distribution object that it should ask the user before -# processing. Where would the question be triggered then? Most probably -# in CPAN::Distribution::rematein. - -use vars qw{ @All $VERSION }; -$VERSION = "5.5"; - -# CPAN::Queue::queue_item ; -sub queue_item { - my($class,@attr) = @_; - my $item = "$class\::Item"->new(@attr); - $class->qpush($item); - return 1; -} - -# CPAN::Queue::qpush ; -sub qpush { - my($class,$obj) = @_; - push @All, $obj; - CPAN->debug(sprintf("in new All[%s]", - join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All), - )) if $CPAN::DEBUG; -} - -# CPAN::Queue::first ; -sub first { - my $obj = $All[0]; - $obj; -} - -# CPAN::Queue::delete_first ; -sub delete_first { - my($class,$what) = @_; - my $i; - for my $i (0..$#All) { - if ( $All[$i]->{qmod} eq $what ) { - splice @All, $i, 1; - return; - } - } -} - -# CPAN::Queue::jumpqueue ; -sub jumpqueue { - my $class = shift; - my @what = @_; - CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]", - join("", - map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All, @what - ))) if $CPAN::DEBUG; - unless (defined $what[0]{reqtype}) { - # apparently it was not the Shell that sent us this enquiry, - # treat it as commandline - $what[0]{reqtype} = "c"; - } - my $inherit_reqtype = $what[0]{reqtype} =~ /^(c|r)$/ ? "r" : "b"; - WHAT: for my $what_tuple (@what) { - my($what,$reqtype) = @$what_tuple{qw(qmod reqtype)}; - if ($reqtype eq "r" - && - $inherit_reqtype eq "b" - ) { - $reqtype = "b"; - } - my $jumped = 0; - for (my $i=0; $i<$#All;$i++) { #prevent deep recursion - # CPAN->debug("i[$i]this[$All[$i]{qmod}]what[$what]") if $CPAN::DEBUG; - if ($All[$i]{qmod} eq $what) { - $jumped++; - if ($jumped >= 50) { - die "PANIC: object[$what] 50 instances on the queue, looks like ". - "some recursiveness has hit"; - } elsif ($jumped > 25) { # one's OK if e.g. just processing - # now; more are OK if user typed - # it several times - my $sleep = sprintf "%.1f", $jumped/10; - $CPAN::Frontend->mywarn( -qq{Warning: Object [$what] queued $jumped times, sleeping $sleep secs!\n} - ); - $CPAN::Frontend->mysleep($sleep); - # next WHAT; - } - } - } - my $obj = "$class\::Item"->new( - qmod => $what, - reqtype => $reqtype - ); - unshift @All, $obj; - } - CPAN->debug(sprintf("after jumpqueue All[%s]", - join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All) - )) if $CPAN::DEBUG; -} - -# CPAN::Queue::exists ; -sub exists { - my($self,$what) = @_; - my @all = map { $_->{qmod} } @All; - my $exists = grep { $_->{qmod} eq $what } @All; - # warn "in exists what[$what] all[@all] exists[$exists]"; - $exists; -} - -# CPAN::Queue::delete ; -sub delete { - my($self,$mod) = @_; - @All = grep { $_->{qmod} ne $mod } @All; - CPAN->debug(sprintf("after delete mod[%s] All[%s]", - $mod, - join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All) - )) if $CPAN::DEBUG; -} - -# CPAN::Queue::nullify_queue ; -sub nullify_queue { - @All = (); -} - -# CPAN::Queue::size ; -sub size { - return scalar @All; -} - -1; - -__END__ - -=head1 LICENSE - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/lib/CPAN/SIGNATURE b/lib/CPAN/SIGNATURE deleted file mode 100644 index 286b255575..0000000000 --- a/lib/CPAN/SIGNATURE +++ /dev/null @@ -1,481 +0,0 @@ -This file contains message digests of all files listed in MANIFEST, -signed via the Module::Signature module, version 0.55. - -To verify the content in this distribution, first make sure you have -Module::Signature installed, then type: - - % cpansign -v - -It will check each file's integrity, as well as the signature's -validity. If "==> Signature verified OK! <==" is not displayed, -the distribution may already have been compromised, and you should -not run its Makefile.PL or Build.PL. - ------BEGIN PGP SIGNED MESSAGE----- -Hash: SHA1 - -SHA1 6e8d0b0d1883761e588707bd952de40bbe3a485e Changes -SHA1 0ea0887959becc8c039f8c37b6a9b2c164200aeb MANIFEST -SHA1 97732eaafa3212deb5fe0e292f70e25ce5ee66a7 MANIFEST.SKIP -SHA1 bfb57c4a633e130303959cd23ba5798e59adeb67 META.yml -SHA1 90bcb550c498de8b05a636e9c85ff1dad5b107d0 Makefile.PL -SHA1 37e858c51409a297ef5d3fb35dc57cd3b57f9a4d PAUSE2003.pub -SHA1 af016003ad503ed078c5f8254521d13a3e0c494f PAUSE2005.pub -SHA1 a3941566358617b918e0bb7b5c4c2638f451a9d8 PAUSE2007.pub -SHA1 6bd0c71ccaf4e9cd77d13a330f02714c08af4de8 PAUSE2009.pub -SHA1 baf5f4df67c583a50193fbc88a465f733492ce23 README -SHA1 efeeb5816ec6e9fbf95384b37fd0a3f76870658c SlayMakefile -SHA1 c08973601e45068809e6499b98a181b4445f5e33 Todo -SHA1 9928e72969096af7df7a4e54c284da21b457c47f distroprefs/00.README -SHA1 79848ebd7fbf81020d38ea81c3b8b989f2ab16fb distroprefs/01.DISABLED.yml -SHA1 377ded2410b847e9ed060b2d1c0dc165cc85c9e7 distroprefs/02.NOREPORT.yml -SHA1 326fc1d05811f13b9e71d341a4eac86c60f06f7d distroprefs/ABELTJE.Test-Smoke.yml -SHA1 a45e5c86c772444a72c22303758f835780ba6b71 distroprefs/ABW.Template-Toolkit.yml -SHA1 adc4cb439b28ecc2ef10c63f34efb88475e306be distroprefs/ACG.Scrabble-Dict.yml -SHA1 de18eeb17d580afbe86e05c71b56457c43f61dde distroprefs/ACH.Tk-Contrib.yml -SHA1 f548764dc4b575d772c3af9f9d83d18321fbd202 distroprefs/ADAMK.Chart-Math-Axis.yml -SHA1 8b68d317e8a2f7875fc634536fe10159a8bf81e2 distroprefs/ADAMK.Image-Delivery.yml -SHA1 002442babbc2b516bbe4793188ad5435a1c8189d distroprefs/ADAMK.PPI.yml -SHA1 4b46b611acd0265d98e43a8263716f5fae83b9cc distroprefs/ADAMK.Test-ClassAPI.yml -SHA1 18d53ac2d3d801cdd37d4f5280c76ef89335c3f1 distroprefs/ADAMK.Test-Inline.yml -SHA1 6e505736a3259660f80d96db4e995938decd40b4 distroprefs/AGENT.OpenResty.yml -SHA1 af2a4a9c72895c8e13b6c194bbf53d75e79eb0aa distroprefs/AGRUNDMA.POE-Loop-EV.yml -SHA1 57ed2146b1be91f5248db77dcabf47f77bda36ac distroprefs/AMICHAUER.Unicode-Lite.yml -SHA1 25d2ff1b3f7e949b0e0583b7d0bbad1c6ae3eac9 distroprefs/ANDK.CPAN-Test-Dummy-Perl5-Build-Fails.yml -SHA1 0baa8fb59f69008f11a6a17043d2a5954534bbaa distroprefs/ANDK.CPAN-Test-Dummy-Perl5-Make-Expect.yml -SHA1 6a2015457edfc1e81682496645ec8ad654393246 distroprefs/ANDREWF.LaTeX-Driver.yml -SHA1 e2e0a4de163ed00631cc43c6efa6b0d0baca0181 distroprefs/ANDYA.File-Find-Parallel.yml -SHA1 75ba6bf3dc08ff216c5ea687cc60445504813bc4 distroprefs/ANDYA.Perl-Version.yml -SHA1 fc84f7d472266de36c6d4c7047584cbcfd085a00 distroprefs/ANDYA.TAP-Parser.yml -SHA1 38e8d5afae5d648ba306fbb5a4ffc892c0297148 distroprefs/ANDYA.Test-Harness.yml -SHA1 240a4624bbc62e5ca3ac878ad45fc47e2ffcc57c distroprefs/ARFREITAS.DTS.yml -SHA1 878a77df89c8b3225112290b037e421dfd264104 distroprefs/ARJAY.Compress-Bzip2.yml -SHA1 c2b41372baf5e79cd2d825baa000d00bdf612b4f distroprefs/ASCOPE.Net-Google.yml -SHA1 1bf3201e105ac95c74fd65853ce97691751610a0 distroprefs/ATOURBIN.rpm-build-perl.yml -SHA1 decf7fc4f592603470c410b823c24726c6acaa57 distroprefs/AUDREYT.Module-Signature.yml -SHA1 a64c5cae865216bb69bfa8147e034000e484a0c0 distroprefs/AUDREYT.PDF-FromHTML.yml -SHA1 61ff9755c8c70276d4514232bbb13a966e663097 distroprefs/AUDREYT.YAML-Syck.yml -SHA1 b0c942fa0256d96898732c8ac3cf023777ca4c01 distroprefs/AVIF.Time-Duration.yml -SHA1 5fb5917c8b746c671f180ffeb7139554aa11f150 distroprefs/BDFOY.Business-ISBN.yml -SHA1 eb02bdafd0208a823f10c68d326682d9ab209b49 distroprefs/BDFOY.Module-Release.yml -SHA1 7695bd3c485f904f3550281e8018cac5b9fa90df distroprefs/BDFOY.Test-HTTPStatus.yml -SHA1 a48bf158f64e969c5796a504143af509c63c5a25 distroprefs/BINGOS.POE-Component-CPAN-YACSmoke.yml -SHA1 6f8ad46c577b0d5c88b4ce69da1a959dd7df1df8 distroprefs/BINGOS.POE-Component-Client-FTP.yml -SHA1 9792abff9bc890fb1d13bc59c9f0b72828cd4cc4 distroprefs/BINGOS.POE-Component-Client-NSCA.yml -SHA1 1c09964633212cd946ca6cae5f17924a8b34d040 distroprefs/BINGOS.POE-Component-Server-NSCA.yml -SHA1 9d7985a25ad9127436ab1d4dc95b71808da6c8cf distroprefs/BINGOS.POE-Component-Server-SimpleContent.yml -SHA1 b46647f67ca1748b4f2d5db8b3d41ce4253b19b6 distroprefs/BINGOS.POE-Component-Server-SimpleHTTP.yml -SHA1 3aee22657088b5f7c99db2c74ff59c69e4ee6a20 distroprefs/BINGOS.POE-Component-SmokeBox-Recent.yml -SHA1 1260ac0f4afb91470b46fc6adf634c1f86142443 distroprefs/BLUEFEET.GIS-Distance.yml -SHA1 45833aebd23d35076bfb8f9ebc958237f3a970a9 distroprefs/BOBTFISH.Text-Markdown.yml -SHA1 261bb596940d3639374d6debace056282e34ac58 distroprefs/BRADFITZ.Perlbal.yml -SHA1 ac322ccd006c03a4799dbfd47701a4202ef73f8b distroprefs/BRIANSKI.XML-Comma.yml -SHA1 48303ba0f66618b81b35a9667265ed4ea8215f16 distroprefs/BRYCE.SVG-Metadata.yml -SHA1 1af9575bdc1f1412f8ee6a7161260944905413e6 distroprefs/BSMITH.Devel-EvalContext.yml -SHA1 7c19fdbeef0a8caf0d0b3a23d5697e7310ae6417 distroprefs/BTROTT.Convert-PEM.yml -SHA1 80302cbcb79e9f24ac6b26bc5b00e43856fb400c distroprefs/BTROTT.Crypt-DH.yml -SHA1 75095401e767dadd92b0e5543923493a5ec78a18 distroprefs/BTROTT.Crypt-DSA.yml -SHA1 8f24308b2d750350a95132b8735f5211f6abfa37 distroprefs/BTROTT.Crypt-OpenPGP.yml -SHA1 cfe5f5535232d6f1f10ad00635d313895ddcbb84 distroprefs/BTROTT.XML-FOAF.yml -SHA1 c7b27ae98c2a16d7119dcfa0db3fa5f996a695a3 distroprefs/BWARFIELD.GDGraph.yml -SHA1 46e075883c9f9530d80b8fc64d4bf2d8b13a979f distroprefs/BYRNE.SOAP-Lite.yml -SHA1 0e237d1b65ba8a93e7bfd108c7accb7e4249fd42 distroprefs/CAPTTOFU.DBD-mysql.yml -SHA1 39fd3feb1b9cce3acb94375fba517d5481baba70 distroprefs/CDENT.Kwiki-Test.yml -SHA1 279eaba864447b22b4c95f8088b5b06c1f2eb1ff distroprefs/CERNEY.Tk-IDElayout.yml -SHA1 6a168c6f5d311b9e55a7d6591115d7f95df68084 distroprefs/CHANG-LIU.XML-Node.yml -SHA1 81c8581de621425cbc94d7d6e1550a0f050198b8 distroprefs/CHARTGRP.Chart.yml -SHA1 fa614c51395fd70d8a0400c5daecf2984645e853 distroprefs/CHISEL.Zucchini.yml -SHA1 abc806da6a613e656d580a7803427a810f3b46ff distroprefs/CHOCOLATE.Scalar-Util-Clone.yml -SHA1 e68d441a2d833c7b5655df8c9fc953f9e6538050 distroprefs/CLACO.Class-Accessor-Grouped.yml -SHA1 6721dfa1e464c57ec7221a44107de736ae71584d distroprefs/CLAESJAC.JavaScript.yml -SHA1 752fd5d043349c7bb32b58a817b3af4251b6e758 distroprefs/CLKAO.App-CLI.yml -SHA1 a97c93bab5620a33ec3b940f40a36b29e3d6ab1e distroprefs/CLKAO.IO-Digest.yml -SHA1 84755defdbb3b2c85d1db01458ced9f4dc8a76c9 distroprefs/CLKAO.SVN-Mirror.yml -SHA1 cfd953eebabdef8e99d7130efe0956a61c21f18a distroprefs/CMOORE.Archive-Any.yml -SHA1 9c3ac6c4a83954425ebfb99e43218d49062c09e4 distroprefs/CORDATA.Kwiki-Formatter-Emphasis.yml -SHA1 7eaac0445622a261cc2e16fd662da8403fc94f77 distroprefs/CORION.List-Sliding-Changes.yml -SHA1 3e715d83c3a6dd91b41e0cfc3da65ac2a30b9bba distroprefs/CRISB.WWW-Curl.yml -SHA1 ed4cd51161403364c068704fad18798cd6149c0c distroprefs/CSOE.PDL.yml -SHA1 7bbe66d00c3b861812492df464a8fe41e9684c0d distroprefs/DAGOLDEN.CPAN-Reporter.yml -SHA1 720b4fd7ffde3134624a6125e97f2165a25a744f distroprefs/DAGOLDEN.Term-Title.yml -SHA1 49d0a317721ef32c8e80d678fa9d7bfe4745edb3 distroprefs/DAMS.RT-Client-REST.yml -SHA1 871d0ded5a5fbaaa1cb9ce5a5e8ad332d5d5693d distroprefs/DANKOGAI.Regexp-Optimizer.yml -SHA1 d6577eaba4d306d0afbd4428292a496d39c7712c distroprefs/DAXIM.Yahoo-Photos.yml -SHA1 b4e4d7072114273e67f177dba5ae56a012bc94e3 distroprefs/DBRIAN.XML-SimpleObject.yml -SHA1 1cb001f569255d50296839883bdfc07190a4269d distroprefs/DBROBINS.Net-SSH-Perl.yml -SHA1 bc25efab0318c03d85a104bbbcb0660bb57ac942 distroprefs/DCANTRELL.Devel-CheckOS.yml -SHA1 75fcbf2e105cbd0891c785693b73c15b936e304e distroprefs/DCONWAY.Parse-RecDescent.yml -SHA1 b975d4234f75c698cd7fca674c0411c86e6bfcb6 distroprefs/DCOPPIT.Mail-Mbox-MessageParser.yml -SHA1 b565742f186afb736dc03acc204446b6135abff5 distroprefs/DDUMONT.Tk-ObjScanner.yml -SHA1 03cd47b82170c01f58a17d954f125ce1ac9a839f distroprefs/DHARRIS.DB_File-Lock.yml -SHA1 f96104c3f60214bd50789474e1e31624045f239d distroprefs/DJBERG.Tk-JListbox.yml -SHA1 1b23871720a7ed2e114dd5e93ae88455b0c1f376 distroprefs/DJKERNEN.Mail-IMAPClient.yml -SHA1 07975dd28ea0f7a8abc9d7f1cbc69791a012952d distroprefs/DKWILSON.Tk-DKW.yml -SHA1 27b107f473bafaf91a0cee9fed5ecb9d9c0dcc0c distroprefs/DLAND.Crypt-SSLeay.yml -SHA1 3f62c22b461eef2b8b592903295fe2cbf28e08a4 distroprefs/DMAKI.Class-DBI-Plugin-DateTime.yml -SHA1 607278c77aa229dd6c9b382704f52cfc494e58fc distroprefs/DMAKI.DateTime-X.yml -SHA1 66725756baf6fd496751267731bcfcbbb54d1f5b distroprefs/DMAKI.File-Extract.yml -SHA1 41d5f13d007f533076378052cbf48a51e880b160 distroprefs/DMAKI.Xango.yml -SHA1 f11b7065a6dd00234f6bca7f2ab13771cdacad98 distroprefs/DMARTIN.Unix-SavedIDs.yml -SHA1 c2481ac12aacc6008b390881263db6028243dcc8 distroprefs/DMUEY.File-Copy-Recursive.yml -SHA1 f16da80410d98c48476b0f7b2f856f74b79ed640 distroprefs/DOM.OpenGuides.yml -SHA1 1f9de8d8d780f71b34b240205501adb1dacc724e distroprefs/DOMM.Module-CPANTS-ProcessCPAN.yml -SHA1 4e6948397ea832c86b374db4bd3b7895f096d3b1 distroprefs/DONEILL.MIME-tools.yml -SHA1 aa33f55f43be8d220492b125e8ab9296bbb01de1 distroprefs/DOWENS.JSON-DWIW.yml -SHA1 640e6c03aab5df568d27816e7e6a81adf1359237 distroprefs/DROLSKY.Alzabo.yml -SHA1 99275c9aadec7e586e576256599dfa5b393e9261 distroprefs/DROLSKY.DateTime-Locale.yml -SHA1 1e5e84bb7b5ebaa44988207050da37883bbd0335 distroprefs/DROLSKY.Devel-StackTrace.yml -SHA1 72078280d49350a50ee9035f1d3190a10bc4d19e distroprefs/DROLSKY.Params-Validate.yml -SHA1 4913fc5a830a7e7a2a5ec2737c302a7ee8ac39f1 distroprefs/DRTECH.Config-Loader.yml -SHA1 e21fd0031c45a351fcd8ca0095d0aa09629aa24d distroprefs/DSKOLL.MIME-tools.yml -SHA1 fe533a848487ea3ea99f21c2f553d3e608efb85f distroprefs/DSUGAL.Devel-Size.yml -SHA1 659f3e3a410d4ad3866cf90c98e52420c9c892f1 distroprefs/DUNNIGANJ.Tk-CursorControl.yml -SHA1 887d92e9be51998e75b0707e1127abdd773dc252 distroprefs/DURIST.WWW-Babelfish.yml -SHA1 01ffd3bc7d2e67d2507c55e50c560ea0da409a13 distroprefs/DWHEELER.Params-CallbackRequest.yml -SHA1 bf61479adb94d120f118e6635f48f6beb0f653a9 distroprefs/EBOHLMAN.Text-Query.yml -SHA1 47bf06fd295ae32fcd87fb78bb92adeeaeaa2341 distroprefs/EESTABROO.IMAP-Admin.yml -SHA1 4bf20fc79554ef1ab798b752f5533de3ee8b31ba distroprefs/EIJABB.MARC-Errorchecks.yml -SHA1 85ea296fe8cde1230bc184a179eb9363be57f52a distroprefs/ERIC.OpenThought.yml -SHA1 6fb9d41f672ec668c4da795045111ea826fc1c12 distroprefs/ERYQ.Convert-BinHex.yml -SHA1 6d1af2cd50467aeefc6fb0af9ba3ca85b446c4db distroprefs/ESUMMERS.MARC-Charset.yml -SHA1 ad2e43724d80e3b02de39fbcd4581e0742c666cd distroprefs/EWILHELM.Math-Vec.yml -SHA1 45a715a5322fb362a87857ae77a1613520bf7f83 distroprefs/FABPOT.Plucene-Plugin-Analyzer-SnowballAnalyzer.yml -SHA1 62acd9323137cf1f1e5425d19c645066018c172d distroprefs/FDALY.Test-Deep.yml -SHA1 19af3c488c75abd32b650a17ff24b9f141ebb524 distroprefs/FHOXH.Test-Reporter.yml -SHA1 6082e0f3ed911a319ef67d4f3a47cc3cf42cb82f distroprefs/FLORA.File-Extractor.yml -SHA1 5cb56427373f2bfd8a332b49dfef8670d1d01538 distroprefs/FLORA.Net_SSLeay.yml -SHA1 8be3d5141dc0059621cc5d6ea8883719339fff85 distroprefs/FLUFFY.Class-MethodMaker.yml -SHA1 f790c18e2a9195ff6b8902f267636137dfd3d86e distroprefs/FOTANGO.Data-Structure-Util.yml -SHA1 564f4f0390742d30773d246bbbf2596670927b90 distroprefs/GAAS.Data-Dump.yml -SHA1 0dfc149b7f84faa02445145672b55936a7aa553d distroprefs/GAAS.Font-AFM.yml -SHA1 58897de05768f6fb56541fc1a4b55f4d10be03bc distroprefs/GAAS.libwww.yml -SHA1 9dd2f59c685e05fccfc788c04586929bcbdcdc64 distroprefs/GBARR.libnet.dd -SHA1 ff6eb4e4887f137049aff6d8e338cae8c8652a37 distroprefs/GBARR.libnet.yml -SHA1 d27f83106d5b5f0274c0640b3ffe10177929667d distroprefs/GBARR.perl-ldap.yml -SHA1 64ad406e29b8d008773815820432dfdcf230c80e distroprefs/GBROCK.Tk-StayOnTop.yml -SHA1 bf302a0bc219482c5561799397ce626989ce19dd distroprefs/GEOFF.Apache-Test.yml -SHA1 d504e51e5f0588137a8ee587bdffafcf4d31780c distroprefs/GIRAFFED.Curses.yml -SHA1 ff3ab58e7d0c36d871143e46e9343bae48133782 distroprefs/GIULIENK.Audio-Beep.yml -SHA1 04de161e38b8d28d9ea86cf97952f808d85cdb5a distroprefs/GOMOR.Net-Write.yml -SHA1 8090887eb0c4e580e126411dd6e195a6dcfceb99 distroprefs/GOZER.mod_perl.yml -SHA1 57ab08cae44386211c9ae4b7334f9247d184a997 distroprefs/GRANTM.XML-SAX.yml -SHA1 aa0777a56689449e15f93c584da5bacced67cb21 distroprefs/GRAY.IO-AIO-Util.yml -SHA1 16ea294f575a95e9d4c13312d5664c9bbc0fb6fe distroprefs/GRICHTER.Embperl.yml -SHA1 02e8382912872a228896414c24344f7ba813650e distroprefs/GRM.App-CamelPKI.yml -SHA1 bfabe2072c878359c50622b0d481f997559bfb28 distroprefs/GTERMARS.Apache2-Filter-Minifier-JavaScript.yml -SHA1 a4228e454b2931f7a85a8412703cf02d439d5b10 distroprefs/GWYN.POE-Component-Daemon.yml -SHA1 fea17425dd1c9b1e735a800dee80a6d405aa1283 distroprefs/HANJE.Syntax-Highlight-Engine-Kate.yml -SHA1 b7b962604271f9dd8fc5e37c540f750f5978a988 distroprefs/HAYASHI.Term-ReadLine-Gnu.yml -SHA1 3bebe187a2e07cd301a8c096fdec91ecccd9e148 distroprefs/HDP.Perl-Version.yml -SHA1 982698f38157411cddae1d2279e9502dc4b7d72b distroprefs/HMBRAND.Spreadsheet-Read.yml -SHA1 3a8461222d63b13643fd39cd746dc7c85a6b0236 distroprefs/HMBRAND.Tk-Clock.yml -SHA1 7c46625bc8be1ea720225bb453edcd1626005cc5 distroprefs/HORROCKS.PersistentPerl.yml -SHA1 90883f7670a88b102891ed83e8ee1a849ca0f4cb distroprefs/ILMARI.DBIx-Class-Schema-Loader.yml -SHA1 9e1facd2099e165bfd0d9bd892e5edb2b9d50fbf distroprefs/ILYAZ.FreezeThaw.yml -SHA1 3f9674ffb2696c29ec8f4286f647c16db0020e84 distroprefs/ILYAZ.Math-Pari.yml -SHA1 caf4578aeacf41d51b43880ea8455358b4d0964a distroprefs/ILYAZ.Term-ReadLine-Perl.dd -SHA1 bda02b677e273259d186961f7c8eae480d7ef910 distroprefs/ILYAZ.Term-ReadLine-Perl.yml -SHA1 d8efd70bd00c80243eb9bfa8338a0d6801752984 distroprefs/INGY.Inline.yml -SHA1 f93375cd230872202736427f640e94642b285afc distroprefs/INGY.YAML.dd -SHA1 87d2f34018deaf22ec78903576efb4ad51ca986d distroprefs/INGY.YAML.yml -SHA1 5f163956229ec897a0fb1a00c4c5d615ffaf8326 distroprefs/ITYNDALL.Net-Amazon-Thumbnail.yml -SHA1 982a7dc0489ab5ab1b998c245ad222fe15ea4a90 distroprefs/JAYK.Catalyst-Authen-S-D-C.yml -SHA1 08bb2709bf24a070983b0c975c56b283e199519a distroprefs/JCRISTY.PerlMagick.yml -SHA1 917a7b41d5d888eb4c4a598afc740758db164658 distroprefs/JDIEPEN.Audio-LADSPA.yml -SHA1 daff1027ab61bf9f4f8b0c12b214917028bf320d distroprefs/JENDA.Mail-Sender.yml -SHA1 c637c9d82ec754647624a5f751e35b59f8e41df2 distroprefs/JESSE.HTTP-Server-Simple.yml -SHA1 4dd8ee17665f8756abc689b13952f1a2ccaf89b5 distroprefs/JESSE.Jifty-DBI.yml -SHA1 43f0ac97dcacbf4d6c621e47cf6af96b06313987 distroprefs/JGMYERS.Encode-Detect.yml -SHA1 b39ac99266e6e2260b31f8a702d64adfc9f71073 distroprefs/JHOBLITT.DateTime-Format-ISO8601.yml -SHA1 4b4ed3298ec9ef5453f96321a5db458bb33cb404 distroprefs/JJORE.AI-Prolog.yml -SHA1 90ad00be735bb0ef97da631d358a52bfccb7179f distroprefs/JJORE.Carp-Clan.yml -SHA1 3fd695351b85b620ff582808541afa0602f7bc32 distroprefs/JKEGL.Test-Weaken.yml -SHA1 3fb457e8ef5eadc9cdc41a75005ec1e2316ab20e distroprefs/JMASON.Mail-SpamAssassin.yml -SHA1 3c5c0f1e7345627d0972071b2eed8471fffce313 distroprefs/JMGDOC.OpenOffice-OODoc.yml -SHA1 eb82c1c6a29983f568b70a29aef638b271667970 distroprefs/JOHNL.DBD-Informix.yml -SHA1 ec602332d67ee23ac665c2a1cedd673317e270c6 distroprefs/JOHNSCA.TkCarp.yml -SHA1 d3c237042968d3a9c867bbdf554f16327252160e distroprefs/JOSEPHW.XML-Writer.yml -SHA1 8dc8c3c8d694fbeb9d494e4823d9a185501ae8e5 distroprefs/JPEACOCK.SVN-Notify-Mirror.yml -SHA1 9f7191057584e9a1e183c9eb11dc9d6dfab90d0a distroprefs/JPIERCE.IO-Pager.yml -SHA1 d4b3f3e610d71e522e5f172c25114417819720f3 distroprefs/JPRIT.Event.yml -SHA1 3cf93c56099bc9490e1c464b294f007b98749283 distroprefs/JRENNIE.WordNet-QueryData.yml -SHA1 96e6ee6973df7502f4ca12d72d22793ad6f71123 distroprefs/JROBINSON.SQL-Translator.yml -SHA1 fdc328eb31d839df7580566406fec0ea740a44ce distroprefs/JROCKWAY.Chroniton.yml -SHA1 8a83f61832a64fb882932ae6c300546d1081437b distroprefs/JSHIRLEY.Catalyst-Action-REST.yml -SHA1 6ee53f5c33fb9eab74894425ab90cac264a97e04 distroprefs/JSTENZEL.Getopt-ArgvFile.yml -SHA1 e4b8d7b83a07f16f45ec27dd7806ab591c7507f0 distroprefs/JV.Getopt-Long.yml -SHA1 3d3c6a30b7d36cb51be07b39c3fee0b955999cbc distroprefs/KANE.CPANPLUS.yml -SHA1 7a75592e12385a241f528b4c3f839c4dd8a0c1d4 distroprefs/KARASIK.IO-Lambda.yml -SHA1 a0e37e20668fed466d5f1906930032879a8e11ae distroprefs/KARMAN.SWISH-Prog.yml -SHA1 4aeb3d2f054d46ddda79037479cd4fef15e2e040 distroprefs/KASEI.Class-Accessor.yml -SHA1 43cc5a3f630449d8765a170f4124193f0cd8db46 distroprefs/KAWASAKI.Lingua-JA-Romanize-Japanese.yml -SHA1 633cdf46c0f756288284ab7a769e28c72f4c59ee distroprefs/KBROWN.SOAP.yml -SHA1 53ed4eaff4ac164f2a9598d3fb6d564865df37f8 distroprefs/KCLARK.SQL-Translator.yml -SHA1 321d9140e1002d8ed84222c09b6a000e3742f2d3 distroprefs/KNORR.Net-MirrorDir.yml -SHA1 003f000da142cd81fd447b1af36f0b58841a58af distroprefs/KROW.DBIx-Password.yml -SHA1 eac68d766e6e3421717b5735e5763a54743fc3c8 distroprefs/KRUSCOE.Tie-DxHash.yml -SHA1 9b4696fccd85473b34975421663c4f8e3a9370cc distroprefs/KVAIL.Tk-Stderr.yml -SHA1 7a31b880a7dceabc3b1664a67900843970041b85 distroprefs/KWILLIAMS.AI-Categorizer.yml -SHA1 9579da4838305cfdf6abdc17d38af21ab9b7577d distroprefs/KWILLIAMS.Crypt-SKey.yml -SHA1 5f4abfa152948882cce3cae77ec3b1cf79a2037a distroprefs/KWILLIAMS.Module-Build.yml -SHA1 2aafd38003e89cbba2ebf438e469e2bf180b18ff distroprefs/LAMPRECHT.Tk-GraphItems.yml -SHA1 5943f8e87d88380f1e5348839698f87b03eed113 distroprefs/LBROCARD.Test-WWW-Mechanize-Catalyst.yml -SHA1 aa66a9c8f43b15356f9a3c75441879f9825f5c87 distroprefs/LDS.Crypt-CBC.yml -SHA1 e9bd2016d5029e7c5359569bddb9946f2f171de9 distroprefs/LEAKIN.File-Rsync.yml -SHA1 943b55a0724fe881729693b15dec362628e6cb5d distroprefs/LETO.Math-GSL.yml -SHA1 4111b8de3b970ef9c37402dd5f138a68a7c97d0a distroprefs/LICHTKIND.Kephra.yml -SHA1 376b298af821012956f0b2a44c09130fa6f60bbe distroprefs/LOCAL.trailing_dot_distros.yml -SHA1 8ca6ecb4a6f5f50e0b8f7776b0ae918b44c530a9 distroprefs/LUKEC.Socialtext-Resting.yml -SHA1 1fb3bd1b3b64d405a5b64aa0f620fcfe61eff58c distroprefs/LUSOL.Tk-Gauge.yml -SHA1 e240d9feee9e4a748b5c47687048b86706952907 distroprefs/LZE.HTML-Menu-TreeView.yml -SHA1 2c123a146740841003b53fa4f532c55a6893a707 distroprefs/MAHEX.Image-Grab.yml -SHA1 5b22419dce7cd965f5ce42fab1437f2ca8952dc0 distroprefs/MAKAMAKA.JSON.yml -SHA1 4baf7d00fe4cd4a088f6f15360cdf46326ff96ac distroprefs/MARKOV.CPAN-Site.yml -SHA1 eb36763e5faea82f614289f3e9068101f17bc217 distroprefs/MARKOV.Mail-Box.yml -SHA1 a1b69bdd26e030bfa9639c880a8aec24dcd69bd7 distroprefs/MARKOV.Mail-IMAPClient.yml -SHA1 4697d319f8a1ee08100a03d302cd0e77b2238f94 distroprefs/MARKOV.MailTools.yml -SHA1 b67a04cc1d49ace0c5f46a73a38f1d7014aa2f18 distroprefs/MARKSTOS.CGI-Session.yml -SHA1 713aefbcda0e1c0f2d6c20f347e0c2eb046f2222 distroprefs/MAURICE.IPC-ShareLite.yml -SHA1 01bc9f5a0b2fbeecc9f5b3e5d745f826ccaad0f0 distroprefs/MBARBON.Alien-wxWidgets.yml -SHA1 2358f5a919f43c64914859eacbe0807fc4440b4b distroprefs/MCEGLOWS.Bloom-Filter.yml -SHA1 367e8ee57fca8ae24e28e9368faeb46108a41e48 distroprefs/METZZO.Java.yml -SHA1 64daf7e6381bc169b445252fc6f6e61e4d1f2e76 distroprefs/MI.yml -SHA1 bc2d5da2f5eeaa6c59e528ca60a69ca72b88fa4e distroprefs/MIKER.IPtables-IPv4-DBTarpit.yml -SHA1 1caa9b2931820a0d118dd08bba2daf830a00fde8 distroprefs/MIROD.XML-Twig.yml -SHA1 7a5e89593d15ca28422e4c9fbdbf0319a0ebb27b distroprefs/MIYAGAWA.Catalyst-View-JSON.yml -SHA1 81234f17fa226bd5dd5b12bbefd91d7b90b4804f distroprefs/MIYAGAWA.Net-IDN-Nameprep.yml -SHA1 3c9a8a247ddc8daf1f01efa16ff1e432464f852a distroprefs/MIYAGAWA.Plagger.yml -SHA1 0498de191664f9a6f57c093330c82dc80000ccff distroprefs/MIYAGAWA.XML-Atom.yml -SHA1 b779cd0a110b5963058200aa5d9436d28e217b32 distroprefs/MInoinc.yml -SHA1 c956ad9757ef03929cd0d5ac5e620d9be91a9b0d distroprefs/MJCARMAN.Tie-Tk-Text.yml -SHA1 6afc4ac0d42adee5bb0282e2ba6c8e1ed2bb5fe8 distroprefs/MJD.Devel-Trace.yml -SHA1 59c1d7fb23e107b3c161a2f9eb1ded77f0023c5b distroprefs/MJD.Text-Template.yml -SHA1 31144ad752fca3fde8f62437ef4acc5019852cf5 distroprefs/MJEVANS.DBD-ODBC.yml -SHA1 317bf6276a6ebf41446eb55bb3ae8470836ed329 distroprefs/MLEHMANN.AnyEvent.yml -SHA1 ccdce00914e7b9d47f3b813113d63c89ae8416b7 distroprefs/MLEHMANN.Coro.yml -SHA1 56ef6643b596f97790a1cf401216e7163ddff1d9 distroprefs/MLEHMANN.EV.yml -SHA1 f7d763be7c995766db9efa9d9733e80e74cbf88c distroprefs/MLEHMANN.Gtk-Perl.yml -SHA1 ef5ae5be19cdde5f70fcd66be7f0ecd42e659b73 distroprefs/MLEHMANN.IO-AIO.yml -SHA1 cc92b51441f76cbe8a43144dd7f5fa2286012faf distroprefs/MLEHMANN.PApp.yml -SHA1 1c6b084c0a5506834e69252494c1eeabb8919d1a distroprefs/MLFISHER.Test-MockDBI.yml -SHA1 307852f9e405b3d41c0eca188cfc8a5bbe4ff4f7 distroprefs/MRAMBERG.Catalyst-View-TT.yml -SHA1 a43818203eff0377ddea029d9e572b6e6f055639 distroprefs/MRAMBERG.MojoMojo.yml -SHA1 ea08ac5ba983335b9ed317a7131f561b6a09b35e distroprefs/MSCHILLI.RRDTool-OO.yml -SHA1 c656d271124382d9ef947cdab375dc1b4d7900b0 distroprefs/MSCHWERN.Test-Simple.yml -SHA1 26e2bf3370edfcb0a5b912d1c57d84dc75e5a92e distroprefs/MSERGEANT.AxKit.yml -SHA1 509237359e8567b1c5a0237b677ce68eabd4c5b2 distroprefs/MSERGEANT.CDB_File.yml -SHA1 eb27ebf7dcd920fac1b267c0df06a3d71970ffd2 distroprefs/MSERGEANT.DBD-SQLite.yml -SHA1 de835cac688de5a1b7bf5da1a49eecfcb3c9c836 distroprefs/MSERGEANT.DBIx-AnyDBD.yml -SHA1 635817d11c7cae6a6ba7eb944d53eef63bf4810c distroprefs/MSERGEANT.XML-Filter-XInclude.yml -SHA1 5ddcdacacb67cdfd2dd4187ecdc8071d85865a7d distroprefs/MSERGEANT.XML-Parser.yml -SHA1 176cdbdb4f2c7e266230c81d435eb82f5ba6d4d7 distroprefs/MSISK.HTML-TableExtract.yml -SHA1 4a01d74570a8ea3d97a0c09a7c85750f70b83f13 distroprefs/MTHURN.I18N-Charset.yml -SHA1 436a7539d42846ae6fd208840bf57940e05c7ca5 distroprefs/MTHURN.Tk-Wizard.yml -SHA1 f1fafcd2e29375836edc55f476a3b78150a7d529 distroprefs/NEELY.Data-Serializer.yml -SHA1 95850096aeec405f90853bd2ed77427e9ecfda0f distroprefs/NEILW.Inline-CPP.yml -SHA1 a0e77e23618b2f94dcbd7eb9fc4d1126164647c7 distroprefs/NESTING.Unicode-Wrap.yml -SHA1 027c98c1cef03db9a01c8f8a0e3a214181cf4440 distroprefs/NI-S.Tk-HTML.yml -SHA1 2290190920c5631a17022740a2739c9b62c450a6 distroprefs/NI-S.Tk.yml -SHA1 65b26d3e23cb5f767536e7545d70b7e65479af8e distroprefs/NICOLAW.WWW-Comic.yml -SHA1 665ee093dc30d34798b6033a4103f2d32e1bb68a distroprefs/NIKIP.Authen-PAM.yml -SHA1 1932708493d031589fc82d94941e7952e0a54e54 distroprefs/NKH.PerlBuildSystem.yml -SHA1 59df82e4d6967fb05be903f925962de382db977c distroprefs/NODINE.Text-Restructured.yml -SHA1 9411052097df9b437f814025fa5128911c0cbe64 distroprefs/NUFFIN.Catalyst-Plugin-Session.yml -SHA1 4ed5526b451138b0019d3bfa824eed56b4f4562b distroprefs/NUFFIN.Devel-Events.yml -SHA1 e614f58ea1329b33f7ae4a7a284cf91d4ab6d2ef distroprefs/OLAF.Net-DNS.yml -SHA1 6ce4f3b443ad8bc05fcdbdced7b7bb8ad0517926 distroprefs/OVID.Class-Trait.yml -SHA1 ad47a62f5f8ee2ed48e7e0d23013c969ad2fcfeb distroprefs/OVID.HOP-Parser.yml -SHA1 fb59671cf11946d81095bde9e119915bbed99e08 distroprefs/OVID.Perl6-Caller.yml -SHA1 f113f114501c6bdba1934c864a2dba6b29e827a5 distroprefs/OVID.TAPx-Parser.yml -SHA1 377a8b9fcedb722e6815fb0598f381ffea6e2f7d distroprefs/OVID.Test-JSON.yml -SHA1 0fb226f103b085c5ce9dcbb87bb11256ebe1235b distroprefs/OWEN.PDF-Labels.yml -SHA1 e0d96552a62d758d3441e54b601664ebbccdbf1c distroprefs/PAJAS.XML-LibXML.yml -SHA1 c5410e306690773e9f20d835394938b97b06d677 distroprefs/PARDUS.File-MimeInfo.yml -SHA1 d20084e5fe455b21f3d2fa9fb961df990277ee19 distroprefs/PCIMPRICH.XML-SAX-ExpatXS.yml -SHA1 38b4ea6d0dc0860ff0390fe866c7a47ed151a890 distroprefs/PDCAWLEY.Class-Inner.yml -SHA1 c075527dd2dc2421e8d10e6d2b487a6bebdd022c distroprefs/PETDANCE.HTML-Tidy.yml -SHA1 bb1852ea960185c4f8c1e9ea9653e6f181280cf5 distroprefs/PETDANCE.WWW-Mechanize.yml -SHA1 4bdbd049ef90db9c3b5f93dee475615e3a65fb7c distroprefs/PETERW.SVG-Parser.yml -SHA1 b04c24b7ca5b2a2a9fb3683705bfcdeac9747875 distroprefs/PEVANS.IPC-PerlSSH.yml -SHA1 2a9a8d6e2692d71c84c626a75f88454e019421aa distroprefs/PHOENIX.Term-ReadPassword.yml -SHA1 0de6bcb1c34b234ae3a688b530f674aa52b78158 distroprefs/PHRED.Apache-Reload.yml -SHA1 b7fb26c1fc512ea3327daea890a6da0c8afc6e13 distroprefs/PIERS.sapnwrfc.yml -SHA1 138800ebf67920e445c0af7fb77de42236067c43 distroprefs/PODMASTER.HTML-Scrubber.yml -SHA1 bd799efc3e69f33849806c0780880ebbe512d6c6 distroprefs/QANTINS.BitTorrent.yml -SHA1 b82524dc1381b4838de18d05fd5612b1088952ea distroprefs/RBERJON.JSON-Any.yml -SHA1 e16549c2d3b38458a0d4a087403908d616b39fd8 distroprefs/RBS.XML-AutoWriter.yml -SHA1 8b5c37da162d0e2528b93bde03940292c51d9981 distroprefs/RCAPUTO.POE.yml -SHA1 c77cb2de786cd8774a60121033d713ddcfc6da8f distroprefs/RCLAMP.Devel-Caller.yml -SHA1 0f84e232b4a810a6cf4823e9bc2921c050afea7b distroprefs/RCLAMP.POE-Component-Server-HTTP.yml -SHA1 dd8d375bac703677c9c364639a4fe22a0c24986e distroprefs/RCSEEGE.Tk-JComboBox.yml -SHA1 ac70ac1656c18554111c802050dfcd36ebb1fb64 distroprefs/RDF.Clone.yml -SHA1 5f24b2f06148034a0dd0fa52537942e18a68b852 distroprefs/REDTREE.PDF-API2-Simple.yml -SHA1 27d3ef5f6c8042a845836a3393c1d13e8d566406 distroprefs/RHOOPER.HTTP-Lite.yml -SHA1 208670861d878584d638ac3f42b5d3fe66a7cec4 distroprefs/RICKM.DateTime-Format-Strptime.yml -SHA1 e3698e8e15378d9c2271bd12d14c394564b572f9 distroprefs/RIZEN.Config-JSON.yml -SHA1 faff33ebc17d0bf928933f25a3f8d94ced7f9686 distroprefs/RJBS.Data-UUID.yml -SHA1 ddef237ae46cc9301143c993ba85e64998351a3a distroprefs/RJBS.Email-Send.yml -SHA1 562b28d9e31de226bdade009f481a7d5aa0a02eb distroprefs/RJBS.MIME-Light.yml -SHA1 f29703d516f1a48946dc75c669ae87786ee23640 distroprefs/RJRAY.RPC-XML.yml -SHA1 e0f009c1951f544f6c9c847db53133562fc72e2d distroprefs/RKINYON.DBM-Deep.yml -SHA1 442a17ba8976e87c80a4d301e4a8babfd66500d4 distroprefs/RKOBES.PPM-Make.yml -SHA1 04fb044577e1480ce2d2d8bdcc992825cc03e4f1 distroprefs/RMUHLE.classes.yml -SHA1 634fe921e8f30fe00ef5511ee08cab8c94a8d532 distroprefs/ROBIN.PadWalker.yml -SHA1 44f72a0292cd70207b9d6ed945b8849ee967e16c distroprefs/ROBIN.Want.yml -SHA1 e7a741f3a4c834149678dfcd30c6a997f613f0ec distroprefs/RONAN.Transform-Canvas.yml -SHA1 2eda35ba49baafaf5bfac771531da48eba0f12a4 distroprefs/ROODE.Readonly-XS.yml -SHA1 e30268d47a0e36d1f2eebfe9810641bbb0a13943 distroprefs/ROODE.Time-Format.yml -SHA1 755467bbc5e8d01fbf978116064bf96140db72ac distroprefs/RRA.PGP-Sign.yml -SHA1 cd4e611d7b14e78dc2158a121b923f7ed9a9be10 distroprefs/RRWO.Graphics-ColorNames.yml -SHA1 d32579b1cd343d4bd7fd6cc15edd9e66a9dd1015 distroprefs/RSOD.IPC-Run.yml -SHA1 da6ccad2744265f551ad93c4aed00d98c40efdd8 distroprefs/RUZ.DBIx-SearchBuilder.yml -SHA1 b13ac86dfa01c3483209d47ea72cf95f02762e94 distroprefs/RYBSKEJ.forks.yml -SHA1 26c91594d6fe20a3d3775788d174848e9b2e33a3 distroprefs/SAMTREGAR.DBIx-Timeout.yml -SHA1 1753817f3641ebbfb7f9e53befb28e9353a769c0 distroprefs/SAMTREGAR.Devel-Profiler.yml -SHA1 e5faa48a8b2732778fa70687e1427d7c99386a3a distroprefs/SANKO.Net-BitTorrent.yml -SHA1 66bc1cd74cecc694696aa91cd3ced68ea84e7a89 distroprefs/SCHUBIGER.DateTime-Format.yml -SHA1 9c855fb07371bc4398ed09825935f0459d5c9ebc distroprefs/SCHWERN.Class-Fields.yml -SHA1 f5bb7075f6f866d1ccabba59da2037bd0c672dd8 distroprefs/SCHWERN.Exporter-Lite.yml -SHA1 9b357284ed3394ea13f6dfa547a83898e65cad16 distroprefs/SCHWIGON.Class-MethodMaker.yml -SHA1 0b27043f34609943cd31652f32e6d2672c8666bf distroprefs/SEANO.Sepia.yml -SHA1 f720892dd9fc401edfd729cdf410719b1933ffbb distroprefs/SHEVEK.Mail-Karmasphere-Client.yml -SHA1 b24ef8e7e28b0e34aa8239057c9d4b59e017cfb1 distroprefs/SLANNING.Ogre.yml -SHA1 8adedb297bd507915e20c89ad6b0cf3c8c08dc28 distroprefs/SREZIC.Tk-Autoscroll.yml -SHA1 4a918cbdd8c70bda8b6e4b69d2c578e442d92cba distroprefs/SREZIC.Tk-HistEntry.yml -SHA1 9a5435df02413b4380a5ff4418f2dc8c66885072 distroprefs/SREZIC.Tk-Pod.yml -SHA1 2b12729f92abfa2c0321ca56874da036e0e35a09 distroprefs/STAS.libapreq.yml -SHA1 297068a64c962a6291988f5e2272f25b764a79b9 distroprefs/STEPANOV.IMDB-Film.yml -SHA1 6df65d0332537ffc179f06c65871fc296ad370ef distroprefs/STEVAN.Class-MOP.yml -SHA1 02cb639f8176717e5188264073b56ddb9c807fd2 distroprefs/SWALTERS.typesafety.yml -SHA1 b0bd11384a7fb5696eb078ca78f07e65adb4b056 distroprefs/SZABGAB.Spreadsheet-ParseExcel.yml -SHA1 9c99712a6c02ff72c0a4701a0582bbdfeb6a59f6 distroprefs/TBONE.HTTP-File.yml -SHA1 22ea6dbf9b3a59dd93a57921cbab7deb230b8108 distroprefs/TELS.Devel-Size.yml -SHA1 329fc641ff34839390f758ea59435a8333601f9d distroprefs/TELS.Math-BigInt-GMP.yml -SHA1 6dd413afbe634d8dc5a27139fa2b13a1691862b2 distroprefs/TIMB.Apache-Status-DBI.yml -SHA1 69b1b6a2a22e7ee0c3c12baa47209f6d1779d009 distroprefs/TIMB.DBI.yml -SHA1 88e6d22214caaa73fe58db2e943739df75064918 distroprefs/TIMB.GoferTransport-http.yml -SHA1 115e1ddce36d8f2b4bbe767eebe039dadd451292 distroprefs/TJENNESS.Tk-TextANSIColor.yml -SHA1 864adef44010b28ad51c3415a6a69d7b69f88367 distroprefs/TKEEFER.Gantry.yml -SHA1 87852bf34685e71a48a3b1fdca17f89a4e252cd8 distroprefs/TLOWERY.DBI-Shell.yml -SHA1 e069e88c15c3f51941ac239ffa0f84c9e3a3404a distroprefs/TODDR.Net-Jabber-Bot.yml -SHA1 008e495fa890c64b8b2ece13e6ed233675227470 distroprefs/TSCH.Cairo.yml -SHA1 129209372806830e309175508c5144ecf34efdef distroprefs/TSCH.Gtk2.yml -SHA1 1f4f49c326e4bcbeab03a42010a1e3ed77ae236e distroprefs/URI.File-Slurp.yml -SHA1 4cc66677ef70c183cf4b1e1d03775abecb2aa393 distroprefs/VKON.Tcl-Tk.yml -SHA1 55c0187a55d564a31550fb658e09f8b62916d603 distroprefs/VKON.Tcl.yml -SHA1 37961a7ab58622f3768d372a1bac4199a850097d distroprefs/VMAN.Net-Libdnet.yml -SHA1 08cbe5308d60009eb1ca06ed15146e9de1977d26 distroprefs/VPIT.Variable-Magic.yml -SHA1 f39e1d313dc706534d2f6a3b31c61e350c11c756 distroprefs/WITTROCK.Tk-PathEntry.yml -SHA1 b885a02b5c5f5fe8fc210b53d976af7271538134 distroprefs/WRW.Barcode-Code128.yml -SHA1 ccbb7be5f9f4058bb9b68c662f1be0a5fd5fa1da distroprefs/WYANT.Astro-SpaceTrack.yml -SHA1 85cd3d85b6c522cf8d76526555bf8b1fc3e41d81 distroprefs/WYANT.Astro-satpass.yml -SHA1 365689ad47e9ba130bcc5804ac834ee8d3b0911d distroprefs/YAMATO.QDBM_File.yml -SHA1 4d57e3ed8074de47151df2741cbd5af152ad9f5a distroprefs/YANICK.XML-XPathScript.yml -SHA1 da98fd4fcb98d2f05a4ca34300f7720374196ffe distroprefs/YEWENBIN.Calendar.yml -SHA1 d901436429a68a96235760113c13c882258877e1 distroprefs/YOSHIDA.WebService-YouTube.yml -SHA1 4ac38e824e7fd50ae249b2ea9becb73459809e15 distroprefs/YSAS.SWF-Builder.yml -SHA1 9b50b7bace5e919c93e08e3837224967f5ef310d distroprefs/YVES.Data-Dump-Streamer.yml -SHA1 4cb61254d009abe65f1d943885cfb72aeda3fa15 distroprefs/YVES.Date-Simple.yml -SHA1 4059727e80d999ba2cb69aab77c47d970d0ef077 distroprefs/ZEV.Test-Dependencies.yml -SHA1 daac7f7627860e2372a3de6ce35e6e9eec80d8d6 distroprefs/ZINCDEV.tk-zinc.yml -SHA1 2d0520a16c25609a0748bc7423d7cbeb5dcba776 distroprefs/ZOFFIX.LWP-UserAgent-ProxyHopper.yml -SHA1 3a216694d57bb44948f1433947cd9aff8e7a03dd distroprefs/ZOOLEIKA.RDF-Simple.yml -SHA1 eeaec00a7b15e8e0dc0ef86b7d92949a70efbd34 distroprefs/ZOOLEIKA.SVG-Plot.yml -SHA1 efbe8e6882a2caa0d741b113959a706830ab5882 inc/Test/Builder.pm -SHA1 ae1d68262bedc2475e2c6fd478d99b259b4fb109 inc/Test/More.pm -SHA1 dc0eab8096ce8e37ef81e4b685f66e5e9682402f lib/CPAN.pm -SHA1 ca47203e0e6479e2be6fac33069ea2cd09d463ec lib/CPAN/API/HOWTO.pod -SHA1 31fe6809bca43dc74f54ecf6a6ace8706b5ed226 lib/CPAN/Admin.pm -SHA1 15d7b0a87447db7f0787172ce315ae552465a7d9 lib/CPAN/Author.pm -SHA1 fcd7c55afb6cd979845010c0290993d33571f419 lib/CPAN/Bundle.pm -SHA1 6613db3adad2817cc30f63ba060f214dba3de008 lib/CPAN/CacheMgr.pm -SHA1 6277f7d06dfb92da050e0ee78fa5fe4ca96537fc lib/CPAN/Complete.pm -SHA1 7e763ea4ad3c8da421e313efa1cc74783d5cb3aa lib/CPAN/Debug.pm -SHA1 34c8162aa20cc7074fe2cffe3fce0573e68515b8 lib/CPAN/DeferredCode.pm -SHA1 5d44abe7ae749db5d21cc4574389ce923721f43e lib/CPAN/Distribution.pm -SHA1 43d3b96072d651441cee8412573f5f18baa72510 lib/CPAN/Distroprefs.pm -SHA1 cd39b0f1bb9763a516bffd2e81b5347c0c797d1f lib/CPAN/Distrostatus.pm -SHA1 62b728edde39be16a38cce29b08f88b4709a1abd lib/CPAN/Exception/RecursiveDependency.pm -SHA1 0914803a2ed6c20f050d6377969fc086e7da56ac lib/CPAN/Exception/blocked_urllist.pm -SHA1 06015c184c85de35a9e7832524a4776d27b20265 lib/CPAN/Exception/yaml_not_installed.pm -SHA1 44b0126e756f43980a469b17e3600f1cecc63a70 lib/CPAN/FTP.pm -SHA1 72a3b878de0fb72a9fd0ef5f806060cf6113acc4 lib/CPAN/FTP/netrc.pm -SHA1 19c4ed734ae2b36d38fb001be4ac99e50494d5f7 lib/CPAN/FirstTime.pm -SHA1 209ffa1405d3356d34ead21255d1b23732c4c8b5 lib/CPAN/HandleConfig.pm -SHA1 2c95b20a0d342635da3d8d7967637fa4ba10b057 lib/CPAN/Index.pm -SHA1 7cf0d99ff78c97afa4e6d042b18338f5f1477198 lib/CPAN/InfoObj.pm -SHA1 d12264dc1735654f0a7e6e31387106336be8726d lib/CPAN/Kwalify.pm -SHA1 0460d53b1b0b4fb6b1b1ec3218a3182210e0802a lib/CPAN/Kwalify/distroprefs.dd -SHA1 ca22988f7fd6d0989d04df8b5f84e913e8a1a593 lib/CPAN/Kwalify/distroprefs.yml -SHA1 d38e7c2e5b019bedd00423fbf82a14defa0aa7c6 lib/CPAN/LWP/UserAgent.pm -SHA1 42e9a304da0a6ef87e8a73ec180fbd915d8628a4 lib/CPAN/Module.pm -SHA1 6faf2d6787bcb6c6d2a205f59a92d78e73fc7f14 lib/CPAN/Nox.pm -SHA1 e18c032c69ccafc2d224ae6dfbb0b60628c7848a lib/CPAN/Prompt.pm -SHA1 ac4e3fd3b264404956de68d227909d8d2abd8498 lib/CPAN/Queue.pm -SHA1 9f656fefbf93517fe0a121000ae5b5bc0e1a44ef lib/CPAN/Shell.pm -SHA1 f742634c1110ab6c66b92b1b9f052027d14a6280 lib/CPAN/Tarzip.pm -SHA1 c572134ef16d4cfdbee4e23f1946062fb5fff5fe lib/CPAN/URL.pm -SHA1 2492ea05e3fd53d03876bdf112cadca009e65418 lib/CPAN/Version.pm -SHA1 01c2c0d35ce8b8e5c472ac2b542a3529d88c4a37 scripts/cpan -SHA1 ce8f1c86172c6cd2698c27f6f76864de724a1282 t/00signature.t -SHA1 215dace24b507de20011d36cbe2d16ddea78bcf3 t/01loadme.t -SHA1 11b0e1300cef04885330d292a52296a44ed689d2 t/02nox.t -SHA1 4f58adf390660cddecf31274a838e48e65dca940 t/03pkgs.t -SHA1 cf39823c3aba766be6f8b99bf74634013b4d6029 t/04clean_load.t -SHA1 6799037363cbb460183f1b483784055cb96c7e40 t/10version.t -SHA1 4c7da618cd8a3054b32b218e4d7daf13ce5fedf2 t/11mirroredby.t -SHA1 9d2be90f9c95844cf3d16c175b3620770d61617c t/12cpan.t -SHA1 c5697c558df9cc12e8a1fb42b9d4eeb2eeae0c6a t/13tarzip.t -SHA1 54e904dc7362af2710b130bafbf7b3ea6e2ddbb8 t/14forkbomb.t -SHA1 e0e62c08ee1152d64d70180a6a06199ec13b05b1 t/30shell.coverage -SHA1 03bbe31acae1d5c4bc3760cea20dbadc842e3960 t/30shell.t -SHA1 514cceea939d34aba0102d5bf76e47b64069dfc6 t/31sessions.t -SHA1 874c4086a55b6d3f2856b47d1be8e39c61bd05ab t/41distribution.t -SHA1 5acddcbee26d5bd075119d309efae14c6f8f8ff7 t/42distroprefs.t -SHA1 b86a9ffad6b939c5091524a6c210dc89cc3cea0c t/43distroprefspref.t -SHA1 6a79f15a10337bd3450604abf39d4462df2a550b t/50pod.t -SHA1 5d5d4a23a6fc5238d05aefc62410dcea7a7e8cd8 t/51pod.t -SHA1 c7ff8e849c791315b09e5fd3e9195b28429ff918 t/52podcover.t -SHA1 8197b806d196bcd1a5c013da22807afe8721b46d t/60credentials.t -SHA1 c4c1beb50a6545c80f42234dcc21beee8e2ac20f t/70_critic.t -SHA1 7efe930efd0a07d8101679ed15d4700dcf208137 t/CPAN/CpanTestDummies-1.55.pm -SHA1 f7dc1c86ff96f2ff444a375024652c50d710e195 t/CPAN/TestConfig.pm -SHA1 081ed556ae14a75c43ca31e67cfc99d180c9ef41 t/CPAN/TestMirroredBy -SHA1 455480f7053abe4ac853a4c456d52b83e8b922e8 t/CPAN/TestPatch.txt -SHA1 b4fd27234696da334ac6a1716222c70610a98c3a t/CPAN/authors/01mailrc.txt -SHA1 816c992e5853ed7312a7789fcab11719de958727 t/CPAN/authors/id/A/AN/ANDK/CHECKSUMS -SHA1 d1a101f24d2d0719c9991df28ede729d58005bb4 t/CPAN/authors/id/A/AN/ANDK/CHECKSUMS.2nd -SHA1 34cf1bf9c95007fe02a4b4f4977eb017516b0cdc t/CPAN/authors/id/A/AN/ANDK/CPAN-Test-Dummy-Perl5-Build-1.03.tar.gz -SHA1 3f66b598a79d5b120205715e86a5eed19251cd13 t/CPAN/authors/id/A/AN/ANDK/CPAN-Test-Dummy-Perl5-Build-DepeFails-1.02.tar.gz -SHA1 57ec31da473af149806cfd0689f6852c5fd3f12a t/CPAN/authors/id/A/AN/ANDK/CPAN-Test-Dummy-Perl5-Build-Fails-1.03.tar.gz -SHA1 4b30a5ff87f92f68616a9d7436be37ee9d0e9b87 t/CPAN/authors/id/A/AN/ANDK/CPAN-Test-Dummy-Perl5-BuildOrMake-1.02.tar.gz -SHA1 7378a536ffa854a49a4fd6082a8d9f924be23d8d t/CPAN/authors/id/A/AN/ANDK/CPAN-Test-Dummy-Perl5-Make-1.05.tar.gz -SHA1 f82f789dfdaa4cf3f34fad2d0f8c97f0f0bd9941 t/CPAN/authors/id/A/AN/ANDK/CPAN-Test-Dummy-Perl5-Make-CircDepeOne-1.00.tar.gz -SHA1 faf5f6c6218c8d862a2e807538a468049cb2263f t/CPAN/authors/id/A/AN/ANDK/CPAN-Test-Dummy-Perl5-Make-CircDepeThree-1.00.tar.gz -SHA1 ffffd32d5e63075ce47527d5af689e76f7421b13 t/CPAN/authors/id/A/AN/ANDK/CPAN-Test-Dummy-Perl5-Make-CircDepeTwo-1.00.tar.gz -SHA1 0a897ebf94b88af75dcd6495f736c317601b9878 t/CPAN/authors/id/A/AN/ANDK/CPAN-Test-Dummy-Perl5-Make-ConfReq-1.00.tar.gz -SHA1 b992aebcd2fa43e3d83113247d2310abf028068f t/CPAN/authors/id/A/AN/ANDK/CPAN-Test-Dummy-Perl5-Make-Expect-1.00.tar.gz -SHA1 522f39ed6921d9704b38bd7dd0c3559815f45a68 t/CPAN/authors/id/A/AN/ANDK/CPAN-Test-Dummy-Perl5-Make-Failearly-1.02.tar.gz -SHA1 35b9020b23e004f349e14fd2cd79b16b94b8c8a9 t/CPAN/authors/id/A/AN/ANDK/CPAN-Test-Dummy-Perl5-Make-UnsatPrereq-1.00.tar.gz -SHA1 a424441767925cd6eb4db35098a896ac15b42991 t/CPAN/authors/id/A/AN/ANDK/CPAN-Test-Dummy-Perl5-Make-Zip-1.03.zip -SHA1 043196f76ae3b0bb245ac2a4428fd910cfeff509 t/CPAN/authors/id/A/AN/ANDK/NotInChecksums-0.000.tar.gz -SHA1 1a5b3cc1fbd14373bc8f1820fdb2e981052d4b70 t/CPAN/authors/id/A/AN/ANDK/cpantestdummies/CHECKSUMS -SHA1 9a5a44d2abc57f3003a0eb2883538f2bb4e5fe79 t/CPAN/authors/id/A/AN/ANDK/cpantestdummies/CPAN-Test-Dummy-Perl5-Make-Features-1.05.tgz -SHA1 5bc14cda7abdb6306caec36f804dfba54b113e80 t/CPAN/authors/id/A/AN/ANDK/patches/CHECKSUMS -SHA1 1aee1bed21f0e9755d693419e810ec75543eb0b7 t/CPAN/authors/id/A/AN/CHECKSUMS -SHA1 1f3304f219bf0da4db6a60f638e11b61c2c2f4c0 t/CPAN/authors/id/A/CHECKSUMS -SHA1 dfc900f5bfbc9683fa91977a1c7198222fbd4452 t/CPAN/authors/id/CHECKSUMS -SHA1 8466a904cf7a0e8522051d19fc028689449a5d73 t/CPAN/modules/02packages.details.txt -SHA1 f4c1a524de16347b37df6427ca01f98dd27f3c81 t/CPAN/modules/03modlist.data -SHA1 e635fad8933c18200afe49290ca25bb1c4694f14 t/data/META-dynamic.yml -SHA1 0182c65f3032611635ad5f008e181ea4eba71ef4 t/data/META-static.yml -SHA1 3735e39de4ee6753cde1c3078afa2d16be8c2f65 t/local_utils.pm -SHA1 3b6f98262392387823dd49f342e6731e1a6ec291 t/perlcriticrc -SHA1 8a00e60e767af838833dea621abe9683cd360e5d t/yaml_code.yml ------BEGIN PGP SIGNATURE----- -Version: GnuPG v1.4.9 (GNU/Linux) - -iEYEARECAAYFAkpFhmsACgkQ7IA58KMXwV0zJQCfdE9L000Ea1PMXQ5vZHupO6vD -yYEAoKMlsaOxc2+RDRh+o8uM5QY4AxpB -=K/sX ------END PGP SIGNATURE----- diff --git a/lib/CPAN/Shell.pm b/lib/CPAN/Shell.pm deleted file mode 100644 index 84f67ffafb..0000000000 --- a/lib/CPAN/Shell.pm +++ /dev/null @@ -1,1939 +0,0 @@ -package CPAN::Shell; -use strict; - -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: - -use vars qw( - $ADVANCED_QUERY - $AUTOLOAD - $COLOR_REGISTERED - $Help - $autoload_recursion - $reload - @ISA - @relo - $VERSION - ); -@relo = ( - "CPAN.pm", - "CPAN/Author.pm", - "CPAN/CacheMgr.pm", - "CPAN/Complete.pm", - "CPAN/Debug.pm", - "CPAN/DeferredCode.pm", - "CPAN/Distribution.pm", - "CPAN/Distroprefs.pm", - "CPAN/Distrostatus.pm", - "CPAN/Exception/RecursiveDependency.pm", - "CPAN/Exception/yaml_not_installed.pm", - "CPAN/FirstTime.pm", - "CPAN/FTP.pm", - "CPAN/FTP/netrc.pm", - "CPAN/HandleConfig.pm", - "CPAN/Index.pm", - "CPAN/InfoObj.pm", - "CPAN/Kwalify.pm", - "CPAN/LWP/UserAgent.pm", - "CPAN/Module.pm", - "CPAN/Prompt.pm", - "CPAN/Queue.pm", - "CPAN/Reporter/Config.pm", - "CPAN/Reporter/History.pm", - "CPAN/Reporter/PrereqCheck.pm", - "CPAN/Reporter.pm", - "CPAN/Shell.pm", - "CPAN/SQLite.pm", - "CPAN/Tarzip.pm", - "CPAN/Version.pm", - ); -$VERSION = "5.5"; -# record the initial timestamp for reload. -$reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo }; -@CPAN::Shell::ISA = qw(CPAN::Debug); -use Cwd qw(chdir); -use Carp (); -$COLOR_REGISTERED ||= 0; -$Help = { - '?' => \"help", - '!' => "eval the rest of the line as perl", - a => "whois author", - autobundle => "write inventory into a bundle file", - b => "info about bundle", - bye => \"quit", - clean => "clean up a distribution's build directory", - # cvs_import - d => "info about a distribution", - # dump - exit => \"quit", - failed => "list all failed actions within current session", - fforce => "redo a command from scratch", - force => "redo a command", - get => "download a distribution", - h => \"help", - help => "overview over commands; 'help ...' explains specific commands", - hosts => "statistics about recently used hosts", - i => "info about authors/bundles/distributions/modules", - install => "install a distribution", - install_tested => "install all distributions tested OK", - is_tested => "list all distributions tested OK", - look => "open a subshell in a distribution's directory", - ls => "list distributions matching a fileglob", - m => "info about a module", - make => "make/build a distribution", - mkmyconfig => "write current config into a CPAN/MyConfig.pm file", - notest => "run a (usually install) command but leave out the test phase", - o => "'o conf ...' for config stuff; 'o debug ...' for debugging", - perldoc => "try to get a manpage for a module", - q => \"quit", - quit => "leave the cpan shell", - r => "review upgradable modules", - readme => "display the README of a distro with a pager", - recent => "show recent uploads to the CPAN", - # recompile - reload => "'reload cpan' or 'reload index'", - report => "test a distribution and send a test report to cpantesters", - reports => "info about reported tests from cpantesters", - # scripts - # smoke - test => "test a distribution", - u => "display uninstalled modules", - upgrade => "combine 'r' command with immediate installation", - }; -{ - $autoload_recursion ||= 0; - - #-> sub CPAN::Shell::AUTOLOAD ; - sub AUTOLOAD { ## no critic - $autoload_recursion++; - my($l) = $AUTOLOAD; - my $class = shift(@_); - # warn "autoload[$l] class[$class]"; - $l =~ s/.*:://; - if ($CPAN::Signal) { - warn "Refusing to autoload '$l' while signal pending"; - $autoload_recursion--; - return; - } - if ($autoload_recursion > 1) { - my $fullcommand = join " ", map { "'$_'" } $l, @_; - warn "Refusing to autoload $fullcommand in recursion\n"; - $autoload_recursion--; - return; - } - if ($l =~ /^w/) { - # XXX needs to be reconsidered - if ($CPAN::META->has_inst('CPAN::WAIT')) { - CPAN::WAIT->$l(@_); - } else { - $CPAN::Frontend->mywarn(qq{ -Commands starting with "w" require CPAN::WAIT to be installed. -Please consider installing CPAN::WAIT to use the fulltext index. -For this you just need to type - install CPAN::WAIT -}); - } - } else { - $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }. - qq{Type ? for help. -}); - } - $autoload_recursion--; - } -} - - -#-> sub CPAN::Shell::h ; -sub h { - my($class,$about) = @_; - if (defined $about) { - my $help; - if (exists $Help->{$about}) { - if (ref $Help->{$about}) { # aliases - $about = ${$Help->{$about}}; - } - $help = $Help->{$about}; - } else { - $help = "No help available"; - } - $CPAN::Frontend->myprint("$about\: $help\n"); - } else { - my $filler = " " x (80 - 28 - length($CPAN::VERSION)); - $CPAN::Frontend->myprint(qq{ -Display Information $filler (ver $CPAN::VERSION) - command argument description - a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules - i WORD or /REGEXP/ about any of the above - ls AUTHOR or GLOB about files in the author's directory - (with WORD being a module, bundle or author name or a distribution - name of the form AUTHOR/DISTRIBUTION) - -Download, Test, Make, Install... - get download clean make clean - make make (implies get) look open subshell in dist directory - test make test (implies make) readme display these README files - install make install (implies test) perldoc display POD documentation - -Upgrade - r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules - upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules - -Pragmas - force CMD try hard to do command fforce CMD try harder - notest CMD skip testing - -Other - h,? display this menu ! perl-code eval a perl command - o conf [opt] set and query options q quit the cpan shell - reload cpan load CPAN.pm again reload index load newer indices - autobundle Snapshot recent latest CPAN uploads}); -} -} - -*help = \&h; - -#-> sub CPAN::Shell::a ; -sub a { - my($self,@arg) = @_; - # authors are always UPPERCASE - for (@arg) { - $_ = uc $_ unless /=/; - } - $CPAN::Frontend->myprint($self->format_result('Author',@arg)); -} - -#-> sub CPAN::Shell::globls ; -sub globls { - my($self,$s,$pragmas) = @_; - # ls is really very different, but we had it once as an ordinary - # command in the Shell (upto rev. 321) and we could not handle - # force well then - my(@accept,@preexpand); - if ($s =~ /[\*\?\/]/) { - if ($CPAN::META->has_inst("Text::Glob")) { - if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) { - my $rau = Text::Glob::glob_to_regex(uc $au); - CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]") - if $CPAN::DEBUG; - push @preexpand, map { $_->id . "/" . $pathglob } - CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/"); - } else { - my $rau = Text::Glob::glob_to_regex(uc $s); - push @preexpand, map { $_->id } - CPAN::Shell->expand_by_method('CPAN::Author', - ['id'], - "/$rau/"); - } - } else { - $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed"); - } - } else { - push @preexpand, uc $s; - } - for (@preexpand) { - unless (/^[A-Z0-9\-]+(\/|$)/i) { - $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n"); - next; - } - push @accept, $_; - } - my $silent = @accept>1; - my $last_alpha = ""; - my @results; - for my $a (@accept) { - my($author,$pathglob); - if ($a =~ m|(.*?)/(.*)|) { - my $a2 = $1; - $pathglob = $2; - $author = CPAN::Shell->expand_by_method('CPAN::Author', - ['id'], - $a2) - or $CPAN::Frontend->mydie("No author found for $a2\n"); - } else { - $author = CPAN::Shell->expand_by_method('CPAN::Author', - ['id'], - $a) - or $CPAN::Frontend->mydie("No author found for $a\n"); - } - if ($silent) { - my $alpha = substr $author->id, 0, 1; - my $ad; - if ($alpha eq $last_alpha) { - $ad = ""; - } else { - $ad = "[$alpha]"; - $last_alpha = $alpha; - } - $CPAN::Frontend->myprint($ad); - } - for my $pragma (@$pragmas) { - if ($author->can($pragma)) { - $author->$pragma(); - } - } - CPAN->debug("author[$author]pathglob[$pathglob]silent[$silent]") if $CPAN::DEBUG; - push @results, $author->ls($pathglob,$silent); # silent if - # more than one - # author - for my $pragma (@$pragmas) { - my $unpragma = "un$pragma"; - if ($author->can($unpragma)) { - $author->$unpragma(); - } - } - } - @results; -} - -#-> sub CPAN::Shell::local_bundles ; -sub local_bundles { - my($self,@which) = @_; - my($incdir,$bdir,$dh); - foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { - my @bbase = "Bundle"; - while (my $bbase = shift @bbase) { - $bdir = File::Spec->catdir($incdir,split /::/, $bbase); - CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG; - if ($dh = DirHandle->new($bdir)) { # may fail - my($entry); - for $entry ($dh->read) { - next if $entry =~ /^\./; - next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/; - if (-d File::Spec->catdir($bdir,$entry)) { - push @bbase, "$bbase\::$entry"; - } else { - next unless $entry =~ s/\.pm(?!\n)\Z//; - $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry"); - } - } - } - } - } -} - -#-> sub CPAN::Shell::b ; -sub b { - my($self,@which) = @_; - CPAN->debug("which[@which]") if $CPAN::DEBUG; - $self->local_bundles; - $CPAN::Frontend->myprint($self->format_result('Bundle',@which)); -} - -#-> sub CPAN::Shell::d ; -sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));} - -#-> sub CPAN::Shell::m ; -sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here - my $self = shift; - $CPAN::Frontend->myprint($self->format_result('Module',@_)); -} - -#-> sub CPAN::Shell::i ; -sub i { - my($self) = shift; - my(@args) = @_; - @args = '/./' unless @args; - my(@result); - for my $type (qw/Bundle Distribution Module/) { - push @result, $self->expand($type,@args); - } - # Authors are always uppercase. - push @result, $self->expand("Author", map { uc $_ } @args); - - my $result = @result == 1 ? - $result[0]->as_string : - @result == 0 ? - "No objects found of any type for argument @args\n" : - join("", - (map {$_->as_glimpse} @result), - scalar @result, " items found\n", - ); - $CPAN::Frontend->myprint($result); -} - -#-> sub CPAN::Shell::o ; - -# CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o -# conf' calls through to CPAN::HandleConfig::edit. 'o conf' should -# probably have been called 'set' and 'o debug' maybe 'set debug' or -# 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm -sub o { - my($self,$o_type,@o_what) = @_; - $o_type ||= ""; - CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n"); - if ($o_type eq 'conf') { - my($cfilter); - ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what; - if (!@o_what or $cfilter) { # print all things, "o conf" - $cfilter ||= ""; - my $qrfilter = eval 'qr/$cfilter/'; - my($k,$v); - $CPAN::Frontend->myprint("\$CPAN::Config options from "); - my @from; - if (exists $INC{'CPAN/Config.pm'}) { - push @from, $INC{'CPAN/Config.pm'}; - } - if (exists $INC{'CPAN/MyConfig.pm'}) { - push @from, $INC{'CPAN/MyConfig.pm'}; - } - $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from); - $CPAN::Frontend->myprint(":\n"); - for $k (sort keys %CPAN::HandleConfig::can) { - next unless $k =~ /$qrfilter/; - $v = $CPAN::HandleConfig::can{$k}; - $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v); - } - $CPAN::Frontend->myprint("\n"); - for $k (sort keys %CPAN::HandleConfig::keys) { - next unless $k =~ /$qrfilter/; - CPAN::HandleConfig->prettyprint($k); - } - $CPAN::Frontend->myprint("\n"); - } else { - if (CPAN::HandleConfig->edit(@o_what)) { - } else { - $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }. - qq{items\n\n}); - } - } - } elsif ($o_type eq 'debug') { - my(%valid); - @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i; - if (@o_what) { - while (@o_what) { - my($what) = shift @o_what; - if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) { - $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what}; - next; - } - if ( exists $CPAN::DEBUG{$what} ) { - $CPAN::DEBUG |= $CPAN::DEBUG{$what}; - } elsif ($what =~ /^\d/) { - $CPAN::DEBUG = $what; - } elsif (lc $what eq 'all') { - my($max) = 0; - for (values %CPAN::DEBUG) { - $max += $_; - } - $CPAN::DEBUG = $max; - } else { - my($known) = 0; - for (keys %CPAN::DEBUG) { - next unless lc($_) eq lc($what); - $CPAN::DEBUG |= $CPAN::DEBUG{$_}; - $known = 1; - } - $CPAN::Frontend->myprint("unknown argument [$what]\n") - unless $known; - } - } - } else { - my $raw = "Valid options for debug are ". - join(", ",sort(keys %CPAN::DEBUG), 'all'). - qq{ or a number. Completion works on the options. }. - qq{Case is ignored.}; - require Text::Wrap; - $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw)); - $CPAN::Frontend->myprint("\n\n"); - } - if ($CPAN::DEBUG) { - $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n"); - my($k,$v); - for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) { - $v = $CPAN::DEBUG{$k}; - $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) - if $v & $CPAN::DEBUG; - } - } else { - $CPAN::Frontend->myprint("Debugging turned off completely.\n"); - } - } else { - $CPAN::Frontend->myprint(qq{ -Known options: - conf set or get configuration variables - debug set or get debugging options -}); - } -} - -# CPAN::Shell::paintdots_onreload -sub paintdots_onreload { - my($ref) = shift; - sub { - if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) { - my($subr) = $1; - ++$$ref; - local($|) = 1; - # $CPAN::Frontend->myprint(".($subr)"); - $CPAN::Frontend->myprint("."); - if ($subr =~ /\bshell\b/i) { - # warn "debug[$_[0]]"; - - # It would be nice if we could detect that a - # subroutine has actually changed, but for now we - # practically always set the GOTOSHELL global - - $CPAN::GOTOSHELL=1; - } - return; - } - warn @_; - }; -} - -#-> sub CPAN::Shell::hosts ; -sub hosts { - my($self) = @_; - my $fullstats = CPAN::FTP->_ftp_statistics(); - my $history = $fullstats->{history} || []; - my %S; # statistics - while (my $last = pop @$history) { - my $attempts = $last->{attempts} or next; - my $start; - if (@$attempts) { - $start = $attempts->[-1]{start}; - if ($#$attempts > 0) { - for my $i (0..$#$attempts-1) { - my $url = $attempts->[$i]{url} or next; - $S{no}{$url}++; - } - } - } else { - $start = $last->{start}; - } - next unless $last->{thesiteurl}; # C-C? bad filenames? - $S{start} = $start; - $S{end} ||= $last->{end}; - my $dltime = $last->{end} - $start; - my $dlsize = $last->{filesize} || 0; - my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl}; - my $s = $S{ok}{$url} ||= {}; - $s->{n}++; - $s->{dlsize} ||= 0; - $s->{dlsize} += $dlsize/1024; - $s->{dltime} ||= 0; - $s->{dltime} += $dltime; - } - my $res; - for my $url (keys %{$S{ok}}) { - next if $S{ok}{$url}{dltime} == 0; # div by zero - push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)}, - $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime}, - $url, - ]; - } - for my $url (keys %{$S{no}}) { - push @{$res->{no}}, [$S{no}{$url}, - $url, - ]; - } - my $R = ""; # report - if ($S{start} && $S{end}) { - $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown"; - $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown"; - } - if ($res->{ok} && @{$res->{ok}}) { - $R .= sprintf "\nSuccessful downloads: - N kB secs kB/s url\n"; - my $i = 20; - for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) { - $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_; - last if --$i<=0; - } - } - if ($res->{no} && @{$res->{no}}) { - $R .= sprintf "\nUnsuccessful downloads:\n"; - my $i = 20; - for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) { - $R .= sprintf "%4d %s\n", @$_; - last if --$i<=0; - } - } - $CPAN::Frontend->myprint($R); -} - -# here is where 'reload cpan' is done -#-> sub CPAN::Shell::reload ; -sub reload { - my($self,$command,@arg) = @_; - $command ||= ""; - $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG; - if ($command =~ /^cpan$/i) { - my $redef = 0; - chdir $CPAN::iCwd if $CPAN::iCwd; # may fail - my $failed; - MFILE: for my $f (@relo) { - next unless exists $INC{$f}; - my $p = $f; - $p =~ s/\.pm$//; - $p =~ s|/|::|g; - $CPAN::Frontend->myprint("($p"); - local($SIG{__WARN__}) = paintdots_onreload(\$redef); - $self->_reload_this($f) or $failed++; - my $v = eval "$p\::->VERSION"; - $CPAN::Frontend->myprint("v$v)"); - } - $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); - if ($failed) { - my $errors = $failed == 1 ? "error" : "errors"; - $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ". - "this session.\n"); - } - } elsif ($command =~ /^index$/i) { - CPAN::Index->force_reload; - } else { - $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules -index re-reads the index files\n}); - } -} - -# reload means only load again what we have loaded before -#-> sub CPAN::Shell::_reload_this ; -sub _reload_this { - my($self,$f,$args) = @_; - CPAN->debug("f[$f]") if $CPAN::DEBUG; - return 1 unless $INC{$f}; # we never loaded this, so we do not - # reload but say OK - my $pwd = CPAN::anycwd(); - CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG; - my($file); - for my $inc (@INC) { - $file = File::Spec->catfile($inc,split /\//, $f); - last if -f $file; - $file = ""; - } - CPAN->debug("file[$file]") if $CPAN::DEBUG; - my @inc = @INC; - unless ($file && -f $file) { - # this thingie is not in the INC path, maybe CPAN/MyConfig.pm? - $file = $INC{$f}; - unless (CPAN->has_inst("File::Basename")) { - @inc = File::Basename::dirname($file); - } else { - # do we ever need this? - @inc = substr($file,0,-length($f)-1); # bring in back to me! - } - } - CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG; - unless (-f $file) { - $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n"); - return; - } - my $mtime = (stat $file)[9]; - $reload->{$f} ||= -1; - my $must_reload = $mtime != $reload->{$f}; - $args ||= {}; - $must_reload ||= $args->{reloforce}; # o conf defaults needs this - if ($must_reload) { - my $fh = FileHandle->new($file) or - $CPAN::Frontend->mydie("Could not open $file: $!"); - local($/); - local $^W = 1; - my $content = <$fh>; - CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128))) - if $CPAN::DEBUG; - delete $INC{$f}; - local @INC = @inc; - eval "require '$f'"; - if ($@) { - warn $@; - return; - } - $reload->{$f} = $mtime; - } else { - $CPAN::Frontend->myprint("__unchanged__"); - } - return 1; -} - -#-> sub CPAN::Shell::mkmyconfig ; -sub mkmyconfig { - my($self, $cpanpm, %args) = @_; - require CPAN::FirstTime; - my $home = CPAN::HandleConfig::home(); - $cpanpm = $INC{'CPAN/MyConfig.pm'} || - File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm"); - File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm; - CPAN::HandleConfig::require_myconfig_or_config(); - $CPAN::Config ||= {}; - $CPAN::Config = { - %$CPAN::Config, - build_dir => undef, - cpan_home => undef, - keep_source_where => undef, - histfile => undef, - }; - CPAN::FirstTime::init($cpanpm, %args); -} - -#-> sub CPAN::Shell::_binary_extensions ; -sub _binary_extensions { - my($self) = shift @_; - my(@result,$module,%seen,%need,$headerdone); - for $module ($self->expand('Module','/./')) { - my $file = $module->cpan_file; - next if $file eq "N/A"; - next if $file =~ /^Contact Author/; - my $dist = $CPAN::META->instance('CPAN::Distribution',$file); - next if $dist->isa_perl; - next unless $module->xs_file; - local($|) = 1; - $CPAN::Frontend->myprint("."); - push @result, $module; - } -# print join " | ", @result; - $CPAN::Frontend->myprint("\n"); - return @result; -} - -#-> sub CPAN::Shell::recompile ; -sub recompile { - my($self) = shift @_; - my($module,@module,$cpan_file,%dist); - @module = $self->_binary_extensions(); - for $module (@module) { # we force now and compile later, so we - # don't do it twice - $cpan_file = $module->cpan_file; - my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); - $pack->force; - $dist{$cpan_file}++; - } - for $cpan_file (sort keys %dist) { - $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n"); - my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); - $pack->install; - $CPAN::Signal = 0; # it's tempting to reset Signal, so we can - # stop a package from recompiling, - # e.g. IO-1.12 when we have perl5.003_10 - } -} - -#-> sub CPAN::Shell::scripts ; -sub scripts { - my($self, $arg) = @_; - $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n"); - - for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) { - unless ($CPAN::META->has_inst($req)) { - $CPAN::Frontend->mywarn(" $req not available\n"); - } - } - my $p = HTML::LinkExtor->new(); - my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html"; - unless (-f $indexfile) { - $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n"); - } - $p->parse_file($indexfile); - my @hrefs; - my $qrarg; - if ($arg =~ s|^/(.+)/$|$1|) { - $qrarg = eval 'qr/$arg/'; # hide construct from 5.004 - } - for my $l ($p->links) { - my $tag = shift @$l; - next unless $tag eq "a"; - my %att = @$l; - my $href = $att{href}; - next unless $href =~ s|^\.\./authors/id/./../||; - if ($arg) { - if ($qrarg) { - if ($href =~ $qrarg) { - push @hrefs, $href; - } - } else { - if ($href =~ /\Q$arg\E/) { - push @hrefs, $href; - } - } - } else { - push @hrefs, $href; - } - } - # now filter for the latest version if there is more than one of a name - my %stems; - for (sort @hrefs) { - my $href = $_; - s/-v?\d.*//; - my $stem = $_; - $stems{$stem} ||= []; - push @{$stems{$stem}}, $href; - } - for (sort keys %stems) { - my $highest; - if (@{$stems{$_}} > 1) { - $highest = List::Util::reduce { - Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b - } @{$stems{$_}}; - } else { - $highest = $stems{$_}[0]; - } - $CPAN::Frontend->myprint("$highest\n"); - } -} - -#-> sub CPAN::Shell::report ; -sub report { - my($self,@args) = @_; - unless ($CPAN::META->has_inst("CPAN::Reporter")) { - $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue"); - } - local $CPAN::Config->{test_report} = 1; - $self->force("test",@args); # force is there so that the test be - # re-run (as documented) -} - -# compare with is_tested -#-> sub CPAN::Shell::install_tested -sub install_tested { - my($self,@some) = @_; - $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"), - return if @some; - CPAN::Index->reload; - - for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) { - my $yaml = "$b.yml"; - unless (-f $yaml) { - $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n"); - next; - } - my $yaml_content = CPAN->_yaml_loadfile($yaml); - my $id = $yaml_content->[0]{distribution}{ID}; - unless ($id) { - $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n"); - next; - } - my $do = CPAN::Shell->expandany($id); - unless ($do) { - $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n"); - next; - } - unless ($do->{build_dir}) { - $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n"); - next; - } - unless ($do->{build_dir} eq $b) { - $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n"); - next; - } - push @some, $do; - } - - $CPAN::Frontend->mywarn("No tested distributions found.\n"), - return unless @some; - - @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some; - $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"), - return unless @some; - - # @some = grep { not $_->uptodate } @some; - # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"), - # return unless @some; - - CPAN->debug("some[@some]"); - for my $d (@some) { - my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id; - $CPAN::Frontend->myprint("install_tested: Running for $id\n"); - $CPAN::Frontend->mysleep(1); - $self->install($d); - } -} - -#-> sub CPAN::Shell::upgrade ; -sub upgrade { - my($self,@args) = @_; - $self->install($self->r(@args)); -} - -#-> sub CPAN::Shell::_u_r_common ; -sub _u_r_common { - my($self) = shift @_; - my($what) = shift @_; - CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG; - Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless - $what && $what =~ /^[aru]$/; - my(@args) = @_; - @args = '/./' unless @args; - my(@result,$module,%seen,%need,$headerdone, - $version_undefs,$version_zeroes, - @version_undefs,@version_zeroes); - $version_undefs = $version_zeroes = 0; - my $sprintf = "%s%-25s%s %9s %9s %s\n"; - my @expand = $self->expand('Module',@args); - if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging - # for metadata cache - my $expand = scalar @expand; - $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time); - } - my @sexpand; - if ($] < 5.008) { - # hard to believe that the more complex sorting can lead to - # stack curruptions on older perl - @sexpand = sort {$a->id cmp $b->id} @expand; - } else { - @sexpand = map { - $_->[1] - } sort { - $b->[0] <=> $a->[0] - || - $a->[1]{ID} cmp $b->[1]{ID}, - } map { - [$_->_is_representative_module, - $_ - ] - } @expand; - } - if ($CPAN::DEBUG) { - $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time); - sleep 1; - } - MODULE: for $module (@sexpand) { - my $file = $module->cpan_file; - next MODULE unless defined $file; # ?? - $file =~ s!^./../!!; - my($latest) = $module->cpan_version; - my($inst_file) = $module->inst_file; - CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG; - my($have); - return if $CPAN::Signal; - my($next_MODULE); - eval { # version.pm involved! - if ($inst_file) { - if ($what eq "a") { - $have = $module->inst_version; - } elsif ($what eq "r") { - $have = $module->inst_version; - local($^W) = 0; - if ($have eq "undef") { - $version_undefs++; - push @version_undefs, $module->as_glimpse; - } elsif (CPAN::Version->vcmp($have,0)==0) { - $version_zeroes++; - push @version_zeroes, $module->as_glimpse; - } - ++$next_MODULE unless CPAN::Version->vgt($latest, $have); - # to be pedantic we should probably say: - # && !($have eq "undef" && $latest ne "undef" && $latest gt ""); - # to catch the case where CPAN has a version 0 and we have a version undef - } elsif ($what eq "u") { - ++$next_MODULE; - } - } else { - if ($what eq "a") { - ++$next_MODULE; - } elsif ($what eq "r") { - ++$next_MODULE; - } elsif ($what eq "u") { - $have = "-"; - } - } - }; - next MODULE if $next_MODULE; - if ($@) { - $CPAN::Frontend->mywarn - (sprintf("Error while comparing cpan/installed versions of '%s': -INST_FILE: %s -INST_VERSION: %s %s -CPAN_VERSION: %s %s -", - $module->id, - $inst_file || "", - (defined $have ? $have : "[UNDEFINED]"), - (ref $have ? ref $have : ""), - $latest, - (ref $latest ? ref $latest : ""), - )); - next MODULE; - } - return if $CPAN::Signal; # this is sometimes lengthy - $seen{$file} ||= 0; - if ($what eq "a") { - push @result, sprintf "%s %s\n", $module->id, $have; - } elsif ($what eq "r") { - push @result, $module->id; - next MODULE if $seen{$file}++; - } elsif ($what eq "u") { - push @result, $module->id; - next MODULE if $seen{$file}++; - next MODULE if $file =~ /^Contact/; - } - unless ($headerdone++) { - $CPAN::Frontend->myprint("\n"); - $CPAN::Frontend->myprint(sprintf( - $sprintf, - "", - "Package namespace", - "", - "installed", - "latest", - "in CPAN file" - )); - } - my $color_on = ""; - my $color_off = ""; - if ( - $COLOR_REGISTERED - && - $CPAN::META->has_inst("Term::ANSIColor") - && - $module->description - ) { - $color_on = Term::ANSIColor::color("green"); - $color_off = Term::ANSIColor::color("reset"); - } - $CPAN::Frontend->myprint(sprintf $sprintf, - $color_on, - $module->id, - $color_off, - $have, - $latest, - $file); - $need{$module->id}++; - } - unless (%need) { - if ($what eq "u") { - $CPAN::Frontend->myprint("No modules found for @args\n"); - } elsif ($what eq "r") { - $CPAN::Frontend->myprint("All modules are up to date for @args\n"); - } - } - if ($what eq "r") { - if ($version_zeroes) { - my $s_has = $version_zeroes > 1 ? "s have" : " has"; - $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }. - qq{a version number of 0\n}); - if ($CPAN::Config->{show_zero_versions}) { - local $" = "\t"; - $CPAN::Frontend->myprint(qq{ they are\n\t@version_zeroes\n}); - $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }. - qq{to hide them)\n}); - } else { - $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }. - qq{to show them)\n}); - } - } - if ($version_undefs) { - my $s_has = $version_undefs > 1 ? "s have" : " has"; - $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }. - qq{parsable version number\n}); - if ($CPAN::Config->{show_unparsable_versions}) { - local $" = "\t"; - $CPAN::Frontend->myprint(qq{ they are\n\t@version_undefs\n}); - $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }. - qq{to hide them)\n}); - } else { - $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }. - qq{to show them)\n}); - } - } - } - @result; -} - -#-> sub CPAN::Shell::r ; -sub r { - shift->_u_r_common("r",@_); -} - -#-> sub CPAN::Shell::u ; -sub u { - shift->_u_r_common("u",@_); -} - -#-> sub CPAN::Shell::failed ; -sub failed { - my($self,$only_id,$silent) = @_; - my @failed; - DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) { - my $failed = ""; - NAY: for my $nosayer ( # order matters! - "unwrapped", - "writemakefile", - "signature_verify", - "make", - "make_test", - "install", - "make_clean", - ) { - next unless exists $d->{$nosayer}; - next unless defined $d->{$nosayer}; - next unless ( - UNIVERSAL::can($d->{$nosayer},"failed") ? - $d->{$nosayer}->failed : - $d->{$nosayer} =~ /^NO/ - ); - next NAY if $only_id && $only_id != ( - UNIVERSAL::can($d->{$nosayer},"commandid") - ? - $d->{$nosayer}->commandid - : - $CPAN::CurrentCommandId - ); - $failed = $nosayer; - last; - } - next DIST unless $failed; - my $id = $d->id; - $id =~ s|^./../||; - #$print .= sprintf( - # " %-45s: %s %s\n", - push @failed, - ( - UNIVERSAL::can($d->{$failed},"failed") ? - [ - $d->{$failed}->commandid, - $id, - $failed, - $d->{$failed}->text, - $d->{$failed}{TIME}||0, - ] : - [ - 1, - $id, - $failed, - $d->{$failed}, - 0, - ] - ); - } - my $scope; - if ($only_id) { - $scope = "this command"; - } elsif ($CPAN::Index::HAVE_REANIMATED) { - $scope = "this or a previous session"; - # it might be nice to have a section for previous session and - # a second for this - } else { - $scope = "this session"; - } - if (@failed) { - my $print; - my $debug = 0; - if ($debug) { - $print = join "", - map { sprintf "%5d %-45s: %s %s\n", @$_ } - sort { $a->[0] <=> $b->[0] } @failed; - } else { - $print = join "", - map { sprintf " %-45s: %s %s\n", @$_[1..3] } - sort { - $a->[0] <=> $b->[0] - || - $a->[4] <=> $b->[4] - } @failed; - } - $CPAN::Frontend->myprint("Failed during $scope:\n$print"); - } elsif (!$only_id || !$silent) { - $CPAN::Frontend->myprint("Nothing failed in $scope\n"); - } -} - -# XXX intentionally undocumented because completely bogus, unportable, -# useless, etc. - -#-> sub CPAN::Shell::status ; -sub status { - my($self) = @_; - require Devel::Size; - my $ps = FileHandle->new; - open $ps, "/proc/$$/status"; - my $vm = 0; - while (<$ps>) { - next unless /VmSize:\s+(\d+)/; - $vm = $1; - last; - } - $CPAN::Frontend->mywarn(sprintf( - "%-27s %6d\n%-27s %6d\n", - "vm", - $vm, - "CPAN::META", - Devel::Size::total_size($CPAN::META)/1024, - )); - for my $k (sort keys %$CPAN::META) { - next unless substr($k,0,4) eq "read"; - warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024; - for my $k2 (sort keys %{$CPAN::META->{$k}}) { - warn sprintf " %-25s %6d (keys: %6d)\n", - $k2, - Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024, - scalar keys %{$CPAN::META->{$k}{$k2}}; - } - } -} - -# compare with install_tested -#-> sub CPAN::Shell::is_tested -sub is_tested { - my($self) = @_; - CPAN::Index->reload; - for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) { - my $time; - if ($CPAN::META->{is_tested}{$b}) { - $time = scalar(localtime $CPAN::META->{is_tested}{$b}); - } else { - $time = scalar localtime; - $time =~ s/\S/?/g; - } - $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b); - } -} - -#-> sub CPAN::Shell::autobundle ; -sub autobundle { - my($self) = shift; - CPAN::HandleConfig->load unless $CPAN::Config_loaded++; - my(@bundle) = $self->_u_r_common("a",@_); - my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle"); - File::Path::mkpath($todir); - unless (-d $todir) { - $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n"); - return; - } - my($y,$m,$d) = (localtime)[5,4,3]; - $y+=1900; - $m++; - my($c) = 0; - my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c; - my($to) = File::Spec->catfile($todir,"$me.pm"); - while (-f $to) { - $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c; - $to = File::Spec->catfile($todir,"$me.pm"); - } - my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!"; - $fh->print( - "package Bundle::$me;\n\n", - "\$VERSION = '0.01';\n\n", - "1;\n\n", - "__END__\n\n", - "=head1 NAME\n\n", - "Bundle::$me - Snapshot of installation on ", - $Config::Config{'myhostname'}, - " on ", - scalar(localtime), - "\n\n=head1 SYNOPSIS\n\n", - "perl -MCPAN -e 'install Bundle::$me'\n\n", - "=head1 CONTENTS\n\n", - join("\n", @bundle), - "\n\n=head1 CONFIGURATION\n\n", - Config->myconfig, - "\n\n=head1 AUTHOR\n\n", - "This Bundle has been generated automatically ", - "by the autobundle routine in CPAN.pm.\n", - ); - $fh->close; - $CPAN::Frontend->myprint("\nWrote bundle file - $to\n\n"); -} - -#-> sub CPAN::Shell::expandany ; -sub expandany { - my($self,$s) = @_; - CPAN->debug("s[$s]") if $CPAN::DEBUG; - if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory - $s = CPAN::Distribution->normalize($s); - return $CPAN::META->instance('CPAN::Distribution',$s); - # Distributions spring into existence, not expand - } elsif ($s =~ m|^Bundle::|) { - $self->local_bundles; # scanning so late for bundles seems - # both attractive and crumpy: always - # current state but easy to forget - # somewhere - return $self->expand('Bundle',$s); - } else { - return $self->expand('Module',$s) - if $CPAN::META->exists('CPAN::Module',$s); - } - return; -} - -#-> sub CPAN::Shell::expand ; -sub expand { - my $self = shift; - my($type,@args) = @_; - CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG; - my $class = "CPAN::$type"; - my $methods = ['id']; - for my $meth (qw(name)) { - next unless $class->can($meth); - push @$methods, $meth; - } - $self->expand_by_method($class,$methods,@args); -} - -#-> sub CPAN::Shell::expand_by_method ; -sub expand_by_method { - my $self = shift; - my($class,$methods,@args) = @_; - my($arg,@m); - for $arg (@args) { - my($regex,$command); - if ($arg =~ m|^/(.*)/$|) { - $regex = $1; -# FIXME: there seem to be some ='s in the author data, which trigger -# a failure here. This needs to be contemplated. -# } elsif ($arg =~ m/=/) { -# $command = 1; - } - my $obj; - CPAN->debug(sprintf "class[%s]regex[%s]command[%s]", - $class, - defined $regex ? $regex : "UNDEFINED", - defined $command ? $command : "UNDEFINED", - ) if $CPAN::DEBUG; - if (defined $regex) { - if (CPAN::_sqlite_running()) { - CPAN::Index->reload; - $CPAN::SQLite->search($class, $regex); - } - for $obj ( - $CPAN::META->all_objects($class) - ) { - unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) { - # BUG, we got an empty object somewhere - require Data::Dumper; - CPAN->debug(sprintf( - "Bug in CPAN: Empty id on obj[%s][%s]", - $obj, - Data::Dumper::Dumper($obj) - )) if $CPAN::DEBUG; - next; - } - for my $method (@$methods) { - my $match = eval {$obj->$method() =~ /$regex/i}; - if ($@) { - my($err) = $@ =~ /^(.+) at .+? line \d+\.$/; - $err ||= $@; # if we were too restrictive above - $CPAN::Frontend->mydie("$err\n"); - } elsif ($match) { - push @m, $obj; - last; - } - } - } - } elsif ($command) { - die "equal sign in command disabled (immature interface), ". - "you can set - ! \$CPAN::Shell::ADVANCED_QUERY=1 -to enable it. But please note, this is HIGHLY EXPERIMENTAL code -that may go away anytime.\n" - unless $ADVANCED_QUERY; - my($method,$criterion) = $arg =~ /(.+?)=(.+)/; - my($matchcrit) = $criterion =~ m/^~(.+)/; - for my $self ( - sort - {$a->id cmp $b->id} - $CPAN::META->all_objects($class) - ) { - my $lhs = $self->$method() or next; # () for 5.00503 - if ($matchcrit) { - push @m, $self if $lhs =~ m/$matchcrit/; - } else { - push @m, $self if $lhs eq $criterion; - } - } - } else { - my($xarg) = $arg; - if ( $class eq 'CPAN::Bundle' ) { - $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/; - } elsif ($class eq "CPAN::Distribution") { - $xarg = CPAN::Distribution->normalize($arg); - } else { - $xarg =~ s/:+/::/g; - } - if ($CPAN::META->exists($class,$xarg)) { - $obj = $CPAN::META->instance($class,$xarg); - } elsif ($CPAN::META->exists($class,$arg)) { - $obj = $CPAN::META->instance($class,$arg); - } else { - next; - } - push @m, $obj; - } - } - @m = sort {$a->id cmp $b->id} @m; - if ( $CPAN::DEBUG ) { - my $wantarray = wantarray; - my $join_m = join ",", map {$_->id} @m; - # $self->debug("wantarray[$wantarray]join_m[$join_m]"); - my $count = scalar @m; - $self->debug("class[$class]wantarray[$wantarray]count m[$count]"); - } - return wantarray ? @m : $m[0]; -} - -#-> sub CPAN::Shell::format_result ; -sub format_result { - my($self) = shift; - my($type,@args) = @_; - @args = '/./' unless @args; - my(@result) = $self->expand($type,@args); - my $result = @result == 1 ? - $result[0]->as_string : - @result == 0 ? - "No objects of type $type found for argument @args\n" : - join("", - (map {$_->as_glimpse} @result), - scalar @result, " items found\n", - ); - $result; -} - -#-> sub CPAN::Shell::report_fh ; -{ - my $installation_report_fh; - my $previously_noticed = 0; - - sub report_fh { - return $installation_report_fh if $installation_report_fh; - if ($CPAN::META->has_usable("File::Temp")) { - $installation_report_fh - = File::Temp->new( - dir => File::Spec->tmpdir, - template => 'cpan_install_XXXX', - suffix => '.txt', - unlink => 0, - ); - } - unless ( $installation_report_fh ) { - warn("Couldn't open installation report file; " . - "no report file will be generated." - ) unless $previously_noticed++; - } - } -} - - -# The only reason for this method is currently to have a reliable -# debugging utility that reveals which output is going through which -# channel. No, I don't like the colors ;-) - -# to turn colordebugging on, write -# cpan> o conf colorize_output 1 - -#-> sub CPAN::Shell::colorize_output ; -{ - my $print_ornamented_have_warned = 0; - sub colorize_output { - my $colorize_output = $CPAN::Config->{colorize_output}; - if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) { - unless ($print_ornamented_have_warned++) { - # no myprint/mywarn within myprint/mywarn! - warn "Colorize_output is set to true but Term::ANSIColor is not -installed. To activate colorized output, please install Term::ANSIColor.\n\n"; - } - $colorize_output = 0; - } - return $colorize_output; - } -} - - -#-> sub CPAN::Shell::print_ornamented ; -sub print_ornamented { - my($self,$what,$ornament) = @_; - return unless defined $what; - - local $| = 1; # Flush immediately - if ( $CPAN::Be_Silent ) { - print {report_fh()} $what; - return; - } - my $swhat = "$what"; # stringify if it is an object - if ($CPAN::Config->{term_is_latin}) { - # note: deprecated, need to switch to $LANG and $LC_* - # courtesy jhi: - $swhat - =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #}; - } - if ($self->colorize_output) { - if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) { - # if you want to have this configurable, please file a bugreport - $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan"; - } - my $color_on = eval { Term::ANSIColor::color($ornament) } || ""; - if ($@) { - print "Term::ANSIColor rejects color[$ornament]: $@\n -Please choose a different color (Hint: try 'o conf init /color/')\n"; - } - # GGOLDBACH/Test-GreaterVersion-0.008 broke without this - # $trailer construct. We want the newline be the last thing if - # there is a newline at the end ensuring that the next line is - # empty for other players - my $trailer = ""; - $trailer = $1 if $swhat =~ s/([\r\n]+)\z//; - print $color_on, - $swhat, - Term::ANSIColor::color("reset"), - $trailer; - } else { - print $swhat; - } -} - -#-> sub CPAN::Shell::myprint ; - -# where is myprint/mywarn/Frontend/etc. documented? Where to use what? -# I think, we send everything to STDOUT and use print for normal/good -# news and warn for news that need more attention. Yes, this is our -# working contract for now. -sub myprint { - my($self,$what) = @_; - $self->print_ornamented($what, - $CPAN::Config->{colorize_print}||'bold blue on_white', - ); -} - -sub optprint { - my($self,$category,$what) = @_; - my $vname = $category . "_verbosity"; - CPAN::HandleConfig->load unless $CPAN::Config_loaded++; - if (!$CPAN::Config->{$vname} - || $CPAN::Config->{$vname} =~ /^v/ - ) { - $CPAN::Frontend->myprint($what); - } -} - -#-> sub CPAN::Shell::myexit ; -sub myexit { - my($self,$what) = @_; - $self->myprint($what); - exit; -} - -#-> sub CPAN::Shell::mywarn ; -sub mywarn { - my($self,$what) = @_; - $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white'); -} - -# only to be used for shell commands -#-> sub CPAN::Shell::mydie ; -sub mydie { - my($self,$what) = @_; - $self->mywarn($what); - - # If it is the shell, we want the following die to be silent, - # but if it is not the shell, we would need a 'die $what'. We need - # to take care that only shell commands use mydie. Is this - # possible? - - die "\n"; -} - -# sub CPAN::Shell::colorable_makemaker_prompt ; -sub colorable_makemaker_prompt { - my($foo,$bar) = @_; - if (CPAN::Shell->colorize_output) { - my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white'; - my $color_on = eval { Term::ANSIColor::color($ornament); } || ""; - print $color_on; - } - my $ans = ExtUtils::MakeMaker::prompt($foo,$bar); - if (CPAN::Shell->colorize_output) { - print Term::ANSIColor::color('reset'); - } - return $ans; -} - -# use this only for unrecoverable errors! -#-> sub CPAN::Shell::unrecoverable_error ; -sub unrecoverable_error { - my($self,$what) = @_; - my @lines = split /\n/, $what; - my $longest = 0; - for my $l (@lines) { - $longest = length $l if length $l > $longest; - } - $longest = 62 if $longest > 62; - for my $l (@lines) { - if ($l =~ /^\s*$/) { - $l = "\n"; - next; - } - $l = "==> $l"; - if (length $l < 66) { - $l = pack "A66 A*", $l, "<=="; - } - $l .= "\n"; - } - unshift @lines, "\n"; - $self->mydie(join "", @lines); -} - -#-> sub CPAN::Shell::mysleep ; -sub mysleep { - my($self, $sleep) = @_; - if (CPAN->has_inst("Time::HiRes")) { - Time::HiRes::sleep($sleep); - } else { - sleep($sleep < 1 ? 1 : int($sleep + 0.5)); - } -} - -#-> sub CPAN::Shell::setup_output ; -sub setup_output { - return if -t STDOUT; - my $odef = select STDERR; - $| = 1; - select STDOUT; - $| = 1; - select $odef; -} - -#-> sub CPAN::Shell::rematein ; -# RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here -sub rematein { - my $self = shift; - my($meth,@some) = @_; - my @pragma; - while($meth =~ /^(ff?orce|notest)$/) { - push @pragma, $meth; - $meth = shift @some or - $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ". - "cannot continue"); - } - setup_output(); - CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG; - - # Here is the place to set "test_count" on all involved parties to - # 0. We then can pass this counter on to the involved - # distributions and those can refuse to test if test_count > X. In - # the first stab at it we could use a 1 for "X". - - # But when do I reset the distributions to start with 0 again? - # Jost suggested to have a random or cycling interaction ID that - # we pass through. But the ID is something that is just left lying - # around in addition to the counter, so I'd prefer to set the - # counter to 0 now, and repeat at the end of the loop. But what - # about dependencies? They appear later and are not reset, they - # enter the queue but not its copy. How do they get a sensible - # test_count? - - # With configure_requires, "get" is vulnerable in recursion. - - my $needs_recursion_protection = "get|make|test|install"; - - # construct the queue - my($s,@s,@qcopy); - STHING: foreach $s (@some) { - my $obj; - if (ref $s) { - CPAN->debug("s is an object[$s]") if $CPAN::DEBUG; - $obj = $s; - } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable - } elsif ($s =~ m|^/|) { # looks like a regexp - if (substr($s,-1,1) eq ".") { - $obj = CPAN::Shell->expandany($s); - } else { - $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ". - "not supported.\nRejecting argument '$s'\n"); - $CPAN::Frontend->mysleep(2); - next; - } - } elsif ($meth eq "ls") { - $self->globls($s,\@pragma); - next STHING; - } else { - CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG; - $obj = CPAN::Shell->expandany($s); - } - if (0) { - } elsif (ref $obj) { - if ($meth =~ /^($needs_recursion_protection)$/) { - # it would be silly to check for recursion for look or dump - # (we are in CPAN::Shell::rematein) - CPAN->debug("Going to test against recursion") if $CPAN::DEBUG; - eval { $obj->color_cmd_tmps(0,1); }; - if ($@) { - if (ref $@ - and $@->isa("CPAN::Exception::RecursiveDependency")) { - $CPAN::Frontend->mywarn($@); - } else { - if (0) { - require Carp; - Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@); - } - die; - } - } - } - CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c"); - push @qcopy, $obj; - } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) { - $obj = $CPAN::META->instance('CPAN::Author',uc($s)); - if ($meth =~ /^(dump|ls|reports)$/) { - $obj->$meth(); - } else { - $CPAN::Frontend->mywarn( - join "", - "Don't be silly, you can't $meth ", - $obj->fullname, - " ;-)\n" - ); - $CPAN::Frontend->mysleep(2); - } - } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") { - CPAN::InfoObj->dump($s); - } else { - $CPAN::Frontend - ->mywarn(qq{Warning: Cannot $meth $s, }. - qq{don't know what it is. -Try the command - - i /$s/ - -to find objects with matching identifiers. -}); - $CPAN::Frontend->mysleep(2); - } - } - - # queuerunner (please be warned: when I started to change the - # queue to hold objects instead of names, I made one or two - # mistakes and never found which. I reverted back instead) - QITEM: while (my $q = CPAN::Queue->first) { - my $obj; - my $s = $q->as_string; - my $reqtype = $q->reqtype || ""; - $obj = CPAN::Shell->expandany($s); - unless ($obj) { - # don't know how this can happen, maybe we should panic, - # but maybe we get a solution from the first user who hits - # this unfortunate exception? - $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ". - "to an object. Skipping.\n"); - $CPAN::Frontend->mysleep(5); - CPAN::Queue->delete_first($s); - next QITEM; - } - $obj->{reqtype} ||= ""; - { - # force debugging because CPAN::SQLite somehow delivers us - # an empty object; - - # local $CPAN::DEBUG = 1024; # Shell; probably fixed now - - CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]". - "q-reqtype[$reqtype]") if $CPAN::DEBUG; - } - if ($obj->{reqtype}) { - if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) { - $obj->{reqtype} = $reqtype; - if ( - exists $obj->{install} - && - ( - UNIVERSAL::can($obj->{install},"failed") ? - $obj->{install}->failed : - $obj->{install} =~ /^NO/ - ) - ) { - delete $obj->{install}; - $CPAN::Frontend->mywarn - ("Promoting $obj->{ID} from 'build_requires' to 'requires'"); - } - } - } else { - $obj->{reqtype} = $reqtype; - } - - for my $pragma (@pragma) { - if ($pragma - && - $obj->can($pragma)) { - $obj->$pragma($meth); - } - } - if (UNIVERSAL::can($obj, 'called_for')) { - $obj->called_for($s); - } - CPAN->debug(qq{pragma[@pragma]meth[$meth]}. - qq{ID[$obj->{ID}]}) if $CPAN::DEBUG; - - push @qcopy, $obj; - if ($meth =~ /^(report)$/) { # they came here with a pragma? - $self->$meth($obj); - } elsif (! UNIVERSAL::can($obj,$meth)) { - # Must never happen - my $serialized = ""; - if (0) { - } elsif ($CPAN::META->has_inst("YAML::Syck")) { - $serialized = YAML::Syck::Dump($obj); - } elsif ($CPAN::META->has_inst("YAML")) { - $serialized = YAML::Dump($obj); - } elsif ($CPAN::META->has_inst("Data::Dumper")) { - $serialized = Data::Dumper::Dumper($obj); - } else { - require overload; - $serialized = overload::StrVal($obj); - } - CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG; - $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]"); - } elsif ($obj->$meth()) { - CPAN::Queue->delete($s); - CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG; - } else { - CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG; - } - - $obj->undelay; - for my $pragma (@pragma) { - my $unpragma = "un$pragma"; - if ($obj->can($unpragma)) { - $obj->$unpragma(); - } - } - if ($CPAN::Config->{halt_on_failure} - && - CPAN::Distrostatus::something_has_just_failed() - ) { - $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n"); - CPAN::Queue->nullify_queue; - last QITEM; - } - CPAN::Queue->delete_first($s); - } - if ($meth =~ /^($needs_recursion_protection)$/) { - for my $obj (@qcopy) { - $obj->color_cmd_tmps(0,0); - } - } -} - -#-> sub CPAN::Shell::recent ; -sub recent { - my($self) = @_; - if ($CPAN::META->has_inst("XML::LibXML")) { - my $url = $CPAN::Defaultrecent; - $CPAN::Frontend->myprint("Going to fetch '$url'\n"); - unless ($CPAN::META->has_usable("LWP")) { - $CPAN::Frontend->mydie("LWP not installed; cannot continue"); - } - CPAN::LWP::UserAgent->config; - my $Ua; - eval { $Ua = CPAN::LWP::UserAgent->new; }; - if ($@) { - $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n"); - } - my $resp = $Ua->get($url); - unless ($resp->is_success) { - $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code); - } - $CPAN::Frontend->myprint("DONE\n\n"); - my $xml = XML::LibXML->new->parse_string($resp->content); - if (0) { - my $s = $xml->serialize(2); - $s =~ s/\n\s*\n/\n/g; - $CPAN::Frontend->myprint($s); - return; - } - my @distros; - if ($url =~ /winnipeg/) { - my $pubdate = $xml->findvalue("/rss/channel/pubDate"); - $CPAN::Frontend->myprint(" pubDate: $pubdate\n\n"); - for my $eitem ($xml->findnodes("/rss/channel/item")) { - my $distro = $eitem->findvalue("enclosure/\@url"); - $distro =~ s|.*?/authors/id/./../||; - my $size = $eitem->findvalue("enclosure/\@length"); - my $desc = $eitem->findvalue("description"); - $desc =~ s/.+? - //; - $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n"); - push @distros, $distro; - } - } elsif ($url =~ /search.*uploads.rdf/) { - # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" - # xmlns="http://purl.org/rss/1.0/" - # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/" - # xmlns:dc="http://purl.org/dc/elements/1.1/" - # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/" - # xmlns:admin="http://webns.net/mvcb/" - - - my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']"); - $CPAN::Frontend->myprint(" dc:date: $dc_date\n\n"); - my $finish_eitem = 0; - local $SIG{INT} = sub { $finish_eitem = 1 }; - EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) { - my $distro = $eitem->findvalue("\@rdf:about"); - $distro =~ s|.*~||; # remove up to the tilde before the name - $distro =~ s|/$||; # remove trailing slash - $distro =~ s|([^/]+)|\U$1\E|; # upcase the name - my $author = uc $1 or die "distro[$distro] without author, cannot continue"; - my $desc = $eitem->findvalue("*[local-name(.) = 'description']"); - my $i = 0; - SUBDIRTEST: while () { - last SUBDIRTEST if ++$i >= 6; # half a dozen must do! - if (my @ret = $self->globls("$distro*")) { - @ret = grep {$_->[2] !~ /meta/} @ret; - @ret = grep {length $_->[2]} @ret; - if (@ret) { - $distro = "$author/$ret[0][2]"; - last SUBDIRTEST; - } - } - $distro =~ s|/|/*/|; # allow it to reside in a subdirectory - } - - next EITEM if $distro =~ m|\*|; # did not find the thing - $CPAN::Frontend->myprint("____$desc\n"); - push @distros, $distro; - last EITEM if $finish_eitem; - } - } - return \@distros; - } else { - # deprecated old version - $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n"); - } -} - -#-> sub CPAN::Shell::smoke ; -sub smoke { - my($self) = @_; - my $distros = $self->recent; - DISTRO: for my $distro (@$distros) { - next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles - $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n"); - { - my $skip = 0; - local $SIG{INT} = sub { $skip = 1 }; - for (0..9) { - $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_); - sleep 1; - if ($skip) { - $CPAN::Frontend->myprint(" skipped\n"); - next DISTRO; - } - } - } - $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline - $self->test($distro); - } -} - -{ - # set up the dispatching methods - no strict "refs"; - for my $command (qw( - clean - cvs_import - dump - force - fforce - get - install - look - ls - make - notest - perldoc - readme - reports - test - )) { - *$command = sub { shift->rematein($command, @_); }; - } -} - -1; diff --git a/lib/CPAN/Tarzip.pm b/lib/CPAN/Tarzip.pm deleted file mode 100644 index 17b3cd748d..0000000000 --- a/lib/CPAN/Tarzip.pm +++ /dev/null @@ -1,404 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -package CPAN::Tarzip; -use strict; -use vars qw($VERSION @ISA $BUGHUNTING); -use CPAN::Debug; -use File::Basename qw(basename); -$VERSION = "5.501"; -# module is internal to CPAN.pm - -@ISA = qw(CPAN::Debug); ## no critic -$BUGHUNTING ||= 0; # released code must have turned off - -# it's ok if file doesn't exist, it just matters if it is .gz or .bz2 -sub new { - my($class,$file) = @_; - $CPAN::Frontend->mydie("CPAN::Tarzip->new called without arg") unless defined $file; - if (0) { - # nonono, we get e.g. 01mailrc.txt uncompressed if only wget is available - $CPAN::Frontend->mydie("file[$file] doesn't match /\\.(bz2|gz|zip|tgz)\$/") - unless $file =~ /\.(bz2|gz|zip|tgz)$/i; - } - my $me = { FILE => $file }; - if (0) { - } elsif ($file =~ /\.bz2$/i) { - unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) { - my $bzip2 = _my_which("bzip2"); - if ($bzip2) { - $me->{UNGZIPPRG} = $bzip2; - } else { - $CPAN::Frontend->mydie(qq{ -CPAN.pm needs the external program bzip2 in order to handle '$file'. -Please install it now and run 'o conf init' to register it as external -program. -}); - } - } - } else { - $me->{UNGZIPPRG} = _my_which("gzip"); - } - $me->{TARPRG} = _my_which("tar") || _my_which("gtar"); - bless $me, $class; -} - -sub _my_which { - my($what) = @_; - if ($CPAN::Config->{$what}) { - return $CPAN::Config->{$what}; - } - if ($CPAN::META->has_inst("File::Which")) { - return File::Which::which($what); - } - my @cand = MM->maybe_command($what); - return $cand[0] if @cand; - require File::Spec; - my $component; - PATH_COMPONENT: foreach $component (File::Spec->path()) { - next unless defined($component) && $component; - my($abs) = File::Spec->catfile($component,$what); - if (MM->maybe_command($abs)) { - return $abs; - } - } - return; -} - -sub gzip { - my($self,$read) = @_; - my $write = $self->{FILE}; - if ($CPAN::META->has_inst("Compress::Zlib")) { - my($buffer,$fhw); - $fhw = FileHandle->new($read) - or $CPAN::Frontend->mydie("Could not open $read: $!"); - my $cwd = `pwd`; - my $gz = Compress::Zlib::gzopen($write, "wb") - or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n"); - $gz->gzwrite($buffer) - while read($fhw,$buffer,4096) > 0 ; - $gz->gzclose() ; - $fhw->close; - return 1; - } else { - my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG}); - system(qq{$command -c "$read" > "$write"})==0; - } -} - - -sub gunzip { - my($self,$write) = @_; - my $read = $self->{FILE}; - if ($CPAN::META->has_inst("Compress::Zlib")) { - my($buffer,$fhw); - $fhw = FileHandle->new(">$write") - or $CPAN::Frontend->mydie("Could not open >$write: $!"); - my $gz = Compress::Zlib::gzopen($read, "rb") - or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n"); - $fhw->print($buffer) - while $gz->gzread($buffer) > 0 ; - $CPAN::Frontend->mydie("Error reading from $read: $!\n") - if $gz->gzerror != Compress::Zlib::Z_STREAM_END(); - $gz->gzclose() ; - $fhw->close; - return 1; - } else { - my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG}); - system(qq{$command -dc "$read" > "$write"})==0; - } -} - - -sub gtest { - my($self) = @_; - return $self->{GTEST} if exists $self->{GTEST}; - defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified"); - my $read = $self->{FILE}; - my $success; - # After I had reread the documentation in zlib.h, I discovered that - # uncompressed files do not lead to an gzerror (anymore?). - if ( $CPAN::META->has_inst("Compress::Zlib") ) { - my($buffer,$len); - $len = 0; - my $gz = Compress::Zlib::gzopen($read, "rb") - or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n", - $read, - $Compress::Zlib::gzerrno)); - while ($gz->gzread($buffer) > 0 ) { - $len += length($buffer); - $buffer = ""; - } - my $err = $gz->gzerror; - $success = ! $err || $err == Compress::Zlib::Z_STREAM_END(); - if ($len == -s $read) { - $success = 0; - CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG; - } - $gz->gzclose(); - CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG; - } else { - my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG}); - $success = 0==system(qq{$command -qdt "$read"}); - } - return $self->{GTEST} = $success; -} - - -sub TIEHANDLE { - my($class,$file) = @_; - my $ret; - $class->debug("file[$file]"); - my $self = $class->new($file); - if (0) { - } elsif (!$self->gtest) { - my $fh = FileHandle->new($file) - or $CPAN::Frontend->mydie("Could not open file[$file]: $!"); - binmode $fh; - $self->{FH} = $fh; - $class->debug("via uncompressed FH"); - } elsif ($CPAN::META->has_inst("Compress::Zlib")) { - my $gz = Compress::Zlib::gzopen($file,"rb") or - $CPAN::Frontend->mydie("Could not gzopen $file"); - $self->{GZ} = $gz; - $class->debug("via Compress::Zlib"); - } else { - my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG}); - my $pipe = "$gzip -dc $file |"; - my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!"); - binmode $fh; - $self->{FH} = $fh; - $class->debug("via external gzip"); - } - $self; -} - - -sub READLINE { - my($self) = @_; - if (exists $self->{GZ}) { - my $gz = $self->{GZ}; - my($line,$bytesread); - $bytesread = $gz->gzreadline($line); - return undef if $bytesread <= 0; - return $line; - } else { - my $fh = $self->{FH}; - return scalar <$fh>; - } -} - - -sub READ { - my($self,$ref,$length,$offset) = @_; - $CPAN::Frontend->mydie("read with offset not implemented") if defined $offset; - if (exists $self->{GZ}) { - my $gz = $self->{GZ}; - my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8 - return $byteread; - } else { - my $fh = $self->{FH}; - return read($fh,$$ref,$length); - } -} - - -sub DESTROY { - my($self) = @_; - if (exists $self->{GZ}) { - my $gz = $self->{GZ}; - $gz->gzclose() if defined $gz; # hard to say if it is allowed - # to be undef ever. AK, 2000-09 - } else { - my $fh = $self->{FH}; - $fh->close if defined $fh; - } - undef $self; -} - -sub untar { - my($self) = @_; - my $file = $self->{FILE}; - my($prefer) = 0; - - my $exttar = $self->{TARPRG} || ""; - $exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it - my $extgzip = $self->{UNGZIPPRG} || ""; - $extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it - if (0) { # makes changing order easier - } elsif ($BUGHUNTING) { - $prefer=2; - } elsif ($exttar && $extgzip && $file =~ /\.bz2$/i) { - # until Archive::Tar handles bzip2 - $prefer = 1; - } elsif ( - $CPAN::META->has_usable("Archive::Tar") - && - $CPAN::META->has_inst("Compress::Zlib") ) { - $prefer = 2; - } elsif ($exttar && $extgzip) { - # no modules and not bz2 - $prefer = 1; - } else { - my $foundtar = $exttar ? "'$exttar'" : "nothing"; - my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing"; - my $foundAT; - if ($CPAN::META->has_usable("Archive::Tar")) { - $foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION; - } else { - $foundAT = "nothing"; - } - my $foundCZ; - if ($CPAN::META->has_inst("Compress::Zlib")) { - $foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION; - } elsif ($foundAT) { - $foundCZ = "nothing"; - } else { - $foundCZ = "also nothing"; - } - $CPAN::Frontend->mydie(qq{ - -CPAN.pm needs either the external programs tar and gzip -or- both -modules Archive::Tar and Compress::Zlib installed. - -For tar I found $foundtar, for gzip $foundzip. - -For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ; - -Can't continue cutting file '$file'. -}); - } - my $tar_verb = "v"; - if (defined $CPAN::Config->{tar_verbosity}) { - $tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" : - $CPAN::Config->{tar_verbosity}; - } - if ($prefer==1) { # 1 => external gzip+tar - my($system); - my $is_compressed = $self->gtest(); - my $tarcommand = CPAN::HandleConfig->safe_quote($exttar); - if ($is_compressed) { - my $command = CPAN::HandleConfig->safe_quote($extgzip); - $system = qq{$command -dc }. - qq{< "$file" | $tarcommand x${tar_verb}f -}; - } else { - $system = qq{$tarcommand x${tar_verb}f "$file"}; - } - if (system($system) != 0) { - # people find the most curious tar binaries that cannot handle - # pipes - if ($is_compressed) { - (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//; - $ungzf = basename $ungzf; - my $ct = CPAN::Tarzip->new($file); - if ($ct->gunzip($ungzf)) { - $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); - } else { - $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n}); - } - $file = $ungzf; - } - $system = qq{$tarcommand x${tar_verb}f "$file"}; - $CPAN::Frontend->myprint(qq{Using Tar:$system:\n}); - if (system($system)==0) { - $CPAN::Frontend->myprint(qq{Untarred $file successfully\n}); - } else { - $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n}); - } - return 1; - } else { - return 1; - } - } elsif ($prefer==2) { # 2 => modules - unless ($CPAN::META->has_usable("Archive::Tar")) { - $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue"); - } - # Make sure AT does not use uid/gid/permissions in the archive - # This leaves it to the user's umask instead - local $Archive::Tar::CHMOD = 1; - local $Archive::Tar::SAME_PERMISSIONS = 0; - # Make sure AT leaves current user as owner - local $Archive::Tar::CHOWN = 0; - my $tar = Archive::Tar->new($file,1); - my $af; # archive file - my @af; - if ($BUGHUNTING) { - # RCS 1.337 had this code, it turned out unacceptable slow but - # it revealed a bug in Archive::Tar. Code is only here to hunt - # the bug again. It should never be enabled in published code. - # GDGraph3d-0.53 was an interesting case according to Larry - # Virden. - warn(">>>Bughunting code enabled<<< " x 20); - for $af ($tar->list_files) { - if ($af =~ m!^(/|\.\./)!) { - $CPAN::Frontend->mydie("ALERT: Archive contains ". - "illegal member [$af]"); - } - $CPAN::Frontend->myprint("$af\n"); - $tar->extract($af); # slow but effective for finding the bug - return if $CPAN::Signal; - } - } else { - for $af ($tar->list_files) { - if ($af =~ m!^(/|\.\./)!) { - $CPAN::Frontend->mydie("ALERT: Archive contains ". - "illegal member [$af]"); - } - if ($tar_verb eq "v" || $tar_verb eq "vv") { - $CPAN::Frontend->myprint("$af\n"); - } - push @af, $af; - return if $CPAN::Signal; - } - $tar->extract(@af) or - $CPAN::Frontend->mydie("Could not untar with Archive::Tar."); - } - - Mac::BuildTools::convert_files([$tar->list_files], 1) - if ($^O eq 'MacOS'); - - return 1; - } -} - -sub unzip { - my($self) = @_; - my $file = $self->{FILE}; - if ($CPAN::META->has_inst("Archive::Zip")) { - # blueprint of the code from Archive::Zip::Tree::extractTree(); - my $zip = Archive::Zip->new(); - my $status; - $status = $zip->read($file); - $CPAN::Frontend->mydie("Read of file[$file] failed\n") - if $status != Archive::Zip::AZ_OK(); - $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG; - my @members = $zip->members(); - for my $member ( @members ) { - my $af = $member->fileName(); - if ($af =~ m!^(/|\.\./)!) { - $CPAN::Frontend->mydie("ALERT: Archive contains ". - "illegal member [$af]"); - } - $status = $member->extractToFileNamed( $af ); - $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG; - $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if - $status != Archive::Zip::AZ_OK(); - return if $CPAN::Signal; - } - return 1; - } else { - my $unzip = $CPAN::Config->{unzip} or - $CPAN::Frontend->mydie("Cannot unzip, no unzip program available"); - my @system = ($unzip, $file); - return system(@system) == 0; - } -} - -1; - -__END__ - -=head1 LICENSE - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/lib/CPAN/URL.pm b/lib/CPAN/URL.pm deleted file mode 100644 index 52b42eec88..0000000000 --- a/lib/CPAN/URL.pm +++ /dev/null @@ -1,31 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- -# vim: ts=4 sts=4 sw=4: -package CPAN::URL; -use overload '""' => "as_string", fallback => 1; -# accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist), -# planned are things like age or quality - -use vars qw( - $VERSION -); -$VERSION = "5.5"; - -sub new { - my($class,%args) = @_; - bless { - %args - }, $class; -} -sub as_string { - my($self) = @_; - $self->text; -} -sub text { - my($self,$set) = @_; - if (defined $set) { - $self->{TEXT} = $set; - } - $self->{TEXT}; -} - -1; diff --git a/lib/CPAN/Version.pm b/lib/CPAN/Version.pm deleted file mode 100644 index da876aac2d..0000000000 --- a/lib/CPAN/Version.pm +++ /dev/null @@ -1,173 +0,0 @@ -package CPAN::Version; - -use strict; -use vars qw($VERSION); -$VERSION = "5.5"; - -# CPAN::Version::vcmp courtesy Jost Krieger -sub vcmp { - my($self,$l,$r) = @_; - local($^W) = 0; - CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG; - - return 0 if $l eq $r; # short circuit for quicker success - - for ($l,$r) { - s/_//g; - } - CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG; - for ($l,$r) { - next unless tr/.// > 1 || /^v/; - s/^v?/v/; - 1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group - } - CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG; - if ($l=~/^v/ <=> $r=~/^v/) { - for ($l,$r) { - next if /^v/; - $_ = $self->float2vv($_); - } - } - CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG; - my $lvstring = "v0"; - my $rvstring = "v0"; - if ($] >= 5.006 - && $l =~ /^v/ - && $r =~ /^v/) { - $lvstring = $self->vstring($l); - $rvstring = $self->vstring($r); - CPAN->debug(sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring) if $CPAN::DEBUG; - } - - return ( - ($l ne "undef") <=> ($r ne "undef") - || - $lvstring cmp $rvstring - || - $l <=> $r - || - $l cmp $r - ); -} - -sub vgt { - my($self,$l,$r) = @_; - $self->vcmp($l,$r) > 0; -} - -sub vlt { - my($self,$l,$r) = @_; - 0 + ($self->vcmp($l,$r) < 0); -} - -sub vge { - my($self,$l,$r) = @_; - $self->vcmp($l,$r) >= 0; -} - -sub vle { - my($self,$l,$r) = @_; - 0 + ($self->vcmp($l,$r) <= 0); -} - -sub vstring { - my($self,$n) = @_; - $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]"; - pack "U*", split /\./, $n; -} - -# vv => visible vstring -sub float2vv { - my($self,$n) = @_; - my($rev) = int($n); - $rev ||= 0; - my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit - # architecture influence - $mantissa ||= 0; - $mantissa .= "0" while length($mantissa)%3; - my $ret = "v" . $rev; - while ($mantissa) { - $mantissa =~ s/(\d{1,3})// or - die "Panic: length>0 but not a digit? mantissa[$mantissa]"; - $ret .= ".".int($1); - } - # warn "n[$n]ret[$ret]"; - $ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0 - $ret; -} - -sub readable { - my($self,$n) = @_; - $n =~ /^([\w\-\+\.]+)/; - - return $1 if defined $1 && length($1)>0; - # if the first user reaches version v43, he will be treated as "+". - # We'll have to decide about a new rule here then, depending on what - # will be the prevailing versioning behavior then. - - if ($] < 5.006) { # or whenever v-strings were introduced - # we get them wrong anyway, whatever we do, because 5.005 will - # have already interpreted 0.2.4 to be "0.24". So even if he - # indexer sends us something like "v0.2.4" we compare wrongly. - - # And if they say v1.2, then the old perl takes it as "v12" - - if (defined $CPAN::Frontend) { - $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n"); - } else { - warn("Suspicious version string seen [$n]\n"); - } - return $n; - } - my $better = sprintf "v%vd", $n; - CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG; - return $better; -} - -1; - -__END__ - -=head1 NAME - -CPAN::Version - utility functions to compare CPAN versions - -=head1 SYNOPSIS - - use CPAN::Version; - - CPAN::Version->vgt("1.1","1.1.1"); # 1 bc. 1.1 > 1.001001 - - CPAN::Version->vlt("1.1","1.1"); # 0 bc. 1.1 not < 1.1 - - CPAN::Version->vcmp("1.1","1.1.1"); # 1 bc. first is larger - - CPAN::Version->vcmp("1.1.1","1.1"); # -1 bc. first is smaller - - CPAN::Version->readable(v1.2.3); # "v1.2.3" - - CPAN::Version->vstring("v1.2.3"); # v1.2.3 - - CPAN::Version->float2vv(1.002003); # "v1.2.3" - -=head1 DESCRIPTION - -This module mediates between some version that perl sees in a package -and the version that is published by the CPAN indexer. - -It's only written as a helper module for both CPAN.pm and CPANPLUS.pm. - -As it stands it predates version.pm but has the same goal: make -version strings visible and comparable. - -=head1 LICENSE - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut - -# Local Variables: -# mode: cperl -# cperl-indent-level: 4 -# End: diff --git a/lib/CPAN/bin/cpan b/lib/CPAN/bin/cpan deleted file mode 100644 index d06666e78f..0000000000 --- a/lib/CPAN/bin/cpan +++ /dev/null @@ -1,467 +0,0 @@ -#!/usr/bin/perl -# $Id: cpan,v 1.9 2006/11/01 21:49:31 comdog Exp $ -use strict; - -=head1 NAME - -cpan - easily interact with CPAN from the command line - -=head1 SYNOPSIS - - # with arguments and no switches, installs specified modules - cpan module_name [ module_name ... ] - - # with switches, installs modules with extra behavior - cpan [-cfimt] module_name [ module_name ... ] - - # without arguments, starts CPAN.pm shell - cpan - - # without arguments, but some switches - cpan [-ahrvACDLO] - -=head1 DESCRIPTION - -This script provides a command interface (not a shell) to CPAN. At the -moment it uses CPAN.pm to do the work, but it is not a one-shot command -runner for CPAN.pm. - -=head2 Meta Options - -These options are mutually exclusive, and the script processes them in -this order: [hvCAar]. Once the script finds one, it ignores the others, -and then exits after it finishes the task. The script ignores any other -command line options. - -=over 4 - -=item -a - -Creates the CPAN.pm autobundle with CPAN::Shell->autobundle. - -=item -A module [ module ... ] - -Shows the primary maintainers for the specified modules - -=item -C module [ module ... ] - -Show the C<Changes> files for the specified modules - -=item -D module [ module ... ] - -Show the module details. This prints one line for each out-of-date module -(meaning, modules locally installed but have newer versions on CPAN). -Each line has three columns: module name, local version, and CPAN -version. - -=item -L author [ author ... ] - -List the modules by the specified authors. - -=item -h - -Prints a help message. - -=item -O - -Show the out-of-date modules. - -=item -r - -Recompiles dynamically loaded modules with CPAN::Shell->recompile. - -=item -v - -Print the script version and CPAN.pm version. - -=back - -=head2 Module options - -These options are mutually exclusive, and the script processes them in -alphabetical order. It only processes the first one it finds. - -=over 4 - -=item c - -Runs a `make clean` in the specified module's directories. - -=item f - -Forces the specified action, when it normally would have failed. - -=item i - -Installed the specified modules. - -=item m - -Makes the specified modules. - -=item t - -Runs a `make test` on the specified modules. - -=back - -=head2 Examples - - # print a help message - cpan -h - - # print the version numbers - cpan -v - - # create an autobundle - cpan -a - - # recompile modules - cpan -r - - # install modules ( sole -i is optional ) - cpan -i Netscape::Booksmarks Business::ISBN - - # force install modules ( must use -i ) - cpan -fi CGI::Minimal URI - -=head1 TO DO - - -=head1 BUGS - -* none noted - -=head1 SEE ALSO - -Most behaviour, including environment variables and configuration, -comes directly from CPAN.pm. - -=head1 SOURCE AVAILABILITY - -This source is part of a SourceForge project which always has the -latest sources in CVS, as well as all of the previous releases. - - http://sourceforge.net/projects/brian-d-foy/ - -If, for some reason, I disappear from the world, one of the other -members of the project can shepherd this module appropriately. - -=head1 CREDITS - -Japheth Cleaver added the bits to allow a forced install (-f). - -Jim Brandt suggest and provided the initial implementation for the -up-to-date and Changes features. - -Adam Kennedy pointed out that exit() causes problems on Windows -where this script ends up with a .bat extension - -=head1 AUTHOR - -brian d foy, C<< <bdfoy@cpan.org> >> - -=head1 COPYRIGHT - -Copyright (c) 2001-2006, brian d foy, All Rights Reserved. - -You may redistribute this under the same terms as Perl itself. - -=cut - -use CPAN (); -use Getopt::Std; - -my $VERSION = - sprintf "%d.%d", q$Revision: 1.9 $ =~ m/ (\d+) \. (\d+) /xg; - -if( $ARGV[0] eq 'install' ) - { - my @args = @ARGV; - shift @args; - - die <<"HERE"; -It looks like you specified 'install' as an argument to cpan(1). This -script is not the CPAN.pm prompt and doesn't understand the same commands. -In fact, doesn't require the extra typing. You probably just want to -list the modules you want to install: - - cpan @args - -See the documentation for more details on using this script. -HERE - } - -if( 0 == @ARGV ) { CPAN::shell(); exit 0 } - -# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # -# set up the order of options that we layer over CPAN::Shell -my @META_OPTIONS = qw( h v C A D O L a r ); - -# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # -# map switches to method names in CPAN::Shell -my $Default = 'default'; - -my %CPAN_METHODS = ( - $Default => 'install', - 'c' => 'clean', - 'f' => 'force', - 'i' => 'install', - 'm' => 'make', - 't' => 'test', - ); -my @CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS; - -# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # -# map switches to the subroutines in this script, along with other information. -# use this stuff instead of hard-coded indices and values -my %Method_table = ( -# key => [ sub ref, takes args?, exit value, description ] - h => [ \&_print_help, 0, 0, 'Printing help' ], - v => [ \&_print_version, 0, 0, 'Printing version' ], - C => [ \&_show_Changes, 1, 0, 'Showing Changes file' ], - A => [ \&_show_Author, 1, 0, 'Showing Author' ], - D => [ \&_show_Details, 1, 0, 'Showing Details' ], - O => [ \&_show_out_of_date, 0, 0, 'Showing Out of date' ], - L => [ \&_show_author_mods, 1, 0, 'Showing author mods' ], - a => [ \&_create_autobundle, 0, 0, 'Creating autobundle' ], - r => [ \&_recompiling, 0, 0, 'Recompiling' ], - - c => [ \&_default, 1, 0, 'Running `make clean`' ], - f => [ \&_default, 1, 0, 'Installing with force' ], - i => [ \&_default, 1, 0, 'Running `make install`' ], - 'm' => [ \&_default, 1, 0, 'Running `make`' ], - t => [ \&_default, 1, 0, 'Running `make test`' ], - - ); - -my %Method_table_index = ( - code => 0, - takes_args => 1, - exit_value => 2, - description => 3, - ); - -# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # -# finally, do some argument processing -my @option_order = ( @META_OPTIONS, @CPAN_OPTIONS ); - -my %options; -Getopt::Std::getopts( - join( '', @option_order ), \%options ); - -my $option_count = grep { $options{$_} } @option_order; -$option_count -= $options{'f'}; # don't count force - -# if there are no options, set -i (this line fixes RT ticket 16915) -$options{i}++ unless $option_count; - -# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # -# try each of the possible switches until we find one to handle -# print an error message if there are too many switches -# print an error message if there are arguments when there shouldn't be any -foreach my $option ( @option_order ) - { - next unless $options{$option}; - die unless - ref $Method_table{$option}[ $Method_table_index{code} ] eq ref sub {}; - - print "$Method_table{$option}[ $Method_table_index{description} ] " . - "-- ignoring other opitions\n" if $option_count > 1; - print "$Method_table{$option}[ $Method_table_index{description} ] " . - "-- ignoring other arguments\n" - if( @ARGV && ! $Method_table{$option}[ $Method_table_index{takes_args} ] ); - - $Method_table{$option}[ $Method_table_index{code} ]->( \@ARGV ); - - last; - } - -# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # - # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # -# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # - -sub _default - { - my $args = shift; - - my $switch = ''; - - # choose the option that we're going to use - # we'll deal with 'f' (force) later, so skip it - foreach my $option ( @CPAN_OPTIONS ) - { - next if $option eq 'f'; - next unless $options{$option}; - $switch = $option; - last; - } - - # 1. with no switches, but arguments, use the default switch (install) - # 2. with no switches and no args, start the shell - # 3. With a switch but no args, die! These switches need arguments. - if( not $switch and @$args ) { $switch = $Default; } - elsif( not $switch and not @$args ) { CPAN::shell(); return } - elsif( $switch and not @$args ) - { die "Nothing to $CPAN_METHODS{$switch}!\n"; } - - # Get and cheeck the method from CPAN::Shell - my $method = $CPAN_METHODS{$switch}; - die "CPAN.pm cannot $method!\n" unless CPAN::Shell->can( $method ); - - # call the CPAN::Shell method, with force if specified - foreach my $arg ( @$args ) - { - if( $options{f} ) { CPAN::Shell->force( $method, $arg ) } - else { CPAN::Shell->$method( $arg ) } - } - } - -# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # -sub _print_help - { - print STDERR "Use perldoc to read the documentation\n"; - exec "perldoc $0"; - } - -sub _print_version - { - print STDERR "$0 script version $VERSION, CPAN.pm version " . - CPAN->VERSION . "\n"; - } - -sub _create_autobundle - { - print "Creating autobundle in ", $CPAN::Config->{cpan_home}, - "/Bundle\n"; - - CPAN::Shell->autobundle; - } - -sub _recompiling - { - print "Recompiling dynamically-loaded extensions\n"; - - CPAN::Shell->recompile; - } - -sub _show_Changes - { - my $args = shift; - - foreach my $arg ( @$args ) - { - print "Checking $arg\n"; - my $module = CPAN::Shell->expand( "Module", $arg ); - - next unless $module->inst_file; - #next if $module->uptodate; - - ( my $id = $module->id() ) =~ s/::/\-/; - - my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" . - $id . "-" . $module->cpan_version() . "/"; - - #print "URL: $url\n"; - _get_changes_file($url); - } - } - -sub _get_changes_file - { - die "Reading Changes files requires LWP::Simple and URI\n" - unless eval { require LWP::Simple; require URI; }; - - my $url = shift; - - my $content = LWP::Simple::get( $url ); - print "Got $url ...\n" if defined $content; - #print $content; - - my( $change_link ) = $content =~ m|<a href="(.*?)">Changes</a>|gi; - - my $changes_url = URI->new_abs( $change_link, $url ); - #print "change link is: $changes_url\n"; - my $changes = LWP::Simple::get( $changes_url ); - #print "change text is: " . $change_link->text() . "\n"; - print $changes; - } - -sub _show_Author - { - my $args = shift; - - foreach my $arg ( @$args ) - { - my $module = CPAN::Shell->expand( "Module", $arg ); - my $author = CPAN::Shell->expand( "Author", $module->userid ); - - next unless $module->userid; - - printf "%-25s %-8s %-25s %s\n", - $arg, $module->userid, $author->email, $author->fullname; - } - } - -sub _show_Details - { - my $args = shift; - - foreach my $arg ( @$args ) - { - my $module = CPAN::Shell->expand( "Module", $arg ); - my $author = CPAN::Shell->expand( "Author", $module->userid ); - - next unless $module->userid; - - print "$arg\n", "-" x 73, "\n\t"; - print join "\n\t", - $module->description ? $module->description : "(no description)", - $module->cpan_file, - $module->inst_file, - 'Installed: ' . $module->inst_version, - 'CPAN: ' . $module->cpan_version . ' ' . - ($module->uptodate ? "" : "Not ") . "up to date", - $author->fullname . " (" . $module->userid . ")", - $author->email; - print "\n\n"; - - } - } - -sub _show_out_of_date - { - my @modules = CPAN::Shell->expand( "Module", "/./" ); - - printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN"; - print "-" x 73, "\n"; - - foreach my $module ( @modules ) - { - next unless $module->inst_file; - next if $module->uptodate; - printf "%-40s %.4f %.4f\n", - $module->id, - $module->inst_version ? $module->inst_version : '', - $module->cpan_version; - } - - } - -sub _show_author_mods - { - my $args = shift; - - my %hash = map { lc $_, 1 } @$args; - - my @modules = CPAN::Shell->expand( "Module", "/./" ); - - foreach my $module ( @modules ) - { - next unless exists $hash{ lc $module->userid }; - print $module->id, "\n"; - } - - } - -1; diff --git a/lib/CPAN/t/01loadme.t b/lib/CPAN/t/01loadme.t deleted file mode 100644 index c22589b656..0000000000 --- a/lib/CPAN/t/01loadme.t +++ /dev/null @@ -1,15 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - print "1..1\n"; -} -use strict; -use CPAN; -use CPAN::FirstTime; - -print "ok 1\n"; - -# Local Variables: -# mode: cperl -# cperl-indent-level: 2 -# End: diff --git a/lib/CPAN/t/02nox.t b/lib/CPAN/t/02nox.t deleted file mode 100644 index 15eae05fa8..0000000000 --- a/lib/CPAN/t/02nox.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./perl - -if (! eval { require Test::More; 1 }) { - printf "1..1\nok 1 # Test::More not available: skipping %s\n", __FILE__; - exit; -} -require Test::More; -Test::More->import(tests => 8); - -# use this first to $CPAN::term can be undefined -use_ok( 'CPAN' ); -$CPAN::Suppress_readline = $CPAN::Suppress_readline; # silence -$CPAN::META = $CPAN::META; # silence -$CPAN::term = $CPAN::term; # silence -undef $CPAN::term; - -# this kicks off all the magic -use_ok( 'CPAN::Nox' ); - -# this will be set if $CPAN::term is undefined -is( $CPAN::Suppress_readline, 1, 'should set suppress readline flag' ); - -# all of these modules have XS components, should be marked unavailable -my $mod; -for $mod (qw( Digest::MD5 LWP Compress::Zlib )) { - is( $CPAN::META->has_inst($mod), 0, "$mod should be marked unavailable" ); -} - -# and these will be set to those in CPAN -is( scalar @CPAN::Nox::EXPORT, scalar @CPAN::EXPORT, 'should export just what CPAN does' ); -is( \&CPAN::Nox::AUTOLOAD, \&CPAN::AUTOLOAD, 'AUTOLOAD should be aliased' ); - -# Local Variables: -# mode: cperl -# cperl-indent-level: 2 -# End: diff --git a/lib/CPAN/t/03pkgs.t b/lib/CPAN/t/03pkgs.t deleted file mode 100644 index 1d877fc4a1..0000000000 --- a/lib/CPAN/t/03pkgs.t +++ /dev/null @@ -1,36 +0,0 @@ -# test if our own version numbers meet expectations - -use strict; -eval 'use warnings'; -use lib "lib"; - -my @m; -if ($ENV{PERL_CORE}){ - @m = ("CPAN", map { "CPAN::$_" } qw(Debug - DeferredCode - Distroprefs - FirstTime - Kwalify - Nox - Queue - Tarzip - Version - )); -} else { - opendir DH, "lib/CPAN" or die; - @m = ("CPAN", map { "CPAN::$_" } grep { s/\.pm$// } readdir DH); -} - -use Test::More; -plan(tests => scalar @m); - -for my $m (@m) { - local $^W = 0; - eval "require $m"; - ok($m->VERSION >= 1.76, sprintf "Found version > 1.76 for %20s: %s", $m, $m->VERSION); -} - -# Local Variables: -# mode: cperl -# cperl-indent-level: 2 -# End: diff --git a/lib/CPAN/t/10version.t b/lib/CPAN/t/10version.t deleted file mode 100644 index c1199e99a7..0000000000 --- a/lib/CPAN/t/10version.t +++ /dev/null @@ -1,129 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; -*- - -use strict; -use CPAN::Version; -use vars qw($D $N); - -# for debugging uncomment the next two lines -# use CPAN; -# $CPAN::DEBUG = 16384; - -while (<DATA>) { - next if tr/.// > 1 && $]<5.006; # multidot tests are not for pre-5.6.0 - last if /^__END__$/; - chomp; - s/\s*#.*//; - push @$D, [ split ]; -} - -$N = scalar @$D; -print "1..$N\n"; - -my $has_sort_versions = eval { require Sort::Versions; 1 }; -my $has_versionpm = eval q{ use version 0.7203; 1 }; -my $has_perl_versionpm = eval { require Perl::Version; 1 }; -while (@$D) { - my($l,$r,$exp) = @{shift @$D}; - my $res = CPAN::Version->vcmp($l,$r); - if ($res != $exp){ - print "# l[$l]r[$r]exp[$exp]res[$res]\n"; - print "not "; - } - my @other = (); - if ($has_sort_versions) { - if (Sort::Versions::versioncmp($l,$r) != $res) { - push @other, sprintf "SV: %d", Sort::Versions::versioncmp($l,$r); - } - } - if ($has_versionpm) { - local $^W; - my $vpack = "version"; # hide the name from 5.004 - my $vres = eval { $vpack->new($l) cmp $vpack->new($r); }; - if ($@) { - push @other, "v.pm: $@"; - } elsif ($vres != $res) { - push @other, sprintf "v.pm: %d", $vres; - } - } - if ($has_perl_versionpm) { - local $^W; - my $vpack = "Perl::Version"; # hide the name from 5.004 - my $vres = eval { $vpack->new($l) cmp $vpack->new($r); }; - if ($@) { - push @other, "PV: $@"; - } elsif ($vres != $res) { - push @other, sprintf "PV: %d", $vres; - } - } - my $other = @other ? " (".join("; ", @other).")" : ""; - printf "ok %2d # %12s %12s %3d%s\n", $N-@$D, $l, $r, $res, $other; - die "Panic" if CPAN::Version->vgt($l,$r) && CPAN::Version->vlt($l,$r); -} - -__END__ -0 0 0 -1 0 1 -0 1 -1 -1 1 0 -1.1 0.0a 1 -1.1a 0.0 1 -1.2.3 1.1.1 1 -v1.2.3 v1.1.1 1 -v1.2.3 v1.2.1 1 -v1.2.3 v1.2.11 -1 -v2.4 2.004000 -1 -v2.4 2.004 0 -1.2.3 1.2.11 -1 -1.9 1.10 1 -VERSION VERSION 0 -0.02 undef 1 -1.57_00 1.57 1 -1.5700 1.57 1 -1.57_01 1.57 1 -1.88_51 1.8801 1 -1.8_8_5_1 1.8801 1 -0.2.10 0.2 -1 -20000000.00 19990108 1 -1.00 0.96 1 -0.7.2 0.7 -1 -0.7.02 0.7 -1 -0.07.02 0.7 -1 -1.3a5 1.3 1 -undef 1.00 -1 -v1.0 undef 1 -v0.2.4 0.24 -1 -v1.0.22 122 -1 -1.0.22 122 -1 -5.00556 v5.5.560 0 -5.005056 v5.5.56 0 -5.00557 v5.5.560 1 -5.00056 v5.0.561 -1 -0.0.2 0.000002 0 -1.0.3 1.000003 0 -1.0.1 1.000001 0 -0.0.1 0.000001 0 -0.01.04 0.001004 0 -0.05.18 0.005018 0 -4.08.00 4.008000 0 -0.001.004 0.001004 0 -0.005.018 0.005018 0 -4.008.000 4.008000 0 -4.008.000 4.008 1 -v4.8 4.008 0 -v4.8.0 4.008000 0 -v1.99.1_1 1.98 -1 -v2.3999 v2.4000 -1 -v2.3999 2.004000 1 -v2.3999 2.999999 1 -v2.1000 2.999999 1 -0123 123 -1 -v2.005 2.005 0 -v1.0 1.0 0 -v1.0 1.000 0 -v1.0 1.000000 0 -__END__ - -# Local Variables: -# mode: cperl -# cperl-indent-level: 2 -# End: diff --git a/lib/CPAN/t/11mirroredby.t b/lib/CPAN/t/11mirroredby.t deleted file mode 100644 index 840dfa3a51..0000000000 --- a/lib/CPAN/t/11mirroredby.t +++ /dev/null @@ -1,29 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - } -} - -use strict; -use lib "BUNDLE"; -use Test::More tests => 6; - -use_ok( 'CPAN::FirstTime' ); -can_ok( 'CPAN::Mirrored::By', 'new', 'continent', 'country', 'url' ); -my $cmb = CPAN::Mirrored::By->new(); -isa_ok( $cmb, 'CPAN::Mirrored::By' ); - -@$cmb = qw( continent country url ); -is( $cmb->continent(), 'continent', - 'continent() should return continent entry' ); -is( $cmb->country(), 'country', 'country() should return country entry' ); -is( $cmb->url(), 'url', 'url() should return url entry' ); - -__END__ -# Local Variables: -# mode: cperl -# cperl-indent-level: 4 -# End: |