From: Jos I. Boumans Date: Fri, 27 Feb 2009 15:07:53 +0000 (+0100) Subject: Update CPANPLUS to 0.85_06 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4443dd534cb30448ffd0c8f241b54eb1d51bbe74;p=p5sagit%2Fp5-mst-13.2.git Update CPANPLUS to 0.85_06 --- diff --git a/MANIFEST b/MANIFEST index e3a1df1..adbfb95 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1862,6 +1862,7 @@ lib/CPANPLUS/bin/cpanp-run-perl the cpanp-run-perl utility lib/CPANPLUS/Config.pm CPANPLUS lib/CPANPLUS/Configure.pm CPANPLUS lib/CPANPLUS/Configure/Setup.pm CPANPLUS +lib/CPANPLUS/Dist/Autobundle.pm CPANPLUS lib/CPANPLUS/Dist/Base.pm CPANPLUS lib/CPANPLUS/Dist/Build/Constants.pm CPANPLUS::Dist::Build lib/CPANPLUS/Dist/Build.pm CPANPLUS::Dist::Build @@ -1884,7 +1885,10 @@ lib/CPANPLUS/Internals/Fetch.pm CPANPLUS lib/CPANPLUS/Internals.pm CPANPLUS lib/CPANPLUS/Internals/Report.pm CPANPLUS lib/CPANPLUS/Internals/Search.pm CPANPLUS +lib/CPANPLUS/Internals/Source/Memory.pm CPANPLUS lib/CPANPLUS/Internals/Source.pm CPANPLUS +lib/CPANPLUS/Internals/Source/SQLite.pm CPANPLUS +lib/CPANPLUS/Internals/Source/SQLite/Tie.pm CPANPLUS lib/CPANPLUS/Internals/Utils/Autoflush.pm CPANPLUS lib/CPANPLUS/Internals/Utils.pm CPANPLUS lib/CPANPLUS/Module/Author/Fake.pm CPANPLUS @@ -1906,6 +1910,8 @@ lib/CPANPLUS/t/00_CPANPLUS-Inc.t CPANPLUS tests lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t CPANPLUS tests lib/CPANPLUS/t/01_CPANPLUS-Configure.t CPANPLUS tests lib/CPANPLUS/t/02_CPANPLUS-Internals.t CPANPLUS tests +lib/CPANPLUS/t/031_CPANPLUS-Internals-Source-SQLite.t CPANPLUS tests +lib/CPANPLUS/t/032_CPANPLUS-Internals-Source-via-sqlite.t CPANPLUS tests lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t CPANPLUS tests lib/CPANPLUS/t/04_CPANPLUS-Module.t CPANPLUS tests lib/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t CPANPLUS tests @@ -1918,11 +1924,13 @@ lib/CPANPLUS/t/15_CPANPLUS-Shell.t CPANPLUS tests lib/CPANPLUS/t/19_CPANPLUS-Dist.t CPANPLUS tests lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t CPANPLUS tests lib/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t CPANPLUS tests +lib/CPANPLUS/t/25_CPANPLUS.t CPANPLUS tests lib/CPANPLUS/t/30_CPANPLUS-Internals-Selfupdate.t CPANPLUS tests lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t CPANPLUS tests lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed CPANPLUS tests lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed CPANPLUS tests lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.meta CPANPLUS tests lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.readme CPANPLUS tests lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS tests lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed CPANPLUS tests @@ -1935,6 +1943,7 @@ lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/CHECKSUMS CPANPLUS tests lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.readme CPANPLUS tests lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/autobundle/Snapshot.pm CPANPLUS tests lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed CPANPLUS tests lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz.packed CPANPLUS tests lib/CPANPLUS/t/inc/conf.pl CPANPLUS tests diff --git a/lib/CPANPLUS.pm b/lib/CPANPLUS.pm index 536c3e3..906cbe0 100644 --- a/lib/CPANPLUS.pm +++ b/lib/CPANPLUS.pm @@ -13,7 +13,7 @@ BEGIN { use vars qw( @EXPORT @ISA $VERSION ); @EXPORT = qw( shell fetch get install ); @ISA = qw( Exporter ); - $VERSION = "0.84_01"; #have to hardcode or cpan.org gets unhappy + $VERSION = "0.86_06"; #have to hardcode or cpan.org gets unhappy } ### purely for backward compatibility, so we can call it from the commandline: diff --git a/lib/CPANPLUS/Backend.pm b/lib/CPANPLUS/Backend.pm index 75beb2e..fb71fcf 100644 --- a/lib/CPANPLUS/Backend.pm +++ b/lib/CPANPLUS/Backend.pm @@ -369,19 +369,21 @@ for my $func (qw[fetch extract install readme files distributions]) { my $conf = $self->configure_object; my %hash = @_; - local $Params::Check::NO_DUPLICATES = 1; - local $Params::Check::ALLOW_UNKNOWN = 1; - my ($mods); - my $tmpl = { - modules => { default => [], strict_type => 1, - required => 1, store => \$mods }, - }; + my $args = do { + local $Params::Check::NO_DUPLICATES = 1; + local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { default => [], strict_type => 1, + required => 1, store => \$mods }, + }; - my $args = check( $tmpl, \%hash ) or return; + check( $tmpl, \%hash ); + } or return; ### make them all into module objects ### - my %mods = map {$_ => $self->parse_module(module => $_) || ''} @$mods; + my %mods = map { $_ => $self->parse_module(module => $_) || '' } @$mods; my $flag; my $href; while( my($name,$obj) = each %mods ) { @@ -556,8 +558,8 @@ sub parse_module { } else { $author = shift @parts || ''; } - - my($pkg, $version, $ext) = + + my($pkg, $version, $ext, $full) = $self->_split_package_string( package => $dist ); ### translate a distribution into a module name ### @@ -599,8 +601,12 @@ sub parse_module { my $modobj = CPANPLUS::Module::Fake->new( module => $maybe->module, version => $version, - package => $pkg . '-' . $version . '.' . - $maybe->package_extension, + ### no extension? use the extension the original package + ### had instead + package => do { $ext + ? $full + : $full .'.'. $maybe->package_extension + }, path => $path, author => $auth_obj, _id => $maybe->_id @@ -941,7 +947,14 @@ sub local_mirror { Writes out a snapshot of your current installation in C bundle style. This can then be used to install the same modules for a -different or on a different machine. +different or on a different machine by issuing the following commands: + + ### using the default shell: + CPAN Terminal> i file://path/to/Snapshot_XXYY.pm + + ### using the API + $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' ); + $modobj->install; It will, by default, write to an 'autobundle' directory under your cpanplus homedirectory, but you can override that by supplying a @@ -1022,7 +1035,7 @@ sub autobundle { my $perl_v = join '', `$^X -V`; print $fh <save_state + +Explicit command to save memory state to disk. This can be used to save +information to disk about where a module was extracted, the result of +C, etc. This will then be re-loaded into memory when a new +session starts. + +The capability of saving state to disk depends on the source engine +being used (See C for the option to choose your +source engine). The default storage engine supports this option. + +Most users will not need this command, but it can handy for automated +systems like setting up CPAN smoke testers. + +The method will return true if it managed to save the state to disk, +or false if it did not. + +=cut + +sub save_state { + my $self = shift; + return $self->_save_state( @_ ); +} + + ### XXX these wrappers are not individually tested! only the underlying ### code through source.t and indirectly trought he CustomSource plugin. =pod diff --git a/lib/CPANPLUS/Config.pm b/lib/CPANPLUS/Config.pm index df1884e..08c80df 100644 --- a/lib/CPANPLUS/Config.pm +++ b/lib/CPANPLUS/Config.pm @@ -26,6 +26,23 @@ use Module::Load::Conditional qw[check_install]; CPANPLUS::Config +=head1 SYNOPSIS + + ### conf object via CPANPLUS::Backend; + $cb = CPANPLUS::Backend->new; + $conf = $cb->configure_object; + + ### or as a standalone object + $conf = CPANPLUS::Configure->new; + + ### values in 'conf' section + $verbose = $conf->get_conf( 'verbose' ); + $conf->set_conf( verbose => 1 ); + + ### values in 'program' section + $editor = $conf->get_program( 'editor' ); + $conf->set_program( editor => '/bin/vi' ); + =head1 DESCRIPTION This module contains defaults and heuristics for configuration @@ -134,7 +151,7 @@ are run interactively or not. Defaults to 'true'. =item base -The directory CPANPLUS keeps all it's build and state information in. +The directory CPANPLUS keeps all its build and state information in. Defaults to ~/.cpanplus. =cut @@ -197,6 +214,20 @@ when sending emails. Defaults to an C address. =cut $Conf->{'conf'}->{'email'} = DEFAULT_EMAIL; + +=item enable_custom_sources + +Boolean flag indicating whether custom sources should be enabled or +not. See the C in C for +details on how to use them. + +Defaults to C + +=cut + + ### this addresses #32248 which requests a possibillity to + ### turn off custom sources + $Conf->{'conf'}->{'enable_custom_sources'} = 1; =item extractdir @@ -419,6 +450,29 @@ a module using the interactive shell. Defaults to 'true'. $Conf->{'conf'}->{'write_install_logs'} = 1; +=item source_engine + +Class to use as the source engine, which is generally a subclass of +C. Default to C. + +=cut + + $Conf->{'conf'}->{'source_engine'} = DEFAULT_SOURCE_ENGINE; + +=item cpantest_reporter_args + +A hashref of key => value pairs that are passed to the constructor +of C. If you'd want to enable TLS for example, you'd +set it to: + + { transport => 'Net::SMTP::TLS', + transport_args => [ User => 'Joe', Password => '123' ], + } + +=cut + + $Conf->{'conf'}->{'cpantest_reporter_args'} = {}; + =back =head2 Section 'program' @@ -486,7 +540,6 @@ remains empty if you do not require super user permissiosn to install. =cut $Conf->{'program'}->{'sudo'} = do { - ### let's assume you dont need sudo, ### unless one of the below criteria tells us otherwise my $sudo = undef; @@ -495,17 +548,20 @@ remains empty if you do not require super user permissiosn to install. if( $> ) { ### check for all install dirs! - ### installsiteman3dir is a 5.8'ism.. don't check - ### it on 5.6.x... ### you have write permissions to the installdir, ### you don't need sudo - if( -w $Config{'installsitelib'} && - ( defined $Config{'installsiteman3dir'} && - -w $Config{'installsiteman3dir'} - ) && -w $Config{'installsitebin'} - ) { - $sudo = undef; + if( -w $Config{'installsitelib'} && -w $Config{'installsitebin'} ) { + ### installsiteman3dir is a 5.8'ism.. don't check + ### it on 5.6.x... + if( defined $Config{'installsiteman3dir'} ) { + $sudo = -w $Config{'installsiteman3dir'} + ? undef + : can_run('sudo'); + } else { + $sudo = undef; + } + ### you have PERL_MM_OPT set to some alternate ### install place. You probably have write permissions ### to that diff --git a/lib/CPANPLUS/Configure.pm b/lib/CPANPLUS/Configure.pm index d890d1c..2d249e5 100644 --- a/lib/CPANPLUS/Configure.pm +++ b/lib/CPANPLUS/Configure.pm @@ -24,7 +24,7 @@ $VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION; ### can't use O::A as we're using our own AUTOLOAD to get to ### the config options. -for my $meth ( qw[conf]) { +for my $meth ( qw[conf _lib _perl5lib]) { no strict 'refs'; *$meth = sub { @@ -70,8 +70,10 @@ This method returns a new object. Normal users will never need to invoke the C method, but instead retrieve the desired object via a method call on a C object. -The C parameter controls wether or not additional -user configurations are to be loaded or not. Defaults to C. +=item load_configs + +Controls wether or not additional user configurations are to be loaded +or not. Defaults to C. =cut @@ -89,7 +91,7 @@ user configurations are to be loaded or not. Defaults to C. my $tmpl = { load_configs => { default => 1, store => \$load }, }; - + check( $tmpl, \%hash ) or ( warn Params::Check->last_error, return ); @@ -97,10 +99,15 @@ user configurations are to be loaded or not. Defaults to C. $Config ||= CPANPLUS::Config->new; my $self = bless {}, $class; $self->conf( $Config ); - + ### you want us to load other configs? ### these can override things in the default config $self->init if $load; + + ### after processing the config files, check what + ### @INC and PERL5LIB are set to. + $self->_lib( \@INC ); + $self->_perl5lib( $ENV{'PERL5LIB'} ); return $self; } @@ -142,6 +149,11 @@ Returns true on success, false on failure. warn Params::Check->last_error, return ); + ### if the base dir is changed, we have to rescan it + ### for any CPANPLUS::Config::* files as well, so keep + ### track of it + my $cur_base = $self->get_conf('base'); + ### warn if we find an old style config specified ### via environment variables { my $env = ENV_CPANPLUS_CONFIG; @@ -155,60 +167,82 @@ Returns true on success, false on failure. } } - ### make sure that the homedir is included now - local @INC = ( CONFIG_USER_LIB_DIR->(), @INC ); + { ### make sure that the homedir is included now + local @INC = ( LIB_DIR->($cur_base), @INC ); - ### only set it up once - if( !$loaded++ or $rescan ) { - ### find plugins & extra configs - ### check $home/.cpanplus/lib as well - require Module::Pluggable; - - Module::Pluggable->import( - search_path => ['CPANPLUS::Config'], - search_dirs => [ CONFIG_USER_LIB_DIR ], - except => qr/::SUPER$/, - sub_name => 'configs' - ); - } - - - ### do system config, user config, rest.. in that order - ### apparently, on a 2nd invocation of -->configs, a - ### ::ISA::CACHE package can appear.. that's bad... - my %confs = map { $_ => $_ } - grep { $_ !~ /::ISA::/ } __PACKAGE__->configs; - my @confs = grep { defined } - map { delete $confs{$_} } CONFIG_SYSTEM, CONFIG_USER; - push @confs, sort keys %confs; - - for my $plugin ( @confs ) { - msg(loc("Found config '%1'", $plugin),0); - - ### if we already did this the /last/ time around dont - ### run the setup agian. - if( my $loc = Module::Loaded::is_loaded( $plugin ) ) { - msg(loc(" Already loaded '%1' (%2)", $plugin, $loc), 0); - next; - } else { - msg(loc(" Loading config '%1'", $plugin),0); - - eval { load $plugin }; - msg(loc(" Loaded '%1' (%2)", - $plugin, Module::Loaded::is_loaded( $plugin ) ), 0); - } + ### only set it up once + if( !$loaded++ or $rescan ) { + ### find plugins & extra configs + ### check $home/.cpanplus/lib as well + require Module::Pluggable; + + Module::Pluggable->import( + search_path => ['CPANPLUS::Config'], + search_dirs => [ LIB_DIR->($cur_base) ], + except => qr/::SUPER$/, + sub_name => 'configs' + ); + } - if( $@ ) { - error(loc("Could not load '%1': %2", $plugin, $@)); - next; - } - my $sub = $plugin->can('setup'); - $sub->( $self ) if $sub; + ### do system config, user config, rest.. in that order + ### apparently, on a 2nd invocation of -->configs, a + ### ::ISA::CACHE package can appear.. that's bad... + my %confs = map { $_ => $_ } + grep { $_ !~ /::ISA::/ } __PACKAGE__->configs; + my @confs = grep { defined } + map { delete $confs{$_} } CONFIG_SYSTEM, CONFIG_USER; + push @confs, sort keys %confs; + + for my $plugin ( @confs ) { + msg(loc("Found config '%1'", $plugin),0); + + ### if we already did this the /last/ time around dont + ### run the setup agian. + if( my $loc = Module::Loaded::is_loaded( $plugin ) ) { + msg(loc(" Already loaded '%1' (%2)", $plugin, $loc), 0); + next; + } else { + msg(loc(" Loading config '%1'", $plugin),0); + + if( eval { load $plugin; 1 } ) { + msg(loc(" Loaded '%1' (%2)", + $plugin, Module::Loaded::is_loaded( $plugin ) ), 0); + } else { + error(loc(" Error loading '%1': %2", $plugin, $@)); + } + } + + if( $@ ) { + error(loc("Could not load '%1': %2", $plugin, $@)); + next; + } + + my $sub = $plugin->can('setup'); + $sub->( $self ) if $sub; + } } + ### did one of the plugins change the base dir? then we should + ### scan the dirs again + if( $cur_base ne $self->get_conf('base') ) { + msg(loc("Base dir changed from '%1' to '%2', rescanning", + $cur_base, $self->get_conf('base')), 0); + $self->init( @_, rescan => 1 ); + } + ### clean up the paths once more, just in case $obj->_clean_up_paths; + + ### XXX in case the 'lib' param got changed, we need to + ### add that now, or it's not propagating ;( + { my $lib = $self->get_conf('lib'); + my %inc = map { $_ => $_ } @INC; + for my $l ( @$lib ) { + push @INC, $l unless $inc{$l}; + } + $self->_lib( \@INC ); + } return 1; } diff --git a/lib/CPANPLUS/Configure/Setup.pm b/lib/CPANPLUS/Configure/Setup.pm index 13c5e0a..3bcf8f4 100644 --- a/lib/CPANPLUS/Configure/Setup.pm +++ b/lib/CPANPLUS/Configure/Setup.pm @@ -211,13 +211,13 @@ installation directory. I see you already have this file: %1 -If you continue & save this file, the previous version will be overwritten. +The file will not be overwritten until you explicitly save it. ], $file ); redo ASK_CONFIG_TYPE unless $term->ask_yn( - prompt => loc( "Shall I overwrite it?"), + prompt => loc( "Do you wish to use this file?"), default => 'n', ); } @@ -969,6 +969,32 @@ Would you like to do this? { ################### + ## use sqlite ? ## + ################### + + print loc(" + +To limit the amount of RAM used by CPANPLUS, you can use the SQLite +source backend instead. Note that it is currently still experimental. +Would you like to do this? + +"); + my $type = 'source_engine'; + my $class = 'CPANPLUS::Internals::Source::SQLite'; + my $yn = $term->ask_yn( + prompt => loc("Use SQLite?"), + default => $conf->get_conf( $type ) eq $class ? 1 : 0, + ); + print "\n"; + print $yn + ? loc("I will use SQLite") + : loc("I will not use SQLite"); + + $conf->set_conf( $type => $class ); + } + + { + ################### ## use cpantest? ## ################### diff --git a/lib/CPANPLUS/Dist.pm b/lib/CPANPLUS/Dist.pm index e5e5cc9..8c881bf 100644 --- a/lib/CPANPLUS/Dist.pm +++ b/lib/CPANPLUS/Dist.pm @@ -2,26 +2,21 @@ package CPANPLUS::Dist; use strict; - use CPANPLUS::Error; use CPANPLUS::Internals::Constants; +use Cwd (); +use Object::Accessor; +use Parse::CPAN::Meta; + +use IPC::Cmd qw[run]; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load check_install]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; -use Object::Accessor; -local $Params::Check::VERBOSE = 1; +use base 'Object::Accessor'; -my @methods = qw[status parent]; -for my $key ( @methods ) { - no strict 'refs'; - *{__PACKAGE__."::$key"} = sub { - my $self = shift; - $self->{$key} = $_[0] if @_; - return $self->{$key}; - } -} +local $Params::Check::VERBOSE = 1; =pod @@ -31,8 +26,7 @@ CPANPLUS::Dist =head1 SYNOPSIS - my $dist = CPANPLUS::Dist->new( - format => 'build', + my $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new( module => $modobj, ); @@ -92,59 +86,53 @@ works. This will be set upon a successful create. =back -=head2 $dist = CPANPLUS::Dist->new( module => MODOBJ, [format => DIST_TYPE] ); +=head2 $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new( module => MODOBJ ); -Create a new C object based on the provided C. +Create a new C object based on the +provided C. + +*** DEPRECATED *** The optional argument C is used to indicate what type of dist -you would like to create (like C for a C -object, C for a C object, and so on ). -If not provided, will default to the setting as specified by your -config C. +you would like to create (like C or +C and so on ). + +C<< CPANPLUS::Dist->new >> is exlusively meant as a method to be +inherited by C. -Returns a C object on success and false on failure. +Returns a C object on success +and false on failure. =cut sub new { - my $self = shift; - my %hash = @_; - - local $Params::Check::ALLOW_UNKNOWN = 1; + my $self = shift; + my $class = ref $self || $self; + my %hash = @_; ### first verify we got a module object ### - my $mod; + my( $mod, $format ); my $tmpl = { module => { required => 1, allow => IS_MODOBJ, store => \$mod }, + ### for backwards compatibility + format => { default => $class, store => \$format, + allow => [ __PACKAGE__->dist_types ], + }, }; check( $tmpl, \%hash ) or return; - ### get the conf object ### - my $conf = $mod->parent->configure_object(); - - ### figure out what type of dist object to create ### - my $format; - my $tmpl2 = { - format => { default => $conf->get_conf('dist_type'), - allow => [ __PACKAGE__->dist_types ], - store => \$format }, - }; - check( $tmpl2, \%hash ) or return; - - unless( can_load( modules => { $format => '0.0' }, verbose => 1 ) ) { error(loc("'%1' not found -- you need '%2' version '%3' or higher ". "to detect plugins", $format, 'Module::Pluggable','2.4')); return; } - ### bless the object in the child class ### - my $obj = bless { parent => $mod }, $format; + ### get an empty o::a object for this class + my $obj = $format->SUPER::new; - ### check if the format is available in this environment ### - if( $conf->_get_build('sanity_check') and not $obj->format_available ) { - error( loc( "Format '%1' is not available",$format) ); - return; - } + $obj->mk_accessors( qw[parent status] ); + + ### set the parent + $obj->parent( $mod ); ### create a status object ### { my $acc = Object::Accessor->new; @@ -155,6 +143,15 @@ sub new { distdir dist] ); } + ### get the conf object ### + my $conf = $mod->parent->configure_object(); + + ### check if the format is available in this environment ### + if( $conf->_get_build('sanity_check') and not $obj->format_available ) { + error( loc( "Format '%1' is not available", $format) ); + return; + } + ### now initialize it or admit failure unless( $obj->init ) { error(loc("Dist initialization of '%1' failed for '%2'", @@ -184,6 +181,7 @@ Returns a list of the CPANPLUS::Dist::* classes available ### backdoor method to exclude dist types sub _ignore_dist_types { my $self = shift; push @Ignore, @_ }; + sub _reset_dist_ignore { @Ignore = () }; ### locally add the plugins dir to @INC, so we can find extra plugins #local @INC = @INC, File::Spec->catdir( @@ -199,26 +197,55 @@ Returns a list of the CPANPLUS::Dist::* classes available require Module::Pluggable; my $only_re = __PACKAGE__ . '::\w+$'; + my %except = map { $_ => 1 } + INSTALLER_SAMPLE, + INSTALLER_BASE; Module::Pluggable->import( sub_name => '_dist_types', search_path => __PACKAGE__, only => qr/$only_re/, - except => [ INSTALLER_MM, - INSTALLER_SAMPLE, - INSTALLER_BASE, - ] + require => 1, + except => [ keys %except ] ); my %ignore = map { $_ => $_ } @Ignore; - push @Dists, grep { not $ignore{$_} } __PACKAGE__->_dist_types; + push @Dists, grep { not $ignore{$_} and not $except{$_} } + __PACKAGE__->_dist_types; } return @Dists; } + +=head2 $bool = CPANPLUS::Dist->rescan_dist_types; + +Rescans C<@INC> for available dist types. Useful if you've installed new +C classes and want to make them available to the +current process. + +=cut + + sub rescan_dist_types { + my $dist = shift; + $Loaded = 0; # reset the flag; + return $dist->dist_types; + } } -=head2 prereq_satisfied( modobj => $modobj, version => $version_spec ) +=head2 $bool = CPANPLUS::Dist->has_dist_type( $type ) + +Returns true if distribution type C<$type> is loaded/supported. + +=cut + +sub has_dist_type { + my $dist = shift; + my $type = shift or return; + + return scalar grep { $_ eq $type } CPANPLUS::Dist->dist_types; +} + +=head2 $bool = $dist->prereq_satisfied( modobj => $modobj, version => $version_spec ) Returns true if this prereq is satisfied. Returns false if it's not. Also issues an error if it seems "unsatisfiable," i.e. if it can't be @@ -255,11 +282,81 @@ sub prereq_satisfied { return; } -=head2 _resolve_prereqs +=head2 $configure_requires = $dist->find_configure_requires( [file => /path/to/META.yml] ) + +Reads the configure_requires for this distribution from the META.yml +file in the root directory and returns a hashref with module names +and versions required. + +=cut + +sub find_configure_requires { + my $self = shift; + my $mod = $self->parent; + my %hash = @_; + + my $meta; + my $tmpl = { ### check if we have an extract path. if not, we + ### get 'undef value' warnings from file::spec + file => { default => do { defined $mod->status->extract + ? META_YML->( $mod->status->extract ) + : '' }, + store => \$meta, + }, + }; + + check( $tmpl, \%hash ) or return; + + ### default is an empty hashref + my $configure_requires = $mod->status->configure_requires || {}; + + ### if there's a meta file, we read it; + if( -e $meta ) { + + ### Parse::CPAN::Meta uses exceptions for errors + ### hash returned in list context!!! + my ($doc) = eval { Parse::CPAN::Meta::LoadFile( $meta ) }; + + unless( $doc ) { + error(loc( "Could not read %1: '%2'", $meta, $@ )); + return; + } + + ### read the configure_requires key, make sure not to throw + ### away anything that was already added + $configure_requires = { + %$configure_requires, + %{ $doc->{'configure_requires'} }, + } if $doc->{'configure_requires'}; + } + + ### and store it in the module + $mod->status->configure_requires( $configure_requires ); + + ### and return a copy + return \%{$configure_requires}; +} + +=head2 $bool = $dist->_resolve_prereqs( ... ) Makes sure prerequisites are resolved -XXX Need docs, internal use only + format The dist class to use to make the prereqs + (ie. CPANPLUS::Dist::MM) + + prereqs Hash of the prerequisite modules and their versions + + target What to do with the prereqs. + create => Just build them + install => Install them + ignore => Ignore them + + prereq_build If true, always build the prereqs even if already + resolved + + verbose Be verbose + + force Force the prereq to be built, even if already resolved =cut @@ -297,6 +394,9 @@ sub _resolve_prereqs { ### so there are no prereqs? then don't even bother return 1 unless keys %$prereqs; + ### Make sure we wound up where we started. + my $original_wd = Cwd::cwd; + ### so you didn't provide an explicit target. ### maybe your config can tell us what to do. $target ||= { @@ -340,6 +440,25 @@ sub _resolve_prereqs { for my $mod ( @sorted_prereqs ) { my $version = $prereqs->{$mod}; + + ### 'perl' is a special case, there's no mod object for it + if( $mod eq PERL_CORE ) { + + ### run a CLI invocation to see if the perl you specified is + ### uptodate + my $ok = run( command => "$^X -M$version -e1", verbose => 0 ); + + unless( $ok ) { + error(loc( "Module '%1' needs perl version '%2', but you ". + "only have version '%3' -- can not proceed", + $self->module, $version, + $cb->_perl_version( perl => $^X ) ) ); + return; + } + + next; + } + my $modobj = $cb->module_tree($mod); #### XXX we ignore the version, and just assume that the latest @@ -453,7 +572,6 @@ sub _resolve_prereqs { $pending->{ $modobj->module } = $modobj; $cb->_status->pending_prereqs( $pending ); - ### call $modobj->install rather than doing ### CPANPLUS::Dist->new and the like ourselves, ### since ->install will take care of fetch && @@ -494,6 +612,9 @@ sub _resolve_prereqs { ### reset the $prereqs iterator, in case we bailed out early ### keys %$prereqs; + ### chdir back to where we started + chdir $original_wd; + return 1 unless $flag; return; } diff --git a/lib/CPANPLUS/Dist/Autobundle.pm b/lib/CPANPLUS/Dist/Autobundle.pm new file mode 100644 index 0000000..16638b2 --- /dev/null +++ b/lib/CPANPLUS/Dist/Autobundle.pm @@ -0,0 +1,117 @@ +package CPANPLUS::Dist::Autobundle; + +use strict; +use warnings; +use CPANPLUS::Error qw[error msg]; +use Params::Check qw[check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +use base qw[CPANPLUS::Dist::Base]; + +=head1 NAME + +CPANPLUS::Dist::Autobundle + +=head1 SYNOPSIS + + $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' ); + $modobj->install; + +=head1 DESCRIPTION + +C is a distribution class for installing installation +snapshots as created by C' C command. + +All modules as mentioned in the snapshot will be installed on your system. + +=cut + +sub init { + my $dist = shift; + my $status = $dist->status; + + $status->mk_accessors( + qw[prepared created installed _prepare_args _create_args _install_args] + ); + + return 1; +} + +sub prepare { + my $dist = shift; + my %args = @_; + + ### store the arguments, so ->install can use them in recursive loops ### + $dist->status->_prepare_args( \%args ); + + return $dist->status->prepared( 1 ); +} + +sub create { + my $dist = shift; + my $self = $dist->parent; + + ### we're also the cpan_dist, since we don't need to have anything + ### prepared + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my( $force, $verbose, $prereq_target, $prereq_format, $prereq_build); + + my $args = do { + local $Params::Check::ALLOW_UNKNOWN = 1; + my $tmpl = { + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + prereq_target => { default => '', store => \$prereq_target }, + + ### don't set the default prereq format to 'makemaker' -- wrong! + prereq_format => { #default => $self->status->installer_type, + default => '', + store => \$prereq_format }, + prereq_build => { default => 0, store => \$prereq_build }, + }; + + check( $tmpl, \%hash ) or return; + }; + + ### maybe we already ran a create on this object? ### + return 1 if $dist->status->created && !$force; + + ### store the arguments, so ->install can use them in recursive loops ### + $dist->status->_create_args( \%hash ); + + msg(loc("Resolving prerequisites mentioned in the bundle"), $verbose); + + ### this will set the directory back to the start + ### dir, so we must chdir /again/ + my $ok = $dist->_resolve_prereqs( + format => $prereq_format, + verbose => $verbose, + prereqs => $self->status->prereqs, + target => $prereq_target, + force => $force, + prereq_build => $prereq_build, + ); + + ### if all went well, mark it & return + return $dist->status->created( $ok ? 1 : 0); +} + +sub install { + my $dist = shift; + my %args = @_; + + ### store the arguments, so ->install can use them in recursive loops ### + $dist->status->_install_args( \%args ); + + return $dist->status->installed( 1 ); +} + +1; diff --git a/lib/CPANPLUS/Dist/Base.pm b/lib/CPANPLUS/Dist/Base.pm index 630bf53..c7108ed 100644 --- a/lib/CPANPLUS/Dist/Base.pm +++ b/lib/CPANPLUS/Dist/Base.pm @@ -2,9 +2,10 @@ package CPANPLUS::Dist::Base; use strict; -use vars qw[@ISA $VERSION]; -@ISA = qw[CPANPLUS::Dist]; -$VERSION = '0.01'; +use base qw[CPANPLUS::Dist]; +use vars qw[$VERSION]; +$VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION; + =head1 NAME @@ -56,6 +57,16 @@ class are called: =cut +=head2 @subs = $Class->methods + +Returns a list of methods that this class implements that you can +override. + +=cut + +sub methods { + return qw[format_available init prepare create install uninstall] +} =head2 $bool = $Class->format_available @@ -88,7 +99,7 @@ object, which you might do as follows: $dist->status->mk_accessors( qw[my_implementation_accessor] ); The C object is implemented as an instance of the -C class. Please refer to it's documentation for +C class. Please refer to its documentation for details. Return true if the initialization was successul, and false if it was diff --git a/lib/CPANPLUS/Dist/MM.pm b/lib/CPANPLUS/Dist/MM.pm index e549ca5..2fa1f0c 100644 --- a/lib/CPANPLUS/Dist/MM.pm +++ b/lib/CPANPLUS/Dist/MM.pm @@ -2,8 +2,7 @@ package CPANPLUS::Dist::MM; use strict; use vars qw[@ISA $STATUS]; -@ISA = qw[CPANPLUS::Dist]; - +use base 'CPANPLUS::Dist::Base'; use CPANPLUS::Internals::Constants; use CPANPLUS::Internals::Constants::Report; @@ -27,10 +26,8 @@ CPANPLUS::Dist::MM =head1 SYNOPSIS - my $mm = CPANPLUS::Dist->new( - format => 'makemaker', - module => $modobj, - ); + $mm = CPANPLUS::Dist::MM->new( module => $modobj ); + $mm->create; # runs make && make test $mm->install; # runs make install @@ -219,7 +216,8 @@ sub prepare { } my $args; - my( $force, $verbose, $perl, $mmflags ); + my( $force, $verbose, $perl, $mmflags, $prereq_target, $prereq_format, + $prereq_build ); { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { perl => { default => $^X, store => \$perl }, @@ -230,11 +228,16 @@ sub prepare { store => \$force }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + prereq_target => { default => '', store => \$prereq_target }, + prereq_format => { default => '', + store => \$prereq_format }, + prereq_build => { default => 0, store => \$prereq_build }, }; $args = check( $tmpl, \%hash ) or return; } + ### maybe we already ran a create on this object? ### return 1 if $dist->status->prepared && !$force; @@ -250,6 +253,39 @@ sub prepare { my $fail; RUN: { + + ### we resolve 'configure requires' here, so we can run the 'perl + ### Makefile.PL' command + ### XXX for tests: mock f_c_r to something that *can* resolve and + ### something that *doesnt* resolve. Check the error log for ok + ### on this step or failure + ### XXX make a seperate tarball to test for this scenario: simply + ### containing a makefile.pl/build.pl for test purposes? + { my $configure_requires = $dist->find_configure_requires; + my $ok = $dist->_resolve_prereqs( + format => $prereq_format, + verbose => $verbose, + prereqs => $configure_requires, + target => $prereq_target, + force => $force, + prereq_build => $prereq_build, + ); + + unless( $ok ) { + + #### use $dist->flush to reset the cache ### + error( loc( "Unable to satisfy '%1' for '%2' " . + "-- aborting install", + 'configure_requires', $self->module ) ); + $dist->status->prepared(0); + $fail++; + last RUN; + } + ### end of prereq resolving ### + } + + + ### don't run 'perl makefile.pl' again if there's a makefile already if( -e MAKEFILE->() && (-M MAKEFILE->() < -M $dir) && !$force ) { msg(loc("'%1' already exists, not running '%2 %3' again ". @@ -436,7 +472,7 @@ sub _find_prereqs { } my %p; - while( <$fh> ) { + while( local $_ = <$fh> ) { my ($found) = m|^[\#]\s+PREREQ_PM\s+=>\s+(.+)|; next unless $found; @@ -579,7 +615,7 @@ sub create { ### end of prereq resolving ### my $captured; - + ### 'make' section ### if( -d BLIB->($dir) && (-M BLIB->($dir) < -M $dir) && !$force ) { msg(loc("Already ran '%1' for this module [%2] -- " . diff --git a/lib/CPANPLUS/Internals.pm b/lib/CPANPLUS/Internals.pm index bfc2620..17b48c1 100644 --- a/lib/CPANPLUS/Internals.pm +++ b/lib/CPANPLUS/Internals.pm @@ -12,7 +12,6 @@ use CPANPLUS::Error; use CPANPLUS::Selfupdate; -use CPANPLUS::Internals::Source; use CPANPLUS::Internals::Extract; use CPANPLUS::Internals::Fetch; use CPANPLUS::Internals::Utils; @@ -20,9 +19,13 @@ use CPANPLUS::Internals::Constants; use CPANPLUS::Internals::Search; use CPANPLUS::Internals::Report; + +require base; use Cwd qw[cwd]; +use Module::Load qw[load]; use Params::Check qw[check]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use Module::Load::Conditional qw[can_load]; use Object::Accessor; @@ -32,7 +35,6 @@ local $Params::Check::VERBOSE = 1; use vars qw[@ISA $VERSION]; @ISA = qw[ - CPANPLUS::Internals::Source CPANPLUS::Internals::Extract CPANPLUS::Internals::Fetch CPANPLUS::Internals::Utils @@ -40,7 +42,7 @@ use vars qw[@ISA $VERSION]; CPANPLUS::Internals::Report ]; -$VERSION = "0.84"; +$VERSION = "0.86_06"; =pod @@ -74,21 +76,11 @@ Get/set the configure object Get/set the id -=item _lib - -Get/set the current @INC path -- @INC is reset to this after each -install. - -=item _perl5lib - -Get/set the current PERL5LIB environment variable -- $ENV{PERL5LIB} -is reset to this after each install. - =cut ### autogenerate accessors ### -for my $key ( qw[_conf _id _lib _perl5lib _modules _hosts _methods _status - _callbacks _selfupdate] +for my $key ( qw[_conf _id _modules _hosts _methods _status + _callbacks _selfupdate _mtree _atree] ) { no strict 'refs'; *{__PACKAGE__."::$key"} = sub { @@ -140,8 +132,6 @@ Returns the object on success, or dies on failure. _conf => { required => 1, store => \$conf, allow => IS_CONFOBJ }, _id => { default => '', no_override => 1 }, - _lib => { default => [ @INC ], no_override => 1 }, - _perl5lib => { default => $ENV{'PERL5LIB'}, no_override => 1 }, _authortree => { default => '', no_override => 1 }, _modtree => { default => '', no_override => 1 }, _hosts => { default => {}, no_override => 1 }, @@ -195,13 +185,6 @@ Returns the object on success, or dies on failure. ### initalize it as an empty hashref ### $args->_status->pending_prereqs( {} ); - ### allow for dirs to be added to @INC at runtime, - ### rather then compile time - push @INC, @{$conf->get_conf('lib')}; - - ### add any possible new dirs ### - $args->_lib( [@INC] ); - $conf->_set_build( startdir => cwd() ), or error( loc("couldn't locate current dir!") ); @@ -214,6 +197,27 @@ Returns the object on success, or dies on failure. $id, $args->_id) ); } + ### different source engines available now, so set them here + { my $store = $conf->get_conf( 'source_engine' ) + || DEFAULT_SOURCE_ENGINE; + + unless( can_load( modules => { $store => '0.0' }, verbose => 1 ) ) { + error( loc( "Could not load source engine '%1'", $store ) ); + + if( $store ne DEFAULT_SOURCE_ENGINE ) { + msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 ); + + load DEFAULT_SOURCE_ENGINE; + + base->import( DEFAULT_SOURCE_ENGINE ); + } else { + return; + } + } else { + base->import( $store ); + } + } + return $args; } @@ -230,6 +234,7 @@ be flushed. sub _flush { my $self = shift; + my $conf = $self->configure_object; my %hash = @_; my $aref; @@ -246,14 +251,15 @@ be flushed. ### set the include paths back to their original ### if( $what eq 'lib' ) { - $ENV{PERL5LIB} = $self->_perl5lib || ''; - @INC = @{$self->_lib}; + $ENV{PERL5LIB} = $conf->_perl5lib || ''; + @INC = @{$conf->_lib}; ### give all modules a new status object -- this is slightly ### costly, but the best way to make sure all statusses are ### forgotten --kane } elsif ( $what eq 'modules' ) { for my $modobj ( values %{$self->module_tree} ) { + $modobj->_flush; } diff --git a/lib/CPANPLUS/Internals/Constants.pm b/lib/CPANPLUS/Internals/Constants.pm index bfd4439..f467f78 100644 --- a/lib/CPANPLUS/Internals/Constants.pm +++ b/lib/CPANPLUS/Internals/Constants.pm @@ -13,8 +13,6 @@ use vars qw[$VERSION @ISA @EXPORT]; use Package::Constants; - -$VERSION = 0.01; @ISA = qw[Exporter]; @EXPORT = Package::Constants->list( __PACKAGE__ ); @@ -26,7 +24,9 @@ use constant INSTALLER_BUILD use constant INSTALLER_MM => 'CPANPLUS::Dist::MM'; use constant INSTALLER_SAMPLE => 'CPANPLUS::Dist::Sample'; -use constant INSTALLER_BASE => 'CPANPLUS::Dist::Base'; +use constant INSTALLER_BASE => 'CPANPLUS::Dist::Base'; +use constant INSTALLER_AUTOBUNDLE + => 'CPANPLUS::Dist::Autobundle'; use constant SHELL_DEFAULT => 'CPANPLUS::Shell::Default'; use constant SHELL_CLASSIC => 'CPANPLUS::Shell::Classic'; @@ -36,6 +36,9 @@ use constant CONFIG_USER => 'CPANPLUS::Config::User'; use constant CONFIG_SYSTEM => 'CPANPLUS::Config::System'; use constant CONFIG_BOXED => 'CPANPLUS::Config::Boxed'; +use constant DEFAULT_SOURCE_ENGINE + => 'CPANPLUS::Internals::Source::Memory'; + use constant TARGET_CREATE => 'create'; use constant TARGET_PREPARE => 'prepare'; use constant TARGET_INSTALL => 'install'; @@ -139,7 +142,12 @@ use constant BUILD_PL => sub { return @_ 'Build.PL' ) : 'Build.PL'; }; - + +use constant META_YML => sub { return @_ + ? File::Spec->catfile( @_, 'META.yml' ) + : 'META.yml'; + }; + use constant BLIB => sub { return @_ ? File::Spec->catfile(@_, 'blib') : 'blib'; @@ -203,6 +211,15 @@ use constant README => sub { my $obj = $_[0]; '.readme'; return $pkg; }; +use constant META_EXT => 'meta'; + +use constant META => sub { my $obj = $_[0]; + my $pkg = $obj->package_name; + $pkg .= '-' . $obj->package_version . + '.' . META_EXT; + return $pkg; + }; + use constant OPEN_FILE => sub { my($file, $mode) = (@_, ''); my $fh; @@ -285,6 +302,9 @@ use constant CUSTOM_AUTHOR_ID use constant DOT_SHELL_DEFAULT_RC => '.shell-default.rc'; + +use constant SOURCE_SQLITE_DB + => 'db.sql'; use constant PREREQ_IGNORE => 0; use constant PREREQ_INSTALL => 1; diff --git a/lib/CPANPLUS/Internals/Constants/Report.pm b/lib/CPANPLUS/Internals/Constants/Report.pm index 57034ca..da46f55 100644 --- a/lib/CPANPLUS/Internals/Constants/Report.pm +++ b/lib/CPANPLUS/Internals/Constants/Report.pm @@ -11,13 +11,13 @@ use vars qw[$VERSION @ISA @EXPORT]; use Package::Constants; +### for the version +require CPANPLUS::Internals; -$VERSION = '0.01_01'; +$VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION; @ISA = qw[Exporter]; @EXPORT = Package::Constants->list( __PACKAGE__ ); -### for the version -require CPANPLUS::Internals; ### OS to regex map ### my %OS = ( @@ -29,7 +29,6 @@ my %OS = ( Cygwin => 'cygwin', Darwin => 'darwin', EBCDIC => 'os390|os400|posix-bc|vmesa', - Haiku => 'haiku', HPUX => 'hpux', Linux => 'linux', MSDOS => 'dos|os2|MSWin32|cygwin', @@ -232,11 +231,6 @@ $prereqs } ); -If you are interested in making a more flexible Makefile.PL that can -probe for missing dependencies and install them, ExtUtils::AutoInstall -at may be -worth a look. - Thanks! :-) . diff --git a/lib/CPANPLUS/Internals/Fetch.pm b/lib/CPANPLUS/Internals/Fetch.pm index 139dab6..395965b 100644 --- a/lib/CPANPLUS/Internals/Fetch.pm +++ b/lib/CPANPLUS/Internals/Fetch.pm @@ -49,7 +49,7 @@ This is the rough flow: =cut -=head1 $path = _fetch( module => $modobj, [fetchdir => '/path/to/save/to', fetch_from => 'scheme://path/to/fetch/from', verbose => BOOL, force => BOOL, prefer_bin => BOOL] ) +=head1 $path = _fetch( module => $modobj, [fetchdir => '/path/to/save/to', fetch_from => 'scheme://path/to/fetch/from', verbose => BOOL, force => BOOL, prefer_bin => BOOL, ttl => $seconds] ) C<_fetch> will fetch files based on the information in a module object. You always need a module object. If you want a fake module @@ -71,6 +71,10 @@ C indicates whether you prefer the use of commandline programs over perl modules. Defaults to your corresponding config setting. +C (in seconds) indicates how long a cached copy is valid for. If +the fetch time of the local copy is within the ttl, the cached copy is +returned. Otherwise, the file is refetched. + C<_fetch> figures out, based on the host list, what scheme to use and from there, delegates to C do the actual fetching. @@ -91,7 +95,7 @@ sub _fetch { local $Params::Check::NO_DUPLICATES = 0; - my ($modobj, $verbose, $force, $fetch_from); + my ($modobj, $verbose, $force, $fetch_from, $ttl); my $tmpl = { module => { required => 1, allow => IS_MODOBJ, store => \$modobj }, fetchdir => { default => $conf->get_conf('fetchdir') }, @@ -101,13 +105,15 @@ sub _fetch { verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, prefer_bin => { default => $conf->get_conf('prefer_bin') }, + ttl => { default => 0, store => \$ttl }, }; my $args = check( $tmpl, \%hash ) or return; ### check if we already downloaded the thing ### - if( (my $where = $modobj->status->fetch()) && !$force ) { + if( (my $where = $modobj->status->fetch()) and not $force and not $ttl ) { + msg(loc("Already fetched '%1' to '%2', " . "won't fetch again without force", $modobj->module, $where ), $verbose ); @@ -138,24 +144,52 @@ sub _fetch { $modobj->package, ) ); - } - - ### do we already have the file? ### - if( -e $local_file ) { - - if( $args->{force} ) { - - ### some fetches will fail if the files exist already, so let's - ### delete them first - unlink $local_file - or msg( loc("Could not delete %1, some methods may " . - "fail to force a download", $local_file), $verbose); - } else { - - ### store where we fetched it ### - $modobj->status->fetch( $local_file ); - return $local_file; + ### do we already have the file? if so, can we use the cached version, + ### or do we need to refetch? + if( -e $local_file ) { + + my $unlink = 0; + my $use_cached = 0; + + ### if force is in effect, we have to refetch + if( $force ) { + $unlink++ + + ### if you provided a ttl, and it was exceeded, we'll refetch, + } elsif( $ttl and ([stat $local_file]->[9] + $ttl > time) ) { + msg(loc("Using cached file '%1' on disk; ". + "ttl (%2s) is not exceeded", + $local_file, $ttl), $verbose ); + + $use_cached++; + + ### if you provided a ttl, and the above conditional didn't match, + ### we exceeded the ttl, so we refetch + } elsif ( $ttl ) { + $unlink++; + + ### otherwise we can use the cached version + } else { + $use_cached++; + } + + if( $unlink ) { + ### some fetches will fail if the files exist already, so let's + ### delete them first + 1 while unlink $local_file; + + msg(loc("Could not delete %1, some methods may " . + "fail to force a download", $local_file), $verbose) + if -e $local_file; + + } else { + + ### store where we fetched it ### + $modobj->status->fetch( $local_file ); + + return $local_file; + } } } @@ -366,6 +400,10 @@ sub __file_fetch { } else { my $abs = File::Spec->rel2abs( $file ); + + ### so TTLs will work + $self->_update_timestamp( file => $abs ); + return $abs; } diff --git a/lib/CPANPLUS/Internals/Report.pm b/lib/CPANPLUS/Internals/Report.pm index cbe76ff..6ce44af 100644 --- a/lib/CPANPLUS/Internals/Report.pm +++ b/lib/CPANPLUS/Internals/Report.pm @@ -103,36 +103,44 @@ otherwise. This function queries the CPAN testers database at I for test results of specified module objects, -module names or distributions. +module names or distributions. The optional argument C controls whether all versions of a given distribution should be grabbed. It defaults to false (fetching only reports for the current version). Returns the a list with the following data structures (for CPANPLUS -version 0.042) on success, or false on failure: +version 0.042) on success, or false on failure. The contents of the +data structure depends on what I returns, +but generally looks like this: { 'grade' => 'PASS', 'dist' => 'CPANPLUS-0.042', 'platform' => 'i686-pld-linux-thread-multi' + 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/98316' + ... }, { 'grade' => 'PASS', 'dist' => 'CPANPLUS-0.042', 'platform' => 'i686-linux-thread-multi' + 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99416' + ... }, { 'grade' => 'FAIL', 'dist' => 'CPANPLUS-0.042', 'platform' => 'cygwin-multi-64int', 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99371' + ... }, { 'grade' => 'FAIL', 'dist' => 'CPANPLUS-0.042', 'platform' => 'i586-linux', 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99396' + ... }, The status of the test can be one of the following: @@ -195,20 +203,21 @@ sub _query_report { return; }; - my $dist = $mod->package_name .'-'. $mod->package_version; + my $dist = $mod->package_name .'-'. $mod->package_version; + my $details = TESTERS_DETAILS_URL->($mod->package_name); my @rv; for my $href ( @$aref ) { next unless $all or defined $href->{'distversion'} && $href->{'distversion'} eq $dist; - push @rv, { platform => $href->{'platform'}, - grade => $href->{'action'}, - dist => $href->{'distversion'}, - ( $href->{'action'} eq 'FAIL' - ? (details => TESTERS_DETAILS_URL->($mod->package_name)) - : () - ) }; + $href->{'details'} = $details; + + ### backwards compatibility :( + $href->{'dist'} = delete $href->{'distversion'}; + $href->{'grade'} = delete $href->{'action'}; + + push @rv, $href; } return @rv if @rv; @@ -217,7 +226,7 @@ sub _query_report { =pod -=head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, dontcc => BOOL, verbose => BOOL, force => BOOL]); +=head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, verbose => BOOL, force => BOOL]); This function sends a testers report to C for a particular distribution. @@ -254,16 +263,6 @@ override this, but it might be useful for debugging purposes. Defaults to C. -=item dontcc - -Boolean indicating whether or not we should Cc: the author. If false, -previous error reports are inspected and checked if the author should -be mailed. If set to true, these tests are skipped and the author is -definitely not Cc:'d. -You should probably not change this setting. - -Defaults to false. - =item verbose Boolean indicating on whether or not to be verbose. @@ -296,7 +295,7 @@ sub _send_report { } ### check arguments ### - my ($buffer, $failed, $mod, $verbose, $force, $address, $save, $dontcc, + my ($buffer, $failed, $mod, $verbose, $force, $address, $save, $tests_skipped ); my $tmpl = { module => { required => 1, store => \$mod, allow => IS_MODOBJ }, @@ -304,7 +303,6 @@ sub _send_report { failed => { required => 1, store => \$failed }, address => { default => CPAN_TESTERS_EMAIL, store => \$address }, save => { default => 0, store => \$save }, - dontcc => { default => 0, store => \$dontcc }, verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, force => { default => $conf->get_conf('force'), @@ -325,6 +323,9 @@ sub _send_report { my $cb = $mod->parent; + ### will be 'fetch', 'make', 'test', 'install', etc ### + my $stage = TEST_FAIL_STAGE->($buffer); + ### determine the grade now ### my $grade; @@ -347,8 +348,17 @@ sub _send_report { while( my($prq_name,$prq_ver) = each %$prq ) { my $obj = $cb->module_tree( $prq_name ); + my $sub = CPANPLUS::Module->can( + 'module_is_supplied_with_perl_core' ); - unless( $obj ) { + ### if we can't find the module and it's not supplied with core. + ### this addresses: #32064: NA reports generated for failing + ### tests where core prereqs are specified + ### Note that due to a bug in Module::CoreList, in some released + ### version of perl (5.8.6+ and 5.9.2-4 at the time of writing) + ### 'Config' is not recognized as a core module. See this bug: + ### http://rt.cpan.org/Ticket/Display.html?id=32155 + if( not $obj and not $sub->( $prq_name ) ) { msg(loc( "Prerequisite '%1' for '%2' could not be obtained". " from CPAN -- sending N/A grade", $prq_name, $name ), $verbose ); @@ -396,6 +406,10 @@ sub _send_report { ### see if the thing even had tests ### } elsif ( NO_TESTS_DEFINED->( $buffer ) ) { $grade = GRADE_UNKNOWN; + ### failures in PL or make/build stage are now considered UNKNOWN + } elsif ( $stage !~ /\btest\b/ ) { + + $grade = GRADE_UNKNOWN } else { @@ -409,7 +423,10 @@ sub _send_report { } } ### so an error occurred, let's see what stage it went wrong in ### - my $message; + + ### the header -- always include so the CPANPLUS version is apparent + my $message = REPORT_MESSAGE_HEADER->( $int_ver, $author ); + if( $grade eq GRADE_FAIL or $grade eq GRADE_UNKNOWN) { ### return if one or more missing external libraries @@ -419,16 +436,10 @@ sub _send_report { return 1; } - ### will be 'fetch', 'make', 'test', 'install', etc ### - my $stage = TEST_FAIL_STAGE->($buffer); - ### return if we're only supposed to report make_test failures ### return 1 if $cp_conf =~ /\bmaketest_only\b/i and ($stage !~ /\btest\b/); - ### the header - $message = REPORT_MESSAGE_HEADER->( $int_ver, $author ); - ### the bit where we inform what went wrong $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer ); @@ -460,52 +471,38 @@ sub _send_report { ### that tests got skipped, since the buffer is not added in } elsif ( $tests_skipped ) { $message .= REPORT_TESTS_SKIPPED->(); - } - - ### if it failed, and that already got reported, we're not cc'ing the - ### author. Also, 'dont_cc' might be in the config, so check this; - my $dont_cc_author = $dontcc; - - unless( $dont_cc_author ) { - if( $cp_conf =~ /\bdont_cc\b/i ) { - $dont_cc_author++; - - } elsif ( $grade eq GRADE_PASS ) { - $dont_cc_author++ - - } elsif( $grade eq GRADE_FAIL ) { - my @already_sent = - $self->_query_report( module => $mod, verbose => $verbose ); + } elsif( $grade eq GRADE_NA) { + + ### the bit where we inform what went wrong + $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer ); - ### if we can't fetch it, we'll just assume no one - ### mailed him yet - my $count = 0; - if( @already_sent ) { - for my $href (@already_sent) { - $count++ if uc $href->{'grade'} eq uc GRADE_FAIL; - } - } + ### the footer + $message .= REPORT_MESSAGE_FOOTER->(); - if( $count > MAX_REPORT_SEND and !$force) { - msg(loc("'%1' already reported for '%2', ". - "not cc-ing the author", - GRADE_FAIL, $dist ), $verbose ); - $dont_cc_author++; - } - } } - + msg( loc("Sending test report for '%1'", $dist), $verbose); ### reporter object ### - my $reporter = Test::Reporter->new( - grade => $grade, - distribution => $dist, - via => "CPANPLUS $int_ver", - timeout => $conf->get_conf('timeout') || 60, - debug => $conf->get_conf('debug'), - ); - + my $reporter = do { + my $args = $conf->get_conf('cpantest_reporter_args') || {}; + + unless( UNIVERSAL::isa( $args, 'HASH' ) ) { + error(loc("'%1' must be a hashref, ignoring...", + 'cpantest_reporter_args')); + $args = {}; + } + + Test::Reporter->new( + grade => $grade, + distribution => $dist, + via => "CPANPLUS $int_ver", + timeout => $conf->get_conf('timeout') || 60, + debug => $conf->get_conf('debug'), + %$args, + ); + }; + ### set a custom mx, if requested $reporter->mx( [ $conf->get_conf('cpantest_mx') ] ) if $conf->get_conf('cpantest_mx'); @@ -537,10 +534,6 @@ sub _send_report { $reporter->edit_comments; } - ### people to mail ### - my @inform; - #push @inform, $email unless $dont_cc_author; - ### allow to be overridden, but default to the normal address ### $reporter->address( $address ); @@ -556,9 +549,8 @@ sub _send_report { return; } - ### should we send it to a bunch of people? ### ### XXX should we do an 'already sent' check? ### - } elsif( $reporter->send( @inform ) ) { + } elsif( $reporter->send( ) ) { msg(loc("Successfully sent '%1' report for '%2'", $grade, $dist), $verbose); return 1; diff --git a/lib/CPANPLUS/Internals/Search.pm b/lib/CPANPLUS/Internals/Search.pm index 85e1678..63c4da6 100644 --- a/lib/CPANPLUS/Internals/Search.pm +++ b/lib/CPANPLUS/Internals/Search.pm @@ -44,7 +44,7 @@ based on certain criteria and return them. =head1 METHODS -=head2 _search_module_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] ) +=head2 _search_module_tree( type => TYPE, allow => \@regexes, [data => \@previous_results ] ) Searches the moduletree for module objects matching the criteria you specify. Returns an array ref of module objects on success, and false @@ -137,13 +137,14 @@ specified in C if provided, rather than the moduletree itself. # sub _search_module_tree { + my $self = shift; my $conf = $self->configure_object; my %hash = @_; my($mods,$list,$verbose,$type); my $tmpl = { - data => { default => [values %{$self->module_tree}], + data => { default => [], strict_type=> 1, store => \$mods }, allow => { required => 1, default => [ ], strict_type => 1, store => \$list }, @@ -153,9 +154,17 @@ sub _search_module_tree { store => \$type }, }; - my $args = check( $tmpl, \%hash ) or return; + my $args = do { + ### don't check the template for sanity + ### -- we know it's good and saves a lot of performance + local $Params::Check::SANITY_CHECK_TEMPLATE = 0; - { local $Params::Check::VERBOSE = 0; + check( $tmpl, \%hash ); + } or return; + + ### a list of module objects was supplied + if( @$mods ) { + local $Params::Check::VERBOSE = 0; my @rv; for my $mod (@$mods) { @@ -167,6 +176,13 @@ sub _search_module_tree { } return \@rv; + + } else { + my @rv = $self->_source_search_module_tree( + allow => $list, + type => $type, + ); + return \@rv; } } @@ -214,7 +230,7 @@ sub _search_author_tree { my($authors,$list,$verbose,$type); my $tmpl = { - data => { default => [values %{$self->author_tree}], + data => { default => [], strict_type=> 1, store => \$authors }, allow => { required => 1, default => [ ], strict_type => 1, store => \$list }, @@ -226,7 +242,8 @@ sub _search_author_tree { my $args = check( $tmpl, \%hash ) or return; - { local $Params::Check::VERBOSE = 0; + if( @$authors ) { + local $Params::Check::VERBOSE = 0; my @rv; for my $auth (@$authors) { @@ -237,9 +254,13 @@ sub _search_author_tree { push @rv, $auth if allow( $auth->$type() => $list ); } return \@rv; + } else { + my @rv = $self->_source_search_author_tree( + allow => $list, + type => $type, + ); + return \@rv; } - - } =pod diff --git a/lib/CPANPLUS/Internals/Source.pm b/lib/CPANPLUS/Internals/Source.pm index bcdde87..1a322cb 100644 --- a/lib/CPANPLUS/Internals/Source.pm +++ b/lib/CPANPLUS/Internals/Source.pm @@ -20,6 +20,56 @@ use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; $Params::Check::VERBOSE = 1; +### list of methods the parent class must implement +{ for my $sub ( qw[_init_trees _finalize_trees + _standard_trees_completed _custom_trees_completed + _add_module_object _add_author_object _save_state + ] + ) { + no strict 'refs'; + *$sub = sub { + my $self = shift; + my $class = ref $self || $self; + + require Carp; + Carp::croak( loc( "Class %1 must implement method '%2'", + $class, $sub ) ); + } + } +} + +{ + my $recurse; # flag to prevent recursive calls to *_tree functions + + ### lazy loading of module tree + sub _module_tree { + my $self = $_[0]; + + unless ($self->_mtree or $recurse++ > 0) { + my $uptodate = $self->_check_trees( @_[1..$#_] ); + $self->_build_trees(uptodate => $uptodate); + } + + $recurse--; + return $self->_mtree; + } + + ### lazy loading of author tree + sub _author_tree { + my $self = $_[0]; + + unless ($self->_atree or $recurse++ > 0) { + my $uptodate = $self->_check_trees( @_[1..$#_] ); + $self->_build_trees(uptodate => $uptodate); + } + + $recurse--; + return $self->_atree; + } + +} + + =pod =head1 NAME @@ -51,14 +101,19 @@ The flow looks like this: $cb->__update_custom_module_sources $cb->__update_custom_module_source $cb->_build_trees + ### engine methods + { $cb->_init_trees; + $cb->_standard_trees_completed + $cb->_custom_trees_completed + } $cb->__create_author_tree - $cb->__retrieve_source + ### engine methods + { $cb->_add_author_object } $cb->__create_module_tree - $cb->__retrieve_source $cb->__create_dslip_tree - $cb->__retrieve_source + ### engine methods + { $cb->_add_module_object } $cb->__create_custom_module_entries - $cb->_save_source $cb->_dslip_defs @@ -66,35 +121,127 @@ The flow looks like this: =cut -{ - my $recurse; # flag to prevent recursive calls to *_tree functions +=pod - ### lazy loading of module tree - sub _module_tree { - my $self = $_[0]; +=head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] ) - unless ($self->{_modtree} or $recurse++ > 0) { - my $uptodate = $self->_check_trees( @_[1..$#_] ); - $self->_build_trees(uptodate => $uptodate); - } +This method rebuilds the author- and module-trees from source. - $recurse--; - return $self->{_modtree}; - } +It takes the following arguments: - ### lazy loading of author tree - sub _author_tree { - my $self = $_[0]; +=over 4 - unless ($self->{_authortree} or $recurse++ > 0) { - my $uptodate = $self->_check_trees( @_[1..$#_] ); - $self->_build_trees(uptodate => $uptodate); - } +=item uptodate - $recurse--; - return $self->{_authortree}; +Indicates whether any on disk caches are still ok to use. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=item use_stored + +A boolean flag indicating whether or not it is ok to use previously +stored trees. Defaults to true. + +=back + +Returns a boolean indicating success. + +=cut + +### (re)build the trees ### +sub _build_trees { + my ($self, %hash) = @_; + my $conf = $self->configure_object; + + my($path,$uptodate,$use_stored,$verbose); + my $tmpl = { + path => { default => $conf->get_conf('base'), store => \$path }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + uptodate => { required => 1, store => \$uptodate }, + use_stored => { default => 1, store => \$use_stored }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + $self->_init_trees( + path => $path, + uptodate => $uptodate, + verbose => $verbose, + use_stored => $use_stored, + ) or do { + error( loc("Could not initialize trees" ) ); + return; + }; + + ### return if we weren't able to build the trees ### + return unless $self->_mtree && $self->_atree; + + ### did we get everything from a stored state? if not, + ### process them now. + if( not $self->_standard_trees_completed ) { + + ### first, prep the author tree + $self->__create_author_tree( + uptodate => $uptodate, + path => $path, + verbose => $verbose, + ); + + ### and now the module tree + $self->_create_mod_tree( + uptodate => $uptodate, + path => $path, + verbose => $verbose, + ); + } + + ### XXX unpleasant hack. since custom sources uses ->parse_module, we + ### already have a special module object with extra meta data. that + ### doesn't gelwell with the sqlite storage engine. So, we check 'normal' + ### trees from seperate trees, so the engine can treat them differently. + ### Effectively this means that with the SQLite engine, for now, custom + ### sources are continuously reparsed =/ -kane + if( not $self->_custom_trees_completed ) { + + ### update them if the other sources are also deemed out of date + if( $conf->get_conf('enable_custom_sources') ) { + $self->__update_custom_module_sources( verbose => $verbose ) + or error(loc("Could not update custom module sources")); + } + + ### add custom sources here if enabled + if( $conf->get_conf('enable_custom_sources') ) { + $self->__create_custom_module_entries( verbose => $verbose ) + or error(loc("Could not create custom module entries")); + } } + ### give the source engine a chance to wrap up creation + $self->_finalize_trees( + path => $path, + uptodate => $uptodate, + verbose => $verbose, + use_stored => $use_stored, + ) or do { + error(loc( "Could not finalize trees" )); + return; + }; + + ### still necessary? can only run one instance now ### + ### will probably stay that way --kane +# my $id = $self->_store_id( $self ); +# +# unless ( $id == $self->_id ) { +# error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) ); +# } + + return 1; } =pod @@ -160,7 +307,7 @@ sub _check_trees { for my $name (qw[auth dslip mod]) { for my $file ( $conf->_get_source( $name ) ) { $self->__check_uptodate( - file => File::Spec->catfile( $args->{path}, $file ), + file => File::Spec->catfile( $path, $file ), name => $name, update_source => $update_source, verbose => $verbose, @@ -334,275 +481,6 @@ sub _update_source { =pod -=head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] ) - -This method rebuilds the author- and module-trees from source. - -It takes the following arguments: - -=over 4 - -=item uptodate - -Indicates whether any on disk caches are still ok to use. - -=item path - -The absolute path to the directory holding the source files. - -=item verbose - -A boolean flag indicating whether or not to be verbose. - -=item use_stored - -A boolean flag indicating whether or not it is ok to use previously -stored trees. Defaults to true. - -=back - -Returns a boolean indicating success. - -=cut - -### (re)build the trees ### -sub _build_trees { - my ($self, %hash) = @_; - my $conf = $self->configure_object; - - my($path,$uptodate,$use_stored); - my $tmpl = { - path => { default => $conf->get_conf('base'), store => \$path }, - verbose => { default => $conf->get_conf('verbose') }, - uptodate => { required => 1, store => \$uptodate }, - use_stored => { default => 1, store => \$use_stored }, - }; - - my $args = check( $tmpl, \%hash ) or return undef; - - ### retrieve the stored source files ### - my $stored = $self->__retrieve_source( - path => $path, - uptodate => $uptodate && $use_stored, - verbose => $args->{'verbose'}, - ) || {}; - - ### build the trees ### - $self->{_authortree} = $stored->{_authortree} || - $self->__create_author_tree( - uptodate => $uptodate, - path => $path, - verbose => $args->{verbose}, - ); - $self->{_modtree} = $stored->{_modtree} || - $self->_create_mod_tree( - uptodate => $uptodate, - path => $path, - verbose => $args->{verbose}, - ); - - ### return if we weren't able to build the trees ### - return unless $self->{_modtree} && $self->{_authortree}; - - ### update them if the other sources are also deemed out of date - unless( $uptodate ) { - $self->__update_custom_module_sources( verbose => $args->{verbose} ) - or error(loc("Could not update custom module sources")); - } - - ### add custom sources here - $self->__create_custom_module_entries( verbose => $args->{verbose} ) - or error(loc("Could not create custom module entries")); - - ### write the stored files to disk, so we can keep using them - ### from now on, till they become invalid - ### write them if the original sources weren't uptodate, or - ### we didn't just load storable files - $self->_save_source() if !$uptodate or not keys %$stored; - - ### still necessary? can only run one instance now ### - ### will probably stay that way --kane -# my $id = $self->_store_id( $self ); -# -# unless ( $id == $self->_id ) { -# error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) ); -# } - - return 1; -} - -=pod - -=head2 $cb->__retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL]) - -This method retrieves a Id tree identified by C<$name>. - -It takes the following arguments: - -=over 4 - -=item name - -The internal name for the source file to retrieve. - -=item uptodate - -A flag indicating whether the file-cache is up-to-date or not. - -=item path - -The absolute path to the directory holding the source files. - -=item verbose - -A boolean flag indicating whether or not to be verbose. - -=back - -Will get information from the config file by default. - -Returns a tree on success, false on failure. - -=cut - -sub __retrieve_source { - my $self = shift; - my %hash = @_; - my $conf = $self->configure_object; - - my $tmpl = { - path => { default => $conf->get_conf('base') }, - verbose => { default => $conf->get_conf('verbose') }, - uptodate => { default => 0 }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - ### check if we can retrieve a frozen data structure with storable ### - my $storable = can_load( modules => {'Storable' => '0.0'} ) - if $conf->get_conf('storable'); - - return unless $storable; - - ### $stored is the name of the frozen data structure ### - my $stored = $self->__storable_file( $args->{path} ); - - if ($storable && -e $stored && -s _ && $args->{'uptodate'}) { - msg( loc("Retrieving %1", $stored), $args->{'verbose'} ); - - my $href = Storable::retrieve($stored); - return $href; - } else { - return; - } -} - -=pod - -=head2 $cb->_save_source([verbose => BOOL, path => $path]) - -This method saves all the parsed trees in Id format if -C is available. - -It takes the following arguments: - -=over 4 - -=item path - -The absolute path to the directory holding the source files. - -=item verbose - -A boolean flag indicating whether or not to be verbose. - -=back - -Will get information from the config file by default. - -Returns true on success, false on failure. - -=cut - -sub _save_source { - my $self = shift; - my %hash = @_; - my $conf = $self->configure_object; - - - my $tmpl = { - path => { default => $conf->get_conf('base'), allow => DIR_EXISTS }, - verbose => { default => $conf->get_conf('verbose') }, - force => { default => 1 }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - my $aref = [qw[_modtree _authortree]]; - - ### check if we can retrieve a frozen data structure with storable ### - my $storable; - $storable = can_load( modules => {'Storable' => '0.0'} ) - if $conf->get_conf('storable'); - return unless $storable; - - my $to_write = {}; - foreach my $key ( @$aref ) { - next unless ref( $self->{$key} ); - $to_write->{$key} = $self->{$key}; - } - - return unless keys %$to_write; - - ### $stored is the name of the frozen data structure ### - my $stored = $self->__storable_file( $args->{path} ); - - if (-e $stored && not -w $stored) { - msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} ); - return; - } - - msg( loc("Writing compiled source information to disk. This might take a little while."), - $args->{'verbose'} ); - - my $flag; - unless( Storable::nstore( $to_write, $stored ) ) { - error( loc("could not store %1!", $stored) ); - $flag++; - } - - return $flag ? 0 : 1; -} - -sub __storable_file { - my $self = shift; - my $conf = $self->configure_object; - my $path = shift or return; - - ### check if we can retrieve a frozen data structure with storable ### - my $storable = $conf->get_conf('storable') - ? can_load( modules => {'Storable' => '0.0'} ) - : 0; - - return unless $storable; - - ### $stored is the name of the frozen data structure ### - ### changed to use File::Spec->catfile -jmb - my $stored = File::Spec->rel2abs( - File::Spec->catfile( - $path, #base dir - $conf->_get_source('stored') #file - . '.' . - $Storable::VERSION #the version of storable - . '.stored' #append a suffix - ) - ); - - return $stored; -} - -=pod - =head2 $cb->__create_author_tree([path => $path, uptodate => BOOL, verbose => BOOL]) This method opens a source files and parses its contents into a @@ -646,7 +524,7 @@ sub __create_author_tree { }; my $args = check( $tmpl, \%hash ) or return; - my $tree = {}; + my $file = File::Spec->catfile( $args->{path}, $conf->_get_source('auth') @@ -675,15 +553,15 @@ sub __create_author_tree { "\s* ([^\"\<]+?) \s* <(.+)> \s*" /x; - $tree->{$id} = CPANPLUS::Module::Author->new( + $self->_add_author_object( author => $name, #authors name email => $email, #authors email address cpanid => $id, #authors CPAN ID - _id => $self->_id, #id of this internals object - ); + ) or error( loc("Could not add author '%1'", $name ) ); + } - return $tree; + return $self->_atree; } #__create_author_tree @@ -755,7 +633,6 @@ sub _create_mod_tree { ### don't need it anymore ### unlink $out; - my $tree = {}; my $flag; for ( split /\n/, $cont ) { @@ -784,8 +661,8 @@ sub _create_mod_tree { ### remove file name from the path $data[2] =~ s|/[^/]+$||; - - unless( $self->author_tree($author) ) { + my $aobj = $self->author_tree($author); + unless( $aobj ) { error( loc( "No such author '%1' -- can't make module object " . "'%2' that is supposed to belong to this author", $author, $data[0] ) ); @@ -802,30 +679,35 @@ sub _create_mod_tree { ? $dslip_tree->{ $data[0] }->{$item} : ' '; } - - ### Every module get's stored as a module object ### - $tree->{ $data[0] } = CPANPLUS::Module->new( - module => $data[0], # full module name - version => ($data[1] eq 'undef' # version number - ? '0.0' - : $data[1]), - path => File::Spec::Unix->catfile( - $conf->_get_mirror('base'), - $data[2], - ), # extended path on the cpan mirror, - # like /A/AB/ABIGAIL - comment => $data[3], # comment on the module - author => $self->author_tree($author), - package => $package, # package name, like - # 'foo-bar-baz-1.03.tar.gz' - description => $dslip_tree->{ $data[0] }->{'description'}, - dslip => $dslip, - _id => $self->_id, # id of this internals object - ); + + ### XXX this could be sped up if we used author names, not author + ### objects in creation, and then look them up in the author tree + ### when needed. This will need a fix to all the places that create + ### fake author/module objects as well. + + ### callback to store the individual object + $self->_add_module_object( + module => $data[0], # full module name + version => ($data[1] eq 'undef' # version number + ? '0.0' + : $data[1]), + path => File::Spec::Unix->catfile( + $conf->_get_mirror('base'), + $data[2], + ), # extended path on the cpan mirror, + # like /A/AB/ABIGAIL + comment => $data[3], # comment on the module + author => $aobj, + package => $package, # package name, like + # 'foo-bar-baz-1.03.tar.gz' + description => $dslip_tree->{ $data[0] }->{'description'}, + dslip => $dslip, + mtime => '', + ) or error( loc( "Could not add module '%1'", $data[0] ) ); } #for - return $tree; + return $self->_mtree; } #_create_mod_tree @@ -1174,6 +1056,12 @@ Returns a list of key value pairs as follows: sub __list_custom_module_sources { my $self = shift; my $conf = $self->configure_object; + + my($verbose); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; my $dir = File::Spec->catdir( $conf->get_conf('base'), @@ -1181,7 +1069,7 @@ sub __list_custom_module_sources { ); unless( IS_DIR->( $dir ) ) { - msg(loc("No '%1' dir, skipping custom sources", $dir)); + msg(loc("No '%1' dir, skipping custom sources", $dir), $verbose); return; } @@ -1335,7 +1223,7 @@ sub __update_custom_module_source { #msg(loc("Index file written to '%1'", $to), $verbose); } - ### copy it to the real spot and update it's timestamp + ### copy it to the real spot and update its timestamp } else { $self->_move( file => $res, to => $local ) or return; $self->_update_timestamp( file => $local ); @@ -1451,7 +1339,7 @@ Returns true on success, false on failure. my $fh = OPEN_FILE->( $file ) or next; - while( <$fh> ) { + while( local $_ = <$fh> ) { chomp; next if /^#/; next unless /\S+/; @@ -1501,12 +1389,4 @@ Returns true on success, false on failure. } } - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - 1; diff --git a/lib/CPANPLUS/Internals/Source/Memory.pm b/lib/CPANPLUS/Internals/Source/Memory.pm new file mode 100644 index 0000000..fc108d5 --- /dev/null +++ b/lib/CPANPLUS/Internals/Source/Memory.pm @@ -0,0 +1,372 @@ +package CPANPLUS::Internals::Source::Memory; + +use base 'CPANPLUS::Internals::Source'; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Module; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author; +use CPANPLUS::Internals::Constants; + +use File::Fetch; +use Archive::Extract; + +use IPC::Cmd qw[can_run]; +use File::Temp qw[tempdir]; +use File::Basename qw[dirname]; +use Params::Check qw[allow check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +=head1 NAME + +CPANPLUS::Internals::Source::Memory - In memory implementation + +=cut + +### flag to show if init_trees got its' data from storable. This allows +### us to not write an existing stored file back to disk +{ my $from_storable; + + sub _init_trees { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($path,$uptodate,$verbose,$use_stored); + my $tmpl = { + path => { default => $conf->get_conf('base'), store => \$path }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + uptodate => { required => 1, store => \$uptodate }, + use_stored => { default => 1, store => \$use_stored }, + }; + + check( $tmpl, \%hash ) or return; + + ### retrieve the stored source files ### + my $stored = $self->__memory_retrieve_source( + path => $path, + uptodate => $uptodate && $use_stored, + verbose => $verbose, + ) || {}; + + ### we got this from storable if $stored has keys.. + $from_storable = keys %$stored ? 1 : 0; + + ### set up the trees + $self->_atree( $stored->{_atree} || {} ); + $self->_mtree( $stored->{_mtree} || {} ); + + return 1; + } + + sub _standard_trees_completed { return $from_storable } + sub _custom_trees_completed { return $from_storable } + + sub _finalize_trees { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($path,$uptodate,$verbose); + my $tmpl = { + path => { default => $conf->get_conf('base'), store => \$path }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + uptodate => { required => 1, store => \$uptodate }, + }; + + { local $Params::Check::ALLOW_UNKNOWN = 1; + check( $tmpl, \%hash ) or return; + } + + ### write the stored files to disk, so we can keep using them + ### from now on, till they become invalid + ### write them if the original sources weren't uptodate, or + ### we didn't just load storable files + $self->__memory_save_source() if !$uptodate or not $from_storable; + + return 1; + } + + ### saves current memory state + sub _save_state { + my $self = shift; + return $self->_finalize_trees( @_, uptodate => 0 ); + } +} + +sub _add_author_object { + my $self = shift; + my %hash = @_; + + my $class; + my $tmpl = { + class => { default => 'CPANPLUS::Module::Author', store => \$class }, + map { $_ => { required => 1 } } + qw[ author cpanid email ] + }; + + my $href = do { + local $Params::Check::NO_DUPLICATES = 1; + check( $tmpl, \%hash ) or return; + }; + + my $obj = $class->new( %$href, _id => $self->_id ); + + $self->author_tree->{ $href->{'cpanid'} } = $obj or return; + + return $obj; +} + +sub _add_module_object { + my $self = shift; + my %hash = @_; + + my $class; + my $tmpl = { + class => { default => 'CPANPLUS::Module', store => \$class }, + map { $_ => { required => 1 } } + qw[ module version path comment author package description dslip mtime ] + }; + + my $href = do { + local $Params::Check::NO_DUPLICATES = 1; + check( $tmpl, \%hash ) or return; + }; + + my $obj = $class->new( %$href, _id => $self->_id ); + + ### Every module get's stored as a module object ### + $self->module_tree->{ $href->{module} } = $obj or return; + + return $obj; +} + +{ my %map = ( + _source_search_module_tree => [ module_tree => 'CPANPLUS::Module' ], + _source_search_author_tree => [ author_tree => 'CPANPLUS::Module::Author' ], + ); + + while( my($sub, $aref) = each %map ) { + no strict 'refs'; + + my($meth, $class) = @$aref; + + *$sub = sub { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($authors,$list,$verbose,$type); + my $tmpl = { + data => { default => [], + strict_type=> 1, store => \$authors }, + allow => { required => 1, default => [ ], strict_type => 1, + store => \$list }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + type => { required => 1, allow => [$class->accessors()], + store => \$type }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my @rv; + for my $obj ( values %{ $self->$meth } ) { + #push @rv, $auth if check( + # { $type => { allow => $list } }, + # { $type => $auth->$type } + # ); + push @rv, $obj if allow( $obj->$type() => $list ); + } + + return @rv; + } + } +} + +=pod + +=head2 $cb->__memory_retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL]) + +This method retrieves a Id tree identified by C<$name>. + +It takes the following arguments: + +=over 4 + +=item name + +The internal name for the source file to retrieve. + +=item uptodate + +A flag indicating whether the file-cache is up-to-date or not. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns a tree on success, false on failure. + +=cut + +sub __memory_retrieve_source { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + my $tmpl = { + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### check if we can retrieve a frozen data structure with storable ### + my $storable = can_load( modules => {'Storable' => '0.0'} ) + if $conf->get_conf('storable'); + + return unless $storable; + + ### $stored is the name of the frozen data structure ### + my $stored = $self->__memory_storable_file( $args->{path} ); + + if ($storable && -e $stored && -s _ && $args->{'uptodate'}) { + msg( loc("Retrieving %1", $stored), $args->{'verbose'} ); + + my $href = Storable::retrieve($stored); + return $href; + } else { + return; + } +} + +=pod + +=head2 $cb->__memory_save_source([verbose => BOOL, path => $path]) + +This method saves all the parsed trees in Id format if +C is available. + +It takes the following arguments: + +=over 4 + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns true on success, false on failure. + +=cut + +sub __memory_save_source { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + path => { default => $conf->get_conf('base'), allow => DIR_EXISTS }, + verbose => { default => $conf->get_conf('verbose') }, + force => { default => 1 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $aref = [qw[_mtree _atree]]; + + ### check if we can retrieve a frozen data structure with storable ### + my $storable; + $storable = can_load( modules => {'Storable' => '0.0'} ) + if $conf->get_conf('storable'); + return unless $storable; + + my $to_write = {}; + foreach my $key ( @$aref ) { + next unless ref( $self->$key ); + $to_write->{$key} = $self->$key; + } + + return unless keys %$to_write; + + ### $stored is the name of the frozen data structure ### + my $stored = $self->__memory_storable_file( $args->{path} ); + + if (-e $stored && not -w $stored) { + msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} ); + return; + } + + msg( loc("Writing compiled source information to disk. This might take a little while."), + $args->{'verbose'} ); + + my $flag; + unless( Storable::nstore( $to_write, $stored ) ) { + error( loc("could not store %1!", $stored) ); + $flag++; + } + + return $flag ? 0 : 1; +} + +sub __memory_storable_file { + my $self = shift; + my $conf = $self->configure_object; + my $path = shift or return; + + ### check if we can retrieve a frozen data structure with storable ### + my $storable = $conf->get_conf('storable') + ? can_load( modules => {'Storable' => '0.0'} ) + : 0; + + return unless $storable; + + ### $stored is the name of the frozen data structure ### + ### changed to use File::Spec->catfile -jmb + my $stored = File::Spec->rel2abs( + File::Spec->catfile( + $path, #base dir + $conf->_get_source('stored') #file + . '.' . + $Storable::VERSION #the version of storable + . '.stored' #append a suffix + ) + ); + + return $stored; +} + + + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + +1; diff --git a/lib/CPANPLUS/Internals/Source/SQLite.pm b/lib/CPANPLUS/Internals/Source/SQLite.pm new file mode 100644 index 0000000..71d33b8 --- /dev/null +++ b/lib/CPANPLUS/Internals/Source/SQLite.pm @@ -0,0 +1,326 @@ +package CPANPLUS::Internals::Source::SQLite; + +use strict; +use warnings; + +use base 'CPANPLUS::Internals::Source'; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Internals::Source::SQLite::Tie; + +use Data::Dumper; +use DBIx::Simple; +use DBD::SQLite; + +use Params::Check qw[allow check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +use constant TXN_COMMIT => 1000; + +=head1 NAME + +CPANPLUS::Internals::Source::SQLite - SQLite implementation + +=cut + +{ my $Dbh; + my $DbFile; + + sub __sqlite_file { + return $DbFile if $DbFile; + + my $self = shift; + my $conf = $self->configure_object; + + $DbFile = File::Spec->catdir( + $conf->get_conf('base'), + SOURCE_SQLITE_DB + ); + + return $DbFile; + }; + + sub __sqlite_dbh { + return $Dbh if $Dbh; + + my $self = shift; + $Dbh = DBIx::Simple->connect( + "dbi:SQLite:dbname=" . $self->__sqlite_file, + '', '', + { AutoCommit => 0 } + ); + #$Dbh->dbh->trace(1); + + return $Dbh; + }; +} + +{ my $used_old_copy = 0; + + sub _init_trees { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($path,$uptodate,$verbose,$use_stored); + my $tmpl = { + path => { default => $conf->get_conf('base'), store => \$path }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + uptodate => { required => 1, store => \$uptodate }, + use_stored => { default => 1, store => \$use_stored }, + }; + + check( $tmpl, \%hash ) or return; + + ### if it's not uptodate, or the file doesn't exist, we need to create + ### a new sqlite db + if( not $uptodate or not -e $self->__sqlite_file ) { + $used_old_copy = 0; + + ### chuck the file + 1 while unlink $self->__sqlite_file; + + ### and create a new one + $self->__sqlite_create_db or do { + error(loc("Could not create new SQLite DB")); + return; + } + } else { + $used_old_copy = 1; + } + + ### set up the author tree + { my %at; + tie %at, 'CPANPLUS::Internals::Source::SQLite::Tie', + dbh => $self->__sqlite_dbh, table => 'author', + key => 'cpanid', cb => $self; + + $self->_atree( \%at ); + } + + ### set up the author tree + { my %mt; + tie %mt, 'CPANPLUS::Internals::Source::SQLite::Tie', + dbh => $self->__sqlite_dbh, table => 'module', + key => 'module', cb => $self; + + $self->_mtree( \%mt ); + } + + ### start a transaction + $self->__sqlite_dbh->query('BEGIN'); + + return 1; + + } + + sub _standard_trees_completed { return $used_old_copy } + sub _custom_trees_completed { return } + ### finish transaction + sub _finalize_trees { $_[0]->__sqlite_dbh->query('COMMIT'); return 1 } + + ### saves current memory state, but not implemented in sqlite + sub _save_state { + error(loc("%1 has not implemented writing state to disk", __PACKAGE__)); + return; + } +} + +{ my $txn_count = 0; + + ### XXX move this outside the sub, so we only compute it once + my $class; + my @keys = qw[ author cpanid email ]; + my $tmpl = { + class => { default => 'CPANPLUS::Module::Author', store => \$class }, + map { $_ => { required => 1 } } @keys + }; + + ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually + my $ph = join ',', map { '?' } @keys; + + + sub _add_author_object { + my $self = shift; + my %hash = @_; + my $dbh = $self->__sqlite_dbh; + + my $href = do { + local $Params::Check::NO_DUPLICATES = 1; + local $Params::Check::SANITY_CHECK_TEMPLATE = 0; + check( $tmpl, \%hash ) or return; + }; + + ### keep counting how many we inserted + unless( ++$txn_count % TXN_COMMIT ) { + #warn "Committing transaction $txn_count"; + $dbh->query('COMMIT') or error( $dbh->error ); # commit previous transaction + $dbh->query('BEGIN') or error( $dbh->error ); # and start a new one + } + + $dbh->query( + "INSERT INTO author (". join(',',keys(%$href)) .") VALUES ($ph)", + values %$href + ) or do { + error( $dbh->error ); + return; + }; + + return 1; + } +} + +{ my $txn_count = 0; + + ### XXX move this outside the sub, so we only compute it once + my $class; + my @keys = qw[ module version path comment author package description dslip mtime ]; + my $tmpl = { + class => { default => 'CPANPLUS::Module', store => \$class }, + map { $_ => { required => 1 } } @keys + }; + + ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually + my $ph = join ',', map { '?' } @keys; + + sub _add_module_object { + my $self = shift; + my %hash = @_; + my $dbh = $self->__sqlite_dbh; + + my $href = do { + local $Params::Check::NO_DUPLICATES = 1; + local $Params::Check::SANITY_CHECK_TEMPLATE = 0; + check( $tmpl, \%hash ) or return; + }; + + ### fix up author to be 'plain' string + $href->{'author'} = $href->{'author'}->cpanid; + + ### keep counting how many we inserted + unless( ++$txn_count % TXN_COMMIT ) { + #warn "Committing transaction $txn_count"; + $dbh->query('COMMIT') or error( $dbh->error ); # commit previous transaction + $dbh->query('BEGIN') or error( $dbh->error ); # and start a new one + } + + $dbh->query( + "INSERT INTO module (". join(',',keys(%$href)) .") VALUES ($ph)", + values %$href + ) or do { + error( $dbh->error ); + return; + }; + + return 1; + } +} + +{ my %map = ( + _source_search_module_tree + => [ module => module => 'CPANPLUS::Module' ], + _source_search_author_tree + => [ author => cpanid => 'CPANPLUS::Module::Author' ], + ); + + while( my($sub, $aref) = each %map ) { + no strict 'refs'; + + my($table, $key, $class) = @$aref; + *$sub = sub { + my $self = shift; + my %hash = @_; + my $dbh = $self->__sqlite_dbh; + + my($list,$type); + my $tmpl = { + allow => { required => 1, default => [ ], strict_type => 1, + store => \$list }, + type => { required => 1, allow => [$class->accessors()], + store => \$type }, + }; + + check( $tmpl, \%hash ) or return; + + + ### we aliased 'module' to 'name', so change that here too + $type = 'module' if $type eq 'name'; + + my $res = $dbh->query( "SELECT * from $table" ); + + my $meth = $table .'_tree'; + my @rv = map { $self->$meth( $_->{$key} ) } + grep { allow( $_->{$type} => $list ) } $res->hashes; + + return @rv; + } + } +} + + + +sub __sqlite_create_db { + my $self = shift; + my $dbh = $self->__sqlite_dbh; + + ### we can ignore the result/error; not all sqlite implemantation + ### support this + $dbh->query( qq[ + DROP TABLE IF EXISTS author; + \n] + ) or do { + msg( $dbh->error ); + }; + $dbh->query( qq[ + DROP TABLE IF EXISTS module; + \n] + ) or do { + msg( $dbh->error ); + }; + + + + $dbh->query( qq[ + /* the author information */ + CREATE TABLE author ( + id INTEGER PRIMARY KEY AUTOINCREMENT, + + author varchar(255), + email varchar(255), + cpanid varchar(255) + ); + \n] + + ) or do { + error( $dbh->error ); + return; + }; + + $dbh->query( qq[ + /* the module information */ + CREATE TABLE module ( + id INTEGER PRIMARY KEY AUTOINCREMENT, + + module varchar(255), + version varchar(255), + path varchar(255), + comment varchar(255), + author varchar(255), + package varchar(255), + description varchar(255), + dslip varchar(255), + mtime varchar(255) + ); + + \n] + + ) or do { + error( $dbh->error ); + return; + }; + + return 1; +} + +1; diff --git a/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm b/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm new file mode 100644 index 0000000..f908c98 --- /dev/null +++ b/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm @@ -0,0 +1,145 @@ +package CPANPLUS::Internals::Source::SQLite::Tie; + +use strict; +use warnings; + +use CPANPLUS::Error; +use CPANPLUS::Module; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author::Fake; +use CPANPLUS::Internals::Constants; + + +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + + +use Data::Dumper; +$Data::Dumper::Indent = 1; + +require Tie::Hash; +use vars qw[@ISA]; +push @ISA, 'Tie::StdHash'; + + +sub TIEHASH { + my $class = shift; + my %hash = @_; + + my $tmpl = { + dbh => { required => 1 }, + table => { required => 1 }, + key => { required => 1 }, + cb => { required => 1 }, + offset => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + my $obj = bless { %$args, store => {} } , $class; + + return $obj; +} + +sub FETCH { + my $self = shift; + my $key = shift or return; + my $dbh = $self->{dbh}; + my $cb = $self->{cb}; + my $table = $self->{table}; + + + ### did we look this one up before? + if( my $obj = $self->{store}->{$key} ) { + return $obj; + } + + my $res = $dbh->query( + "SELECT * from $table where $self->{key} = ?", $key + ) or do { + error( $dbh->error ); + return; + }; + + my $href = $res->hash; + + ### get rid of the primary key + delete $href->{'id'}; + + ### no results? + return unless keys %$href; + + ### expand author if needed + ### XXX no longer generic :( + if( $table eq 'module' ) { + $href->{author} = $cb->author_tree( $href->{author } ) or return; + } + + my $class = { + module => 'CPANPLUS::Module', + author => 'CPANPLUS::Module::Author', + }->{ $table }; + + my $obj = $self->{store}->{$key} = $class->new( %$href, _id => $cb->_id ); + + return $obj; +} + +sub STORE { + my $self = shift; + my $key = shift; + my $val = shift; + + $self->{store}->{$key} = $val; +} + +1; + +sub FIRSTKEY { + my $self = shift; + my $dbh = $self->{'dbh'}; + + my $res = $dbh->query( + "select $self->{key} from $self->{table} order by $self->{key} limit 1" + ); + + $self->{offset} = 0; + + my $key = $res->flat->[0]; + + return $key; +} + +sub NEXTKEY { + my $self = shift; + my $dbh = $self->{'dbh'}; + + my $res = $dbh->query( + "select $self->{key} from $self->{table} ". + "order by $self->{key} limit 1 offset $self->{offset}" + ); + + $self->{offset} +=1; + + my $key = $res->flat->[0]; + my $val = $self->FETCH( $key ); + + ### use each() semantics + return wantarray ? ( $key, $val ) : $key; +} + +sub EXISTS { !!$_[0]->FETCH( $_[1] ) } + +sub SCALAR { + my $self = shift; + my $dbh = $self->{'dbh'}; + + my $res = $dbh->query( "select count(*) from $self->{table}" ); + + return $res->flat; +} + +### intentionally left blank +sub DELETE { } +sub CLEAR { } + diff --git a/lib/CPANPLUS/Internals/Utils.pm b/lib/CPANPLUS/Internals/Utils.pm index 1a260ef..d79320c 100644 --- a/lib/CPANPLUS/Internals/Utils.pm +++ b/lib/CPANPLUS/Internals/Utils.pm @@ -472,7 +472,7 @@ sub _safe_path { =head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING ); -Splits the name of a CPAN package string up in it's package, version +Splits the name of a CPAN package string up into its package, version and extension parts. For example, C would return the following parts: @@ -495,8 +495,8 @@ For example, C would return the following parts: )* /xi; - my $ver_re = qr/[a-z]*\d+[a-z]* # contains a digit and possibly letters - (?: + my $ver_re = qr/[a-z]*\d*?[a-z]* # contains a digit and possibly letters + (?: # however, some start with a . only :( [-._] # followed by a delimiter [a-z\d]+ # and more digits and or letters )*? @@ -521,11 +521,13 @@ For example, C would return the following parts: ### composed regex for CPAN packages my $full_re = qr/ ^ - ($pkg_re+) # package - (?: - $del_re # delimiter - $ver_ext_re # version + extension - )? + ( # the whole thing + ($pkg_re+) # package + (?: + $del_re # delimiter + $ver_ext_re # version + extension + )? + ) $ /xi; @@ -533,10 +535,12 @@ For example, C would return the following parts: my $perl = PERL_CORE; my $perl_re = qr/ ^ - ($perl) # package name for 'perl' - (?: - $ver_ext_re # version + extension - )? + ( # the whole thing + ($perl) # package name for 'perl' + (?: + $ver_ext_re # version + extension + )? + ) $ /xi; @@ -558,9 +562,10 @@ sub _split_package_string { ### try the next if the match fails $str =~ $re or next; - my $pkg = $1 || ''; - my $ver = $2 || ''; - my $ext = $3 || ''; + my $full = $1 || ''; + my $pkg = $2 || ''; + my $ver = $3 || ''; + my $ext = $4 || ''; ### this regex resets the capture markers! ### strip the trailing delimiter @@ -569,7 +574,7 @@ sub _split_package_string { ### strip the .pm package suffix some authors insist on adding $pkg =~ s/\.pm$//i; - return ($pkg, $ver, $ext ); + return ($pkg, $ver, $ext, $full ); } return; diff --git a/lib/CPANPLUS/Module.pm b/lib/CPANPLUS/Module.pm index fb6be9b..b8949fe 100644 --- a/lib/CPANPLUS/Module.pm +++ b/lib/CPANPLUS/Module.pm @@ -16,6 +16,7 @@ use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use IPC::Cmd qw[can_run run]; use File::Find qw[find]; use Params::Check qw[check]; +use File::Basename qw[dirname]; use Module::Load::Conditional qw[can_load check_install]; $Params::Check::VERBOSE = 1; @@ -231,7 +232,7 @@ C object. Undefined if you didn't specify a separate format to install through. -=item prereqs +=item prereqs | requires A hashref of prereqs this distribution was found to have. Will look something like this: @@ -240,6 +241,11 @@ something like this: Might be undefined if the distribution didn't have any prerequisites. +=item configure_requires + +Like prereqs, but these are necessary to be installed before the +build process can even begin. + =item signature Flag indicating, if a signature check was done, whether it was OK or @@ -287,7 +293,7 @@ The checksum value this distribution is expected to have =head1 METHODS -=head2 $self = CPANPLUS::Module::new( OPTIONS ) +=head2 $self = CPANPLUS::Module->new( OPTIONS ) This method returns a C object. Normal users should never call this method directly, but instead use the @@ -333,7 +339,13 @@ sub status { $acc->mk_accessors( qw[ installer_type dist_cpan dist prereqs signature extract fetch readme uninstall created installed prepared checksums files - checksum_ok checksum_value _fetch_from] ); + checksum_ok checksum_value _fetch_from + configure_requires + ] ); + + ### create an alias from 'requires' to 'prereqs', so it's more in + ### line with 'configure_requires'; + $acc->mk_aliases( requires => 'prereqs' ); $self->_status( $acc ); @@ -348,17 +360,17 @@ sub _flush { return 1; } -=head2 $mod->package_name +=head2 $mod->package_name( [$package_string] ) Returns the name of the package a module is in. For C that might be C. -=head2 $mod->package_version +=head2 $mod->package_version( [$package_string] ) Returns the version of the package a module is in. For a module in the package C this would be C<1.1>. -=head2 $mod->package_extension +=head2 $mod->package_extension( [$package_string] ) Returns the suffix added by the compression method of a package a certain module is in. For a module in C, this @@ -380,6 +392,11 @@ Returns a boolean indicating if the module you are looking at, is actually a bundle. Bundles are identified as modules whose name starts with C. +=head2 $mod->is_autobundle; + +Returns a boolean indicating if the module you are looking at, is +actually an autobundle as generated by C<< $cb->autobundle >>. + =head2 $mod->is_third_party Returns a boolean indicating whether the package is a known third-party @@ -408,9 +425,8 @@ L for more details. no strict 'refs'; *$name = sub { my $self = shift; - my @res = $self->parent->_split_package_string( - package => $self->package - ); + my $val = shift || $self->package; + my @res = $self->parent->_split_package_string( package => $val ); ### return the corresponding index from the result return $res[$index] if @res; @@ -446,16 +462,46 @@ L for more details. my $self = shift; my $ver = shift || $]; + ### allow it to be called as a package function as well like: + ### CPANPLUS::Module::module_is_supplied_with_perl_core('Config') + ### so that we can check the status of modules that aren't released + ### to CPAN, but are part of the core. + my $name = ref $self ? $self->module : $self; + ### check Module::CoreList to see if it's a core package require Module::CoreList; - my $core = $Module::CoreList::version{ $ver }->{ $self->module }; + + ### Address #41157: Module::module_is_supplied_with_perl_core() + ### broken for perl 5.10: Module::CoreList's version key for the + ### hash has a different number of trailing zero than $] aka + ### $PERL_VERSION. + my $core = $Module::CoreList::version{ 0+$ver }->{ $name }; return $core; } ### make sure Bundle-Foo also gets flagged as bundle sub is_bundle { - return shift->module =~ /^bundle(?:-|::)/i ? 1 : 0; + my $self = shift; + + ### cpan'd bundle + return 1 if $self->module =~ /^bundle(?:-|::)/i; + + ### autobundle + return 1 if $self->is_autobundle; + + ### neither + return; + } + + ### full path to a generated autobundle + sub is_autobundle { + my $self = shift; + my $conf = $self->parent->configure_object; + my $prefix = $conf->_get_build('autobundle_prefix'); + + return 1 if $self->module eq $prefix; + return; } sub is_third_party { @@ -485,18 +531,19 @@ a fake C object. =cut -sub clone { - my $self = shift; - - ### clone the object ### - my %data; - for my $acc ( grep !/status/, __PACKAGE__->accessors() ) { - $data{$acc} = $self->$acc(); +{ ### accessors dont change during run time, so only compute once + my @acc = grep !/status/, __PACKAGE__->accessors(); + + sub clone { + my $self = shift; + + ### clone the object ### + my %data = map { $_ => $self->$_ } @acc; + + my $obj = CPANPLUS::Module::Fake->new( %data ); + + return $obj; } - - my $obj = CPANPLUS::Module::Fake->new( %data ); - - return $obj; } =pod @@ -556,7 +603,16 @@ sub extract { $self->module) ); return; } - + + ### can't extract these, so just use the basedir for the file + if( $self->is_autobundle ) { + + ### this is expected to be set after an extract call + $self->get_installer_type; + + return $self->status->extract( dirname( $self->status->fetch ) ); + } + return $cb->_extract( @_, module => $self ); } @@ -578,41 +634,60 @@ sub get_installer_type { my $conf = $cb->configure_object; my %hash = @_; - my $prefer_makefile; + my ($prefer_makefile,$verbose); my $tmpl = { prefer_makefile => { default => $conf->get_conf('prefer_makefile'), - store => \$prefer_makefile, allow => BOOLEANS }, + store => \$prefer_makefile, allow => BOOLEANS }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, }; check( $tmpl, \%hash ) or return; - my $extract = $self->status->extract(); - unless( $extract ) { - error(loc("Cannot determine installer type of unextracted module '%1'", - $self->module)); - return; - } - - - ### check if it's a makemaker or a module::build type dist ### - my $found_build = -e BUILD_PL->( $extract ); - my $found_makefile = -e MAKEFILE_PL->( $extract ); - my $type; - $type = INSTALLER_BUILD if !$prefer_makefile && $found_build; - $type = INSTALLER_BUILD if $found_build && !$found_makefile; - $type = INSTALLER_MM if $prefer_makefile && $found_makefile; - $type = INSTALLER_MM if $found_makefile && !$found_build; + + ### autobundles use their own installer, so return that + if( $self->is_autobundle ) { + $type = INSTALLER_AUTOBUNDLE; + + } else { + my $extract = $self->status->extract(); + unless( $extract ) { + error(loc( + "Cannot determine installer type of unextracted module '%1'", + $self->module + )); + return; + } + + ### check if it's a makemaker or a module::build type dist ### + my $found_build = -e BUILD_PL->( $extract ); + my $found_makefile = -e MAKEFILE_PL->( $extract ); + + $type = INSTALLER_BUILD if !$prefer_makefile && $found_build; + $type = INSTALLER_BUILD if $found_build && !$found_makefile; + $type = INSTALLER_MM if $prefer_makefile && $found_makefile; + $type = INSTALLER_MM if $found_makefile && !$found_build; + } ### ok, so it's a 'build' installer, but you don't /have/ module build - if( $type eq INSTALLER_BUILD and ( - not grep { $_ eq INSTALLER_BUILD } CPANPLUS::Dist->dist_types ) + if( $type eq INSTALLER_BUILD and + not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD ) ) { - error( loc( "This module requires '%1' and '%2' to be installed, ". - "but you don't have it! Will fall back to ". - "'%3', but might not be able to install!", - 'Module::Build', INSTALLER_BUILD, INSTALLER_MM ) ); - $type = INSTALLER_MM; + + ### XXX this is for recording purposes only. We *have* to install + ### these before even creating a dist object, or we'll get an error + ### saying 'no such dist type'; + my $href = $self->status->configure_requires || {}; + my $deps = { INSTALLER_BUILD, 0, %$href }; + + $self->status->configure_requires( $deps ); + + msg(loc("This module requires '%1' and '%2' to be installed first. ". + "Adding these modules to your prerequisites list", + 'Module::Build', INSTALLER_BUILD + ), $verbose ); + ### ok, actually we found neither ### } elsif ( !$type ) { @@ -653,7 +728,6 @@ sub dist { ### we need the info $self->get_installer_type unless $self->status->installer_type; - my($type,$args,$target); my $tmpl = { format => { default => $conf->get_conf('dist_type') || @@ -665,17 +739,49 @@ sub dist { check( $tmpl, \%hash ) or return; - my $dist = CPANPLUS::Dist->new( - format => $type, - module => $self - ) or return; + ### ok, check for $type. Do we have it? + unless( CPANPLUS::Dist->has_dist_type( $type ) ) { + + ### ok, we don't have it. Is it C::D::Build? if so we can install the + ### whole thing now + ### XXX we _could_ do this for any type we dont have actually... + if( $type eq INSTALLER_BUILD ) { + msg(loc("Bootstrapping installer '%1'", $type)); + + ### don't propagate the format, it's the one we're trying to + ### bootstrap, so it'll be an infinite loop if we do + + $cb->module_tree( $type )->install( target => $target, %$args ) or + do { + error(loc("Could not bootstrap installer '%1' -- ". + "can not continue", $type)); + return; + }; + + ### re-scan for available modules now + CPANPLUS::Dist->rescan_dist_types; + + unless( CPANPLUS::Dist->has_dist_type( $type ) ) { + error(loc("Newly installed installer type '%1' should be ". + "available, but is not! -- aborting", $type)); + return; + } else { + msg(loc("Installer '%1' succesfully bootstrapped", $type)); + } + + ### some other plugin you dont have. Abort + } else { + error(loc("Installer type '%1' not found. Please verify your ". + "installation -- aborting", $type )); + return; + } + } + + my $dist = $type->new( module => $self ) or return; my $dist_cpan = $type eq $self->status->installer_type ? $dist - : CPANPLUS::Dist->new( - format => $self->status->installer_type, - module => $self, - ); + : $self->status->installer_type->new( module => $self ); ### store the dists $self->status->dist_cpan( $dist_cpan ); @@ -968,17 +1074,32 @@ sub bundle_modules { return; } - my $dir; - unless( $dir = $self->status->extract ) { - error( loc("Don't know where '%1' was extracted to", $self->module ) ); - return; - } - my @files; - find( { - wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i; }, - no_chdir => 1, - }, $dir ); + + ### autobundles are special files generated by CPANPLUS. If we can + ### read the file, we can determine the prereqs + if( $self->is_autobundle ) { + my $where; + unless( $where = $self->status->fetch ) { + error(loc("Don't know where '%1' was fetched to", $self->package)); + return; + } + + push @files, $where + + ### regular bundle::* upload + } else { + my $dir; + unless( $dir = $self->status->extract ) { + error(loc("Don't know where '%1' was extracted to", $self->module)); + return; + } + + find( { + wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i }, + no_chdir => 1, + }, $dir ); + } my $prereqs = {}; my @list; my $seen = {}; for my $file ( @files ) { @@ -987,7 +1108,7 @@ sub bundle_modules { $file,$!)), next ); my $flag; - while(<$fh>) { + while( local $_ = <$fh> ) { ### quick hack to read past the header of the file ### last if $flag && m|^=head|i; @@ -999,7 +1120,7 @@ sub bundle_modules { if ($flag && /^(?!=)(\S+)\s*(\S+)?/) { my $module = $1; - my $version = $2 || '0'; + my $version = $cb->_version_to_number( version => $2 ); my $obj = $cb->module_tree($module); @@ -1074,8 +1195,7 @@ sub readme { return; } - my $in; - { local $/; $in = <$fh> }; + my $in = do{ local $/; <$fh> }; $fh->close; return $self->status->readme( $in ); @@ -1092,6 +1212,11 @@ Returns the currently installed version of this module, if any. Returns the location of the currently installed file of this module, if any. +=head2 $dir = $self->installed_dir() + +Returns the directory (or more accurately, the C<@INC> handle) from +which this module was loaded, if any. + =head2 $bool = $self->is_uptodate([version => VERSION_NUMBER]) Returns a boolean indicating if this module is uptodate or not. @@ -1102,6 +1227,7 @@ Returns a boolean indicating if this module is uptodate or not. { my $map = { # hashkey, alternate rv installed_version => ['version', 0 ], installed_file => ['file', ''], + installed_dir => ['dir', ''], is_uptodate => ['uptodate', 0 ], }; @@ -1318,7 +1444,7 @@ sub uninstall { for my $dir ( sort @$dirs ) { local *DIR; - open DIR, $dir or next; + opendir DIR, $dir or next; my @count = readdir(DIR); close DIR; @@ -1334,7 +1460,7 @@ sub uninstall { # unless $^O eq 'MSWin32'; #} - my @cmd = ($^X, "-ermdir+q[$dir]"); + my @cmd = ($^X, "-e", "rmdir q[$dir]"); unshift @cmd, $sudo if $sudo; my $buffer; @@ -1454,8 +1580,42 @@ sub _extutils_installed { verbose => $verbose, ); - my $inst; - unless( $inst = ExtUtils::Installed->new() ) { + ### search in your regular @INC, and anything you added to your config. + ### this lets EU::Installed find .packlists that are *not* in the standard + ### compiled in @INC path. Requires EU::I 1.42 or up. this addresses #33438 + ### make sure the archname path is also added, as that's where the .packlist + ### files are written + my @libs; + for my $lib ( @{ $conf->get_conf('lib') } ) { + require Config; + + ### figure out what an MM prefix expands to. Basically, it's the + ### site install target from %Config, ie: /opt/lib/perl5/site_perl/5.8.8 + ### minus the site wide prefix, ie: /opt + ### this lets users add the dir they have set as their EU::MM PREFIX + ### to our 'lib' config and it Just Works + ### XXX is this the right thing to do? + push @libs, do { + my $site = $Config::Config{sitelib}; + my $prefix = quotemeta $Config::Config{prefix}; + + ### strip the prefix from the site dir + $site =~ s/^$prefix//; + + File::Spec->catdir( $lib, $site ), + File::Spec->catdir( $lib, $site, $Config::Config{'archname'} ); + }; + + ### the arch specific dir, ie: + ### /opt/lib/perl5/site_perl/5.8.8/darwin-2level + push @libs, File::Spec->catdir( $lib, $Config::Config{'archname'} ); + + ### and just the standard dir + push @libs, $lib; + } + + my $inst; + unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) { error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) ); ### in case it's being used directly... ### @@ -1481,9 +1641,9 @@ sub _extutils_installed { =head2 $bool = $self->add_to_includepath; Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows -you to add the module from it's build dir to your path. +you to add the module from its build dir to your path. -You can reset C<@INC> and C<$PERL5LIB> to it's original state when you +You can reset C<@INC> and C<$PERL5LIB> to its original state when you started the program, by calling: $self->parent->flush('lib'); diff --git a/lib/CPANPLUS/Module/Author.pm b/lib/CPANPLUS/Module/Author.pm index 95de09c..92940fa 100644 --- a/lib/CPANPLUS/Module/Author.pm +++ b/lib/CPANPLUS/Module/Author.pm @@ -3,6 +3,7 @@ package CPANPLUS::Module::Author; use strict; use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; use Params::Check qw[check]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; @@ -129,7 +130,10 @@ sub modules { my $aref = $cb->_search_module_tree( type => 'author', - allow => [$self], + ### XXX, depending on backend, this is either an object + ### or the cpanid string. Dont know an elegant way to + ### solve this right now, so passing both + allow => [$self, $self->cpanid], ); return @$aref if $aref; return; @@ -173,18 +177,33 @@ sub distributions { my $href = $mod->_parse_checksums_file( file => $file ) or return; my @rv; - for my $dist ( keys %$href ) { - my $clone = $mod->clone; - - $clone->package( $dist ); - $clone->module( $clone->package_name ); - $clone->version( $clone->package_version ); - $clone->mtime( $href->{$dist}->{'mtime'} ); # release date + for my $name ( keys %$href ) { + ### shortcut asap, so we avoid extra ops. On big checksums files + ### the call to clone() takes up a lot of time. ### .meta files are now also in the checksums file, ### which means we have to filter out things that dont ### match our regex - push @rv, $clone if $clone->package_extension; + next if $mod->package_extension( $name ) eq META_EXT; + + ### used to do this wiht ->clone. However, that calls ->dslip, + ### (which is wrong anyway, as we're doing a different module), + ### which in turn calls ->contains, which scans the entire + ### module tree using _search_module_tree, which uses P::C + ### and is therefor VERY VERY slow. + ### so let's do this the direct way for speed ups. + my $dist = CPANPLUS::Module::Fake->new( + module => do { my $m = $mod->package_name( $name ); + $m =~ s/-/::/g; $m; + }, + version => $mod->package_version( $name ), + package => $name, + path => $mod->path, # same author after all + author => $mod->author, # same author after all + mtime => $href->{$name}->{'mtime'}, # release date + ); + + push @rv, $dist; } return @rv; diff --git a/lib/CPANPLUS/Module/Checksums.pm b/lib/CPANPLUS/Module/Checksums.pm index 92a2cc2..e1a2bbd 100644 --- a/lib/CPANPLUS/Module/Checksums.pm +++ b/lib/CPANPLUS/Module/Checksums.pm @@ -141,7 +141,7 @@ sub _get_checksums_file { my $clone = $self->clone; $clone->package( CHECKSUMS ); - my $file = $clone->fetch( %hash, force => 1 ) or return; + my $file = $clone->fetch( ttl => 3600, %hash ) or return; return $file; } @@ -160,7 +160,7 @@ sub _parse_checksums_file { ### loop over the header, there might be a pgp signature ### my $signed; - while (<$fh>) { + while (local $_ = <$fh>) { last if /^\$cksum = \{\s*$/; # skip till this line my $header = PGP_HEADER; # but be tolerant of whitespace $signed = 1 if /^${header}\s*$/;# due to crossplatform linebreaks @@ -170,7 +170,7 @@ sub _parse_checksums_file { ### *should* be valid perl code my $dist; my $cksum = {}; - while (<$fh>) { + while (local $_ = <$fh>) { if (/^\s*'([^']+)' => \{\s*$/) { $dist = $1; @@ -214,7 +214,7 @@ sub _check_signature_for_checksum_file { my $fh = OPEN_FILE->($file) or return; my $signed; - while (<$fh>) { + while (local $_ = <$fh>) { my $header = PGP_HEADER; $signed = 1 if /^$header$/; } diff --git a/lib/CPANPLUS/Selfupdate.pm b/lib/CPANPLUS/Selfupdate.pm index 41eabf0..b8b40ed 100644 --- a/lib/CPANPLUS/Selfupdate.pm +++ b/lib/CPANPLUS/Selfupdate.pm @@ -40,14 +40,14 @@ CPANPLUS::Selfupdate my $Modules = { dependencies => { - 'File::Fetch' => '0.13_04', # win32 & VMS file:// + 'File::Fetch' => '0.15_02', # lynx & 404 handling 'File::Spec' => '0.82', 'IPC::Cmd' => '0.36', # 5.6.2 compat: 2-arg open 'Locale::Maketext::Simple' => '0.01', 'Log::Message' => '0.01', 'Module::Load' => '0.10', - 'Module::Load::Conditional' => '0.18', # Better parsing: #23995, - # uses version.pm for <=> + 'Module::Load::Conditional' => '0.28', # returns dir for loaded + # modules 'version' => '0.73', # needed for M::L::C # addresses #24630 and # #24675 @@ -61,10 +61,12 @@ CPANPLUS::Selfupdate 'Archive::Extract' => '0.16', # ./Dir bug fix 'Archive::Tar' => '1.23', 'IO::Zlib' => '1.04', # needed for Archive::Tar - 'Object::Accessor' => '0.32', # overloaded stringification + 'Object::Accessor' => '0.34', # mk_aliases support 'Module::CoreList' => '2.09', 'Module::Pluggable' => '2.4', 'Module::Loaded' => '0.01', + 'Parse::CPAN::Meta' => '0.02', # config_requires support + 'ExtUtils::Install' => '1.42', # uninstall outside @INC }, features => { @@ -82,9 +84,8 @@ CPANPLUS::Selfupdate sub { return 1 }, # always enabled ], cpantest => [ - { - 'YAML::Tiny' => '0.0', - 'Test::Reporter' => '1.34', + { 'Test::Reporter' => '1.34', + 'YAML::Tiny' => '0.0' }, sub { my $cb = shift; @@ -159,6 +160,17 @@ CPANPLUS::Selfupdate return $cb->configure_object->get_conf('storable'); }, ], + sqlite_backend => [ + { 'DBIx::Simple' => '0.0', + 'DBD::SQLite' => '0.0', + }, + sub { + my $cb = shift; + my $conf = $cb->configure_object; + return $conf->get_conf('source_engine') + eq 'CPANPLUS::Internals::Source::SQLite' + }, + ], }, core => { 'CPANPLUS' => '0.0', diff --git a/lib/CPANPLUS/Shell.pm b/lib/CPANPLUS/Shell.pm index b56adeb..854d46b 100644 --- a/lib/CPANPLUS/Shell.pm +++ b/lib/CPANPLUS/Shell.pm @@ -124,6 +124,8 @@ $TMPL = { remote => { default => undef }, noninteractive => { default => '' }, cache => { default => [ ] }, + settings => { default => { install_all_prereqs => undef }, + no_override => 1 }, _old_sigpipe => { default => '', no_override => 1 }, _old_outfh => { default => '', no_override => 1 }, _signals => { default => { INT => { } }, no_override => 1 }, diff --git a/lib/CPANPLUS/Shell/Default.pm b/lib/CPANPLUS/Shell/Default.pm index 550064d..668fbc7 100644 --- a/lib/CPANPLUS/Shell/Default.pm +++ b/lib/CPANPLUS/Shell/Default.pm @@ -26,7 +26,7 @@ local $Data::Dumper::Indent = 1; # for dumpering from ! BEGIN { use vars qw[ $VERSION @ISA ]; @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; - $VERSION = "0.84"; + $VERSION = "0.86_06"; } load CPANPLUS::Shell; @@ -247,8 +247,13 @@ sub _input_loop { $cb->_flush( list => [qw|lib load|] ); } continue { + ### clear the sigint count $self->_signals->{INT}{count}-- - if $self->_signals->{INT}{count}; # clear the sigint count + if $self->_signals->{INT}{count}; + + ### reset the 'install prereq?' cached answer + $self->settings->{'install_all_prereqs'} = undef; + } return 1; @@ -425,7 +430,7 @@ sub _select_modules { sub _format_version { my $self = shift; - my $version = shift; + my $version = shift || 0; ### fudge $version into the 'optimal' format $version = 0 if $version eq 'undef'; @@ -959,6 +964,12 @@ sub __ask_about_install { $Shell->__print( loc("Module '%1' requires '%2' to be installed", $mod->module, $prereq->module ) ); $Shell->__print( "\n\n" ); + + ### previously cached answer? + return $Shell->settings->{'install_all_prereqs'} + if defined $Shell->settings->{'install_all_prereqs'}; + + $Shell->__print( loc( "If you don't wish to see this question anymore\n". "you can disable it by entering the following ". @@ -966,12 +977,28 @@ sub __ask_about_install { 's conf prereqs 1; s save' ) ); $Shell->__print("\n\n"); - my $bool = $term->ask_yn( + my $yes = loc("Yes"); + my $no = loc("No"); + my $all = loc("Yes to all (for this module)"); + my $none = loc("No to all (for this module)"); + + my $reply = $term->get_reply( prompt => loc("Should I install this module?"), - default => 'y' + choices => [ $yes, $no, $all, $none ], + default => $yes, ); - return $bool; + ### if 'all' or 'none', save this, so we can apply it to + ### other prereqs in this chain. + $Shell->settings->{'install_all_prereqs'} = + $reply eq $all ? 1 : + $reply eq $none ? 0 : + undef; + + ### if 'yes' or 'all', the user wants it installed + return $reply eq $all ? 1 : + $reply eq $yes ? 1 : + 0; } sub __ask_about_send_test_report { @@ -1054,7 +1081,8 @@ sub _details { $self->_pager_open if scalar @$mods * 10 > $self->_term_rowcount; - my $format = "%-30s %-30s\n"; + my $format = "%-24s %-45s\n"; + my $cformat = "%-24s %-45s %-10s\n"; for my $mod (@$mods) { my $href = $mod->details( %$opts ); my @list = sort { $a->module cmp $b->module } $mod->contains; @@ -1074,7 +1102,8 @@ sub _details { my $showed; for my $item ( @list ) { $self->__printf( - $format, ($showed ? '' : 'Contains:'), $item->module + $cformat, ($showed ? '' : 'Contains:'), + $item->module, $item->version ); $showed++; } @@ -1172,7 +1201,7 @@ sub _set_conf { boxed => CONFIG_BOXED, }->{ $key } || CONFIG_USER; - ### boxed is special, so let's get it's value from %INC + ### boxed is special, so let's get its value from %INC ### so we can tell it where to save ### XXX perhaps this logic should be generic for all ### types, and put in the ->save() routine @@ -1205,14 +1234,14 @@ sub _set_conf { user => CONFIG_USER, system => CONFIG_SYSTEM, }->{ $key } || CONFIG_USER; - + my $file = $conf->_config_pm_to_file( $where ); system("$editor $file"); ### now reload it ### disable warnings for this { require Module::Loaded; - Module::Loaded::mark_as_unloaded( $_ ) for $conf->configs; + Module::Loaded::mark_as_unloaded( $where ); ### reinitialize the config local $^W; @@ -1233,6 +1262,9 @@ sub _set_conf { $i++; $self->__print( "\t[$i] $uri\n" ); } + + $self->__print( + loc("\nTo edit this list, please type: '%1'\n", 's edit') ); } elsif ( $type eq 'selfupdate' ) { my %valid = map { $_ => $_ } @@ -1314,11 +1346,11 @@ sub _set_conf { $self->__printf( " $format\n", $name, $val ); } - } elsif ( $key eq 'hosts' ) { + } elsif ( $key eq 'hosts' or $key eq 'lib' ) { $self->__print( - loc( "Setting hosts is not trivial.\n" . - "It is suggested you use '%1' and edit the " . - "configuration file manually", 's edit') + loc( "Setting %1 is not trivial.\n" . + "It is suggested you use '%2' and edit the " . + "configuration file manually", $key, 's edit') ); } else { my $method = 'set_' . $type; @@ -1626,7 +1658,7 @@ sub _reports { } } - ### dispatch a plugin command to it's function + ### dispatch a plugin command to its function sub _meta { my $self = shift; my %hash = @_; @@ -1681,7 +1713,10 @@ sub _reports { my $who = $pkg eq $this ? "Standard Plugin" - : do { $pkg =~ s/^$this/../; "Provided by: $pkg" }; + : do { my $v = $self->_format_version($pkg->VERSION) || ''; + $pkg =~ s/^$this/../; + sprintf "Provided by: %-30s %-10s", $pkg, $v; + }; $self->__printf( $help_format, $name, $who ); } @@ -1808,6 +1843,10 @@ sub _read_configuration_from_rc { loc( "You can run an interactive setup using '%1'", 's reconfigure' ), loc( "You can add custom sources to your index. See '%1' for details", '/cs --help' ), + loc( "CPANPLUS now has an experimental SQLite backend. You can enable ". + "it via: '%1'. Update dependencies via '%2'", + 's conf source_engine CPANPLUS::Internals::Source::SQLite; s save', + 's selfupdate enabled_features ' ), ); sub _show_random_tip { diff --git a/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod b/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod index c537c4e..ca765f9 100644 --- a/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod +++ b/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod @@ -47,7 +47,7 @@ For example, a simple 'Hello, World!' plugin: sub hw { print "Hello, world!\n" } When the user in the default shell now issues the C command, -this command will be dispatched to the plugin, and it's C method will +this command will be dispatched to the plugin, and its C method will be called =head2 Registering Plugin Help diff --git a/lib/CPANPLUS/bin/cpan2dist b/lib/CPANPLUS/bin/cpan2dist index 8c913ba..5ba4556 100644 --- a/lib/CPANPLUS/bin/cpan2dist +++ b/lib/CPANPLUS/bin/cpan2dist @@ -273,7 +273,7 @@ for my $name (@modules) { my $obj; ### is it a tarball? then we get it locally and transform it - ### and it's dependencies into .debs + ### and its dependencies into .debs if( $tarball ) { ### make sure we use an absolute path, so chdirs() dont ### mess things up @@ -434,7 +434,7 @@ sub usage { specified on the command line, and all their prerequisites. Can also create a distribution of type FMT from a local - archive and all it's prerequisites + archive and all of its prerequisites. =cut @@ -520,11 +520,11 @@ Options: Examples: - ### build a debian package of DBI and it's prerequisites, + ### build a debian package of DBI and its prerequisites, ### don't bother running tests cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --skiptest DBI - ### build a debian package of DBI and it's prerequisites and install them + ### build a debian package of DBI and its prerequisites and install them cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --install DBI ### Build a package, whose format is determined by your config, of @@ -537,7 +537,7 @@ Examples: ### patterns mentioned in /tmp/ban cpan2dist --ban Foo --ban Bar --banlist /tmp/ban Net::FTP - ### build a package from Net::FTP, but ignore it's listed dependency + ### build a package from Net::FTP, but ignore its listed dependency ### on IO::Socket, as it's shipped per default with the OS we're on cpan2dist --ignore IO::Socket Net::FTP diff --git a/lib/CPANPLUS/inc.pm b/lib/CPANPLUS/inc.pm index 000a0ce..2bcdc7c 100644 --- a/lib/CPANPLUS/inc.pm +++ b/lib/CPANPLUS/inc.pm @@ -38,7 +38,7 @@ CPANPLUS::inc - runtime inclusion of privately bundled modules =head1 SYNOPSIS - ### set up CPANPLUS::inc to do it's thing ### + ### set up CPANPLUS::inc to do its thing ### BEGIN { use CPANPLUS::inc }; ### enable debugging ### diff --git a/lib/CPANPLUS/t/031_CPANPLUS-Internals-Source-SQLite.t b/lib/CPANPLUS/t/031_CPANPLUS-Internals-Source-SQLite.t new file mode 100644 index 0000000..730e04b --- /dev/null +++ b/lib/CPANPLUS/t/031_CPANPLUS-Internals-Source-SQLite.t @@ -0,0 +1,80 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; + +use Module::Load; +use Test::More eval { load 'CPANPLUS::Internals::Source::SQLite'; 1 } + ? 'no_plan' + : (skip_all => "SQLite engine not available"); + +use Data::Dumper; +use File::Basename qw[dirname]; +use CPANPLUS::Error; +use CPANPLUS::Backend; +use CPANPLUS::Internals::Constants; + +my $conf = gimme_conf(); + +### make sure we use the SQLite engine +$conf->set_conf( source_engine => 'CPANPLUS::Internals::Source::SQLite' ); + +my $cb = CPANPLUS::Backend->new( $conf ); +my $mod = TEST_CONF_MODULE; +my $auth = TEST_CONF_AUTHOR; + +ok( $cb->reload_indices( update_source => 1 ), + "Building trees" ); +ok( $cb->__sqlite_dbh, " Got a DBH " ); +ok( $cb->__sqlite_file, " Got a DB file" ); + + +### make sure we have trees and they're hashes +{ ok( $cb->author_tree, "Got author tree" ); + isa_ok( $cb->author_tree, "HASH" ); + + ok( $cb->module_tree, "Got module tree" ); + isa_ok( $cb->module_tree, "HASH" ); +} + +### save state, shouldn't work +{ CPANPLUS::Error->flush; + my $rv = $cb->save_state; + + ok( !$rv, "Saving state not implemented" ); + like( CPANPLUS::Error->stack_as_string, qr/not implemented/i, + " Diagnostics confirmed" ); +} + +### test look ups +{ my %map = ( + $auth => 'author_tree', + $mod => 'module_tree', + ); + + while( my($str, $meth) = each %map ) { + + ok( $str, "Trying to retrieve $str" ); + ok( $cb->$meth( $str ), " Got $str object via ->$meth" ); + ok( $cb->$meth->{$str}, " Got author object via ->{ $str }" ); + ok( exists $cb->$meth->{ $str }, + " Testing exists() " ); + ok( not(exists( $cb->$meth->{ $$ } )), + " And non-exists() " ); + cmp_ok( scalar(keys(%{ $cb->$meth })), ">", 1, + " Got keys()" ); + + cmp_ok( scalar(keys(%{ $cb->$meth })), '==', scalar(keys(%{ $cb->$meth })), + " Keys == Values" ); + + while( my($key,$val) = each %{ $cb->$meth } ) { + ok( $key, " Retrieved $key via each()" ); + ok( $val, " And value" ); + ok( ref $val, " Value is a ref: $val" ); + can_ok( $val, '_id' ); + } + } +} diff --git a/lib/CPANPLUS/t/032_CPANPLUS-Internals-Source-via-sqlite.t b/lib/CPANPLUS/t/032_CPANPLUS-Internals-Source-via-sqlite.t new file mode 100644 index 0000000..46505f5 --- /dev/null +++ b/lib/CPANPLUS/t/032_CPANPLUS-Internals-Source-via-sqlite.t @@ -0,0 +1,14 @@ +use strict; +use FindBin; + +use Module::Load; + +local $ENV{CPANPLUS_SOURCE_ENGINE} = 'CPANPLUS::Internals::Source::SQLite'; + +my $old = select STDERR; $|++; +select $old; $|++; +my $rv = do("$FindBin::Bin/03_CPANPLUS-Internals-Source.t") or do { + die $@ if $@; + die $! if $!; +}; + diff --git a/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t b/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t index d8dc53a..65f1e54 100644 --- a/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t +++ b/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t @@ -6,10 +6,16 @@ BEGIN { use strict; +use Module::Load; +use Test::More eval { + load $ENV{CPANPLUS_SOURCE_ENGINE} if $ENV{CPANPLUS_SOURCE_ENGINE}; 1 + } ? 'no_plan' + : (skip_all => "SQLite engine not available"); + +use CPANPLUS::Error; use CPANPLUS::Backend; use CPANPLUS::Internals::Constants; -use Test::More 'no_plan'; use Data::Dumper; use File::Basename qw[dirname]; @@ -21,34 +27,77 @@ my $cb = CPANPLUS::Backend->new( $conf ); isa_ok($cb, "CPANPLUS::Internals" ); -my $mt = $cb->_module_tree; -my $at = $cb->_author_tree; my $modname = TEST_CONF_MODULE; -for my $name (qw[auth mod dslip] ) { - my $file = File::Spec->catfile( - $conf->get_conf('base'), - $conf->_get_source($name) - ); - ok( (-e $file && -f _ && -s _), "$file exists" ); -} +### test lookups +{ my $mt = $cb->_module_tree; + my $at = $cb->_author_tree; -ok( scalar keys %$at, "Authortree loaded successfully" ); -ok( scalar keys %$mt, "Moduletree loaded successfully" ); + ### source files should be copied from the 'server' now + for my $name (qw[auth mod dslip] ) { + my $file = File::Spec->catfile( + $conf->get_conf('base'), + $conf->_get_source($name) + ); + ok( (-e $file && -f _ && -s _), "$file exists" ); + } -### test lookups -{ my $auth = $at->{'EUNOXS'}; + ok( $at, "Authortree loaded successfully" ); + ok( scalar keys %$at, " Authortree has items in it" ); + ok( $mt, "Moduletree loaded successfully" ); + ok( scalar keys %$mt, " Moduletree has items in it" ); + + my $auth = $at->{'EUNOXS'}; my $mod = $mt->{$modname}; isa_ok( $auth, 'CPANPLUS::Module::Author' ); isa_ok( $mod, 'CPANPLUS::Module' ); } +### save state tests +SKIP: { + skip "Save state tests for custom engine $ENV{CPANPLUS_SOURCE_ENGINE}", 7 + if $ENV{CPANPLUS_SOURCE_ENGINE}; + + ok( 1, "Testing save state functionality" ); + + + ### check we dont have a status set yet + { my $mod = $cb->_module_tree->{$modname}; + ok( !$mod->_status, " No status set yet in module object" ); + ok( $mod->status, " Status now set" ); + } + + ### now save this to disk + { CPANPLUS::Error->flush; + + my $rv = $cb->save_state; + ok( $rv, " State information saved" ); + + like( CPANPLUS::Error->stack_as_string, qr/Writing compiled source/, + " Diagnostics confirmed" ); + } + + ### now we rebuild the trees from disk and + ### check if the module object has a status saved with it + { CPANPLUS::Error->flush; + ok( $cb->_build_trees( uptodate => 1, use_stored => 1), + " Trees are rebuilt" ); + + like( CPANPLUS::Error->stack_as_string, qr/Retrieving/, + " Diagnostics confirmed" ); + + + my $mod = $cb->_module_tree->{$modname}; + ok( $mod->status, " Status now set in module object" ); + } +} + ### check custom sources ### XXX whitebox test SKIP: { ### first, find a file to serve as a source - my $mod = $mt->{$modname}; + my $mod = $cb->_module_tree->{$modname}; my $package = File::Spec->rel2abs( File::Spec->catfile( $FindBin::Bin, @@ -126,7 +175,7 @@ SKIP: { ok( $cb->$meth, "Sources file loaded" ); my $add_name = TEST_CONF_INST_MODULE; - my $add = $mt->{$add_name}; + my $add = $cb->_module_tree->{$add_name}; ok( $add, " Found added module" ); ok( $add->status->_fetch_from, diff --git a/lib/CPANPLUS/t/04_CPANPLUS-Module.t b/lib/CPANPLUS/t/04_CPANPLUS-Module.t index 7c1c8fa..f457551 100644 --- a/lib/CPANPLUS/t/04_CPANPLUS-Module.t +++ b/lib/CPANPLUS/t/04_CPANPLUS-Module.t @@ -14,6 +14,7 @@ use CPANPLUS::Internals::Constants; use Test::More 'no_plan'; use Data::Dumper; +use File::Spec; use File::Path (); my $Conf = gimme_conf(); @@ -142,7 +143,7 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); skip(q[You chose not to enable checksum verification], 5) unless $Conf->get_conf('md5'); - my $cksum_file = $Mod->checksums( force => 1 ); + my $cksum_file = $Mod->checksums; ok( $cksum_file, "Checksum file found" ); is( $cksum_file, $Mod->status->checksums, " File stored in module object" ); @@ -152,6 +153,15 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); ### XXX test checksum_value if there's digest::md5 + config wants it ok( $Mod->status->checksum_ok, " Checksum is ok" ); + + ### check ttl code for checksums; fetching it now means the cache + ### should kick in + { CPANPLUS::Error->flush; + ok( $Mod->checksums, + " Checksums re-fetched" ); + like( CPANPLUS::Error->stack_as_string, qr/Using cached file/, + " Cached file used" ); + } } } @@ -176,7 +186,7 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); ### dslip & related { my $dslip = $Mod->dslip; ok( $dslip, "Got dslip information from $ModName ($dslip)" ); - + ### now find it for a submodule { my $submod = $CB->module_tree( TEST_CONF_MODULE_SUB ); ok( $submod, " Found submodule " . $submod->name ); @@ -262,6 +272,44 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); } } +{ ### testing autobundles + my $file = File::Spec->catfile( + dummy_cpan_dir(), + $Conf->_get_build('autobundle'), + 'Snapshot.pm' + ); + my $uri = $CB->_host_to_uri( scheme => 'file', path => $file ); + my $bundle = $CB->parse_module( module => $uri ); + + ok( -e $file, "Creating bundle from '$file'" ); + ok( $bundle, " Object created" ); + isa_ok( $bundle, 'CPANPLUS::Module', + " Object" ); + ok( $bundle->is_bundle, " Recognized as bundle" ); + ok( $bundle->is_autobundle, " Recognized as autobundle" ); + + my $type = $bundle->get_installer_type; + ok( $type, " Found installer type" ); + is( $type, INSTALLER_AUTOBUNDLE, + " Installer type is $type" ); + + my $where = $bundle->fetch; + ok( $where, " Autobundle fetched" ); + ok( -e $where, " File exists" ); + + + my @list = $bundle->bundle_modules; + ok( scalar(@list), " Prereqs found" ); + is( scalar(@list), 1, " Right number of prereqs" ); + isa_ok( $list[0], 'CPANPLUS::Module', + " Object" ); + + ### skiptests to make sure we don't get any test header mismatches + my $rv = $bundle->create( prereq_target => 'create', skiptest => 1 ); + ok( $rv, " Tested prereqs" ); + +} + ### test module from perl core ### { isa_ok( $CoreMod, 'CPANPLUS::Module', "Core module " . $CoreName ); diff --git a/lib/CPANPLUS/t/08_CPANPLUS-Backend.t b/lib/CPANPLUS/t/08_CPANPLUS-Backend.t index f6be5a7..fbcaeca 100644 --- a/lib/CPANPLUS/t/08_CPANPLUS-Backend.t +++ b/lib/CPANPLUS/t/08_CPANPLUS-Backend.t @@ -59,52 +59,138 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); ### parse_module tests ### -{ my @map = ( # author package version - $Name => [ $mod->author->cpanid, $mod->package_name, $mod->version ], - $mod => [ $mod->author->cpanid, $mod->package_name, $mod->version ], - 'Foo-Bar-EU-NOXS' - => [ $mod->author->cpanid, $mod->package_name, $mod->version ], - 'Foo-Bar-EU-NOXS-0.01' - => [ $mod->author->cpanid, $mod->package_name, '0.01' ], - 'EUNOXS/Foo-Bar-EU-NOXS' - => [ 'EUNOXS', $mod->package_name, $mod->version ], - 'EUNOXS/Foo-Bar-EU-NOXS-0.01' - => [ 'EUNOXS', $mod->package_name, '0.01' ], - 'Foo-Bar-EU-NOXS-0.09' - => [ $mod->author->cpanid, $mod->package_name, '0.09' ], - 'MBXS/Foo-Bar-EU-NOXS-0.01' - => [ 'MBXS', $mod->package_name, '0.01' ], - 'EUNOXS/Foo-Bar-EU-NOXS-0.09' - => [ 'EUNOXS', $mod->package_name, '0.09' ], - 'EUNOXS/Foo-Bar-EU-NOXS-0.09.zip' - => [ 'EUNOXS', $mod->package_name, '0.09' ], - 'FROO/Flub-Flob-1.1.zip' - => [ 'FROO', 'Flub-Flob', '1.1' ], - 'G/GO/GOYALI/SMS_API_3_01.tar.gz' - => [ 'GOYALI', 'SMS_API', '3_01' ], - 'E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091' - => [ 'EYCK', 'Net-Lite-FTP', '0.091' ], - 'EYCK/Net/Lite/Net-Lite-FTP-0.091' - => [ 'EYCK', 'Net-Lite-FTP', '0.091' ], - 'M/MA/MAXDB/DBD-MaxDB-7.5.00.24a' - => [ 'MAXDB', 'DBD-MaxDB', '7.5.00.24a' ], - 'EUNOXS/perl5.005_03.tar.gz' - => [ 'EUNOXS', 'perl', '5.005_03' ], - 'FROO/Flub-Flob-v1.1.0.tbz' - => [ 'FROO', 'Flub-Flob', 'v1.1.0' ], - 'FROO/Flub-Flob-1.1_2.tbz' - => [ 'FROO', 'Flub-Flob', '1.1_2' ], - 'LDS/CGI.pm-3.27.tar.gz' - => [ 'LDS', 'CGI', '3.27' ], - 'FROO/Text-Tabs+Wrap-2006.1117.tar.gz' - => [ 'FROO', 'Text-Tabs+Wrap', '2006.1117' ], - 'JETTERO/Crypt-PBC-0.7.20.0-0.4.9', - => [ 'JETTERO', 'Crypt-PBC', '0.7.20.0-0.4.9' ], - +{ my @map = ( + $Name => [ + $mod->author->cpanid, # author + $mod->package_name, # package name + $mod->version, # version + ], + $mod => [ + $mod->author->cpanid, + $mod->package_name, + $mod->version, + ], + 'Foo-Bar-EU-NOXS' => [ + $mod->author->cpanid, + $mod->package_name, + $mod->version, + ], + 'Foo-Bar-EU-NOXS-0.01' => [ + $mod->author->cpanid, + $mod->package_name, + '0.01', + ], + 'EUNOXS/Foo-Bar-EU-NOXS' => [ + 'EUNOXS', + $mod->package_name, + $mod->version, + ], + 'EUNOXS/Foo-Bar-EU-NOXS-0.01' => [ + 'EUNOXS', + $mod->package_name, + '0.01', + ], + ### existing module, no extension given + ### this used to create a modobj with no package extension + 'EUNOXS/Foo-Bar-0.02' => [ + 'EUNOXS', + 'Foo-Bar', + '0.02', + ], + 'Foo-Bar-EU-NOXS-0.09' => [ + $mod->author->cpanid, + $mod->package_name, + '0.09', + ], + 'MBXS/Foo-Bar-EU-NOXS-0.01' => [ + 'MBXS', + $mod->package_name, + '0.01', + ], + 'EUNOXS/Foo-Bar-EU-NOXS-0.09' => [ + 'EUNOXS', + $mod->package_name, + '0.09', + ], + 'EUNOXS/Foo-Bar-EU-NOXS-0.09.zip' => [ + 'EUNOXS', + $mod->package_name, + '0.09', + ], + 'FROO/Flub-Flob-1.1.zip' => [ + 'FROO', + 'Flub-Flob', + '1.1', + ], + 'G/GO/GOYALI/SMS_API_3_01.tar.gz' => [ + 'GOYALI', + 'SMS_API', + '3_01', + ], + 'E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091' => [ + 'EYCK', + 'Net-Lite-FTP', + '0.091', + ], + 'EYCK/Net/Lite/Net-Lite-FTP-0.091' => [ + 'EYCK', + 'Net-Lite-FTP', + '0.091', + ], + 'M/MA/MAXDB/DBD-MaxDB-7.5.0.24a' => [ + 'MAXDB', + 'DBD-MaxDB', + '7.5.0.24a', + ], + 'EUNOXS/perl5.005_03.tar.gz' => [ + 'EUNOXS', + 'perl', + '5.005_03', + ], + 'FROO/Flub-Flub-v1.1.0.tbz' => [ + 'FROO', + 'Flub-Flub', + 'v1.1.0', + ], + 'FROO/Flub-Flub-1.1_2.tbz' => [ + 'FROO', + 'Flub-Flub', + '1.1_2', + ], + 'LDS/CGI.pm-3.27.tar.gz' => [ + 'LDS', + 'CGI', + '3.27', + ], + 'FROO/Text-Tabs+Wrap-2006.1117.tar.gz' => [ + 'FROO', + 'Text-Tabs+Wrap', + '2006.1117', + ], + 'JETTERO/Crypt-PBC-0.7.20.0-0.4.9' => [ + 'JETTERO', + 'Crypt-PBC', + '0.7.20.0-0.4.9' , + ], + 'GRICHTER/HTML-Embperl-1.2.1.tar.gz' => [ + 'GRICHTER', + 'HTML-Embperl', + '1.2.1', + ], + 'KANE/File-Fetch-0.15_03' => [ + 'KANE', + 'File-Fetch', + '0.15_03', + ], + 'AUSCHUTZ/IO-Stty-.02.tar.gz' => [ + 'AUSCHUTZ', + 'IO-Stty', + '.02', + ], ); while ( my($guess, $attr) = splice @map, 0, 2 ) { - my( $author, $pkg, $version ) = @$attr; + my( $author, $pkg_name, $version ) = @$attr; ok( $guess, "Attempting to parse $guess" ); @@ -118,10 +204,14 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); " Proper version found: $version" ); is( $obj->package_version, $version, " Found in package_version as well" ); - is( $obj->package_name, $pkg, - " Proper package found: $pkg" ); + is( $obj->package_name, $pkg_name, + " Proper package_name found: $pkg_name" ); unlike( $obj->package_name, qr/\d/, " No digits in package name" ); + { my $ext = $obj->package_extension; + ok( $ext, " Has extension as well: $ext" ); + } + like( $obj->author->cpanid, "/$author/i", " Proper author found: $author"); like( $obj->path, "/$author/i", diff --git a/lib/CPANPLUS/t/09_CPANPLUS-Internals-Search.t b/lib/CPANPLUS/t/09_CPANPLUS-Internals-Search.t index 583d464..c00437d 100644 --- a/lib/CPANPLUS/t/09_CPANPLUS-Internals-Search.t +++ b/lib/CPANPLUS/t/09_CPANPLUS-Internals-Search.t @@ -37,6 +37,11 @@ for my $type ( CPANPLUS::Module->accessors() ) { ### search for authors ### my $auth = $Mod->author; for my $type ( CPANPLUS::Module::Author->accessors() ) { + + ### don't muck around with references/objects + ### or private identifiers + next if ref $auth->$type() or $type =~/^_/; + my @aref = $CB->search( type => $type, allow => [$auth->$type()], diff --git a/lib/CPANPLUS/t/19_CPANPLUS-Dist.t b/lib/CPANPLUS/t/19_CPANPLUS-Dist.t index 3e35a54..cb0cd33 100644 --- a/lib/CPANPLUS/t/19_CPANPLUS-Dist.t +++ b/lib/CPANPLUS/t/19_CPANPLUS-Dist.t @@ -55,7 +55,7 @@ my $ModPrereq = TEST_CONF_INST_MODULE; ### XXX this version doesn't exist, but we don't check for it either ### my $Prereq = { $ModPrereq => '1000' }; -### since it's in this file, not in it's own module file, +### since it's in this file, not in its own module file, ### make M::L::C think it already was loaded $Module::Load::Conditional::CACHE->{$Module}->{usable} = 1; @@ -71,10 +71,7 @@ ok( $Mod, "Got module object" ); ### straight forward dist build - prepare, create, install -{ my $dist = CPANPLUS::Dist->new( - format => $Module, - module => $Mod - ); +{ my $dist = $Module->new( module => $Mod ); ok( $dist, "New dist object created" ); isa_ok( $dist, 'CPANPLUS::Dist' ); @@ -103,10 +100,7 @@ ok( $Mod, "Got module object" ); { $conf->_set_build('sanity_check' => 0); - my $dist = CPANPLUS::Dist->new( - format => $Module, - module => $Mod - ); + my $dist = $Module->new( module => $Mod ); ok( $dist, "Dist created with sanity check off" ); isa_ok( $dist, $Module ); @@ -114,11 +108,9 @@ ok( $Mod, "Got module object" ); } { $conf->_set_build('sanity_check' => 1); - my $dist = CPANPLUS::Dist->new( - format => $Module, - module => $Mod - ); - + + my $dist = $Module->new( module => $Mod ); + ok( !$dist, "Dist not created with sanity check on" ); like( CPANPLUS::Error->stack_as_string, qr/Format '$Module' is not available/, @@ -129,17 +121,44 @@ ok( $Mod, "Got module object" ); ### undef the status hash, make sure it complains ### { local $CPANPLUS::Dist::_Test::Init = 0; - my $dist = CPANPLUS::Dist->new( - format => $Module, - module => $Mod - ); - + my $dist = $Module->new( module => $Mod ); + ok( !$dist, "No dist created by failed init" ); like( CPANPLUS::Error->stack_as_string, qr/Dist initialization of '$Module' failed for/s, " Error recorded as expected" ); } +### configure_requires tests +{ my $meta = META->( $Mod ); + ok( $meta, "Reading 'configure_requires' from '$meta'" ); + + my $clone = $Mod->clone; + ok( $clone, " Package cloned" ); + + ### set the new location to fetch from + $clone->package( $meta ); + + my $file = $clone->fetch; + ok( $file, " Meta file fetched" ); + ok( -e $file, " File '$file' exits" ); + + my $dist = $Module->new( module => $Mod ); + + ok( $dist, " Dist object created" ); + + my $meth = 'find_configure_requires'; + can_ok( $dist, $meth ); + + my $href = $dist->$meth( file => $file ); + ok( $href, " '$meth' returned hashref" ); + + ok( scalar(keys(%$href)), " Contains entries" ); + ok( $href->{ +TEST_CONF_PREREQ }, + " Contains the right prereq" ); +} + + ### test _resolve prereqs, in a somewhat simulated set of circumstances { my $old_prereq = $conf->get_conf('prereqs'); @@ -207,6 +226,13 @@ ok( $Mod, "Got module object" ); ### set the conf back ### sub { $conf->set_conf(prereqs => PREREQ_INSTALL); }, ], + 'Perl binary version too low' => [ + sub { $cb->module_tree( $ModName ) + ->status->prereqs({ PERL_CORE, 10000000000 }); '' }, + sub { like( CPANPLUS::Error->stack_as_string, + qr/needs perl version/, + " Perl version not high enough" ) }, + ], }, 1 => { 'Simple create' => [ @@ -286,8 +312,14 @@ ok( $Mod, "Got module object" ); qr/Recursive dependency detected/, " Recursive dependency recorded ok" ) }, ], - - }, + 'Perl binary version sufficient' => [ + sub { $cb->module_tree( $ModName ) + ->status->prereqs({ PERL_CORE, 1 }); '' }, + sub { unlike( CPANPLUS::Error->stack_as_string, + qr/needs perl version/, + " Perl version sufficient" ) }, + ], + }, }; for my $bool ( sort keys %$map ) { @@ -310,10 +342,8 @@ ok( $Mod, "Got module object" ); $cb->_status->mk_flush; ### get a new dist from Text::Bastardize ### - my $dist = CPANPLUS::Dist->new( - format => $Module, - module => $cb->module_tree( $ModName ), - ); + my $mod = $cb->module_tree( $ModName ); + my $dist = $Module->new( module => $mod ); ### first sub returns target ### my $sub = shift @$aref; @@ -323,7 +353,7 @@ ok( $Mod, "Got module object" ); format => $Module, force => 1, target => $target, - prereqs => $Prereq ); + prereqs => ($mod->status->prereqs || $Prereq) ); is( !!$flag, !!$bool, $txt ); @@ -352,10 +382,7 @@ ok( $Mod, "Got module object" ); ok( $mod, "Fake module created" ); is( $mod->version, 1, " Version set correctly" ); - my $dist = CPANPLUS::Dist->new( - format => $Module, - module => $Mod - ); + my $dist = $Module->new( module => $Mod ); ok( $dist, "Dist object created" ); isa_ok( $dist, $Module ); diff --git a/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t b/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t index 315cea6..d3eb525 100644 --- a/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t +++ b/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t @@ -129,16 +129,6 @@ SKIP: { skip(q[No install tests under core perl], 10) if $ENV{PERL_CORE}; skip(q[Possibly no permission to install, skipping], 10) if $noperms; - ### XXX new EU::I should be forthcoming pending this patch from Steffen - ### Mueller on p5p: http://www.xray.mpe.mpg.de/mailing-lists/ \ - ### perl5-porters/2007-01/msg00895.html - ### This should become EU::I 1.42.. if so, we should upgrade this bit of - ### code and remove the diag, since we can then install in our dummy dir.. - diag("\nSorry, installing into your real perl dir, rather than our test"); - diag("area since ExtUtils::Installed does not probe for .packlists in " ); - diag('other dirs than those in %Config. See bug #6871 on rt.cpan.org ' ); - diag('for details'); - ### we now say 'no perms' if sudo is configured, as per #29904 #diag(q[Note: 'sudo' might ask for your password to do the install test]) # if $conf->get_program('sudo'); @@ -151,17 +141,19 @@ SKIP: { ### include INSTALL_BASE { local $ENV{'PERL5_MM_OPT'}; - ok( $Mod->install( force =>1 ), - "Installing module" ); + ### add the new dir to the configuration too, so eu::installed tests + ### work as they should + $conf->set_conf( lib => [ TEST_CONF_INSTALL_DIR ] ); + + ok( $Mod->install( force => 1, + makemakerflags => 'PREFIX='.TEST_CONF_INSTALL_DIR, + ), "Installing module" ); } ok( $Mod->status->installed," Module installed according to status" ); SKIP: { ### EU::Installed tests ### - - skip("makemakerflags set -- probably EU::Installed tests will fail", 8) - if $conf->get_conf('makemakerflags'); skip( "Old perl on cygwin detected " . "-- tests will fail due to known bugs", 8 @@ -221,9 +213,8 @@ SKIP: { ### test exceptions in Dist::MM->create ### { ok( $Mod->status->mk_flush, "Old status info flushed" ); - my $dist = CPANPLUS::Dist->new( module => $Mod, - format => INSTALLER_MM ); - + my $dist = INSTALLER_MM->new( module => $Mod ); + ok( $dist, "New dist object made" ); ok(!$dist->prepare, " Dist->prepare failed" ); like( CPANPLUS::Error->stack_as_string, qr/No dir found to operate on/, diff --git a/lib/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t b/lib/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t index c818338..6ac77f6 100644 --- a/lib/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t +++ b/lib/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t @@ -6,49 +6,112 @@ BEGIN { use strict; use Test::More 'no_plan'; +use Module::Loaded; +use Object::Accessor; use CPANPLUS::Dist; use CPANPLUS::Backend; -use CPANPLUS::Module::Fake; -use CPANPLUS::Module::Author::Fake; +use CPANPLUS::Error; use CPANPLUS::Internals::Constants; my $Conf = gimme_conf(); my $CB = CPANPLUS::Backend->new( $Conf ); +my $Inst = INSTALLER_BUILD; ### set the config so that we will ignore the build installer, ### but prefer it anyway -{ CPANPLUS::Dist->_ignore_dist_types( INSTALLER_BUILD ); +{ Module::Loaded::mark_as_loaded( $Inst ); + CPANPLUS::Dist->_ignore_dist_types( $Inst ); $Conf->set_conf( prefer_makefile => 0 ); } my $Mod = $CB->module_tree( 'Foo::Bar::MB::NOXS' ); -ok( $Mod, "Module object retrieved" ); -ok( not grep { $_ eq INSTALLER_BUILD } CPANPLUS::Dist->dist_types, - " Build installer not returned" ); +ok( $Mod, "Module object retrieved" ); +ok( not grep { $_ eq $Inst } CPANPLUS::Dist->dist_types, + " $Inst installer not returned" ); ### fetch the file first { my $where = $Mod->fetch; - ok( -e $where, " Tarball '$where' exists" ); + ok( -e $where, " Tarball '$where' exists" ); } ### extract it, silence warnings/messages { my $where = $Mod->extract; - ok( -e $where, " Tarball extracted to '$where'" ); + ok( -e $where, " Tarball extracted to '$where'" ); } ### check the installer type -{ is( $Mod->status->installer_type, INSTALLER_MM, - "Proper installer type found" ); +{ is( $Mod->status->installer_type, $Inst, + "Proper installer type found: $Inst" ); + + my $href = $Mod->status->configure_requires; + ok( scalar(keys(%$href)), " Dependencies recorded" ); + + ok( defined $href->{$Inst}, " Dependency on $Inst" ); my $err = CPANPLUS::Error->stack_as_string; - like( $err, '/'.INSTALLER_MM.'/', - " Error mentions " . INSTALLER_MM ); - like( $err, '/'.INSTALLER_BUILD.'/', - " Error mentions " . INSTALLER_BUILD ); - like( $err, qr/but might not be able to install/, - " Error mentions install warning" ); + like( $err, qr/$Inst/, " Message mentions $Inst" ); + like( $err, qr/prerequisites list/, + " Message mentions adding prerequisites" ); +} + +### now run the test, it should trigger the installation of the installer +### XXX whitebox test +{ no warnings 'redefine'; + + ### bootstrapping creates a call to $cb->module_tree('c::d::build')->install + ### we need to intercept that call + my $org_mt = CPANPLUS::Backend->can('module_tree'); + local *CPANPLUS::Backend::module_tree = sub { + my $self = shift; + my $mod = shift; + + ### return a dummy object if this is the bootstrap call + return CPANPLUS::Test::Module->new if $mod eq $Inst; + + ### otherwise do a regular call + return $org_mt->( $self, $mod, @_ ); + }; + + ### bootstrap install call will abort the ->create() call, so catch + ### that here + eval { $Mod->create( skiptest => 1) }; + + ok( $@, "Create call aborted at bootstrap phase" ); + like( $@, qr/$Inst/, " Diagnostics confirmed" ); + + my $diag = CPANPLUS::Error->stack_as_string; + like( $diag, qr/This module requires.*$Inst/, + " Dependency on $Inst recorded" ); + like( $diag, qr/Bootstrapping installer.*$Inst/, + " Bootstrap notice recorded" ); + like( $diag, qr/Installer '$Inst' succesfully bootstrapped/, + " Successful bootstrap recorded" ); } END { 1 while unlink output_file() } + +### place holder package to serve as a module object for C::D::Build +{ package CPANPLUS::Test::Module; + sub new { return bless {} } + sub install { + ### at load time we ignored C::D::Build. Reset the ignore here + ### so a 'rescan' after the 'install' picks up C::D::Build + CPANPLUS::Dist->_reset_dist_ignore; + return 1; + } +} + +### test package for cpanplus::dist::build +{ package CPANPLUS::Dist::Build; + use base 'CPANPLUS::Dist::Base'; + + ### shortcut out of the installation procedure + sub new { die __PACKAGE__ }; + sub format_available { 1 } + sub init { 1 } + sub prepare { 1 } + sub create { 1 } + sub install { 1 } +} diff --git a/lib/CPANPLUS/t/25_CPANPLUS.t b/lib/CPANPLUS/t/25_CPANPLUS.t new file mode 100644 index 0000000..9cbd15c --- /dev/null +++ b/lib/CPANPLUS/t/25_CPANPLUS.t @@ -0,0 +1,90 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; +use Test::More 'no_plan'; +use CPANPLUS::Error; +use CPANPLUS::Backend; + +my $Class = 'CPANPLUS'; +my $ModName = TEST_CONF_MODULE; +my $Conf = gimme_conf(); +my $CB = CPANPLUS::Backend->new( $Conf ); + +### so we get an object with *our* configuration +no warnings 'redefine'; +local *CPANPLUS::Backend::new = sub { $CB }; + +use_ok( $Class ); + +### install / get / fetch tests +for my $meth ( qw[fetch get install] ) { + my $sub = $Class->can( $meth ); + ok( $sub, "$Class->can( $meth )" ); + + my %map = ( + 0 => qr/failed/, + 1 => qr/successful/, + ); + + ok( 1, "Trying '$meth' in different configurations" ); + + while( my($rv, $re) = each %map ) { + + ### don't actually install, just test logic + no warnings 'redefine'; + local *CPANPLUS::Module::install = sub { $rv }; + local *CPANPLUS::Module::fetch = sub { $rv }; + + CPANPLUS::Error->flush; + + my $ok = $sub->( $ModName ); + is( $ok, $rv, " Expected RV: $rv" ); + like( CPANPLUS::Error->stack_as_string, $re, + " With expected diagnostic" ); + } + + ### does not take objects / references + { CPANPLUS::Error->flush; + + my $ok = $sub->( [] ); + ok( !$ok, "'$meth' with reference does not work" ); + like( CPANPLUS::Error->stack_as_string, qr/object/, + " Error as expected"); + } + + ### requires argument + { CPANPLUS::Error->flush; + + my $ok = $sub->( ); + ok( !$ok, "'$meth' without argument does not work" ); + like( CPANPLUS::Error->stack_as_string, qr/No module specified/, + " Error as expected"); + } +} + +### shell tests +{ my $meth = 'shell'; + my $sub = $Class->can( $meth ); + + ok( $sub, "$Class->can( $meth )" ); + + { ### test package for shell() method + package CPANPLUS::Shell::Test; + + ### ->shell() looks in %INC + use Module::Loaded qw[mark_as_loaded]; + mark_as_loaded( __PACKAGE__ ); + + sub new { bless {}, __PACKAGE__ }; + sub shell { $$ }; + } + + my $rv = $sub->( 'Test' ); + ok( $rv, " Shell started" ); + is( $rv, $$, " Proper shell called" ); +} + diff --git a/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t b/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t index 00c8173..4e91bae 100644 --- a/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t +++ b/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t @@ -134,9 +134,22 @@ my $map = { ], check => 0, }, - - - + prereq_not_on_cpan_but_core => { + pre_hook => sub { + my $mod = shift; + my $clone = $mod->clone; + $clone->status->prereqs( + { TEST_CONF_PREREQ, 0 } + ); + return $clone; + }, + failed => 1, + match => ['/This distribution has been tested/', + '/http://testers.cpan.org/', + '/UNKNOWN/', + ], + check => 0, + }, }; ### test config settings @@ -362,15 +375,19 @@ SKIP: { ? $map->{$type}->{'pre_hook'}->( $Mod ) : $Mod; - my $file = $CB->_send_report( + my $file = do { + ### so T::R does not try to resolve our maildomain, which can + ### lead to large timeouts for *every* invocation in T::R < 1.51_01 + ### see: http://code.google.com/p/test-reporter/issues/detail?id=15 + local $ENV{MAILDOMAIN} ||= 'example.com'; + $CB->_send_report( module => $mod, buffer => $map->{$type}{'buffer'}, failed => $map->{$type}{'failed'}, tests_skipped => ($map->{$type}{'skiptests'} ? 1 : 0), save => 1, - dontcc => 1, # no need to send, and also skips - # fetching reports from testers.cpan ); + }; ok( $file, "Type '$type' written to file" ); ok( -e $file, " File exists" ); @@ -413,7 +430,6 @@ SKIP: { # buffer => $map->{$type}->{'buffer'}, # failed => $map->{$type}->{'failed'}, # address => NOBODY, -# dontcc => 1, # ); # ok( $ok, " Mailed report to NOBODY" ); # } diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed index d48e396..c25653f 100644 --- a/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed -Created at Fri Dec 14 13:43:16 2007 +Created at Tue Feb 24 22:22:00 2009 ######################################################################### __UU__ M'XL("%_EO$4``S`Q;6%I;')C+G1X=`!+S,E,+%9P#8T(5@`#)=>*DM"2S)QB diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed index 4fc004d..0272e71 100644 --- a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed -Created at Fri Dec 14 13:43:16 2007 +Created at Tue Feb 24 22:22:00 2009 ######################################################################### __UU__ M'XL("!1%OT4"`T)U;F1L92U&;V\M0F%R+3`N,#$N=&%R`.V7:V_:,!2&^8I_ diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS index e716d36..ea9aa57 100644 --- a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS @@ -6,9 +6,14 @@ Hash: SHA1 $cksum = { 'Foo-Bar-0.01.tar.gz' => { 'mtime' => '1999-05-13', - 'md5' => '2917421f5a41419f7bb2d2cf87f04b8d', - 'size' => 1066 + 'md5' => '5cfed19e324ef8379d092807f10e5903', + 'size' => 1118 }, + 'Foo-Bar-0.01.meta' => { + 'mtime' => '1999-05-13', + 'size' => '389', + 'md5' => '6ca49cb8414b093e56515b1b65ccf718', + }, 'perl5.005_03.tar.gz' => { 'mtime' => '1999-05-13', 'md5' => '2b70961796a2ed7ca21fbf7e0c615643', diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.meta b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.meta new file mode 100644 index 0000000..870d7b7 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.meta @@ -0,0 +1,13 @@ +# http://module-build.sourceforge.net/META-spec.html +#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# +name: Foo-Bar +version: 0.01 +version_from: lib/Foo/Bar.pm +installdirs: site +requires: +# for configure_requires support +configure_requires: + Cwd: 0.01 + +distribution_type: module +generated_by: ExtUtils::MakeMaker version 6.25 diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed index 073e4f0..57be5f3 100644 --- a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed @@ -10,30 +10,31 @@ To recreate it use the following command: uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed -Created at Fri Dec 14 13:43:16 2007 +Created at Tue Feb 24 22:22:00 2009 ######################################################################### __UU__ -M'XL("/8X34("`T9O;RU"87(M,"XP,2YT87(`[9KQ;]I&%,?Y^?Z*1YE$(A5C -M8YM(SE*-K69!*LD4Z%:IJZ(#'V!A^[SSN2F:]K_O#ML,6)ONAP+M\CY*XMCW -MS/EX]WWWGNT^YZT?J6B9AFFU:X?!5%RXKMY:%ZZUO:VH66:G8W=LQ^YV:Z;5 -M<1VS!F[M".29I`*@MJ0)>\SN<^W50*KM-T)_V_\_7?=N?O9'A_"_XSB?]G_' -M*?VO)L"%]K_M=MP:F.C_@S,`&@.%TO,P"R-&:LB384?_P][-H.^/Q@?0?_<1 -M_7?L_?BO_CJH_V-0"I_<^;V70Y\,Z9+I&&#\\HI4LX%(EDDCC4@43MIJOK35 -M?#'2F$S"I#WC?*+W(C+TQSUC%4?P.88\R",&,9.T%5!)X8P&`0M@L@+=N_X5 -MYQB#3J+_TH='UK_C=O;T[Z@4$/5_#!JPD#+UVNUX+=XF"D'9+72-CDN>@/[+0'_T_+]K[>7_CNE75;[?`G%/BZ9_U_]Z\#Z5=S_L6VSB_=_3N)_O;">W/^. -M:5OH_Y/YOTBLCK7^:]?OK?^NB?7_<2!7"T8#"VYZJOHG(QJGJC9OZ5P<5&T/ -M67%`_4LJR][K\?7MW<9V2!/XOC#[@7U8;XTICU]L[&_'U[XRKW+I*$Q8IBN" -ME`>0+7@>J=)?E0CSA`L6>.2[7_V[T>#V!JZ@F7`)?.G!7&VK\W4)H,^M-R]5 -M%]-:)&`:K/*8V(+IL^-9Z,37D2[`\K8'I,?Q%B -M88+WA/,_705\)?F?A<__3N/_S1W=+^M_]S'_.^[^^F]9^/SOI/5_,0U4O8]+ -MPM.)_UM/?[YT_'],_QW7WK__YUHVZO\XPV]^]NAY7);EE9&OIO_/O^X)4_^N>SWC9W%J#FN^>Z -M@9Q?K@TP"AU<_\5#X(/D?X^__[.O?]NQ+-3_,2C?_RD\CZ__(`B"(`B"(`B" -?(`B"(`B"(`B"(`B"(`B"(`B"(,@WP=^)5B"Y`%`````` +M'XL(`#P*BD<``^V:;6_B1A"`\WE_Q214(I$.QQ@;)*P,+>=>WUY:*J_[V[?D$Q).1.`J=2YI&B!>^8V?6\>,;.4(C6.QJW3,-L +M'^_M!E/1EUU/&VU6MW]L#9T7HJI(FD,<#>@G*V +M2>YNSEBP87YE4UM>Y[\('OL[]E=:R.W>EVE?T[=M=&^]?!FOVG +M0HQI;$2;]OJ#Z.OA;+*_[13V5P[0T_9W5`+8@UHNXBNW?V/_.$WBS/(1BP-" +MHMCG$@YR-S@X(:1]0EYZDB?].S\3X +MKX5SH"%0*"P/4S]@&.ZOB$K\!_[X?U/_65C_U<&:_=6!;?O`C]O?MDP'[5\' +MC]K_G6X`PJWI>.;^KTV_5O_;)M[_ZX"75TO9$>7P2W[Z8W!U?7YY`:?0Y$*"6+@P4V-Y_C06H3YW +MOZEZD]-)*E7+0B<+.F-ZT:ZK?%=--&!-GUI4R+A,'E/:@.]26_Q$IKH!?3:_G``T'BR'?:5!TR/D'Z*/ +MW[%R2O#@'B1=L$S5U(\3654X%2E7NP"ETWOZ%YN] +M5TL1AEE3T30(>#ZYLMZ]#QT-WP_,?J +MK-7_)M9_]5`\^"%7@_ZOJ@)\<`<@I3<0R1*IXI%4XYA4@I6,!C=]XSX,X#E& +MPDM5W1@R25L>E10.J>SL!N$T9.XR,12N +M6':*Q81VS/+0K6Y77%C)0SY7)@P"3_5%ZIQ$52TD9G^G?LP2W=FI7:@.AT_] +MF5)^6\Y`DD:1B"59G\H59T7*^SO/7<]@Q:*(YRIU$O3>W[?C>?:R^6C9@7<-R7C+95>(_OPEL7<AM6\>S\=]MK_;_ZA/&?QT\]?\?;<-H_\4/3LKO8@'Y]Y=>,((@ +F"((@"((@"((@"((@"((@"((@"((@"((@"((@>_\!0F6@FP!0```` diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed index 58f5dd7..7eb2d53 100644 --- a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed -Created at Fri Dec 14 13:43:16 2007 +Created at Tue Feb 24 22:22:00 2009 ######################################################################### __UU__ M'XL(`'3DO44``^W/,0J`,`Q`T1RE)Y"T-O4XXN"DB%2]OR(*NNC4[;_E#\F0 diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed index 9b88351..f5e6964 100644 --- a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed @@ -10,7 +10,7 @@ To recreate it use the following command: uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed -Created at Fri Dec 14 13:43:16 2007 +Created at Tue Feb 24 22:22:00 2009 ######################################################################### __UU__ M'XL("`DY34("`T9O;RU"87(M,"XP,2YT87(`[5IK3]M(%,U7YE='0`G=-1;],P$`#@=_^* +M'XL("-"H)4<``S`R<&%C:V%G97,N9&5T86EL'0`G=-1;],P$`#@=_^* M>^`!I,;Q4D63_$136@2T8Z)$VQORXEMKD=B1?5DHOQY[9=JH*#!.EB+9Y\]W M5KPT+4IX"%'TJOFJMABX1E*F#9R^$:L_K1YS8$?4RSP?QY'WZ%O>N"Z?7\XN M\L[IH<60GU#>8&B\Z 'Foo::Bar'; use constant TEST_CONF_INVALID_MODULE => 'fnurk'; use constant TEST_CONF_MIRROR_DIR => 'dummy-localmirror'; use constant TEST_CONF_CPAN_DIR => 'dummy-CPAN'; +use constant TEST_CONF_CPANPLUS_DIR => 'dummy-cpanplus'; +use constant TEST_CONF_INSTALL_DIR => File::Spec->rel2abs( + File::Spec->catdir( + TEST_CONF_CPANPLUS_DIR, + 'install' + ) + ); ### we might need this Some Day when we're installing into ### our own sandbox. see t/20.t for details @@ -131,13 +138,7 @@ use constant TEST_CONF_CPAN_DIR => 'dummy-CPAN'; # ' INSTALLSITEMAN3DIR=' . TEST_INSTALL_DIR_MAN3; -sub gimme_conf { - - ### don't load any other configs than the heuristic one - ### during tests. They might hold broken/incorrect data - ### for our test suite. Bug [perl #43629] showed this. - my $conf = CPANPLUS::Configure->new( load_configs => 0 ); - +sub dummy_cpan_dir { ### VMS needs this in directory format for rel2abs my $test_dir = $^O eq 'VMS' ? File::Spec->catdir(TEST_CONF_CPAN_DIR) @@ -149,13 +150,25 @@ sub gimme_conf { ### According to John M: the hosts path needs to be in UNIX format. ### File::Spec::Unix->rel2abs does not work at all on VMS $abs_test_dir = VMS::Filespec::unixify( $abs_test_dir ) if $^O eq 'VMS'; + + return $abs_test_dir; +} + +sub gimme_conf { + + ### don't load any other configs than the heuristic one + ### during tests. They might hold broken/incorrect data + ### for our test suite. Bug [perl #43629] showed this. + my $conf = CPANPLUS::Configure->new( load_configs => 0 ); + + my $dummy_cpan = dummy_cpan_dir(); $conf->set_conf( hosts => [ { - path => $abs_test_dir, + path => $dummy_cpan, scheme => 'file', } ], ); - $conf->set_conf( base => File::Spec->rel2abs('dummy-cpanplus') ); + $conf->set_conf( base => File::Spec->rel2abs(TEST_CONF_CPANPLUS_DIR)); $conf->set_conf( dist_type => '' ); $conf->set_conf( signature => 0 ); $conf->set_conf( verbose => 1 ) if $ENV{ $Env }; @@ -170,6 +183,9 @@ sub gimme_conf { $conf->set_conf( makeflags => '/nologo' ); } } + + $conf->set_conf( source_engine => $ENV{CPANPLUS_SOURCE_ENGINE} ) + if $ENV{CPANPLUS_SOURCE_ENGINE}; _clean_test_dir( [ $conf->get_conf('base'),