diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPAN')
21 files changed, 1482 insertions, 379 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm b/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm index b9b4eeb32bf..23e756e75b2 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm @@ -49,6 +49,7 @@ sub tidyup { $self->_clean_cache($toremove); return if $CPAN::Signal; } + $self->{FIFO} = []; } #-> sub CPAN::CacheMgr::dir ; diff --git a/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm b/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm index 637ab277d96..32648ecc1ff 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm @@ -8,7 +8,7 @@ use CPAN::InfoObj; use File::Path (); @CPAN::Distribution::ISA = qw(CPAN::InfoObj); use vars qw($VERSION); -$VERSION = "1.9602_01"; +$VERSION = "1.9602"; # Accessors sub cpan_comment { @@ -158,7 +158,7 @@ sub tested_ok_but_not_installed { || $self->{install}->failed ) - ); + ); } @@ -741,7 +741,7 @@ sub choose_MM_or_MB { $prefer_installer = CPAN::HandleConfig->prefs_lookup( $self, q{prefer_installer} ); - # M::B <= 0.35 left a DATA handle open that + # 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; @@ -777,6 +777,12 @@ sub choose_MM_or_MB { 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}, ". @@ -859,7 +865,7 @@ sub try_download { } } my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches"); - $CPAN::Frontend->myprint("Going to apply $countedpatches:\n"); + $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)) { @@ -1845,7 +1851,7 @@ is part of the perl-%s distribution. To install that, you need to run delete $self->{force_update}; return; } - $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n"); + $CPAN::Frontend->myprint("\n CPAN.pm: Building ".$self->id."\n\n"); $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; if ($^O eq 'MacOS') { @@ -2886,8 +2892,8 @@ sub read_yaml { 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; + 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} ) { @@ -3167,7 +3173,7 @@ sub test { # 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") + && $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 @@ -3287,43 +3293,43 @@ sub test { 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 @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; + if (@prereq) { + my $cnt = @prereq; + my $which = join ",", @prereq; $but = $cnt == 1 ? "one dependency not OK ($which)" : - "$cnt dependencies missing ($which)"; - } + "$cnt dependencies missing ($which)"; + } $but; } @@ -3669,7 +3675,7 @@ sub perldoc { $CPAN::Frontend->myprint(qq{ Function system("@args") returned status $estatus (wstat $wstatus) - }); + }); } } else { diff --git a/Master/tlpkg/tlperl/lib/CPAN/Distroprefs.pm b/Master/tlpkg/tlperl/lib/CPAN/Distroprefs.pm index e1be9cdf749..61c389ed2d3 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Distroprefs.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Distroprefs.pm @@ -169,7 +169,7 @@ sub find { file => $_, ext => $ext, dir => $dir }); # copied from CPAN.pm; is this ever actually possible? - redo unless -f $result->abs; + redo unless -f $result->abs; my $load_method = $self->_load_method($loader, $result); my @prefs = eval { $self->$load_method($loader, $result) }; @@ -314,7 +314,7 @@ __END__ CPAN::Distroprefs -- read and match distroprefs -=head1 SYNOPSIS +=head1 SYNOPSIS use CPAN::Distroprefs; @@ -381,7 +381,7 @@ All results share some common attributes: C<success>, C<warning>, or C<fatal> -=head3 file +=head3 file the file from which these prefs were read, or to which this error refers (relative filename) @@ -413,7 +413,7 @@ Success results contain: an arrayref of CPAN::Distroprefs::Pref objects -=head1 PREFS +=head1 PREFS CPAN::Distroprefs::Pref objects represent individual distroprefs documents. They are constructed automatically as part of C<success> results from C<find()>. diff --git a/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm b/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm index e1259e5397d..1e7fa83a53b 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm @@ -20,54 +20,4 @@ sub as_string { "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n"; } -package CPAN::Exception::yaml_process_error; -use strict; -use overload '""' => "as_string"; - -use vars qw( - $VERSION -); -$VERSION = "5.5"; - - -sub new { - my($class,$module,$file,$during,$error) = @_; - # my $at = Carp::longmess(""); # XXX find something more beautiful - bless { module => $module, - file => $file, - during => $during, - error => $error, - # at => $at, - }, $class; -} - -sub as_string { - my($self) = shift; - if ($self->{during}) { - if ($self->{file}) { - if ($self->{module}) { - if ($self->{error}) { - return "Alert: While trying to '$self->{during}' YAML file\n". - " '$self->{file}'\n". - "with '$self->{module}' the following error was encountered:\n". - " $self->{error}\n"; - } else { - return "Alert: While trying to '$self->{during}' YAML file\n". - " '$self->{file}'\n". - "with '$self->{module}' some unknown error was encountered\n"; - } - } else { - return "Alert: While trying to '$self->{during}' YAML file\n". - " '$self->{file}'\n". - "some unknown error was encountered\n"; - } - } else { - return "Alert: While trying to '$self->{during}' some YAML file\n". - "some unknown error was encountered\n"; - } - } else { - return "Alert: unknown error encountered\n"; - } -} - 1; diff --git a/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_process_error.pm b/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_process_error.pm new file mode 100644 index 00000000000..ae8c14ebebe --- /dev/null +++ b/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_process_error.pm @@ -0,0 +1,53 @@ +# -*- 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; diff --git a/Master/tlpkg/tlperl/lib/CPAN/FTP.pm b/Master/tlpkg/tlperl/lib/CPAN/FTP.pm index 4f233814e54..997e141be5a 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/FTP.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/FTP.pm @@ -21,6 +21,11 @@ $VERSION = "5.5005"; 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; @@ -56,6 +61,7 @@ sub _ftp_statistics { $CPAN::Frontend->mydie($@); } } + CPAN::_flock($fh, LOCK_UN); return $stats->[0]; } @@ -567,7 +573,7 @@ sub hostdleasy { #called from hostdlxxx $ThesiteURL = $ro_url; return $l; } - # If request is for a compressed file and we can find the + # 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$/) { @@ -975,7 +981,7 @@ ftp config variable with Trying with external ftp to get '$url' $netrc_explain - Going to send the dialog + Sending the dialog $dialog } ); @@ -1014,7 +1020,7 @@ $dialog $CPAN::Frontend->myprint(qq{ Trying with external ftp to get $url - Going to send the dialog + Sending the dialog $dialog } ); diff --git a/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm b/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm index 667bdca2f9a..5030ef9b838 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm @@ -202,8 +202,8 @@ 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. +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)? @@ -339,7 +339,7 @@ Your choice: Parameters for the './Build install' command? Typical frequently used setting: - --uninst 1 # uninstall conflicting files + --uninst 1 # uninstall conflicting files # (but do NOT use with local::lib or INSTALL_BASE) Your choice: @@ -781,8 +781,8 @@ sub init { if ( $args{autoconfig} ) { $auto_config = 1; } elsif ($matcher) { - $auto_config = 0; - } else { + $auto_config = 0; + } else { my $_conf = prompt($prompts{auto_config}, "yes"); $auto_config = ($_conf and $_conf =~ /^y/i) ? 1 : 0; } @@ -795,7 +795,7 @@ sub init { my $i_am_mad = 0; # silent prompting -- just quietly use default *_real_prompt = sub { return $_[1] }; - } + } # # bootstrap local::lib or sudo @@ -993,8 +993,8 @@ sub init { 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" . + $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" ); } @@ -1224,9 +1224,9 @@ sub init { ); } else { - $CPAN::Frontend->myprint( - "Autoconfigured everything but 'urllist'.\n" - ); + $CPAN::Frontend->myprint( + "Autoconfigured everything but 'urllist'.\n" + ); _do_pick_mirrors(); } } @@ -1247,8 +1247,8 @@ sub init { $CPAN::Frontend->myprint( "Skipping local::lib bootstrap because 'urllist' is not configured.\n" ); - } - else { + } + 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 @@ -1268,11 +1268,11 @@ sub init { $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(); - } + } } } @@ -1515,7 +1515,7 @@ 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") { + if ($^O eq "MSWin32") { $CPAN::Frontend->mywarn(<<"HERE"); Windows users may want to follow this procedure when back in the CPAN shell: @@ -1528,7 +1528,7 @@ substitute. You can then revisit this dialog with o conf init make HERE - } + } } sub init_cpan_home { @@ -1657,7 +1657,7 @@ sub my_prompt_loop { # (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, +# (2b) If we aren't allowed to connect, sub conf_sites { my %args = @_; @@ -1732,7 +1732,7 @@ HERE } else { $CPAN::Frontend->mywarn(<<'HERE'); -You will need to provide CPAN mirror URLs yourself or set +You will need to provide CPAN mirror URLs yourself or set 'o conf connect_to_internet_ok 1' and try again. HERE } @@ -1851,7 +1851,9 @@ 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($local); + my $mirrors = CPAN::Mirrors->new; + $mirrors->parse_mirrored_by($local); + my $cnt = 0; my @best = $mirrors->best_mirrors( how_many => 3, @@ -1860,9 +1862,11 @@ sub auto_mirrored_by { 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 } @@ -1998,8 +2002,8 @@ later if you\'re sure it\'s right.\n}, sub _print_urllist { my ($which) = @_; $CPAN::Frontend->myprint("$which urllist\n"); - for ( @{$CPAN::Config->{urllist} || []} ) { - $CPAN::Frontend->myprint(" $_\n") + for ( @{$CPAN::Config->{urllist} || []} ) { + $CPAN::Frontend->myprint(" $_\n") }; } diff --git a/Master/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm b/Master/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm index 52de7fe237c..c5eb0f6a435 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm @@ -31,8 +31,8 @@ sub mirror { my($self, $uri, $path) = @_; my $want_proxy = $self->_want_proxy($uri); - my $http = HTTP::Tiny->new( - $want_proxy ? (proxy => $self->{proxy}) : () + my $http = HTTP::Tiny->new( + $want_proxy ? (proxy => $self->{proxy}) : () ); my ($response, %headers); @@ -112,7 +112,7 @@ sub _get_challenge { 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); diff --git a/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm b/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm index 58ccbe50e5d..09c42efee08 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm @@ -265,11 +265,11 @@ 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" - ); + $CPAN::Frontend->mydie( + "'o conf commit' disabled in ". + "degraded mode. Maybe try\n". + " !undef \$CPAN::RUN_DEGRADED\n" + ); } my ($configpm, $must_reload); @@ -474,13 +474,13 @@ sub init { 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 @@ -495,8 +495,8 @@ sub _try_loading { if ( -f File::Spec->catfile($dir, $file) ) { unshift @INC, $dir; last; + } } - } eval { require $file }; my $err_myconfig = $@; @@ -515,7 +515,7 @@ sub cpan_home_dir_candidates { if ($^O ne 'darwin') { push @dirs, File::HomeDir->my_data; # my_data is ~/Library/Application Support on darwin, - # which causes issues in the toolchain. + # which causes issues in the toolchain. } push @dirs, File::HomeDir->my_home; } @@ -592,7 +592,7 @@ sub make_new_config { Old configuration file $configpm moved to $configpm_bak END - } + } } my $fh = FileHandle->new; if ($fh->open(">$configpm")) { diff --git a/Master/tlpkg/tlperl/lib/CPAN/Index.pm b/Master/tlpkg/tlperl/lib/CPAN/Index.pm index 4fcde8c390d..af98d7bf15c 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Index.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Index.pm @@ -132,7 +132,7 @@ sub reanimate_build_dir { return; } $CPAN::Frontend->myprint - (sprintf("Going to read %d yaml file%s from %s/\n", + (sprintf("Reading %d yaml file%s from %s/\n", scalar @candidates, @candidates==1 ? "" : "s", $CPAN::Config->{build_dir} @@ -231,7 +231,7 @@ sub rd_authindex { return unless defined $index_target; return if CPAN::_sqlite_running(); my @lines; - $CPAN::Frontend->myprint("Going to read '$index_target'\n"); + $CPAN::Frontend->myprint("Reading '$index_target'\n"); local(*FH); tie *FH, 'CPAN::Tarzip', $index_target; local($/) = "\n"; @@ -271,7 +271,7 @@ sub rd_modpacks { my($self, $index_target) = @_; return unless defined $index_target; return if CPAN::_sqlite_running(); - $CPAN::Frontend->myprint("Going to read '$index_target'\n"); + $CPAN::Frontend->myprint("Reading '$index_target'\n"); my $fh = CPAN::Tarzip->TIEHANDLE($index_target); local $_; CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG; @@ -494,7 +494,7 @@ sub rd_modlist { my($cl,$index_target) = @_; return unless defined $index_target; return if CPAN::_sqlite_running(); - $CPAN::Frontend->myprint("Going to read '$index_target'\n"); + $CPAN::Frontend->myprint("Reading '$index_target'\n"); my $fh = CPAN::Tarzip->TIEHANDLE($index_target); local $_; my $slurp = ""; @@ -556,7 +556,7 @@ sub write_metadata_cache { $cache->{last_time} = $LAST_TIME; $cache->{DATE_OF_02} = $DATE_OF_02; $cache->{PROTOCOL} = PROTOCOL; - $CPAN::Frontend->myprint("Going to write $metadata_file\n"); + $CPAN::Frontend->myprint("Writing $metadata_file\n"); eval { Storable::nstore($cache, $metadata_file) }; $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ?? } @@ -569,7 +569,7 @@ sub read_metadata_cache { return unless $CPAN::META->has_usable("Storable"); my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata"); return unless -r $metadata_file and -f $metadata_file; - $CPAN::Frontend->myprint("Going to read '$metadata_file'\n"); + $CPAN::Frontend->myprint("Reading '$metadata_file'\n"); my $cache; eval { $cache = Storable::retrieve($metadata_file) }; $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ?? diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta.pm index ef798559fb4..f8185983a42 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Meta.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Meta.pm @@ -2,10 +2,7 @@ use 5.006; use strict; use warnings; package CPAN::Meta; -BEGIN { - $CPAN::Meta::VERSION = '2.110440'; -} -# ABSTRACT: the distribution metadata for a CPAN dist +our $VERSION = '2.120630'; # VERSION use Carp qw(carp croak); @@ -13,7 +10,9 @@ use CPAN::Meta::Feature; use CPAN::Meta::Prereqs; use CPAN::Meta::Converter; use CPAN::Meta::Validator; -use Parse::CPAN::Meta 1.44 (); +use Parse::CPAN::Meta 1.4400 (); + +BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone } BEGIN { @@ -47,7 +46,7 @@ BEGIN { my $value = $_[0]{ $attr }; croak "$attr must be called in list context" unless wantarray; - return @{ Storable::dclone($value) } if ref $value; + return @{ _dclone($value) } if ref $value; return $value; }; } @@ -73,7 +72,7 @@ BEGIN { (my $subname = $attr) =~ s/-/_/; *$subname = sub { my $value = $_[0]{ $attr }; - return Storable::dclone($value) if $value; + return _dclone($value) if $value; return {}; }; } @@ -87,7 +86,7 @@ sub custom_keys { sub custom { my ($self, $attr) = @_; my $value = $self->{$attr}; - return Storable::dclone($value) if ref $value; + return _dclone($value) if ref $value; return $value; } @@ -215,7 +214,6 @@ sub save { } -# XXX Do we need this if we always upconvert? -- dagolden, 2010-04-14 sub meta_spec_version { my ($self) = @_; return $self->meta_spec->{version}; @@ -290,10 +288,7 @@ sub feature { sub as_struct { my ($self, $options) = @_; - my $backend = Parse::CPAN::Meta->json_backend(); - my $struct = $backend->new->decode( - $backend->new->convert_blessed->encode($self) - ); + my $struct = _dclone($self); if ( $options->{version} ) { my $cmc = CPAN::Meta::Converter->new( $struct ); $struct = $cmc->convert( version => $options->{version} ); @@ -308,7 +303,7 @@ sub as_string { my $version = $options->{version} || '2'; my $struct; - if ( $self->version ne $version ) { + if ( $self->meta_spec_version ne $version ) { my $cmc = CPAN::Meta::Converter->new( $self->as_struct ); $struct = $cmc->convert( version => $version ); } @@ -339,6 +334,8 @@ sub TO_JSON { 1; +# ABSTRACT: the distribution metadata for a CPAN dist + =pod @@ -349,7 +346,7 @@ CPAN::Meta - the distribution metadata for a CPAN dist =head1 VERSION -version 2.110440 +version 2.120630 =head1 SYNOPSIS @@ -644,6 +641,10 @@ particular keys may be retrieved with the C<custom> method. If a custom key refers to a data structure, a deep clone is returned. +=for Pod::Coverage TO_JSON abstract author authors custom custom_keys description dynamic_config +generated_by keywords license licenses meta_spec name no_index +optional_features prereqs provides release_status resources version + =head1 BUGS Please report any bugs or feature using the CPAN Request Tracker. @@ -667,6 +668,25 @@ L<CPAN::Meta::Validator> =back +=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + +=head1 SUPPORT + +=head2 Bugs / Feature Requests + +Please report any bugs or feature requests through the issue tracker +at L<http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta>. +You will be notified automatically of any progress on your issue. + +=head2 Source Code + +This is open source software. The code repository is available for +public review and contribution under the terms of the license. + +L<http://github.com/dagolden/cpan-meta> + + git clone git://github.com/dagolden/cpan-meta.git + =head1 AUTHORS =over 4 diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm index 2c6ce857d3d..0348e55504e 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm @@ -2,15 +2,29 @@ use 5.006; use strict; use warnings; package CPAN::Meta::Converter; -BEGIN { - $CPAN::Meta::Converter::VERSION = '2.110440'; -} -# ABSTRACT: Convert CPAN distribution metadata structures +our $VERSION = '2.120630'; # VERSION use CPAN::Meta::Validator; -use Storable qw/dclone/; -use version 0.82 (); +use CPAN::Meta::Requirements; +use version 0.88 (); +use Parse::CPAN::Meta 1.4400 (); + +sub _dclone { + my $ref = shift; + + # if an object is in the data structure and doesn't specify how to + # turn itself into JSON, we just stringify the object. That does the + # right thing for typical things that might be there, like version objects, + # Path::Class objects, etc. + no warnings 'once'; + local *UNIVERSAL::TO_JSON = sub { return "$_[0]" }; + + my $backend = Parse::CPAN::Meta->json_backend(); + return $backend->new->utf8->decode( + $backend->new->utf8->allow_blessed->convert_blessed->encode($ref) + ); +} my %known_specs = ( '2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', @@ -134,15 +148,18 @@ my @valid_licenses_2 = qw( unknown ); +# The "old" values were defined by Module::Build, and were often vague. I have +# made the decisions below based on reading Module::Build::API and how clearly +# it specifies the version of the license. my %license_map_2 = ( - ( map { $_ => $_ } @valid_licenses_2 ), - apache => 'apache_2_0', - artistic => 'artistic_1', - artistic2 => 'artistic_2', - gpl => 'gpl_1', - lgpl => 'lgpl_2_1', - mozilla => 'mozilla_1_0', - perl => 'perl_5', + (map { $_ => $_ } @valid_licenses_2), + apache => 'apache_2_0', # clearly stated as 2.0 + artistic => 'artistic_1', # clearly stated as 1 + artistic2 => 'artistic_2', # clearly stated as 2 + gpl => 'open_source', # we don't know which GPL; punt + lgpl => 'open_source', # we don't know which LGPL; punt + mozilla => 'open_source', # we don't know which MPL; punt + perl => 'perl_5', # clearly Perl 5 restrictive => 'restricted', ); @@ -300,7 +317,10 @@ sub _clean_version { return 0 if ! length $element; return 0 if ( $element eq 'undef' || $element eq '<undef>' ); - if ( my $v = eval { version->new($element) } ) { + my $v = eval { version->new($element) }; + # XXX check defined $v and not just $v because version objects leak memory + # in boolean context -- dagolden, 2012-02-03 + if ( defined $v ) { return $v->is_qv ? $v->normal : $element; } else { @@ -308,29 +328,36 @@ sub _clean_version { } } +sub _bad_version_hook { + my ($v) = @_; + $v =~ s{[a-z]+$}{}; # strip trailing alphabetics + my $vobj = eval { version->parse($v) }; + return defined($vobj) ? $vobj : version->parse(0); # or give up +} + sub _version_map { my ($element) = @_; - return undef unless defined $element; + return unless defined $element; if ( ref $element eq 'HASH' ) { - my $new_map = {}; - for my $k ( keys %$element ) { + # XXX turn this into CPAN::Meta::Requirements with bad version hook + # and then turn it back into a hash + my $new_map = CPAN::Meta::Requirements->new( + { bad_version_hook => sub { version->new(0) } } # punt + ); + while ( my ($k,$v) = each %$element ) { next unless _is_module_name($k); - my $value = $element->{$k}; - if ( ! ( defined $value && length $value ) ) { - $new_map->{$k} = 0; - } - elsif ( $value eq 'undef' || $value eq '<undef>' ) { - $new_map->{$k} = 0; + if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>' ) { + $v = 0; } - elsif ( _is_module_name( $value ) ) { # some weird, old META have this - $new_map->{$k} = 0; - $new_map->{$value} = 0; - } - else { - $new_map->{$k} = _clean_version($value); + # some weird, old META have bad yml with module => module + # so check if value is like a module name and not like a version + if ( _is_module_name($v) && ! version::is_lax($v) ) { + $new_map->add_minimum($k => 0); + $new_map->add_minimum($v => 0); } + $new_map->add_string_requirement($k => $v); } - return $new_map; + return $new_map->as_string_hash; } elsif ( ref $element eq 'ARRAY' ) { my $hashref = { map { $_ => 0 } @$element }; @@ -413,9 +440,8 @@ sub _get_build_requires { my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {}; my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {}; - require Version::Requirements; - my $test_req = Version::Requirements->from_string_hash($test_h); - my $build_req = Version::Requirements->from_string_hash($build_h); + my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h); + my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h); $test_req->add_requirements($build_req)->as_string_hash; } @@ -423,12 +449,12 @@ sub _get_build_requires { sub _extract_prereqs { my ($prereqs, $phase, $type) = @_; return unless ref $prereqs eq 'HASH'; - return $prereqs->{$phase}{$type}; + return scalar _version_map($prereqs->{$phase}{$type}); } sub _downgrade_optional_features { my (undef, undef, $meta) = @_; - return undef unless exists $meta->{optional_features}; + return unless exists $meta->{optional_features}; my $origin = $meta->{optional_features}; my $features = {}; for my $name ( keys %$origin ) { @@ -449,7 +475,7 @@ sub _downgrade_optional_features { sub _upgrade_optional_features { my (undef, undef, $meta) = @_; - return undef unless exists $meta->{optional_features}; + return unless exists $meta->{optional_features}; my $origin = $meta->{optional_features}; my $features = {}; for my $name ( keys %$origin ) { @@ -545,7 +571,7 @@ my $resource2_upgrade = { return unless $item; if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } } elsif( _is_urlish($item) ) { return { web => $item } } - else { return undef } + else { return } }, repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef }, ':custom' => \&_prefix_custom, @@ -553,7 +579,7 @@ my $resource2_upgrade = { sub _upgrade_resources_2 { my (undef, undef, $meta, $version) = @_; - return undef unless exists $meta->{resources}; + return unless exists $meta->{resources}; return _convert($meta->{resources}, $resource2_upgrade); } @@ -591,7 +617,7 @@ my $resources2_cleanup = { sub _cleanup_resources_2 { my ($resources, $key, $meta, $to_version) = @_; - return undef unless $resources && ref $resources eq 'HASH'; + return unless $resources && ref $resources eq 'HASH'; return _convert($resources, $resources2_cleanup, $to_version); } @@ -605,7 +631,7 @@ my $resource1_spec = { sub _resources_1_3 { my (undef, undef, $meta, $version) = @_; - return undef unless exists $meta->{resources}; + return unless exists $meta->{resources}; return _convert($meta->{resources}, $resource1_spec); } @@ -618,7 +644,7 @@ sub _resources_1_2 { $resources->{license} = $meta->license_url if _is_urlish($meta->{license_url}); } - return undef unless keys %$resources; + return unless keys %$resources; return _convert($resources, $resource1_spec); } @@ -632,7 +658,7 @@ my $resource_downgrade_spec = { sub _downgrade_resources { my (undef, undef, $meta, $version) = @_; - return undef unless exists $meta->{resources}; + return unless exists $meta->{resources}; return _convert($meta->{resources}, $resource_downgrade_spec); } @@ -1187,7 +1213,7 @@ sub convert { my $new_version = $args->{version} || $HIGHEST; my ($old_version) = $self->{spec}; - my $converted = dclone $self->{data}; + my $converted = _dclone($self->{data}); if ( $old_version == $new_version ) { $converted = _convert( $converted, $cleanup{$old_version}, $old_version ); @@ -1232,6 +1258,8 @@ sub convert { 1; +# ABSTRACT: Convert CPAN distribution metadata structures + =pod @@ -1242,7 +1270,7 @@ CPAN::Meta::Converter - Convert CPAN distribution metadata structures =head1 VERSION -version 2.110440 +version 2.120630 =head1 SYNOPSIS diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm index d3575e5e7e8..cd7689e9a67 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm @@ -2,10 +2,7 @@ use 5.006; use strict; use warnings; package CPAN::Meta::Feature; -BEGIN { - $CPAN::Meta::Feature::VERSION = '2.110440'; -} -# ABSTRACT: an optional feature provided by a CPAN distribution +our $VERSION = '2.120630'; # VERSION use CPAN::Meta::Prereqs; @@ -33,6 +30,8 @@ sub prereqs { $_[0]{prereqs} } 1; +# ABSTRACT: an optional feature provided by a CPAN distribution + =pod @@ -43,7 +42,7 @@ CPAN::Meta::Feature - an optional feature provided by a CPAN distribution =head1 VERSION -version 2.110440 +version 2.120630 =head1 DESCRIPTION diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/History.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/History.pm index ab036907a49..001686e1b70 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Meta/History.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/History.pm @@ -3,12 +3,12 @@ use 5.006; use strict; use warnings; package CPAN::Meta::History; -BEGIN { - $CPAN::Meta::History::VERSION = '2.110440'; -} -# ABSTRACT: history of CPAN Meta Spec changes +our $VERSION = '2.120630'; # VERSION + 1; +# ABSTRACT: history of CPAN Meta Spec changes + __END__ @@ -20,7 +20,7 @@ CPAN::Meta::History - history of CPAN Meta Spec changes =head1 VERSION -version 2.110440 +version 2.120630 =head1 DESCRIPTION @@ -242,7 +242,7 @@ Added 'resources' field with subkeys 'homepage', 'license', and =item * -Added 'optional_features' field as an alterate under 'recommends'. +Added 'optional_features' field as an alternate under 'recommends'. Includes 'description', 'requires', 'build_requires', 'conflicts', 'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm index 4fc20939abd..640a299a01d 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm @@ -2,15 +2,12 @@ use 5.006; use strict; use warnings; package CPAN::Meta::Prereqs; -BEGIN { - $CPAN::Meta::Prereqs::VERSION = '2.110440'; -} -# ABSTRACT: a set of distribution prerequisites by phase and type +our $VERSION = '2.120630'; # VERSION use Carp qw(confess); use Scalar::Util qw(blessed); -use Version::Requirements 0.101020; # finalize +use CPAN::Meta::Requirements; sub __legal_phases { qw(configure build test runtime develop) } @@ -38,7 +35,7 @@ sub new { next TYPE unless keys %$spec; - $guts{prereqs}{$phase}{$type} = Version::Requirements->from_string_hash( + $guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash( $spec ); } @@ -62,7 +59,7 @@ sub requirements_for { confess "requested requirements for unknown type: $type"; } - my $req = ($self->{prereqs}{$phase}{$type} ||= Version::Requirements->new); + my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new); $req->finalize if $self->is_finalized; @@ -81,7 +78,7 @@ sub with_merged_prereqs { for my $phase ($self->__legal_phases) { for my $type ($self->__legal_types) { - my $req = Version::Requirements->new; + my $req = CPAN::Meta::Requirements->new; for my $prereq (@prereq_objs) { my $this_req = $prereq->requirements_for($phase, $type); @@ -140,6 +137,8 @@ sub clone { 1; +# ABSTRACT: a set of distribution prerequisites by phase and type + =pod @@ -150,7 +149,7 @@ CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type =head1 VERSION -version 2.110440 +version 2.120630 =head1 DESCRIPTION @@ -190,10 +189,10 @@ dumping the whole set into a structure or string. my $requirements = $prereqs->requirements_for( $phase, $type ); -This method returns a L<Version::Requirements> object for the given phase/type -combination. If no prerequisites are registered for that combination, a new -Version::Requirements object will be returned, and it may be added to as -needed. +This method returns a L<CPAN::Meta::Requirements> object for the given +phase/type combination. If no prerequisites are registered for that +combination, a new CPAN::Meta::Requirements object will be returned, and it may +be added to as needed. If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will be raised. @@ -216,7 +215,7 @@ will not alter them. This method returns a hashref containing structures suitable for dumping into a distmeta data structure. It is made up of hashes and strings, only; there will -be no Prereqs, Version::Requirements, or C<version> objects inside it. +be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it. =head2 is_finalized diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/Requirements.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/Requirements.pm new file mode 100644 index 00000000000..483a8448a5b --- /dev/null +++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/Requirements.pm @@ -0,0 +1,680 @@ +use strict; +use warnings; +package CPAN::Meta::Requirements; +our $VERSION = '2.120630'; # VERSION +# ABSTRACT: a set of version requirements for a CPAN dist + + +use Carp (); +use Scalar::Util (); +use version 0.77 (); # the ->parse method + + +my @valid_options = qw( bad_version_hook ); + +sub new { + my ($class, $options) = @_; + $options ||= {}; + Carp::croak "Argument to $class\->new() must be a hash reference" + unless ref $options eq 'HASH'; + my %self = map {; $_ => $options->{$_}} @valid_options; + + return bless \%self => $class; +} + +sub _version_object { + my ($self, $version) = @_; + + my $vobj; + + eval { + $vobj = (! defined $version) ? version->parse(0) + : (! Scalar::Util::blessed($version)) ? version->parse($version) + : $version; + }; + + if ( my $err = $@ ) { + my $hook = $self->{bad_version_hook}; + $vobj = eval { $hook->($version) } + if ref $hook eq 'CODE'; + unless (Scalar::Util::blessed($vobj) && $vobj->isa("version")) { + $err =~ s{ at .* line \d+.*$}{}; + die "Can't convert '$version': $err"; + } + } + + # ensure no leading '.' + if ( $vobj =~ m{\A\.} ) { + $vobj = version->parse("0$vobj"); + } + + # ensure normal v-string form + if ( $vobj->is_qv ) { + $vobj = version->parse($vobj->normal); + } + + return $vobj; +} + + +BEGIN { + for my $type (qw(minimum maximum exclusion exact_version)) { + my $method = "with_$type"; + my $to_add = $type eq 'exact_version' ? $type : "add_$type"; + + my $code = sub { + my ($self, $name, $version) = @_; + + $version = $self->_version_object( $version ); + + $self->__modify_entry_for($name, $method, $version); + + return $self; + }; + + no strict 'refs'; + *$to_add = $code; + } +} + + +sub add_requirements { + my ($self, $req) = @_; + + for my $module ($req->required_modules) { + my $modifiers = $req->__entry_for($module)->as_modifiers; + for my $modifier (@$modifiers) { + my ($method, @args) = @$modifier; + $self->$method($module => @args); + }; + } + + return $self; +} + + +sub accepts_module { + my ($self, $module, $version) = @_; + + $version = $self->_version_object( $version ); + + return 1 unless my $range = $self->__entry_for($module); + return $range->_accepts($version); +} + + +sub clear_requirement { + my ($self, $module) = @_; + + return $self unless $self->__entry_for($module); + + Carp::confess("can't clear requirements on finalized requirements") + if $self->is_finalized; + + delete $self->{requirements}{ $module }; + + return $self; +} + + +sub required_modules { keys %{ $_[0]{requirements} } } + + +sub clone { + my ($self) = @_; + my $new = (ref $self)->new; + + return $new->add_requirements($self); +} + +sub __entry_for { $_[0]{requirements}{ $_[1] } } + +sub __modify_entry_for { + my ($self, $name, $method, $version) = @_; + + my $fin = $self->is_finalized; + my $old = $self->__entry_for($name); + + Carp::confess("can't add new requirements to finalized requirements") + if $fin and not $old; + + my $new = ($old || 'CPAN::Meta::Requirements::_Range::Range') + ->$method($version); + + Carp::confess("can't modify finalized requirements") + if $fin and $old->as_string ne $new->as_string; + + $self->{requirements}{ $name } = $new; +} + + +sub is_simple { + my ($self) = @_; + for my $module ($self->required_modules) { + # XXX: This is a complete hack, but also entirely correct. + return if $self->__entry_for($module)->as_string =~ /\s/; + } + + return 1; +} + + +sub is_finalized { $_[0]{finalized} } + + +sub finalize { $_[0]{finalized} = 1 } + + +sub as_string_hash { + my ($self) = @_; + + my %hash = map {; $_ => $self->{requirements}{$_}->as_string } + $self->required_modules; + + return \%hash; +} + + +my %methods_for_op = ( + '==' => [ qw(exact_version) ], + '!=' => [ qw(add_exclusion) ], + '>=' => [ qw(add_minimum) ], + '<=' => [ qw(add_maximum) ], + '>' => [ qw(add_minimum add_exclusion) ], + '<' => [ qw(add_maximum add_exclusion) ], +); + +sub add_string_requirement { + my ($self, $module, $req) = @_; + + my @parts = split qr{\s*,\s*}, $req; + for my $part (@parts) { + my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z}; + + if (! defined $op) { + $self->add_minimum($module => $part); + } else { + Carp::confess("illegal requirement string: $req") + unless my $methods = $methods_for_op{ $op }; + + $self->$_($module => $ver) for @$methods; + } + } +} + + +sub from_string_hash { + my ($class, $hash) = @_; + + my $self = $class->new; + + for my $module (keys %$hash) { + $self->add_string_requirement($module, $hash->{ $module }); + } + + return $self; +} + +############################################################## + +{ + package + CPAN::Meta::Requirements::_Range::Exact; + sub _new { bless { version => $_[1] } => $_[0] } + + sub _accepts { return $_[0]{version} == $_[1] } + + sub as_string { return "== $_[0]{version}" } + + sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] } + + sub _clone { + (ref $_[0])->_new( version->new( $_[0]{version} ) ) + } + + sub with_exact_version { + my ($self, $version) = @_; + + return $self->_clone if $self->_accepts($version); + + Carp::confess("illegal requirements: unequal exact version specified"); + } + + sub with_minimum { + my ($self, $minimum) = @_; + return $self->_clone if $self->{version} >= $minimum; + Carp::confess("illegal requirements: minimum above exact specification"); + } + + sub with_maximum { + my ($self, $maximum) = @_; + return $self->_clone if $self->{version} <= $maximum; + Carp::confess("illegal requirements: maximum below exact specification"); + } + + sub with_exclusion { + my ($self, $exclusion) = @_; + return $self->_clone unless $exclusion == $self->{version}; + Carp::confess("illegal requirements: excluded exact specification"); + } +} + +############################################################## + +{ + package + CPAN::Meta::Requirements::_Range::Range; + + sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) } + + sub _clone { + return (bless { } => $_[0]) unless ref $_[0]; + + my ($s) = @_; + my %guts = ( + (exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()), + (exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()), + + (exists $s->{exclusions} + ? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ]) + : ()), + ); + + bless \%guts => ref($s); + } + + sub as_modifiers { + my ($self) = @_; + my @mods; + push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum}; + push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum}; + push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []}; + return \@mods; + } + + sub as_string { + my ($self) = @_; + + return 0 if ! keys %$self; + + return "$self->{minimum}" if (keys %$self) == 1 and exists $self->{minimum}; + + my @exclusions = @{ $self->{exclusions} || [] }; + + my @parts; + + for my $pair ( + [ qw( >= > minimum ) ], + [ qw( <= < maximum ) ], + ) { + my ($op, $e_op, $k) = @$pair; + if (exists $self->{$k}) { + my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions; + if (@new_exclusions == @exclusions) { + push @parts, "$op $self->{ $k }"; + } else { + push @parts, "$e_op $self->{ $k }"; + @exclusions = @new_exclusions; + } + } + } + + push @parts, map {; "!= $_" } @exclusions; + + return join q{, }, @parts; + } + + sub with_exact_version { + my ($self, $version) = @_; + $self = $self->_clone; + + Carp::confess("illegal requirements: exact specification outside of range") + unless $self->_accepts($version); + + return CPAN::Meta::Requirements::_Range::Exact->_new($version); + } + + sub _simplify { + my ($self) = @_; + + if (defined $self->{minimum} and defined $self->{maximum}) { + if ($self->{minimum} == $self->{maximum}) { + Carp::confess("illegal requirements: excluded all values") + if grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] }; + + return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum}) + } + + Carp::confess("illegal requirements: minimum exceeds maximum") + if $self->{minimum} > $self->{maximum}; + } + + # eliminate irrelevant exclusions + if ($self->{exclusions}) { + my %seen; + @{ $self->{exclusions} } = grep { + (! defined $self->{minimum} or $_ >= $self->{minimum}) + and + (! defined $self->{maximum} or $_ <= $self->{maximum}) + and + ! $seen{$_}++ + } @{ $self->{exclusions} }; + } + + return $self; + } + + sub with_minimum { + my ($self, $minimum) = @_; + $self = $self->_clone; + + if (defined (my $old_min = $self->{minimum})) { + $self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0]; + } else { + $self->{minimum} = $minimum; + } + + return $self->_simplify; + } + + sub with_maximum { + my ($self, $maximum) = @_; + $self = $self->_clone; + + if (defined (my $old_max = $self->{maximum})) { + $self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0]; + } else { + $self->{maximum} = $maximum; + } + + return $self->_simplify; + } + + sub with_exclusion { + my ($self, $exclusion) = @_; + $self = $self->_clone; + + push @{ $self->{exclusions} ||= [] }, $exclusion; + + return $self->_simplify; + } + + sub _accepts { + my ($self, $version) = @_; + + return if defined $self->{minimum} and $version < $self->{minimum}; + return if defined $self->{maximum} and $version > $self->{maximum}; + return if defined $self->{exclusions} + and grep { $version == $_ } @{ $self->{exclusions} }; + + return 1; + } +} + +1; + +__END__ +=pod + +=head1 NAME + +CPAN::Meta::Requirements - a set of version requirements for a CPAN dist + +=head1 VERSION + +version 2.120630 + +=head1 SYNOPSIS + + use CPAN::Meta::Requirements; + + my $build_requires = CPAN::Meta::Requirements->new; + + $build_requires->add_minimum('Library::Foo' => 1.208); + + $build_requires->add_minimum('Library::Foo' => 2.602); + + $build_requires->add_minimum('Module::Bar' => 'v1.2.3'); + + $METAyml->{build_requires} = $build_requires->as_string_hash; + +=head1 DESCRIPTION + +A CPAN::Meta::Requirements object models a set of version constraints like +those specified in the F<META.yml> or F<META.json> files in CPAN distributions. +It can be built up by adding more and more constraints, and it will reduce them +to the simplest representation. + +Logically impossible constraints will be identified immediately by thrown +exceptions. + +=head1 METHODS + +=head2 new + + my $req = CPAN::Meta::Requirements->new; + +This returns a new CPAN::Meta::Requirements object. It takes an optional +hash reference argument. The following keys are supported: + +=over 4 + +=item * + +<bad_version_hook> -- if provided, when a version cannot be parsed into + +a version object, this code reference will be called with the invalid version +string as an argument. It must return a valid version object. + +=back + +All other keys are ignored. + +=head2 add_minimum + + $req->add_minimum( $module => $version ); + +This adds a new minimum version requirement. If the new requirement is +redundant to the existing specification, this has no effect. + +Minimum requirements are inclusive. C<$version> is required, along with any +greater version number. + +This method returns the requirements object. + +=head2 add_maximum + + $req->add_maximum( $module => $version ); + +This adds a new maximum version requirement. If the new requirement is +redundant to the existing specification, this has no effect. + +Maximum requirements are inclusive. No version strictly greater than the given +version is allowed. + +This method returns the requirements object. + +=head2 add_exclusion + + $req->add_exclusion( $module => $version ); + +This adds a new excluded version. For example, you might use these three +method calls: + + $req->add_minimum( $module => '1.00' ); + $req->add_maximum( $module => '1.82' ); + + $req->add_exclusion( $module => '1.75' ); + +Any version between 1.00 and 1.82 inclusive would be acceptable, except for +1.75. + +This method returns the requirements object. + +=head2 exact_version + + $req->exact_version( $module => $version ); + +This sets the version required for the given module to I<exactly> the given +version. No other version would be considered acceptable. + +This method returns the requirements object. + +=head2 add_requirements + + $req->add_requirements( $another_req_object ); + +This method adds all the requirements in the given CPAN::Meta::Requirements object +to the requirements object on which it was called. If there are any conflicts, +an exception is thrown. + +This method returns the requirements object. + +=head2 accepts_module + + my $bool = $req->accepts_modules($module => $version); + +Given an module and version, this method returns true if the version +specification for the module accepts the provided version. In other words, +given: + + Module => '>= 1.00, < 2.00' + +We will accept 1.00 and 1.75 but not 0.50 or 2.00. + +For modules that do not appear in the requirements, this method will return +true. + +=head2 clear_requirement + + $req->clear_requirement( $module ); + +This removes the requirement for a given module from the object. + +This method returns the requirements object. + +=head2 required_modules + +This method returns a list of all the modules for which requirements have been +specified. + +=head2 clone + + $req->clone; + +This method returns a clone of the invocant. The clone and the original object +can then be changed independent of one another. + +=head2 is_simple + +This method returns true if and only if all requirements are inclusive minimums +-- that is, if their string expression is just the version number. + +=head2 is_finalized + +This method returns true if the requirements have been finalized by having the +C<finalize> method called on them. + +=head2 finalize + +This method marks the requirements finalized. Subsequent attempts to change +the requirements will be fatal, I<if> they would result in a change. If they +would not alter the requirements, they have no effect. + +If a finalized set of requirements is cloned, the cloned requirements are not +also finalized. + +=head2 as_string_hash + +This returns a reference to a hash describing the requirements using the +strings in the F<META.yml> specification. + +For example after the following program: + + my $req = CPAN::Meta::Requirements->new; + + $req->add_minimum('CPAN::Meta::Requirements' => 0.102); + + $req->add_minimum('Library::Foo' => 1.208); + + $req->add_maximum('Library::Foo' => 2.602); + + $req->add_minimum('Module::Bar' => 'v1.2.3'); + + $req->add_exclusion('Module::Bar' => 'v1.2.8'); + + $req->exact_version('Xyzzy' => '6.01'); + + my $hashref = $req->as_string_hash; + +C<$hashref> would contain: + + { + 'CPAN::Meta::Requirements' => '0.102', + 'Library::Foo' => '>= 1.208, <= 2.206', + 'Module::Bar' => '>= v1.2.3, != v1.2.8', + 'Xyzzy' => '== 6.01', + } + +=head2 add_string_requirement + + $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206'); + +This method parses the passed in string and adds the appropriate requirement +for the given module. It understands version ranges as described in the +L<CPAN::Meta::Spec/Version Ranges>. For example: + +=over 4 + +=item 1.3 + +=item >= 1.3 + +=item <= 1.3 + +=item == 1.3 + +=item ! 1.3 + +=item > 1.3 + +=item < 1.3 + +=item >= 1.3, ! 1.5, <= 2.0 + +A version number without an operator is equivalent to specifying a minimum +(C<E<gt>=>). Extra whitespace is allowed. + +=back + +=head2 from_string_hash + + my $req = CPAN::Meta::Requirements->from_string_hash( \%hash ); + +This is an alternate constructor for a CPAN::Meta::Requirements object. It takes +a hash of module names and version requirement strings and returns a new +CPAN::Meta::Requirements object. + +=head1 AUTHORS + +=over 4 + +=item * + +David Golden <dagolden@cpan.org> + +=item * + +Ricardo Signes <rjbs@cpan.org> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2010 by David Golden and Ricardo Signes. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut + diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm index 8f94c718cb4..07d32246411 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm @@ -3,12 +3,12 @@ use 5.006; use strict; use warnings; package CPAN::Meta::Spec; -BEGIN { - $CPAN::Meta::Spec::VERSION = '2.110440'; -} -# ABSTRACT: specification for CPAN distribution metadata +our $VERSION = '2.120630'; # VERSION + 1; +# ABSTRACT: specification for CPAN distribution metadata + __END__ @@ -20,7 +20,7 @@ CPAN::Meta::Spec - specification for CPAN distribution metadata =head1 VERSION -version 2.110440 +version 2.120630 =head1 SYNOPSIS @@ -31,6 +31,7 @@ version 2.110440 . "building, testing, and installing Perl modules. " . "It is meant to ... blah blah blah ...", version => '0.36', + release_status => 'stable', author => [ 'Ken Williams <kwilliams@cpan.org>', 'Module-Build List <module-build@perl.org>', # additional contact @@ -505,12 +506,12 @@ Valid subkeys are as follows: =item file A I<List> of relative paths to files. Paths B<must be> specified with -unix convetions. +unix conventions. =item directory A I<List> of relative paths to directories. Paths B<must be> specified -with unix convetions. +with unix conventions. [ Note: previous editions of the spec had C<dir> instead of C<directory> ] @@ -565,13 +566,13 @@ This entry is required and has the same structure as that of the C<L</prereqs>> key. It provides a list of package requirements that must be satisfied for the feature to be supported or enabled. -There is one crucial restriction: the preqreqs of an optional feature +There is one crucial restriction: the prereqs of an optional feature B<must not> include C<configure> phase prereqs. =back Consumers B<must not> include optional features as prerequisites without -explict instruction from users (whether via interactive prompting, +explicit instruction from users (whether via interactive prompting, a function parameter or a configuration value, etc. ). If an optional feature is used by a consumer to add additional @@ -663,8 +664,9 @@ the distribution. The values are Maps with the following valid subkeys: =item file -This field is required. The value must contain a relative file path -from the root of the distribution to the module containing the package. +This field is required. The value must contain a Unix-style relative +file path from the root of the distribution to the module containing the +package. =item version @@ -680,12 +682,12 @@ Example: license => [ 'http://dev.perl.org/licenses/' ], homepage => 'http://sourceforge.net/projects/module-build', bugtracker => { - web => 'http://github.com/dagolden/cpan-meta-spec/issues', + web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta', mailto => 'meta-bugs@example.com', }, repository => { - url => 'git://github.com/dagolden/cpan-meta-spec.git', - web => 'http://github.com/dagolden/cpan-meta-spec', + url => 'git://github.com/dagolden/cpan-meta.git', + web => 'http://github.com/dagolden/cpan-meta', type => 'git', }, x_twitter => 'http://twitter.com/cpan_linked/', @@ -1027,10 +1029,10 @@ if both are found. =head2 Extracting Version Numbers from Perl Modules To get the version number from a Perl module, consumers should use the -C<< MM->parse_version($file) >> method provided by L<ExtUtils::MakeMaker> or -the L<Module::Build::ModuleInfo> module provided with L<Module::Build>. For -example, for the module given by C<$mod>, the version may be retrieved in one -of the following ways: +C<< MM->parse_version($file) >> method provided by +L<ExtUtils::MakeMaker> or L<Module::Metadata>. For example, for the +module given by C<$mod>, the version may be retrieved in one of the +following ways: # via ExtUtils::MakeMaker my $file = MM->_installed_file_for_module($mod); @@ -1039,14 +1041,14 @@ of the following ways: The private C<_installed_file_for_module> method may be replaced with other methods for locating a module in C<@INC>. - # via Module::Build - my $info = Module::Build::ModuleInfo->new_from_module($mod); + # via Module::Metadata + my $info = Module::Metadata->new_from_module($mod); my $version = $info->version; If only a filename is available, the following approach may be used: # via Module::Build - my $info = Module::Build::ModuleInfo->new_from_file($file); + my $info = Module::Metadata->new_from_file($file); my $version = $info->version; =head2 Comparing Version Numbers diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm index a203621ab8f..1bb53592275 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm @@ -2,10 +2,7 @@ use 5.006; use strict; use warnings; package CPAN::Meta::Validator; -BEGIN { - $CPAN::Meta::Validator::VERSION = '2.110440'; -} -# ABSTRACT: validate CPAN distribution metadata structures +our $VERSION = '2.120630'; # VERSION #--------------------------------------------------------------------------# @@ -692,7 +689,7 @@ my %v1_licenses = ( 'apache' => 'http://apache.org/licenses/LICENSE-2.0', 'artistic' => 'http://opensource.org/licenses/artistic-license.php', 'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php', - 'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.phpt', + 'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php', 'bsd' => 'http://www.opensource.org/licenses/bsd-license.php', 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php', 'mit' => 'http://opensource.org/licenses/mit-license.php', @@ -829,6 +826,8 @@ sub _error { 1; +# ABSTRACT: validate CPAN distribution metadata structures + =pod @@ -839,7 +838,7 @@ CPAN::Meta::Validator - validate CPAN distribution metadata structures =head1 VERSION -version 2.110440 +version 2.120630 =head1 SYNOPSIS @@ -881,87 +880,143 @@ is valid. Returns a list of errors seen during validation. -=begin internals +=begin :internals =head2 Check Methods =over -=item * check_map($spec,$data) +=item * + +check_map($spec,$data) Checks whether a map (or hash) part of the data structure conforms to the appropriate specification definition. -=item * check_list($spec,$data) + +=item * + +check_list($spec,$data) Checks whether a list (or array) part of the data structure conforms to the appropriate specification definition. -=item * check_lazylist($spec,$data) + +=item * + +check_lazylist($spec,$data) Checks whether a list conforms, but converts strings to a single-element list + =back =head2 Validator Methods =over -=item * header($self,$key,$value) +=item * + +header($self,$key,$value) Validates that the header is valid. -Note: No longer used as we now read the data structure, not the file.=item * url($self,$key,$value) +Note: No longer used as we now read the data structure, not the file. + +=item * + +url($self,$key,$value) Validates that a given value is in an acceptable URL format -=item * urlspec($self,$key,$value) + +=item * + +urlspec($self,$key,$value) Validates that the URL to a META specification is a known one. -=item * string_or_undef($self,$key,$value) + +=item * + +string_or_undef($self,$key,$value) Validates that the value is either a string or an undef value. Bit of a catchall function for parts of the data structure that are completely user defined. -=item * string($self,$key,$value) + +=item * + +string($self,$key,$value) Validates that a string exists for the given key. -=item * file($self,$key,$value) + +=item * + +file($self,$key,$value) Validate that a file is passed for the given key. This may be made more thorough in the future. For now it acts like \&string. -=item * exversion($self,$key,$value) + +=item * + +exversion($self,$key,$value) Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'. -=item * version($self,$key,$value) + +=item * + +version($self,$key,$value) Validates a single version string. Versions of the type '5.8.8' and '0.00_00' are both valid. A leading 'v' like 'v1.2.3' is also valid. -=item * boolean($self,$key,$value) + +=item * + +boolean($self,$key,$value) Validates for a boolean value. Currently these values are '1', '0', 'true', 'false', however the latter 2 may be removed. -=item * license($self,$key,$value) + +=item * + +license($self,$key,$value) Validates that a value is given for the license. Returns 1 if an known license type, or 2 if a value is given but the license type is not a recommended one. -=item * custom_1($self,$key,$value) + +=item * + +custom_1($self,$key,$value) Validates that the given key is in CamelCase, to indicate a user defined keyword and only has characters in the class [-_a-zA-Z]. In version 1.X of the spec, this was only explicitly stated for 'resources'. -=item * custom_2($self,$key,$value) + +=item * + +custom_2($self,$key,$value) Validates that the given key begins with 'x_' or 'X_', to indicate a user defined keyword and only has characters in the class [-_a-zA-Z] -=item * identifier($self,$key,$value) + +=item * + +identifier($self,$key,$value) Validates that key is in an acceptable format for the META specification, for an identifier, i.e. any that matches the regular expression qr/[a-z][a-z_]/i. -=item * module($self,$key,$value) + +=item * + +module($self,$key,$value) Validates that a given key is in an acceptable module name format, e.g. 'Test::CPAN::Meta::Version'. + =back -=end internals +=end :internals + +=for Pod::Coverage anything boolean check_lazylist check_list custom_1 custom_2 exversion file +identifier license module phase relation release_status string string_or_undef +url urlspec version header check_map =head1 BUGS diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm index 2e94a180840..ba8a702f74d 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm @@ -1,6 +1,6 @@ package CPAN::Meta::YAML; -BEGIN { - $CPAN::Meta::YAML::VERSION = '0.003'; +{ + $CPAN::Meta::YAML::VERSION = '0.007'; } use strict; @@ -459,7 +459,7 @@ sub _write_scalar { $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g; return qq|"$string"|; } - if ( $string =~ /(?:^\W|\s)/ or $QUOTE{$string} ) { + if ( $string =~ /(?:^\W|\s|:\z)/ or $QUOTE{$string} ) { return "'$string'"; } return $string; @@ -610,12 +610,13 @@ sub LoadFile { # Use Scalar::Util if possible, otherwise emulate it BEGIN { + local $@; eval { require Scalar::Util; - *refaddr = *Scalar::Util::refaddr; }; - eval <<'END_PERL' if $@; -# Failed to load Scalar::Util + if ( $@ or $Scalar::Util::VERSION < 1.18 ) { + eval <<'END_PERL' if $@; +# Scalar::Util failed to load or too old sub refaddr { my $pkg = ref($_[0]) or return undef; if ( !! UNIVERSAL::can($_[0], 'can') ) { @@ -629,7 +630,9 @@ sub refaddr { $i; } END_PERL - + } else { + *refaddr = *Scalar::Util::refaddr; + } } 1; @@ -644,26 +647,26 @@ CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files =head1 VERSION -version 0.003 +version 0.007 =head1 SYNOPSIS use CPAN::Meta::YAML; - # methods for files - $yaml = CPAN::Meta::YAML->read('META.yml'); - $yaml->write('MYMETA.yml'); - - # methods for strings - $yaml_text = $yaml->write_string; - $yaml = CPAN::Meta::YAML->read_string($yaml_text); + # reading a META file + open $fh, "<:utf8", "META.yml"; + $yaml_text = do { local $/; <$fh> }; + $yaml = CPAN::Meta::YAML->read_string($yaml_text) + or die CPAN::Meta::YAML->errstr; # finding the metadata - my $meta = $yaml->[0]; + $meta = $yaml->[0]; - # handling errors - $yaml->write($file) + # writing a META file + $yaml_text = $yaml->write_string or die CPAN::Meta::YAML->errstr; + open $fh, ">:utf8", "META.yml"; + print $fh $yaml_text; =head1 DESCRIPTION @@ -671,6 +674,10 @@ This module implements a subset of the YAML specification for use in reading and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>. It should not be used for any other general YAML parsing or generation task. +NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded. Users are +responsible for proper encoding and decoding. In particular, the C<read> and +C<write> methods do B<not> support UTF-8 and should not be used. + =head1 SUPPORT This module is currently derived from L<YAML::Tiny> by Adam Kennedy. If @@ -682,6 +689,25 @@ L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=YAML-Tiny> L<YAML::Tiny>, L<YAML>, L<YAML::XS> +=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders + +=head1 SUPPORT + +=head2 Bugs / Feature Requests + +Please report any bugs or feature requests through the issue tracker +at L<http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta-YAML>. +You will be notified automatically of any progress on your issue. + +=head2 Source Code + +This is open source software. The code repository is available for +public review and contribution under the terms of the license. + +L<https://github.com/dagolden/cpan-meta-yaml> + + git clone https://github.com/dagolden/cpan-meta-yaml.git + =head1 AUTHORS =over 4 diff --git a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm index 3582b0acb4c..daafc1dbaf1 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm @@ -1,5 +1,37 @@ # -*- 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); @@ -10,31 +42,55 @@ use FileHandle; use Fcntl ":flock"; use Net::Ping (); +=item new( LOCAL_FILE_NAME ) + +=cut + sub new { my ($class, $file) = @_; - my $self = bless { - mirrors => [], - geography => {}, + 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) + $handle->open($file) or croak "Couldn't open $file: $!"; flock $handle, LOCK_SH; $self->_parse($file,$handle); flock $handle, LOCK_UN; $handle->close; +} - # populate continents & countries +=item continents() - return $self -} +Return a list of continents based on those defined in F<MIRRORED.BY>. + +=cut sub continents { my ($self) = @_; return keys %{$self->{geography}}; } +=item countries( [CONTINENTS] ) + +Return a list of countries based on those defined in F<MIRRORED.BY>. +It only returns countries for the continents you specify (as defined +in C<continents>). If you don't specify any continents, it returns all +of the countries listed in F<MIRRORED.BY>. + +=cut + sub countries { my ($self, @continents) = @_; @continents = $self->continents unless @continents; @@ -45,6 +101,15 @@ sub countries { return @countries; } +=item mirrors( [COUNTRIES] ) + +Return a list of mirrors based on those defined in F<MIRRORED.BY>. +It only returns mirrors for the countries you specify (as defined +in C<countries>). If you don't specify any countries, it returns all +of the mirrors listed in F<MIRRORED.BY>. + +=cut + sub mirrors { my ($self, @countries) = @_; return @{$self->{mirrors}} unless @countries; @@ -56,118 +121,300 @@ sub mirrors { 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<best_mirrors> checks for the best mirrors based on the list of +continents you pass, or, without that, all continents, as defined +by C<CPAN::Mirrored::By>. It pings each mirror, up to the value of +C<how_many>. In list context, it returns up to C<how_many> 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<best_mirrors> calls +C<find_best_continents> 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 = $args{verbose}; - my $conts = $args{continents} || []; - $conts = [$conts] unless ref $conts; + 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 ( ! @$conts ) { + if ( ! @$continents ) { print "Searching for the best continent ...\n" if $verbose; - my @best = $self->_find_best_continent($seen, $verbose, $callback); + 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 $c ( @best ) { - push @$conts, $c; - $count += $self->mirrors( $self->countries($c) ); + for my $continent ( @best_continents ) { + push @$continents, $continent; + $count += $self->mirrors( $self->countries($continent) ); last if $count >= $how_many; } } - print "Scanning " . join(", ", @$conts) . " ...\n" if $verbose; + 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; - my @timings; - my @long_list = $self->mirrors($self->countries(@$conts)); - my $long_list_size = ( $how_many > 10 ? $how_many : 10 ); - if ( @long_list > $long_list_size ) { - @long_list = map {$_->[0]} - sort {$a->[1] <=> $b->[1]} - map {[$_, rand]} @long_list; - splice @long_list, $long_list_size; # truncate + if ( $n <= 0 ) { + return wantarray ? () : []; } - for my $m ( @long_list ) { - next unless $m->http; - my $hostname = $m->hostname; - if ( $seen->{$hostname} ) { - push @timings, $seen->{$hostname} - if defined $seen->{$hostname}[1]; + 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 { - my $ping = $m->ping; - next unless defined $ping; - push @timings, [$m, $ping]; - $callback->($m,$ping) if $callback; + push @$timings, $seen->{$m->hostname} + if defined $seen->{$m->hostname}->rtt; } } - return unless @timings; - - $how_many = @timings if $how_many > @timings; - my @best = - map { $_->[0] } - sort { $a->[1] <=> $b->[1] } @timings; - return wantarray ? @best[0 .. $how_many-1] : $best[0]; + 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; } -sub _find_best_continent { - my ($self, $seen, $verbose, $callback) = @_; +=item find_best_continents( HASH_REF ); + +C<find_best_continents> goes through each continent and pings C<N> 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<seen> hash has hostnames as keys and anonymous arrays as values. The +anonymous array is a triplet of a C<CPAN::Mirrored::By> object, a ping +time, and the epoch time for the measurement. + +The callback subroutine gets the C<CPAN::Mirrored::By> object, the ping +time, and measurement time (the same things in the C<seen> hashref) as arguments. +C<find_best_continents> doesn't care what the callback does and ignores the return +value. - my %median; +=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 $sample = 3; - my $n = (@mirrors < $sample) ? @mirrors : $sample; + my $n = (@mirrors < $args{n}) ? @mirrors : $args{n}; + my @tests; - RANDOM: while ( @mirrors && @tests < $n ) { + my $tries = 0; + RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) { my $m = splice( @mirrors, int(rand(@mirrors)), 1 ); - my $ping = $m->ping; - $callback->($m,$ping) if $callback; - # record undef so we don't try again - $seen->{$m->hostname} = [$m, $ping]; - next RANDOM unless defined $ping; - push @tests, $ping; - } - next CONT unless @tests; - @tests = sort { $a <=> $b } @tests; - if ( @tests == 1 ) { - $median{$c} = $tests[0]; - } - elsif ( @tests % 2 ) { - $median{$c} = $tests[ int(@tests / 2) ]; - } - else { - my $mid_high = int(@tests/2); - $median{$c} = ($tests[$mid_high-1] + $tests[$mid_high])/2; + 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 { $median{$a} <=> $median{$b} } keys %median ; + my @best_cont = sort { $medians{$a} <=> $medians{$b} } keys %medians; - if ( $verbose ) { + if ( $args{verbose} ) { print "Median result by continent:\n"; for my $c ( @best_cont ) { - printf( " %d ms %s\n", int($median{$c}*1000+.5), $c ); + 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}; + my $geo = $self->{geography}; local $/ = "\012"; my $line = 0; @@ -193,7 +440,7 @@ sub _parse { $mirror ||= {}; if ( $prop eq 'dst_location' ) { my (@location,$continent,$country); - @location = (split /\s*,\s*/, $value) + @location = (split /\s*,\s*/, $value) and ($continent, $country) = @location[-1,-2]; $continent =~ s/\s\(.*//; $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude @@ -244,35 +491,61 @@ sub new { $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 url { +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); + + 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); - return $alive ? $rtt : undef; + + $self->{rtt} = $alive ? $rtt : undef; + $self->{ping_time} = time; + + $self->rtt; } 1; +=back + +=head1 AUTHOR + +Andreas Koenig C<< <andk@cpan.org> >>, David Golden C<< <dagolden@cpan.org> >>, +brian d foy C<< <bdfoy@cpan.org> >> + +=head1 LICENSE + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See L<http://www.perl.com/perl/misc/Artistic.html> + + + +=cut diff --git a/Master/tlpkg/tlperl/lib/CPAN/Shell.pm b/Master/tlpkg/tlperl/lib/CPAN/Shell.pm index 9effb0d2e70..21441df653f 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Shell.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Shell.pm @@ -653,7 +653,7 @@ sub mkmyconfig { "CPAN::MyConfig already exists as $configpm.\n" . "Running configuration again...\n" ); - require CPAN::FirstTime; + require CPAN::FirstTime; CPAN::FirstTime::init($configpm); } else { @@ -1221,6 +1221,7 @@ sub autobundle { $fh->close; $CPAN::Frontend->myprint("\nWrote bundle file $to\n\n"); + return $to; } #-> sub CPAN::Shell::expandany ; @@ -1684,7 +1685,7 @@ sub rematein { if ($meth =~ /^($needs_recursion_protection)$/) { # it would be silly to check for recursion for look or dump # (we are in CPAN::Shell::rematein) - CPAN->debug("Going to test against recursion") if $CPAN::DEBUG; + CPAN->debug("Testing against recursion") if $CPAN::DEBUG; eval { $obj->color_cmd_tmps(0,1); }; if ($@) { if (ref $@ @@ -1847,7 +1848,7 @@ sub recent { my($self) = @_; if ($CPAN::META->has_inst("XML::LibXML")) { my $url = $CPAN::Defaultrecent; - $CPAN::Frontend->myprint("Going to fetch '$url'\n"); + $CPAN::Frontend->myprint("Fetching '$url'\n"); unless ($CPAN::META->has_usable("LWP")) { $CPAN::Frontend->mydie("LWP not installed; cannot continue"); } @@ -1935,7 +1936,7 @@ sub smoke { my $distros = $self->recent; DISTRO: for my $distro (@$distros) { next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles - $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n"); + $CPAN::Frontend->myprint(sprintf "Downloading and testing '$distro'\n"); { my $skip = 0; local $SIG{INT} = sub { $skip = 1 }; |