diff options
Diffstat (limited to 'lib/CPANPLUS/Internals')
| -rw-r--r-- | lib/CPANPLUS/Internals/Constants.pm | 302 | ||||
| -rw-r--r-- | lib/CPANPLUS/Internals/Constants/Report.pm | 357 | ||||
| -rw-r--r-- | lib/CPANPLUS/Internals/Extract.pm | 236 | ||||
| -rw-r--r-- | lib/CPANPLUS/Internals/Fetch.pm | 372 | ||||
| -rw-r--r-- | lib/CPANPLUS/Internals/Report.pm | 609 | ||||
| -rw-r--r-- | lib/CPANPLUS/Internals/Search.pm | 316 | ||||
| -rw-r--r-- | lib/CPANPLUS/Internals/Source.pm | 1011 | ||||
| -rw-r--r-- | lib/CPANPLUS/Internals/Utils.pm | 536 | ||||
| -rw-r--r-- | lib/CPANPLUS/Internals/Utils/Autoflush.pm | 5 |
9 files changed, 3744 insertions, 0 deletions
diff --git a/lib/CPANPLUS/Internals/Constants.pm b/lib/CPANPLUS/Internals/Constants.pm new file mode 100644 index 0000000000..0961e25807 --- /dev/null +++ b/lib/CPANPLUS/Internals/Constants.pm @@ -0,0 +1,302 @@ +package CPANPLUS::Internals::Constants; + +use strict; + +use CPANPLUS::Error; + +use File::Spec; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +require Exporter; +use vars qw[$VERSION @ISA @EXPORT]; + +use Package::Constants; + + +$VERSION = 0.01; +@ISA = qw[Exporter]; +@EXPORT = Package::Constants->list( __PACKAGE__ ); + + +sub constants { @EXPORT }; + +use constant INSTALLER_BUILD + => 'CPANPLUS::Dist::Build'; +use constant INSTALLER_MM => 'CPANPLUS::Dist::MM'; +use constant INSTALLER_SAMPLE + => 'CPANPLUS::Dist::Sample'; +use constant INSTALLER_BASE => 'CPANPLUS::Dist::Base'; + +use constant CONFIG => 'CPANPLUS::Config'; +use constant CONFIG_USER => 'CPANPLUS::Config::User'; +use constant CONFIG_SYSTEM => 'CPANPLUS::Config::System'; + +use constant TARGET_CREATE => 'create'; +use constant TARGET_PREPARE => 'prepare'; +use constant TARGET_INSTALL => 'install'; +use constant TARGET_IGNORE => 'ignore'; +use constant DOT_CPANPLUS => $^O eq 'VMS' ? '_cpanplus' : '.cpanplus'; + +use constant OPT_AUTOFLUSH => '-MCPANPLUS::Internals::Utils::Autoflush'; + +use constant UNKNOWN_DL_LOCATION + => 'UNKNOWN-ORIGIN'; + +use constant NMAKE => 'nmake.exe'; +use constant NMAKE_URL => + 'ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe'; + +use constant INSTALL_VIA_PACKAGE_MANAGER + => sub { my $fmt = $_[0] or return; + return 1 if $fmt ne INSTALLER_BUILD and + $fmt ne INSTALLER_MM; + }; + +use constant IS_CODEREF => sub { ref $_[-1] eq 'CODE' }; +use constant IS_MODOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Module') }; +use constant IS_FAKE_MODOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Module::Fake') }; +use constant IS_AUTHOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Module::Author') }; +use constant IS_FAKE_AUTHOBJ + => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Module::Author::Fake') }; + +use constant IS_CONFOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Configure') }; + +use constant IS_RVOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Backend::RV') }; + +use constant IS_INTERNALS_OBJ + => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Internals') }; + +use constant IS_FILE => sub { return 1 if -e $_[-1] }; + +use constant FILE_EXISTS => sub { + my $file = $_[-1]; + return 1 if IS_FILE->($file); + local $Carp::CarpLevel = + $Carp::CarpLevel+2; + error(loc( q[File '%1' does not exist], + $file)); + return; + }; + +use constant FILE_READABLE => sub { + my $file = $_[-1]; + return 1 if -e $file && -r _; + local $Carp::CarpLevel = + $Carp::CarpLevel+2; + error( loc( q[File '%1' is not readable ]. + q[or does not exist], $file)); + return; + }; +use constant IS_DIR => sub { return 1 if -d $_[-1] }; + +use constant DIR_EXISTS => sub { + my $dir = $_[-1]; + return 1 if IS_DIR->($dir); + local $Carp::CarpLevel = + $Carp::CarpLevel+2; + error(loc(q[Dir '%1' does not exist], + $dir)); + return; + }; + +use constant MAKEFILE_PL => sub { return @_ + ? File::Spec->catfile( @_, + 'Makefile.PL' ) + : 'Makefile.PL'; + }; +use constant MAKEFILE => sub { return @_ + ? File::Spec->catfile( @_, + 'Makefile' ) + : 'Makefile'; + }; +use constant BUILD_PL => sub { return @_ + ? File::Spec->catfile( @_, + 'Build.PL' ) + : 'Build.PL'; + }; + +use constant BLIB => sub { return @_ + ? File::Spec->catfile(@_, 'blib') + : 'blib'; + }; + +use constant LIB => 'lib'; +use constant LIB_DIR => sub { return @_ + ? File::Spec->catdir(@_, LIB) + : LIB; + }; +use constant AUTO => 'auto'; +use constant LIB_AUTO_DIR => sub { return @_ + ? File::Spec->catdir(@_, LIB, AUTO) + : File::Spec->catdir(LIB, AUTO) + }; +use constant ARCH => 'arch'; +use constant ARCH_DIR => sub { return @_ + ? File::Spec->catdir(@_, ARCH) + : ARCH; + }; +use constant ARCH_AUTO_DIR => sub { return @_ + ? File::Spec->catdir(@_,ARCH,AUTO) + : File::Spec->catdir(ARCH,AUTO) + }; + +use constant BLIB_LIBDIR => sub { return @_ + ? File::Spec->catdir( + @_, BLIB->(), LIB ) + : File::Spec->catdir( BLIB->(), LIB ); + }; + +use constant CONFIG_USER_LIB_DIR => sub { + require CPANPLUS::Internals::Utils; + LIB_DIR->( + CPANPLUS::Internals::Utils->_home_dir, + DOT_CPANPLUS + ); + }; +use constant CONFIG_USER_FILE => sub { + File::Spec->catfile( + CONFIG_USER_LIB_DIR->(), + split('::', CONFIG_USER), + ) . '.pm'; + }; +use constant CONFIG_SYSTEM_FILE => sub { + require CPANPLUS::Internals; + require File::Basename; + my $dir = File::Basename::dirname( + $INC{'CPANPLUS/Internals.pm'} + ); + + ### XXX use constants + File::Spec->catfile( + $dir, qw[Config System.pm] + ); + }; + +use constant README => sub { my $obj = $_[0]; + my $pkg = $obj->package_name; + $pkg .= '-' . $obj->package_version . + '.readme'; + return $pkg; + }; +use constant OPEN_FILE => sub { + my($file, $mode) = (@_, ''); + my $fh; + open $fh, "$mode" . $file + or error(loc( + "Could not open file '%1': %2", + $file, $!)); + return $fh if $fh; + return; + }; + +use constant STRIP_GZ_SUFFIX + => sub { + my $file = $_[0] or return; + $file =~ s/.gz$//i; + return $file; + }; + +use constant CHECKSUMS => 'CHECKSUMS'; +use constant PGP_HEADER => '-----BEGIN PGP SIGNED MESSAGE-----'; +use constant ENV_CPANPLUS_CONFIG + => 'PERL5_CPANPLUS_CONFIG'; +use constant ENV_CPANPLUS_IS_EXECUTING + => 'PERL5_CPANPLUS_IS_EXECUTING'; +use constant DEFAULT_EMAIL => 'cpanplus@example.com'; +use constant CPANPLUS_UA => sub { ### for the version number ### + require CPANPLUS::Internals; + "CPANPLUS/$CPANPLUS::Internals::VERSION" + }; +use constant TESTERS_URL => sub { + "http://testers.cpan.org/show/" . + $_[0] .".yaml" + }; +use constant TESTERS_DETAILS_URL + => sub { + 'http://testers.cpan.org/show/' . + $_[0] . '.html'; + }; + +use constant CREATE_FILE_URI + => sub { + my $dir = $_[0] or return; + return $dir =~ m|^/| + ? 'file:/' . $dir + : 'file://' . $dir; + }; + +use constant DOT_SHELL_DEFAULT_RC + => '.shell-default.rc'; + +use constant PREREQ_IGNORE => 0; +use constant PREREQ_INSTALL => 1; +use constant PREREQ_ASK => 2; +use constant PREREQ_BUILD => 3; +use constant BOOLEANS => [0,1]; +use constant CALLING_FUNCTION + => sub { my $lvl = $_[0] || 0; + return join '::', (caller(2+$lvl))[3] + }; +use constant PERL_CORE => 'perl'; + +use constant GET_XS_FILES => sub { my $dir = $_[0] or return; + require File::Find; + my @files; + File::Find::find( + sub { push @files, $File::Find::name + if $File::Find::name =~ /\.xs$/i + }, $dir ); + + return @files; + }; + +use constant INSTALL_LOG_FILE + => sub { my $obj = shift or return; + my $name = $obj->name; $name =~ s/::/-/g; + $name .= '-'. $obj->version; + $name .= '-'. scalar(time) . '.log'; + return $name; + }; + +use constant ON_WIN32 => $^O eq 'MSWin32'; +use constant ON_NETWARE => $^O eq 'NetWare'; +use constant ON_CYGWIN => $^O eq 'cygwin'; +use constant ON_VMS => $^O eq 'VMS'; + +use constant ON_OLD_CYGWIN => do { ON_CYGWIN and $] < 5.008 + ? loc( + "Your perl version for %1 is too low; ". + "Require %2 or higher for this function", + $^O, '5.8.0' ) + : ''; + }; + +### XXX these 2 are probably obsolete -- check & remove; +use constant DOT_EXISTS => '.exists'; + +use constant QUOTE_PERL_ONE_LINER + => sub { my $line = shift or return; + + ### use double quotes on these systems + return qq["$line"] + if ON_WIN32 || ON_NETWARE || ON_VMS; + + ### single quotes on the rest + return qq['$line']; + }; + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Constants/Report.pm b/lib/CPANPLUS/Internals/Constants/Report.pm new file mode 100644 index 0000000000..10a14e60e3 --- /dev/null +++ b/lib/CPANPLUS/Internals/Constants/Report.pm @@ -0,0 +1,357 @@ +package CPANPLUS::Internals::Constants::Report; + +use strict; +use CPANPLUS::Error; + +use File::Spec; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +require Exporter; +use vars qw[$VERSION @ISA @EXPORT]; + +use Package::Constants; + + +$VERSION = 0.01; +@ISA = qw[Exporter]; +@EXPORT = Package::Constants->list( __PACKAGE__ ); + +### for the version +require CPANPLUS::Internals; + +### OS to regex map ### +my %OS = ( + Amiga => 'amigaos', + Atari => 'mint', + BSD => 'bsdos|darwin|freebsd|openbsd|netbsd', + Be => 'beos', + BeOS => 'beos', + Cygwin => 'cygwin', + Darwin => 'darwin', + EBCDIC => 'os390|os400|posix-bc|vmesa', + HPUX => 'hpux', + Linux => 'linux', + MSDOS => 'dos|os2|MSWin32|cygwin', + 'bin\\d*Mac'=> 'MacOS|darwin', # binMac, bin56Mac, bin58Mac... + Mac => 'MacOS|darwin', + MacPerl => 'MacOS', + MacOS => 'MacOS|darwin', + MacOSX => 'darwin', + MPE => 'mpeix', + MPEiX => 'mpeix', + OS2 => 'os2', + Plan9 => 'plan9', + RISCOS => 'riscos', + SGI => 'irix', + Solaris => 'solaris', + Unix => 'aix|bsdos|darwin|dgux|dynixptx|freebsd|'. + 'linux|hpux|machten|netbsd|next|openbsd|dec_osf|'. + 'svr4|sco_sv|unicos|unicosmk|solaris|sunos', + VMS => 'VMS', + VOS => 'VOS', + Win32 => 'MSWin32|cygwin', + Win32API => 'MSWin32|cygwin', +); + +use constant GRADE_FAIL => 'fail'; +use constant GRADE_PASS => 'pass'; +use constant GRADE_NA => 'na'; +use constant GRADE_UNKNOWN => 'unknown'; + +use constant MAX_REPORT_SEND + => 2; + +use constant CPAN_TESTERS_EMAIL + => 'cpan-testers@perl.org'; + +### the cpan mail account for this user ### +use constant CPAN_MAIL_ACCOUNT + => sub { + my $username = shift or return; + return $username . '@cpan.org'; + }; + +### check if this module is platform specific and if we're on that +### specific platform. Alternately, the module is not platform specific +### and we're always OK to send out test results. +use constant RELEVANT_TEST_RESULT + => sub { + my $mod = shift or return; + my $name = $mod->module; + my $specific; + for my $platform (keys %OS) { + if( $name =~ /\b$platform\b/i ) { + # beware the Mac != MAC + next if($platform eq 'Mac' && + $name !~ /\b$platform\b/); + $specific++; + return 1 if + $^O =~ /^(?:$OS{$platform})$/ + } + }; + return $specific ? 0 : 1; + }; + +use constant UNSUPPORTED_OS + => sub { + my $buffer = shift or return; + if( $buffer =~ + /No support for OS|OS unsupported/im ) { + return 1; + } + return 0; + }; + +use constant PERL_VERSION_TOO_LOW + => sub { + my $buffer = shift or return; + # ExtUtils::MakeMaker format + if( $buffer =~ + /Perl .*? required--this is only .*?/m ) { + return 1; + } + # Module::Build format + if( $buffer =~ + /ERROR:( perl:)? Version .*?( of perl)? is installed, but we need version >= .*?/m ) { + return 1; + } + return 0; + }; + +use constant NO_TESTS_DEFINED + => sub { + my $buffer = shift or return; + if( $buffer =~ + /(No tests defined( for [\w:]+ extension)?\.)/ + and $buffer !~ /\*\.t/m and + $buffer !~ /test\.pl/m + ) { + return $1 + } + + return; + }; + +### what stage did the test fail? ### +use constant TEST_FAIL_STAGE + => sub { + my $buffer = shift or return; + return $buffer =~ /(MAKE [A-Z]+).*/ + ? lc $1 : + 'fetch'; + }; + + +use constant MISSING_PREREQS_LIST + => sub { + my $buffer = shift; + my @list = map { s/.pm$//; s|/|::|g; $_ } + ($buffer =~ + m/\bCan\'t locate (\S+) in \@INC/g); + + ### make sure every missing prereq is only + ### listed ones + { my %seen; + @list = grep { !$seen{$_}++ } @list + } + + return @list; + }; + +use constant MISSING_EXTLIBS_LIST + => sub { + my $buffer = shift; + my @list = + ($buffer =~ + m/No library found for -l([-\w]+)/g); + + return @list; + }; + +use constant REPORT_MESSAGE_HEADER + => sub { + my ($version, $author) = @_; + return << "."; + +Dear $author, + +This is a computer-generated error report created automatically by +CPANPLUS, version $version. Testers personal comments may appear +at the end of this report. + +. + }; + +use constant REPORT_MESSAGE_FAIL_HEADER + => sub { + my($stage, $buffer) = @_; + return << "."; + +Thank you for uploading your work to CPAN. However, it appears that +there were some problems testing your distribution. + +TEST RESULTS: + +Below is the error stack from stage '$stage': + +$buffer + +. + }; + +use constant REPORT_MISSING_PREREQS + => sub { + my ($author,$email,@missing) = @_; + $author = ($author && $email) + ? "$author ($email)" + : 'Your Name Here'; + + my $modules = join "\n", @missing; + my $prereqs = join "\n", + map {"\t'$_'\t=> '0',". + " # or a minimum working version"} + @missing; + + return << "."; + +MISSING PREREQUISITES: + +It was observed that the test suite seem to fail without these modules: + +$modules + +As such, adding the prerequisite module(s) to 'PREREQ_PM' in your +Makefile.PL should solve this problem. For example: + +WriteMakefile( + AUTHOR => '$author', + ... # other information + PREREQ_PM => { +$prereqs + } +); + +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! :-) + +. + }; + +use constant REPORT_MISSING_TESTS + => sub { + return << "."; +RECOMMENDATIONS: + +It would be very helpful if you could include even a simple test +script in the next release, so people can verify which platforms +can successfully install them, as well as avoid regression bugs? + +A simple 't/use.t' that says: + +#!/usr/bin/env perl -w +use strict; +use Test; +BEGIN { plan tests => 1 } + +use Your::Module::Here; ok(1); +exit; +__END__ + +would be appreciated. If you are interested in making a more robust +test suite, please see the Test::Simple, Test::More and Test::Tutorial +documentation at <http://search.cpan.org/dist/Test-Simple/>. + +Thanks! :-) + +. + }; + +use constant REPORT_LOADED_PREREQS + => sub { + my $mod = shift; + my $cb = $mod->parent; + my $prq = $mod->status->prereqs || {}; + + ### not every prereq may be coming from CPAN + ### so maybe we wont find it in our module + ### tree at all... + ### skip ones that cant be found in teh list + ### as reported in #12723 + my @prq = grep { defined } + map { $cb->module_tree($_) } + sort keys %$prq; + + ### no prereqs? + return '' unless @prq; + + ### some apparently, list what we loaded + my $str = << "."; +PREREQUISITES: + +Here is a list of prerequisites you specified and versions we +managed to load: + +. + $str .= join '', + map { my $want = $prq->{$_->name}; + + sprintf "\t%s %-30s %8s %8s\n", + do { $_->is_uptodate( + version => $want + ) ? ' ' : '!' + }, + $_->name, + $_->installed_version, + $want + + ### might be empty entries in there + } grep { defined $_ } @prq; + + return $str; + }; + +use constant REPORT_TESTS_SKIPPED + => sub { + return << "."; + +******************************** NOTE ******************************** +*** *** +*** The tests for this module were skipped during this build *** +*** *** +********************************************************************** + +. + }; + +use constant REPORT_MESSAGE_FOOTER + => sub { + return << "."; + +******************************** NOTE ******************************** +The comments above are created mechanically, possibly without manual +checking by the sender. As there are many people performing automatic +tests on each upload to CPAN, it is likely that you will receive +identical messages about the same problem. + +If you believe that the message is mistaken, please reply to the first +one with correction and/or additional informations, and do not take +it personally. We appreciate your patience. :) +********************************************************************** + +Additional comments: + +. + }; + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Extract.pm b/lib/CPANPLUS/Internals/Extract.pm new file mode 100644 index 0000000000..544d5894f9 --- /dev/null +++ b/lib/CPANPLUS/Internals/Extract.pm @@ -0,0 +1,236 @@ +package CPANPLUS::Internals::Extract; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use File::Spec (); +use File::Basename (); +use Archive::Extract; +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'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Extract + +=head1 SYNOPSIS + + ### for source files ### + $self->_gunzip( file => 'foo.gz', output => 'blah.txt' ); + + ### for modules/packages ### + $dir = $self->_extract( module => $modobj, + extractdir => '/some/where' ); + +=head1 DESCRIPTION + +CPANPLUS::Internals::Extract extracts compressed files for CPANPLUS. +It can do this by either a pure perl solution (preferred) with the +use of C<Archive::Tar> and C<Compress::Zlib>, or with binaries, like +C<gzip> and C<tar>. + +The flow looks like this: + + $cb->_extract + Delegate to Archive::Extract + +=head1 METHODS + +=head2 $dir = _extract( module => $modobj, [perl => '/path/to/perl', extractdir => '/path/to/extract/to', prefer_bin => BOOL, verbose => BOOL, force => BOOL] ) + +C<_extract> will take a module object and extract it to C<extractdir> +if provided, or the default location which is obtained from your +config. + +The file name is obtained by looking at C<< $modobj->status->fetch >> +and will be parsed to see if it's a tar or zip archive. + +If it's a zip archive, C<__unzip> will be called, otherwise C<__untar> +will be called. In the unlikely event the file is of neither format, +an error will be thrown. + +C<_extract> takes the following options: + +=over 4 + +=item module + +A C<CPANPLUS::Module> object. This is required. + +=item extractdir + +The directory to extract the archive to. By default this looks +something like: + /CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME + +=item prefer_bin + +A flag indicating whether you prefer a pure perl solution, ie +C<Archive::Tar> or C<Archive::Zip> respectively, or a binary solution +like C<unzip> and C<tar>. + +=item perl + +The path to the perl executable to use for any perl calls. Also used +to determine the build version directory for extraction. + +=item verbose + +Specifies whether to be verbose or not. Defaults to your corresponding +config entry. + +=item force + +Specifies whether to force the extraction or not. Defaults to your +corresponding config entry. + +=back + +All other options are passed on verbatim to C<__unzip> or C<__untar>. + +Returns the directory the file was extracted to on success and false +on failure. + +=cut + +sub _extract { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + local $Params::Check::ALLOW_UNKNOWN = 1; + + my( $mod, $verbose, $force ); + my $tmpl = { + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + prefer_bin => { default => $conf->get_conf('prefer_bin') }, + extractdir => { default => $conf->get_conf('extractdir') }, + module => { required => 1, allow => IS_MODOBJ, store => \$mod }, + perl => { default => $^X }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### did we already extract it ? ### + my $loc = $mod->status->extract(); + + if( $loc && !$force ) { + msg(loc("Already extracted '%1' to '%2'. ". + "Won't extract again without force", + $mod->module, $loc), $verbose); + return $loc; + } + + ### did we already fetch the file? ### + my $file = $mod->status->fetch(); + unless( -s $file ) { + error( loc( "File '%1' has zero size: cannot extract", $file ) ); + return; + } + + ### the dir to extract to ### + my $to = $args->{'extractdir'} || + File::Spec->catdir( + $conf->get_conf('base'), + $self->_perl_version( perl => $args->{'perl'} ), + $conf->_get_build('moddir'), + ); + + ### delegate to Archive::Extract ### + ### set up some flags for archive::extract ### + local $Archive::Extract::PREFER_BIN = $args->{'prefer_bin'}; + local $Archive::Extract::DEBUG = $conf->get_conf('debug'); + local $Archive::Extract::WARN = $verbose; + + my $ae = Archive::Extract->new( archive => $file ); + + unless( $ae->extract( to => $to ) ) { + error( loc( "Unable to extract '%1' to '%2': %3", + $file, $to, $ae->error ) ); + return; + } + + ### if ->files is not filled, we dont know what the hell was + ### extracted.. try to offer a suggestion and bail :( + unless ( $ae->files ) { + error( loc( "'%1' was not able to determine extracted ". + "files from the archive. Instal '%2' and ensure ". + "it works properly and try again", + $ae->is_zip ? 'Archive::Zip' : 'Archive::Tar' ) ); + return; + } + + + ### print out what files we extracted ### + msg(loc("Extracted '%1'",$_),$verbose) for @{$ae->files}; + + ### set them all to be +w for the owner, so we don't get permission + ### denied for overwriting files that are just +r + + ### this is to rigurous -- just change to +w for the owner [cpan #13358] + #chmod 0755, map { File::Spec->rel2abs( File::Spec->catdir($to, $_) ) } + # @{$ae->files}; + + for my $file ( @{$ae->files} ) { + my $path = File::Spec->rel2abs( File::Spec->catdir($to, $file) ); + + $self->_mode_plus_w( file => $path ); + } + + ### check the return value for the extracted path ### + ### Make an educated guess if we didn't get an extract_path + ### back + ### XXX apparently some people make their own dists and they + ### pack up '.' which means the leading directory is '.' + ### and only the second directory is the actual module directory + ### so, we'll have to check if our educated guess exists first, + ### then see if the extract path works.. and if nothing works... + ### well, then we really don't know. + + my $dir; + for my $try ( File::Spec->rel2abs( File::Spec->catdir( + $to, $mod->package_name .'-'. $mod->package_version ) ), + File::Spec->rel2abs( $ae->extract_path ), + ) { + ($dir = $try) && last if -d $try; + } + + ### test if the dir exists ### + unless( $dir && -d $dir ) { + error(loc("Unable to determine extract dir for '%1'",$mod->module)); + return; + + } else { + msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose); + + ### register where we extracted the files to, + ### also store what files were extracted + $mod->status->extract( $dir ); + $mod->status->files( $ae->files ); + } + + ### also, figure out what kind of install we're dealing with ### + $mod->get_installer_type(); + + return $mod->status->extract(); +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Fetch.pm b/lib/CPANPLUS/Internals/Fetch.pm new file mode 100644 index 0000000000..b8ad371fcc --- /dev/null +++ b/lib/CPANPLUS/Internals/Fetch.pm @@ -0,0 +1,372 @@ +package CPANPLUS::Internals::Fetch; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use File::Fetch; +use File::Spec; +use Cwd qw[cwd]; +use IPC::Cmd qw[run]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Fetch + +=head1 SYNOPSIS + + my $output = $cb->_fetch( + module => $modobj, + fetchdir => '/path/to/save/to', + verbose => BOOL, + force => BOOL, + ); + + $cb->_add_fail_host( host => 'foo.com' ); + $cb->_host_ok( host => 'foo.com' ); + + +=head1 DESCRIPTION + +CPANPLUS::Internals::Fetch fetches files from either ftp, http, file +or rsync mirrors. + +This is the rough flow: + + $cb->_fetch + Delegate to File::Fetch; + + +=head1 METHODS + +=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] ) + +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 +object for a one-off fetch, look at C<CPANPLUS::Module::Fake>. + +C<fetchdir> is the place to save the file to. Usually this +information comes from your configuration, but you can override it +expressly if needed. + +C<fetch_from> lets you specify an URI to get this file from. If you +do not specify one, your list of configured hosts will be probed to +download the file from. + +C<force> forces a new download, even if the file already exists. + +C<verbose> simply indicates whether or not to print extra messages. + +C<prefer_bin> indicates whether you prefer the use of commandline +programs over perl modules. Defaults to your corresponding config +setting. + +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. + +Returns the path of the output file on success, false on failure. + +Note that you can set a C<blacklist> on certain methods in the config. +Simply add the identifying name of the method (ie, C<lwp>) to: + $conf->_set_fetch( blacklist => ['lwp'] ); + +And the C<LWP> function will be skipped by C<File::Fetch>. + +=cut + +sub _fetch { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + local $Params::Check::NO_DUPLICATES = 0; + + my ($modobj, $verbose, $force, $fetch_from); + my $tmpl = { + module => { required => 1, allow => IS_MODOBJ, store => \$modobj }, + fetchdir => { default => $conf->get_conf('fetchdir') }, + fetch_from => { default => '', store => \$fetch_from }, + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + prefer_bin => { default => $conf->get_conf('prefer_bin') }, + }; + + + my $args = check( $tmpl, \%hash ) or return; + + ### check if we already downloaded the thing ### + if( (my $where = $modobj->status->fetch()) && !$force ) { + msg(loc("Already fetched '%1' to '%2', " . + "won't fetch again without force", + $modobj->module, $where ), $verbose ); + return $where; + } + + my ($remote_file, $local_file, $local_path); + + ### build the local path to downlaod to ### + { + $local_path = $args->{fetchdir} || + File::Spec->catdir( + $conf->get_conf('base'), + $modobj->path, + ); + + ### create the path if it doesn't exist ### + unless( -d $local_path ) { + unless( $self->_mkdir( dir => $local_path ) ) { + msg( loc("Could not create path '%1'", $local_path), $verbose); + return; + } + } + + $local_file = File::Spec->rel2abs( + File::Spec->catfile( + $local_path, + $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; + } + } + + + ### we got a custom URI + if ( $fetch_from ) { + my $abs = $self->__file_fetch( from => $fetch_from, + to => $local_path, + verbose => $verbose ); + + unless( $abs ) { + error(loc("Unable to download '%1'", $fetch_from)); + return; + } + + ### store where we fetched it ### + $modobj->status->fetch( $abs ); + + return $abs; + + ### we will get it from one of our mirrors + } else { + ### build the remote path to download from ### + { $remote_file = File::Spec::Unix->catfile( + $modobj->path, + $modobj->package, + ); + unless( $remote_file ) { + error( loc('No remote file given for download') ); + return; + } + } + + ### see if we even have a host or a method to use to download with ### + my $found_host; + my @maybe_bad_host; + + HOST: { + ### F*CKING PIECE OF F*CKING p4 SHIT makes + ### '$File :: Fetch::SOME_VAR' + ### into a meta variable and starts substituting the file name... + ### GRAAAAAAAAAAAAAAAAAAAAAAH! + ### use ' to combat it! + + ### set up some flags for File::Fetch ### + local $File'Fetch::BLACKLIST = $conf->_get_fetch('blacklist'); + local $File'Fetch::TIMEOUT = $conf->get_conf('timeout'); + local $File'Fetch::DEBUG = $conf->get_conf('debug'); + local $File'Fetch::FTP_PASSIVE = $conf->get_conf('passive'); + local $File'Fetch::FROM_EMAIL = $conf->get_conf('email'); + local $File'Fetch::PREFER_BIN = $conf->get_conf('prefer_bin'); + local $File'Fetch::WARN = $verbose; + + + ### loop over all hosts we have ### + for my $host ( @{$conf->get_conf('hosts')} ) { + $found_host++; + + my $mirror_path = File::Spec::Unix->catfile( + $host->{'path'}, $remote_file + ); + + ### build pretty print uri ### + my $where; + if( $host->{'scheme'} eq 'file' ) { + $where = CREATE_FILE_URI->( + File::Spec::Unix->rel2abs( + File::Spec::Unix->catdir( + grep { defined $_ && length $_ } + $host->{'host'}, + $mirror_path + ) + ) + ); + } else { + my %args = ( scheme => $host->{scheme}, + host => $host->{host}, + path => $mirror_path, + ); + + $where = $self->_host_to_uri( %args ); + } + + my $abs = $self->__file_fetch( from => $where, + to => $local_path, + verbose => $verbose ); + + ### we got a path back? + if( $abs ) { + ### store where we fetched it ### + $modobj->status->fetch( $abs ); + + ### this host is good, the previous ones are apparently + ### not, so mark them as such. + $self->_add_fail_host( host => $_ ) for @maybe_bad_host; + + return $abs; + } + + ### so we tried to get the file but didn't actually fetch it -- + ### there's a chance this host is bad. mark it as such and + ### actually flag it back if we manage to get the file + ### somewhere else + push @maybe_bad_host, $host; + } + } + + $found_host + ? error(loc("Fetch failed: host list exhausted " . + "-- are you connected today?")) + : error(loc("No hosts found to download from " . + "-- check your config")); + } + + return; +} + +sub __file_fetch { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my ($where, $local_path, $verbose); + my $tmpl = { + from => { required => 1, store => \$where }, + to => { required => 1, store => \$local_path }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + check( $tmpl, \%hash ) or return; + + msg(loc("Trying to get '%1'", $where ), $verbose ); + + ### build the object ### + my $ff = File::Fetch->new( uri => $where ); + + ### sanity check ### + error(loc("Bad uri '%1'",$where)), return unless $ff; + + if( my $file = $ff->fetch( to => $local_path ) ) { + unless( -e $file && -s _ ) { + msg(loc("'%1' said it fetched '%2', but it was not created", + 'File::Fetch', $file), $verbose); + + } else { + my $abs = File::Spec->rel2abs( $file ); + return $abs; + } + + } else { + error(loc("Fetching of '%1' failed: %2", $where, $ff->error)); + } + + return; +} + +=pod + +=head2 _add_fail_host( host => $host_hashref ) + +Mark a particular host as bad. This makes C<CPANPLUS::Internals::Fetch> +skip it in fetches until this cache is flushed. + +=head2 _host_ok( host => $host_hashref ) + +Query the cache to see if this host is ok, or if it has been flagged +as bad. + +Returns true if the host is ok, false otherwise. + +=cut + +{ ### caching functions ### + + sub _add_fail_host { + my $self = shift; + my %hash = @_; + + my $host; + my $tmpl = { + host => { required => 1, default => {}, + strict_type => 1, store => \$host }, + }; + + check( $tmpl, \%hash ) or return; + + return $self->_hosts->{$host} = 1; + } + + sub _host_ok { + my $self = shift; + my %hash = @_; + + my $host; + my $tmpl = { + host => { required => 1, store => \$host }, + }; + + check( $tmpl, \%hash ) or return; + + return $self->_hosts->{$host} ? 0 : 1; + } +} + + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Report.pm b/lib/CPANPLUS/Internals/Report.pm new file mode 100644 index 0000000000..ffcb4f0d33 --- /dev/null +++ b/lib/CPANPLUS/Internals/Report.pm @@ -0,0 +1,609 @@ +package CPANPLUS::Internals::Report; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Internals::Constants::Report; + +use Data::Dumper; + +use Params::Check qw[check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use Module::Load::Conditional qw[can_load]; + +$Params::Check::VERBOSE = 1; + +### for the version ### +require CPANPLUS::Internals; + +=head1 NAME + +CPANPLUS::Internals::Report + +=head1 SYNOPSIS + + ### enable test reporting + $cb->configure_object->set_conf( cpantest => 1 ); + + ### set custom mx host, shouldn't normally be needed + $cb->configure_object->set_conf( cpantest_mx => 'smtp.example.com' ); + +=head1 DESCRIPTION + +This module provides all the functionality to send test reports to +C<http://testers.cpan.org> using the C<Test::Reporter> module. + +All methods will be called automatically if you have C<CPANPLUS> +configured to enable test reporting (see the C<SYNOPSIS>). + +=head1 METHODS + +=head2 $bool = $cb->_have_query_report_modules + +This function checks if all the required modules are here for querying +reports. It returns true and loads them if they are, or returns false +otherwise. + +=head2 $bool = $cb->_have_send_report_modules + +This function checks if all the required modules are here for sending +reports. It returns true and loads them if they are, or returns false +otherwise. + +=cut +{ my $query_list = { + LWP => '0.0', + 'LWP::UserAgent' => '0.0', + 'HTTP::Request' => '0.0', + URI => '0.0', + YAML => '0.0', + }; + + my $send_list = { + %$query_list, + 'Test::Reporter' => 1.27, + }; + + sub _have_query_report_modules { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $tmpl = { + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + return can_load( modules => $query_list, verbose => $args->{verbose} ) + ? 1 + : 0; + } + + sub _have_send_report_modules { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $tmpl = { + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + return can_load( modules => $send_list, verbose => $args->{verbose} ) + ? 1 + : 0; + } +} + +=head2 @list = $cb->_query_report( module => $modobj, [all_versions => BOOL, verbose => BOOL] ) + +This function queries the CPAN testers database at +I<http://testers.cpan.org/> for test results of specified module objects, +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: + + { + 'grade' => 'PASS', + 'dist' => 'CPANPLUS-0.042', + 'platform' => 'i686-pld-linux-thread-multi' + }, + { + 'grade' => 'PASS', + 'dist' => 'CPANPLUS-0.042', + 'platform' => 'i686-linux-thread-multi' + }, + { + '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: +UNKNOWN, PASS, FAIL or NA (not applicable). + +=cut + +sub _query_report { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($mod, $verbose, $all); + my $tmpl = { + module => { required => 1, allow => IS_MODOBJ, + store => \$mod }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + all_versions => { default => 0, store => \$all }, + }; + + check( $tmpl, \%hash ) or return; + + ### check if we have the modules we need for querying + return unless $self->_have_query_report_modules( verbose => 1 ); + + ### new user agent ### + my $ua = LWP::UserAgent->new; + $ua->agent( CPANPLUS_UA->() ); + + ### set proxies if we have them ### + $ua->env_proxy(); + + my $url = TESTERS_URL->($mod->package_name); + my $req = HTTP::Request->new( GET => $url); + + msg( loc("Fetching: '%1'", $url), $verbose ); + + my $res = $ua->request( $req ); + + unless( $res->is_success ) { + error( loc( "Fetching report for '%1' failed: %2", + $url, $res->message ) ); + return; + } + + my $aref = YAML::Load( $res->content ); + + my $dist = $mod->package_name .'-'. $mod->package_version; + + 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)) + : () + ) }; + } + + return @rv if @rv; + return; +} + +=pod + +=head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, dontcc => BOOL, verbose => BOOL, force => BOOL]); + +This function sends a testers report to C<cpan-testers@perl.org> for a +particular distribution. +It returns true on success, and false on failure. + +It takes the following options: + +=over 4 + +=item module + +The module object of this particular distribution + +=item buffer + +The output buffer from the 'make/make test' process + +=item failed + +Boolean indicating if the 'make/make test' went wrong + +=item save + +Boolean indicating if the report should be saved locally instead of +mailed out. If provided, this function will return the location the +report was saved to, rather than a simple boolean 'TRUE'. + +Defaults to false. + +=item address + +The email address to mail the report for. You should never need to +override this, but it might be useful for debugging purposes. + +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. + +Defaults to your configuration settings + +=item force + +Boolean indicating whether to force the sending, even if the max +amount of reports for fails have already been reached, or if you +may already have sent it before. + +Defaults to your configuration settings + +=back + +=cut + +sub _send_report { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + ### do you even /have/ test::reporter? ### + unless( $self->_have_send_report_modules(verbose => 1) ) { + error( loc( "You don't have '%1' (or modules required by '%2') ". + "installed, you cannot report test results.", + 'Test::Reporter', 'Test::Reporter' ) ); + return; + } + + ### check arguments ### + my ($buffer, $failed, $mod, $verbose, $force, $address, $save, $dontcc, + $tests_skipped ); + my $tmpl = { + module => { required => 1, store => \$mod, allow => IS_MODOBJ }, + buffer => { required => 1, store => \$buffer }, + 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'), + store => \$force }, + tests_skipped + => { default => 0, store => \$tests_skipped }, + }; + + check( $tmpl, \%hash ) or return; + + ### get the data to fill the email with ### + my $name = $mod->module; + my $dist = $mod->package_name . '-' . $mod->package_version; + my $author = $mod->author->author; + my $email = $mod->author->email || CPAN_MAIL_ACCOUNT->( $author ); + my $cp_conf = $conf->get_conf('cpantest') || ''; + my $int_ver = $CPANPLUS::Internals::VERSION; + my $cb = $mod->parent; + + + ### determine the grade now ### + + my $grade; + ### check if this is a platform specific module ### + ### if we failed the test, there may be reasons why + ### an 'NA' might have to be insted + GRADE: { if ( $failed ) { + + + ### XXX duplicated logic between this block + ### and REPORTED_LOADED_PREREQS :( + + ### figure out if the prereqs are on CPAN at all + ### -- if not, send NA grade + ### Also, if our version of prereqs is too low, + ### -- send NA grade. + ### This is to address bug: #25327: do not count + ### as FAIL modules where prereqs are not filled + { my $prq = $mod->status->prereqs || {}; + + while( my($prq_name,$prq_ver) = each %$prq ) { + my $obj = $cb->module_tree( $prq_name ); + + unless( $obj ) { + msg(loc( "Prerequisite '%1' for '%2' could not be obtained". + " from CPAN -- sending N/A grade", + $prq_name, $name ), $verbose ); + + $grade = GRADE_NA; + last GRADE; + } + + if( $cb->_vcmp( $prq_ver, $obj->installed_version ) > 0 ) { + msg(loc( "Installed version of '%1' ('%2') is too low for ". + "'%3' (needs '%4') -- sending N/A grade", + $prq_name, $obj->installed_version, + $name, $prq_ver ), $verbose ); + + $grade = GRADE_NA; + last GRADE; + } + } + } + + unless( RELEVANT_TEST_RESULT->($mod) ) { + msg(loc( + "'%1' is a platform specific module, and the test results on". + " your platform are not relevant --sending N/A grade.", + $name), $verbose); + + $grade = GRADE_NA; + + } elsif ( UNSUPPORTED_OS->( $buffer ) ) { + msg(loc( + "'%1' is a platform specific module, and the test results on". + " your platform are not relevant --sending N/A grade.", + $name), $verbose); + + $grade = GRADE_NA; + + ### you dont have a high enough perl version? + } elsif ( PERL_VERSION_TOO_LOW->( $buffer ) ) { + msg(loc("'%1' requires a higher version of perl than your current ". + "version -- sending N/A grade.", $name), $verbose); + + $grade = GRADE_NA; + + ### perhaps where were no tests... + ### see if the thing even had tests ### + } elsif ( NO_TESTS_DEFINED->( $buffer ) ) { + $grade = GRADE_UNKNOWN; + + } else { + + $grade = GRADE_FAIL; + } + + ### if we got here, it didn't fail and tests were present.. so a PASS + ### is in order + } else { + $grade = GRADE_PASS; + } } + + ### so an error occurred, let's see what stage it went wrong in ### + my $message; + if( $grade eq GRADE_FAIL or $grade eq GRADE_UNKNOWN) { + + ### return if one or more missing external libraries + if( my @missing = MISSING_EXTLIBS_LIST->($buffer) ) { + msg(loc("Not sending test report - " . + "external libraries not pre-installed")); + 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 ); + + ### was it missing prereqs? ### + if( my @missing = MISSING_PREREQS_LIST->($buffer) ) { + if(!$self->_verify_missing_prereqs( + module => $mod, + missing => \@missing + )) { + msg(loc("Not sending test report - " . + "bogus missing prerequisites report")); + return 1; + } + $message .= REPORT_MISSING_PREREQS->($author,$email,@missing); + } + + ### was it missing test files? ### + if( NO_TESTS_DEFINED->($buffer) ) { + $message .= REPORT_MISSING_TESTS->(); + } + + ### add a list of what modules have been loaded of your prereqs list + $message .= REPORT_LOADED_PREREQS->($mod); + + ### the footer + $message .= REPORT_MESSAGE_FOOTER->(); + + ### it may be another grade than fail/unknown.. may be worth noting + ### 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 ); + + ### 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; + } + } + + 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++; + } + } + } + + ### reporter object ### + my $reporter = Test::Reporter->new( + grade => $grade, + distribution => $dist, + via => "CPANPLUS $int_ver", + debug => $conf->get_conf('debug'), + ); + + ### set a custom mx, if requested + $reporter->mx( [ $conf->get_conf('cpantest_mx') ] ) + if $conf->get_conf('cpantest_mx'); + + ### set the from address ### + $reporter->from( $conf->get_conf('email') ) + if $conf->get_conf('email') !~ /\@example\.\w+$/i; + + ### give the user a chance to programattically alter the message + $message = $self->_callbacks->munge_test_report->($mod, $message, $grade); + + ### add the body if we have any ### + $reporter->comments( $message ) if defined $message && length $message; + + ### do a callback to ask if we should send the report + unless ($self->_callbacks->send_test_report->($mod, $grade)) { + msg(loc("Ok, not sending test report")); + return 1; + } + + ### do a callback to ask if we should edit the report + if ($self->_callbacks->edit_test_report->($mod, $grade)) { + ### test::reporter 1.20 and lower don't have a way to set + ### the preferred editor with a method call, but it does + ### respect your env variable, so let's set that. + local $ENV{VISUAL} = $conf->get_program('editor') + if $conf->get_program('editor'); + + $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 ); + + ### should we save it locally? ### + if( $save ) { + if( my $file = $reporter->write() ) { + msg(loc("Successfully wrote report for '%1' to '%2'", + $dist, $file), $verbose); + return $file; + + } else { + error(loc("Failed to write report for '%1'", $dist)); + return; + } + + ### should we send it to a bunch of people? ### + ### XXX should we do an 'already sent' check? ### + } elsif( $reporter->send( @inform ) ) { + msg(loc("Successfully sent '%1' report for '%2'", $grade, $dist), + $verbose); + return 1; + + ### something broke :( ### + } else { + error(loc("Could not send '%1' report for '%2': %3", + $grade, $dist, $reporter->errstr)); + return; + } +} + +sub _verify_missing_prereqs { + my $self = shift; + my %hash = @_; + + ### check arguments ### + my ($mod, $missing); + my $tmpl = { + module => { required => 1, store => \$mod }, + missing => { required => 1, store => \$missing }, + }; + + check( $tmpl, \%hash ) or return; + + + my %missing = map {$_ => 1} @$missing; + my $conf = $self->configure_object; + my $extract = $mod->status->extract; + + ### Read pre-requisites from Makefile.PL or Build.PL (if there is one), + ### of the form: + ### 'PREREQ_PM' => { + ### 'Compress::Zlib' => '1.20', + ### 'Test::More' => 0, + ### }, + ### Build.PL uses 'requires' instead of 'PREREQ_PM'. + + my @search; + push @search, ($extract ? MAKEFILE_PL->( $extract ) : MAKEFILE_PL->()); + push @search, ($extract ? BUILD_PL->( $extract ) : BUILD_PL->()); + + for my $file ( @search ) { + if(-e $file and -r $file) { + my $slurp = $self->_get_file_contents(file => $file); + my ($prereq) = + ($slurp =~ /'?(?:PREREQ_PM|requires)'?\s*=>\s*{(.*?)}/s); + my @prereq = + ($prereq =~ /'?([\w\:]+)'?\s*=>\s*'?\d[\d\.\-\_]*'?/sg); + delete $missing{$_} for(@prereq); + } + } + + return 1 if(keys %missing); # There ARE missing prerequisites + return; # All prerequisites accounted for +} + +1; + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Search.pm b/lib/CPANPLUS/Internals/Search.pm new file mode 100644 index 0000000000..30443f09fd --- /dev/null +++ b/lib/CPANPLUS/Internals/Search.pm @@ -0,0 +1,316 @@ +package CPANPLUS::Internals::Search; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Module; +use CPANPLUS::Module::Author; + +use File::Find; +use File::Spec; + +use Params::Check qw[check allow]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Search + +=head1 SYNOPSIS + + my $aref = $cpan->_search_module_tree( + type => 'package', + allow => [qr/DBI/], + ); + + my $aref = $cpan->_search_author_tree( + type => 'cpanid', + data => \@old_results, + verbose => 1, + allow => [qw|KANE AUTRIJUS|], + ); + + my $aref = $cpan->_all_installed( ); + +=head1 DESCRIPTION + +The functions in this module are designed to find module(objects) +based on certain criteria and return them. + +=head1 METHODS + +=head2 _search_module_tree( type => TYPE, allow => \@regexex, [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 +on failure. + +It takes the following arguments: + +=over 4 + +=item type + +This can be any of the accessors for the C<CPANPLUS::Module> objects. +This is a required argument. + +=item allow + +A set of rules, or more precisely, a list of regexes (via C<qr//> or +plain strings), that the C<type> must adhere too. You can specify as +many as you like, and it will be treated as an C<OR> search. +For an C<AND> search, see the C<data> argument. + +This is a required argument. + +=item data + +An arrayref of previous search results. This is the way to do an C<AND> +search -- C<_search_module_tree> will only search the module objects +specified in C<data> if provided, rather than the moduletree itself. + +=back + +=cut + +# Although the Params::Check solution is more graceful, it is WAY too slow. +# +# This sample script: +# +# use CPANPLUS::Backend; +# my $cb = new CPANPLUS::Backend; +# $cb->module_tree; +# my @list = $cb->search( type => 'module', allow => [qr/^Acme/] ); +# print $_->module, $/ for @list; +# +# Produced the following output using Dprof WITH params::check code +# +# Total Elapsed Time = 3.670024 Seconds +# User+System Time = 3.390373 Seconds +# Exclusive Times +# %Time ExclSec CumulS #Calls sec/call Csec/c Name +# 88.7 3.008 4.463 20610 0.0001 0.0002 Params::Check::check +# 47.4 1.610 1.610 1 1.6100 1.6100 Storable::net_pstore +# 25.6 0.869 0.737 20491 0.0000 0.0000 Locale::Maketext::Simple::_default +# _gettext +# 23.2 0.789 0.524 40976 0.0000 0.0000 Params::Check::_who_was_it +# 23.2 0.789 0.677 20610 0.0000 0.0000 Params::Check::_sanity_check +# 19.7 0.670 0.670 1 0.6700 0.6700 Storable::pretrieve +# 14.1 0.480 0.211 41350 0.0000 0.0000 Params::Check::_convert_case +# 11.5 0.390 0.256 20610 0.0000 0.0000 Params::Check::_hashdefs +# 11.5 0.390 0.255 20697 0.0000 0.0000 Params::Check::_listreqs +# 11.4 0.389 0.177 20653 0.0000 0.0000 Params::Check::_canon_key +# 10.9 0.370 0.356 20697 0.0000 0.0000 Params::Check::_hasreq +# 8.02 0.272 4.750 1 0.2723 4.7501 CPANPLUS::Internals::Search::_sear +# ch_module_tree +# 6.49 0.220 0.086 20653 0.0000 0.0000 Params::Check::_iskey +# 6.19 0.210 0.077 20488 0.0000 0.0000 Params::Check::_store_error +# 5.01 0.170 0.036 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__ +# +# and this output /without/ +# +# Total Elapsed Time = 2.803426 Seconds +# User+System Time = 2.493426 Seconds +# Exclusive Times +# %Time ExclSec CumulS #Calls sec/call Csec/c Name +# 56.9 1.420 1.420 1 1.4200 1.4200 Storable::net_pstore +# 25.6 0.640 0.640 1 0.6400 0.6400 Storable::pretrieve +# 9.22 0.230 0.096 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__ +# 7.06 0.176 0.272 1 0.1762 0.2719 CPANPLUS::Internals::Search::_sear +# ch_module_tree +# 3.21 0.080 0.098 10 0.0080 0.0098 IPC::Cmd::BEGIN +# 1.60 0.040 0.205 13 0.0031 0.0158 CPANPLUS::Internals::BEGIN +# 1.20 0.030 0.030 29 0.0010 0.0010 vars::BEGIN +# 1.20 0.030 0.117 10 0.0030 0.0117 Log::Message::BEGIN +# 1.20 0.030 0.029 9 0.0033 0.0033 CPANPLUS::Internals::Search::BEGIN +# 0.80 0.020 0.020 5 0.0040 0.0040 DynaLoader::dl_load_file +# 0.80 0.020 0.127 10 0.0020 0.0127 CPANPLUS::Module::BEGIN +# 0.80 0.020 0.389 2 0.0099 0.1944 main::BEGIN +# 0.80 0.020 0.359 12 0.0017 0.0299 CPANPLUS::Backend::BEGIN +# 0.40 0.010 0.010 30 0.0003 0.0003 Config::FETCH +# 0.40 0.010 0.010 18 0.0006 0.0005 Locale::Maketext::Simple::load_loc +# + +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}], + strict_type=> 1, store => \$mods }, + allow => { required => 1, default => [ ], strict_type => 1, + store => \$list }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + type => { required => 1, allow => [CPANPLUS::Module->accessors()], + store => \$type }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + { local $Params::Check::VERBOSE = 0; + + my @rv; + for my $mod (@$mods) { + #push @rv, $mod if check( + # { $type => { allow => $list } }, + # { $type => $mod->$type() } + # ); + push @rv, $mod if allow( $mod->$type() => $list ); + + } + return \@rv; + } +} + +=pod + +=head2 _search_author_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] ) + +Searches the authortree for author objects matching the criteria you +specify. Returns an array ref of author objects on success, and false +on failure. + +It takes the following arguments: + +=over 4 + +=item type + +This can be any of the accessors for the C<CPANPLUS::Module::Author> +objects. This is a required argument. + +=item allow + + +A set of rules, or more precisely, a list of regexes (via C<qr//> or +plain strings), that the C<type> must adhere too. You can specify as +many as you like, and it will be treated as an C<OR> search. +For an C<AND> search, see the C<data> argument. + +This is a required argument. + +=item data + +An arrayref of previous search results. This is the way to do an C<and> +search -- C<_search_author_tree> will only search the author objects +specified in C<data> if provided, rather than the authortree itself. + +=back + +=cut + +sub _search_author_tree { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($authors,$list,$verbose,$type); + my $tmpl = { + data => { default => [values %{$self->author_tree}], + 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 => [CPANPLUS::Module::Author->accessors()], + store => \$type }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + { local $Params::Check::VERBOSE = 0; + + my @rv; + for my $auth (@$authors) { + #push @rv, $auth if check( + # { $type => { allow => $list } }, + # { $type => $auth->$type } + # ); + push @rv, $auth if allow( $auth->$type() => $list ); + } + return \@rv; + } + + +} + +=pod + +=head2 _all_installed() + +This function returns an array ref of module objects of modules that +are installed on this system. + +=cut + +sub _all_installed { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my %seen; my @rv; + + + ### File::Find uses lstat, which quietly becomes stat on win32 + ### it then uses -l _ which is not allowed by the statbuffer because + ### you did a stat, not an lstat (duh!). so don't tell win32 to + ### follow symlinks, as that will break badly + my %find_args = (); + $find_args{'follow_fast'} = 1 unless $^O eq 'MSWin32'; + + ### never use the @INC hooks to find installed versions of + ### modules -- they're just there in case they're not on the + ### perl install, but the user shouldn't trust them for *other* + ### modules! + ### XXX CPANPLUS::inc is now obsolete, remove the calls + #local @INC = CPANPLUS::inc->original_inc; + + for my $dir (@INC ) { + next if $dir eq '.'; + + ### not a directory after all ### + next unless -d $dir; + + ### make sure to clean up the directories just in case, + ### as we're making assumptions about the length + ### This solves rt.cpan issue #19738 + $dir = File::Spec->canonpath( $dir ); + + File::Find::find( + { %find_args, + wanted => sub { + + return unless /\.pm$/i; + my $mod = $File::Find::name; + + $mod = substr($mod, length($dir) + 1, -3); + $mod = join '::', File::Spec->splitdir($mod); + + return if $seen{$mod}++; + my $modobj = $self->module_tree($mod) or return; + + push @rv, $modobj; + }, + }, $dir + ); + } + + return \@rv; +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Source.pm b/lib/CPANPLUS/Internals/Source.pm new file mode 100644 index 0000000000..c58632b355 --- /dev/null +++ b/lib/CPANPLUS/Internals/Source.pm @@ -0,0 +1,1011 @@ +package CPANPLUS::Internals::Source; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Module; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author; +use CPANPLUS::Internals::Constants; + +use Archive::Extract; + +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use Params::Check qw[check]; +use IPC::Cmd qw[can_run]; +use Module::Load::Conditional qw[can_load]; + +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Source + +=head1 SYNOPSIS + + ### lazy load author/module trees ### + + $cb->_author_tree; + $cb->_module_tree; + +=head1 DESCRIPTION + +CPANPLUS::Internals::Source controls the updating of source files and +the parsing of them into usable module/author trees to be used by +C<CPANPLUS>. + +Functions exist to check if source files are still C<good to use> as +well as update them, and then parse them. + +The flow looks like this: + + $cb->_author_tree || $cb->_module_tree + $cb->__check_trees + $cb->__check_uptodate + $cb->_update_source + $cb->_build_trees + $cb->__create_author_tree + $cb->__retrieve_source + $cb->__create_module_tree + $cb->__retrieve_source + $cb->__create_dslip_tree + $cb->__retrieve_source + $cb->_save_source + + $cb->_dslip_defs + +=head1 METHODS + +=cut + +{ + my $recurse; # flag to prevent recursive calls to *_tree functions + + ### lazy loading of module tree + sub _module_tree { + my $self = $_[0]; + + unless ($self->{_modtree} or $recurse++ > 0) { + my $uptodate = $self->_check_trees( @_[1..$#_] ); + $self->_build_trees(uptodate => $uptodate); + } + + $recurse--; + return $self->{_modtree}; + } + + ### lazy loading of author tree + sub _author_tree { + my $self = $_[0]; + + unless ($self->{_authortree} or $recurse++ > 0) { + my $uptodate = $self->_check_trees( @_[1..$#_] ); + $self->_build_trees(uptodate => $uptodate); + } + + $recurse--; + return $self->{_authortree}; + } + +} + +=pod + +=head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] ) + +Retrieve source files and return a boolean indicating whether or not +the source files are up to date. + +Takes several arguments: + +=over 4 + +=item update_source + +A flag to force re-fetching of the source files, even +if they are still up to date. + +=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. + +=cut + +### retrieve source files, and returns a boolean indicating if it's up to date +sub _check_trees { + my ($self, %hash) = @_; + my $conf = $self->configure_object; + + my $update_source; + my $verbose; + my $path; + + my $tmpl = { + path => { default => $conf->get_conf('base'), + store => \$path + }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose + }, + update_source => { default => 0, store => \$update_source }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### if the user never wants to update their source without explicitly + ### telling us, shortcircuit here + return 1 if $conf->get_conf('no_update') && !$update_source; + + ### a check to see if our source files are still up to date ### + msg( loc("Checking if source files are up to date"), $verbose ); + + my $uptodate = 1; # default return value + + for my $name (qw[auth dslip mod]) { + for my $file ( $conf->_get_source( $name ) ) { + $self->__check_uptodate( + file => File::Spec->catfile( $args->{path}, $file ), + name => $name, + update_source => $update_source, + verbose => $verbose, + ) or $uptodate = 0; + } + } + + return $uptodate; +} + +=pod + +=head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] ) + +C<__check_uptodate> checks if a given source file is still up-to-date +and if not, or when C<update_source> is true, will re-fetch the source +file. + +Takes the following arguments: + +=over 4 + +=item file + +The source file to check. + +=item name + +The internal shortcut name for the source file (used for config +lookups). + +=item update_source + +Flag to force updating of sourcefiles regardless. + +=item verbose + +Boolean to indicate whether to be verbose or not. + +=back + +Returns a boolean value indicating whether the current files are up +to date or not. + +=cut + +### this method checks whether or not the source files we are using are still up to date +sub __check_uptodate { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + file => { required => 1 }, + name => { required => 1 }, + update_source => { default => 0 }, + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $flag; + unless ( -e $args->{'file'} && ( + ( stat $args->{'file'} )[9] + + $conf->_get_source('update') ) + > time ) { + $flag = 1; + } + + if ( $flag or $args->{'update_source'} ) { + + if ( $self->_update_source( name => $args->{'name'} ) ) { + return 0; # return 0 so 'uptodate' will be set to 0, meaning no use + # of previously stored hashrefs! + } else { + msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} ); + return 1; + } + + } else { + return 1; + } +} + +=pod + +=head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] ) + +This method does the actual fetching of source files. + +It takes the following arguments: + +=over 4 + +=item name + +The internal shortcut name for the source file (used for config +lookups). + +=item path + +The full path where to write the files. + +=item verbose + +Boolean to indicate whether to be verbose or not. + +=back + +Returns a boolean to indicate success. + +=cut + +### this sub fetches new source files ### +sub _update_source { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + name => { required => 1 }, + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + + my $path = $args->{path}; + my $now = time; + + { ### this could use a clean up - Kane + ### no worries about the / -> we get it from the _ftp configuration, so + ### it's not platform dependant. -kane + my ($dir, $file) = $conf->_get_mirror( $args->{'name'} ) =~ m|(.+/)(.+)$|sg; + + msg( loc("Updating source file '%1'", $file), $args->{'verbose'} ); + + my $fake = CPANPLUS::Module::Fake->new( + module => $args->{'name'}, + path => $dir, + package => $file, + _id => $self->_id, + ); + + ### can't use $fake->fetch here, since ->parent won't work -- + ### the sources haven't been saved yet + my $rv = $self->_fetch( + module => $fake, + fetchdir => $path, + force => 1, + ); + + + unless ($rv) { + error( loc("Couldn't fetch '%1'", $file) ); + return; + } + + ### `touch` the file, so windoze knows it's new -jmb + ### works on *nix too, good fix -Kane + utime ( $now, $now, File::Spec->catfile($path, $file) ) or + error( loc("Couldn't touch %1", $file) ); + + } + return 1; +} + +=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}; + + ### 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 +searchable author-tree or restores a file-cached version of a +previous parse, if the sources are uptodate and the file-cache exists. + +It takes the following arguments: + +=over 4 + +=item uptodate + +A flag indicating whether the file-cache is uptodate 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 __create_author_tree() { + 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; + my $tree = {}; + my $file = File::Spec->catfile( + $args->{path}, + $conf->_get_source('auth') + ); + + msg(loc("Rebuilding author tree, this might take a while"), + $args->{verbose}); + + ### extract the file ### + my $ae = Archive::Extract->new( archive => $file ) or return; + my $out = STRIP_GZ_SUFFIX->($file); + + ### make sure to set the PREFER_BIN flag if desired ### + { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); + $ae->extract( to => $out ) or return; + } + + my $cont = $self->_get_file_contents( file => $out ) or return; + + ### don't need it anymore ### + unlink $out; + + for ( split /\n/, $cont ) { + my($id, $name, $email) = m/^alias \s+ + (\S+) \s+ + "\s* ([^\"\<]+?) \s* <(.+)> \s*" + /x; + + $tree->{$id} = CPANPLUS::Module::Author->new( + author => $name, #authors name + email => $email, #authors email address + cpanid => $id, #authors CPAN ID + _id => $self->_id, #id of this internals object + ); + } + + return $tree; + +} #__create_author_tree + +=pod + +=head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL]) + +This method opens a source files and parses its contents into a +searchable module-tree or restores a file-cached version of a +previous parse, if the sources are uptodate and the file-cache exists. + +It takes the following arguments: + +=over 4 + +=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 + +### this builds a hash reference with the structure of the cpan module tree ### +sub _create_mod_tree { + 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 undef; + my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod')); + + msg(loc("Rebuilding module tree, this might take a while"), + $args->{verbose}); + + + my $dslip_tree = $self->__create_dslip_tree( %$args ); + + ### extract the file ### + my $ae = Archive::Extract->new( archive => $file ) or return; + my $out = STRIP_GZ_SUFFIX->($file); + + ### make sure to set the PREFER_BIN flag if desired ### + { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); + $ae->extract( to => $out ) or return; + } + + my $cont = $self->_get_file_contents( file => $out ) or return; + + ### don't need it anymore ### + unlink $out; + + my $tree = {}; + my $flag; + + for ( split /\n/, $cont ) { + + ### quick hack to read past the header of the file ### + ### this is still rather evil... fix some time - Kane + $flag = 1 if m|^\s*$|; + next unless $flag; + + ### skip empty lines ### + next unless /\S/; + chomp; + + my @data = split /\s+/; + + ### filter out the author and filename as well ### + ### authors can apparently have digits in their names, + ### and dirs can have dots... blah! + my ($author, $package) = $data[2] =~ + m| [A-Z\d-]/ + [A-Z\d-]{2}/ + ([A-Z\d-]+) (?:/[\S]+)?/ + ([^/]+)$ + |xsg; + + ### remove file name from the path + $data[2] =~ s|/[^/]+$||; + + + unless( $self->author_tree($author) ) { + error( loc( "No such author '%1' -- can't make module object " . + "'%2' that is supposed to belong to this author", + $author, $data[0] ) ); + next; + } + + ### adding the dslip info + ### probably can use some optimization + my $dslip; + for my $item ( qw[ statd stats statl stati statp ] ) { + ### checking if there's an entry in the dslip info before + ### catting it on. appeasing warnings this way + $dslip .= $dslip_tree->{ $data[0] }->{$item} + ? $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 + ); + + } #for + + return $tree; + +} #_create_mod_tree + +=pod + +=head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL]) + +This method opens a source files and parses its contents into a +searchable dslip-tree or restores a file-cached version of a +previous parse, if the sources are uptodate and the file-cache exists. + +It takes the following arguments: + +=over 4 + +=item uptodate + +A flag indicating whether the file-cache is uptodate 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 __create_dslip_tree { + 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; + + ### get the file name of the source ### + my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip')); + + ### extract the file ### + my $ae = Archive::Extract->new( archive => $file ) or return; + my $out = STRIP_GZ_SUFFIX->($file); + + ### make sure to set the PREFER_BIN flag if desired ### + { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); + $ae->extract( to => $out ) or return; + } + + my $in = $self->_get_file_contents( file => $out ) or return; + + ### don't need it anymore ### + unlink $out; + + + ### get rid of the comments and the code ### + ### need a smarter parser, some people have this in their dslip info: + # [ + # 'Statistics::LTU', + # 'R', + # 'd', + # 'p', + # 'O', + # '?', + # 'Implements Linear Threshold Units', + # ...skipping... + # "\x{c4}dd \x{fc}ml\x{e4}\x{fc}ts t\x{f6} \x{eb}v\x{eb}r\x{ff}th\x{ef}ng!", + # 'BENNIE', + # '11' + # ], + ### also, older versions say: + ### $cols = [....] + ### and newer versions say: + ### $CPANPLUS::Modulelist::cols = [...] + ### split '$cols' and '$data' into 2 variables ### + ### use this regex to make sure dslips with ';' in them don't cause + ### parser errors + my ($ds_one, $ds_two) = ($in =~ m|.+}\s+ + (\$(?:CPAN::Modulelist::)?cols.*?) + (\$(?:CPAN::Modulelist::)?data.*) + |sx); + + ### eval them into existence ### + ### still not too fond of this solution - kane ### + my ($cols, $data); + { #local $@; can't use this, it's buggy -kane + + $cols = eval $ds_one; + error( loc("Error in eval of dslip source files: %1", $@) ) if $@; + + $data = eval $ds_two; + error( loc("Error in eval of dslip source files: %1", $@) ) if $@; + + } + + my $tree = {}; + my $primary = "modid"; + + ### this comes from CPAN::Modulelist + ### which is in 03modlist.data.gz + for (@$data){ + my %hash; + @hash{@$cols} = @$_; + $tree->{$hash{$primary}} = \%hash; + } + + return $tree; + +} #__create_dslip_tree + +=pod + +=head2 $cb->_dslip_defs () + +This function returns the definition structure (ARRAYREF) of the +dslip tree. + +=cut + +### these are the definitions used for dslip info +### they shouldn't change over time.. so hardcoding them doesn't appear to +### be a problem. if it is, we need to parse 03modlist.data better to filter +### all this out. +### right now, this is just used to look up dslip info from a module +sub _dslip_defs { + my $self = shift; + + my $aref = [ + + # D + [ q|Development Stage|, { + i => loc('Idea, listed to gain consensus or as a placeholder'), + c => loc('under construction but pre-alpha (not yet released)'), + a => loc('Alpha testing'), + b => loc('Beta testing'), + R => loc('Released'), + M => loc('Mature (no rigorous definition)'), + S => loc('Standard, supplied with Perl 5'), + }], + + # S + [ q|Support Level|, { + m => loc('Mailing-list'), + d => loc('Developer'), + u => loc('Usenet newsgroup comp.lang.perl.modules'), + n => loc('None known, try comp.lang.perl.modules'), + a => loc('Abandoned; volunteers welcome to take over maintainance'), + }], + + # L + [ q|Language Used|, { + p => loc('Perl-only, no compiler needed, should be platform independent'), + c => loc('C and perl, a C compiler will be needed'), + h => loc('Hybrid, written in perl with optional C code, no compiler needed'), + '+' => loc('C++ and perl, a C++ compiler will be needed'), + o => loc('perl and another language other than C or C++'), + }], + + # I + [ q|Interface Style|, { + f => loc('plain Functions, no references used'), + h => loc('hybrid, object and function interfaces available'), + n => loc('no interface at all (huh?)'), + r => loc('some use of unblessed References or ties'), + O => loc('Object oriented using blessed references and/or inheritance'), + }], + + # P + [ q|Public License|, { + p => loc('Standard-Perl: user may choose between GPL and Artistic'), + g => loc('GPL: GNU General Public License'), + l => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'), + b => loc('BSD: The BSD License'), + a => loc('Artistic license alone'), + o => loc('other (but distribution allowed without restrictions)'), + }], + ]; + + return $aref; +} + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + +1; diff --git a/lib/CPANPLUS/Internals/Utils.pm b/lib/CPANPLUS/Internals/Utils.pm new file mode 100644 index 0000000000..625160831b --- /dev/null +++ b/lib/CPANPLUS/Internals/Utils.pm @@ -0,0 +1,536 @@ +package CPANPLUS::Internals::Utils; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use Cwd; +use File::Copy; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Utils + +=head1 SYNOPSIS + + my $bool = $cb->_mkdir( dir => 'blah' ); + my $bool = $cb->_chdir( dir => 'blah' ); + my $bool = $cb->_rmdir( dir => 'blah' ); + + my $bool = $cb->_move( from => '/some/file', to => '/other/file' ); + my $bool = $cb->_move( from => '/some/dir', to => '/other/dir' ); + + my $cont = $cb->_get_file_contents( file => '/path/to/file' ); + + + my $version = $cb->_perl_version( perl => $^X ); + +=head1 DESCRIPTION + +C<CPANPLUS::Internals::Utils> holds a few convenience functions for +CPANPLUS libraries. + +=head1 METHODS + +=head2 $cb->_mkdir( dir => '/some/dir' ) + +C<_mkdir> creates a full path to a directory. + +Returns true on success, false on failure. + +=cut + +sub _mkdir { + my $self = shift; + + my %hash = @_; + + my $tmpl = { + dir => { required => 1 }, + }; + + my $args = check( $tmpl, \%hash ) or ( + error(loc( Params::Check->last_error ) ), return + ); + + unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { + error( loc("Could not use File::Path! This module should be core!") ); + return; + } + + eval { File::Path::mkpath($args->{dir}) }; + + if($@) { + chomp($@); + error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ )); + return; + } + + return 1; +} + +=pod + +=head2 $cb->_chdir( dir => '/some/dir' ) + +C<_chdir> changes directory to a dir. + +Returns true on success, false on failure. + +=cut + +sub _chdir { + my $self = shift; + my %hash = @_; + + my $tmpl = { + dir => { required => 1, allow => DIR_EXISTS }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + unless( chdir $args->{dir} ) { + error( loc(q[Could not chdir into '%1'], $args->{dir}) ); + return; + } + + return 1; +} + +=pod + +=head2 $cb->_rmdir( dir => '/some/dir' ); + +Removes a directory completely, even if it is non-empty. + +Returns true on success, false on failure. + +=cut + +sub _rmdir { + my $self = shift; + my %hash = @_; + + my $tmpl = { + dir => { required => 1, allow => IS_DIR }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { + error( loc("Could not use File::Path! This module should be core!") ); + return; + } + + eval { File::Path::rmtree($args->{dir}) }; + + if($@) { + chomp($@); + error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ )); + return; + } + + return 1; +} + +=pod + +=head2 $cb->_perl_version ( perl => 'some/perl/binary' ); + +C<_perl_version> returns the version of a certain perl binary. +It does this by actually running a command. + +Returns the perl version on success and false on failure. + +=cut + +sub _perl_version { + my $self = shift; + my %hash = @_; + + my $perl; + my $tmpl = { + perl => { required => 1, store => \$perl }, + }; + + check( $tmpl, \%hash ) or return; + + my $perl_version; + ### special perl, or the one we are running under? + if( $perl eq $^X ) { + ### just load the config + require Config; + $perl_version = $Config::Config{version}; + + } else { + my $cmd = $perl . + ' -MConfig -eprint+Config::config_vars+version'; + ($perl_version) = (`$cmd` =~ /version='(.*)'/); + } + + return $perl_version if defined $perl_version; + return; +} + +=pod + +=head2 $cb->_version_to_number( version => $version ); + +Returns a proper module version, or '0.0' if none was available. + +=cut + +sub _version_to_number { + my $self = shift; + my %hash = @_; + + my $version; + my $tmpl = { + version => { default => '0.0', store => \$version }, + }; + + check( $tmpl, \%hash ) or return; + + return $version if $version =~ /^\.?\d/; + return '0.0'; +} + +=pod + +=head2 $cb->_whoami + +Returns the name of the subroutine you're currently in. + +=cut + +sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name } + +=pod + +=head2 _get_file_contents( file => $file ); + +Returns the contents of a file + +=cut + +sub _get_file_contents { + my $self = shift; + my %hash = @_; + + my $file; + my $tmpl = { + file => { required => 1, store => \$file } + }; + + check( $tmpl, \%hash ) or return; + + my $fh = OPEN_FILE->($file) or return; + my $contents = do { local $/; <$fh> }; + + return $contents; +} + +=pod $cb->_move( from => $file|$dir, to => $target ); + +Moves a file or directory to the target. + +Returns true on success, false on failure. + +=cut + +sub _move { + my $self = shift; + my %hash = @_; + + my $from; my $to; + my $tmpl = { + file => { required => 1, allow => [IS_FILE,IS_DIR], + store => \$from }, + to => { required => 1, store => \$to } + }; + + check( $tmpl, \%hash ) or return; + + if( File::Copy::move( $from, $to ) ) { + return 1; + } else { + error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!)); + return; + } +} + +=pod $cb->_copy( from => $file|$dir, to => $target ); + +Moves a file or directory to the target. + +Returns true on success, false on failure. + +=cut + +sub _copy { + my $self = shift; + my %hash = @_; + + my($from,$to); + my $tmpl = { + file =>{ required => 1, allow => [IS_FILE,IS_DIR], + store => \$from }, + to => { required => 1, store => \$to } + }; + + check( $tmpl, \%hash ) or return; + + if( File::Copy::copy( $from, $to ) ) { + return 1; + } else { + error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!)); + return; + } +} + +=head2 $cb->_mode_plus_w( file => '/path/to/file' ); + +Sets the +w bit for the file. + +Returns true on success, false on failure. + +=cut + +sub _mode_plus_w { + my $self = shift; + my %hash = @_; + + require File::stat; + + my $file; + my $tmpl = { + file => { required => 1, allow => IS_FILE, store => \$file }, + }; + + check( $tmpl, \%hash ) or return; + + ### set the mode to +w for a file and +wx for a dir + my $x = File::stat::stat( $file ); + my $mask = -d $file ? 0100 : 0200; + + if( $x and chmod( $x->mode|$mask, $file ) ) { + return 1; + + } else { + error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!)); + return; + } +} + +=head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH ); + +Turns a CPANPLUS::Config style C<host> entry into an URI string. + +Returns the uri on success, and false on failure + +=cut + +sub _host_to_uri { + my $self = shift; + my %hash = @_; + + my($scheme, $host, $path); + my $tmpl = { + scheme => { required => 1, store => \$scheme }, + host => { default => '', store => \$host }, + path => { default => '', store => \$path }, + }; + + check( $tmpl, \%hash ) or return; + + $host ||= 'localhost'; + + return "$scheme://" . File::Spec::Unix->catdir( $host, $path ); +} + +=head2 $cb->_vcmp( VERSION, VERSION ); + +Normalizes the versions passed and does a '<=>' on them, returning the result. + +=cut + +sub _vcmp { + my $self = shift; + my ($x, $y) = @_; + + s/_//g foreach $x, $y; + + return $x <=> $y; +} + +=head2 $cb->_home_dir + +Returns the user's homedir, or C<cwd> if it could not be found + +=cut + +sub _home_dir { + my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN ); + + for my $env ( @os_home_envs ) { + next unless exists $ENV{ $env }; + next unless defined $ENV{ $env } && length $ENV{ $env }; + return $ENV{ $env } if -d $ENV{ $env }; + } + + return cwd(); +} + +=head2 $path = $cb->_safe_path( path => $path ); + +Returns a path that's safe to us on Win32. Only cleans up +the path on Win32 if the path exists. + +=cut + +sub _safe_path { + my $self = shift; + + my %hash = @_; + + my $path; + my $tmpl = { + path => { required => 1, store => \$path }, + }; + + check( $tmpl, \%hash ) or return; + + ### only need to fix it up if there's spaces in the path + return $path unless $path =~ /\s+/; + + ### or if we are on win32 + return $path if $^O ne 'MSWin32'; + + ### clean up paths if we are on win32 + return Win32::GetShortPathName( $path ) || $path; + +} + + +=head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING ); + +Splits the name of a CPAN package string up in it's package, version +and extension parts. + +For example, C<Foo-Bar-1.2.tar.gz> would return the following parts: + + Package: Foo-Bar + Version: 1.2 + Extension: tar.gz + +=cut + +{ my $del_re = qr/[-_\+]/i; # delimiter between elements + my $pkg_re = qr/[a-z] # any letters followed by + [a-z\d]* # any letters, numbers + (?i:\.pm)? # followed by '.pm'--authors do this :( + (?: # optionally repeating: + $del_re # followed by a delimiter + [a-z] # any letters followed by + [a-z\d]* # any letters, numbers + (?i:\.pm)? # followed by '.pm'--authors do this :( + )* + /xi; + + my $ver_re = qr/[a-z]*\d+[a-z]* # contains a digit and possibly letters + (?: + [-._] # followed by a delimiter + [a-z\d]+ # and more digits and or letters + )*? + /xi; + + my $ext_re = qr/[a-z] # a letter, followed by + [a-z\d]* # letters and or digits, optionally + (?: + \. # followed by a dot and letters + [a-z\d]+ # and or digits (like .tar.bz2) + )? # optionally + /xi; + + my $ver_ext_re = qr/ + ($ver_re+) # version, optional + (?: + \. # a literal . + ($ext_re) # extension, + )? # optional, but requires version + /xi; + + ### composed regex for CPAN packages + my $full_re = qr/ + ^ + ($pkg_re+) # package + (?: + $del_re # delimiter + $ver_ext_re # version + extension + )? + $ + /xi; + + ### composed regex for perl packages + my $perl = PERL_CORE; + my $perl_re = qr/ + ^ + ($perl) # package name for 'perl' + (?: + $ver_ext_re # version + extension + )? + $ + /xi; + + +sub _split_package_string { + my $self = shift; + my %hash = @_; + + my $str; + my $tmpl = { package => { required => 1, store => \$str } }; + check( $tmpl, \%hash ) or return; + + + ### 2 different regexes, one for the 'perl' package, + ### one for ordinary CPAN packages.. try them both, + ### first match wins. + for my $re ( $full_re, $perl_re ) { + + ### try the next if the match fails + $str =~ $re or next; + + my $pkg = $1 || ''; + my $ver = $2 || ''; + my $ext = $3 || ''; + + ### this regex resets the capture markers! + ### strip the trailing delimiter + $pkg =~ s/$del_re$//; + + ### strip the .pm package suffix some authors insist on adding + $pkg =~ s/\.pm$//i; + + return ($pkg, $ver, $ext ); + } + + return; + } +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Utils/Autoflush.pm b/lib/CPANPLUS/Internals/Utils/Autoflush.pm new file mode 100644 index 0000000000..56566436a1 --- /dev/null +++ b/lib/CPANPLUS/Internals/Utils/Autoflush.pm @@ -0,0 +1,5 @@ +package CPANPLUS::Internals::Utils::Autoflush; + +BEGIN { $|++ }; + +1; |