Initial Commit
This commit is contained in:
Riley Schneider
391
database/perl/vendor/lib/CPANPLUS/Internals/Constants.pm
vendored
Normal file
391
database/perl/vendor/lib/CPANPLUS/Internals/Constants.pm
vendored
Normal file
@@ -0,0 +1,391 @@
|
||||
package CPANPLUS::Internals::Constants;
|
||||
|
||||
use strict;
|
||||
|
||||
use CPANPLUS::Error;
|
||||
|
||||
use Config;
|
||||
use File::Spec;
|
||||
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
|
||||
|
||||
require Exporter;
|
||||
use vars qw[$VERSION @ISA @EXPORT];
|
||||
|
||||
use Package::Constants;
|
||||
|
||||
$VERSION = "0.9910";
|
||||
@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 INSTALLER_AUTOBUNDLE
|
||||
=> 'CPANPLUS::Dist::Autobundle';
|
||||
|
||||
use constant SHELL_DEFAULT => 'CPANPLUS::Shell::Default';
|
||||
use constant SHELL_CLASSIC => 'CPANPLUS::Shell::Classic';
|
||||
|
||||
use constant CONFIG => 'CPANPLUS::Config';
|
||||
use constant CONFIG_USER => 'CPANPLUS::Config::User';
|
||||
use constant CONFIG_SYSTEM => 'CPANPLUS::Config::System';
|
||||
use constant CONFIG_BOXED => 'CPANPLUS::Config::Boxed';
|
||||
|
||||
use constant DEFAULT_SOURCE_ENGINE
|
||||
=> 'CPANPLUS::Internals::Source::Memory';
|
||||
|
||||
use constant TARGET_INIT => 'init';
|
||||
use constant TARGET_CREATE => 'create';
|
||||
use constant TARGET_PREPARE => 'prepare';
|
||||
use constant TARGET_INSTALL => 'install';
|
||||
use constant TARGET_IGNORE => 'ignore';
|
||||
|
||||
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_MINIX => $^O eq 'minix';
|
||||
|
||||
use constant DOT_CPANPLUS => ON_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;
|
||||
};
|
||||
|
||||
### On VMS, if the $Config{make} is either MMK
|
||||
### or MMS, then the makefile is 'DESCRIP.MMS'.
|
||||
use constant MAKEFILE => sub { my $file =
|
||||
(ON_VMS and
|
||||
$Config::Config{make} =~ /MM[S|K]/i)
|
||||
? 'DESCRIP.MMS'
|
||||
: 'Makefile';
|
||||
|
||||
return @_
|
||||
? File::Spec->catfile( @_, $file )
|
||||
: $file;
|
||||
};
|
||||
use constant MAKEFILE_PL => sub { return @_
|
||||
? File::Spec->catfile( @_,
|
||||
'Makefile.PL' )
|
||||
: 'Makefile.PL';
|
||||
};
|
||||
use constant BUILD_PL => sub { return @_
|
||||
? File::Spec->catfile( @_,
|
||||
'Build.PL' )
|
||||
: 'Build.PL';
|
||||
};
|
||||
|
||||
use constant META_YML => sub { return @_
|
||||
? File::Spec->catfile( @_, 'META.yml' )
|
||||
: 'META.yml';
|
||||
};
|
||||
|
||||
use constant MYMETA_YML => sub { return @_
|
||||
? File::Spec->catfile( @_, 'MYMETA.yml' )
|
||||
: 'MYMETA.yml';
|
||||
};
|
||||
|
||||
use constant META_JSON => sub { return @_
|
||||
? File::Spec->catfile( @_, 'META.json' )
|
||||
: 'META.json';
|
||||
};
|
||||
|
||||
use constant MYMETA_JSON => sub { return @_
|
||||
? File::Spec->catfile( @_, 'MYMETA.json' )
|
||||
: 'MYMETA.json';
|
||||
};
|
||||
|
||||
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 BIN => 'bin';
|
||||
|
||||
use constant SCRIPT => 'script';
|
||||
|
||||
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 META_EXT => 'meta';
|
||||
|
||||
use constant META => sub { my $obj = $_[0];
|
||||
my $pkg = $obj->package_name;
|
||||
$pkg .= '-' . $obj->package_version .
|
||||
'.' . META_EXT;
|
||||
return $pkg;
|
||||
};
|
||||
|
||||
use constant OPEN_FILE => sub {
|
||||
my($file, $mode) = (@_, '');
|
||||
my $fh;
|
||||
open $fh, "$mode" . $file
|
||||
or error(loc(
|
||||
"Could not open file '%1': %2",
|
||||
$file, $!));
|
||||
return $fh if $fh;
|
||||
return;
|
||||
};
|
||||
|
||||
use constant OPEN_DIR => sub {
|
||||
my $dir = shift;
|
||||
my $dh;
|
||||
opendir $dh, $dir or error(loc(
|
||||
"Could not open dir '%1': %2", $dir, $!
|
||||
));
|
||||
|
||||
return $dh if $dh;
|
||||
return;
|
||||
};
|
||||
|
||||
use constant READ_DIR => sub {
|
||||
my $dir = shift;
|
||||
my $dh = OPEN_DIR->( $dir ) or return;
|
||||
|
||||
### exclude . and ..
|
||||
my @files = grep { $_ !~ /^\.{1,2}/ }
|
||||
readdir($dh);
|
||||
|
||||
### Remove trailing dot on VMS when
|
||||
### using VMS syntax.
|
||||
if( ON_VMS ) {
|
||||
s/(?<!\^)\.$// for @files;
|
||||
}
|
||||
|
||||
return @files;
|
||||
};
|
||||
|
||||
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://cpantesters.org/distro/'.
|
||||
uc(substr($_[0],0,1)) .'/'. $_[0] . '.yaml';
|
||||
};
|
||||
use constant TESTERS_DETAILS_URL
|
||||
=> sub {
|
||||
'http://cpantesters.org/distro/'.
|
||||
uc(substr($_[0],0,1)) .'/'. $_[0];
|
||||
};
|
||||
|
||||
use constant CREATE_FILE_URI
|
||||
=> sub {
|
||||
my $dir = $_[0] or return;
|
||||
return $dir =~ m|^/|
|
||||
? 'file://' . $dir
|
||||
: 'file:///' . $dir;
|
||||
};
|
||||
|
||||
use constant EMPTY_DSLIP => ' ';
|
||||
|
||||
use constant CUSTOM_AUTHOR_ID
|
||||
=> 'LOCAL';
|
||||
|
||||
use constant DOT_SHELL_DEFAULT_RC
|
||||
=> '.shell-default.rc';
|
||||
|
||||
use constant SOURCE_SQLITE_DB
|
||||
=> 'db.sql';
|
||||
|
||||
use constant PREREQ_IGNORE => 0;
|
||||
use constant PREREQ_INSTALL => 1;
|
||||
use 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 PERL_WRAPPER => 'use strict; BEGIN { my $old = select STDERR; $|++; select $old; $|++; $0 = shift(@ARGV); my $rv = do($0); die $@ if $@; }';
|
||||
use constant STORABLE_EXT => '.stored';
|
||||
|
||||
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_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:
|
||||
426
database/perl/vendor/lib/CPANPLUS/Internals/Constants/Report.pm
vendored
Normal file
426
database/perl/vendor/lib/CPANPLUS/Internals/Constants/Report.pm
vendored
Normal file
@@ -0,0 +1,426 @@
|
||||
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;
|
||||
|
||||
### for the version
|
||||
require CPANPLUS::Internals;
|
||||
|
||||
$VERSION = "0.9910";
|
||||
@ISA = qw[Exporter];
|
||||
@EXPORT = Package::Constants->list( __PACKAGE__ );
|
||||
|
||||
### OS to regex map ###
|
||||
my %OS = (
|
||||
Amiga => 'amigaos',
|
||||
Atari => 'mint',
|
||||
BSD => 'bsdos|bitrig|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|bitrig|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 =~ /^$platform\b/i ) {
|
||||
# beware the Mac != MAC
|
||||
next if($platform eq 'Mac' &&
|
||||
$name !~ /^$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 $last = ( split /\[ERROR\] .+? MAKE TEST/, $buffer )[-1];
|
||||
my @list = map { s/.pm$//; s|/|::|g; $_ }
|
||||
($last =~
|
||||
m/\bCan\'t locate (\S+) in \@INC/g);
|
||||
|
||||
### make sure every missing prereq is only
|
||||
### listed once
|
||||
{ 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_MESSAGE_PASS_HEADER
|
||||
=> sub {
|
||||
my($stage, $buffer) = @_;
|
||||
return << ".";
|
||||
|
||||
Thank you for uploading your work to CPAN. Congratulations!
|
||||
All tests were successful.
|
||||
|
||||
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
|
||||
}
|
||||
);
|
||||
|
||||
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 can't be found in the 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 { sprintf "\t%s %-30s %8s %8s\n",
|
||||
@$_
|
||||
|
||||
} [' ', 'Module Name', 'Have', 'Want'],
|
||||
map { my $want = $prq->{$_->name};
|
||||
[ do { $_->is_uptodate(
|
||||
version => $want
|
||||
) ? ' ' : '!'
|
||||
},
|
||||
$_->name,
|
||||
$_->installed_version,
|
||||
$want
|
||||
],
|
||||
### might be empty entries in there
|
||||
} grep { $_ } @prq;
|
||||
|
||||
return $str;
|
||||
};
|
||||
|
||||
use constant REPORT_TOOLCHAIN_VERSIONS
|
||||
=> sub {
|
||||
my $mod = shift;
|
||||
my $cb = $mod->parent;
|
||||
#die unless $cb->isa('CPANPLUS::Backend');
|
||||
|
||||
my @toolchain_modules= qw(
|
||||
CPANPLUS
|
||||
CPANPLUS::Dist::Build
|
||||
Cwd
|
||||
ExtUtils::CBuilder
|
||||
ExtUtils::Command
|
||||
ExtUtils::Install
|
||||
ExtUtils::MakeMaker
|
||||
ExtUtils::Manifest
|
||||
ExtUtils::ParseXS
|
||||
File::Spec
|
||||
Module::Build
|
||||
Pod::Parser
|
||||
Pod::Simple
|
||||
Test::Harness
|
||||
Test::More
|
||||
Test2
|
||||
version
|
||||
);
|
||||
|
||||
my @toolchain =
|
||||
grep { $_ } #module_tree returns '' when module is not found
|
||||
map { $cb->module_tree($_) }
|
||||
sort @toolchain_modules;
|
||||
|
||||
### no prereqs?
|
||||
return '' unless @toolchain;
|
||||
|
||||
### toolchain modules
|
||||
my $str = << ".";
|
||||
|
||||
Perl module toolchain versions installed:
|
||||
.
|
||||
$str .= join '',
|
||||
map { sprintf "\t%-30s %8s\n",
|
||||
@$_
|
||||
|
||||
} ['Module Name', 'Have'],
|
||||
map {
|
||||
[ $_->name,
|
||||
$_->installed_version,
|
||||
],
|
||||
### might be empty entries in there
|
||||
} @toolchain;
|
||||
|
||||
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:
|
||||
253
database/perl/vendor/lib/CPANPLUS/Internals/Extract.pm
vendored
Normal file
253
database/perl/vendor/lib/CPANPLUS/Internals/Extract.pm
vendored
Normal file
@@ -0,0 +1,253 @@
|
||||
package CPANPLUS::Internals::Extract;
|
||||
|
||||
use strict;
|
||||
|
||||
use CPANPLUS::Error;
|
||||
use CPANPLUS::Internals::Constants;
|
||||
|
||||
use File::Spec ();
|
||||
use File::Path ();
|
||||
use File::Temp ();
|
||||
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';
|
||||
|
||||
use vars qw[$VERSION];
|
||||
$VERSION = "0.9910";
|
||||
|
||||
local $Params::Check::VERBOSE = 1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CPANPLUS::Internals::Extract - internals for archive extraction
|
||||
|
||||
=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'),
|
||||
);
|
||||
|
||||
File::Path::mkpath( $to ) unless -d $to;
|
||||
$to = File::Temp::tempdir( DIR => $to, CLEANUP => 0 );
|
||||
|
||||
msg(loc("Extracting '%1'", $mod->package), $verbose);
|
||||
### 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 don't 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. Install '%2' and ensure ".
|
||||
"it works properly and try again",
|
||||
$ae->is_zip ? 'Archive::Zip' : 'Archive::Tar' ) );
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
### print out what files we extracted ###
|
||||
### No one needs to see this, but we'll log it
|
||||
msg(loc("Extracted '%1'",$_),0) 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 too rigorous -- 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->catfile($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(
|
||||
### _safe_path must be called before catdir because catdir on
|
||||
### VMS currently will not handle the extra dots in the directories.
|
||||
File::Spec->catdir( $self->_safe_path( path => $to ) ,
|
||||
$self->_safe_path( path =>
|
||||
$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:
|
||||
475
database/perl/vendor/lib/CPANPLUS/Internals/Fetch.pm
vendored
Normal file
475
database/perl/vendor/lib/CPANPLUS/Internals/Fetch.pm
vendored
Normal file
@@ -0,0 +1,475 @@
|
||||
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';
|
||||
use vars qw[$VERSION];
|
||||
$VERSION = "0.9910";
|
||||
|
||||
$Params::Check::VERBOSE = 1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CPANPLUS::Internals::Fetch - internals for fetching files
|
||||
|
||||
=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, ttl => $seconds] )
|
||||
|
||||
C<_fetch> will fetch files based on the information in a module
|
||||
object. You always need a module object. If you want a fake module
|
||||
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<ttl> (in seconds) indicates how long a cached copy is valid for. If
|
||||
the fetch time of the local copy is within the ttl, the cached copy is
|
||||
returned. Otherwise, the file is refetched.
|
||||
|
||||
C<_fetch> figures out, based on the host list, what scheme to use and
|
||||
from there, delegates to C<File::Fetch> do the actual fetching.
|
||||
|
||||
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, $ttl);
|
||||
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') },
|
||||
ttl => { default => 0, store => \$ttl },
|
||||
};
|
||||
|
||||
|
||||
my $args = check( $tmpl, \%hash ) or return;
|
||||
|
||||
### check if we already downloaded the thing ###
|
||||
if( (my $where = $modobj->status->fetch()) and not $force and not $ttl ) {
|
||||
|
||||
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 download 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 so, can we use the cached version,
|
||||
### or do we need to refetch?
|
||||
if( -e $local_file ) {
|
||||
|
||||
my $unlink = 0;
|
||||
my $use_cached = 0;
|
||||
|
||||
### if force is in effect, we have to refetch
|
||||
if( $force ) {
|
||||
$unlink++
|
||||
|
||||
### if you provided a ttl, and it was exceeded, we'll refetch,
|
||||
} elsif( $ttl and ([stat $local_file]->[9] + $ttl > time) ) {
|
||||
msg(loc("Using cached file '%1' on disk; ".
|
||||
"ttl (%2s) is not exceeded",
|
||||
$local_file, $ttl), $verbose );
|
||||
|
||||
$use_cached++;
|
||||
|
||||
### if you provided a ttl, and the above conditional didn't match,
|
||||
### we exceeded the ttl, so we refetch
|
||||
} elsif ( $ttl ) {
|
||||
$unlink++;
|
||||
|
||||
### otherwise we can use the cached version
|
||||
} else {
|
||||
$use_cached++;
|
||||
}
|
||||
|
||||
if( $unlink ) {
|
||||
### some fetches will fail if the files exist already, so let's
|
||||
### delete them first
|
||||
1 while unlink $local_file;
|
||||
|
||||
msg(loc("Could not delete %1, some methods may " .
|
||||
"fail to force a download", $local_file), $verbose)
|
||||
if -e $local_file;
|
||||
|
||||
} else {
|
||||
|
||||
### store where we fetched it ###
|
||||
$modobj->status->fetch( $local_file );
|
||||
|
||||
return $local_file;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
### 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 $where;
|
||||
|
||||
### file:// uris are special and need parsing
|
||||
if( $host->{'scheme'} eq 'file' ) {
|
||||
|
||||
### the full path in the native format of the OS
|
||||
my $host_spec =
|
||||
File::Spec->file_name_is_absolute( $host->{'path'} )
|
||||
? $host->{'path'}
|
||||
: File::Spec->rel2abs( $host->{'path'} );
|
||||
|
||||
### there might be volumes involved on vms/win32
|
||||
if( ON_WIN32 or ON_VMS ) {
|
||||
|
||||
### now extract the volume in order to be Win32 and
|
||||
### VMS friendly.
|
||||
### 'no_file' indicates that there's no file part
|
||||
### of this path, so we only get 2 bits returned.
|
||||
my ($vol, $host_path) = File::Spec->splitpath(
|
||||
$host_spec, 'no_file'
|
||||
);
|
||||
|
||||
### and split up the directories
|
||||
my @host_dirs = File::Spec->splitdir( $host_path );
|
||||
|
||||
### if we got a volume we pretend its a directory for
|
||||
### the sake of the file:// url
|
||||
if( defined $vol and $vol ) {
|
||||
|
||||
### D:\foo\bar needs to be encoded as D|\foo\bar
|
||||
### For details, see the following link:
|
||||
### http://en.wikipedia.org/wiki/File://
|
||||
### The RFC doesn't seem to address Windows volume
|
||||
### descriptors but it does address VMS volume
|
||||
### descriptors, however wikipedia covers a bit of
|
||||
### history regarding win32
|
||||
$vol =~ s/:$/|/ if ON_WIN32;
|
||||
|
||||
$vol =~ s/:// if ON_VMS;
|
||||
|
||||
### XXX i'm not sure what cases this is addressing.
|
||||
### this comes straight from dmq's file:// patches
|
||||
### for win32. --kane
|
||||
### According to dmq, the best summary is:
|
||||
### "if file:// urls don't look right on VMS reuse
|
||||
### the win32 logic and see if that fixes things"
|
||||
|
||||
### first element not empty? Might happen on VMS.
|
||||
### prepend the volume in that case.
|
||||
if( $host_dirs[0] ) {
|
||||
unshift @host_dirs, $vol;
|
||||
|
||||
### element empty? reuse it to store the volume
|
||||
### encoded as a directory name. (Win32/VMS)
|
||||
} else {
|
||||
$host_dirs[0] = $vol;
|
||||
}
|
||||
}
|
||||
|
||||
### now it's in UNIX format, which is the same format
|
||||
### as used for URIs
|
||||
$host_spec = File::Spec::Unix->catdir( @host_dirs );
|
||||
}
|
||||
|
||||
### now create the file:// uri from the components
|
||||
$where = CREATE_FILE_URI->(
|
||||
File::Spec::Unix->catfile(
|
||||
$host->{'host'} || '',
|
||||
$host_spec,
|
||||
$remote_file,
|
||||
)
|
||||
);
|
||||
|
||||
### its components will be in unix format, for a http://,
|
||||
### ftp:// or any other style of URI
|
||||
} else {
|
||||
my $mirror_path = File::Spec::Unix->catfile(
|
||||
$host->{'path'}, $remote_file
|
||||
);
|
||||
|
||||
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 );
|
||||
|
||||
### so TTLs will work
|
||||
$self->_update_timestamp( file => $abs );
|
||||
|
||||
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:
|
||||
695
database/perl/vendor/lib/CPANPLUS/Internals/Report.pm
vendored
Normal file
695
database/perl/vendor/lib/CPANPLUS/Internals/Report.pm
vendored
Normal file
@@ -0,0 +1,695 @@
|
||||
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 Module::Load::Conditional qw[can_load];
|
||||
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
|
||||
use version;
|
||||
|
||||
use vars qw[$VERSION];
|
||||
$VERSION = "0.9910";
|
||||
|
||||
$Params::Check::VERBOSE = 1;
|
||||
|
||||
### for the version ###
|
||||
require CPANPLUS::Internals;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CPANPLUS::Internals::Report - internals for sending test reports
|
||||
|
||||
=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
|
||||
|
||||
### XXX remove this list and move it into selfupdate, somehow..
|
||||
### this is dual administration
|
||||
{ my $query_list = {
|
||||
'File::Fetch' => '0.13_02',
|
||||
'Parse::CPAN::Meta' => '0.0',
|
||||
'File::Temp' => '0.0',
|
||||
};
|
||||
|
||||
my $send_list = {
|
||||
%$query_list,
|
||||
'Test::Reporter' => '1.54',
|
||||
};
|
||||
|
||||
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. The contents of the
|
||||
data structure depends on what I<http://testers.cpan.org> returns,
|
||||
but generally looks like this:
|
||||
|
||||
{
|
||||
'grade' => 'PASS',
|
||||
'dist' => 'CPANPLUS-0.042',
|
||||
'platform' => 'i686-pld-linux-thread-multi'
|
||||
'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/98316'
|
||||
...
|
||||
},
|
||||
{
|
||||
'grade' => 'PASS',
|
||||
'dist' => 'CPANPLUS-0.042',
|
||||
'platform' => 'i686-linux-thread-multi'
|
||||
'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99416'
|
||||
...
|
||||
},
|
||||
{
|
||||
'grade' => 'FAIL',
|
||||
'dist' => 'CPANPLUS-0.042',
|
||||
'platform' => 'cygwin-multi-64int',
|
||||
'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99371'
|
||||
...
|
||||
},
|
||||
{
|
||||
'grade' => 'FAIL',
|
||||
'dist' => 'CPANPLUS-0.042',
|
||||
'platform' => 'i586-linux',
|
||||
'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99396'
|
||||
...
|
||||
},
|
||||
|
||||
The status of the test can be one of the following:
|
||||
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 );
|
||||
|
||||
|
||||
### XXX no longer use LWP here. However, that means we don't
|
||||
### automagically set proxies anymore!!!
|
||||
# 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 $ff = File::Fetch->new( uri => $url );
|
||||
|
||||
msg( loc("Fetching: '%1'", $url), $verbose );
|
||||
|
||||
my $res = do {
|
||||
my $tempdir = File::Temp::tempdir();
|
||||
my $where = $ff->fetch( to => $tempdir );
|
||||
|
||||
unless( $where ) {
|
||||
error( loc( "Fetching report for '%1' failed: %2",
|
||||
$url, $ff->error ) );
|
||||
return;
|
||||
}
|
||||
|
||||
my $fh = OPEN_FILE->( $where );
|
||||
|
||||
do { local $/; <$fh> };
|
||||
};
|
||||
|
||||
my ($aref) = eval { Parse::CPAN::Meta::Load( $res ) };
|
||||
|
||||
if( $@ ) {
|
||||
error(loc("Error reading result: %1", $@));
|
||||
return;
|
||||
};
|
||||
|
||||
my $dist = $mod->package_name .'-'. $mod->package_version;
|
||||
my $details = TESTERS_DETAILS_URL->($mod->package_name);
|
||||
|
||||
my @rv;
|
||||
for my $href ( @$aref ) {
|
||||
next unless $all or defined $href->{'distversion'} &&
|
||||
$href->{'distversion'} eq $dist;
|
||||
|
||||
$href->{'details'} = $details;
|
||||
|
||||
### backwards compatibility :(
|
||||
$href->{'dist'} ||= $href->{'distversion'};
|
||||
$href->{'grade'} ||= $href->{'action'} || $href->{'status'};
|
||||
|
||||
push @rv, $href;
|
||||
}
|
||||
|
||||
return @rv if @rv;
|
||||
return;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, verbose => BOOL, force => BOOL]);
|
||||
|
||||
This function sends a testers report to C<cpan-testers@perl.org> for a
|
||||
particular distribution.
|
||||
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 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,
|
||||
$tests_skipped, $status );
|
||||
my $tmpl = {
|
||||
module => { required => 1, store => \$mod, allow => IS_MODOBJ },
|
||||
buffer => { required => 1, store => \$buffer },
|
||||
failed => { required => 1, store => \$failed },
|
||||
status => { default => {}, store => \$status, strict_type => 1 },
|
||||
address => { default => CPAN_TESTERS_EMAIL, store => \$address },
|
||||
save => { default => 0, store => \$save },
|
||||
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 $distfile= $mod->author->cpanid . "/" . $mod->package;
|
||||
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;
|
||||
|
||||
|
||||
### will be 'fetch', 'make', 'test', 'install', etc ###
|
||||
my $stage = TEST_FAIL_STAGE->($buffer);
|
||||
|
||||
### 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 instead
|
||||
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 || {};
|
||||
|
||||
PREREQ: while( my($prq_name,$prq_ver) = each %$prq ) {
|
||||
|
||||
# 'perl' listed as prereq
|
||||
|
||||
if ( $prq_name eq 'perl' ) {
|
||||
my $req_ver = eval { version->new( $prq_ver ) };
|
||||
next PREREQ unless $req_ver;
|
||||
if ( version->new( $] ) < $req_ver ) {
|
||||
msg(loc("'%1' requires a higher version of perl than your current ".
|
||||
"version -- sending N/A grade.", $name), $verbose);
|
||||
|
||||
$grade = GRADE_NA;
|
||||
last GRADE;
|
||||
}
|
||||
next PREREQ;
|
||||
}
|
||||
|
||||
my $obj = $cb->module_tree( $prq_name );
|
||||
my $sub = CPANPLUS::Module->can(
|
||||
'module_is_supplied_with_perl_core' );
|
||||
|
||||
### if we can't find the module and it's not supplied with core.
|
||||
### this addresses: #32064: NA reports generated for failing
|
||||
### tests where core prereqs are specified
|
||||
### Note that due to a bug in Module::CoreList, in some released
|
||||
### version of perl (5.8.6+ and 5.9.2-4 at the time of writing)
|
||||
### 'Config' is not recognized as a core module. See this bug:
|
||||
### http://rt.cpan.org/Ticket/Display.html?id=32155
|
||||
if( !$obj and !defined $sub->( $prq_name ) ) {
|
||||
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 ( !$obj ) {
|
||||
my $vcore = $sub->( $prq_name );
|
||||
if ( $cb->_vcmp( $prq_ver, $vcore ) > 0 ) {
|
||||
msg(loc( "Version of core module '%1' ('%2') is too low for ".
|
||||
"'%3' (needs '%4') -- sending N/A grade",
|
||||
$prq_name, $vcore,
|
||||
$name, $prq_ver ), $verbose );
|
||||
|
||||
$grade = GRADE_NA;
|
||||
last GRADE;
|
||||
}
|
||||
}
|
||||
|
||||
if( $obj and $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 don't 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;
|
||||
### failures in PL or make/build stage are now considered UNKNOWN
|
||||
} elsif ( $stage !~ /\btest\b/ ) {
|
||||
|
||||
$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 ###
|
||||
|
||||
### the header -- always include so the CPANPLUS version is apparent
|
||||
my $message = REPORT_MESSAGE_HEADER->( $int_ver, $author );
|
||||
|
||||
if( $grade eq GRADE_FAIL or $grade eq GRADE_UNKNOWN) {
|
||||
|
||||
### return if one or more missing external libraries
|
||||
if( my @missing = MISSING_EXTLIBS_LIST->($buffer) ) {
|
||||
msg(loc("Not sending test report - " .
|
||||
"external libraries not pre-installed"));
|
||||
return 1;
|
||||
}
|
||||
|
||||
### return if we're only supposed to report make_test failures ###
|
||||
return 1 if $cp_conf =~ /\bmaketest_only\b/i
|
||||
and ($stage !~ /\btest\b/);
|
||||
|
||||
my $capture = ( $status && defined $status->{capture} ? $status->{capture} : $buffer );
|
||||
### the bit where we inform what went wrong
|
||||
$message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $capture );
|
||||
|
||||
### 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);
|
||||
|
||||
### add a list of versions of toolchain modules
|
||||
$message .= REPORT_TOOLCHAIN_VERSIONS->($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->();
|
||||
} elsif( $grade eq GRADE_NA) {
|
||||
|
||||
my $capture = ( $status && defined $status->{capture} ? $status->{capture} : $buffer );
|
||||
|
||||
### add the reason for the NA to the buffer
|
||||
$capture = join $/, $capture, map {
|
||||
'[' . $_->tag . '] [' . $_->when . '] ' .
|
||||
$_->message } ( CPANPLUS::Error->stack )[-1];
|
||||
|
||||
### the bit where we inform what went wrong
|
||||
$message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $capture );
|
||||
|
||||
### add a list of what modules have been loaded of your prereqs list
|
||||
$message .= REPORT_LOADED_PREREQS->($mod);
|
||||
|
||||
### add a list of versions of toolchain modules
|
||||
$message .= REPORT_TOOLCHAIN_VERSIONS->($mod);
|
||||
|
||||
### the footer
|
||||
$message .= REPORT_MESSAGE_FOOTER->();
|
||||
|
||||
} elsif ( $grade eq GRADE_PASS and ( $status and defined $status->{capture} ) ) {
|
||||
### the bit where we inform what went right
|
||||
$message .= REPORT_MESSAGE_PASS_HEADER->( $stage, $status->{capture} );
|
||||
|
||||
### add a list of what modules have been loaded of your prereqs list
|
||||
$message .= REPORT_LOADED_PREREQS->($mod);
|
||||
|
||||
### add a list of versions of toolchain modules
|
||||
$message .= REPORT_TOOLCHAIN_VERSIONS->($mod);
|
||||
|
||||
### the footer
|
||||
$message .= REPORT_MESSAGE_FOOTER->();
|
||||
|
||||
}
|
||||
|
||||
msg( loc("Sending test report for '%1'", $dist), $verbose);
|
||||
|
||||
### reporter object ###
|
||||
my $reporter = do {
|
||||
my $args = $conf->get_conf('cpantest_reporter_args') || {};
|
||||
|
||||
unless( UNIVERSAL::isa( $args, 'HASH' ) ) {
|
||||
error(loc("'%1' must be a hashref, ignoring...",
|
||||
'cpantest_reporter_args'));
|
||||
$args = {};
|
||||
}
|
||||
|
||||
Test::Reporter->new(
|
||||
grade => $grade,
|
||||
distribution => $dist,
|
||||
distfile => $distfile,
|
||||
via => "CPANPLUS $int_ver",
|
||||
timeout => $conf->get_conf('timeout') || 60,
|
||||
debug => $conf->get_conf('debug'),
|
||||
%$args,
|
||||
);
|
||||
};
|
||||
|
||||
### set a custom mx, if requested
|
||||
$reporter->mx( [ $conf->get_conf('cpantest_mx') ] )
|
||||
if $conf->get_conf('cpantest_mx');
|
||||
|
||||
### set the from address ###
|
||||
$reporter->from( $conf->get_conf('email') )
|
||||
if $conf->get_conf('email') !~ /\@example\.\w+$/i;
|
||||
|
||||
### give the user a chance to programmatically 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;
|
||||
}
|
||||
|
||||
### 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;
|
||||
}
|
||||
|
||||
### XXX should we do an 'already sent' check? ###
|
||||
### something broke :( ###
|
||||
}
|
||||
else {
|
||||
my $status;
|
||||
eval {
|
||||
$status = $reporter->send();
|
||||
};
|
||||
if ( $@ ) {
|
||||
error(loc("Could not send '%1' report for '%2': %3",
|
||||
$grade, $dist, $@));
|
||||
return;
|
||||
}
|
||||
if ( $status ) {
|
||||
msg(loc("Successfully sent '%1' report for '%2'", $grade, $dist),
|
||||
$verbose);
|
||||
return 1;
|
||||
}
|
||||
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:
|
||||
366
database/perl/vendor/lib/CPANPLUS/Internals/Search.pm
vendored
Normal file
366
database/perl/vendor/lib/CPANPLUS/Internals/Search.pm
vendored
Normal file
@@ -0,0 +1,366 @@
|
||||
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';
|
||||
|
||||
use vars qw[$VERSION];
|
||||
$VERSION = "0.9910";
|
||||
|
||||
$Params::Check::VERBOSE = 1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CPANPLUS::Internals::Search - internals for searching for modules
|
||||
|
||||
=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 => \@regexes, [data => \@previous_results ] )
|
||||
|
||||
Searches the moduletree for module objects matching the criteria you
|
||||
specify. Returns an array ref of module objects on success, and false
|
||||
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 => [],
|
||||
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 = do {
|
||||
### don't check the template for sanity
|
||||
### -- we know it's good and saves a lot of performance
|
||||
local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
|
||||
|
||||
check( $tmpl, \%hash );
|
||||
} or return;
|
||||
|
||||
### a list of module objects was supplied
|
||||
if( @$mods ) {
|
||||
local $Params::Check::VERBOSE = 0;
|
||||
|
||||
my @rv;
|
||||
for my $mod (@$mods) {
|
||||
#push @rv, $mod if check(
|
||||
# { $type => { allow => $list } },
|
||||
# { $type => $mod->$type() }
|
||||
# );
|
||||
push @rv, $mod if allow( $mod->$type() => $list );
|
||||
|
||||
}
|
||||
return \@rv;
|
||||
|
||||
} else {
|
||||
my @rv = $self->_source_search_module_tree(
|
||||
allow => $list,
|
||||
type => $type,
|
||||
);
|
||||
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 => [],
|
||||
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;
|
||||
|
||||
if( @$authors ) {
|
||||
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;
|
||||
} else {
|
||||
my @rv = $self->_source_search_author_tree(
|
||||
allow => $list,
|
||||
type => $type,
|
||||
);
|
||||
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 = @_;
|
||||
|
||||
### File::Find uses follow_skip => 1 by default, which doesn't die
|
||||
### on duplicates, unless they are directories or symlinks.
|
||||
### Ticket #29796 shows this code dying on Alien::WxWidgets,
|
||||
### which uses symlinks.
|
||||
### File::Find doc says to use follow_skip => 2 to ignore duplicates
|
||||
### so this will stop it from dying.
|
||||
my %find_args = ( follow_skip => 2 );
|
||||
|
||||
### 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
|
||||
$find_args{'follow_fast'} = 1 unless ON_WIN32;
|
||||
|
||||
### 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;
|
||||
|
||||
my %seen; my @rv;
|
||||
for my $dir (@INC ) {
|
||||
next if $dir eq '.';
|
||||
|
||||
### not a directory after all
|
||||
### may be coderef or some such
|
||||
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
|
||||
|
||||
### John M. notes: On VMS cannonpath can not currently handle
|
||||
### the $dir values that are in UNIX format.
|
||||
$dir = File::Spec->canonpath( $dir ) unless ON_VMS;
|
||||
|
||||
### have to use F::S::Unix on VMS, or things will break
|
||||
my $file_spec = ON_VMS ? 'File::Spec::Unix' : 'File::Spec';
|
||||
|
||||
### XXX in some cases File::Find can actually die!
|
||||
### so be safe and wrap it in an eval.
|
||||
eval { File::Find::find(
|
||||
{ %find_args,
|
||||
wanted => sub {
|
||||
|
||||
return unless /\.pm$/i;
|
||||
my $mod = $File::Find::name;
|
||||
|
||||
### make sure it's in Unix format, as it
|
||||
### may be in VMS format on VMS;
|
||||
$mod = VMS::Filespec::unixify( $mod ) if ON_VMS;
|
||||
|
||||
$mod = substr($mod, length($dir) + 1, -3);
|
||||
$mod = join '::', $file_spec->splitdir($mod);
|
||||
|
||||
return if $seen{$mod}++;
|
||||
|
||||
my $modobj = $self->module_tree($mod);
|
||||
|
||||
### separate return, a list context return with one ''
|
||||
### in it, is also true!
|
||||
return unless $modobj;
|
||||
|
||||
push @rv, $modobj;
|
||||
},
|
||||
}, $dir
|
||||
) };
|
||||
|
||||
### report the error if file::find died
|
||||
error(loc("Error finding installed files in '%1': %2", $dir, $@)) if $@;
|
||||
}
|
||||
|
||||
return \@rv;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# Local variables:
|
||||
# c-indentation-style: bsd
|
||||
# c-basic-offset: 4
|
||||
# indent-tabs-mode: nil
|
||||
# End:
|
||||
# vim: expandtab shiftwidth=4:
|
||||
1391
database/perl/vendor/lib/CPANPLUS/Internals/Source.pm
vendored
Normal file
1391
database/perl/vendor/lib/CPANPLUS/Internals/Source.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
380
database/perl/vendor/lib/CPANPLUS/Internals/Source/Memory.pm
vendored
Normal file
380
database/perl/vendor/lib/CPANPLUS/Internals/Source/Memory.pm
vendored
Normal file
@@ -0,0 +1,380 @@
|
||||
package CPANPLUS::Internals::Source::Memory;
|
||||
|
||||
use base 'CPANPLUS::Internals::Source';
|
||||
|
||||
use strict;
|
||||
|
||||
use CPANPLUS::Error;
|
||||
use CPANPLUS::Module;
|
||||
use CPANPLUS::Module::Fake;
|
||||
use CPANPLUS::Module::Author;
|
||||
use CPANPLUS::Internals::Constants;
|
||||
|
||||
use File::Fetch;
|
||||
use Archive::Extract;
|
||||
|
||||
use IPC::Cmd qw[can_run];
|
||||
use File::Temp qw[tempdir];
|
||||
use File::Basename qw[dirname];
|
||||
use Params::Check qw[allow check];
|
||||
use Module::Load::Conditional qw[can_load];
|
||||
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
|
||||
|
||||
use vars qw[$VERSION];
|
||||
$VERSION = "0.9910";
|
||||
|
||||
$Params::Check::VERBOSE = 1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CPANPLUS::Internals::Source::Memory - In memory implementation
|
||||
|
||||
=cut
|
||||
|
||||
### flag to show if init_trees got its' data from storable. This allows
|
||||
### us to not write an existing stored file back to disk
|
||||
{ my $from_storable;
|
||||
|
||||
sub _init_trees {
|
||||
my $self = shift;
|
||||
my $conf = $self->configure_object;
|
||||
my %hash = @_;
|
||||
|
||||
my($path,$uptodate,$verbose,$use_stored);
|
||||
my $tmpl = {
|
||||
path => { default => $conf->get_conf('base'), store => \$path },
|
||||
verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
|
||||
uptodate => { required => 1, store => \$uptodate },
|
||||
use_stored => { default => 1, store => \$use_stored },
|
||||
};
|
||||
|
||||
check( $tmpl, \%hash ) or return;
|
||||
|
||||
### retrieve the stored source files ###
|
||||
my $stored = $self->__memory_retrieve_source(
|
||||
path => $path,
|
||||
uptodate => $uptodate && $use_stored,
|
||||
verbose => $verbose,
|
||||
) || {};
|
||||
|
||||
### we got this from storable if $stored has keys..
|
||||
$from_storable = keys %$stored ? 1 : 0;
|
||||
|
||||
### set up the trees
|
||||
$self->_atree( $stored->{_atree} || {} );
|
||||
$self->_mtree( $stored->{_mtree} || {} );
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _standard_trees_completed { return $from_storable }
|
||||
sub _custom_trees_completed { return $from_storable }
|
||||
|
||||
sub _finalize_trees {
|
||||
my $self = shift;
|
||||
my $conf = $self->configure_object;
|
||||
my %hash = @_;
|
||||
|
||||
my($path,$uptodate,$verbose);
|
||||
my $tmpl = {
|
||||
path => { default => $conf->get_conf('base'), store => \$path },
|
||||
verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
|
||||
uptodate => { required => 1, store => \$uptodate },
|
||||
};
|
||||
|
||||
{ local $Params::Check::ALLOW_UNKNOWN = 1;
|
||||
check( $tmpl, \%hash ) or return;
|
||||
}
|
||||
|
||||
### write the stored files to disk, so we can keep using them
|
||||
### from now on, till they become invalid
|
||||
### write them if the original sources weren't uptodate, or
|
||||
### we didn't just load storable files
|
||||
$self->__memory_save_source() if !$uptodate or not $from_storable;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
### saves current memory state
|
||||
sub _save_state {
|
||||
my $self = shift;
|
||||
return $self->_finalize_trees( @_, uptodate => 0 );
|
||||
}
|
||||
}
|
||||
|
||||
sub _add_author_object {
|
||||
my $self = shift;
|
||||
my %hash = @_;
|
||||
|
||||
my $class;
|
||||
my $tmpl = {
|
||||
class => { default => 'CPANPLUS::Module::Author', store => \$class },
|
||||
map { $_ => { required => 1 } }
|
||||
qw[ author cpanid email ]
|
||||
};
|
||||
|
||||
my $href = do {
|
||||
local $Params::Check::NO_DUPLICATES = 1;
|
||||
check( $tmpl, \%hash ) or return;
|
||||
};
|
||||
|
||||
my $obj = $class->new( %$href, _id => $self->_id );
|
||||
|
||||
$self->author_tree->{ $href->{'cpanid'} } = $obj or return;
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
{
|
||||
my $tmpl = {
|
||||
class => { default => 'CPANPLUS::Module' },
|
||||
map { $_ => { required => 1 } } qw[
|
||||
module version path comment author package description dslip mtime
|
||||
],
|
||||
};
|
||||
|
||||
sub _add_module_object {
|
||||
my $self = shift;
|
||||
my %hash = @_;
|
||||
|
||||
my $href = do {
|
||||
local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
|
||||
check( $tmpl, \%hash ) or return;
|
||||
};
|
||||
my $class = delete $href->{class};
|
||||
|
||||
my $obj = $class->new( %$href, _id => $self->_id );
|
||||
|
||||
### Every module get's stored as a module object ###
|
||||
$self->module_tree->{ $href->{module} } = $obj or return;
|
||||
|
||||
return $obj;
|
||||
}
|
||||
}
|
||||
|
||||
{ my %map = (
|
||||
_source_search_module_tree => [ module_tree => 'CPANPLUS::Module' ],
|
||||
_source_search_author_tree => [ author_tree => 'CPANPLUS::Module::Author' ],
|
||||
);
|
||||
|
||||
while( my($sub, $aref) = each %map ) {
|
||||
no strict 'refs';
|
||||
|
||||
my($meth, $class) = @$aref;
|
||||
|
||||
*$sub = sub {
|
||||
my $self = shift;
|
||||
my $conf = $self->configure_object;
|
||||
my %hash = @_;
|
||||
|
||||
my($authors,$list,$verbose,$type);
|
||||
my $tmpl = {
|
||||
data => { default => [],
|
||||
strict_type=> 1, store => \$authors },
|
||||
allow => { required => 1, default => [ ], strict_type => 1,
|
||||
store => \$list },
|
||||
verbose => { default => $conf->get_conf('verbose'),
|
||||
store => \$verbose },
|
||||
type => { required => 1, allow => [$class->accessors()],
|
||||
store => \$type },
|
||||
};
|
||||
|
||||
my $args = check( $tmpl, \%hash ) or return;
|
||||
|
||||
my @rv;
|
||||
for my $obj ( values %{ $self->$meth } ) {
|
||||
#push @rv, $auth if check(
|
||||
# { $type => { allow => $list } },
|
||||
# { $type => $auth->$type }
|
||||
# );
|
||||
push @rv, $obj if allow( $obj->$type() => $list );
|
||||
}
|
||||
|
||||
return @rv;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 $cb->__memory_retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL])
|
||||
|
||||
This method retrieves a I<storable>d tree identified by C<$name>.
|
||||
|
||||
It takes the following arguments:
|
||||
|
||||
=over 4
|
||||
|
||||
=item name
|
||||
|
||||
The internal name for the source file to retrieve.
|
||||
|
||||
=item uptodate
|
||||
|
||||
A flag indicating whether the file-cache is up-to-date or not.
|
||||
|
||||
=item path
|
||||
|
||||
The absolute path to the directory holding the source files.
|
||||
|
||||
=item verbose
|
||||
|
||||
A boolean flag indicating whether or not to be verbose.
|
||||
|
||||
=back
|
||||
|
||||
Will get information from the config file by default.
|
||||
|
||||
Returns a tree on success, false on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub __memory_retrieve_source {
|
||||
my $self = shift;
|
||||
my %hash = @_;
|
||||
my $conf = $self->configure_object;
|
||||
|
||||
my $tmpl = {
|
||||
path => { default => $conf->get_conf('base') },
|
||||
verbose => { default => $conf->get_conf('verbose') },
|
||||
uptodate => { default => 0 },
|
||||
};
|
||||
|
||||
my $args = check( $tmpl, \%hash ) or return;
|
||||
|
||||
### check if we can retrieve a frozen data structure with storable ###
|
||||
my $storable = can_load( modules => {'Storable' => '0.0'} )
|
||||
if $conf->get_conf('storable');
|
||||
|
||||
return unless $storable;
|
||||
|
||||
### $stored is the name of the frozen data structure ###
|
||||
my $stored = $self->__memory_storable_file( $args->{path} );
|
||||
|
||||
if ($storable && -e $stored && -s _ && $args->{'uptodate'}) {
|
||||
msg( loc("Retrieving %1", $stored), $args->{'verbose'} );
|
||||
|
||||
my $href = Storable::retrieve($stored);
|
||||
return $href;
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 $cb->__memory_save_source([verbose => BOOL, path => $path])
|
||||
|
||||
This method saves all the parsed trees in I<storable>d format if
|
||||
C<Storable> is available.
|
||||
|
||||
It takes the following arguments:
|
||||
|
||||
=over 4
|
||||
|
||||
=item path
|
||||
|
||||
The absolute path to the directory holding the source files.
|
||||
|
||||
=item verbose
|
||||
|
||||
A boolean flag indicating whether or not to be verbose.
|
||||
|
||||
=back
|
||||
|
||||
Will get information from the config file by default.
|
||||
|
||||
Returns true on success, false on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub __memory_save_source {
|
||||
my $self = shift;
|
||||
my %hash = @_;
|
||||
my $conf = $self->configure_object;
|
||||
|
||||
|
||||
my $tmpl = {
|
||||
path => { default => $conf->get_conf('base'), allow => DIR_EXISTS },
|
||||
verbose => { default => $conf->get_conf('verbose') },
|
||||
force => { default => 1 },
|
||||
};
|
||||
|
||||
my $args = check( $tmpl, \%hash ) or return;
|
||||
|
||||
my $aref = [qw[_mtree _atree]];
|
||||
|
||||
### check if we can retrieve a frozen data structure with storable ###
|
||||
my $storable;
|
||||
$storable = can_load( modules => {'Storable' => '0.0'} )
|
||||
if $conf->get_conf('storable');
|
||||
return unless $storable;
|
||||
|
||||
my $to_write = {};
|
||||
foreach my $key ( @$aref ) {
|
||||
next unless ref( $self->$key );
|
||||
$to_write->{$key} = $self->$key;
|
||||
}
|
||||
|
||||
return unless keys %$to_write;
|
||||
|
||||
### $stored is the name of the frozen data structure ###
|
||||
my $stored = $self->__memory_storable_file( $args->{path} );
|
||||
|
||||
if (-e $stored && not -w $stored) {
|
||||
msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} );
|
||||
return;
|
||||
}
|
||||
|
||||
msg( loc("Writing compiled source information to disk. This might take a little while."),
|
||||
$args->{'verbose'} );
|
||||
|
||||
my $flag;
|
||||
unless( Storable::nstore( $to_write, $stored ) ) {
|
||||
error( loc("could not store %1!", $stored) );
|
||||
$flag++;
|
||||
}
|
||||
|
||||
return $flag ? 0 : 1;
|
||||
}
|
||||
|
||||
sub __memory_storable_file {
|
||||
my $self = shift;
|
||||
my $conf = $self->configure_object;
|
||||
my $path = shift or return;
|
||||
|
||||
### check if we can retrieve a frozen data structure with storable ###
|
||||
my $storable = $conf->get_conf('storable')
|
||||
? can_load( modules => {'Storable' => '0.0'} )
|
||||
: 0;
|
||||
|
||||
return unless $storable;
|
||||
|
||||
### $stored is the name of the frozen data structure ###
|
||||
### changed to use File::Spec->catfile -jmb
|
||||
my $stored = File::Spec->rel2abs(
|
||||
File::Spec->catfile(
|
||||
$path, #base dir
|
||||
$conf->_get_source('stored') #file
|
||||
. '.s' .
|
||||
$Storable::VERSION #the version of storable
|
||||
. '.c' .
|
||||
$self->VERSION #the version of CPANPLUS
|
||||
. STORABLE_EXT #append a suffix
|
||||
)
|
||||
);
|
||||
|
||||
return $stored;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
# Local variables:
|
||||
# c-indentation-style: bsd
|
||||
# c-basic-offset: 4
|
||||
# indent-tabs-mode: nil
|
||||
# End:
|
||||
# vim: expandtab shiftwidth=4:
|
||||
|
||||
1;
|
||||
382
database/perl/vendor/lib/CPANPLUS/Internals/Source/SQLite.pm
vendored
Normal file
382
database/perl/vendor/lib/CPANPLUS/Internals/Source/SQLite.pm
vendored
Normal file
@@ -0,0 +1,382 @@
|
||||
package CPANPLUS::Internals::Source::SQLite;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'CPANPLUS::Internals::Source';
|
||||
|
||||
use CPANPLUS::Error;
|
||||
use CPANPLUS::Internals::Constants;
|
||||
use CPANPLUS::Internals::Source::SQLite::Tie;
|
||||
|
||||
use Data::Dumper;
|
||||
use DBIx::Simple;
|
||||
use DBD::SQLite;
|
||||
|
||||
use Params::Check qw[allow check];
|
||||
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
|
||||
|
||||
use vars qw[$VERSION];
|
||||
$VERSION = "0.9910";
|
||||
|
||||
use constant TXN_COMMIT => 1000;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CPANPLUS::Internals::Source::SQLite - SQLite implementation
|
||||
|
||||
=cut
|
||||
|
||||
{ my $Dbh;
|
||||
my $DbFile;
|
||||
|
||||
sub __sqlite_file {
|
||||
return $DbFile if $DbFile;
|
||||
|
||||
my $self = shift;
|
||||
my $conf = $self->configure_object;
|
||||
|
||||
$DbFile = File::Spec->catdir(
|
||||
$conf->get_conf('base'),
|
||||
SOURCE_SQLITE_DB
|
||||
);
|
||||
|
||||
return $DbFile;
|
||||
};
|
||||
|
||||
sub __sqlite_dbh {
|
||||
return $Dbh if $Dbh;
|
||||
|
||||
my $self = shift;
|
||||
$Dbh = DBIx::Simple->connect(
|
||||
"dbi:SQLite:dbname=" . $self->__sqlite_file,
|
||||
'', '',
|
||||
{ AutoCommit => 1 }
|
||||
);
|
||||
#$Dbh->dbh->trace(1);
|
||||
$Dbh->query(qq{PRAGMA synchronous = OFF});
|
||||
|
||||
return $Dbh;
|
||||
};
|
||||
|
||||
sub __sqlite_disconnect {
|
||||
return unless $Dbh;
|
||||
$Dbh->disconnect;
|
||||
$Dbh = undef;
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
{ my $used_old_copy = 0;
|
||||
|
||||
sub _init_trees {
|
||||
my $self = shift;
|
||||
my $conf = $self->configure_object;
|
||||
my %hash = @_;
|
||||
|
||||
my($path,$uptodate,$verbose,$use_stored);
|
||||
my $tmpl = {
|
||||
path => { default => $conf->get_conf('base'), store => \$path },
|
||||
verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
|
||||
uptodate => { required => 1, store => \$uptodate },
|
||||
use_stored => { default => 1, store => \$use_stored },
|
||||
};
|
||||
|
||||
check( $tmpl, \%hash ) or return;
|
||||
|
||||
### if it's not uptodate, or the file doesn't exist, we need to create
|
||||
### a new sqlite db
|
||||
if( not $uptodate or not -e $self->__sqlite_file ) {
|
||||
$used_old_copy = 0;
|
||||
|
||||
### chuck the file
|
||||
$self->__sqlite_disconnect;
|
||||
1 while unlink $self->__sqlite_file;
|
||||
|
||||
### and create a new one
|
||||
$self->__sqlite_create_db or do {
|
||||
error(loc("Could not create new SQLite DB"));
|
||||
return;
|
||||
}
|
||||
} else {
|
||||
$used_old_copy = 1;
|
||||
}
|
||||
|
||||
### set up the author tree
|
||||
{ my %at;
|
||||
tie %at, 'CPANPLUS::Internals::Source::SQLite::Tie',
|
||||
dbh => $self->__sqlite_dbh, table => 'author',
|
||||
key => 'cpanid', cb => $self;
|
||||
|
||||
$self->_atree( \%at );
|
||||
}
|
||||
|
||||
### set up the author tree
|
||||
{ my %mt;
|
||||
tie %mt, 'CPANPLUS::Internals::Source::SQLite::Tie',
|
||||
dbh => $self->__sqlite_dbh, table => 'module',
|
||||
key => 'module', cb => $self;
|
||||
|
||||
$self->_mtree( \%mt );
|
||||
}
|
||||
|
||||
### start a transaction
|
||||
$self->__sqlite_dbh->query('BEGIN');
|
||||
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub _standard_trees_completed { return $used_old_copy }
|
||||
sub _custom_trees_completed { return }
|
||||
### finish transaction
|
||||
sub _finalize_trees { $_[0]->__sqlite_dbh->commit; return 1 }
|
||||
|
||||
### saves current memory state, but not implemented in sqlite
|
||||
sub _save_state {
|
||||
error(loc("%1 has not implemented writing state to disk", __PACKAGE__));
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
{ my $txn_count = 0;
|
||||
|
||||
### XXX move this outside the sub, so we only compute it once
|
||||
my $class;
|
||||
my @keys = qw[ author cpanid email ];
|
||||
my $tmpl = {
|
||||
class => { default => 'CPANPLUS::Module::Author', store => \$class },
|
||||
map { $_ => { required => 1 } } @keys
|
||||
};
|
||||
|
||||
### dbix::simple's expansion of (??) is REALLY expensive, so do it manually
|
||||
my $ph = join ',', map { '?' } @keys;
|
||||
|
||||
|
||||
sub _add_author_object {
|
||||
my $self = shift;
|
||||
my %hash = @_;
|
||||
my $dbh = $self->__sqlite_dbh;
|
||||
|
||||
my $href = do {
|
||||
local $Params::Check::NO_DUPLICATES = 1;
|
||||
local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
|
||||
check( $tmpl, \%hash ) or return;
|
||||
};
|
||||
|
||||
### keep counting how many we inserted
|
||||
unless( ++$txn_count % TXN_COMMIT ) {
|
||||
#warn "Committing transaction $txn_count";
|
||||
$dbh->commit or error( $dbh->error ); # commit previous transaction
|
||||
$dbh->begin_work or error( $dbh->error ); # and start a new one
|
||||
}
|
||||
|
||||
$dbh->query(
|
||||
"INSERT INTO author (". join(',',keys(%$href)) .") VALUES ($ph)",
|
||||
values %$href
|
||||
) or do {
|
||||
error( $dbh->error );
|
||||
return;
|
||||
};
|
||||
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
{ my $txn_count = 0;
|
||||
|
||||
### XXX move this outside the sub, so we only compute it once
|
||||
my $class;
|
||||
my @keys = qw[ module version path comment author package description dslip mtime ];
|
||||
my $tmpl = {
|
||||
class => { default => 'CPANPLUS::Module', store => \$class },
|
||||
map { $_ => { required => 1 } } @keys
|
||||
};
|
||||
|
||||
### dbix::simple's expansion of (??) is REALLY expensive, so do it manually
|
||||
my $ph = join ',', map { '?' } @keys;
|
||||
|
||||
sub _add_module_object {
|
||||
my $self = shift;
|
||||
my %hash = @_;
|
||||
my $dbh = $self->__sqlite_dbh;
|
||||
|
||||
my $href = do {
|
||||
local $Params::Check::NO_DUPLICATES = 1;
|
||||
local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
|
||||
check( $tmpl, \%hash ) or return;
|
||||
};
|
||||
|
||||
### fix up author to be 'plain' string
|
||||
$href->{'author'} = $href->{'author'}->cpanid;
|
||||
|
||||
### keep counting how many we inserted
|
||||
unless( ++$txn_count % TXN_COMMIT ) {
|
||||
#warn "Committing transaction $txn_count";
|
||||
$dbh->commit or error( $dbh->error ); # commit previous transaction
|
||||
$dbh->begin_work or error( $dbh->error ); # and start a new one
|
||||
}
|
||||
|
||||
$dbh->query(
|
||||
"INSERT INTO module (". join(',',keys(%$href)) .") VALUES ($ph)",
|
||||
values %$href
|
||||
) or do {
|
||||
error( $dbh->error );
|
||||
return;
|
||||
};
|
||||
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
{ my %map = (
|
||||
_source_search_module_tree
|
||||
=> [ module => module => 'CPANPLUS::Module' ],
|
||||
_source_search_author_tree
|
||||
=> [ author => cpanid => 'CPANPLUS::Module::Author' ],
|
||||
);
|
||||
|
||||
while( my($sub, $aref) = each %map ) {
|
||||
no strict 'refs';
|
||||
|
||||
my($table, $key, $class) = @$aref;
|
||||
*$sub = sub {
|
||||
my $self = shift;
|
||||
my %hash = @_;
|
||||
|
||||
my($list,$type);
|
||||
my $tmpl = {
|
||||
allow => { required => 1, default => [ ], strict_type => 1,
|
||||
store => \$list },
|
||||
type => { required => 1, allow => [$class->accessors()],
|
||||
store => \$type },
|
||||
};
|
||||
|
||||
check( $tmpl, \%hash ) or return;
|
||||
|
||||
|
||||
### we aliased 'module' to 'name', so change that here too
|
||||
$type = 'module' if $type eq 'name';
|
||||
|
||||
my $meth = $table .'_tree';
|
||||
|
||||
{
|
||||
my $throw = $self->$meth;
|
||||
}
|
||||
|
||||
my $dbh = $self->__sqlite_dbh;
|
||||
my $res = $dbh->query( "SELECT * from $table" );
|
||||
|
||||
my @rv = map { $self->$meth( $_->{$key} ) }
|
||||
grep { allow( $_->{$type} => $list ) } $res->hashes;
|
||||
|
||||
return @rv;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub __sqlite_create_db {
|
||||
my $self = shift;
|
||||
my $dbh = $self->__sqlite_dbh;
|
||||
|
||||
### we can ignore the result/error; not all sqlite implementations
|
||||
### support this
|
||||
$dbh->query( qq[
|
||||
DROP TABLE IF EXISTS author;
|
||||
\n]
|
||||
) or do {
|
||||
msg( $dbh->error );
|
||||
};
|
||||
$dbh->query( qq[
|
||||
DROP TABLE IF EXISTS module;
|
||||
\n]
|
||||
) or do {
|
||||
msg( $dbh->error );
|
||||
};
|
||||
|
||||
|
||||
|
||||
$dbh->query( qq[
|
||||
/* the author information */
|
||||
CREATE TABLE author (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
|
||||
author varchar(255),
|
||||
email varchar(255),
|
||||
cpanid varchar(255)
|
||||
);
|
||||
\n]
|
||||
|
||||
) or do {
|
||||
error( $dbh->error );
|
||||
return;
|
||||
};
|
||||
|
||||
$dbh->query( qq[
|
||||
/* the module information */
|
||||
CREATE TABLE module (
|
||||
id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
|
||||
module varchar(255),
|
||||
version varchar(255),
|
||||
path varchar(255),
|
||||
comment varchar(255),
|
||||
author varchar(255),
|
||||
package varchar(255),
|
||||
description varchar(255),
|
||||
dslip varchar(255),
|
||||
mtime varchar(255)
|
||||
);
|
||||
|
||||
\n]
|
||||
|
||||
) or do {
|
||||
error( $dbh->error );
|
||||
return;
|
||||
};
|
||||
|
||||
$dbh->query( qq[
|
||||
/* the module index */
|
||||
CREATE INDEX IX_module_module ON module (
|
||||
module
|
||||
);
|
||||
|
||||
\n]
|
||||
|
||||
) or do {
|
||||
error( $dbh->error );
|
||||
return;
|
||||
};
|
||||
|
||||
$dbh->query( qq[
|
||||
/* the version index */
|
||||
CREATE INDEX IX_module_version ON module (
|
||||
version
|
||||
);
|
||||
|
||||
\n]
|
||||
|
||||
) or do {
|
||||
error( $dbh->error );
|
||||
return;
|
||||
};
|
||||
|
||||
$dbh->query( qq[
|
||||
/* the module-version index */
|
||||
CREATE INDEX IX_module_module_version ON module (
|
||||
module, version
|
||||
);
|
||||
|
||||
\n]
|
||||
|
||||
) or do {
|
||||
error( $dbh->error );
|
||||
return;
|
||||
};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
142
database/perl/vendor/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm
vendored
Normal file
142
database/perl/vendor/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm
vendored
Normal file
@@ -0,0 +1,142 @@
|
||||
package CPANPLUS::Internals::Source::SQLite::Tie;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use CPANPLUS::Error;
|
||||
use CPANPLUS::Module;
|
||||
use CPANPLUS::Module::Fake;
|
||||
use CPANPLUS::Module::Author::Fake;
|
||||
use CPANPLUS::Internals::Constants;
|
||||
|
||||
use Params::Check qw[check];
|
||||
use Module::Load::Conditional qw[can_load];
|
||||
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
|
||||
|
||||
use vars qw[@ISA $VERSION];
|
||||
$VERSION = "0.9910";
|
||||
|
||||
require Tie::Hash;
|
||||
push @ISA, 'Tie::StdHash';
|
||||
|
||||
|
||||
sub TIEHASH {
|
||||
my $class = shift;
|
||||
my %hash = @_;
|
||||
|
||||
my $tmpl = {
|
||||
dbh => { required => 1 },
|
||||
table => { required => 1 },
|
||||
key => { required => 1 },
|
||||
cb => { required => 1 },
|
||||
offset => { default => 0 },
|
||||
};
|
||||
|
||||
my $args = check( $tmpl, \%hash ) or return;
|
||||
my $obj = bless { %$args, store => {} } , $class;
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my $self = shift;
|
||||
my $key = shift or return;
|
||||
my $dbh = $self->{dbh};
|
||||
my $cb = $self->{cb};
|
||||
my $table = $self->{table};
|
||||
|
||||
|
||||
### did we look this one up before?
|
||||
if( my $obj = $self->{store}->{$key} ) {
|
||||
return $obj;
|
||||
}
|
||||
|
||||
my $res = $dbh->query(
|
||||
"SELECT * from $table where $self->{key} = ?", $key
|
||||
) or do {
|
||||
error( $dbh->error );
|
||||
return;
|
||||
};
|
||||
|
||||
my $href = $res->hash;
|
||||
|
||||
### get rid of the primary key
|
||||
delete $href->{'id'};
|
||||
|
||||
### no results?
|
||||
return unless keys %$href;
|
||||
|
||||
### expand author if needed
|
||||
### XXX no longer generic :(
|
||||
if( $table eq 'module' ) {
|
||||
$href->{author} = $cb->author_tree( $href->{author } ) or return;
|
||||
}
|
||||
|
||||
my $class = {
|
||||
module => 'CPANPLUS::Module',
|
||||
author => 'CPANPLUS::Module::Author',
|
||||
}->{ $table };
|
||||
|
||||
my $obj = $self->{store}->{$key} = $class->new( %$href, _id => $cb->_id );
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
my $val = shift;
|
||||
|
||||
$self->{store}->{$key} = $val;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
sub FIRSTKEY {
|
||||
my $self = shift;
|
||||
my $dbh = $self->{'dbh'};
|
||||
|
||||
my $res = $dbh->query(
|
||||
"select $self->{key} from $self->{table} order by $self->{key} limit 1"
|
||||
);
|
||||
|
||||
$self->{offset} = 0;
|
||||
|
||||
my $key = $res->flat->[0];
|
||||
|
||||
return $key;
|
||||
}
|
||||
|
||||
sub NEXTKEY {
|
||||
my $self = shift;
|
||||
my $dbh = $self->{'dbh'};
|
||||
|
||||
my $res = $dbh->query(
|
||||
"select $self->{key} from $self->{table} ".
|
||||
"order by $self->{key} limit 1 offset $self->{offset}"
|
||||
);
|
||||
|
||||
$self->{offset} +=1;
|
||||
|
||||
my $key = $res->flat->[0];
|
||||
my $val = $self->FETCH( $key );
|
||||
|
||||
### use each() semantics
|
||||
return wantarray ? ( $key, $val ) : $key;
|
||||
}
|
||||
|
||||
sub EXISTS { !!$_[0]->FETCH( $_[1] ) }
|
||||
|
||||
sub SCALAR {
|
||||
my $self = shift;
|
||||
my $dbh = $self->{'dbh'};
|
||||
|
||||
my $res = $dbh->query( "select count(*) from $self->{table}" );
|
||||
|
||||
return $res->flat;
|
||||
}
|
||||
|
||||
### intentionally left blank
|
||||
sub DELETE { }
|
||||
sub CLEAR { }
|
||||
|
||||
763
database/perl/vendor/lib/CPANPLUS/Internals/Utils.pm
vendored
Normal file
763
database/perl/vendor/lib/CPANPLUS/Internals/Utils.pm
vendored
Normal file
@@ -0,0 +1,763 @@
|
||||
package CPANPLUS::Internals::Utils;
|
||||
|
||||
use strict;
|
||||
|
||||
use CPANPLUS::Error;
|
||||
use CPANPLUS::Internals::Constants;
|
||||
|
||||
use Cwd qw[chdir cwd];
|
||||
use File::Copy;
|
||||
use Params::Check qw[check];
|
||||
use Module::Load::Conditional qw[can_load];
|
||||
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
|
||||
use version;
|
||||
|
||||
use vars qw[$VERSION];
|
||||
$VERSION = "0.9910";
|
||||
|
||||
local $Params::Check::VERBOSE = 1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CPANPLUS::Internals::Utils - convenience functions for CPANPLUS
|
||||
|
||||
=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;
|
||||
|
||||
$version =~ s!_!!g; # *sigh*
|
||||
return $version if $version =~ /^\d*(?:\.\d+)?$/;
|
||||
if ( my ($vers) = $version =~ /^(v?\d+(?:\.\d+(?:\.\d+)?)?)/ ) {
|
||||
return eval { version->parse($vers)->numify };
|
||||
}
|
||||
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
|
||||
|
||||
=head2 $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
|
||||
|
||||
=head2 $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 => 'localhost', store => \$host },
|
||||
path => { default => '', store => \$path },
|
||||
};
|
||||
|
||||
check( $tmpl, \%hash ) or return;
|
||||
|
||||
### it's an URI, so unixify the path.
|
||||
### VMS has a special method for just that
|
||||
$path = ON_VMS
|
||||
? VMS::Filespec::unixify($path)
|
||||
: File::Spec::Unix->catdir( File::Spec->splitdir( $path ) );
|
||||
|
||||
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) = @_;
|
||||
|
||||
$x = $self->_version_to_number(version => $x);
|
||||
$y = $self->_version_to_number(version => $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 {
|
||||
|
||||
if ( can_load( modules => { 'File::HomeDir' => 0.0 } ) ) {
|
||||
if ( defined $ENV{APPDATA} && length $ENV{APPDATA} && !ON_WIN32 ) {
|
||||
msg("'APPDATA' env var is set and not on MSWin32, " .
|
||||
"please use 'PERL5_CPANPLUS_HOME' instead to change .cpanplus location", 1 );
|
||||
}
|
||||
return File::HomeDir->my_home if -d File::HomeDir->my_home;
|
||||
}
|
||||
|
||||
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 and VMS.
|
||||
|
||||
Only cleans up the path on Win32 if the path exists.
|
||||
|
||||
On VMS, it encodes dots to _ using C<VMS::Filespec::vmsify>
|
||||
|
||||
=cut
|
||||
|
||||
sub _safe_path {
|
||||
my $self = shift;
|
||||
|
||||
my %hash = @_;
|
||||
|
||||
my $path;
|
||||
my $tmpl = {
|
||||
path => { required => 1, store => \$path },
|
||||
};
|
||||
|
||||
check( $tmpl, \%hash ) or return;
|
||||
|
||||
if( ON_WIN32 ) {
|
||||
### only need to fix it up if there's spaces in the path
|
||||
return $path unless $path =~ /\s+/;
|
||||
|
||||
### clean up paths if we are on win32
|
||||
return Win32::GetShortPathName( $path ) || $path;
|
||||
|
||||
} elsif ( ON_VMS ) {
|
||||
### XXX According to John Malmberg, there's an VMS issue:
|
||||
### catdir on VMS can not currently deal with directory components
|
||||
### with dots in them.
|
||||
### Fixing this is a three step procedure, which will work for
|
||||
### VMS in its traditional ODS-2 mode, and it will also work if
|
||||
### VMS is in the ODS-5 mode that is being implemented.
|
||||
### If the path is already in VMS syntax, assume that we are done.
|
||||
|
||||
### VMS format is a path with a trailing ']' or ':'
|
||||
return $path if $path =~ /\:|\]$/;
|
||||
|
||||
### 1. Make sure that the value to be converted, $path is
|
||||
### in UNIX directory syntax by appending a '/' to it.
|
||||
$path .= '/' unless $path =~ m|/$|;
|
||||
|
||||
### 2. Use VMS::Filespec::vmsify($path . '/') to convert the dots to
|
||||
### underscores if needed. The trailing '/' is needed as so that
|
||||
### C<vmsify> knows that it should use directory translation instead of
|
||||
### filename translation, as filename translation leaves one dot.
|
||||
$path = VMS::Filespec::vmsify( $path );
|
||||
|
||||
### 3. Use $path = File::Spec->splitdir( VMS::Filespec::vmsify(
|
||||
### $path . '/') to remove the directory delimiters.
|
||||
|
||||
### From John Malmberg:
|
||||
### File::Spec->catdir will put the path back together.
|
||||
### The '/' trick only works if the string is a directory name
|
||||
### with UNIX style directory delimiters or no directory delimiters.
|
||||
### It is to force vmsify to treat the input specification as UNIX.
|
||||
###
|
||||
### There is a VMS::Filespec::unixpath() to do the appending of the '/'
|
||||
### to the specification, which will do a VMS::Filespec::vmsify()
|
||||
### if needed.
|
||||
### However it is not a good idea to call vmsify() on a pathname
|
||||
### returned by unixify(), and it is not a good idea to call unixify()
|
||||
### on a pathname returned by vmsify(). Because of the nature of the
|
||||
### conversion, not all file specifications can make the round trip.
|
||||
###
|
||||
### I think that directory specifications can safely make the round
|
||||
### trip, but not ones containing filenames.
|
||||
$path = File::Spec->catdir( File::Spec->splitdir( $path ) )
|
||||
}
|
||||
|
||||
return $path;
|
||||
}
|
||||
|
||||
|
||||
=head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING );
|
||||
|
||||
Splits the name of a CPAN package string up into its package, version
|
||||
and extension parts.
|
||||
|
||||
For example, C<Foo-Bar-1.2.tar.gz> would return the following parts:
|
||||
|
||||
Package: Foo-Bar
|
||||
Version: 1.2
|
||||
Extension: tar.gz
|
||||
|
||||
=cut
|
||||
|
||||
sub _distname_info {
|
||||
my $file = shift or return;
|
||||
|
||||
my ($dist, $version) = $file =~ /^
|
||||
((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))*
|
||||
(?:
|
||||
[A-Za-z](?=[^A-Za-z]|$)
|
||||
|
|
||||
\d(?=-)
|
||||
)(?<![._-][vV])
|
||||
)+)(.*)
|
||||
$/xs or return ($file,undef,undef);
|
||||
|
||||
if ($dist =~ /-undef\z/ and ! length $version) {
|
||||
$dist =~ s/-undef\z//;
|
||||
}
|
||||
|
||||
# Remove potential -withoutworldwriteables suffix
|
||||
$version =~ s/-withoutworldwriteables$//;
|
||||
|
||||
if ($version =~ /^(-[Vv].*)-(\d.*)/) {
|
||||
|
||||
# Catch names like Unicode-Collate-Standard-V3_1_1-0.1
|
||||
# where the V3_1_1 is part of the distname
|
||||
$dist .= $1;
|
||||
$version = $2;
|
||||
}
|
||||
|
||||
if ($version =~ /(.+_.*)-(\d.*)/) {
|
||||
# Catch names like Task-Deprecations5_14-1.00.tar.gz where the 5_14 is
|
||||
# part of the distname. However, names like libao-perl_0.03-1.tar.gz
|
||||
# should still have 0.03-1 as their version.
|
||||
$dist .= $1;
|
||||
$version = $2;
|
||||
}
|
||||
|
||||
# Normalize the Dist.pm-1.23 convention which CGI.pm and
|
||||
# a few others use.
|
||||
$dist =~ s{\.pm$}{};
|
||||
|
||||
$version = $1
|
||||
if !length $version and $dist =~ s/-(\d+\w)$//;
|
||||
|
||||
$version = $1 . $version
|
||||
if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;
|
||||
|
||||
if ($version =~ /\d\.\d/) {
|
||||
$version =~ s/^[-_.]+//;
|
||||
}
|
||||
else {
|
||||
$version =~ s/^[-_]+//;
|
||||
}
|
||||
|
||||
my $dev;
|
||||
if (length $version) {
|
||||
if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) {
|
||||
$dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3;
|
||||
}
|
||||
elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) {
|
||||
$dev = 1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$version = undef;
|
||||
}
|
||||
|
||||
($dist, $version, $dev);
|
||||
}
|
||||
|
||||
{ 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
|
||||
(?: # however, some start with a . only :(
|
||||
[-._] # 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/
|
||||
^
|
||||
( # the whole thing
|
||||
($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/
|
||||
^
|
||||
( # the whole thing
|
||||
($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;
|
||||
|
||||
my ($dpkg,$dver);
|
||||
{
|
||||
my ($base,$ext);
|
||||
if ( $str =~ m,([^/]+)\.(tar\.(?:[gx]?z|bz2)|zip|tbz|tgz|txz)$,i ) {
|
||||
$base = $1;
|
||||
$ext = $2;
|
||||
}
|
||||
else {
|
||||
$base = $str;
|
||||
}
|
||||
($dpkg,$dver) = _distname_info($base);
|
||||
}
|
||||
|
||||
### 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 $full = $1 || '';
|
||||
my $pkg = $2 || '';
|
||||
my $ver = $3 || '';
|
||||
my $ext = $4 || '';
|
||||
|
||||
### 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;
|
||||
|
||||
$pkg = $dpkg if $dpkg && $pkg ne $dpkg;
|
||||
$ver = $dver if $dver && $ver ne $dver;
|
||||
|
||||
return ($pkg, $ver, $ext, $full );
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
{ my %escapes = map {
|
||||
chr($_) => sprintf("%%%02X", $_)
|
||||
} 0 .. 255;
|
||||
|
||||
sub _uri_encode {
|
||||
my $self = shift;
|
||||
my %hash = @_;
|
||||
|
||||
my $str;
|
||||
my $tmpl = {
|
||||
uri => { store => \$str, required => 1 }
|
||||
};
|
||||
|
||||
check( $tmpl, \%hash ) or return;
|
||||
|
||||
### XXX taken straight from URI::Encode
|
||||
### Default unsafe characters. RFC 2732 ^(uric - reserved)
|
||||
$str =~ s|([^A-Za-z0-9\-_.!~*'()])|$escapes{$1}|g;
|
||||
|
||||
return $str;
|
||||
}
|
||||
|
||||
|
||||
sub _uri_decode {
|
||||
my $self = shift;
|
||||
my %hash = @_;
|
||||
|
||||
my $str;
|
||||
my $tmpl = {
|
||||
uri => { store => \$str, required => 1 }
|
||||
};
|
||||
|
||||
check( $tmpl, \%hash ) or return;
|
||||
|
||||
### XXX use unencode routine in utils?
|
||||
$str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
|
||||
|
||||
return $str;
|
||||
}
|
||||
}
|
||||
|
||||
sub _update_timestamp {
|
||||
my $self = shift;
|
||||
my %hash = @_;
|
||||
|
||||
my $file;
|
||||
my $tmpl = {
|
||||
file => { required => 1, store => \$file, allow => FILE_EXISTS }
|
||||
};
|
||||
|
||||
check( $tmpl, \%hash ) or return;
|
||||
|
||||
### `touch` the file, so windoze knows it's new -jmb
|
||||
### works on *nix too, good fix -Kane
|
||||
### make sure it is writable first, otherwise the `touch` will fail
|
||||
|
||||
my $now = time;
|
||||
unless( chmod( 0644, $file) && utime ($now, $now, $file) ) {
|
||||
error( loc("Couldn't touch %1", $file) );
|
||||
return;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
# Local variables:
|
||||
# c-indentation-style: bsd
|
||||
# c-basic-offset: 4
|
||||
# indent-tabs-mode: nil
|
||||
# End:
|
||||
# vim: expandtab shiftwidth=4:
|
||||
8
database/perl/vendor/lib/CPANPLUS/Internals/Utils/Autoflush.pm
vendored
Normal file
8
database/perl/vendor/lib/CPANPLUS/Internals/Utils/Autoflush.pm
vendored
Normal file
@@ -0,0 +1,8 @@
|
||||
package CPANPLUS::Internals::Utils::Autoflush;
|
||||
|
||||
use vars qw[$VERSION];
|
||||
$VERSION = "0.9910";
|
||||
|
||||
BEGIN { my $old = select STDERR; $|++; select $old; $|++; };
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user