eaiovnaovbqoebvqoeavibavo PK uiZw)#99Kwalify/distroprefs.ymlnu[--- 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 PK uiZ< Kwalify/distroprefs.ddnu[$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"}; PK uiZMܪpZpZHandleConfig.pmnu[package CPAN::HandleConfig; use strict; use vars qw(%can %keys $loading $VERSION); use File::Path (); use File::Spec (); use File::Basename (); use Carp (); =head1 NAME CPAN::HandleConfig - internal configuration handling for CPAN.pm =cut $VERSION = "5.5003"; # see also CPAN::Config::VERSION at end of file %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 [git e997b71de88f1019a1472fc13cb97b1b7f96610f] # A2: svn diff -r 985:986 # where andk added yaml_module [git 312b6d9b12b1bdec0b6e282d853482145475021f] # 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_external_tar", "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", "version_timeout", "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); } } # generally, this should be called without arguments so that the currently # loaded config file is where changes are committed. 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, $must_reload); # XXX does anything do this? can it be simplified? -- dagolden, 2011-01-19 if (@args) { if ($args[0] eq "args") { # we have not signed that contract } else { $configpm = $args[0]; } } # use provided name or the current config or create a new MyConfig $configpm ||= require_myconfig_or_config() || make_new_config(); # commit to MyConfig if we can't write to Config if ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm} ) { my $myconfig = _new_config_name(); $CPAN::Frontend->mywarn( "Your $configpm file\n". "is not writable. I will attempt to write your configuration to\n" . "$myconfig instead.\n\n" ); $configpm = make_new_config(); $must_reload++; # so it gets loaded as $INC{'CPAN/MyConfig.pm'} } # XXX why not just "-w $configpm"? -- dagolden, 2011-01-19 my($mode); if (-f $configpm) { $mode = (stat $configpm)[2]; if ($mode && ! -w _) { _die_cant_write_config($configpm); } } $self->_write_config_file($configpm); require_myconfig_or_config() if $must_reload; #$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; } sub _write_config_file { my ($self, $configpm) = @_; my $msg; $msg = <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; return; } # 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 to determine the correct quote. If C 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(do_init => 1, @args); 1; } # Loads CPAN::MyConfig or fall-back to CPAN::Config. Will not reload a file # if already loaded. Returns the path to the file %INC or else the empty string # # Note -- if CPAN::Config were loaded and CPAN::MyConfig subsequently # created, calling this again will leave *both* in %INC sub require_myconfig_or_config () { if ( $INC{"CPAN/MyConfig.pm"} || _try_loading("CPAN::MyConfig", cpan_home())) { return $INC{"CPAN/MyConfig.pm"}; } elsif ( $INC{"CPAN/Config.pm"} || _try_loading("CPAN::Config") ) { return $INC{"CPAN/Config.pm"}; } else { return q{}; } } # Load a module, but ignore "can't locate..." errors # Optionally take a list of directories to add to @INC for the load sub _try_loading { my ($module, @dirs) = @_; (my $file = $module) =~ s{::}{/}g; $file .= ".pm"; local @INC = @INC; for my $dir ( @dirs ) { if ( -f File::Spec->catfile($dir, $file) ) { unshift @INC, $dir; last; } } eval { require $file }; my $err_myconfig = $@; if ($err_myconfig and $err_myconfig !~ m#locate \Q$file\E#) { die "Error while requiring ${module}:\n$err_myconfig"; } return $INC{$file}; } # prioritized list of possible places for finding "CPAN/MyConfig.pm" sub cpan_home_dir_candidates { my @dirs; my $old_v = $CPAN::Config->{load_module_verbosity}; $CPAN::Config->{load_module_verbosity} = q[none]; if ($CPAN::META->has_usable('File::HomeDir')) { if ($^O ne 'darwin') { push @dirs, File::HomeDir->my_data; # my_data is ~/Library/Application Support on darwin, # which causes issues in the toolchain. } push @dirs, File::HomeDir->my_home; } # Windows might not have HOME, so check it first push @dirs, $ENV{HOME} if $ENV{HOME}; # Windows might have these instead push( @dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') ) if $ENV{HOMEDRIVE} && $ENV{HOMEPATH}; push @dirs, $ENV{USERPROFILE} if $ENV{USERPROFILE}; $CPAN::Config->{load_module_verbosity} = $old_v; @dirs = map { "$_/.cpan" } grep { defined } @dirs; return wantarray ? @dirs : $dirs[0]; } sub load { my($self, %args) = @_; $CPAN::Be_Silent+=0; # protect against 'used only once' $CPAN::Be_Silent++ if $args{be_silent}; # do not use; planned to be removed in 2011 my $do_init = delete $args{do_init} || 0; my $make_myconfig = delete $args{make_myconfig}; $loading = 0 unless defined $loading; my $configpm = require_myconfig_or_config; my @miss = $self->missing_config_data; CPAN->debug("do_init[$do_init]loading[$loading]miss[@miss]") if $CPAN::DEBUG; return unless $do_init || @miss; # I'm not how we'd ever wind up in a recursive loop, but I'm leaving # this here for safety's sake -- dagolden, 2011-01-19 return if $loading; local $loading = ($loading||0) + 1; # Warn if we have a config file, but things were found missing if ($configpm && @miss && !$do_init) { if ($make_myconfig || ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm})) { $configpm = make_new_config(); $CPAN::Frontend->myprint(<> END } else { $CPAN::Frontend->myprint(<> END } } require CPAN::FirstTime; return CPAN::FirstTime::init($configpm || make_new_config(), %args); } # Creates a new, empty config file at the preferred location # Any existing will be renamed with a ".bak" suffix if possible # If the file cannot be created, an exception is thrown sub make_new_config { my $configpm = _new_config_name(); my $configpmdir = File::Basename::dirname( $configpm ); File::Path::mkpath($configpmdir) unless -d $configpmdir; if ( -w $configpmdir ) { #_#_# following code dumped core on me with 5.003_11, a.k. if( -f $configpm ) { my $configpm_bak = "$configpm.bak"; unlink $configpm_bak if -f $configpm_bak; if( rename $configpm, $configpm_bak ) { $CPAN::Frontend->mywarn(<new; if ($fh->open(">$configpm")) { $fh->print("1;\n"); return $configpm; } } _die_cant_write_config($configpm); } sub _die_cant_write_config { my ($configpm) = @_; $CPAN::Frontend->mydie(<<"END"); WARNING: CPAN.pm is unable to write a configuration file. You must be able to create and write to '$configpm'. Aborting configuration. END } # From candidate directories, we would like (in descending preference order): # * the one that contains a MyConfig file # * one that exists (even without MyConfig) # * the first one on the list sub cpan_home { my @dirs = cpan_home_dir_candidates(); for my $d (@dirs) { return $d if -f "$d/CPAN/MyConfig.pm"; } for my $d (@dirs) { return $d if -d $d; } return $dirs[0]; } sub _new_config_name { return File::Spec->catfile(cpan_home(), 'CPAN', 'MyConfig.pm'); } # 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 ]); 1; #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.5001"; # 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: # vim: ts=4 sts=4 sw=4: PK uiZH CacheMgr.pmnu[# -*- 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.5001"; 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; } $self->{FIFO} = []; } #-> 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,$phase) = @_; $phase ||= "atstart"; 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 }; $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}") unless $self->{SCAN} =~ /never|atstart|atexit/; File::Path::mkpath($self->{ID}); my $dh = DirHandle->new($self->{ID}); bless $self, $class; $self->scan_cache($phase); $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, $phase) = @_; $phase = '' unless defined $phase; return unless $phase eq $self->{SCAN}; 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; PK uiZך9LLURL.pmnu[# -*- 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; PK uiZ$d d Kwalify.pmnu[=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 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<< >> =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =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 $/; ; }; $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 $/; ; }; return $content; } 1; # Local Variables: # mode: cperl # cperl-indent-level: 4 # End: PK uiZg[cc Complete.pmnu[# -*- 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; PK uiZj8:8: Mirrors.pmnu[# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- # vim: ts=4 sts=4 sw=4: =head1 NAME CPAN::Mirrors - Get CPAN miror information and select a fast one =head1 SYNOPSIS use CPAN::Mirrors; my $mirrors = CPAN::Mirrors->new; $mirrors->parse_from_file( $mirrored_by_file ); my $seen = {}; my $best_continent = $mirrors->find_best_continents( { seen => $seen } ); my @mirrors = $mirrors->get_mirrors_by_continents( $best_continent ); my $callback = sub { my( $m ) = @_; printf "%s = %s\n", $m->hostname, $m->rtt }; $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback ); @mirrors = sort { $a->rtt <=> $b->rtt } @mirrors; print "Best mirrors are ", map( { $_->rtt } @mirrors[0..3] ), "\n"; =head1 DESCRIPTION =over =cut package CPAN::Mirrors; use strict; use vars qw($VERSION $urllist $silent); $VERSION = "1.9600"; use Carp; use FileHandle; use Fcntl ":flock"; use Net::Ping (); =item new( LOCAL_FILE_NAME ) =cut sub new { my ($class, $file) = @_; my $self = bless { mirrors => [], geography => {}, }, $class; if( defined $file ) { $self->parse_mirrored_by( $file ); } return $self } sub parse_mirrored_by { my ($self, $file) = @_; my $handle = FileHandle->new; $handle->open($file) or croak "Couldn't open $file: $!"; flock $handle, LOCK_SH; $self->_parse($file,$handle); flock $handle, LOCK_UN; $handle->close; } =item continents() Return a list of continents based on those defined in F. =cut sub continents { my ($self) = @_; return keys %{$self->{geography}}; } =item countries( [CONTINENTS] ) Return a list of countries based on those defined in F. It only returns countries for the continents you specify (as defined in C). If you don't specify any continents, it returns all of the countries listed in F. =cut sub countries { my ($self, @continents) = @_; @continents = $self->continents unless @continents; my @countries; for my $c (@continents) { push @countries, keys %{ $self->{geography}{$c} }; } return @countries; } =item mirrors( [COUNTRIES] ) Return a list of mirrors based on those defined in F. It only returns mirrors for the countries you specify (as defined in C). If you don't specify any countries, it returns all of the mirrors listed in F. =cut sub mirrors { my ($self, @countries) = @_; return @{$self->{mirrors}} unless @countries; my %wanted = map { $_ => 1 } @countries; my @found; for my $m (@{$self->{mirrors}}) { push @found, $m if exists $wanted{$m->country}; } return @found; } =item get_mirrors_by_countries( [COUNTRIES] ) A more sensible synonym for mirrors. =cut sub get_mirrors_by_countries { &mirrors } =item get_mirrors_by_continents( [CONTINENTS] ) Return a list of mirrors for all of continents you specify. If you don't specify any continents, it returns all of the mirrors. =cut sub get_mirrors_by_continents { my ($self, $continents ) = @_; $self->mirrors( $self->get_countries_by_continents( @$continents ) ); } =item get_countries_by_continents( [CONTINENTS] ) A more sensible synonym for countries. =cut sub get_countries_by_continents { &countries } =item best_mirrors C checks for the best mirrors based on the list of continents you pass, or, without that, all continents, as defined by C. It pings each mirror, up to the value of C. In list context, it returns up to C mirror. In scalar context, it returns the single best mirror. Arguments how_many - the number of mirrors to return. Default: 1 callback - a callback for find_best_continents verbose - true or false on all the whining and moaning. Default: false continents - an array ref of the continents to check If you don't specify the continents, C calls C to get the list of continents to check. =cut sub best_mirrors { my ($self, %args) = @_; my $how_many = $args{how_many} || 1; my $callback = $args{callback}; my $verbose = defined $args{verbose} ? $args{verbose} : 0; my $continents = $args{continents} || []; $continents = [$continents] unless ref $continents; # Old Net::Ping did not do timings at all return "http://www.cpan.org/" unless Net::Ping->VERSION gt '2.13'; my $seen = {}; if ( ! @$continents ) { print "Searching for the best continent ...\n" if $verbose; my @best_continents = $self->find_best_continents( seen => $seen, verbose => $verbose, callback => $callback, ); # Only add enough continents to find enough mirrors my $count = 0; for my $continent ( @best_continents ) { push @$continents, $continent; $count += $self->mirrors( $self->countries($continent) ); last if $count >= $how_many; } } print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose; my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] ); my $timings = $self->get_mirrors_timings( $trial_mirrors, $seen, $callback ); return [] unless @$timings; $how_many = @$timings if $how_many > @$timings; return wantarray ? @{$timings}[0 .. $how_many-1] : $timings->[0]; } =item get_n_random_mirrors_by_continents( N, [CONTINENTS] Returns up to N random mirrors for the specified continents. Specify the continents as an array reference. =cut sub get_n_random_mirrors_by_continents { my( $self, $n, $continents ) = @_; $n ||= 3; $continents = [ $continents ] unless ref $continents; if ( $n <= 0 ) { return wantarray ? () : []; } my @long_list = $self->get_mirrors_by_continents( $continents ); if ( $n eq '*' or $n > @long_list ) { return wantarray ? @long_list : \@long_list; } @long_list = map {$_->[0]} sort {$a->[1] <=> $b->[1]} map {[$_, rand]} @long_list; splice @long_list, $n; # truncate \@long_list; } =item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK ); Pings the listed mirrors and returns a list of mirrors sorted in ascending ping times. =cut sub get_mirrors_timings { my( $self, $mirror_list, $seen, $callback ) = @_; $seen = {} unless defined $seen; croak "The mirror list argument must be an array reference" unless ref $mirror_list eq ref []; croak "The seen argument must be a hash reference" unless ref $seen eq ref {}; croak "callback must be a subroutine" if( defined $callback and ref $callback ne ref sub {} ); my $timings = []; for my $m ( @$mirror_list ) { $seen->{$m->hostname} = $m; next unless eval{ $m->http }; if( $self->_try_a_ping( $seen, $m, ) ) { my $ping = $m->ping; next unless defined $ping; push @$timings, $m; $callback->( $m ) if $callback; } else { push @$timings, $seen->{$m->hostname} if defined $seen->{$m->hostname}->rtt; } } my @best = sort { if( defined $a->rtt and defined $b->rtt ) { $a->rtt <=> $b->rtt } elsif( defined $a->rtt and ! defined $b->rtt ) { return -1; } elsif( ! defined $a->rtt and defined $b->rtt ) { return 1; } elsif( ! defined $a->rtt and ! defined $b->rtt ) { return 0; } } @$timings; return wantarray ? @best : \@best; } =item find_best_continents( HASH_REF ); C goes through each continent and pings C random mirrors on that continent. It then orders the continents by ascending median ping time. In list context, it returns the ordered list of continent. In scalar context, it returns the same list as an anonymous array. Arguments: n - the number of hosts to ping for each continent. Default: 3 seen - a hashref of cached hostname ping times verbose - true or false for noisy or quiet. Default: false callback - a subroutine to run after each ping. ping_cache_limit - how long, in seconds, to reuse previous ping times. Default: 1 day The C hash has hostnames as keys and anonymous arrays as values. The anonymous array is a triplet of a C object, a ping time, and the epoch time for the measurement. The callback subroutine gets the C object, the ping time, and measurement time (the same things in the C hashref) as arguments. C doesn't care what the callback does and ignores the return value. =cut sub find_best_continents { my ($self, %args) = @_; $args{n} ||= 3; $args{verbose} = 0 unless defined $args{verbose}; $args{seen} = {} unless defined $args{seen}; croak "The seen argument must be a hash reference" unless ref $args{seen} eq ref {}; $args{ping_cache_limit} = 24 * 60 * 60 unless defined $args{ping_cache_time}; croak "callback must be a subroutine" if( defined $args{callback} and ref $args{callback} ne ref sub {} ); my %medians; CONT: for my $c ( $self->continents ) { print "Testing $c\n" if $args{verbose}; my @mirrors = $self->mirrors( $self->countries($c) ); next CONT unless @mirrors; my $n = (@mirrors < $args{n}) ? @mirrors : $args{n}; my @tests; my $tries = 0; RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) { my $m = splice( @mirrors, int(rand(@mirrors)), 1 ); if( $self->_try_a_ping( $args{seen}, $m, $args{ping_cache_limit} ) ) { $self->get_mirrors_timings( [ $m ], @args{qw(seen callback)} ); next RANDOM unless defined $args{seen}{$m->hostname}->rtt; } printf "\t%s -> %0.2f ms\n", $m->hostname, join ' ', 1000 * $args{seen}{$m->hostname}->rtt if $args{verbose}; push @tests, $args{seen}{$m->hostname}->rtt; } my $median = $self->_get_median_ping_time( \@tests, $args{verbose} ); $medians{$c} = $median if defined $median; } my @best_cont = sort { $medians{$a} <=> $medians{$b} } keys %medians; if ( $args{verbose} ) { print "Median result by continent:\n"; for my $c ( @best_cont ) { printf( " %4d ms %s\n", int($medians{$c}*1000+.5), $c ); } } return wantarray ? @best_cont : $best_cont[0]; } # retry if sub _try_a_ping { my ($self, $seen, $mirror, $ping_cache_limit ) = @_; ( ! exists $seen->{$mirror->hostname} ) or ( ! defined $seen->{$mirror->hostname}->rtt or time - $seen->{$mirror->hostname}->rtt > $ping_cache_limit ) } sub _get_median_ping_time { my ($self, $tests, $verbose ) = @_; my @sorted = sort { $a <=> $b } @$tests; my $median = do { if ( @sorted == 0 ) { undef } elsif ( @sorted == 1 ) { $sorted[0] } elsif ( @sorted % 2 ) { $sorted[ int(@sorted / 2) ] } else { my $mid_high = int(@sorted/2); ($sorted[$mid_high-1] + $sorted[$mid_high])/2; } }; printf "\t-->median time: %0.2f ms\n", $median * 1000 if $verbose; return $median; } # Adapted from Parse::CPAN::MirroredBy by Adam Kennedy sub _parse { my ($self, $file, $handle) = @_; my $output = $self->{mirrors}; my $geo = $self->{geography}; local $/ = "\012"; my $line = 0; my $mirror = undef; while ( 1 ) { # Next line my $string = <$handle>; last if ! defined $string; $line = $line + 1; # Remove the useless lines chomp( $string ); next if $string =~ /^\s*$/; next if $string =~ /^\s*#/; # Hostname or property? if ( $string =~ /^\s/ ) { # Property unless ( $string =~ /^\s+(\w+)\s+=\s+\"(.*)\"$/ ) { croak("Invalid property on line $line"); } my ($prop, $value) = ($1,$2); $mirror ||= {}; if ( $prop eq 'dst_location' ) { my (@location,$continent,$country); @location = (split /\s*,\s*/, $value) and ($continent, $country) = @location[-1,-2]; $continent =~ s/\s\(.*//; $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude $geo->{$continent}{$country} = 1 if $continent && $country; $mirror->{continent} = $continent || "unknown"; $mirror->{country} = $country || "unknown"; } elsif ( $prop eq 'dst_http' ) { $mirror->{http} = $value; } elsif ( $prop eq 'dst_ftp' ) { $mirror->{ftp} = $value; } elsif ( $prop eq 'dst_rsync' ) { $mirror->{rsync} = $value; } else { $prop =~ s/^dst_//; $mirror->{$prop} = $value; } } else { # Hostname unless ( $string =~ /^([\w\.-]+)\:\s*$/ ) { croak("Invalid host name on line $line"); } my $current = $mirror; $mirror = { hostname => "$1" }; if ( $current ) { push @$output, CPAN::Mirrored::By->new($current); } } } if ( $mirror ) { push @$output, CPAN::Mirrored::By->new($mirror); } return; } #--------------------------------------------------------------------------# package CPAN::Mirrored::By; use strict; use Net::Ping (); sub new { my($self,$arg) = @_; $arg ||= {}; bless $arg, $self; } sub hostname { shift->{hostname} } sub continent { shift->{continent} } sub country { shift->{country} } sub http { shift->{http} || '' } sub ftp { shift->{ftp} || '' } sub rsync { shift->{rsync} || '' } sub rtt { shift->{rtt} } sub ping_time { shift->{ping_time} } sub url { my $self = shift; return $self->{http} || $self->{ftp}; } sub ping { my $self = shift; my $ping = Net::Ping->new("tcp",1); my ($proto) = $self->url =~ m{^([^:]+)}; my $port = $proto eq 'http' ? 80 : 21; return unless $port; if ( $ping->can('port_number') ) { $ping->port_number($port); } else { $ping->{'port_num'} = $port; } $ping->hires(1) if $ping->can('hires'); my ($alive,$rtt) = $ping->ping($self->hostname); $self->{rtt} = $alive ? $rtt : undef; $self->{ping_time} = time; $self->rtt; } 1; =back =head1 AUTHOR Andreas Koenig C<< >>, David Golden C<< >>, brian d foy C<< >> =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut PK uiZް Config.pmnu[# This CPAN::Config was automatically generated using /usr/local/cpanel/scripts/cpan_config # at Mon Sep 12 09:34:25 2022 # # If this Config.pm replaced an existing version, then it would be located at: # /usr/share/perl5/CPAN/Config.pm.1662996865 # 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. $CPAN::Config = { 'auto_commit' => q[1], 'build_cache' => q[10], 'build_dir' => q[/home/.cpan/build], 'cache_metadata' => q[1], 'connect_to_internet_ok' => q[no], 'cpan_home' => q[/home/.cpan], 'dontload_hash' => { }, 'ftp' => q[/bin/false], 'ftp_proxy' => q[], 'getcwd' => q[cwd], 'gzip' => q[/bin/gzip], 'histfile' => q[/home/.cpan/histfile], 'histsize' => q[100], 'http_proxy' => q[], 'inactivity_timeout' => q[310], 'index_expire' => q[1], 'inhibit_startup_message' => q[1], 'keep_source_where' => q[/home/.cpan/sources], 'lynx' => q[], 'make' => q[/usr/bin/make], 'make_arg' => q[], 'make_install_arg' => q[UNINST=1], 'makepl_arg' => q[], 'mbuild_arg' => q[], 'mbuild_install_arg' => q[], 'mbuild_install_build_command' => q[./Build], 'mbuildpl_arg' => q[], 'ncftpget' => q[], 'no_proxy' => q[], 'pager' => q[/usr/bin/less], 'prefer_installer' => q[EUMM], 'prerequisites_policy' => q[follow], 'scan_cache' => q[atstart], 'shell' => q[/bin/bash], 'tar' => q[/bin/gtar], 'term_is_latin' => q[1], 'unzip' => q[/usr/bin/unzip], 'urllist' => [q[http://208.100.0.204/pub/CPAN/], q[http://31.22.112.31/pub/CPAN/], q[http://103.101.161.235/pub/CPAN/], q[http://184.94.196.93/pub/CPAN/], q[http://185.15.22.168/pub/CPAN/], q[http://184.94.196.92/pub/CPAN/], q[http://103.48.119.120/pub/CPAN/], q[http://184.94.196.94/pub/CPAN/], q[http://103.72.162.35/pub/CPAN/], q[http://203.174.85.202/pub/CPAN/], q[http://27.50.85.8/pub/CPAN/], q[http://103.17.8.8/pub/CPAN/], q[http://103.120.66.133/pub/CPAN/], q[http://138.118.173.126/pub/CPAN/], q[http://45.228.65.220/pub/CPAN/], q[http://102.22.80.80/pub/CPAN/], q[http://103.15.48.49/pub/CPAN/], q[http://201.159.169.169/pub/CPAN/], q[http://101.0.120.94/pub/CPAN/], q[http://103.252.152.1/pub/CPAN/], q[http://184.94.196.97/pub/CPAN/], q[http://208.74.123.61/pub/CPAN/], q[http://45.234.92.141/pub/CPAN/], q[http://208.74.123.62/pub/CPAN/], q[http://178.18.193.52/pub/CPAN/]], 'use_sqlite' => q[0], 'wget' => q[/bin/false], }; 1; __END__ PK uiZM Author.pmnu[# -*- 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.5001"; 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 = eval { 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 = eval { 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; PK uiZ䍽DeferredCode.pmnu[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; PK uiZiۨDDistrostatus.pmnu[# -*- 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; PK uiZ}l++ API/HOWTO.podnu[=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 =head1 AUTHOR David Cantrell =cut PK uiZЧ InfoObj.pmnu[# -*- 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 .= " "; } $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; PK uiZuy]VV Module.pmnu[# -*- 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.5001"; BEGIN { # alarm() is not implemented in perl 5.6.x and earlier under Windows *ALARM_IMPLEMENTED = sub () { $] >= 5.007 || $^O !~ /MSWin/ }; } # 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::deprecated_in_core ; sub deprecated_in_core { my ($self) = @_; return unless $CPAN::META->has_inst('Module::CoreList') && Module::CoreList->can('is_deprecated'); return Module::CoreList::is_deprecated($self->{ID}); } #-> sub CPAN::Module::inst_deprecated; # Indicates whether the *installed* version of the module is a deprecated *and* # installed as part of the Perl core library path sub inst_deprecated { my ($self) = @_; my $inst_file = $self->inst_file or return; return $self->deprecated_in_core && $self->_in_priv_or_arch($inst_file); } #-> sub CPAN::Module::uptodate ; sub uptodate { my ($self) = @_; local ($_); my $inst = $self->inst_version or return 0; my $cpan = $self->cpan_version; return 0 if CPAN::Version->vgt($cpan,$inst) || $self->inst_deprecated; CPAN->debug (join ("", "returning uptodate. ", "cpan[$cpan]inst[$inst]", )) 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 (CPAN support level flag 'abandoned').\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) = @_; if (ALARM_IMPLEMENTED) { my $timeout = (exists($CPAN::Config{'version_timeout'})) ? $CPAN::Config{'version_timeout'} : 15; alarm($timeout); } 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) if ALARM_IMPLEMENTED; 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; PK uiZ|­!::Queue.pmnu[# -*- 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.5001"; # 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), join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @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($qmod,$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 if ($All[$i]{qmod} eq $qmod) { $jumped++; } } # high jumped values are normal for popular modules when # dealing with large bundles: XML::Simple, # namespace::autoclean, UNIVERSAL::require CPAN->debug("qmod[$qmod]jumped[$jumped]") if $CPAN::DEBUG; my $obj = "$class\::Item"->new( qmod => $qmod, 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; } sub reqtype_of { my($self,$mod) = @_; my $best = ""; for my $item (grep { $_->{qmod} eq $mod } @All) { my $c = $item->{reqtype}; if ($c eq "c") { $best = $c; last; } elsif ($c eq "r") { $best = $c; } elsif ($c eq "b") { if ($best eq "") { $best = $c; } } else { die "Panic: in reqtype_of: reqtype[$c] seen, should never happen"; } } return $best; } 1; __END__ =head1 NAME CPAN::Queue - internal queue support for CPAN.pm =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK uiZ$UUIndex.pmnu[package CPAN::Index; use strict; use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION); $VERSION = "1.9600"; @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("Reading %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("Reading '$index_target'\n"); local(*FH); tie *FH, 'CPAN::Tarzip', $index_target; local($/) = "\n"; local($_); push @lines, split /\012/ while ; 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("Reading '$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; my $errors = 0; 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 }); $errors++; $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 }); $errors++; $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; LINE: 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) { require Dumpvalue; my $dv = Dumpvalue->new(tick => '"'); $CPAN::Frontend->mywarn(sprintf "Could not split line[%s]\n", $dv->stringify($_)); if ($errors++ >= 5){ $CPAN::Frontend->mydie("Giving up parsing your $index_target, too many errors"); } next LINE; } 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("Reading '$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("Writing $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("Reading '$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; PK uiZܑHException/yaml_process_error.pmnu[# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- # vim: ts=4 sts=4 sw=4: 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; PK uiZ*^Exception/blocked_urllist.pmnu[# -*- 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.001"; 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; PK uiZ Exception/RecursiveDependency.pmnu[# -*- 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; PK uiZTException/yaml_not_installed.pmnu[# -*- 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"; } 1; PK uiZ* __+_+Distroprefs.pmnu[# -*- 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 = ; 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 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 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, indicating that no prefs files remain to be found =back =head1 RESULTS L|/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, C, or C =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 results from C. =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) currently: C =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 (above) =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK uiZ   FirstTime.pmnu[# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- # vim: ts=4 sts=4 sw=4: package CPAN::FirstTime; use strict; use ExtUtils::MakeMaker (); use FileHandle (); use File::Basename (); use File::Path (); use File::Spec (); use CPAN::Mirrors (); use vars qw($VERSION $auto_config); $VERSION = "5.5303"; =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 saves 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 in your configuration then C 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 Normally, 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 ENTER 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 # (but do NOT use with local::lib or INSTALL_BASE) 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 # (but do NOT use with local::lib or INSTALL_BASE) 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 your 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'). Choosing 'follow' also sets PERL_AUTOINSTALL and PERL_EXTUTILS_AUTOINSTALL for "--defaultdeps" if not already set. 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 ('atstart'). Alternatively, scanning and cleanup can happen when CPAN exits ('atexit'). To prevent any cache cleanup, answer 'never'. Perform cache scanning ('atstart', 'atexit' 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 (a.k.a. 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 deliver 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 traffic, you may need to configure CPAN::Reporter before sending reports. Generate 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 prefer_external_tar Per default all untar operations are done with the perl module Archive::Tar; by setting this variable to true the external tar command is used if available; on Unix this is usually preferred because they have a reliable and fast gnutar implementation. Use the external tar program instead of Archive::Tar? =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 version_timeout This timeout prevents CPAN from hanging when trying to parse a pathologically coded $VERSION from a module. The default is 15 seconds. If you set this value to 0, no timeout will occur, but this is not recommended. Timeout for parsing module versions? =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 = ( auto_config => qq{ CPAN.pm requires configuration, but most of it can be done automatically. If you answer 'no' below, you will enter an interactive dialog for each configuration option instead. Would you like to configure as much as possible automatically?}, auto_pick => qq{ Would you like me to automatically choose some CPAN mirror sites for you? (This means connecting to the Internet)}, 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 ENTER. 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 ENTER. You will then be asked for the password in every future session. }, urls_intro => qq{ Now you need to choose your CPAN mirror sites. You can let me pick mirrors for you, you can select them from a list or you can enter them by hand. }, urls_picker_intro => qq{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. You should select more than one (just in case the first isn't available). }, password_warn => qq{ Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal! }, install_help => qq{ Warning: You do not have write permission for Perl library directories. To install modules, you need to configure a local Perl library directory or escalate your privileges. CPAN can help you by bootstrapping the local::lib module or by configuring itself to use 'sudo' (if available). You may also resolve this problem manually if you need to customize your setup. What approach do you want? (Choose 'local::lib', 'sudo' or 'manual') }, local_lib_installed => qq{ local::lib is installed. You must now add the following environment variables to your shell configuration files (or registry, if you are on Windows) and then restart your command line shell and CPAN before installing modules: }, ); 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 # local *_real_prompt; if ( $args{autoconfig} ) { $auto_config = 1; } elsif ($matcher) { $auto_config = 0; } else { my $_conf = prompt($prompts{auto_config}, "yes"); $auto_config = ($_conf and $_conf =~ /^y/i) ? 1 : 0; } CPAN->debug("auto_config[$auto_config]") if $CPAN::DEBUG; if ( $auto_config ) { local $^W = 0; # prototype should match that of &MakeMaker::prompt my $current_second = time; my $current_second_count = 0; my $i_am_mad = 0; # silent prompting -- just quietly use default *_real_prompt = sub { return $_[1] }; } # # bootstrap local::lib or sudo # unless ( $matcher || _can_write_to_libdirs() || _using_installbase() || _using_sudo() ) { local $auto_config = 0; # We *must* ask, even under autoconfig local *_real_prompt; # We *must* show prompt my_prompt_loop(install_help => 'local::lib', $matcher, 'local::lib|sudo|manual'); } $CPAN::Config->{install_help} ||= ''; # Temporary to suppress warnings if (!$matcher or q{ build_dir build_dir_reuse cpan_home keep_source_where prefs_dir } =~ /$matcher/) { $CPAN::Frontend->myprint($prompts{config_intro}) unless $auto_config; 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|atexit|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 => 'follow', $matcher, 'follow|ask|ignore'); my_prompt_loop(build_requires_install_policy => '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 ( $matcher && $CPAN::Config->{test_report} && $CPAN::META->has_inst("CPAN::Reporter") && CPAN::Reporter->can('configure') ) { my $_conf = prompt("Would you like me configure CPAN::Reporter now?", "yes"); if ($_conf =~ /^y/i) { $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); my $old_v = $CPAN::Config->{load_module_verbosity}; $CPAN::Config->{load_module_verbosity} = q[none]; if (!$auto_config && !$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); } $CPAN::Config->{load_module_verbosity} = $old_v; } # #= YAML code deserialisation # my_yn_prompt(yaml_load_code => 0, $matcher); # #= External programs # my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'}; $CPAN::Frontend->myprint($prompts{external_progs}) if !$matcher && !$auto_config; _init_external_progs($matcher, { path => \@path, progs => [ qw/make bzip2 gzip tar unzip gpg patch applypatch/ ], shortcut => 0 }); _init_external_progs($matcher, { path => \@path, progs => [ qw/wget curl lynx ncftpget ncftp ftp/ ], shortcut => 1 }); { 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 ||= 'sh', $path =~ s,\\,/,g if $^O eq 'os2'; # Cosmetic only my_dflt_prompt(shell => $path, $matcher); } } { my $tar = $CPAN::Config->{tar}; my $prefer_external_tar = $CPAN::Config->{prefer_external_tar}; # XXX not yet supported unless (defined $prefer_external_tar) { if ($^O =~ /(MSWin32|solaris)/) { # both have a record of broken tars $prefer_external_tar = 0; } elsif ($tar) { $prefer_external_tar = 1; } else { $prefer_external_tar = 0; } } my_yn_prompt(prefer_external_tar => $prefer_external_tar, $matcher); } # # verbosity # my_prompt_loop(tar_verbosity => 'none', $matcher, 'none|v|vv'); my_prompt_loop(load_module_verbosity => 'none', $matcher, 'none|v'); my_prompt_loop(perl5lib_verbosity => 'none', $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 $default = $CPAN::Config->{make} || ""; if ( $default && $CPAN::Config->{install_help} eq 'sudo' ) { if ( find_exe('sudo') ) { $default = "sudo $default"; delete $CPAN::Config->{make_install_make_command} unless $CPAN::Config->{make_install_make_command} =~ /sudo/; } else { $CPAN::Frontend->mywarnonce("Could not find 'sudo' in PATH\n"); } } my_dflt_prompt(make_install_make_command => $default, $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 $default = "./Build"; if ( $CPAN::Config->{install_help} eq 'sudo' ) { if ( find_exe('sudo') ) { $default = "sudo $default"; delete $CPAN::Config->{mbuild_install_build_command} unless $CPAN::Config->{mbuild_install_build_command} =~ /sudo/; } else { $CPAN::Frontend->mywarnonce("Could not find 'sudo' in PATH\n"); } } my_dflt_prompt(mbuild_install_build_command => $default, $matcher); } my_dflt_prompt(mbuild_install_arg => "", $matcher); # #= Alarm period # my_dflt_prompt(inactivity_timeout => 0, $matcher); my_dflt_prompt(version_timeout => 15, $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}) unless $auto_config; 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}) unless $auto_config; if ($CPAN::Config->{proxy_user} = prompt("Your proxy user id?",$default)) { $CPAN::Frontend->myprint($prompts{proxy_pass}) unless $auto_config; if ($CPAN::META->has_inst("Term::ReadKey")) { Term::ReadKey::ReadMode("noecho"); } else { $CPAN::Frontend->myprint($prompts{password_warn}) unless $auto_config; } $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") unless $auto_config; } } } # #= 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"; $CPAN::Frontend->myprint( " on_ on_y ". " on_ma on_\n") unless $auto_config; $CPAN::Frontend->myprint( " on_black on_red green ellow ". "on_blue genta on_cyan white\n") unless $auto_config; for my $FG ("", "bold", map {$_,"bold $_"} "black","red","green", "yellow","blue", "magenta", "cyan","white") { $CPAN::Frontend->myprint(sprintf( "%12s ", $FG)) unless $auto_config; for my $BG ("",map {"on_$_"} qw(black red green yellow blue magenta cyan white)) { $CPAN::Frontend->myprint( $FG||$BG ? Term::ANSIColor::colored(" $T ","$FG $BG") : " $T ") unless $auto_config; } $CPAN::Frontend->myprint( "\n" ) unless $auto_config; } $CPAN::Frontend->myprint( "\n" ) unless $auto_config; } 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}) unless $auto_config; 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/ ) { my_yn_prompt(show_unparsable_versions => 0, $matcher); my_yn_prompt(show_zero_versions => 0, $matcher); } # #= MIRRORED.BY and conf_sites() # # Let's assume they want to use the internet and make them turn it # off if they really don't. my_yn_prompt("connect_to_internet_ok" => 1, $matcher); # Allow matching but don't show during manual config if ($matcher) { 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); } } $CPAN::Config->{urllist} ||= []; if ($auto_config) { if(@{ $CPAN::Config->{urllist} }) { $CPAN::Frontend->myprint( "Your 'urllist' is already configured. Type 'o conf init urllist' to change it.\n" ); } else { $CPAN::Frontend->myprint( "Autoconfigured everything but 'urllist'.\n" ); _do_pick_mirrors(); } } elsif (!$matcher || "urllist" =~ $matcher) { _do_pick_mirrors(); } if ($auto_config) { $CPAN::Frontend->myprint( "\nAutoconfiguration complete.\n" ); $auto_config = 0; # reset } # bootstrap local::lib now if requested if ( $CPAN::Config->{install_help} eq 'local::lib' ) { if ( ! @{ $CPAN::Config->{urllist} } ) { $CPAN::Frontend->myprint( "Skipping local::lib bootstrap because 'urllist' is not configured.\n" ); } else { $CPAN::Frontend->myprint("\nAttempting to bootstrap local::lib...\n"); $CPAN::Frontend->myprint("\nWriting $configpm for bootstrap...\n"); delete $CPAN::Config->{install_help}; # temporary only CPAN::HandleConfig->commit; my $dist; if ( $dist = CPAN::Shell->expand('Module', 'local::lib')->distribution ) { # this is a hack to force bootstrapping $dist->{prefs}{pl}{commandline} = "$^X Makefile.PL --bootstrap"; # Set @INC for this process so we find things as they bootstrap require lib; lib->import(_local_lib_inc_path()); eval { $dist->install }; } if ( ! $dist || (my $err = $@) ) { $err ||= 'Could not locate local::lib in the CPAN index'; $CPAN::Frontend->mywarn("Error bootstrapping local::lib: $@\n"); $CPAN::Frontend->myprint("From the CPAN Shell, you might try 'look local::lib' and \n" . "run 'perl Makefile --bootstrap' and see if that is successful. Then\n" . "restart your CPAN client\n" ); } else { _local_lib_config(); } } } # install_help is temporary for configuration and not saved delete $CPAN::Config->{install_help}; $CPAN::Frontend->myprint("\n"); if ($matcher && !$CPAN::Config->{auto_commit}) { $CPAN::Frontend->myprint("Please remember to call 'o conf commit' to ". "make the config permanent!\n"); } else { CPAN::HandleConfig->commit; } if (! $matcher) { $CPAN::Frontend->myprint( "\nYou can re-run configuration any time with 'o conf init' in the CPAN shell\n" ); } } sub _local_lib_config { # Set environment stuff for this process require local::lib; my %env = local::lib->build_environment_vars_for(_local_lib_path(), 1); while ( my ($k, $v) = each %env ) { $ENV{$k} = $v; } # Tell user about environment vars to set $CPAN::Frontend->myprint($prompts{local_lib_installed}); local $ENV{SHELL} = $CPAN::Config->{shell} || $ENV{SHELL}; my $shellvars = local::lib->environment_vars_string_for(_local_lib_path()); $CPAN::Frontend->myprint($shellvars); # Offer to mangle the shell config my $munged_rc; if ( my $rc = _find_shell_config() ) { local $auto_config = 0; # We *must* ask, even under autoconfig local *_real_prompt; # We *must* show prompt my $_conf = prompt( "\nWould you like me to append that to $rc now?", "yes" ); if ($_conf =~ /^y/i) { open my $fh, ">>", $rc; print {$fh} "\n$shellvars"; close $fh; $munged_rc++; } } # Warn at exit time if ($munged_rc) { push @{$CPAN::META->_exit_messages}, << "HERE"; *** Remember to restart your shell before running cpan again *** HERE } else { push @{$CPAN::META->_exit_messages}, << "HERE"; *** Remember to add these environment variables to your shell config and restart your shell before running cpan again *** $shellvars HERE } } { my %shell_rc_map = ( map { $_ => ".${_}rc" } qw/ bash tcsh csh /, map { $_ => ".profile" } qw/dash ash sh/, zsh => ".zshenv", ); sub _find_shell_config { my $shell = File::Basename::basename($CPAN::Config->{shell}); if ( my $rc = $shell_rc_map{$shell} ) { my $path = File::Spec->catfile($ENV{HOME}, $rc); return $path if -w $path; } } } sub _local_lib_inc_path { return File::Spec->catdir(_local_lib_path(), qw/lib perl5/); } sub _local_lib_path { return File::Spec->catdir(_local_lib_home(), 'perl5'); } # Adapted from resolve_home_path() in local::lib -- this is where # local::lib thinks the user's home is { my $local_lib_home; sub _local_lib_home { $local_lib_home ||= File::Spec->rel2abs( do { if ($CPAN::META->has_usable("File::HomeDir") && File::HomeDir->VERSION >= 0.65) { File::HomeDir->my_home; } elsif (defined $ENV{HOME}) { $ENV{HOME}; } else { (getpwuid $<)[7] || "~"; } }); } } sub _do_pick_mirrors { local *_real_prompt; *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt; $CPAN::Frontend->myprint($prompts{urls_intro}); # Only prompt for auto-pick if Net::Ping is new enough to do timings my $_conf = 'n'; if ( $CPAN::META->has_usable("Net::Ping") && Net::Ping->VERSION gt '2.13') { $_conf = prompt($prompts{auto_pick}, "yes"); } my @old_list = @{ $CPAN::Config->{urllist} }; if ( $_conf =~ /^y/i ) { conf_sites( auto_pick => 1 ) or bring_your_own(); } else { _print_urllist('Current') if @old_list; my $msg = scalar @old_list ? "\nWould you like to edit the urllist or pick new mirrors from a list?" : "\nWould you like to pick from the CPAN mirror list?" ; my $_conf = prompt($msg, "yes"); if ( $_conf =~ /^y/i ) { conf_sites(); } bring_your_own(); } _print_urllist('New'); } sub _init_external_progs { my($matcher,$args) = @_; my $PATH = $args->{path}; my @external_progs = @{ $args->{progs} }; my $shortcut = $args->{shortcut}; my $showed_make_warning; if (!$matcher or "@external_progs" =~ /$matcher/) { 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") unless $auto_config; _beg_for_make(), $showed_make_warning++ if $progname eq "make"; } $prompts{$progname} = "Where is your $progname program?"; $path = my_dflt_prompt($progname,$path,$matcher,1); # 1 => no strip spaces my $disabling = $path =~ m/^\s*$/; # don't let them disable or misconfigure make without warning if ( $progname eq "make" && ( $disabling || ! _check_found($path) ) ) { if ( $disabling && $showed_make_warning ) { next; } else { _beg_for_make() unless $showed_make_warning++; undef $CPAN::Config->{$progname}; $CPAN::Frontend->mywarn("Press SPACE and ENTER to disable make (NOT RECOMMENDED)\n"); redo; } } elsif ( $disabling ) { next; } elsif ( _check_found( $CPAN::Config->{$progname} ) ) { last if $shortcut && !$matcher; } else { undef $CPAN::Config->{$progname}; $CPAN::Frontend->mywarn("Press SPACE and ENTER to disable $progname\n"); redo; } } } } sub _check_found { my ($prog) = @_; if ( ! -f $prog ) { $CPAN::Frontend->mywarn("Warning: '$prog' does not exist\n") unless $auto_config; return; } elsif ( ! -x $prog ) { $CPAN::Frontend->mywarn("Warning: '$prog' is not executable\n") unless $auto_config; return; } return 1; } sub _beg_for_make { $CPAN::Frontend->mywarn(<<"HERE"); ALERT: 'make' is an essential tool for building perl Modules. Please make sure you have 'make' (or some equivalent) working. HERE if ($^O eq "MSWin32") { $CPAN::Frontend->mywarn(<<"HERE"); 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 HERE } } sub init_cpan_home { my($matcher) = @_; if (!$matcher or 'cpan_home' =~ /$matcher/) { my $cpan_home = $CPAN::Config->{cpan_home} || CPAN::HandleConfig::cpan_home(); if (-d $cpan_home) { $CPAN::Frontend->myprint( "\nI see you already have a directory\n" . "\n$cpan_home\n" . "Shall we use it as the general CPAN build and cache directory?\n\n" ) unless $auto_config; } else { # no cpan-home, must prompt and get one $CPAN::Frontend->myprint($prompts{cpan_home_where}) unless $auto_config; } my $default = $cpan_home; my $loop = 0; my($last_ans,$ans); $CPAN::Frontend->myprint(" \n") unless $auto_config; PROMPT: while ($ans = prompt("CPAN build and cache directory?",$default)) { 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, $no_strip) = @_; my $default = $CPAN::Config->{$item} || $dflt; if (!$auto_config && (!$m || $item =~ /$m/)) { if (my $intro = $prompts{$item . "_intro"}) { $CPAN::Frontend->myprint($intro); } $CPAN::Frontend->myprint(" <$item>\n"); $CPAN::Config->{$item} = $no_strip ? prompt_no_strip($prompts{$item}, $default) : prompt( $prompts{$item}, $default); } else { $CPAN::Config->{$item} = $default; } return $CPAN::Config->{$item}; } sub my_yn_prompt { my ($item, $dflt, $m) = @_; my $default; defined($default = $CPAN::Config->{$item}) or $default = $dflt; # $DB::single = 1; if (!$auto_config && (!$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); } else { $CPAN::Config->{$item} = $default; } } sub my_prompt_loop { my ($item, $dflt, $m, $ok) = @_; my $default = $CPAN::Config->{$item} || $dflt; my $ans; if (!$auto_config && (!$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; } else { $CPAN::Config->{$item} = $default; } } # Here's the logic about the MIRRORED.BY file. There are a number of scenarios: # (1) We have a cached MIRRORED.BY file # (1a) We're auto-picking # - Refresh it automatically if it's old # (1b) Otherwise, ask if using cached is ok. If old, default to no. # - If cached is not ok, get it from the Internet. If it succeeds we use # the new file. Otherwise, we use the old file. # (2) We don't have a copy at all # (2a) If we are allowed to connect, we try to get a new copy. If it succeeds, # we use it, otherwise, we warn about failure # (2b) If we aren't allowed to connect, sub conf_sites { my %args = @_; # auto pick implies using the internet $CPAN::Config->{connect_to_internet_ok} = 1 if $args{auto_pick}; my $m = 'MIRRORED.BY'; my $mby = File::Spec->catfile($CPAN::Config->{keep_source_where},$m); File::Path::mkpath(File::Basename::dirname($mby)); # Why are we using MIRRORED.BY from the current directory? # Is this for testing? -- dagolden, 2009-11-05 if (-f $mby && -f $m && -M $m < -M $mby) { require File::Copy; File::Copy::copy($m,$mby) or die "Could not update $mby: $!"; } local $^T = time; # if we have a cached copy is not older than 60 days, we either # use it or refresh it or fall back to it if the refresh failed. if ($mby && -f $mby && -s _ > 0 ) { my $very_old = (-M $mby > 60); my $mtime = localtime((stat _)[9]); # if auto_pick, refresh anything old automatically if ( $args{auto_pick} ) { if ( $very_old ) { $CPAN::Frontend->myprint(qq{Trying to refresh your mirror list\n}); eval { CPAN::FTP->localize($m,$mby,3,1) } or $CPAN::Frontend->myprint(qq{Refresh failed. Using the old cached copy instead.\n}); $CPAN::Frontend->myprint("\n"); } } else { my $prompt = qq{Found a cached mirror list as of $mtime If you'd like to just use the cached copy, answer 'yes', below. If you'd like an updated copy of the mirror list, answer 'no' and I'll get a fresh one from the Internet. Shall I use the cached mirror list?}; my $ans = prompt($prompt, $very_old ? "no" : "yes"); if ($ans =~ /^n/i) { $CPAN::Frontend->myprint(qq{Trying to refresh your mirror list\n}); # you asked for it from the Internet $CPAN::Config->{connect_to_internet_ok} = 1; eval { CPAN::FTP->localize($m,$mby,3,1) } or $CPAN::Frontend->myprint(qq{Refresh failed. Using the old cached copy instead.\n}); $CPAN::Frontend->myprint("\n"); } } } # else there is no cached copy and we must fetch or fail else { # If they haven't agree to connect to the internet, ask again if ( ! $CPAN::Config->{connect_to_internet_ok} ) { my $prompt = q{You are missing a copy of the CPAN mirror list. May I connect to the Internet to get it?}; my $ans = prompt($prompt, "yes"); if ($ans =~ /^y/i) { $CPAN::Config->{connect_to_internet_ok} = 1; } } # Now get it from the Internet or complain if ( $CPAN::Config->{connect_to_internet_ok} ) { $CPAN::Frontend->myprint(qq{Trying to fetch a mirror list from the Internet\n}); eval { CPAN::FTP->localize($m,$mby,3,1) } or $CPAN::Frontend->mywarn(<<'HERE'); We failed to get a copy of the mirror list from the Internet. You will need to provide CPAN mirror URLs yourself. HERE $CPAN::Frontend->myprint("\n"); } else { $CPAN::Frontend->mywarn(<<'HERE'); You will need to provide CPAN mirror URLs yourself or set 'o conf connect_to_internet_ok 1' and try again. HERE } } # if we finally have a good local MIRRORED.BY, get on with picking if (-f $mby && -s _ > 0){ $CPAN::Config->{urllist} = $args{auto_pick} ? auto_mirrored_by($mby) : choose_mirrored_by($mby); return 1; } return; } sub find_exe { my($exe,$path) = @_; $path ||= [split /$Config{'path_sep'}/, $ENV{'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"); } # 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 ENTER" : "ENTER"; $CPAN::Frontend->myprint(sprintf("%d more items, hit %s to show them\n", (@$items - $pos), $hit_what, )) if $pos < @$items; return $pos; } sub auto_mirrored_by { my $local = shift or return; local $|=1; $CPAN::Frontend->myprint("Looking for CPAN mirrors near you (please be patient)\n"); my $mirrors = CPAN::Mirrors->new; $mirrors->parse_mirrored_by($local); my $cnt = 0; my @best = $mirrors->best_mirrors( how_many => 3, callback => sub { $CPAN::Frontend->myprint("."); if ($cnt++>60) { $cnt=0; $CPAN::Frontend->myprint("\n"); } }, ); my $urllist = [ map { $_->http } @best ]; push @$urllist, grep { /^file:/ } @{$CPAN::Config->{urllist}}; $CPAN::Frontend->myprint(" done!\n\n"); return $urllist } sub choose_mirrored_by { my $local = shift or return; my ($default); my $mirrors = CPAN::Mirrors->new($local); my @previous_urls = @{$CPAN::Config->{urllist}}; $CPAN::Frontend->myprint($prompts{urls_picker_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 $mirrors->continents]; 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 $mirrors->countries($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 my $country (@countries) { next if $country =~ /edit previous picks/; (my $bare_country = $country) =~ s/ \(.*\)//; my @u; for my $m ( $mirrors->mirrors($bare_country) ) { push @u, $m->ftp if $m->ftp; push @u, $m->http if $m->http; } @u = grep (! $seen{$_}, @u); @u = map ("$_ ($bare_country)", @u) if @countries > 1; push (@urls, sort @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 ENTER to keep your previous picks)"; } @urls = picklist (\@urls, $prompt, $default); foreach (@urls) { s/ \(.*\)//; } return [ @urls ]; } sub bring_your_own { my $urllist = [ @{$CPAN::Config->{urllist}} ]; my %seen = map (($_ => 1), @$urllist); my($ans,@urls); my $eacnt = 0; # empty answers $CPAN::Frontend->myprint(<<'HERE'); Now you can enter your own CPAN URLs by hand. A local CPAN mirror can be listed using a 'file:' URL like 'file:///path/to/cpan/' HERE do { my $prompt = "Enter another URL or ENTER 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 # XXX This manipulation is odd. Shouldn't we check that $ans is # a directory before converting to file:///? And we need /// below, # too, don't we? -- dagolden, 2009-11-05 $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; } sub _print_urllist { my ($which) = @_; $CPAN::Frontend->myprint("$which urllist\n"); for ( @{$CPAN::Config->{urllist} || []} ) { $CPAN::Frontend->myprint(" $_\n") }; } sub _can_write_to_libdirs { return -w $Config{installprivlib} && -w $Config{installarchlib} && -w $Config{installsitelib} && -w $Config{installsitearch} } sub _using_installbase { return 1 if $ENV{PERL_MM_OPT} && $ENV{PERL_MM_OPT} =~ /install_base/i; return 1 if grep { ($CPAN::Config->{$_}||q{}) =~ /install_base/i } qw(makepl_arg make_install_arg mbuildpl_arg mbuild_install_arg); return; } sub _using_sudo { return 1 if grep { ($CPAN::Config->{$_}||q{}) =~ /sudo/ } qw(make_install_make_command mbuild_install_build_command); return; } 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); $CPAN::Frontend->myprint("\n") unless $auto_config; return $ans; } sub prompt_no_strip ($;$) { unless (defined &_real_prompt) { *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt; } return _real_prompt(@_); } 1; PK uiZeJMNox.pmnu[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 =cut PK uiZs LWP/UserAgent.pmnu[# -*- 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); use CPAN::HTTP::Credentials; # we delay requiring LWP::UserAgent and setting up inheritance until we need it $CPAN::LWP::UserAgent::VERSION = $CPAN::LWP::UserAgent::VERSION = "1.9600"; 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 ( $proxy ) { return CPAN::HTTP::Credentials->get_proxy_credentials(); } else { return CPAN::HTTP::Credentials->get_non_proxy_credentials(); } } sub no_proxy { my ( $self, $no_proxy ) = @_; return $self->SUPER::no_proxy( split(',',$no_proxy) ); } # 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) { CPAN::HTTP::Credentials->clear_credentials; $result = $self->SUPER::mirror($url,$aslocal); } $result; } 1; PK uiZz66Debug.pmnu[# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- package CPAN::Debug; use strict; use vars qw($VERSION); $VERSION = "5.5001"; # 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("Debug(\n" . $arg->as_string . ")\n"); } else { $CPAN::Frontend->myprint("Debug(\n" . Data::Dumper::Dumper($arg) . ")\n"); } } else { my $outer = ""; local $" = ","; if (@caller>1) { $outer = ",[@{$caller[1]}]"; } $CPAN::Frontend->myprint("Debug(@{$caller[0]}$outer): $arg\n"); } } } 1; __END__ =head1 NAME CPAN::Debug - internal debugging for CPAN.pm =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK uiZ;]D]DDistribution.pmnu[# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- # vim: ts=4 sts=4 sw=4: package CPAN::Distribution; use strict; use Cwd qw(chdir); use CPAN::Distroprefs; use CPAN::InfoObj; use File::Path (); @CPAN::Distribution::ISA = qw(CPAN::InfoObj); use vars qw($VERSION); $VERSION = "1.9602"; # 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 $self->debug("color_cmd_tmps[$depth,$color,@$ancestors]") if $CPAN::DEBUG; 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(0.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(<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; } eval { File::Path::mkpath $builddir; }; if ($@) { $CPAN::Frontend->mydie("Cannot create directory $builddir: $@"); } $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(<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::pick_meta_file ; sub pick_meta_file { my($self, $filter) = @_; $filter = '.' unless defined $filter; 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; } my $has_cm = $CPAN::META->has_usable("CPAN::Meta"); my $has_pcm = $CPAN::META->has_usable("Parse::CPAN::Meta"); my @choices; push @choices, 'MYMETA.json' if $has_cm; push @choices, 'MYMETA.yml' if $has_cm || $has_pcm; push @choices, 'META.json' if $has_cm; push @choices, 'META.yml' if $has_cm || $has_pcm; for my $file ( grep { /$filter/ } @choices ) { my $path = File::Spec->catdir( $build_dir, $file ); return $path if -f $path } return; } #-> sub CPAN::Distribution::parse_meta_yml ; sub parse_meta_yml { my($self, $yaml) = @_; $self->debug(sprintf("parse_meta_yml[%s]",$yaml||'undef')) if $CPAN::DEBUG; my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir"; $yaml ||= File::Spec->catfile($build_dir,"META.yml"); $self->debug("meta[$yaml]") if $CPAN::DEBUG; return unless -f $yaml; my $early_yaml; eval { $CPAN::META->has_inst("Parse::CPAN::Meta") or die; die "Parse::CPAN::Meta yaml too old" unless $Parse::CPAN::Meta::VERSION >= "1.40"; # P::C::M returns last document in scalar context $early_yaml = Parse::CPAN::Meta::LoadFile($yaml); }; unless ($early_yaml) { eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; }; } $self->debug(sprintf("yaml[%s]", $early_yaml || 'UNDEF')) if $CPAN::DEBUG; $self->debug($early_yaml) if $CPAN::DEBUG && $early_yaml; return $early_yaml || undef; } #-> sub CPAN::Distribution::satisfy_requires ; sub satisfy_requires { my ($self) = @_; $self->debug("Entering satisfy_requires") if $CPAN::DEBUG; if (my @prereq = $self->unsat_prereq("later")) { $self->debug("unsatisfied[@prereq]") if $CPAN::DEBUG; $self->debug(@prereq) if $CPAN::DEBUG && @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; 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"; } } } return; } #-> sub CPAN::Distribution::satisfy_configure_requires ; sub satisfy_configure_requires { my($self) = @_; $self->debug("Entering satisfy_configure_requires") if $CPAN::DEBUG; 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"); $self->debug(sprintf "configure_requires[%s]", join(",",map {join "/",@$_} @prereq)) if $CPAN::DEBUG; return 1 unless @prereq; $self->debug(\@prereq) if $CPAN::DEBUG; if ($self->{configure_requires_later}) { for my $k (keys %{$self->{configure_requires_later_for}||{}}) { if ($self->{configure_requires_later_for}{$k}>1) { my $type = ""; for my $p (@prereq) { if ($p->[0] eq $k) { $type = $p->[1]; } } $type = " $type" if $type; $CPAN::Frontend->mywarn("Warning: unmanageable(?) prerequisite $k$type"); sleep 1; } } } 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"); } else { return $self->goodbye("[configure_requires] -- 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} ); # M::B <= 0.35 left a DATA handle open that # causes problems upgrading M::B on Windows close *Module::Build::Version::DATA if fileno *Module::Build::Version::DATA; } } 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 (defined $dir && length $dir) { my $id = $self->id; $CPAN::Frontend->mywarnonce("build_dir of $id is not known, ". "will not store persistent state\n"); return; } unless (File::Spec->canonpath(File::Basename::dirname($dir)) eq File::Spec->canonpath($CPAN::Config->{build_dir})) { $CPAN::Frontend->mywarnonce("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->myprintonce("'$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 () { 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("Applying $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) { CPAN->debug("not on disk: patch[$patch]") if $CPAN::DEBUG; 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,$pfiles) = $self->_patch_p_parameter($readfh); if ($ppp eq "applypatch") { $pcommand = "$CPAN::Config->{applypatch} -verbose"; } else { my $thispatchargs = join " ", $stdpatchargs, $ppp; $pcommand = "$patchbin $thispatchargs"; require Config; # usually loaded from CPAN.pm if ($Config::Config{osname} eq "solaris") { # native solaris patch cannot patch readonly files for my $file (@{$pfiles||[]}) { my @stat = stat $file or next; chmod $stat[2] | 0600, $file; # may fail } } } $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; } } # may return # - "applypatch" # - ("-p0"|"-p1", $files) sub _patch_p_parameter { my($self,$fh) = @_; my $cnt_files = 0; my $cnt_p0files = 0; my @files; local($_); while ($_ = $fh->READLINE) { if ( $CPAN::Config->{applypatch} && /\#\#\#\# ApplyPatch data follows \#\#\#\#/ ) { return "applypatch" } next unless /^[\*\+]{3}\s(\S+)/; my $file = $1; push @files, $file; $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; my $opt_p = $cnt_files==$cnt_p0files ? "-p0" : "-p1"; return ($opt_p, \@files); } #-> 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 " }); 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"), ); my $readme = "authors/id/$sans.readme"; $self->debug("Doing localize for '$readme'") if $CPAN::DEBUG; $local_file = CPAN::FTP->localize($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", ], 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: Building ".$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; if ($CPAN::Config->{prerequisites_policy} eq "follow") { $ENV{PERL_AUTOINSTALL} ||= "--defaultdeps"; $ENV{PERL_EXTUTILS_AUTOINSTALL} ||= "--defaultdeps"; } 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; $but =~ s/(?s:^.*?)$regex//; $timeout_start = time; 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"); } # shortcut if there are no distroprefs files { my $dh = DirHandle->new($prefs_dir) or $CPAN::Frontend->mydie("Couldn't open '$prefs_dir': $!"); my @files = map { /\.(yml|dd|st)\z/i } $dh->read; return unless @files; } 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->mywarnonce("'$yaml_module' not installed, falling back ". "to @fallbacks to read prefs '$prefs_dir'\n"); } } else { unless ($self->{have_complained_about_missing_yaml}++) { $CPAN::Frontend->mywarnonce("'$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) { # promote if possible if ($p->[1] =~ /^(r|c)$/) { push @good_prereq_tuples, $p; } elsif ($p->[1] =~ /^(b)$/) { my $reqtype = CPAN::Queue->reqtype_of($p->[0]); if ($reqtype =~ /^(r|c)$/) { push @good_prereq_tuples, [$p->[0], $reqtype]; } else { push @good_prereq_tuples, $p; } } else { die "Panic: in follow_prereqs: reqtype[$p->[1]] seen, should never happen"; } } 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_configure_requires = $self->configure_requires(); %merged = ( %{$meta_configure_requires||{}}, %{$prefs_depends->{configure_requires}||{}}, %{$feature_depends->{configure_requires}||{}}, ); if (-f "Build.PL" && ! -f "Makefile.PL" && ! exists $merged{"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); $merged{"Module::Build"} = 0; delete $self->{writemakefile}; } $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,$inst_file,$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; $inst_file = $nmo->inst_file || ''; $available_file = $nmo->available_file || ''; # if they have not specified a version, we accept any installed one if ( $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" )) { unless ($nmo->inst_deprecated) { 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. # But we don't want to accept a deprecated module installed as part # of the Perl core, so we continue if the available file is the installed # one and is deprecated if ( $available_file ) { if ( $inst_file && $available_file eq $inst_file && $nmo->inst_deprecated ) { # continue installing as a prereq } elsif ($self->{reqtype} =~ /^(r|c)$/ && exists $prereq_pm->{requires}{$need_module} && $nmo && !$inst_file) { # continue installing as a prereq; this may be a # distro we already used when it was a build_requires # so we did not install it. But suddenly somebody # wants it as a requires my $need_distro = $nmo->distribution; if ($need_distro->{install} && $need_distro->{install}->failed && $need_distro->{install}->text =~ /is only/) { CPAN->debug("promotion from build_requires to requires") if $CPAN::DEBUG; delete $need_distro->{install}; # promote to another installation attempt $need_distro->{reqtype} = "r"; $need_distro->install; next NEED; } } else { next NEED if $self->_fulfills_all_version_rqs( $need_module,$available_file,$available_version,$need_version ); } } 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; if (0) { } elsif (exists $prereq_pm->{requires}{$need_module}) { $needed_as = "r"; } elsif ($slot eq "configure_requires_later") { # in ae872487d5 we said: C< we have not yet run the # {Build,Makefile}.PL, we must presume "r" >; but the # meta.yml standard says C< These dependencies are not # required after the distribution is installed. >; so now # we change it back to "b" and care for the proper # promotion later. $needed_as = "b"; } else { $needed_as = "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 { $ok=0; last RQ; } } elsif ($rq =~ m|<=?\s*|) { # 2005-12: no user $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n"); $ok++; next RQ; } elsif ($rq =~ s|==\s*||) { # 2009-07: ELLIOTJS/Perl-Critic-1.099_002.tar.gz if (CPAN::Version->vcmp($available_version,$rq)) { $ok=0; last RQ; } else { $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; } my $ret = $ok == @all_requirements; CPAN->debug(sprintf("need_module[%s]ok[%s]all_requirements[%d]",$need_module, $ok, scalar @all_requirements)) if $CPAN::DEBUG; return $ret; } #-> sub CPAN::Distribution::read_meta # read any sort of meta files, return CPAN::Meta object if no errors sub read_meta { my($self) = @_; my $meta_file = $self->pick_meta_file or return; return unless $CPAN::META->has_usable("CPAN::Meta"); my $meta = eval { CPAN::Meta->load_file($meta_file)} or return; # Very old EU::MM could have wrong META if ($meta_file eq 'META.yml' && $meta->generated_by =~ /ExtUtils::MakeMaker version ([\d\._]+)/ ) { my $eummv = do { local $^W = 0; $1+0; }; return if $eummv < 6.2501; } return $meta; } #-> sub CPAN::Distribution::read_yaml ; # XXX This should be DEPRECATED -- dagolden, 2011-02-05 sub read_yaml { my($self) = @_; my $meta_file = $self->pick_meta_file; $self->debug("meta_file[$meta_file]") if $CPAN::DEBUG; return unless $meta_file; my $yaml; eval { $yaml = $self->parse_meta_yml($meta_file) }; if ($@ or ! $yaml) { return undef; # if we die, then we cannot read YAML's own META.yml } # not "authoritative" if (defined $yaml && (! ref $yaml || ref $yaml ne "HASH")) { $CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n"); $yaml = undef; } $self->debug(sprintf "yaml[%s]", $yaml || "UNDEF") if $CPAN::DEBUG; $self->debug($yaml) if $CPAN::DEBUG && $yaml; # MYMETA.yml is static and authoritative by definition if ( $meta_file =~ /MYMETA\.yml/ ) { return $yaml; } # META.yml is authoritative only if dynamic_config is defined and false if ( defined $yaml->{dynamic_config} && ! $yaml->{dynamic_config} ) { return $yaml; } # otherwise, we can't use what we found return undef; } #-> sub CPAN::Distribution::configure_requires ; sub configure_requires { my($self) = @_; return unless my $meta_file = $self->pick_meta_file('^META'); if (my $meta_obj = $self->read_meta) { my $prereqs = $meta_obj->effective_prereqs; my $cr = $prereqs->requirements_for(qw/configure requires/); return $cr ? $cr->as_string_hash : undef; } else { my $yaml = eval { $self->parse_meta_yml($meta_file) }; return $yaml->{configure_requires}; } } #-> sub CPAN::Distribution::prereq_pm ; sub prereq_pm { my($self) = @_; 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); my $meta_obj = $self->read_meta; # META/MYMETA is only authoritative if dynamic_config is false if ($meta_obj && ! $meta_obj->dynamic_config) { my $prereqs = $meta_obj->effective_prereqs; my $requires = $prereqs->requirements_for(qw/runtime requires/); my $build_requires = $prereqs->requirements_for(qw/build requires/); my $test_requires = $prereqs->requirements_for(qw/test requires/); # XXX we don't yet distinguish build vs test, so merge them for now $build_requires->add_requirements($test_requires); $req = $requires->as_string_hash; $breq = $build_requires->as_string_hash; } elsif (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||{}}) { next unless defined $v; 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; } } else { $CPAN::Frontend->mywarnonce("Could not read metadata file. Falling back to other ". "methods to determine prerequisites\n"); } 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 ) { my($m,$n) = ($1,$2); # When a prereq is mentioned twice: let the bigger # win; usual culprit is that they declared # build_requires separately from requires; see # rt.cpan.org #47774 my($prevn); if ( defined $req->{$m} ) { $prevn = $req->{$m}; } if ($n =~ /^q\[(.*?)\]$/) { $n = $1; } if (!$prevn || CPAN::Version->vlt($prevn, $n)){ $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 $/; ; }; my $bphash = eval $content; if ($@) { } else { $req = $bphash->{requires} || +{}; $breq = $bphash->{build_requires} || +{}; } } } } if ($req || $breq) { 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; my $but = $self->_make_test_illuminate_prereqs(); if ( $tests_ok ) { if ($but) { $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 { if ($but) { $but .= "; additionally test harness failed"; $CPAN::Frontend->mywarn("$but\n"); $self->{make_test} = CPAN::Distrostatus->new("NO $but"); } 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 _make_test_illuminate_prereqs { my($self) = @_; 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; } } my $but; if (@prereq) { my $cnt = @prereq; my $which = join ",", @prereq; $but = $cnt == 1 ? "one dependency not OK ($which)" : "$cnt dependencies missing ($which)"; } $but; } 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}) { my $text = UNIVERSAL::can($self->{install},"text") ? $self->{install}->text : $self->{install}; if ($text =~ /^YES/) { $CPAN::Frontend->myprint(" Already done\n"); $CPAN::META->is_installed($self->{build_dir}); return 1; } elsif ($text =~ /is only/) { push @e, $text; } 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 () { $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 () { $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_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->mywarnonce( "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; PK uiZV)G Version.pmnu[package CPAN::Version; use strict; use vars qw($VERSION); $VERSION = "5.5001"; # 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) = @_; $self->vcmp($l,$r) < 0; } sub vge { my($self,$l,$r) = @_; $self->vcmp($l,$r) >= 0; } sub vle { my($self,$l,$r) = @_; $self->vcmp($l,$r) <= 0; } sub vstring { my($self,$n) = @_; $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]"; pack "U*", split /\./, $n; } # vv => visible vstring sub float2vv { my($self,$n) = @_; my($rev) = int($n); $rev ||= 0; my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit # architecture influence $mantissa ||= 0; $mantissa .= "0" while length($mantissa)%3; my $ret = "v" . $rev; while ($mantissa) { $mantissa =~ s/(\d{1,3})// or die "Panic: length>0 but not a digit? mantissa[$mantissa]"; $ret .= ".".int($1); } # warn "n[$n]ret[$ret]"; $ret =~ 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: PK uiZŤŤFTP.pmnu[# -*- 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.5005"; #-> 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; # XXX On Windows flock() implements mandatory locking, so we can # XXX only use shared locking to still allow _yaml_load_file() to # XXX read from the file using a different filehandle. $locktype = LOCK_SH if $^O eq "MSWin32"; $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): $@\n"); return; } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") { my $time = time; my $to = "$file.$time"; $CPAN::Frontend->myprint("Error reading '$file': $@\nStashing away as '$to' to prevent further interruptions. You may want to remove that file later.\n"); rename $file, $to or $CPAN::Frontend->mydie("Could not rename: $!"); return; } } else { $CPAN::Frontend->mydie($@); } } CPAN::_flock($fh, LOCK_UN); 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' or $^O eq 'os2'); _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, $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, $with_defaults) = @_; $with_defaults ||= 0; CPAN->debug("with_defaults[$with_defaults]") if $CPAN::DEBUG; $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}}; push @urllist, @CPAN::Defaultsites if $with_defaults; 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\n"); return; } unless ( $ftp->cwd($dir) ) { my $msg = $ftp->message; $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg\n"); 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\n"); 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,$with_defaults) = @_; $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($with_defaults); $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" && !@$ccurllist; 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 { # ! $defaultsites 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)) { @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; } elsif (-f $ret && $scheme eq 'file' ) { # it's a local file, so there's nothing left to do, we # let them read from where it is } $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) . "\n"); 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->file; } 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" 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 request is for a compressed file and we can find the # uncompressed file also, return the path of the uncompressed file # otherwise, decompress it and return the resulting path if ($l =~ /(.+)\.gz$/) { my $ungz = $1; if ( -f $ungz && -r _) { $ThesiteURL = $ro_url; return $ungz; } elsif (-f $l && -r _) { eval { CPAN::Tarzip->new($l)->gunzip($aslocal) }; if ( -f $aslocal && -s _) { $ThesiteURL = $ro_url; return $aslocal; } elsif (! -s $aslocal) { unlink $aslocal; } elsif (-f $l) { $CPAN::Frontend->mywarn("Error decompressing '$l': $@\n") if $@; return; } } } # Otherwise, return the local file path if it exists elsif ( -f $l && -r _) { $ThesiteURL = $ro_url; return $l; } # If we can't find it, but there is a compressed version # of it, then decompress it elsif (-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; } else { $CPAN::Frontend->mywarn("Error decompressing '$l': $@\n") if $@; return; } } $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:\n$url\n"); 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:\n$gzurl\n"); $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. } } elsif ($url =~ /^http:/ && $CPAN::META->has_usable('HTTP::Tiny')) { require CPAN::HTTP::Client; my $chc = CPAN::HTTP::Client->new( proxy => $CPAN::Config->{http_proxy} || $ENV{http_proxy}, no_proxy => $CPAN::Config->{no_proxy} || $ENV{no_proxy}, ); for my $try ( $url, ( $url !~ /\.gz(?!\n)\Z/ ? "$url.gz" : () ) ) { $CPAN::Frontend->myprint("Fetching with HTTP::Tiny:\n$try\n"); my $res = eval { $chc->mirror($try, $aslocal) }; if ( $res && $res->{success} ) { $ThesiteURL = $ro_url; my $now = time; utime $now, $now, $aslocal; # download time is more # important than upload # time return $aslocal; } elsif ( $res && $res->{status} ne '599') { $CPAN::Frontend->myprint(sprintf( "HTTP::Tiny failed with code[%s] message[%s]\n", $res->{status}, $res->{reason}, ) ); } elsif ( $res && $res->{status} eq '599') { $CPAN::Frontend->myprint(sprintf( "HTTP::Tiny failed with an internal error: %s\n", $res->{content}, ) ); } else { my $err = $@ || 'Unknown error'; $CPAN::Frontend->myprint(sprintf( "Error downloading with HTTP::Tiny: %s\n", $err ) ); } } } 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:\n$url\n"); $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\n$url.gz\n"); 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; my $any_attempt = 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 # making at least one attempt against a host $any_attempt++; $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($src_switch) = ""; my($chdir) = ""; my($stdout_redir) = " > \"$aslocal\""; if ($f eq "lynx") { $src_switch = " -source"; } elsif ($f eq "ncftp") { next DLPRG unless $url =~ m{\Aftp://}; $src_switch = " -c"; } elsif ($f eq "wget") { $src_switch = " -O \"$aslocal\""; $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}"}; } } elsif ($f eq "ncftpget") { next DLPRG unless $url =~ m{\Aftp://}; $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 $aslocal) { my $content = do { local *FH; open FH, $aslocal or die; local $/; }; if ($content =~ /^<.*([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++; } $ThesiteURL = $ro_url; return $aslocal; } 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 return unless $any_attempt; if ($some_dl_success) { $CPAN::Frontend->mywarn("Warning: doesn't seem we had substantial success downloading '$aslocal'. Don't know how to proceed.\n"); } else { $CPAN::Frontend->mywarn("Warning: no success downloading '$aslocal'. Giving up on it.\n"); } 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::HTTP::Credentials->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", "passive", "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 Sending 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 Sending 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; PK����� uiZnaX67��7�� ��Prompt.pmnu�[��������# -*- 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; PK����� uiZ) )K ��K ����HTTP/Credentials.pmnu�[��������# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- # vim: ts=4 sts=4 sw=4: package CPAN::HTTP::Credentials; use strict; use vars qw($USER $PASSWORD $PROXY_USER $PROXY_PASSWORD); $CPAN::HTTP::Credentials::VERSION = $CPAN::HTTP::Credentials::VERSION = "1.9600"; sub clear_credentials { _clear_non_proxy_credentials(); _clear_proxy_credentials(); } sub clear_non_proxy_credentials { undef $USER; undef $PASSWORD; } sub clear_proxy_credentials { undef $PROXY_USER; undef $PROXY_PASSWORD; } sub get_proxy_credentials { my $self = shift; if ($PROXY_USER && $PROXY_PASSWORD) { return ($PROXY_USER, $PROXY_PASSWORD); } if ( defined $CPAN::Config->{proxy_user} && $CPAN::Config->{proxy_user} ) { $PROXY_USER = $CPAN::Config->{proxy_user}; $PROXY_PASSWORD = $CPAN::Config->{proxy_pass} || ""; return ($PROXY_USER, $PROXY_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:"; ($PROXY_USER, $PROXY_PASSWORD) = _get_username_and_password_from_user($username_prompt); return ($PROXY_USER,$PROXY_PASSWORD); } sub get_non_proxy_credentials { my $self = shift; if ($USER && $PASSWORD) { return ($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); } 1; PK����� uiZ/��/����HTTP/Client.pmnu�[��������# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- # vim: ts=4 sts=4 sw=4: package CPAN::HTTP::Client; use strict; use vars qw(@ISA); use CPAN::HTTP::Credentials; use HTTP::Tiny 0.005; $CPAN::HTTP::Client::VERSION = $CPAN::HTTP::Client::VERSION = "1.9600"; # CPAN::HTTP::Client is adapted from parts of cpanm by Tatsuhiko Miyagawa # and parts of LWP by Gisle Aas sub new { my $class = shift; my %args = @_; for my $k ( keys %args ) { $args{$k} = '' unless defined $args{$k}; } $args{no_proxy} = [split(",", $args{no_proxy}) ] if $args{no_proxy}; return bless \%args, $class; } # This executes a request with redirection (up to 5) and returns the # response structure generated by HTTP::Tiny # # If authentication fails, it will attempt to get new authentication # information and repeat up to 5 times sub mirror { my($self, $uri, $path) = @_; my $want_proxy = $self->_want_proxy($uri); my $http = HTTP::Tiny->new( verify_SSL => 1, $want_proxy ? (proxy => $self->{proxy}) : () ); my ($response, %headers); my $retries = 0; while ( $retries++ < 5 ) { $response = $http->mirror( $uri, $path, {headers => \%headers} ); if ( $response->{status} eq '401' ) { last unless $self->_get_auth_params( $response, 'non_proxy' ); } elsif ( $response->{status} eq '407' ) { last unless $self->_get_auth_params( $response, 'proxy' ); } else { last; # either success or failure } my %headers = ( $self->_auth_headers( $uri, 'non_proxy' ), ( $want_proxy ? $self->_auth_headers($uri, 'proxy') : () ), ); } return $response; } sub _want_proxy { my ($self, $uri) = @_; return unless $self->{proxy}; my($host) = $uri =~ m|://([^/:]+)|; return ! grep { $host =~ /\Q$_\E$/ } @{ $self->{no_proxy} || [] }; } # Generates the authentication headers for a given mode # C<mode> is 'proxy' or 'non_proxy' # C<_${mode}_type> is 'basic' or 'digest' # C<_${mode}_params> will be the challenge parameters from the 401/407 headers sub _auth_headers { my ($self, $uri, $mode) = @_; # Get names for our mode-specific attributes my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/; # If _prepare_auth has not been called, we can't prepare headers return unless $self->{$type_key}; # Get user credentials for mode my $cred_method = "get_" . ($mode ? "proxy" : "non_proxy") ."_credentials"; my ($user, $pass) = return CPAN::HTTP::Credentials->$cred_method; # Generate the header for the mode & type my $header = $mode eq 'proxy' ? 'Proxy-Authorization' : 'Authorization'; my $value_method = "_" . $self->{$type_key} . "_auth"; my $value = $self->$value_method($user, $pass, $self->{$param_key}, $uri); # If we didn't get a value, we didn't have the right modules available return $value ? ( $header, $value ) : (); } # Extract authentication parameters from headers, but clear any prior # credentials if we failed (so we might prompt user for password again) sub _get_auth_params { my ($self, $response, $mode) = @_; my $prefix = $mode eq 'proxy' ? 'Proxy' : 'WWW'; my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/; if ( ! $response->{success} ) { # auth failed my $method = "clear_${mode}_credentials"; CPAN::HTTP::Credentials->$method; delete $self->{$_} for $type_key, $param_key; } ($self->{$type_key}, $self->{$param_key}) = $self->_get_challenge( $response, "${prefix}-Authenticate"); return $self->{$type_key}; } # Extract challenge type and parameters for a challenge list sub _get_challenge { my ($self, $response, $auth_header) = @_; my $auth_list = $response->{headers}(lc $auth_header); return unless defined $auth_list; $auth_list = [$auth_list] unless ref $auth_list; for my $challenge (@$auth_list) { $challenge =~ tr/,/;/; # "," is used to separate auth-params!! ($challenge) = $self->split_header_words($challenge); my $scheme = shift(@$challenge); shift(@$challenge); # no value $challenge = { @$challenge }; # make rest into a hash unless ($scheme =~ /^(basic|digest)$/) { next; # bad scheme } $scheme = $1; # untainted now return ($scheme, $challenge); } return; } # Generate a basic authentication header value sub _basic_auth { my ($self, $user, $pass) = @_; unless ( $CPAN::META->has_usable('MIME::Base64') ) { $CPAN::Frontend->mywarn( "MIME::Base64 is required for 'Basic' style authentication" ); return; } return "Basic " . MIME::Base64::encode_base64("$user\:$pass", q{}); } # Generate a digest authentication header value sub _digest_auth { my ($self, $user, $pass, $auth_param, $uri) = @_; unless ( $CPAN::META->has_usable('Digest::MD5') ) { $CPAN::Frontend->mywarn( "Digest::MD5 is required for 'Digest' style authentication" ); return; } my $nc = sprintf "%08X", ++$self->{_nonce_count}{$auth_param->{nonce}}; my $cnonce = sprintf "%8x", time; my ($path) = $uri =~ m{^\w+?://[^/]+(/.*)$}; $path = "/" unless defined $path; my $md5 = Digest::MD5->new; my(@digest); $md5->add(join(":", $user, $auth_param->{realm}, $pass)); push(@digest, $md5->hexdigest); $md5->reset; push(@digest, $auth_param->{nonce}); if ($auth_param->{qop}) { push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop}); } $md5->add(join(":", 'GET', $path)); push(@digest, $md5->hexdigest); $md5->reset; $md5->add(join(":", @digest)); my($digest) = $md5->hexdigest; $md5->reset; my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque); @resp{qw(username uri response algorithm)} = ($user, $path, $digest, "MD5"); if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) { @resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc); } my(@order) = qw(username realm qop algorithm uri nonce nc cnonce response opaque); my @pairs; for (@order) { next unless defined $resp{$_}; push(@pairs, "$_=" . qq("$resp{$_}")); } my $auth_value = "Digest " . join(", ", @pairs); return $auth_value; } # split_header_words adapted from HTTP::Headers::Util sub split_header_words { my ($self, @words) = @_; my @res = $self->_split_header_words(@words); for my $arr (@res) { for (my $i = @$arr - 2; $i >= 0; $i -= 2) { $arr->[$i] = lc($arr->[$i]); } } return @res; } sub _split_header_words { my($self, @val) = @_; my @res; for (@val) { my @cur; while (length) { if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute' push(@cur, $1); # a quoted value if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) { my $val = $1; $val =~ s/\\(.)/$1/g; push(@cur, $val); # some unquoted value } elsif (s/^\s*=\s*([^;,\s]*)//) { my $val = $1; $val =~ s/\s+$//; push(@cur, $val); # no value, a lone token } else { push(@cur, undef); } } elsif (s/^\s*,//) { push(@res, [@cur]) if @cur; @cur = (); } elsif (s/^\s*;// || s/^\s+//) { # continue } else { die "This should not happen: '$_'"; } } push(@res, \@cur) if @cur; } @res; } 1; PK����� uiZU ZK>��>�� ��Tarzip.pmnu�[��������# -*- 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.5011"; # 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; my $me = { FILE => $file }; if ($file =~ /\.(bz2|gz|zip|tbz|tgz)$/i) { $me->{ISCOMPRESSED} = 1; } else { $me->{ISCOMPRESSED} = 0; } if (0) { } elsif ($file =~ /\.(?:bz2|tbz)$/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 bzip2' from the CPAN shell prompt 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; if ($read=~/\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) { my($buffer,$len); $len = 0; my $gz = Compress::Bzip2::bzopen($read, "rb") or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n", $read, $Compress::Bzip2::bzerrno)); while ($gz->bzread($buffer) > 0 ) { $len += length($buffer); $buffer = ""; } my $err = $gz->bzerror; $success = ! $err || $err == Compress::Bzip2::BZ_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; } elsif ( $read=~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib") ) { # After I had reread the documentation in zlib.h, I discovered that # uncompressed files do not lead to an gzerror (anymore?). 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; } elsif (!$self->{ISCOMPRESSED}) { $success = 0; } 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 ($file =~ /\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) { my $gz = Compress::Bzip2::bzopen($file,"rb") or $CPAN::Frontend->mydie("Could not bzopen $file"); $self->{GZ} = $gz; $class->debug("via Compress::Bzip2"); } elsif ($file =~/\.(?:gz|tgz)$/ && $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 ($CPAN::Config->{prefer_external_tar}) { $prefer = 1; } elsif ( $CPAN::META->has_usable("Archive::Tar") && $CPAN::META->has_inst("Compress::Zlib") ) { my $prefer_external_tar = $CPAN::Config->{prefer_external_tar}; unless (defined $prefer_external_tar) { if ($^O =~ /(MSWin32|solaris)/) { $prefer_external_tar = 0; } else { $prefer_external_tar = 1; } } $prefer = $prefer_external_tar ? 1 : 2; } elsif ($exttar && $extgzip) { # no modules and not bz2 $prefer = 1; # but solaris binary tar is a problem if ($^O eq 'solaris' && qx($exttar --version 2>/dev/null) !~ /gnu/i) { $CPAN::Frontend->mywarn(<< 'END_WARN'); WARNING: Many CPAN distributions were archived with GNU tar and some of them may be incompatible with Solaris tar. We respectfully suggest you configure CPAN to use a GNU tar instead ("o conf init tar") or install a recent Archive::Tar instead; END_WARN } } 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; } elsif ( my $unzip = $CPAN::Config->{unzip} ) { my @system = ($unzip, $file); return system(@system) == 0; } else { $CPAN::Frontend->mydie(<<"END"); Can't unzip '$file': You have not configured an 'unzip' program and do not have Archive::Zip installed. Please either install Archive::Zip or else configure 'unzip' by running the command 'o conf init unzip' from the CPAN shell prompt. END } } 1; __END__ =head1 NAME CPAN::Tarzip - internal handling of tar archives for CPAN.pm =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK����� uiZH���� ��FTP/netrc.pmnu�[��������package CPAN::FTP::netrc; use strict; $CPAN::FTP::netrc::VERSION = $CPAN::FTP::netrc::VERSION = "1.01"; # package CPAN::FTP::netrc; sub new { my($class) = @_; my $file = File::Spec->catfile($ENV{HOME},".netrc"); my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat($file); $mode ||= 0; my $protected = 0; my($fh,@machines,$hasdefault); $hasdefault = 0; $fh = FileHandle->new or die "Could not create a filehandle"; 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; PK����� uiZ;����Shell.pmnu�[��������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.5002"; # 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; my @m = @_; for (@m) { if (m|(?:\w+/)*\w+\.pm$|) { # same regexp in expandany s/.pm$//; s|/|::|g; } } $CPAN::Frontend->myprint($self->format_result('Module',@m)); } #-> 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); my $configpm = CPAN::HandleConfig->require_myconfig_or_config; $CPAN::Frontend->myprint("\$CPAN::Config options from $configpm\:\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) = @_; if ( my $configpm = $INC{'CPAN/MyConfig.pm'} ) { $CPAN::Frontend->myprint( "CPAN::MyConfig already exists as $configpm.\n" . "Running configuration again...\n" ); require CPAN::FirstTime; CPAN::FirstTime::init($configpm); } else { # force some missing values to be filled in with defaults delete $CPAN::Config->{$_} for qw/build_dir cpan_home keep_source_where histfile/; CPAN::HandleConfig->load( make_myconfig => 1 ); } } #-> 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", # hide from perl-reversion "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"); return $to; } #-> sub CPAN::Shell::expandany ; sub expandany { my($self,$s) = @_; CPAN->debug("s[$s]") if $CPAN::DEBUG; my $module_as_path = ""; if ($s =~ m|(?:\w+/)*\w+\.pm$|) { # same regexp in sub m $module_as_path = $s; $module_as_path =~ s/.pm$//; $module_as_path =~ s|/|::|g; } if ($module_as_path) { if ($module_as_path =~ m|^Bundle::|) { $self->local_bundles; return $self->expand('Bundle',$module_as_path); } else { return $self->expand('Module',$module_as_path) if $CPAN::META->exists('CPAN::Module',$module_as_path); } } elsif ($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 ) { # WARNING: variable Be_Silent is poisoned and must be eliminated. 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', ); } my %already_printed; #-> sub CPAN::Shell::mywarnonce ; sub myprintonce { my($self,$what) = @_; $self->myprint($what) unless $already_printed{$what}++; } 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'); } my %already_warned; #-> sub CPAN::Shell::mywarnonce ; sub mywarnonce { my($self,$what) = @_; $self->mywarn($what) unless $already_warned{$what}++; } # 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; # this variable was global and disturbed programmers, so localize: local $CPAN::Distrostatus::something_has_failed_at; 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 { my @obj; CLASS: for my $class (qw(Distribution Bundle Module)) { if (@obj = $self->expand($class,$s)) { last CLASS; } } if (@obj) { if (1==@obj) { $obj = $obj[0]; } else { $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ". "only supported when unambiguous.\nRejecting argument '$s'\n"); $CPAN::Frontend->mysleep(2); next STHING; } } } } 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("Testing 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("Fetching '$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 "Downloading and testing '$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; PK����� uiZ5S>$��$�� ��Bundle.pmnu�[��������# -*- 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; PK������� uiZw)#9��9������������������Kwalify/distroprefs.ymlnu�[��������PK������� uiZ< �� ����������������Kwalify/distroprefs.ddnu�[��������PK������� uiZMܪpZ��pZ��������������a��HandleConfig.pmnu�[��������PK������� uiZH���� ������������n��CacheMgr.pmnu�[��������PK������� uiZך9L��L��������������:��URL.pmnu�[��������PK������� uiZ$d ��d �� ��������������Kwalify.pmnu�[��������PK������� uiZg[c��c�� ������������Z��Complete.pmnu�[��������PK������� uiZj8:��8:�� ��������������Mirrors.pmnu�[��������PK������� uiZް �� �� ������������j��Config.pmnu�[��������PK������� uiZM���� ������������L��Author.pmnu�[��������PK������� uiZ䍽������������������>�DeferredCode.pmnu�[��������PK������� uiZiۨD����������������:�Distrostatus.pmnu�[��������PK������� uiZ}l+��+�� ������������E�API/HOWTO.podnu�[��������PK������� uiZЧ���� �������������InfoObj.pmnu�[��������PK������� uiZuy]V��V�� ������������7�Module.pmnu�[��������PK������� uiZ|­!:��:��������������-�Queue.pmnu�[��������PK������� uiZ$U��U���������������Index.pmnu�[��������PK������� uiZܑH�����������������Exception/yaml_process_error.pmnu�[��������PK������� uiZ*^�����������������Exception/blocked_urllist.pmnu�[��������PK������� uiZ �� �� ������������i�Exception/RecursiveDependency.pmnu�[��������PK������� uiZT�����������������Exception/yaml_not_installed.pmnu�[��������PK������� uiZ* __+��_+���������������Distroprefs.pmnu�[��������PK������� uiZ � � ������������lB�FirstTime.pmnu�[��������PK������� uiZeJM����������������N�Nox.pmnu�[��������PK������� uiZs �� ��������������mR�LWP/UserAgent.pmnu�[��������PK������� uiZz6��6��������������]�Debug.pmnu�[��������PK������� uiZ;]D�]D�������������f�Distribution.pmnu�[��������PK������� uiZV)G���� �������������Version.pmnu�[��������PK������� uiZŤ��Ť���������������FTP.pmnu�[��������PK������� uiZnaX67��7�� ������������`�Prompt.pmnu�[��������PK������� uiZ) )K ��K ��������������c�HTTP/Credentials.pmnu�[��������PK������� uiZ/��/��������������m�HTTP/Client.pmnu�[��������PK������� uiZU ZK>��>�� �������������Tarzip.pmnu�[��������PK������� uiZH���� �������������FTP/netrc.pmnu�[��������PK������� uiZ;��������������n�Shell.pmnu�[��������PK������� uiZ5S>$��$�� ������������t�Bundle.pmnu�[��������PK����$�$� �����