diff options
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals')
12 files changed, 5430 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Constants.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Constants.pm new file mode 100755 index 00000000000..1a38200dfb7 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Constants.pm @@ -0,0 +1,375 @@ +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; + +@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 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 BLIB => sub { return @_ + ? File::Spec->catfile(@_, 'blib') + : 'blib'; + }; + +use constant LIB => 'lib'; +use constant LIB_DIR => sub { return @_ + ? File::Spec->catdir(@_, LIB) + : LIB; + }; +use constant AUTO => 'auto'; +use constant LIB_AUTO_DIR => sub { return @_ + ? File::Spec->catdir(@_, LIB, AUTO) + : File::Spec->catdir(LIB, AUTO) + }; +use constant ARCH => 'arch'; +use constant ARCH_DIR => sub { return @_ + ? File::Spec->catdir(@_, ARCH) + : ARCH; + }; +use constant ARCH_AUTO_DIR => sub { return @_ + ? File::Spec->catdir(@_,ARCH,AUTO) + : File::Spec->catdir(ARCH,AUTO) + }; + +use constant BLIB_LIBDIR => sub { return @_ + ? File::Spec->catdir( + @_, BLIB->(), LIB ) + : File::Spec->catdir( BLIB->(), LIB ); + }; + +use constant CONFIG_USER_LIB_DIR => sub { + require CPANPLUS::Internals::Utils; + LIB_DIR->( + CPANPLUS::Internals::Utils->_home_dir, + DOT_CPANPLUS + ); + }; +use constant CONFIG_USER_FILE => sub { + File::Spec->catfile( + CONFIG_USER_LIB_DIR->(), + split('::', CONFIG_USER), + ) . '.pm'; + }; +use constant CONFIG_SYSTEM_FILE => sub { + require CPANPLUS::Internals; + require File::Basename; + my $dir = File::Basename::dirname( + $INC{'CPANPLUS/Internals.pm'} + ); + + ### XXX use constants + File::Spec->catfile( + $dir, qw[Config System.pm] + ); + }; + +use constant README => sub { my $obj = $_[0]; + my $pkg = $obj->package_name; + $pkg .= '-' . $obj->package_version . + '.readme'; + return $pkg; + }; +use constant 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 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: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Constants/Report.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Constants/Report.pm new file mode 100755 index 00000000000..59a41a6083b --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Constants/Report.pm @@ -0,0 +1,407 @@ +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 = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION; +@ISA = qw[Exporter]; +@EXPORT = Package::Constants->list( __PACKAGE__ ); + + +### OS to regex map ### +my %OS = ( + Amiga => 'amigaos', + Atari => 'mint', + BSD => 'bsdos|darwin|freebsd|openbsd|netbsd', + Be => 'beos', + BeOS => 'beos', + Cygwin => 'cygwin', + Darwin => 'darwin', + EBCDIC => 'os390|os400|posix-bc|vmesa', + HPUX => 'hpux', + Linux => 'linux', + MSDOS => 'dos|os2|MSWin32|cygwin', + 'bin\\d*Mac'=> 'MacOS|darwin', # binMac, bin56Mac, bin58Mac... + Mac => 'MacOS|darwin', + MacPerl => 'MacOS', + MacOS => 'MacOS|darwin', + MacOSX => 'darwin', + MPE => 'mpeix', + MPEiX => 'mpeix', + OS2 => 'os2', + Plan9 => 'plan9', + RISCOS => 'riscos', + SGI => 'irix', + Solaris => 'solaris', + Unix => 'aix|bsdos|darwin|dgux|dynixptx|freebsd|'. + 'linux|hpux|machten|netbsd|next|openbsd|dec_osf|'. + 'svr4|sco_sv|unicos|unicosmk|solaris|sunos', + VMS => 'VMS', + VOS => 'VOS', + Win32 => 'MSWin32|cygwin', + Win32API => 'MSWin32|cygwin', +); + +use constant GRADE_FAIL => 'fail'; +use constant GRADE_PASS => 'pass'; +use constant GRADE_NA => 'na'; +use constant GRADE_UNKNOWN => 'unknown'; + +use constant MAX_REPORT_SEND + => 2; + +use constant CPAN_TESTERS_EMAIL + => 'cpan-testers@perl.org'; + +### the cpan mail account for this user ### +use constant CPAN_MAIL_ACCOUNT + => sub { + my $username = shift or return; + return $username . '@cpan.org'; + }; + +### check if this module is platform specific and if we're on that +### specific platform. Alternately, the module is not platform specific +### and we're always OK to send out test results. +use constant RELEVANT_TEST_RESULT + => sub { + my $mod = shift or return; + my $name = $mod->module; + my $specific; + for my $platform (keys %OS) { + if( $name =~ /\b$platform\b/i ) { + # beware the Mac != MAC + next if($platform eq 'Mac' && + $name !~ /\b$platform\b/); + $specific++; + return 1 if + $^O =~ /^(?:$OS{$platform})$/ + } + }; + return $specific ? 0 : 1; + }; + +use constant UNSUPPORTED_OS + => sub { + my $buffer = shift or return; + if( $buffer =~ + /No support for OS|OS unsupported/im ) { + return 1; + } + return 0; + }; + +use constant PERL_VERSION_TOO_LOW + => sub { + my $buffer = shift or return; + # ExtUtils::MakeMaker format + if( $buffer =~ + /Perl .*? required--this is only .*?/m ) { + return 1; + } + # Module::Build format + if( $buffer =~ + /ERROR:( perl:)? Version .*?( of perl)? is installed, but we need version >= .*?/m ) { + return 1; + } + return 0; + }; + +use constant NO_TESTS_DEFINED + => sub { + my $buffer = shift or return; + if( $buffer =~ + /(No tests defined( for [\w:]+ extension)?\.)/ + and $buffer !~ /\*\.t/m and + $buffer !~ /test\.pl/m + ) { + return $1 + } + + return; + }; + +### what stage did the test fail? ### +use constant TEST_FAIL_STAGE + => sub { + my $buffer = shift or return; + return $buffer =~ /(MAKE [A-Z]+).*/ + ? lc $1 : + 'fetch'; + }; + + +use constant MISSING_PREREQS_LIST + => sub { + my $buffer = shift; + my $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_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 cant be found in teh list + ### as reported in #12723 + my @prq = grep { defined } + map { $cb->module_tree($_) } + sort keys %$prq; + + ### no prereqs? + return '' unless @prq; + + ### some apparently, list what we loaded + my $str = << "."; +PREREQUISITES: + +Here is a list of prerequisites you specified and versions we +managed to load: + +. + $str .= join '', + map { 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 + Test::Harness + Test::More + 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: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Extract.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Extract.pm new file mode 100755 index 00000000000..84a48a50dea --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Extract.pm @@ -0,0 +1,243 @@ +package CPANPLUS::Internals::Extract; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use File::Spec (); +use File::Basename (); +use Archive::Extract; +use IPC::Cmd qw[run]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Extract + +=head1 SYNOPSIS + + ### for source files ### + $self->_gunzip( file => 'foo.gz', output => 'blah.txt' ); + + ### for modules/packages ### + $dir = $self->_extract( module => $modobj, + extractdir => '/some/where' ); + +=head1 DESCRIPTION + +CPANPLUS::Internals::Extract extracts compressed files for CPANPLUS. +It can do this by either a pure perl solution (preferred) with the +use of C<Archive::Tar> and C<Compress::Zlib>, or with binaries, like +C<gzip> and C<tar>. + +The flow looks like this: + + $cb->_extract + Delegate to Archive::Extract + +=head1 METHODS + +=head2 $dir = _extract( module => $modobj, [perl => '/path/to/perl', extractdir => '/path/to/extract/to', prefer_bin => BOOL, verbose => BOOL, force => BOOL] ) + +C<_extract> will take a module object and extract it to C<extractdir> +if provided, or the default location which is obtained from your +config. + +The file name is obtained by looking at C<< $modobj->status->fetch >> +and will be parsed to see if it's a tar or zip archive. + +If it's a zip archive, C<__unzip> will be called, otherwise C<__untar> +will be called. In the unlikely event the file is of neither format, +an error will be thrown. + +C<_extract> takes the following options: + +=over 4 + +=item module + +A C<CPANPLUS::Module> object. This is required. + +=item extractdir + +The directory to extract the archive to. By default this looks +something like: + /CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME + +=item prefer_bin + +A flag indicating whether you prefer a pure perl solution, ie +C<Archive::Tar> or C<Archive::Zip> respectively, or a binary solution +like C<unzip> and C<tar>. + +=item perl + +The path to the perl executable to use for any perl calls. Also used +to determine the build version directory for extraction. + +=item verbose + +Specifies whether to be verbose or not. Defaults to your corresponding +config entry. + +=item force + +Specifies whether to force the extraction or not. Defaults to your +corresponding config entry. + +=back + +All other options are passed on verbatim to C<__unzip> or C<__untar>. + +Returns the directory the file was extracted to on success and false +on failure. + +=cut + +sub _extract { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + local $Params::Check::ALLOW_UNKNOWN = 1; + + my( $mod, $verbose, $force ); + my $tmpl = { + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + prefer_bin => { default => $conf->get_conf('prefer_bin') }, + extractdir => { default => $conf->get_conf('extractdir') }, + module => { required => 1, allow => IS_MODOBJ, store => \$mod }, + perl => { default => $^X }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### did we already extract it ? ### + my $loc = $mod->status->extract(); + + if( $loc && !$force ) { + msg(loc("Already extracted '%1' to '%2'. ". + "Won't extract again without force", + $mod->module, $loc), $verbose); + return $loc; + } + + ### did we already fetch the file? ### + my $file = $mod->status->fetch(); + unless( -s $file ) { + error( loc( "File '%1' has zero size: cannot extract", $file ) ); + return; + } + + ### the dir to extract to ### + my $to = $args->{'extractdir'} || + File::Spec->catdir( + $conf->get_conf('base'), + $self->_perl_version( perl => $args->{'perl'} ), + $conf->_get_build('moddir'), + ); + + ### delegate to Archive::Extract ### + ### set up some flags for archive::extract ### + local $Archive::Extract::PREFER_BIN = $args->{'prefer_bin'}; + local $Archive::Extract::DEBUG = $conf->get_conf('debug'); + local $Archive::Extract::WARN = $verbose; + + my $ae = Archive::Extract->new( archive => $file ); + + unless( $ae->extract( to => $to ) ) { + error( loc( "Unable to extract '%1' to '%2': %3", + $file, $to, $ae->error ) ); + return; + } + + ### if ->files is not filled, we dont know what the hell was + ### extracted.. try to offer a suggestion and bail :( + unless ( $ae->files ) { + error( loc( "'%1' was not able to determine extracted ". + "files from the archive. Instal '%2' and ensure ". + "it works properly and try again", + $ae->is_zip ? 'Archive::Zip' : 'Archive::Tar' ) ); + return; + } + + + ### print out what files we extracted ### + msg(loc("Extracted '%1'",$_),$verbose) for @{$ae->files}; + + ### set them all to be +w for the owner, so we don't get permission + ### denied for overwriting files that are just +r + + ### this is to rigurous -- just change to +w for the owner [cpan #13358] + #chmod 0755, map { File::Spec->rel2abs( File::Spec->catdir($to, $_) ) } + # @{$ae->files}; + + for my $file ( @{$ae->files} ) { + my $path = File::Spec->rel2abs( File::Spec->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: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Fetch.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Fetch.pm new file mode 100755 index 00000000000..395965bab60 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Fetch.pm @@ -0,0 +1,473 @@ +package CPANPLUS::Internals::Fetch; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use File::Fetch; +use File::Spec; +use Cwd qw[cwd]; +use IPC::Cmd qw[run]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Fetch + +=head1 SYNOPSIS + + my $output = $cb->_fetch( + module => $modobj, + fetchdir => '/path/to/save/to', + verbose => BOOL, + force => BOOL, + ); + + $cb->_add_fail_host( host => 'foo.com' ); + $cb->_host_ok( host => 'foo.com' ); + + +=head1 DESCRIPTION + +CPANPLUS::Internals::Fetch fetches files from either ftp, http, file +or rsync mirrors. + +This is the rough flow: + + $cb->_fetch + Delegate to File::Fetch; + + +=head1 METHODS + +=cut + +=head1 $path = _fetch( module => $modobj, [fetchdir => '/path/to/save/to', fetch_from => 'scheme://path/to/fetch/from', verbose => BOOL, force => BOOL, prefer_bin => BOOL, 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 downlaod to ### + { + $local_path = $args->{fetchdir} || + File::Spec->catdir( + $conf->get_conf('base'), + $modobj->path, + ); + + ### create the path if it doesn't exist ### + unless( -d $local_path ) { + unless( $self->_mkdir( dir => $local_path ) ) { + msg( loc("Could not create path '%1'", $local_path), $verbose); + return; + } + } + + $local_file = File::Spec->rel2abs( + File::Spec->catfile( + $local_path, + $modobj->package, + ) + ); + + ### do we already have the file? if 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 doesnt 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 dont 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: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Report.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Report.pm new file mode 100755 index 00000000000..774c6b91a02 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Report.pm @@ -0,0 +1,645 @@ +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'; + +$Params::Check::VERBOSE = 1; + +### for the version ### +require CPANPLUS::Internals; + +=head1 NAME + +CPANPLUS::Internals::Report + +=head1 SYNOPSIS + + ### enable test reporting + $cb->configure_object->set_conf( cpantest => 1 ); + + ### set custom mx host, shouldn't normally be needed + $cb->configure_object->set_conf( cpantest_mx => 'smtp.example.com' ); + +=head1 DESCRIPTION + +This module provides all the functionality to send test reports to +C<http://testers.cpan.org> using the C<Test::Reporter> module. + +All methods will be called automatically if you have C<CPANPLUS> +configured to enable test reporting (see the C<SYNOPSIS>). + +=head1 METHODS + +=head2 $bool = $cb->_have_query_report_modules + +This function checks if all the required modules are here for querying +reports. It returns true and loads them if they are, or returns false +otherwise. + +=head2 $bool = $cb->_have_send_report_modules + +This function checks if all the required modules are here for sending +reports. It returns true and loads them if they are, or returns false +otherwise. + +=cut + +### 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.34', + }; + + 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 ); + my $tmpl = { + module => { required => 1, store => \$mod, allow => IS_MODOBJ }, + buffer => { required => 1, store => \$buffer }, + failed => { required => 1, store => \$failed }, + address => { default => CPAN_TESTERS_EMAIL, store => \$address }, + save => { default => 0, store => \$save }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + force => { default => $conf->get_conf('force'), + store => \$force }, + tests_skipped + => { default => 0, store => \$tests_skipped }, + }; + + check( $tmpl, \%hash ) or return; + + ### get the data to fill the email with ### + my $name = $mod->module; + my $dist = $mod->package_name . '-' . $mod->package_version; + my $author = $mod->author->author; + my $email = $mod->author->email || CPAN_MAIL_ACCOUNT->( $author ); + my $cp_conf = $conf->get_conf('cpantest') || ''; + my $int_ver = $CPANPLUS::Internals::VERSION; + my $cb = $mod->parent; + + + ### 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 insted + GRADE: { if ( $failed ) { + + + ### XXX duplicated logic between this block + ### and REPORTED_LOADED_PREREQS :( + + ### figure out if the prereqs are on CPAN at all + ### -- if not, send NA grade + ### Also, if our version of prereqs is too low, + ### -- send NA grade. + ### This is to address bug: #25327: do not count + ### as FAIL modules where prereqs are not filled + { my $prq = $mod->status->prereqs || {}; + + while( my($prq_name,$prq_ver) = each %$prq ) { + my $obj = $cb->module_tree( $prq_name ); + 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 !$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 dont have a high enough perl version? + } elsif ( PERL_VERSION_TOO_LOW->( $buffer ) ) { + msg(loc("'%1' requires a higher version of perl than your current ". + "version -- sending N/A grade.", $name), $verbose); + + $grade = GRADE_NA; + + ### perhaps where were no tests... + ### see if the thing even had tests ### + } elsif ( NO_TESTS_DEFINED->( $buffer ) ) { + $grade = GRADE_UNKNOWN; + ### 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/); + + ### the bit where we inform what went wrong + $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer ); + + ### was it missing prereqs? ### + if( my @missing = MISSING_PREREQS_LIST->($buffer) ) { + if(!$self->_verify_missing_prereqs( + module => $mod, + missing => \@missing + )) { + msg(loc("Not sending test report - " . + "bogus missing prerequisites report")); + return 1; + } + $message .= REPORT_MISSING_PREREQS->($author,$email,@missing); + } + + ### was it missing test files? ### + if( NO_TESTS_DEFINED->($buffer) ) { + $message .= REPORT_MISSING_TESTS->(); + } + + ### add a list of what modules have been loaded of your prereqs list + $message .= REPORT_LOADED_PREREQS->($mod); + + ### 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) { + + ### the bit where we inform what went wrong + $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer ); + + ### 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, + 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 programattically alter the message + $message = $self->_callbacks->munge_test_report->($mod, $message, $grade); + + ### add the body if we have any ### + $reporter->comments( $message ) if defined $message && length $message; + + ### do a callback to ask if we should send the report + unless ($self->_callbacks->send_test_report->($mod, $grade)) { + msg(loc("Ok, not sending test report")); + return 1; + } + + ### do a callback to ask if we should edit the report + if ($self->_callbacks->edit_test_report->($mod, $grade)) { + ### test::reporter 1.20 and lower don't have a way to set + ### the preferred editor with a method call, but it does + ### respect your env variable, so let's set that. + local $ENV{VISUAL} = $conf->get_program('editor') + if $conf->get_program('editor'); + + $reporter->edit_comments; + } + + ### 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: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Search.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Search.pm new file mode 100755 index 00000000000..63c4da64d92 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Search.pm @@ -0,0 +1,363 @@ +package CPANPLUS::Internals::Search; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Module; +use CPANPLUS::Module::Author; + +use File::Find; +use File::Spec; + +use Params::Check qw[check allow]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Search + +=head1 SYNOPSIS + + my $aref = $cpan->_search_module_tree( + type => 'package', + allow => [qr/DBI/], + ); + + my $aref = $cpan->_search_author_tree( + type => 'cpanid', + data => \@old_results, + verbose => 1, + allow => [qw|KANE AUTRIJUS|], + ); + + my $aref = $cpan->_all_installed( ); + +=head1 DESCRIPTION + +The functions in this module are designed to find module(objects) +based on certain criteria and return them. + +=head1 METHODS + +=head2 _search_module_tree( type => TYPE, allow => \@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); + + ### seperate 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: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source.pm new file mode 100755 index 00000000000..54e9d710cfd --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source.pm @@ -0,0 +1,1417 @@ +package CPANPLUS::Internals::Source; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Module; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author; +use CPANPLUS::Internals::Constants; + +use 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[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +### list of methods the parent class must implement +{ for my $sub ( qw[_init_trees _finalize_trees + _standard_trees_completed _custom_trees_completed + _add_module_object _add_author_object _save_state + ] + ) { + no strict 'refs'; + *$sub = sub { + my $self = shift; + my $class = ref $self || $self; + + require Carp; + Carp::croak( loc( "Class %1 must implement method '%2'", + $class, $sub ) ); + } + } +} + +{ + my $recurse; # flag to prevent recursive calls to *_tree functions + + ### lazy loading of module tree + sub _module_tree { + my $self = $_[0]; + + unless ($self->_mtree or $recurse++ > 0) { + my $uptodate = $self->_check_trees( @_[1..$#_] ); + $self->_build_trees(uptodate => $uptodate); + } + + $recurse--; + return $self->_mtree; + } + + ### lazy loading of author tree + sub _author_tree { + my $self = $_[0]; + + unless ($self->_atree or $recurse++ > 0) { + my $uptodate = $self->_check_trees( @_[1..$#_] ); + $self->_build_trees(uptodate => $uptodate); + } + + $recurse--; + return $self->_atree; + } + +} + + +=pod + +=head1 NAME + +CPANPLUS::Internals::Source + +=head1 SYNOPSIS + + ### lazy load author/module trees ### + + $cb->_author_tree; + $cb->_module_tree; + +=head1 DESCRIPTION + +CPANPLUS::Internals::Source controls the updating of source files and +the parsing of them into usable module/author trees to be used by +C<CPANPLUS>. + +Functions exist to check if source files are still C<good to use> as +well as update them, and then parse them. + +The flow looks like this: + + $cb->_author_tree || $cb->_module_tree + $cb->_check_trees + $cb->__check_uptodate + $cb->_update_source + $cb->__update_custom_module_sources + $cb->__update_custom_module_source + $cb->_build_trees + ### engine methods + { $cb->_init_trees; + $cb->_standard_trees_completed + $cb->_custom_trees_completed + } + $cb->__create_author_tree + ### engine methods + { $cb->_add_author_object } + $cb->__create_module_tree + $cb->__create_dslip_tree + ### engine methods + { $cb->_add_module_object } + $cb->__create_custom_module_entries + + $cb->_dslip_defs + +=head1 METHODS + +=cut + +=pod + +=head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] ) + +This method rebuilds the author- and module-trees from source. + +It takes the following arguments: + +=over 4 + +=item uptodate + +Indicates whether any on disk caches are still ok to use. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=item use_stored + +A boolean flag indicating whether or not it is ok to use previously +stored trees. Defaults to true. + +=back + +Returns a boolean indicating success. + +=cut + +### (re)build the trees ### +sub _build_trees { + my ($self, %hash) = @_; + my $conf = $self->configure_object; + + my($path,$uptodate,$use_stored,$verbose); + my $tmpl = { + path => { default => $conf->get_conf('base'), store => \$path }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + uptodate => { required => 1, store => \$uptodate }, + use_stored => { default => 1, store => \$use_stored }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + $self->_init_trees( + path => $path, + uptodate => $uptodate, + verbose => $verbose, + use_stored => $use_stored, + ) or do { + error( loc("Could not initialize trees" ) ); + return; + }; + + ### return if we weren't able to build the trees ### + return unless $self->_mtree && $self->_atree; + + ### did we get everything from a stored state? if not, + ### process them now. + if( not $self->_standard_trees_completed ) { + + ### first, prep the author tree + $self->__create_author_tree( + uptodate => $uptodate, + path => $path, + verbose => $verbose, + ) or return; + + ### and now the module tree + $self->_create_mod_tree( + uptodate => $uptodate, + path => $path, + verbose => $verbose, + ) or return; + } + + ### XXX unpleasant hack. since custom sources uses ->parse_module, we + ### already have a special module object with extra meta data. that + ### doesn't gelwell with the sqlite storage engine. So, we check 'normal' + ### trees from seperate trees, so the engine can treat them differently. + ### Effectively this means that with the SQLite engine, for now, custom + ### sources are continuously reparsed =/ -kane + if( not $self->_custom_trees_completed ) { + + ### update them if the other sources are also deemed out of date + if( $conf->get_conf('enable_custom_sources') ) { + $self->__update_custom_module_sources( verbose => $verbose ) + or error(loc("Could not update custom module sources")); + } + + ### add custom sources here if enabled + if( $conf->get_conf('enable_custom_sources') ) { + $self->__create_custom_module_entries( verbose => $verbose ) + or error(loc("Could not create custom module entries")); + } + } + + ### give the source engine a chance to wrap up creation + $self->_finalize_trees( + path => $path, + uptodate => $uptodate, + verbose => $verbose, + use_stored => $use_stored, + ) or do { + error(loc( "Could not finalize trees" )); + return; + }; + + ### still necessary? can only run one instance now ### + ### will probably stay that way --kane +# my $id = $self->_store_id( $self ); +# +# unless ( $id == $self->_id ) { +# error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) ); +# } + + return 1; +} + +=pod + +=head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] ) + +Retrieve source files and return a boolean indicating whether or not +the source files are up to date. + +Takes several arguments: + +=over 4 + +=item update_source + +A flag to force re-fetching of the source files, even +if they are still up to date. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +=cut + +### retrieve source files, and returns a boolean indicating if it's up to date +sub _check_trees { + my ($self, %hash) = @_; + my $conf = $self->configure_object; + + my $update_source; + my $verbose; + my $path; + + my $tmpl = { + path => { default => $conf->get_conf('base'), + store => \$path + }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose + }, + update_source => { default => 0, store => \$update_source }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### if the user never wants to update their source without explicitly + ### telling us, shortcircuit here + return 1 if $conf->get_conf('no_update') && !$update_source; + + ### a check to see if our source files are still up to date ### + msg( loc("Checking if source files are up to date"), $verbose ); + + my $uptodate = 1; # default return value + + for my $name (qw[auth dslip mod]) { + for my $file ( $conf->_get_source( $name ) ) { + $self->__check_uptodate( + file => File::Spec->catfile( $path, $file ), + name => $name, + update_source => $update_source, + verbose => $verbose, + ) or $uptodate = 0; + } + } + + ### if we're explicitly asked to update the sources, or if the + ### standard source files are out of date, update the custom sources + ### as well + ### RT #47820: Don't try to update custom sources if they are disabled + ### in the configuration. + $self->__update_custom_module_sources( verbose => $verbose ) + if $conf->get_conf('enable_custom_sources') and ( $update_source or !$uptodate ); + + return $uptodate; +} + +=pod + +=head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] ) + +C<__check_uptodate> checks if a given source file is still up-to-date +and if not, or when C<update_source> is true, will re-fetch the source +file. + +Takes the following arguments: + +=over 4 + +=item file + +The source file to check. + +=item name + +The internal shortcut name for the source file (used for config +lookups). + +=item update_source + +Flag to force updating of sourcefiles regardless. + +=item verbose + +Boolean to indicate whether to be verbose or not. + +=back + +Returns a boolean value indicating whether the current files are up +to date or not. + +=cut + +### this method checks whether or not the source files we are using are still up to date +sub __check_uptodate { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + file => { required => 1 }, + name => { required => 1 }, + update_source => { default => 0 }, + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $flag; + unless ( -e $args->{'file'} && ( + ( stat $args->{'file'} )[9] + + $conf->_get_source('update') ) + > time ) { + $flag = 1; + } + + if ( $flag or $args->{'update_source'} ) { + + if ( $self->_update_source( name => $args->{'name'} ) ) { + return 0; # return 0 so 'uptodate' will be set to 0, meaning no + # use of previously stored hashrefs! + } else { + msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} ); + return 1; + } + + } else { + return 1; + } +} + +=pod + +=head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] ) + +This method does the actual fetching of source files. + +It takes the following arguments: + +=over 4 + +=item name + +The internal shortcut name for the source file (used for config +lookups). + +=item path + +The full path where to write the files. + +=item verbose + +Boolean to indicate whether to be verbose or not. + +=back + +Returns a boolean to indicate success. + +=cut + +### this sub fetches new source files ### +sub _update_source { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + my $verbose; + my $tmpl = { + name => { required => 1 }, + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + + my $path = $args->{path}; + { ### this could use a clean up - Kane + ### no worries about the / -> we get it from the _ftp configuration, so + ### it's not platform dependant. -kane + my ($dir, $file) = $conf->_get_mirror( $args->{'name'} ) =~ m|(.+/)(.+)$|sg; + + msg( loc("Updating source file '%1'", $file), $verbose ); + + my $fake = CPANPLUS::Module::Fake->new( + module => $args->{'name'}, + path => $dir, + package => $file, + _id => $self->_id, + ); + + ### can't use $fake->fetch here, since ->parent won't work -- + ### the sources haven't been saved yet + my $rv = $self->_fetch( + module => $fake, + fetchdir => $path, + force => 1, + ); + + + unless ($rv) { + error( loc("Couldn't fetch '%1'", $file) ); + return; + } + + $self->_update_timestamp( file => File::Spec->catfile($path, $file) ); + } + + return 1; +} + +=pod + +=head2 $cb->__create_author_tree([path => $path, uptodate => BOOL, verbose => BOOL]) + +This method opens a source files and parses its contents into a +searchable author-tree or restores a file-cached version of a +previous parse, if the sources are uptodate and the file-cache exists. + +It takes the following arguments: + +=over 4 + +=item uptodate + +A flag indicating whether the file-cache is uptodate or not. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns a tree on success, false on failure. + +=cut + +sub __create_author_tree { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $file = File::Spec->catfile( + $args->{path}, + $conf->_get_source('auth') + ); + + msg(loc("Rebuilding author tree, this might take a while"), + $args->{verbose}); + + ### extract the file ### + my $ae = Archive::Extract->new( archive => $file ) or return; + my $out = STRIP_GZ_SUFFIX->($file); + + ### make sure to set the PREFER_BIN flag if desired ### + { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); + $ae->extract( to => $out ) or return; + } + + my $cont = $self->_get_file_contents( file => $out ) or return; + + ### don't need it anymore ### + unlink $out; + + for ( split /\n/, $cont ) { + my($id, $name, $email) = m/^alias \s+ + (\S+) \s+ + "\s* ([^\"\<]+?) \s* <(.+)> \s*" + /x; + + $self->_add_author_object( + author => $name, #authors name + email => $email, #authors email address + cpanid => $id, #authors CPAN ID + ) or error( loc("Could not add author '%1'", $name ) ); + + } + + return $self->_atree; + +} #__create_author_tree + +=pod + +=head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL]) + +This method opens a source files and parses its contents into a +searchable module-tree or restores a file-cached version of a +previous parse, if the sources are uptodate and the file-cache exists. + +It takes the following arguments: + +=over 4 + +=item uptodate + +A flag indicating whether the file-cache is up-to-date or not. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns a tree on success, false on failure. + +=cut + +### this builds a hash reference with the structure of the cpan module tree ### +sub _create_mod_tree { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return undef; + my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod')); + + msg(loc("Rebuilding module tree, this might take a while"), + $args->{verbose}); + + + my $dslip_tree = $self->__create_dslip_tree( %$args ); + + ### extract the file ### + my $ae = Archive::Extract->new( archive => $file ) or return; + my $out = STRIP_GZ_SUFFIX->($file); + + ### make sure to set the PREFER_BIN flag if desired ### + { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); + $ae->extract( to => $out ) or return; + } + + my $content = $self->_get_file_contents( file => $out ) or return; + my $lines = $content =~ tr/\n/\n/; + + ### don't need it anymore ### + unlink $out; + + my($past_header, $count); + for ( split /\n/, $content ) { + + ### quick hack to read past the header of the file ### + ### this is still rather evil... fix some time - Kane + if( m|^\s*$| ) { + unless( $count ) { + error(loc("Could not determine line count from %1", $file)); + return; + } + $past_header = 1; + } + + ### we're still in the header -- find the amount of lines we expect + unless( $past_header ) { + + ### if the line count doesn't match what we expect, bail out + ### this should address: #45644: detect broken index + $count = $1 if /^Line-Count:\s+(\d+)/; + if( $count ) { + if( $lines < $count ) { + error(loc("Expected to read at least %1 lines, but %2 ". + "contains only %3 lines!", + $count, $file, $lines )); + return; + } + } + ### still in the header, keep moving + next; + } + + ### skip empty lines ### + next unless /\S/; + chomp; + + my @data = split /\s+/; + + ### filter out the author and filename as well ### + ### authors can apparently have digits in their names, + ### and dirs can have dots... blah! + my ($author, $package) = $data[2] =~ + m| (?:[A-Z\d-]/)? + (?:[A-Z\d-]{2}/)? + ([A-Z\d-]+) (?:/[\S]+)?/ + ([^/]+)$ + |xsg; + + ### remove file name from the path + $data[2] =~ s|/[^/]+$||; + + my $aobj = $self->author_tree($author); + unless( $aobj ) { + error( loc( "No such author '%1' -- can't make module object " . + "'%2' that is supposed to belong to this author", + $author, $data[0] ) ); + next; + } + + ### adding the dslip info + ### probably can use some optimization + my $dslip; + for my $item ( qw[ statd stats statl stati statp ] ) { + ### checking if there's an entry in the dslip info before + ### catting it on. appeasing warnings this way + $dslip .= $dslip_tree->{ $data[0] }->{$item} + ? $dslip_tree->{ $data[0] }->{$item} + : ' '; + } + + ### XXX this could be sped up if we used author names, not author + ### objects in creation, and then look them up in the author tree + ### when needed. This will need a fix to all the places that create + ### fake author/module objects as well. + + ### callback to store the individual object + $self->_add_module_object( + module => $data[0], # full module name + version => ($data[1] eq 'undef' # version number + ? '0.0' + : $data[1]), + path => File::Spec::Unix->catfile( + $conf->_get_mirror('base'), + $data[2], + ), # extended path on the cpan mirror, + # like /A/AB/ABIGAIL + comment => $data[3], # comment on the module + author => $aobj, + package => $package, # package name, like + # 'foo-bar-baz-1.03.tar.gz' + description => $dslip_tree->{ $data[0] }->{'description'}, + dslip => $dslip, + mtime => '', + ) or error( loc( "Could not add module '%1'", $data[0] ) ); + + } #for + + return $self->_mtree; + +} #_create_mod_tree + +=pod + +=head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL]) + +This method opens a source files and parses its contents into a +searchable dslip-tree or restores a file-cached version of a +previous parse, if the sources are uptodate and the file-cache exists. + +It takes the following arguments: + +=over 4 + +=item uptodate + +A flag indicating whether the file-cache is uptodate or not. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns a tree on success, false on failure. + +=cut + +sub __create_dslip_tree { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + my $tmpl = { + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### get the file name of the source ### + my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip')); + + ### extract the file ### + my $ae = Archive::Extract->new( archive => $file ) or return; + my $out = STRIP_GZ_SUFFIX->($file); + + ### make sure to set the PREFER_BIN flag if desired ### + { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); + $ae->extract( to => $out ) or return; + } + + my $in = $self->_get_file_contents( file => $out ) or return; + + ### don't need it anymore ### + unlink $out; + + + ### get rid of the comments and the code ### + ### need a smarter parser, some people have this in their dslip info: + # [ + # 'Statistics::LTU', + # 'R', + # 'd', + # 'p', + # 'O', + # '?', + # 'Implements Linear Threshold Units', + # ...skipping... + # "\x{c4}dd \x{fc}ml\x{e4}\x{fc}ts t\x{f6} \x{eb}v\x{eb}r\x{ff}th\x{ef}ng!", + # 'BENNIE', + # '11' + # ], + ### also, older versions say: + ### $cols = [....] + ### and newer versions say: + ### $CPANPLUS::Modulelist::cols = [...] + ### split '$cols' and '$data' into 2 variables ### + ### use this regex to make sure dslips with ';' in them don't cause + ### parser errors + my ($ds_one, $ds_two) = ($in =~ m|.+}\s+ + (\$(?:CPAN::Modulelist::)?cols.*?) + (\$(?:CPAN::Modulelist::)?data.*) + |sx); + + ### eval them into existence ### + ### still not too fond of this solution - kane ### + my ($cols, $data); + { #local $@; can't use this, it's buggy -kane + + $cols = eval $ds_one; + error( loc("Error in eval of dslip source files: %1", $@) ) if $@; + + $data = eval $ds_two; + error( loc("Error in eval of dslip source files: %1", $@) ) if $@; + + } + + my $tree = {}; + my $primary = "modid"; + + ### this comes from CPAN::Modulelist + ### which is in 03modlist.data.gz + for (@$data){ + my %hash; + @hash{@$cols} = @$_; + $tree->{$hash{$primary}} = \%hash; + } + + return $tree; + +} #__create_dslip_tree + +=pod + +=head2 $cb->_dslip_defs () + +This function returns the definition structure (ARRAYREF) of the +dslip tree. + +=cut + +### these are the definitions used for dslip info +### they shouldn't change over time.. so hardcoding them doesn't appear to +### be a problem. if it is, we need to parse 03modlist.data better to filter +### all this out. +### right now, this is just used to look up dslip info from a module +sub _dslip_defs { + my $self = shift; + + my $aref = [ + + # D + [ q|Development Stage|, { + i => loc('Idea, listed to gain consensus or as a placeholder'), + c => loc('under construction but pre-alpha (not yet released)'), + a => loc('Alpha testing'), + b => loc('Beta testing'), + R => loc('Released'), + M => loc('Mature (no rigorous definition)'), + S => loc('Standard, supplied with Perl 5'), + }], + + # S + [ q|Support Level|, { + m => loc('Mailing-list'), + d => loc('Developer'), + u => loc('Usenet newsgroup comp.lang.perl.modules'), + n => loc('None known, try comp.lang.perl.modules'), + a => loc('Abandoned; volunteers welcome to take over maintainance'), + }], + + # L + [ q|Language Used|, { + p => loc('Perl-only, no compiler needed, should be platform independent'), + c => loc('C and perl, a C compiler will be needed'), + h => loc('Hybrid, written in perl with optional C code, no compiler needed'), + '+' => loc('C++ and perl, a C++ compiler will be needed'), + o => loc('perl and another language other than C or C++'), + }], + + # I + [ q|Interface Style|, { + f => loc('plain Functions, no references used'), + h => loc('hybrid, object and function interfaces available'), + n => loc('no interface at all (huh?)'), + r => loc('some use of unblessed References or ties'), + O => loc('Object oriented using blessed references and/or inheritance'), + }], + + # P + [ q|Public License|, { + p => loc('Standard-Perl: user may choose between GPL and Artistic'), + g => loc('GPL: GNU General Public License'), + l => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'), + b => loc('BSD: The BSD License'), + a => loc('Artistic license alone'), + o => loc('other (but distribution allowed without restrictions)'), + }], + ]; + + return $aref; +} + +=head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] ); + +Adds a custom source index and updates it based on the provided URI. + +Returns the full path to the index file on success or false on failure. + +=cut + +sub _add_custom_module_source { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($verbose,$uri); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + uri => { required => 1, store => \$uri } + }; + + check( $tmpl, \%hash ) or return; + + ### what index file should we use on disk? + my $index = $self->__custom_module_source_index_file( uri => $uri ); + + ### already have it. + if( IS_FILE->( $index ) ) { + msg(loc("Source '%1' already added", $uri)); + return 1; + } + + ### do we need to create the targe dir? + { my $dir = dirname( $index ); + unless( IS_DIR->( $dir ) ) { + $self->_mkdir( dir => $dir ) or return + } + } + + ### write the file + my $fh = OPEN_FILE->( $index => '>' ) or do { + error(loc("Could not open index file for '%1'", $uri)); + return; + }; + + ### basically we 'touched' it. Check the return value, may be + ### important on win32 and similar OS, where there's file length + ### limits + close $fh or do { + error(loc("Could not write index file to disk for '%1'", $uri)); + return; + }; + + $self->__update_custom_module_source( + remote => $uri, + local => $index, + verbose => $verbose, + ) or do { + ### we faild to update it, we probably have an empty + ### possibly silly filename on disk now -- remove it + 1 while unlink $index; + return; + }; + + return $index; +} + +=head2 $index = $cb->__custom_module_source_index_file( uri => $uri ); + +Returns the full path to the encoded index file for C<$uri>, as used by +all C<custom module source> routines. + +=cut + +sub __custom_module_source_index_file { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($verbose,$uri); + my $tmpl = { + uri => { required => 1, store => \$uri } + }; + + check( $tmpl, \%hash ) or return; + + my $index = File::Spec->catfile( + $conf->get_conf('base'), + $conf->_get_build('custom_sources'), + $self->_uri_encode( uri => $uri ), + ); + + return $index; +} + +=head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] ); + +Removes a custom index file based on the URI provided. + +Returns the full path to the index file on success or false on failure. + +=cut + +sub _remove_custom_module_source { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($verbose,$uri); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + uri => { required => 1, store => \$uri } + }; + + check( $tmpl, \%hash ) or return; + + ### use uri => local, instead of the other way around + my %files = reverse $self->__list_custom_module_sources; + + ### On VMS the case of key to %files can be either exact or lower case + ### XXX abstract this lookup out? --kane + my $file = $files{ $uri }; + $file = $files{ lc $uri } if !defined($file) && ON_VMS; + + unless (defined $file) { + error(loc("No such custom source '%1'", $uri)); + return; + }; + + 1 while unlink $file; + + if( IS_FILE->( $file ) ) { + error(loc("Could not remove index file '%1' for custom source '%2'", + $file, $uri)); + return; + } + + msg(loc("Successfully removed index file for '%1'", $uri), $verbose); + + return $file; +} + +=head2 %files = $cb->__list_custom_module_sources + +This method scans the 'custom-sources' directory in your base directory +for additional sources to include in your module tree. + +Returns a list of key value pairs as follows: + + /full/path/to/source/file%3Fencoded => http://decoded/mirror/path + +=cut + +sub __list_custom_module_sources { + my $self = shift; + my $conf = $self->configure_object; + + my($verbose); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + my $dir = File::Spec->catdir( + $conf->get_conf('base'), + $conf->_get_build('custom_sources'), + ); + + unless( IS_DIR->( $dir ) ) { + msg(loc("No '%1' dir, skipping custom sources", $dir), $verbose); + return; + } + + ### unencode the files + ### skip ones starting with # though + my %files = map { + my $org = $_; + my $dec = $self->_uri_decode( uri => $_ ); + File::Spec->catfile( $dir, $org ) => $dec + } grep { $_ !~ /^#/ } READ_DIR->( $dir ); + + return %files; +} + +=head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] ); + +Attempts to update all the index files to your custom module sources. + +If the index is missing, and it's a C<file://> uri, it will generate +a new local index for you. + +Return true on success, false on failure. + +=cut + +sub __update_custom_module_sources { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $verbose; + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose } + }; + + check( $tmpl, \%hash ) or return; + + my %files = $self->__list_custom_module_sources; + + ### uptodate check has been done a few levels up. + my $fail; + while( my($local,$remote) = each %files ) { + + $self->__update_custom_module_source( + remote => $remote, + local => $local, + verbose => $verbose, + ) or ( $fail++, next ); + } + + error(loc("Failed updating one or more remote sources files")) if $fail; + + return if $fail; + return 1; +} + +=head2 $ok = $cb->__update_custom_module_source + +Attempts to update all the index files to your custom module sources. + +If the index is missing, and it's a C<file://> uri, it will generate +a new local index for you. + +Return true on success, false on failure. + +=cut + +sub __update_custom_module_source { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($verbose,$local,$remote); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + local => { store => \$local, allow => FILE_EXISTS }, + remote => { required => 1, store => \$remote }, + }; + + check( $tmpl, \%hash ) or return; + + msg( loc("Updating sources from '%1'", $remote), $verbose); + + ### if you didn't provide a local file, we'll look in your custom + ### dir to find the local encoded version for you + $local ||= do { + ### find all files we know of + my %files = reverse $self->__list_custom_module_sources or do { + error(loc("No custom modules sources defined -- need '%1' argument", + 'local')); + return; + }; + + ### On VMS the case of key to %files can be either exact or lower case + ### XXX abstract this lookup out? --kane + my $file = $files{ $remote }; + $file = $files{ lc $remote } if !defined ($file) && ON_VMS; + + ### return the local file we're supposed to use + $file or do { + error(loc("Remote source '%1' unknown -- needs '%2' argument", + $remote, 'local')); + return; + }; + }; + + my $uri = join '/', $remote, $conf->_get_source('custom_index'); + my $ff = File::Fetch->new( uri => $uri ); + + ### tempdir doesn't clean up by default, as opposed to tempfile() + ### so add it explicitly. + my $dir = tempdir( CLEANUP => 1 ); + + my $res = do { local $File::Fetch::WARN = 0; + local $File::Fetch::WARN = 0; + $ff->fetch( to => $dir ); + }; + + ### couldn't get the file + unless( $res ) { + + ### it's not a local scheme, so can't auto index + unless( $ff->scheme eq 'file' ) { + error(loc("Could not update sources from '%1': %2", + $remote, $ff->error )); + return; + + ### it's a local uri, we can index it ourselves + } else { + msg(loc("No index file found at '%1', generating one", + $ff->uri), $verbose ); + + ### ON VMS, if you are working with a UNIX file specification, + ### you need currently use the UNIX variants of the File::Spec. + my $ff_path = do { + my $file_class = 'File::Spec'; + $file_class .= '::Unix' if ON_VMS; + $file_class->catdir( File::Spec::Unix->splitdir( $ff->path ) ); + }; + + $self->__write_custom_module_index( + path => $ff_path, + to => $local, + verbose => $verbose, + ) or return; + + ### XXX don't write that here, __write_custom_module_index + ### already prints this out + #msg(loc("Index file written to '%1'", $to), $verbose); + } + + ### copy it to the real spot and update its timestamp + } else { + $self->_move( file => $res, to => $local ) or return; + $self->_update_timestamp( file => $local ); + + msg(loc("Index file saved to '%1'", $local), $verbose); + } + + return $local; +} + +=head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] ) + +Scans the C<path> you provided for packages and writes an index with all +the available packages to C<$path/packages.txt>. If you'd like the index +to be written to a different file, provide the C<to> argument. + +Returns true on success and false on failure. + +=cut + +sub __write_custom_module_index { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my ($verbose, $path, $to); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + path => { required => 1, allow => DIR_EXISTS, store => \$path }, + to => { store => \$to }, + }; + + check( $tmpl, \%hash ) or return; + + ### no explicit to? then we'll use our default + $to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') ); + + my @files; + require File::Find; + File::Find::find( sub { + ### let's see if A::E can even parse it + my $ae = do { + local $Archive::Extract::WARN = 0; + local $Archive::Extract::WARN = 0; + Archive::Extract->new( archive => $File::Find::name ) + } or return; + + ### it's a type A::E recognize, so we can add it + $ae->type or return; + + ### neither $_ nor $File::Find::name have the chunk of the path in + ### it starting $path -- it's either only the filename, or the full + ### path, so we have to strip it ourselves + ### make sure to remove the leading slash as well. + my $copy = $File::Find::name; + my $re = quotemeta($path); + $copy =~ s|^$re[\\/]?||i; + + push @files, $copy; + + }, $path ); + + ### does the dir exist? if not, create it. + { my $dir = dirname( $to ); + unless( IS_DIR->( $dir ) ) { + $self->_mkdir( dir => $dir ) or return + } + } + + ### create the index file + my $fh = OPEN_FILE->( $to => '>' ) or return; + + print $fh "$_\n" for @files; + close $fh; + + msg(loc("Successfully written index file to '%1'", $to), $verbose); + + return $to; +} + + +=head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] ) + +Creates entries in the module tree based upon the files as returned +by C<__list_custom_module_sources>. + +Returns true on success, false on failure. + +=cut + +### use $auth_obj as a persistant version, so we don't have to recreate +### modules all the time +{ my $auth_obj; + + sub __create_custom_module_entries { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $verbose; + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + }; + + check( $tmpl, \%hash ) or return undef; + + my %files = $self->__list_custom_module_sources; + + while( my($file,$name) = each %files ) { + + msg(loc("Adding packages from custom source '%1'", $name), $verbose); + + my $fh = OPEN_FILE->( $file ) or next; + + while( local $_ = <$fh> ) { + chomp; + next if /^#/; + next unless /\S+/; + + ### join on / -- it's a URI after all! + my $parse = join '/', $name, $_; + + ### try to make a module object out of it + my $mod = $self->parse_module( module => $parse ) or ( + error(loc("Could not parse '%1'", $_)), + next + ); + + ### mark this object with a custom author + $auth_obj ||= do { + my $id = CUSTOM_AUTHOR_ID; + + ### if the object is being created for the first time, + ### make sure there's an entry in the author tree as + ### well, so we can search on the CPAN ID + $self->author_tree->{ $id } = + CPANPLUS::Module::Author::Fake->new( cpanid => $id ); + }; + + $mod->author( $auth_obj ); + + ### and now add it to the modlue tree -- this MAY + ### override things of course + if( my $old_mod = $self->module_tree( $mod->module ) ) { + + ### On VMS use the old module name to get the real case + $mod->module( $old_mod->module ) if ON_VMS; + + msg(loc("About to overwrite module tree entry for '%1' with '%2'", + $mod->module, $mod->package), $verbose); + } + + ### mark where it came from + $mod->description( loc("Custom source from '%1'",$name) ); + + ### store it in the module tree + $self->module_tree->{ $mod->module } = $mod; + } + } + + return 1; + } +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/Memory.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/Memory.pm new file mode 100755 index 00000000000..cb3fd4f1e76 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/Memory.pm @@ -0,0 +1,374 @@ +package CPANPLUS::Internals::Source::Memory; + +use base 'CPANPLUS::Internals::Source'; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Module; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author; +use CPANPLUS::Internals::Constants; + +use File::Fetch; +use Archive::Extract; + +use IPC::Cmd qw[can_run]; +use File::Temp qw[tempdir]; +use File::Basename qw[dirname]; +use Params::Check qw[allow check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +=head1 NAME + +CPANPLUS::Internals::Source::Memory - In memory implementation + +=cut + +### flag to show if init_trees got its' data from storable. This allows +### us to not write an existing stored file back to disk +{ my $from_storable; + + sub _init_trees { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($path,$uptodate,$verbose,$use_stored); + my $tmpl = { + path => { default => $conf->get_conf('base'), store => \$path }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + uptodate => { required => 1, store => \$uptodate }, + use_stored => { default => 1, store => \$use_stored }, + }; + + check( $tmpl, \%hash ) or return; + + ### retrieve the stored source files ### + my $stored = $self->__memory_retrieve_source( + path => $path, + uptodate => $uptodate && $use_stored, + verbose => $verbose, + ) || {}; + + ### we got this from storable if $stored has keys.. + $from_storable = keys %$stored ? 1 : 0; + + ### set up the trees + $self->_atree( $stored->{_atree} || {} ); + $self->_mtree( $stored->{_mtree} || {} ); + + return 1; + } + + sub _standard_trees_completed { return $from_storable } + sub _custom_trees_completed { return $from_storable } + + sub _finalize_trees { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($path,$uptodate,$verbose); + my $tmpl = { + path => { default => $conf->get_conf('base'), store => \$path }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + uptodate => { required => 1, store => \$uptodate }, + }; + + { local $Params::Check::ALLOW_UNKNOWN = 1; + check( $tmpl, \%hash ) or return; + } + + ### write the stored files to disk, so we can keep using them + ### from now on, till they become invalid + ### write them if the original sources weren't uptodate, or + ### we didn't just load storable files + $self->__memory_save_source() if !$uptodate or not $from_storable; + + return 1; + } + + ### saves current memory state + sub _save_state { + my $self = shift; + return $self->_finalize_trees( @_, uptodate => 0 ); + } +} + +sub _add_author_object { + my $self = shift; + my %hash = @_; + + my $class; + my $tmpl = { + class => { default => 'CPANPLUS::Module::Author', store => \$class }, + map { $_ => { required => 1 } } + qw[ author cpanid email ] + }; + + my $href = do { + local $Params::Check::NO_DUPLICATES = 1; + check( $tmpl, \%hash ) or return; + }; + + my $obj = $class->new( %$href, _id => $self->_id ); + + $self->author_tree->{ $href->{'cpanid'} } = $obj or return; + + return $obj; +} + +sub _add_module_object { + my $self = shift; + my %hash = @_; + + my $class; + my $tmpl = { + class => { default => 'CPANPLUS::Module', store => \$class }, + map { $_ => { required => 1 } } + qw[ module version path comment author package description dslip mtime ] + }; + + my $href = do { + local $Params::Check::NO_DUPLICATES = 1; + check( $tmpl, \%hash ) or return; + }; + + my $obj = $class->new( %$href, _id => $self->_id ); + + ### Every module get's stored as a module object ### + $self->module_tree->{ $href->{module} } = $obj or return; + + return $obj; +} + +{ my %map = ( + _source_search_module_tree => [ module_tree => 'CPANPLUS::Module' ], + _source_search_author_tree => [ author_tree => 'CPANPLUS::Module::Author' ], + ); + + while( my($sub, $aref) = each %map ) { + no strict 'refs'; + + my($meth, $class) = @$aref; + + *$sub = sub { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($authors,$list,$verbose,$type); + my $tmpl = { + data => { default => [], + strict_type=> 1, store => \$authors }, + allow => { required => 1, default => [ ], strict_type => 1, + store => \$list }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + type => { required => 1, allow => [$class->accessors()], + store => \$type }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my @rv; + for my $obj ( values %{ $self->$meth } ) { + #push @rv, $auth if check( + # { $type => { allow => $list } }, + # { $type => $auth->$type } + # ); + push @rv, $obj if allow( $obj->$type() => $list ); + } + + return @rv; + } + } +} + +=pod + +=head2 $cb->__memory_retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL]) + +This method retrieves a I<storable>d tree identified by C<$name>. + +It takes the following arguments: + +=over 4 + +=item name + +The internal name for the source file to retrieve. + +=item uptodate + +A flag indicating whether the file-cache is up-to-date or not. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns a tree on success, false on failure. + +=cut + +sub __memory_retrieve_source { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + my $tmpl = { + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### check if we can retrieve a frozen data structure with storable ### + my $storable = can_load( modules => {'Storable' => '0.0'} ) + if $conf->get_conf('storable'); + + return unless $storable; + + ### $stored is the name of the frozen data structure ### + my $stored = $self->__memory_storable_file( $args->{path} ); + + if ($storable && -e $stored && -s _ && $args->{'uptodate'}) { + msg( loc("Retrieving %1", $stored), $args->{'verbose'} ); + + my $href = Storable::retrieve($stored); + return $href; + } else { + return; + } +} + +=pod + +=head2 $cb->__memory_save_source([verbose => BOOL, path => $path]) + +This method saves all the parsed trees in I<storable>d format if +C<Storable> is available. + +It takes the following arguments: + +=over 4 + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns true on success, false on failure. + +=cut + +sub __memory_save_source { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + path => { default => $conf->get_conf('base'), allow => DIR_EXISTS }, + verbose => { default => $conf->get_conf('verbose') }, + force => { default => 1 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $aref = [qw[_mtree _atree]]; + + ### check if we can retrieve a frozen data structure with storable ### + my $storable; + $storable = can_load( modules => {'Storable' => '0.0'} ) + if $conf->get_conf('storable'); + return unless $storable; + + my $to_write = {}; + foreach my $key ( @$aref ) { + next unless ref( $self->$key ); + $to_write->{$key} = $self->$key; + } + + return unless keys %$to_write; + + ### $stored is the name of the frozen data structure ### + my $stored = $self->__memory_storable_file( $args->{path} ); + + if (-e $stored && not -w $stored) { + msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} ); + return; + } + + msg( loc("Writing compiled source information to disk. This might take a little while."), + $args->{'verbose'} ); + + my $flag; + unless( Storable::nstore( $to_write, $stored ) ) { + error( loc("could not store %1!", $stored) ); + $flag++; + } + + return $flag ? 0 : 1; +} + +sub __memory_storable_file { + my $self = shift; + my $conf = $self->configure_object; + my $path = shift or return; + + ### check if we can retrieve a frozen data structure with storable ### + my $storable = $conf->get_conf('storable') + ? can_load( modules => {'Storable' => '0.0'} ) + : 0; + + return unless $storable; + + ### $stored is the name of the frozen data structure ### + ### changed to use File::Spec->catfile -jmb + my $stored = File::Spec->rel2abs( + File::Spec->catfile( + $path, #base dir + $conf->_get_source('stored') #file + . '.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; diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/SQLite.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/SQLite.pm new file mode 100755 index 00000000000..a0ddf499bf6 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/SQLite.pm @@ -0,0 +1,326 @@ +package CPANPLUS::Internals::Source::SQLite; + +use strict; +use warnings; + +use base 'CPANPLUS::Internals::Source'; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Internals::Source::SQLite::Tie; + +use Data::Dumper; +use DBIx::Simple; +use DBD::SQLite; + +use Params::Check qw[allow check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +use constant TXN_COMMIT => 1000; + +=head1 NAME + +CPANPLUS::Internals::Source::SQLite - SQLite implementation + +=cut + +{ my $Dbh; + my $DbFile; + + sub __sqlite_file { + return $DbFile if $DbFile; + + my $self = shift; + my $conf = $self->configure_object; + + $DbFile = File::Spec->catdir( + $conf->get_conf('base'), + SOURCE_SQLITE_DB + ); + + return $DbFile; + }; + + sub __sqlite_dbh { + return $Dbh if $Dbh; + + my $self = shift; + $Dbh = DBIx::Simple->connect( + "dbi:SQLite:dbname=" . $self->__sqlite_file, + '', '', + { AutoCommit => 1 } + ); + #$Dbh->dbh->trace(1); + + return $Dbh; + }; +} + +{ my $used_old_copy = 0; + + sub _init_trees { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($path,$uptodate,$verbose,$use_stored); + my $tmpl = { + path => { default => $conf->get_conf('base'), store => \$path }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + uptodate => { required => 1, store => \$uptodate }, + use_stored => { default => 1, store => \$use_stored }, + }; + + check( $tmpl, \%hash ) or return; + + ### if it's not uptodate, or the file doesn't exist, we need to create + ### a new sqlite db + if( not $uptodate or not -e $self->__sqlite_file ) { + $used_old_copy = 0; + + ### chuck the file + 1 while unlink $self->__sqlite_file; + + ### and create a new one + $self->__sqlite_create_db or do { + error(loc("Could not create new SQLite DB")); + return; + } + } else { + $used_old_copy = 1; + } + + ### set up the author tree + { my %at; + tie %at, 'CPANPLUS::Internals::Source::SQLite::Tie', + dbh => $self->__sqlite_dbh, table => 'author', + key => 'cpanid', cb => $self; + + $self->_atree( \%at ); + } + + ### set up the author tree + { my %mt; + tie %mt, 'CPANPLUS::Internals::Source::SQLite::Tie', + dbh => $self->__sqlite_dbh, table => 'module', + key => 'module', cb => $self; + + $self->_mtree( \%mt ); + } + + ### start a transaction + $self->__sqlite_dbh->query('BEGIN'); + + return 1; + + } + + sub _standard_trees_completed { return $used_old_copy } + sub _custom_trees_completed { return } + ### finish transaction + sub _finalize_trees { $_[0]->__sqlite_dbh->query('COMMIT'); return 1 } + + ### saves current memory state, but not implemented in sqlite + sub _save_state { + error(loc("%1 has not implemented writing state to disk", __PACKAGE__)); + return; + } +} + +{ my $txn_count = 0; + + ### XXX move this outside the sub, so we only compute it once + my $class; + my @keys = qw[ author cpanid email ]; + my $tmpl = { + class => { default => 'CPANPLUS::Module::Author', store => \$class }, + map { $_ => { required => 1 } } @keys + }; + + ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually + my $ph = join ',', map { '?' } @keys; + + + sub _add_author_object { + my $self = shift; + my %hash = @_; + my $dbh = $self->__sqlite_dbh; + + my $href = do { + local $Params::Check::NO_DUPLICATES = 1; + local $Params::Check::SANITY_CHECK_TEMPLATE = 0; + check( $tmpl, \%hash ) or return; + }; + + ### keep counting how many we inserted + unless( ++$txn_count % TXN_COMMIT ) { + #warn "Committing transaction $txn_count"; + $dbh->query('COMMIT') or error( $dbh->error ); # commit previous transaction + $dbh->query('BEGIN') or error( $dbh->error ); # and start a new one + } + + $dbh->query( + "INSERT INTO author (". join(',',keys(%$href)) .") VALUES ($ph)", + values %$href + ) or do { + error( $dbh->error ); + return; + }; + + return 1; + } +} + +{ my $txn_count = 0; + + ### XXX move this outside the sub, so we only compute it once + my $class; + my @keys = qw[ module version path comment author package description dslip mtime ]; + my $tmpl = { + class => { default => 'CPANPLUS::Module', store => \$class }, + map { $_ => { required => 1 } } @keys + }; + + ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually + my $ph = join ',', map { '?' } @keys; + + sub _add_module_object { + my $self = shift; + my %hash = @_; + my $dbh = $self->__sqlite_dbh; + + my $href = do { + local $Params::Check::NO_DUPLICATES = 1; + local $Params::Check::SANITY_CHECK_TEMPLATE = 0; + check( $tmpl, \%hash ) or return; + }; + + ### fix up author to be 'plain' string + $href->{'author'} = $href->{'author'}->cpanid; + + ### keep counting how many we inserted + unless( ++$txn_count % TXN_COMMIT ) { + #warn "Committing transaction $txn_count"; + $dbh->query('COMMIT') or error( $dbh->error ); # commit previous transaction + $dbh->query('BEGIN') or error( $dbh->error ); # and start a new one + } + + $dbh->query( + "INSERT INTO module (". join(',',keys(%$href)) .") VALUES ($ph)", + values %$href + ) or do { + error( $dbh->error ); + return; + }; + + return 1; + } +} + +{ my %map = ( + _source_search_module_tree + => [ module => module => 'CPANPLUS::Module' ], + _source_search_author_tree + => [ author => cpanid => 'CPANPLUS::Module::Author' ], + ); + + while( my($sub, $aref) = each %map ) { + no strict 'refs'; + + my($table, $key, $class) = @$aref; + *$sub = sub { + my $self = shift; + my %hash = @_; + my $dbh = $self->__sqlite_dbh; + + my($list,$type); + my $tmpl = { + allow => { required => 1, default => [ ], strict_type => 1, + store => \$list }, + type => { required => 1, allow => [$class->accessors()], + store => \$type }, + }; + + check( $tmpl, \%hash ) or return; + + + ### we aliased 'module' to 'name', so change that here too + $type = 'module' if $type eq 'name'; + + my $res = $dbh->query( "SELECT * from $table" ); + + my $meth = $table .'_tree'; + my @rv = map { $self->$meth( $_->{$key} ) } + grep { allow( $_->{$type} => $list ) } $res->hashes; + + return @rv; + } + } +} + + + +sub __sqlite_create_db { + my $self = shift; + my $dbh = $self->__sqlite_dbh; + + ### we can ignore the result/error; not all sqlite implemantation + ### support this + $dbh->query( qq[ + DROP TABLE IF EXISTS author; + \n] + ) or do { + msg( $dbh->error ); + }; + $dbh->query( qq[ + DROP TABLE IF EXISTS module; + \n] + ) or do { + msg( $dbh->error ); + }; + + + + $dbh->query( qq[ + /* the author information */ + CREATE TABLE author ( + id INTEGER PRIMARY KEY AUTOINCREMENT, + + author varchar(255), + email varchar(255), + cpanid varchar(255) + ); + \n] + + ) or do { + error( $dbh->error ); + return; + }; + + $dbh->query( qq[ + /* the module information */ + CREATE TABLE module ( + id INTEGER PRIMARY KEY AUTOINCREMENT, + + module varchar(255), + version varchar(255), + path varchar(255), + comment varchar(255), + author varchar(255), + package varchar(255), + description varchar(255), + dslip varchar(255), + mtime varchar(255) + ); + + \n] + + ) or do { + error( $dbh->error ); + return; + }; + + return 1; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm new file mode 100755 index 00000000000..f908c9803e4 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm @@ -0,0 +1,145 @@ +package CPANPLUS::Internals::Source::SQLite::Tie; + +use strict; +use warnings; + +use CPANPLUS::Error; +use CPANPLUS::Module; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author::Fake; +use CPANPLUS::Internals::Constants; + + +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + + +use Data::Dumper; +$Data::Dumper::Indent = 1; + +require Tie::Hash; +use vars qw[@ISA]; +push @ISA, 'Tie::StdHash'; + + +sub TIEHASH { + my $class = shift; + my %hash = @_; + + my $tmpl = { + dbh => { required => 1 }, + table => { required => 1 }, + key => { required => 1 }, + cb => { required => 1 }, + offset => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + my $obj = bless { %$args, store => {} } , $class; + + return $obj; +} + +sub FETCH { + my $self = shift; + my $key = shift or return; + my $dbh = $self->{dbh}; + my $cb = $self->{cb}; + my $table = $self->{table}; + + + ### did we look this one up before? + if( my $obj = $self->{store}->{$key} ) { + return $obj; + } + + my $res = $dbh->query( + "SELECT * from $table where $self->{key} = ?", $key + ) or do { + error( $dbh->error ); + return; + }; + + my $href = $res->hash; + + ### get rid of the primary key + delete $href->{'id'}; + + ### no results? + return unless keys %$href; + + ### expand author if needed + ### XXX no longer generic :( + if( $table eq 'module' ) { + $href->{author} = $cb->author_tree( $href->{author } ) or return; + } + + my $class = { + module => 'CPANPLUS::Module', + author => 'CPANPLUS::Module::Author', + }->{ $table }; + + my $obj = $self->{store}->{$key} = $class->new( %$href, _id => $cb->_id ); + + return $obj; +} + +sub STORE { + my $self = shift; + my $key = shift; + my $val = shift; + + $self->{store}->{$key} = $val; +} + +1; + +sub FIRSTKEY { + my $self = shift; + my $dbh = $self->{'dbh'}; + + my $res = $dbh->query( + "select $self->{key} from $self->{table} order by $self->{key} limit 1" + ); + + $self->{offset} = 0; + + my $key = $res->flat->[0]; + + return $key; +} + +sub NEXTKEY { + my $self = shift; + my $dbh = $self->{'dbh'}; + + my $res = $dbh->query( + "select $self->{key} from $self->{table} ". + "order by $self->{key} limit 1 offset $self->{offset}" + ); + + $self->{offset} +=1; + + my $key = $res->flat->[0]; + my $val = $self->FETCH( $key ); + + ### use each() semantics + return wantarray ? ( $key, $val ) : $key; +} + +sub EXISTS { !!$_[0]->FETCH( $_[1] ) } + +sub SCALAR { + my $self = shift; + my $dbh = $self->{'dbh'}; + + my $res = $dbh->query( "select count(*) from $self->{table}" ); + + return $res->flat; +} + +### intentionally left blank +sub DELETE { } +sub CLEAR { } + diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Utils.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Utils.pm new file mode 100755 index 00000000000..8475c362023 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Utils.pm @@ -0,0 +1,657 @@ +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'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Utils + +=head1 SYNOPSIS + + my $bool = $cb->_mkdir( dir => 'blah' ); + my $bool = $cb->_chdir( dir => 'blah' ); + my $bool = $cb->_rmdir( dir => 'blah' ); + + my $bool = $cb->_move( from => '/some/file', to => '/other/file' ); + my $bool = $cb->_move( from => '/some/dir', to => '/other/dir' ); + + my $cont = $cb->_get_file_contents( file => '/path/to/file' ); + + + my $version = $cb->_perl_version( perl => $^X ); + +=head1 DESCRIPTION + +C<CPANPLUS::Internals::Utils> holds a few convenience functions for +CPANPLUS libraries. + +=head1 METHODS + +=head2 $cb->_mkdir( dir => '/some/dir' ) + +C<_mkdir> creates a full path to a directory. + +Returns true on success, false on failure. + +=cut + +sub _mkdir { + my $self = shift; + + my %hash = @_; + + my $tmpl = { + dir => { required => 1 }, + }; + + my $args = check( $tmpl, \%hash ) or ( + error(loc( Params::Check->last_error ) ), return + ); + + unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { + error( loc("Could not use File::Path! This module should be core!") ); + return; + } + + eval { File::Path::mkpath($args->{dir}) }; + + if($@) { + chomp($@); + error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ )); + return; + } + + return 1; +} + +=pod + +=head2 $cb->_chdir( dir => '/some/dir' ) + +C<_chdir> changes directory to a dir. + +Returns true on success, false on failure. + +=cut + +sub _chdir { + my $self = shift; + my %hash = @_; + + my $tmpl = { + dir => { required => 1, allow => DIR_EXISTS }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + unless( chdir $args->{dir} ) { + error( loc(q[Could not chdir into '%1'], $args->{dir}) ); + return; + } + + return 1; +} + +=pod + +=head2 $cb->_rmdir( dir => '/some/dir' ); + +Removes a directory completely, even if it is non-empty. + +Returns true on success, false on failure. + +=cut + +sub _rmdir { + my $self = shift; + my %hash = @_; + + my $tmpl = { + dir => { required => 1, allow => IS_DIR }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { + error( loc("Could not use File::Path! This module should be core!") ); + return; + } + + eval { File::Path::rmtree($args->{dir}) }; + + if($@) { + chomp($@); + error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ )); + return; + } + + return 1; +} + +=pod + +=head2 $cb->_perl_version ( perl => 'some/perl/binary' ); + +C<_perl_version> returns the version of a certain perl binary. +It does this by actually running a command. + +Returns the perl version on success and false on failure. + +=cut + +sub _perl_version { + my $self = shift; + my %hash = @_; + + my $perl; + my $tmpl = { + perl => { required => 1, store => \$perl }, + }; + + check( $tmpl, \%hash ) or return; + + my $perl_version; + ### special perl, or the one we are running under? + if( $perl eq $^X ) { + ### just load the config + require Config; + $perl_version = $Config::Config{version}; + + } else { + my $cmd = $perl . + ' -MConfig -eprint+Config::config_vars+version'; + ($perl_version) = (`$cmd` =~ /version='(.*)'/); + } + + return $perl_version if defined $perl_version; + return; +} + +=pod + +=head2 $cb->_version_to_number( version => $version ); + +Returns a proper module version, or '0.0' if none was available. + +=cut + +sub _version_to_number { + my $self = shift; + my %hash = @_; + + my $version; + my $tmpl = { + version => { default => '0.0', store => \$version }, + }; + + check( $tmpl, \%hash ) or return; + + return $version if $version =~ /^\.?\d/; + return '0.0'; +} + +=pod + +=head2 $cb->_whoami + +Returns the name of the subroutine you're currently in. + +=cut + +sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name } + +=pod + +=head2 _get_file_contents( file => $file ); + +Returns the contents of a file + +=cut + +sub _get_file_contents { + my $self = shift; + my %hash = @_; + + my $file; + my $tmpl = { + file => { required => 1, store => \$file } + }; + + check( $tmpl, \%hash ) or return; + + my $fh = OPEN_FILE->($file) or return; + my $contents = do { local $/; <$fh> }; + + return $contents; +} + +=pod $cb->_move( from => $file|$dir, to => $target ); + +Moves a file or directory to the target. + +Returns true on success, false on failure. + +=cut + +sub _move { + my $self = shift; + my %hash = @_; + + my $from; my $to; + my $tmpl = { + file => { required => 1, allow => [IS_FILE,IS_DIR], + store => \$from }, + to => { required => 1, store => \$to } + }; + + check( $tmpl, \%hash ) or return; + + if( File::Copy::move( $from, $to ) ) { + return 1; + } else { + error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!)); + return; + } +} + +=pod $cb->_copy( from => $file|$dir, to => $target ); + +Moves a file or directory to the target. + +Returns true on success, false on failure. + +=cut + +sub _copy { + my $self = shift; + my %hash = @_; + + my($from,$to); + my $tmpl = { + file =>{ required => 1, allow => [IS_FILE,IS_DIR], + store => \$from }, + to => { required => 1, store => \$to } + }; + + check( $tmpl, \%hash ) or return; + + if( File::Copy::copy( $from, $to ) ) { + return 1; + } else { + error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!)); + return; + } +} + +=head2 $cb->_mode_plus_w( file => '/path/to/file' ); + +Sets the +w bit for the file. + +Returns true on success, false on failure. + +=cut + +sub _mode_plus_w { + my $self = shift; + my %hash = @_; + + require File::stat; + + my $file; + my $tmpl = { + file => { required => 1, allow => IS_FILE, store => \$file }, + }; + + check( $tmpl, \%hash ) or return; + + ### set the mode to +w for a file and +wx for a dir + my $x = File::stat::stat( $file ); + my $mask = -d $file ? 0100 : 0200; + + if( $x and chmod( $x->mode|$mask, $file ) ) { + return 1; + + } else { + error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!)); + return; + } +} + +=head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH ); + +Turns a CPANPLUS::Config style C<host> entry into an URI string. + +Returns the uri on success, and false on failure + +=cut + +sub _host_to_uri { + my $self = shift; + my %hash = @_; + + my($scheme, $host, $path); + my $tmpl = { + scheme => { required => 1, store => \$scheme }, + host => { default => '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) = @_; + + s/_//g foreach $x, $y; + + return $x <=> $y; +} + +=head2 $cb->_home_dir + +Returns the user's homedir, or C<cwd> if it could not be found + +=cut + +sub _home_dir { + my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN ); + + for my $env ( @os_home_envs ) { + next unless exists $ENV{ $env }; + next unless defined $ENV{ $env } && length $ENV{ $env }; + return $ENV{ $env } if -d $ENV{ $env }; + } + + return cwd(); +} + +=head2 $path = $cb->_safe_path( path => $path ); + +Returns a path that's safe to us on Win32 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 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 + +{ 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; + + + ### 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; + + 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: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Utils/Autoflush.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Utils/Autoflush.pm new file mode 100755 index 00000000000..56566436a14 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Utils/Autoflush.pm @@ -0,0 +1,5 @@ +package CPANPLUS::Internals::Utils::Autoflush; + +BEGIN { $|++ }; + +1; |