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
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
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
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
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
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:
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 ) {
} 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 ###
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
Writes out a snapshot of your current installation in C<CPAN> 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
my $perl_v = join '', `$^X -V`;
print $fh <<EOF;
-package $name
+package $name;
\$VERSION = '0.01';
$head SYNOPSIS
-perl -MCPANPLUS -e "install $name"
+perl -MCPANPLUS -e "install file://full/path/to/$name"
$head CONTENTS
return $file;
}
+=head2 $bool = $cb->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<make test>, 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<CPANPLUS::Config> 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
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
=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
=cut
$Conf->{'conf'}->{'email'} = DEFAULT_EMAIL;
+
+=item enable_custom_sources
+
+Boolean flag indicating whether custom sources should be enabled or
+not. See the C<CUSTOM MODULE SOURCES> in C<CPANPLUS::Backend> for
+details on how to use them.
+
+Defaults to C<true>
+
+=cut
+
+ ### this addresses #32248 which requests a possibillity to
+ ### turn off custom sources
+ $Conf->{'conf'}->{'enable_custom_sources'} = 1;
=item extractdir
$Conf->{'conf'}->{'write_install_logs'} = 1;
+=item source_engine
+
+Class to use as the source engine, which is generally a subclass of
+C<CPANPLUS::Internals::Source>. Default to C<CPANPLUS::Internals::Source::Memory>.
+
+=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<Test::Reporter>. 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'
=cut
$Conf->{'program'}->{'sudo'} = do {
-
### let's assume you dont need sudo,
### unless one of the below criteria tells us otherwise
my $sudo = undef;
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
### 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 {
invoke the C<new> method, but instead retrieve the desired object via
a method call on a C<CPANPLUS::Backend> object.
-The C<load_configs> parameter controls wether or not additional
-user configurations are to be loaded or not. Defaults to C<true>.
+=item load_configs
+
+Controls wether or not additional user configurations are to be loaded
+or not. Defaults to C<true>.
=cut
my $tmpl = {
load_configs => { default => 1, store => \$load },
};
-
+
check( $tmpl, \%hash ) or (
warn Params::Check->last_error, return
);
$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;
}
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;
}
}
- ### 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;
}
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',
);
}
{
###################
+ ## 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? ##
###################
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
=head1 SYNOPSIS
- my $dist = CPANPLUS::Dist->new(
- format => 'build',
+ my $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new(
module => $modobj,
);
=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<CPANPLUS::Dist> object based on the provided C<MODOBJ>.
+Create a new C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object based on the
+provided C<MODOBJ>.
+
+*** DEPRECATED ***
The optional argument C<format> is used to indicate what type of dist
-you would like to create (like C<makemaker> for a C<CPANPLUS::Dist::MM>
-object, C<build> for a C<CPANPLUS::Dist::Build> object, and so on ).
-If not provided, will default to the setting as specified by your
-config C<dist_type>.
+you would like to create (like C<CPANPLUS::Dist::MM> or
+C<CPANPLUS::Dist::Build> and so on ).
+
+C<< CPANPLUS::Dist->new >> is exlusively meant as a method to be
+inherited by C<CPANPLUS::Dist::MM|Build>.
-Returns a C<CPANPLUS::Dist> object on success and false on failure.
+Returns a C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> 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;
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'",
### 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(
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<CPANPLUS::Dist::*> 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
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
### 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 ||= {
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
$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 &&
### 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;
}
--- /dev/null
+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<CPANPLUS::Dist::Autobundle> is a distribution class for installing installation
+snapshots as created by C<CPANPLUS>' C<autobundle> 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;
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
=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
$dist->status->mk_accessors( qw[my_implementation_accessor] );
The C<status> object is implemented as an instance of the
-C<Object::Accessor> class. Please refer to it's documentation for
+C<Object::Accessor> class. Please refer to its documentation for
details.
Return true if the initialization was successul, and false if it was
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;
=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
}
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 },
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;
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 ".
}
my %p;
- while( <$fh> ) {
+ while( local $_ = <$fh> ) {
my ($found) = m|^[\#]\s+PREREQ_PM\s+=>\s+(.+)|;
next unless $found;
### 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] -- " .
use CPANPLUS::Selfupdate;
-use CPANPLUS::Internals::Source;
use CPANPLUS::Internals::Extract;
use CPANPLUS::Internals::Fetch;
use CPANPLUS::Internals::Utils;
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;
use vars qw[@ISA $VERSION];
@ISA = qw[
- CPANPLUS::Internals::Source
CPANPLUS::Internals::Extract
CPANPLUS::Internals::Fetch
CPANPLUS::Internals::Utils
CPANPLUS::Internals::Report
];
-$VERSION = "0.84";
+$VERSION = "0.86_06";
=pod
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 {
_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 },
### 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!") );
$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;
}
sub _flush {
my $self = shift;
+ my $conf = $self->configure_object;
my %hash = @_;
my $aref;
### 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;
}
use Package::Constants;
-
-$VERSION = 0.01;
@ISA = qw[Exporter];
@EXPORT = Package::Constants->list( __PACKAGE__ );
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';
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';
'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';
'.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;
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;
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 = (
Cygwin => 'cygwin',
Darwin => 'darwin',
EBCDIC => 'os390|os400|posix-bc|vmesa',
- Haiku => 'haiku',
HPUX => 'hpux',
Linux => 'linux',
MSDOS => 'dos|os2|MSWin32|cygwin',
}
);
-If you are interested in making a more flexible Makefile.PL that can
-probe for missing dependencies and install them, ExtUtils::AutoInstall
-at <http://search.cpan.org/dist/ExtUtils-AutoInstall/> may be
-worth a look.
-
Thanks! :-)
.
=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
programs over perl modules. Defaults to your corresponding config
setting.
+C<ttl> (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<File::Fetch> do the actual fetching.
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') },
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 );
$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;
+ }
}
}
} else {
my $abs = File::Spec->rel2abs( $file );
+
+ ### so TTLs will work
+ $self->_update_timestamp( file => $abs );
+
return $abs;
}
This function queries the CPAN testers database at
I<http://testers.cpan.org/> for test results of specified module objects,
-module names or distributions.
+module names or distributions.
The optional argument C<all_versions> 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<http://testers.cpan.org> 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:
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;
=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<cpan-testers@perl.org> for a
particular distribution.
Defaults to C<cpan-testers@perl.org>.
-=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.
}
### 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 },
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'),
my $cb = $mod->parent;
+ ### will be 'fetch', 'make', 'test', 'install', etc ###
+ my $stage = TEST_FAIL_STAGE->($buffer);
+
### determine the grade now ###
my $grade;
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 );
### 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 {
} }
### 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
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 );
### 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');
$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 );
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;
=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
#
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 },
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) {
}
return \@rv;
+
+ } else {
+ my @rv = $self->_source_search_module_tree(
+ allow => $list,
+ type => $type,
+ );
+ return \@rv;
}
}
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 },
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) {
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
$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
$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
=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
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,
=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 I<storable>d 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 I<storable>d format if
-C<Storable> 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
};
my $args = check( $tmpl, \%hash ) or return;
- my $tree = {};
+
my $file = File::Spec->catfile(
$args->{path},
$conf->_get_source('auth')
"\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
### don't need it anymore ###
unlink $out;
- my $tree = {};
my $flag;
for ( split /\n/, $cont ) {
### 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] ) );
? $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
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'),
);
unless( IS_DIR->( $dir ) ) {
- msg(loc("No '%1' dir, skipping custom sources", $dir));
+ msg(loc("No '%1' dir, skipping custom sources", $dir), $verbose);
return;
}
#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 );
my $fh = OPEN_FILE->( $file ) or next;
- while( <$fh> ) {
+ while( local $_ = <$fh> ) {
chomp;
next if /^#/;
next unless /\S+/;
}
}
-
-# Local variables:
-# c-indentation-style: bsd
-# c-basic-offset: 4
-# indent-tabs-mode: nil
-# End:
-# vim: expandtab shiftwidth=4:
-
1;
--- /dev/null
+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 I<storable>d 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 I<storable>d format if
+C<Storable> 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;
--- /dev/null
+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;
--- /dev/null
+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 { }
+
=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<Foo-Bar-1.2.tar.gz> 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
)*?
### 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;
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;
### 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
### strip the .pm package suffix some authors insist on adding
$pkg =~ s/\.pm$//i;
- return ($pkg, $ver, $ext );
+ return ($pkg, $ver, $ext, $full );
}
return;
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;
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:
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
=head1 METHODS
-=head2 $self = CPANPLUS::Module::new( OPTIONS )
+=head2 $self = CPANPLUS::Module->new( OPTIONS )
This method returns a C<CPANPLUS::Module> object. Normal users
should never call this method directly, but instead use the
$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 );
return 1;
}
-=head2 $mod->package_name
+=head2 $mod->package_name( [$package_string] )
Returns the name of the package a module is in. For C<Acme::Bleach>
that might be C<Acme-Bleach>.
-=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<Acme-Bleach-1.1.tar.gz> 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<Acme-Bleach-1.1.tar.gz>, this
actually a bundle. Bundles are identified as modules whose name starts
with C<Bundle::>.
+=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
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;
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 {
=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
$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 );
}
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 ) {
### 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') ||
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 );
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 ) {
$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;
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);
return;
}
- my $in;
- { local $/; $in = <$fh> };
+ my $in = do{ local $/; <$fh> };
$fh->close;
return $self->status->readme( $in );
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.
{ my $map = { # hashkey, alternate rv
installed_version => ['version', 0 ],
installed_file => ['file', ''],
+ installed_dir => ['dir', ''],
is_uptodate => ['uptodate', 0 ],
};
for my $dir ( sort @$dirs ) {
local *DIR;
- open DIR, $dir or next;
+ opendir DIR, $dir or next;
my @count = readdir(DIR);
close DIR;
# unless $^O eq 'MSWin32';
#}
- my @cmd = ($^X, "-ermdir+q[$dir]");
+ my @cmd = ($^X, "-e", "rmdir q[$dir]");
unshift @cmd, $sudo if $sudo;
my $buffer;
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... ###
=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');
use strict;
use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
use Params::Check qw[check];
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
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;
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;
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;
}
### 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
### *should* be valid perl code
my $dist;
my $cksum = {};
- while (<$fh>) {
+ while (local $_ = <$fh>) {
if (/^\s*'([^']+)' => \{\s*$/) {
$dist = $1;
my $fh = OPEN_FILE->($file) or return;
my $signed;
- while (<$fh>) {
+ while (local $_ = <$fh>) {
my $header = PGP_HEADER;
$signed = 1 if /^$header$/;
}
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
'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 => {
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;
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',
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 },
BEGIN {
use vars qw[ $VERSION @ISA ];
@ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ];
- $VERSION = "0.84";
+ $VERSION = "0.86_06";
}
load CPANPLUS::Shell;
$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;
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';
$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 ".
'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 {
$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;
my $showed;
for my $item ( @list ) {
$self->__printf(
- $format, ($showed ? '' : 'Contains:'), $item->module
+ $cformat, ($showed ? '' : 'Contains:'),
+ $item->module, $item->version
);
$showed++;
}
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
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;
$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 { $_ => $_ }
$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;
}
}
- ### dispatch a plugin command to it's function
+ ### dispatch a plugin command to its function
sub _meta {
my $self = shift;
my %hash = @_;
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 );
}
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 {
sub hw { print "Hello, world!\n" }
When the user in the default shell now issues the C</helloworld> command,
-this command will be dispatched to the plugin, and it's C<hw> method will
+this command will be dispatched to the plugin, and its C<hw> method will
be called
=head2 Registering Plugin Help
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
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
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
### 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
=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 ###
--- /dev/null
+### 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' );
+ }
+ }
+}
--- /dev/null
+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 $!;
+};
+
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];
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,
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,
use Test::More 'no_plan';
use Data::Dumper;
+use File::Spec;
use File::Path ();
my $Conf = gimme_conf();
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" );
### 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" );
+ }
}
}
### 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 );
}
}
+{ ### 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 );
### 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" );
" 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",
### 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()],
### 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;
### 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' );
{ $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 );
}
{ $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/,
### 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');
### 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' => [
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 ) {
$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;
format => $Module,
force => 1,
target => $target,
- prereqs => $Prereq );
+ prereqs => ($mod->status->prereqs || $Prereq) );
is( !!$flag, !!$bool, $txt );
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 );
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');
### 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
### 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/,
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 }
+}
--- /dev/null
+### 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" );
+}
+
],
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
? $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" );
# buffer => $map->{$type}->{'buffer'},
# failed => $map->{$type}->{'failed'},
# address => NOBODY,
-# dontcc => 1,
# );
# ok( $ok, " Mailed report to NOBODY" );
# }
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
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_
$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',
--- /dev/null
+# 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
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+<O6)`^CP,AX+J9LQL6<
-M&0F3ZXG1RE(V-18RCDCC30&,%V$&ZH="*KCD<I6R>KT.,)#P$$813!<TF3,(
-M$Y`+!K-<YF)ML#Z[01(:,V\3&,JI2-XSD84\*1OTQ*P.W<\$CSW8BT-AHEP8
-M14$H,G5.%DI&!/LC#P7+/$*",),BG.12GZ\OT(-BJ&3.$B:H9,']9.6!_T&^
-MEF&4>=XF"D'9+72-CDN>@/[+0'_T_+]K[>7_CNE<H/Z/HO]Z.\]$6Z_E*1,1
-M(:D($PG/+,.P?D^>75;[?`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%]-<JI2%3I=4E1GJHCU/S5W5T(!_]:<N*F:)S#[6:0/^4[?E1ZR[;JB2IBA^
-M=&FSW1L\L*9@$'&^#).Y^N[$SJC.FEIKS?.WYKM+@,;6Y;#W-&H&A/Q)]/$'
-M5C7Q)%J!5!5)446I.D?N=CCC>:)&`: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<?N_6M=/^;""6K9L39.JG41<+V
-MH[RK%]"LDN[F\[5)F7;>]^]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@;)*<YE;M"$^E(JB37GG0]
+M10M>P,+>=>WUY:*J_[V[?D$Q).1.`J=2YI&B!>^8V?6\>,;.4(C6.QJW3,-L
+M'^_M!E/1<YQ\[.:CHARSSVVS9UNVV>EUU/&VU6MW]L#9T7HJI(FD,<#>@G*V
+M2>YNSEBP87YE4UM>Y<X8/K3_V.>[\('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]0EYZD<C.J,3_^[/^Q6^#ZVWKR$+<MI^.?\M>B?].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"<SAGUVG#1'PT(N:9A%#!H@?("4"T`
+M)/D!]9&4DOV/-V>75TO9$>7P<R[V"_N6C<9$A&^7\I<W9P,E_I7%B2\X!#YG
+M"?@<(N%!,A=IX,&8@3_C(F:>2W[Z8W!U?7YY`:?0Y$*"6+@P4V-Y_C06H3YW
+MOZEZD]-)*E7+0B<+.F-ZT:ZK?%=--&!-GUI4R+A,'E/:@.]26_Q$IKH!<NZK
+M'T[4R"K:X(XU8P:!$`N?S]2UBRN[.FSJ6&L>?3:_G``T'BR'?:5!TR/D'Z*/
+MW[%R2O#@'B1=L$S5U(\3654X%2E7NP"E<T(#-<*3^TG81'!O=5L>TWOZ%YN]
+M5T<E_X^4C^D.P/C]PS9UZ'RXZ?F/Y716\K_=[?8P_]=!FC`8?),?I1\DKJL=
+M0/_I%/IG[$M6>L1AEE3T30(></H6FF72;;[)1(JT<SN\NAR5(M6RHA`<?!K<
+M#L\_J)YS^5N?FY4'D,TO;_0$.3K)!#`Q[8)J_/<OSH>#ZYLMZ]#QT-WP_,?J
+MK-7_)M9_]5`\^"%7@_ZOJ@)\<`<@I3<0R1*IXI%4XYA4@I6,!C=]XSX,X#E&
+MPDM5W1@R25L>E10.J><Q50#=PS+]'&&PUT0U_@L;;EG'<_'?-9V5][]V6XEA
+M_-=``^921N[Q<9B%96N<^H%G)"*-)TQU+C-F<"8SQV@E$9L8<QD&I/$I!VZ*
+M%HA"%`LIY'W$]O?W`<XEW/E!`),YY:HQ4]U7UKFD,HTS@>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:*(YR<R]L>IU$O3>W<AOXIDQCB+
+MJ63>[?C>?:R^6C9@7<-R7C+95>(_OPEL7<<SSW]T`;#Z_L?!^*^'XOU/;GE\
+M_?/JJ,1_4>AM6\>S\=]MK_;_ZA/&?QT\]?\?;<-H_\4/3LKO8@'Y]Y=>,((@
+F"((@"((@"((@"((@"((@"((@"((@"((@"((@>_\!0F6@FP!0````
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
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=<H%5``A.;
uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/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("-<X34(``T9O;RU"87(M,"XP,2YT87(`[9E;;]HP%,=Y]J<X+9722@-R
uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/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("-\X34(``T9O;RU"87(M,"XP,2YT87(`[5K_3QI)%/=7YZ]XU39H(BN[
--- /dev/null
+package Snapshot;
+
+$VERSION = '0.01';
+
+1;
+
+__END__
+
+=head1 NAME
+
+Snapshot - Snapshot of your installation at Wed Jan 2 17:46:24 2008
+
+=head1 SYNOPSIS
+
+perl -MCPANPLUS -e "install Snapshot"
+
+=head1 CONTENTS
+
+Foo::Bar 0.01
uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed
-Created at Fri Dec 14 13:43:16 2007
+Created at Tue Feb 24 22:22:00 2009
#########################################################################
__UU__
-M'XL("$TN$T<``S`R<&%C:V%G97,N9&5T86EL<RYT>'0`G=-1;],P$`#@=_^*
+M'XL("-"H)4<``S`R<&%C:V%G97,N9&5T86EL<RYT>'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<DX&[7+0PI8U6&`6S=8#<:"-AX;<GX/+^Y--=#.^9`;
uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz.packed
-Created at Fri Dec 14 13:43:16 2007
+Created at Tue Feb 24 22:22:00 2009
#########################################################################
__UU__
M'XL("#'FO$4``S`S;6]D;&ES="YD871A`%U3_6O;,!#].?HKCBXC"20A=<@&
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
# ' 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)
### 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 };
$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'),
projects / p5sagit/p5-mst-13.2.git / commitdiff