diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Internals')
12 files changed, 0 insertions, 5669 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants.pm deleted file mode 100644 index 09501c78e84..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants.pm +++ /dev/null @@ -1,391 +0,0 @@ -package CPANPLUS::Internals::Constants; -use deprecate; - -use strict; - -use CPANPLUS::Error; - -use Config; -use File::Spec; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -require Exporter; -use vars qw[$VERSION @ISA @EXPORT]; - -use Package::Constants; - -$VERSION = "0.9135"; -@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 META_JSON => sub { return @_ - ? File::Spec->catfile( @_, 'META.json' ) - : 'META.json'; - }; - -use constant MYMETA_JSON => sub { return @_ - ? File::Spec->catfile( @_, 'MYMETA.json' ) - : 'MYMETA.json'; - }; - -use constant BLIB => sub { return @_ - ? File::Spec->catfile(@_, 'blib') - : 'blib'; - }; - -use constant LIB => 'lib'; -use constant LIB_DIR => sub { return @_ - ? File::Spec->catdir(@_, LIB) - : LIB; - }; -use constant AUTO => 'auto'; -use constant LIB_AUTO_DIR => sub { return @_ - ? File::Spec->catdir(@_, LIB, AUTO) - : File::Spec->catdir(LIB, AUTO) - }; -use constant ARCH => 'arch'; -use constant ARCH_DIR => sub { return @_ - ? File::Spec->catdir(@_, ARCH) - : ARCH; - }; -use constant ARCH_AUTO_DIR => sub { return @_ - ? File::Spec->catdir(@_,ARCH,AUTO) - : File::Spec->catdir(ARCH,AUTO) - }; - -use constant BLIB_LIBDIR => sub { return @_ - ? File::Spec->catdir( - @_, BLIB->(), LIB ) - : File::Spec->catdir( BLIB->(), LIB ); - }; - -use constant BIN => 'bin'; - -use constant SCRIPT => 'script'; - -use constant CONFIG_USER_LIB_DIR => sub { - require CPANPLUS::Internals::Utils; - LIB_DIR->( - CPANPLUS::Internals::Utils->_home_dir, - DOT_CPANPLUS - ); - }; -use constant CONFIG_USER_FILE => sub { - File::Spec->catfile( - CONFIG_USER_LIB_DIR->(), - split('::', CONFIG_USER), - ) . '.pm'; - }; -use constant CONFIG_SYSTEM_FILE => sub { - require CPANPLUS::Internals; - require File::Basename; - my $dir = File::Basename::dirname( - $INC{'CPANPLUS/Internals.pm'} - ); - - ### XXX use constants - File::Spec->catfile( - $dir, qw[Config System.pm] - ); - }; - -use constant README => sub { my $obj = $_[0]; - my $pkg = $obj->package_name; - $pkg .= '-' . $obj->package_version . - '.readme'; - return $pkg; - }; -use constant META_EXT => 'meta'; - -use constant META => sub { my $obj = $_[0]; - my $pkg = $obj->package_name; - $pkg .= '-' . $obj->package_version . - '.' . META_EXT; - return $pkg; - }; - -use constant OPEN_FILE => sub { - my($file, $mode) = (@_, ''); - my $fh; - open $fh, "$mode" . $file - or error(loc( - "Could not open file '%1': %2", - $file, $!)); - return $fh if $fh; - return; - }; - -use constant OPEN_DIR => sub { - my $dir = shift; - my $dh; - opendir $dh, $dir or error(loc( - "Could not open dir '%1': %2", $dir, $! - )); - - return $dh if $dh; - return; - }; - -use constant READ_DIR => sub { - my $dir = shift; - my $dh = OPEN_DIR->( $dir ) or return; - - ### exclude . and .. - my @files = grep { $_ !~ /^\.{1,2}/ } - readdir($dh); - - ### Remove trailing dot on VMS when - ### using VMS syntax. - if( ON_VMS ) { - s/(?<!\^)\.$// for @files; - } - - return @files; - }; - -use constant STRIP_GZ_SUFFIX - => sub { - my $file = $_[0] or return; - $file =~ s/.gz$//i; - return $file; - }; - -use constant CHECKSUMS => 'CHECKSUMS'; -use constant PGP_HEADER => '-----BEGIN PGP SIGNED MESSAGE-----'; -use constant ENV_CPANPLUS_CONFIG - => 'PERL5_CPANPLUS_CONFIG'; -use constant ENV_CPANPLUS_IS_EXECUTING - => 'PERL5_CPANPLUS_IS_EXECUTING'; -use constant DEFAULT_EMAIL => 'cpanplus@example.com'; -use constant CPANPLUS_UA => sub { ### for the version number ### - require CPANPLUS::Internals; - "CPANPLUS/$CPANPLUS::Internals::VERSION" - }; -use constant TESTERS_URL => sub { - 'http://cpantesters.org/distro/'. - uc(substr($_[0],0,1)) .'/'. $_[0] . '.yaml'; - }; -use constant TESTERS_DETAILS_URL - => sub { - 'http://cpantesters.org/distro/'. - uc(substr($_[0],0,1)) .'/'. $_[0]; - }; - -use constant CREATE_FILE_URI - => sub { - my $dir = $_[0] or return; - return $dir =~ m|^/| - ? 'file://' . $dir - : 'file:///' . $dir; - }; - -use constant EMPTY_DSLIP => ' '; - -use constant CUSTOM_AUTHOR_ID - => 'LOCAL'; - -use constant DOT_SHELL_DEFAULT_RC - => '.shell-default.rc'; - -use constant SOURCE_SQLITE_DB - => 'db.sql'; - -use constant PREREQ_IGNORE => 0; -use constant PREREQ_INSTALL => 1; -use constant PREREQ_ASK => 2; -use constant PREREQ_BUILD => 3; -use constant BOOLEANS => [0,1]; -use constant CALLING_FUNCTION - => sub { my $lvl = $_[0] || 0; - return join '::', (caller(2+$lvl))[3] - }; -use constant PERL_CORE => 'perl'; -use constant PERL_WRAPPER => 'use strict; BEGIN { my $old = select STDERR; $|++; select $old; $|++; $0 = shift(@ARGV); my $rv = do($0); die $@ if $@; }'; -use constant STORABLE_EXT => '.stored'; - -use constant GET_XS_FILES => sub { my $dir = $_[0] or return; - require File::Find; - my @files; - File::Find::find( - sub { push @files, $File::Find::name - if $File::Find::name =~ /\.xs$/i - }, $dir ); - - return @files; - }; - -use constant INSTALL_LOG_FILE - => sub { my $obj = shift or return; - my $name = $obj->name; $name =~ s/::/-/g; - $name .= '-'. $obj->version; - $name .= '-'. scalar(time) . '.log'; - return $name; - }; - -use constant ON_OLD_CYGWIN => do { ON_CYGWIN and $] < 5.008 - ? loc( - "Your perl version for %1 is too low; ". - "Require %2 or higher for this function", - $^O, '5.8.0' ) - : ''; - }; - -### XXX these 2 are probably obsolete -- check & remove; -use constant DOT_EXISTS => '.exists'; - -use constant QUOTE_PERL_ONE_LINER - => sub { my $line = shift or return; - - ### use double quotes on these systems - return qq["$line"] - if ON_WIN32 || ON_NETWARE || ON_VMS; - - ### single quotes on the rest - return qq['$line']; - }; - -1; - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants/Report.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants/Report.pm deleted file mode 100644 index dc92ec6c31d..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants/Report.pm +++ /dev/null @@ -1,426 +0,0 @@ -package CPANPLUS::Internals::Constants::Report; -use deprecate; - -use strict; -use CPANPLUS::Error; - -use File::Spec; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -require Exporter; -use vars qw[$VERSION @ISA @EXPORT]; - -use Package::Constants; - -### for the version -require CPANPLUS::Internals; - -$VERSION = "0.9135"; -@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 =~ /^$platform\b/i ) { - # beware the Mac != MAC - next if($platform eq 'Mac' && - $name !~ /^$platform\b/); - $specific++; - return 1 if - $^O =~ /^(?:$OS{$platform})$/ - } - }; - return $specific ? 0 : 1; - }; - -use constant UNSUPPORTED_OS - => sub { - my $buffer = shift or return; - if( $buffer =~ - /No support for OS|OS unsupported/im ) { - return 1; - } - return 0; - }; - -use constant PERL_VERSION_TOO_LOW - => sub { - my $buffer = shift or return; - # ExtUtils::MakeMaker format - if( $buffer =~ - /Perl .*? required--this is only .*?/m ) { - return 1; - } - # Module::Build format - if( $buffer =~ - /ERROR:( perl:)? Version .*?( of perl)? is installed, but we need version >= .*?/m ) { - return 1; - } - return 0; - }; - -use constant NO_TESTS_DEFINED - => sub { - my $buffer = shift or return; - if( $buffer =~ - /(No tests defined( for [\w:]+ extension)?\.)/ - and $buffer !~ /\*\.t/m and - $buffer !~ /test\.pl/m - ) { - return $1 - } - - return; - }; - -### what stage did the test fail? ### -use constant TEST_FAIL_STAGE - => sub { - my $buffer = shift or return; - return $buffer =~ /(MAKE [A-Z]+).*/ - ? lc $1 : - 'fetch'; - }; - - -use constant MISSING_PREREQS_LIST - => sub { - my $buffer = shift; - my $last = ( split /\[ERROR\] .+? MAKE TEST/, $buffer )[-1]; - my @list = map { s/.pm$//; s|/|::|g; $_ } - ($last =~ - m/\bCan\'t locate (\S+) in \@INC/g); - - ### make sure every missing prereq is only - ### listed once - { my %seen; - @list = grep { !$seen{$_}++ } @list - } - - return @list; - }; - -use constant MISSING_EXTLIBS_LIST - => sub { - my $buffer = shift; - my @list = - ($buffer =~ - m/No library found for -l([-\w]+)/g); - - return @list; - }; - -use constant REPORT_MESSAGE_HEADER - => sub { - my ($version, $author) = @_; - return << "."; - -Dear $author, - -This is a computer-generated error report created automatically by -CPANPLUS, version $version. Testers personal comments may appear -at the end of this report. - -. - }; - -use constant REPORT_MESSAGE_FAIL_HEADER - => sub { - my($stage, $buffer) = @_; - return << "."; - -Thank you for uploading your work to CPAN. However, it appears that -there were some problems testing your distribution. - -TEST RESULTS: - -Below is the error stack from stage '$stage': - -$buffer - -. - }; - -use constant REPORT_MESSAGE_PASS_HEADER - => sub { - my($stage, $buffer) = @_; - return << "."; - -Thank you for uploading your work to CPAN. Congratulations! -All tests were successful. - -TEST RESULTS: - -Below is the error stack from stage '$stage': - -$buffer - -. - }; - -use constant REPORT_MISSING_PREREQS - => sub { - my ($author,$email,@missing) = @_; - $author = ($author && $email) - ? "$author ($email)" - : 'Your Name Here'; - - my $modules = join "\n", @missing; - my $prereqs = join "\n", - map {"\t'$_'\t=> '0',". - " # or a minimum working version"} - @missing; - - return << "."; - -MISSING PREREQUISITES: - -It was observed that the test suite seem to fail without these modules: - -$modules - -As such, adding the prerequisite module(s) to 'PREREQ_PM' in your -Makefile.PL should solve this problem. For example: - -WriteMakefile( - AUTHOR => '$author', - ... # other information - PREREQ_PM => { -$prereqs - } -); - -Thanks! :-) - -. - }; - -use constant REPORT_MISSING_TESTS - => sub { - return << "."; -RECOMMENDATIONS: - -It would be very helpful if you could include even a simple test -script in the next release, so people can verify which platforms -can successfully install them, as well as avoid regression bugs? - -A simple 't/use.t' that says: - -#!/usr/bin/env perl -w -use strict; -use Test; -BEGIN { plan tests => 1 } - -use Your::Module::Here; ok(1); -exit; -__END__ - -would be appreciated. If you are interested in making a more robust -test suite, please see the Test::Simple, Test::More and Test::Tutorial -documentation at <http://search.cpan.org/dist/Test-Simple/>. - -Thanks! :-) - -. - }; - -use constant REPORT_LOADED_PREREQS - => sub { - my $mod = shift; - my $cb = $mod->parent; - my $prq = $mod->status->prereqs || {}; - - ### not every prereq may be coming from CPAN - ### so maybe we wont find it in our module - ### tree at all... - ### skip ones that 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 - Pod::Parser - Pod::Simple - 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/lib/CPANPLUS/Internals/Extract.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm deleted file mode 100644 index 4028aacfa70..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm +++ /dev/null @@ -1,247 +0,0 @@ -package CPANPLUS::Internals::Extract; -use deprecate; - -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'; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -local $Params::Check::VERBOSE = 1; - -=pod - -=head1 NAME - -CPANPLUS::Internals::Extract - internals for archive extraction - -=head1 SYNOPSIS - - ### for source files ### - $self->_gunzip( file => 'foo.gz', output => 'blah.txt' ); - - ### for modules/packages ### - $dir = $self->_extract( module => $modobj, - extractdir => '/some/where' ); - -=head1 DESCRIPTION - -CPANPLUS::Internals::Extract extracts compressed files for CPANPLUS. -It can do this by either a pure perl solution (preferred) with the -use of C<Archive::Tar> and C<Compress::Zlib>, or with binaries, like -C<gzip> and C<tar>. - -The flow looks like this: - - $cb->_extract - Delegate to Archive::Extract - -=head1 METHODS - -=head2 $dir = _extract( module => $modobj, [perl => '/path/to/perl', extractdir => '/path/to/extract/to', prefer_bin => BOOL, verbose => BOOL, force => BOOL] ) - -C<_extract> will take a module object and extract it to C<extractdir> -if provided, or the default location which is obtained from your -config. - -The file name is obtained by looking at C<< $modobj->status->fetch >> -and will be parsed to see if it's a tar or zip archive. - -If it's a zip archive, C<__unzip> will be called, otherwise C<__untar> -will be called. In the unlikely event the file is of neither format, -an error will be thrown. - -C<_extract> takes the following options: - -=over 4 - -=item module - -A C<CPANPLUS::Module> object. This is required. - -=item extractdir - -The directory to extract the archive to. By default this looks -something like: - /CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME - -=item prefer_bin - -A flag indicating whether you prefer a pure perl solution, ie -C<Archive::Tar> or C<Archive::Zip> respectively, or a binary solution -like C<unzip> and C<tar>. - -=item perl - -The path to the perl executable to use for any perl calls. Also used -to determine the build version directory for extraction. - -=item verbose - -Specifies whether to be verbose or not. Defaults to your corresponding -config entry. - -=item force - -Specifies whether to force the extraction or not. Defaults to your -corresponding config entry. - -=back - -All other options are passed on verbatim to C<__unzip> or C<__untar>. - -Returns the directory the file was extracted to on success and false -on failure. - -=cut - -sub _extract { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - local $Params::Check::ALLOW_UNKNOWN = 1; - - my( $mod, $verbose, $force ); - my $tmpl = { - force => { default => $conf->get_conf('force'), - store => \$force }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - prefer_bin => { default => $conf->get_conf('prefer_bin') }, - extractdir => { default => $conf->get_conf('extractdir') }, - module => { required => 1, allow => IS_MODOBJ, store => \$mod }, - perl => { default => $^X }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - ### did we already extract it ? ### - my $loc = $mod->status->extract(); - - if( $loc && !$force ) { - msg(loc("Already extracted '%1' to '%2'. ". - "Won't extract again without force", - $mod->module, $loc), $verbose); - return $loc; - } - - ### did we already fetch the file? ### - my $file = $mod->status->fetch(); - unless( -s $file ) { - error( loc( "File '%1' has zero size: cannot extract", $file ) ); - return; - } - - ### the dir to extract to ### - my $to = $args->{'extractdir'} || - File::Spec->catdir( - $conf->get_conf('base'), - $self->_perl_version( perl => $args->{'perl'} ), - $conf->_get_build('moddir'), - ); - - ### 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. Install '%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 too rigorous -- just change to +w for the owner [cpan #13358] - #chmod 0755, map { File::Spec->rel2abs( File::Spec->catdir($to, $_) ) } - # @{$ae->files}; - - for my $file ( @{$ae->files} ) { - my $path = File::Spec->rel2abs( File::Spec->catfile($to, $file) ); - - $self->_mode_plus_w( file => $path ); - } - - ### check the return value for the extracted path ### - ### Make an educated guess if we didn't get an extract_path - ### back - ### XXX apparently some people make their own dists and they - ### pack up '.' which means the leading directory is '.' - ### and only the second directory is the actual module directory - ### so, we'll have to check if our educated guess exists first, - ### then see if the extract path works.. and if nothing works... - ### well, then we really don't know. - - my $dir; - for my $try ( - File::Spec->rel2abs( - ### _safe_path must be called before catdir because catdir on - ### VMS currently will not handle the extra dots in the directories. - File::Spec->catdir( $self->_safe_path( path => $to ) , - $self->_safe_path( path => - $mod->package_name .'-'. - $mod->package_version - ) ) ) , - File::Spec->rel2abs( $ae->extract_path ), - ) { - ($dir = $try) && last if -d $try; - } - - ### test if the dir exists ### - unless( $dir && -d $dir ) { - error(loc("Unable to determine extract dir for '%1'",$mod->module)); - return; - - } else { - msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose); - - ### register where we extracted the files to, - ### also store what files were extracted - $mod->status->extract( $dir ); - $mod->status->files( $ae->files ); - } - - ### also, figure out what kind of install we're dealing with ### - $mod->get_installer_type(); - - return $mod->status->extract(); -} - -1; - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm deleted file mode 100644 index 098d1e3761f..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm +++ /dev/null @@ -1,476 +0,0 @@ -package CPANPLUS::Internals::Fetch; -use deprecate; - -use strict; - -use CPANPLUS::Error; -use CPANPLUS::Internals::Constants; - -use File::Fetch; -use File::Spec; -use Cwd qw[cwd]; -use IPC::Cmd qw[run]; -use Params::Check qw[check]; -use Module::Load::Conditional qw[can_load]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -$Params::Check::VERBOSE = 1; - -=pod - -=head1 NAME - -CPANPLUS::Internals::Fetch - internals for fetching files - -=head1 SYNOPSIS - - my $output = $cb->_fetch( - module => $modobj, - fetchdir => '/path/to/save/to', - verbose => BOOL, - force => BOOL, - ); - - $cb->_add_fail_host( host => 'foo.com' ); - $cb->_host_ok( host => 'foo.com' ); - - -=head1 DESCRIPTION - -CPANPLUS::Internals::Fetch fetches files from either ftp, http, file -or rsync mirrors. - -This is the rough flow: - - $cb->_fetch - Delegate to File::Fetch; - - -=head1 METHODS - -=cut - -=head1 $path = _fetch( module => $modobj, [fetchdir => '/path/to/save/to', fetch_from => 'scheme://path/to/fetch/from', verbose => BOOL, force => BOOL, prefer_bin => BOOL, ttl => $seconds] ) - -C<_fetch> will fetch files based on the information in a module -object. You always need a module object. If you want a fake module -object for a one-off fetch, look at C<CPANPLUS::Module::Fake>. - -C<fetchdir> is the place to save the file to. Usually this -information comes from your configuration, but you can override it -expressly if needed. - -C<fetch_from> lets you specify an URI to get this file from. If you -do not specify one, your list of configured hosts will be probed to -download the file from. - -C<force> forces a new download, even if the file already exists. - -C<verbose> simply indicates whether or not to print extra messages. - -C<prefer_bin> indicates whether you prefer the use of commandline -programs over perl modules. Defaults to your corresponding config -setting. - -C<ttl> (in seconds) indicates how long a cached copy is valid for. If -the fetch time of the local copy is within the ttl, the cached copy is -returned. Otherwise, the file is refetched. - -C<_fetch> figures out, based on the host list, what scheme to use and -from there, delegates to C<File::Fetch> do the actual fetching. - -Returns the path of the output file on success, false on failure. - -Note that you can set a C<blacklist> on certain methods in the config. -Simply add the identifying name of the method (ie, C<lwp>) to: - $conf->_set_fetch( blacklist => ['lwp'] ); - -And the C<LWP> function will be skipped by C<File::Fetch>. - -=cut - -sub _fetch { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - local $Params::Check::NO_DUPLICATES = 0; - - my ($modobj, $verbose, $force, $fetch_from, $ttl); - my $tmpl = { - module => { required => 1, allow => IS_MODOBJ, store => \$modobj }, - fetchdir => { default => $conf->get_conf('fetchdir') }, - fetch_from => { default => '', store => \$fetch_from }, - force => { default => $conf->get_conf('force'), - store => \$force }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - prefer_bin => { default => $conf->get_conf('prefer_bin') }, - ttl => { default => 0, store => \$ttl }, - }; - - - my $args = check( $tmpl, \%hash ) or return; - - ### check if we already downloaded the thing ### - if( (my $where = $modobj->status->fetch()) and not $force and not $ttl ) { - - msg(loc("Already fetched '%1' to '%2', " . - "won't fetch again without force", - $modobj->module, $where ), $verbose ); - return $where; - } - - my ($remote_file, $local_file, $local_path); - - ### build the local path to download to ### - { - $local_path = $args->{fetchdir} || - File::Spec->catdir( - $conf->get_conf('base'), - $modobj->path, - ); - - ### create the path if it doesn't exist ### - unless( -d $local_path ) { - unless( $self->_mkdir( dir => $local_path ) ) { - msg( loc("Could not create path '%1'", $local_path), $verbose); - return; - } - } - - $local_file = File::Spec->rel2abs( - File::Spec->catfile( - $local_path, - $modobj->package, - ) - ); - - ### do we already have the file? if so, can we use the cached version, - ### or do we need to refetch? - if( -e $local_file ) { - - my $unlink = 0; - my $use_cached = 0; - - ### if force is in effect, we have to refetch - if( $force ) { - $unlink++ - - ### if you provided a ttl, and it was exceeded, we'll refetch, - } elsif( $ttl and ([stat $local_file]->[9] + $ttl > time) ) { - msg(loc("Using cached file '%1' on disk; ". - "ttl (%2s) is not exceeded", - $local_file, $ttl), $verbose ); - - $use_cached++; - - ### if you provided a ttl, and the above conditional didn't match, - ### we exceeded the ttl, so we refetch - } elsif ( $ttl ) { - $unlink++; - - ### otherwise we can use the cached version - } else { - $use_cached++; - } - - if( $unlink ) { - ### some fetches will fail if the files exist already, so let's - ### delete them first - 1 while unlink $local_file; - - msg(loc("Could not delete %1, some methods may " . - "fail to force a download", $local_file), $verbose) - if -e $local_file; - - } else { - - ### store where we fetched it ### - $modobj->status->fetch( $local_file ); - - return $local_file; - } - } - } - - - ### we got a custom URI - if ( $fetch_from ) { - my $abs = $self->__file_fetch( from => $fetch_from, - to => $local_path, - verbose => $verbose ); - - unless( $abs ) { - error(loc("Unable to download '%1'", $fetch_from)); - return; - } - - ### store where we fetched it ### - $modobj->status->fetch( $abs ); - - return $abs; - - ### we will get it from one of our mirrors - } else { - ### build the remote path to download from ### - { $remote_file = File::Spec::Unix->catfile( - $modobj->path, - $modobj->package, - ); - unless( $remote_file ) { - error( loc('No remote file given for download') ); - return; - } - } - - ### see if we even have a host or a method to use to download with ### - my $found_host; - my @maybe_bad_host; - - HOST: { - ### F*CKING PIECE OF F*CKING p4 SHIT makes - ### '$File :: Fetch::SOME_VAR' - ### into a meta variable and starts substituting the file name... - ### GRAAAAAAAAAAAAAAAAAAAAAAH! - ### use ' to combat it! - - ### set up some flags for File::Fetch ### - local $File'Fetch::BLACKLIST = $conf->_get_fetch('blacklist'); - local $File'Fetch::TIMEOUT = $conf->get_conf('timeout'); - local $File'Fetch::DEBUG = $conf->get_conf('debug'); - local $File'Fetch::FTP_PASSIVE = $conf->get_conf('passive'); - local $File'Fetch::FROM_EMAIL = $conf->get_conf('email'); - local $File'Fetch::PREFER_BIN = $conf->get_conf('prefer_bin'); - local $File'Fetch::WARN = $verbose; - - - ### loop over all hosts we have ### - for my $host ( @{$conf->get_conf('hosts')} ) { - $found_host++; - - my $where; - - ### file:// uris are special and need parsing - if( $host->{'scheme'} eq 'file' ) { - - ### the full path in the native format of the OS - my $host_spec = - File::Spec->file_name_is_absolute( $host->{'path'} ) - ? $host->{'path'} - : File::Spec->rel2abs( $host->{'path'} ); - - ### there might be volumes involved on vms/win32 - if( ON_WIN32 or ON_VMS ) { - - ### now extract the volume in order to be Win32 and - ### VMS friendly. - ### 'no_file' indicates that there's no file part - ### of this path, so we only get 2 bits returned. - my ($vol, $host_path) = File::Spec->splitpath( - $host_spec, 'no_file' - ); - - ### and split up the directories - my @host_dirs = File::Spec->splitdir( $host_path ); - - ### if we got a volume we pretend its a directory for - ### the sake of the file:// url - if( defined $vol and $vol ) { - - ### D:\foo\bar needs to be encoded as D|\foo\bar - ### For details, see the following link: - ### http://en.wikipedia.org/wiki/File:// - ### The RFC doesn't seem to address Windows volume - ### descriptors but it does address VMS volume - ### descriptors, however wikipedia covers a bit of - ### history regarding win32 - $vol =~ s/:$/|/ if ON_WIN32; - - $vol =~ s/:// if ON_VMS; - - ### XXX i'm not sure what cases this is addressing. - ### this comes straight from dmq's file:// patches - ### for win32. --kane - ### According to dmq, the best summary is: - ### "if file:// urls 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/lib/CPANPLUS/Internals/Report.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm deleted file mode 100644 index c5892f93bb6..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm +++ /dev/null @@ -1,696 +0,0 @@ -package CPANPLUS::Internals::Report; -use deprecate; - -use strict; - -use CPANPLUS::Error; -use CPANPLUS::Internals::Constants; -use CPANPLUS::Internals::Constants::Report; - -use Data::Dumper; - -use Params::Check qw[check]; -use Module::Load::Conditional qw[can_load]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; -use version; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -$Params::Check::VERBOSE = 1; - -### for the version ### -require CPANPLUS::Internals; - -=head1 NAME - -CPANPLUS::Internals::Report - internals for sending test reports - -=head1 SYNOPSIS - - ### enable test reporting - $cb->configure_object->set_conf( cpantest => 1 ); - - ### set custom mx host, shouldn't normally be needed - $cb->configure_object->set_conf( cpantest_mx => 'smtp.example.com' ); - -=head1 DESCRIPTION - -This module provides all the functionality to send test reports to -C<http://testers.cpan.org> using the C<Test::Reporter> module. - -All methods will be called automatically if you have C<CPANPLUS> -configured to enable test reporting (see the C<SYNOPSIS>). - -=head1 METHODS - -=head2 $bool = $cb->_have_query_report_modules - -This function checks if all the required modules are here for querying -reports. It returns true and loads them if they are, or returns false -otherwise. - -=head2 $bool = $cb->_have_send_report_modules - -This function checks if all the required modules are here for sending -reports. It returns true and loads them if they are, or returns false -otherwise. - -=cut - -### XXX remove this list and move it into selfupdate, somehow.. -### this is dual administration -{ my $query_list = { - 'File::Fetch' => '0.13_02', - 'Parse::CPAN::Meta' => '0.0', - 'File::Temp' => '0.0', - }; - - my $send_list = { - %$query_list, - 'Test::Reporter' => '1.54', - }; - - sub _have_query_report_modules { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my $tmpl = { - verbose => { default => $conf->get_conf('verbose') }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - return can_load( modules => $query_list, verbose => $args->{verbose} ) - ? 1 - : 0; - } - - sub _have_send_report_modules { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my $tmpl = { - verbose => { default => $conf->get_conf('verbose') }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - return can_load( modules => $send_list, verbose => $args->{verbose} ) - ? 1 - : 0; - } -} - -=head2 @list = $cb->_query_report( module => $modobj, [all_versions => BOOL, verbose => BOOL] ) - -This function queries the CPAN testers database at -I<http://testers.cpan.org/> for test results of specified module objects, -module names or distributions. - -The optional argument C<all_versions> controls whether all versions of -a given distribution should be grabbed. It defaults to false -(fetching only reports for the current version). - -Returns the a list with the following data structures (for CPANPLUS -version 0.042) on success, or false on failure. The contents of the -data structure depends on what I<http://testers.cpan.org> returns, -but generally looks like this: - - { - 'grade' => 'PASS', - 'dist' => 'CPANPLUS-0.042', - 'platform' => 'i686-pld-linux-thread-multi' - 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/98316' - ... - }, - { - 'grade' => 'PASS', - 'dist' => 'CPANPLUS-0.042', - 'platform' => 'i686-linux-thread-multi' - 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99416' - ... - }, - { - 'grade' => 'FAIL', - 'dist' => 'CPANPLUS-0.042', - 'platform' => 'cygwin-multi-64int', - 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99371' - ... - }, - { - 'grade' => 'FAIL', - 'dist' => 'CPANPLUS-0.042', - 'platform' => 'i586-linux', - 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99396' - ... - }, - -The status of the test can be one of the following: -UNKNOWN, PASS, FAIL or NA (not applicable). - -=cut - -sub _query_report { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my($mod, $verbose, $all); - my $tmpl = { - module => { required => 1, allow => IS_MODOBJ, - store => \$mod }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - all_versions => { default => 0, store => \$all }, - }; - - check( $tmpl, \%hash ) or return; - - ### check if we have the modules we need for querying - return unless $self->_have_query_report_modules( verbose => 1 ); - - - ### XXX no longer use LWP here. However, that means we don't - ### automagically set proxies anymore!!! - # my $ua = LWP::UserAgent->new; - # $ua->agent( CPANPLUS_UA->() ); - # - ### set proxies if we have them ### - # $ua->env_proxy(); - - my $url = TESTERS_URL->($mod->package_name); - my $ff = File::Fetch->new( uri => $url ); - - msg( loc("Fetching: '%1'", $url), $verbose ); - - my $res = do { - my $tempdir = File::Temp::tempdir(); - my $where = $ff->fetch( to => $tempdir ); - - unless( $where ) { - error( loc( "Fetching report for '%1' failed: %2", - $url, $ff->error ) ); - return; - } - - my $fh = OPEN_FILE->( $where ); - - do { local $/; <$fh> }; - }; - - my ($aref) = eval { Parse::CPAN::Meta::Load( $res ) }; - - if( $@ ) { - error(loc("Error reading result: %1", $@)); - return; - }; - - my $dist = $mod->package_name .'-'. $mod->package_version; - my $details = TESTERS_DETAILS_URL->($mod->package_name); - - my @rv; - for my $href ( @$aref ) { - next unless $all or defined $href->{'distversion'} && - $href->{'distversion'} eq $dist; - - $href->{'details'} = $details; - - ### backwards compatibility :( - $href->{'dist'} ||= $href->{'distversion'}; - $href->{'grade'} ||= $href->{'action'} || $href->{'status'}; - - push @rv, $href; - } - - return @rv if @rv; - return; -} - -=pod - -=head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, verbose => BOOL, force => BOOL]); - -This function sends a testers report to C<cpan-testers@perl.org> for a -particular distribution. -It returns true on success, and false on failure. - -It takes the following options: - -=over 4 - -=item module - -The module object of this particular distribution - -=item buffer - -The output buffer from the 'make/make test' process - -=item failed - -Boolean indicating if the 'make/make test' went wrong - -=item save - -Boolean indicating if the report should be saved locally instead of -mailed out. If provided, this function will return the location the -report was saved to, rather than a simple boolean 'TRUE'. - -Defaults to false. - -=item address - -The email address to mail the report for. You should never need to -override this, but it might be useful for debugging purposes. - -Defaults to C<cpan-testers@perl.org>. - -=item verbose - -Boolean indicating on whether or not to be verbose. - -Defaults to your configuration settings - -=item force - -Boolean indicating whether to force the sending, even if the max -amount of reports for fails have already been reached, or if you -may already have sent it before. - -Defaults to your configuration settings - -=back - -=cut - -sub _send_report { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - ### do you even /have/ test::reporter? ### - unless( $self->_have_send_report_modules(verbose => 1) ) { - error( loc( "You don't have '%1' (or modules required by '%2') ". - "installed, you cannot report test results.", - 'Test::Reporter', 'Test::Reporter' ) ); - return; - } - - ### check arguments ### - my ($buffer, $failed, $mod, $verbose, $force, $address, $save, - $tests_skipped, $status ); - my $tmpl = { - module => { required => 1, store => \$mod, allow => IS_MODOBJ }, - buffer => { required => 1, store => \$buffer }, - failed => { required => 1, store => \$failed }, - status => { default => {}, store => \$status, strict_type => 1 }, - address => { default => CPAN_TESTERS_EMAIL, store => \$address }, - save => { default => 0, store => \$save }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - force => { default => $conf->get_conf('force'), - store => \$force }, - tests_skipped - => { default => 0, store => \$tests_skipped }, - }; - - check( $tmpl, \%hash ) or return; - - ### get the data to fill the email with ### - my $name = $mod->module; - my $dist = $mod->package_name . '-' . $mod->package_version; - my $author = $mod->author->author; - my $distfile= $mod->author->cpanid . "/" . $mod->package; - my $email = $mod->author->email || CPAN_MAIL_ACCOUNT->( $author ); - my $cp_conf = $conf->get_conf('cpantest') || ''; - my $int_ver = $CPANPLUS::Internals::VERSION; - my $cb = $mod->parent; - - - ### will be 'fetch', 'make', 'test', 'install', etc ### - my $stage = TEST_FAIL_STAGE->($buffer); - - ### determine the grade now ### - - my $grade; - ### check if this is a platform specific module ### - ### if we failed the test, there may be reasons why - ### an 'NA' might have to be instead - GRADE: { if ( $failed ) { - - - ### XXX duplicated logic between this block - ### and REPORTED_LOADED_PREREQS :( - - ### figure out if the prereqs are on CPAN at all - ### -- if not, send NA grade - ### Also, if our version of prereqs is too low, - ### -- send NA grade. - ### This is to address bug: #25327: do not count - ### as FAIL modules where prereqs are not filled - { my $prq = $mod->status->prereqs || {}; - - PREREQ: while( my($prq_name,$prq_ver) = each %$prq ) { - - # 'perl' listed as prereq - - if ( $prq_name eq 'perl' ) { - my $req_ver = eval { version->new( $prq_ver ) }; - next PREREQ unless $req_ver; - if ( version->new( $] ) < $req_ver ) { - msg(loc("'%1' requires a higher version of perl than your current ". - "version -- sending N/A grade.", $name), $verbose); - - $grade = GRADE_NA; - last GRADE; - } - next PREREQ; - } - - my $obj = $cb->module_tree( $prq_name ); - my $sub = CPANPLUS::Module->can( - 'module_is_supplied_with_perl_core' ); - - ### if we can't find the module and it's not supplied with core. - ### this addresses: #32064: NA reports generated for failing - ### tests where core prereqs are specified - ### Note that due to a bug in Module::CoreList, in some released - ### version of perl (5.8.6+ and 5.9.2-4 at the time of writing) - ### 'Config' is not recognized as a core module. See this bug: - ### http://rt.cpan.org/Ticket/Display.html?id=32155 - if( !$obj and !defined $sub->( $prq_name ) ) { - msg(loc( "Prerequisite '%1' for '%2' could not be obtained". - " from CPAN -- sending N/A grade", - $prq_name, $name ), $verbose ); - - $grade = GRADE_NA; - last GRADE; - } - - if ( !$obj ) { - my $vcore = $sub->( $prq_name ); - if ( $cb->_vcmp( $prq_ver, $vcore ) > 0 ) { - msg(loc( "Version of core module '%1' ('%2') is too low for ". - "'%3' (needs '%4') -- sending N/A grade", - $prq_name, $vcore, - $name, $prq_ver ), $verbose ); - - $grade = GRADE_NA; - last GRADE; - } - } - - if( $obj and $cb->_vcmp( $prq_ver, $obj->installed_version ) > 0 ) { - msg(loc( "Installed version of '%1' ('%2') is too low for ". - "'%3' (needs '%4') -- sending N/A grade", - $prq_name, $obj->installed_version, - $name, $prq_ver ), $verbose ); - - $grade = GRADE_NA; - last GRADE; - } - } - } - - unless( RELEVANT_TEST_RESULT->($mod) ) { - msg(loc( - "'%1' is a platform specific module, and the test results on". - " your platform are not relevant --sending N/A grade.", - $name), $verbose); - - $grade = GRADE_NA; - - } elsif ( UNSUPPORTED_OS->( $buffer ) ) { - msg(loc( - "'%1' is a platform specific module, and the test results on". - " your platform are not relevant --sending N/A grade.", - $name), $verbose); - - $grade = GRADE_NA; - - ### you 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/); - - my $capture = ( $status && defined $status->{capture} ? $status->{capture} : $buffer ); - ### the bit where we inform what went wrong - $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $capture ); - - ### was it missing prereqs? ### - if( my @missing = MISSING_PREREQS_LIST->($buffer) ) { - if(!$self->_verify_missing_prereqs( - module => $mod, - missing => \@missing - )) { - msg(loc("Not sending test report - " . - "bogus missing prerequisites report")); - return 1; - } - $message .= REPORT_MISSING_PREREQS->($author,$email,@missing); - } - - ### was it missing test files? ### - if( NO_TESTS_DEFINED->($buffer) ) { - $message .= REPORT_MISSING_TESTS->(); - } - - ### add a list of what modules have been loaded of your prereqs list - $message .= REPORT_LOADED_PREREQS->($mod); - - ### add a list of versions of toolchain modules - $message .= REPORT_TOOLCHAIN_VERSIONS->($mod); - - ### the footer - $message .= REPORT_MESSAGE_FOOTER->(); - - ### it may be another grade than fail/unknown.. may be worth noting - ### that tests got skipped, since the buffer is not added in - } elsif ( $tests_skipped ) { - $message .= REPORT_TESTS_SKIPPED->(); - } elsif( $grade eq GRADE_NA) { - - my $capture = ( $status && defined $status->{capture} ? $status->{capture} : $buffer ); - - ### add the reason for the NA to the buffer - $capture = join $/, $capture, map { - '[' . $_->tag . '] [' . $_->when . '] ' . - $_->message } ( CPANPLUS::Error->stack )[-1]; - - ### the bit where we inform what went wrong - $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $capture ); - - ### add a list of what modules have been loaded of your prereqs list - $message .= REPORT_LOADED_PREREQS->($mod); - - ### add a list of versions of toolchain modules - $message .= REPORT_TOOLCHAIN_VERSIONS->($mod); - - ### the footer - $message .= REPORT_MESSAGE_FOOTER->(); - - } elsif ( $grade eq GRADE_PASS and ( $status and defined $status->{capture} ) ) { - ### the bit where we inform what went right - $message .= REPORT_MESSAGE_PASS_HEADER->( $stage, $status->{capture} ); - - ### add a list of what modules have been loaded of your prereqs list - $message .= REPORT_LOADED_PREREQS->($mod); - - ### add a list of versions of toolchain modules - $message .= REPORT_TOOLCHAIN_VERSIONS->($mod); - - ### the footer - $message .= REPORT_MESSAGE_FOOTER->(); - - } - - msg( loc("Sending test report for '%1'", $dist), $verbose); - - ### reporter object ### - my $reporter = do { - my $args = $conf->get_conf('cpantest_reporter_args') || {}; - - unless( UNIVERSAL::isa( $args, 'HASH' ) ) { - error(loc("'%1' must be a hashref, ignoring...", - 'cpantest_reporter_args')); - $args = {}; - } - - Test::Reporter->new( - grade => $grade, - distribution => $dist, - distfile => $distfile, - via => "CPANPLUS $int_ver", - timeout => $conf->get_conf('timeout') || 60, - debug => $conf->get_conf('debug'), - %$args, - ); - }; - - ### set a custom mx, if requested - $reporter->mx( [ $conf->get_conf('cpantest_mx') ] ) - if $conf->get_conf('cpantest_mx'); - - ### set the from address ### - $reporter->from( $conf->get_conf('email') ) - if $conf->get_conf('email') !~ /\@example\.\w+$/i; - - ### give the user a chance to programatically 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/lib/CPANPLUS/Internals/Search.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Search.pm deleted file mode 100644 index 2a99dbfde30..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Search.pm +++ /dev/null @@ -1,367 +0,0 @@ -package CPANPLUS::Internals::Search; -use deprecate; - -use strict; - -use CPANPLUS::Error; -use CPANPLUS::Internals::Constants; -use CPANPLUS::Module; -use CPANPLUS::Module::Author; - -use File::Find; -use File::Spec; - -use Params::Check qw[check allow]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -$Params::Check::VERBOSE = 1; - -=pod - -=head1 NAME - -CPANPLUS::Internals::Search - internals for searching for modules - -=head1 SYNOPSIS - - my $aref = $cpan->_search_module_tree( - type => 'package', - allow => [qr/DBI/], - ); - - my $aref = $cpan->_search_author_tree( - type => 'cpanid', - data => \@old_results, - verbose => 1, - allow => [qw|KANE AUTRIJUS|], - ); - - my $aref = $cpan->_all_installed( ); - -=head1 DESCRIPTION - -The functions in this module are designed to find module(objects) -based on certain criteria and return them. - -=head1 METHODS - -=head2 _search_module_tree( type => TYPE, allow => \@regexes, [data => \@previous_results ] ) - -Searches the moduletree for module objects matching the criteria you -specify. Returns an array ref of module objects on success, and false -on failure. - -It takes the following arguments: - -=over 4 - -=item type - -This can be any of the accessors for the C<CPANPLUS::Module> objects. -This is a required argument. - -=item allow - -A set of rules, or more precisely, a list of regexes (via C<qr//> or -plain strings), that the C<type> must adhere too. You can specify as -many as you like, and it will be treated as an C<OR> search. -For an C<AND> search, see the C<data> argument. - -This is a required argument. - -=item data - -An arrayref of previous search results. This is the way to do an C<AND> -search -- C<_search_module_tree> will only search the module objects -specified in C<data> if provided, rather than the moduletree itself. - -=back - -=cut - -# Although the Params::Check solution is more graceful, it is WAY too slow. -# -# This sample script: -# -# use CPANPLUS::Backend; -# my $cb = new CPANPLUS::Backend; -# $cb->module_tree; -# my @list = $cb->search( type => 'module', allow => [qr/^Acme/] ); -# print $_->module, $/ for @list; -# -# Produced the following output using Dprof WITH params::check code -# -# Total Elapsed Time = 3.670024 Seconds -# User+System Time = 3.390373 Seconds -# Exclusive Times -# %Time ExclSec CumulS #Calls sec/call Csec/c Name -# 88.7 3.008 4.463 20610 0.0001 0.0002 Params::Check::check -# 47.4 1.610 1.610 1 1.6100 1.6100 Storable::net_pstore -# 25.6 0.869 0.737 20491 0.0000 0.0000 Locale::Maketext::Simple::_default -# _gettext -# 23.2 0.789 0.524 40976 0.0000 0.0000 Params::Check::_who_was_it -# 23.2 0.789 0.677 20610 0.0000 0.0000 Params::Check::_sanity_check -# 19.7 0.670 0.670 1 0.6700 0.6700 Storable::pretrieve -# 14.1 0.480 0.211 41350 0.0000 0.0000 Params::Check::_convert_case -# 11.5 0.390 0.256 20610 0.0000 0.0000 Params::Check::_hashdefs -# 11.5 0.390 0.255 20697 0.0000 0.0000 Params::Check::_listreqs -# 11.4 0.389 0.177 20653 0.0000 0.0000 Params::Check::_canon_key -# 10.9 0.370 0.356 20697 0.0000 0.0000 Params::Check::_hasreq -# 8.02 0.272 4.750 1 0.2723 4.7501 CPANPLUS::Internals::Search::_sear -# ch_module_tree -# 6.49 0.220 0.086 20653 0.0000 0.0000 Params::Check::_iskey -# 6.19 0.210 0.077 20488 0.0000 0.0000 Params::Check::_store_error -# 5.01 0.170 0.036 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__ -# -# and this output /without/ -# -# Total Elapsed Time = 2.803426 Seconds -# User+System Time = 2.493426 Seconds -# Exclusive Times -# %Time ExclSec CumulS #Calls sec/call Csec/c Name -# 56.9 1.420 1.420 1 1.4200 1.4200 Storable::net_pstore -# 25.6 0.640 0.640 1 0.6400 0.6400 Storable::pretrieve -# 9.22 0.230 0.096 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__ -# 7.06 0.176 0.272 1 0.1762 0.2719 CPANPLUS::Internals::Search::_sear -# ch_module_tree -# 3.21 0.080 0.098 10 0.0080 0.0098 IPC::Cmd::BEGIN -# 1.60 0.040 0.205 13 0.0031 0.0158 CPANPLUS::Internals::BEGIN -# 1.20 0.030 0.030 29 0.0010 0.0010 vars::BEGIN -# 1.20 0.030 0.117 10 0.0030 0.0117 Log::Message::BEGIN -# 1.20 0.030 0.029 9 0.0033 0.0033 CPANPLUS::Internals::Search::BEGIN -# 0.80 0.020 0.020 5 0.0040 0.0040 DynaLoader::dl_load_file -# 0.80 0.020 0.127 10 0.0020 0.0127 CPANPLUS::Module::BEGIN -# 0.80 0.020 0.389 2 0.0099 0.1944 main::BEGIN -# 0.80 0.020 0.359 12 0.0017 0.0299 CPANPLUS::Backend::BEGIN -# 0.40 0.010 0.010 30 0.0003 0.0003 Config::FETCH -# 0.40 0.010 0.010 18 0.0006 0.0005 Locale::Maketext::Simple::load_loc -# - -sub _search_module_tree { - - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my($mods,$list,$verbose,$type); - my $tmpl = { - data => { default => [], - strict_type=> 1, store => \$mods }, - allow => { required => 1, default => [ ], strict_type => 1, - store => \$list }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - type => { required => 1, allow => [CPANPLUS::Module->accessors()], - store => \$type }, - }; - - my $args = do { - ### don't check the template for sanity - ### -- we know it's good and saves a lot of performance - local $Params::Check::SANITY_CHECK_TEMPLATE = 0; - - check( $tmpl, \%hash ); - } or return; - - ### a list of module objects was supplied - if( @$mods ) { - local $Params::Check::VERBOSE = 0; - - my @rv; - for my $mod (@$mods) { - #push @rv, $mod if check( - # { $type => { allow => $list } }, - # { $type => $mod->$type() } - # ); - push @rv, $mod if allow( $mod->$type() => $list ); - - } - return \@rv; - - } else { - my @rv = $self->_source_search_module_tree( - allow => $list, - type => $type, - ); - return \@rv; - } -} - -=pod - -=head2 _search_author_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] ) - -Searches the authortree for author objects matching the criteria you -specify. Returns an array ref of author objects on success, and false -on failure. - -It takes the following arguments: - -=over 4 - -=item type - -This can be any of the accessors for the C<CPANPLUS::Module::Author> -objects. This is a required argument. - -=item allow - - -A set of rules, or more precisely, a list of regexes (via C<qr//> or -plain strings), that the C<type> must adhere too. You can specify as -many as you like, and it will be treated as an C<OR> search. -For an C<AND> search, see the C<data> argument. - -This is a required argument. - -=item data - -An arrayref of previous search results. This is the way to do an C<and> -search -- C<_search_author_tree> will only search the author objects -specified in C<data> if provided, rather than the authortree itself. - -=back - -=cut - -sub _search_author_tree { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my($authors,$list,$verbose,$type); - my $tmpl = { - data => { default => [], - strict_type=> 1, store => \$authors }, - allow => { required => 1, default => [ ], strict_type => 1, - store => \$list }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - type => { required => 1, allow => [CPANPLUS::Module::Author->accessors()], - store => \$type }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - if( @$authors ) { - local $Params::Check::VERBOSE = 0; - - my @rv; - for my $auth (@$authors) { - #push @rv, $auth if check( - # { $type => { allow => $list } }, - # { $type => $auth->$type } - # ); - push @rv, $auth if allow( $auth->$type() => $list ); - } - return \@rv; - } else { - my @rv = $self->_source_search_author_tree( - allow => $list, - type => $type, - ); - return \@rv; - } -} - -=pod - -=head2 _all_installed() - -This function returns an array ref of module objects of modules that -are installed on this system. - -=cut - -sub _all_installed { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - ### File::Find uses follow_skip => 1 by default, which doesn't die - ### on duplicates, unless they are directories or symlinks. - ### Ticket #29796 shows this code dying on Alien::WxWidgets, - ### which uses symlinks. - ### File::Find doc says to use follow_skip => 2 to ignore duplicates - ### so this will stop it from dying. - my %find_args = ( follow_skip => 2 ); - - ### File::Find uses lstat, which quietly becomes stat on win32 - ### it then uses -l _ which is not allowed by the statbuffer because - ### you did a stat, not an lstat (duh!). so don't tell win32 to - ### follow symlinks, as that will break badly - $find_args{'follow_fast'} = 1 unless ON_WIN32; - - ### never use the @INC hooks to find installed versions of - ### modules -- they're just there in case they're not on the - ### perl install, but the user shouldn't trust them for *other* - ### modules! - ### XXX CPANPLUS::inc is now obsolete, remove the calls - #local @INC = CPANPLUS::inc->original_inc; - - my %seen; my @rv; - for my $dir (@INC ) { - next if $dir eq '.'; - - ### not a directory after all - ### may be coderef or some such - next unless -d $dir; - - ### make sure to clean up the directories just in case, - ### as we're making assumptions about the length - ### This solves rt.cpan issue #19738 - - ### John M. notes: On VMS cannonpath can not currently handle - ### the $dir values that are in UNIX format. - $dir = File::Spec->canonpath( $dir ) unless ON_VMS; - - ### have to use F::S::Unix on VMS, or things will break - my $file_spec = ON_VMS ? 'File::Spec::Unix' : 'File::Spec'; - - ### XXX in some cases File::Find can actually die! - ### so be safe and wrap it in an eval. - eval { File::Find::find( - { %find_args, - wanted => sub { - - return unless /\.pm$/i; - my $mod = $File::Find::name; - - ### make sure it's in Unix format, as it - ### may be in VMS format on VMS; - $mod = VMS::Filespec::unixify( $mod ) if ON_VMS; - - $mod = substr($mod, length($dir) + 1, -3); - $mod = join '::', $file_spec->splitdir($mod); - - return if $seen{$mod}++; - - my $modobj = $self->module_tree($mod); - - ### separate return, a list context return with one '' - ### in it, is also true! - return unless $modobj; - - push @rv, $modobj; - }, - }, $dir - ) }; - - ### report the error if file::find died - error(loc("Error finding installed files in '%1': %2", $dir, $@)) if $@; - } - - return \@rv; -} - -1; - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm deleted file mode 100644 index 8f8ad7bd4c7..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm +++ /dev/null @@ -1,1470 +0,0 @@ -package CPANPLUS::Internals::Source; -use deprecate; - -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'; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -$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 - internals for updating source files - -=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 separate 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; - - my ($tot,$prce,$prc,$idx); - - if ( $args->{verbose} and local $|=1 ) { - no warnings; - $tot = scalar(split /\n/, $cont); - ($prce, $prc, $idx) = (int $tot / 25, 0, 0); - print "\t0%"; - } - - 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 ) ); - - $args->{verbose} - and ( - $idx++, - - ($idx==$prce - and ($prc+=4,$idx=0,print ".")), - - (($prc % 10) - or $idx - or print $prc,'%') - ); - - } - - $args->{verbose} - and print "\n"; - - - 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 $base = $conf->_get_mirror('base'); - - 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 ); - - my $author_tree = $self->author_tree; - - ### 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, $tot, $prce, $prc, $idx); - - if ( $args->{verbose} and local $|=1 ) { - no warnings; - $tot = scalar(split /\n/, $content); - ($prce, $prc, $idx) = (int $tot / 25, 0, 0); - print "\t0%"; - } - - for ( split /\n/, $content ) { - - ### we're still in the header -- find the amount of lines we expect - unless( $past_header ) { - - ### header has ended -- did we get the line count? - if( m|^\s*$| ) { - unless( $count ) { - error(loc("Could not determine line count from %1", $file)); - return; - } - $past_header = 1; - - ### if the line count doesn't match what we expect, bail out - ### this should address: #45644: detect broken index - } else { - $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; - } - - my @data = split /\s+/; - ### three fields expected on each line - next unless @data == 3; - - ### 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 = $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; - } - - my $dslip_mod = $dslip_tree->{ $data[0] }; - - ### adding the dslip info - 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_mod->{$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( - $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_mod->{'description'}, - dslip => $dslip, - mtime => '', - ) or error( loc( "Could not add module '%1'", $data[0] ) ); - - $args->{verbose} - and ( - $idx++, - - ($idx==$prce - and ($prc+=4,$idx=0,print ".")), - - (($prc % 10) - or $idx - or print $prc,'%') - ); - - } #for - - $args->{verbose} - and print "\n"; - - 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 maintenance'), - }], - - # 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::TIMEOUT = $conf->get_conf('timeout'); - $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 persistent 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 module 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/lib/CPANPLUS/Internals/Source/Memory.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm deleted file mode 100644 index a28532e02cd..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm +++ /dev/null @@ -1,381 +0,0 @@ -package CPANPLUS::Internals::Source::Memory; -use deprecate; - -use base 'CPANPLUS::Internals::Source'; - -use strict; - -use CPANPLUS::Error; -use CPANPLUS::Module; -use CPANPLUS::Module::Fake; -use CPANPLUS::Module::Author; -use CPANPLUS::Internals::Constants; - -use File::Fetch; -use Archive::Extract; - -use IPC::Cmd qw[can_run]; -use File::Temp qw[tempdir]; -use File::Basename qw[dirname]; -use Params::Check qw[allow check]; -use Module::Load::Conditional qw[can_load]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -$Params::Check::VERBOSE = 1; - -=head1 NAME - -CPANPLUS::Internals::Source::Memory - In memory implementation - -=cut - -### flag to show if init_trees got its' data from storable. This allows -### us to not write an existing stored file back to disk -{ my $from_storable; - - sub _init_trees { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my($path,$uptodate,$verbose,$use_stored); - my $tmpl = { - path => { default => $conf->get_conf('base'), store => \$path }, - verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, - uptodate => { required => 1, store => \$uptodate }, - use_stored => { default => 1, store => \$use_stored }, - }; - - check( $tmpl, \%hash ) or return; - - ### retrieve the stored source files ### - my $stored = $self->__memory_retrieve_source( - path => $path, - uptodate => $uptodate && $use_stored, - verbose => $verbose, - ) || {}; - - ### we got this from storable if $stored has keys.. - $from_storable = keys %$stored ? 1 : 0; - - ### set up the trees - $self->_atree( $stored->{_atree} || {} ); - $self->_mtree( $stored->{_mtree} || {} ); - - return 1; - } - - sub _standard_trees_completed { return $from_storable } - sub _custom_trees_completed { return $from_storable } - - sub _finalize_trees { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my($path,$uptodate,$verbose); - my $tmpl = { - path => { default => $conf->get_conf('base'), store => \$path }, - verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, - uptodate => { required => 1, store => \$uptodate }, - }; - - { local $Params::Check::ALLOW_UNKNOWN = 1; - check( $tmpl, \%hash ) or return; - } - - ### write the stored files to disk, so we can keep using them - ### from now on, till they become invalid - ### write them if the original sources weren't uptodate, or - ### we didn't just load storable files - $self->__memory_save_source() if !$uptodate or not $from_storable; - - return 1; - } - - ### saves current memory state - sub _save_state { - my $self = shift; - return $self->_finalize_trees( @_, uptodate => 0 ); - } -} - -sub _add_author_object { - my $self = shift; - my %hash = @_; - - my $class; - my $tmpl = { - class => { default => 'CPANPLUS::Module::Author', store => \$class }, - map { $_ => { required => 1 } } - qw[ author cpanid email ] - }; - - my $href = do { - local $Params::Check::NO_DUPLICATES = 1; - check( $tmpl, \%hash ) or return; - }; - - my $obj = $class->new( %$href, _id => $self->_id ); - - $self->author_tree->{ $href->{'cpanid'} } = $obj or return; - - return $obj; -} - -{ - my $tmpl = { - class => { default => 'CPANPLUS::Module' }, - map { $_ => { required => 1 } } qw[ - module version path comment author package description dslip mtime - ], - }; - - sub _add_module_object { - my $self = shift; - my %hash = @_; - - my $href = do { - local $Params::Check::SANITY_CHECK_TEMPLATE = 0; - check( $tmpl, \%hash ) or return; - }; - my $class = delete $href->{class}; - - my $obj = $class->new( %$href, _id => $self->_id ); - - ### Every module get's stored as a module object ### - $self->module_tree->{ $href->{module} } = $obj or return; - - return $obj; - } -} - -{ my %map = ( - _source_search_module_tree => [ module_tree => 'CPANPLUS::Module' ], - _source_search_author_tree => [ author_tree => 'CPANPLUS::Module::Author' ], - ); - - while( my($sub, $aref) = each %map ) { - no strict 'refs'; - - my($meth, $class) = @$aref; - - *$sub = sub { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my($authors,$list,$verbose,$type); - my $tmpl = { - data => { default => [], - strict_type=> 1, store => \$authors }, - allow => { required => 1, default => [ ], strict_type => 1, - store => \$list }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - type => { required => 1, allow => [$class->accessors()], - store => \$type }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - my @rv; - for my $obj ( values %{ $self->$meth } ) { - #push @rv, $auth if check( - # { $type => { allow => $list } }, - # { $type => $auth->$type } - # ); - push @rv, $obj if allow( $obj->$type() => $list ); - } - - return @rv; - } - } -} - -=pod - -=head2 $cb->__memory_retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL]) - -This method retrieves a I<storable>d tree identified by C<$name>. - -It takes the following arguments: - -=over 4 - -=item name - -The internal name for the source file to retrieve. - -=item uptodate - -A flag indicating whether the file-cache is up-to-date or not. - -=item path - -The absolute path to the directory holding the source files. - -=item verbose - -A boolean flag indicating whether or not to be verbose. - -=back - -Will get information from the config file by default. - -Returns a tree on success, false on failure. - -=cut - -sub __memory_retrieve_source { - my $self = shift; - my %hash = @_; - my $conf = $self->configure_object; - - my $tmpl = { - path => { default => $conf->get_conf('base') }, - verbose => { default => $conf->get_conf('verbose') }, - uptodate => { default => 0 }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - ### check if we can retrieve a frozen data structure with storable ### - my $storable = can_load( modules => {'Storable' => '0.0'} ) - if $conf->get_conf('storable'); - - return unless $storable; - - ### $stored is the name of the frozen data structure ### - my $stored = $self->__memory_storable_file( $args->{path} ); - - if ($storable && -e $stored && -s _ && $args->{'uptodate'}) { - msg( loc("Retrieving %1", $stored), $args->{'verbose'} ); - - my $href = Storable::retrieve($stored); - return $href; - } else { - return; - } -} - -=pod - -=head2 $cb->__memory_save_source([verbose => BOOL, path => $path]) - -This method saves all the parsed trees in I<storable>d format if -C<Storable> is available. - -It takes the following arguments: - -=over 4 - -=item path - -The absolute path to the directory holding the source files. - -=item verbose - -A boolean flag indicating whether or not to be verbose. - -=back - -Will get information from the config file by default. - -Returns true on success, false on failure. - -=cut - -sub __memory_save_source { - my $self = shift; - my %hash = @_; - my $conf = $self->configure_object; - - - my $tmpl = { - path => { default => $conf->get_conf('base'), allow => DIR_EXISTS }, - verbose => { default => $conf->get_conf('verbose') }, - force => { default => 1 }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - my $aref = [qw[_mtree _atree]]; - - ### check if we can retrieve a frozen data structure with storable ### - my $storable; - $storable = can_load( modules => {'Storable' => '0.0'} ) - if $conf->get_conf('storable'); - return unless $storable; - - my $to_write = {}; - foreach my $key ( @$aref ) { - next unless ref( $self->$key ); - $to_write->{$key} = $self->$key; - } - - return unless keys %$to_write; - - ### $stored is the name of the frozen data structure ### - my $stored = $self->__memory_storable_file( $args->{path} ); - - if (-e $stored && not -w $stored) { - msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} ); - return; - } - - msg( loc("Writing compiled source information to disk. This might take a little while."), - $args->{'verbose'} ); - - my $flag; - unless( Storable::nstore( $to_write, $stored ) ) { - error( loc("could not store %1!", $stored) ); - $flag++; - } - - return $flag ? 0 : 1; -} - -sub __memory_storable_file { - my $self = shift; - my $conf = $self->configure_object; - my $path = shift or return; - - ### check if we can retrieve a frozen data structure with storable ### - my $storable = $conf->get_conf('storable') - ? can_load( modules => {'Storable' => '0.0'} ) - : 0; - - return unless $storable; - - ### $stored is the name of the frozen data structure ### - ### changed to use File::Spec->catfile -jmb - my $stored = File::Spec->rel2abs( - File::Spec->catfile( - $path, #base dir - $conf->_get_source('stored') #file - . '.s' . - $Storable::VERSION #the version of storable - . '.c' . - $self->VERSION #the version of CPANPLUS - . STORABLE_EXT #append a suffix - ) - ); - - return $stored; -} - - - - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - -1; diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite.pm deleted file mode 100644 index 50f82f485c9..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite.pm +++ /dev/null @@ -1,383 +0,0 @@ -package CPANPLUS::Internals::Source::SQLite; -use deprecate; - -use strict; -use warnings; - -use base 'CPANPLUS::Internals::Source'; - -use CPANPLUS::Error; -use CPANPLUS::Internals::Constants; -use CPANPLUS::Internals::Source::SQLite::Tie; - -use Data::Dumper; -use DBIx::Simple; -use DBD::SQLite; - -use Params::Check qw[allow check]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -use constant TXN_COMMIT => 1000; - -=head1 NAME - -CPANPLUS::Internals::Source::SQLite - SQLite implementation - -=cut - -{ my $Dbh; - my $DbFile; - - sub __sqlite_file { - return $DbFile if $DbFile; - - my $self = shift; - my $conf = $self->configure_object; - - $DbFile = File::Spec->catdir( - $conf->get_conf('base'), - SOURCE_SQLITE_DB - ); - - return $DbFile; - }; - - sub __sqlite_dbh { - return $Dbh if $Dbh; - - my $self = shift; - $Dbh = DBIx::Simple->connect( - "dbi:SQLite:dbname=" . $self->__sqlite_file, - '', '', - { AutoCommit => 1 } - ); - #$Dbh->dbh->trace(1); - $Dbh->query(qq{PRAGMA synchronous = OFF}); - - return $Dbh; - }; - - sub __sqlite_disconnect { - return unless $Dbh; - $Dbh->disconnect; - $Dbh = undef; - return; - } -} - -{ my $used_old_copy = 0; - - sub _init_trees { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my($path,$uptodate,$verbose,$use_stored); - my $tmpl = { - path => { default => $conf->get_conf('base'), store => \$path }, - verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, - uptodate => { required => 1, store => \$uptodate }, - use_stored => { default => 1, store => \$use_stored }, - }; - - check( $tmpl, \%hash ) or return; - - ### if it's not uptodate, or the file doesn't exist, we need to create - ### a new sqlite db - if( not $uptodate or not -e $self->__sqlite_file ) { - $used_old_copy = 0; - - ### chuck the file - $self->__sqlite_disconnect; - 1 while unlink $self->__sqlite_file; - - ### and create a new one - $self->__sqlite_create_db or do { - error(loc("Could not create new SQLite DB")); - return; - } - } else { - $used_old_copy = 1; - } - - ### set up the author tree - { my %at; - tie %at, 'CPANPLUS::Internals::Source::SQLite::Tie', - dbh => $self->__sqlite_dbh, table => 'author', - key => 'cpanid', cb => $self; - - $self->_atree( \%at ); - } - - ### set up the author tree - { my %mt; - tie %mt, 'CPANPLUS::Internals::Source::SQLite::Tie', - dbh => $self->__sqlite_dbh, table => 'module', - key => 'module', cb => $self; - - $self->_mtree( \%mt ); - } - - ### start a transaction - $self->__sqlite_dbh->query('BEGIN'); - - return 1; - - } - - sub _standard_trees_completed { return $used_old_copy } - sub _custom_trees_completed { return } - ### finish transaction - sub _finalize_trees { $_[0]->__sqlite_dbh->commit; return 1 } - - ### saves current memory state, but not implemented in sqlite - sub _save_state { - error(loc("%1 has not implemented writing state to disk", __PACKAGE__)); - return; - } -} - -{ my $txn_count = 0; - - ### XXX move this outside the sub, so we only compute it once - my $class; - my @keys = qw[ author cpanid email ]; - my $tmpl = { - class => { default => 'CPANPLUS::Module::Author', store => \$class }, - map { $_ => { required => 1 } } @keys - }; - - ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually - my $ph = join ',', map { '?' } @keys; - - - sub _add_author_object { - my $self = shift; - my %hash = @_; - my $dbh = $self->__sqlite_dbh; - - my $href = do { - local $Params::Check::NO_DUPLICATES = 1; - local $Params::Check::SANITY_CHECK_TEMPLATE = 0; - check( $tmpl, \%hash ) or return; - }; - - ### keep counting how many we inserted - unless( ++$txn_count % TXN_COMMIT ) { - #warn "Committing transaction $txn_count"; - $dbh->commit or error( $dbh->error ); # commit previous transaction - $dbh->begin_work or error( $dbh->error ); # and start a new one - } - - $dbh->query( - "INSERT INTO author (". join(',',keys(%$href)) .") VALUES ($ph)", - values %$href - ) or do { - error( $dbh->error ); - return; - }; - - return 1; - } -} - -{ my $txn_count = 0; - - ### XXX move this outside the sub, so we only compute it once - my $class; - my @keys = qw[ module version path comment author package description dslip mtime ]; - my $tmpl = { - class => { default => 'CPANPLUS::Module', store => \$class }, - map { $_ => { required => 1 } } @keys - }; - - ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually - my $ph = join ',', map { '?' } @keys; - - sub _add_module_object { - my $self = shift; - my %hash = @_; - my $dbh = $self->__sqlite_dbh; - - my $href = do { - local $Params::Check::NO_DUPLICATES = 1; - local $Params::Check::SANITY_CHECK_TEMPLATE = 0; - check( $tmpl, \%hash ) or return; - }; - - ### fix up author to be 'plain' string - $href->{'author'} = $href->{'author'}->cpanid; - - ### keep counting how many we inserted - unless( ++$txn_count % TXN_COMMIT ) { - #warn "Committing transaction $txn_count"; - $dbh->commit or error( $dbh->error ); # commit previous transaction - $dbh->begin_work or error( $dbh->error ); # and start a new one - } - - $dbh->query( - "INSERT INTO module (". join(',',keys(%$href)) .") VALUES ($ph)", - values %$href - ) or do { - error( $dbh->error ); - return; - }; - - return 1; - } -} - -{ my %map = ( - _source_search_module_tree - => [ module => module => 'CPANPLUS::Module' ], - _source_search_author_tree - => [ author => cpanid => 'CPANPLUS::Module::Author' ], - ); - - while( my($sub, $aref) = each %map ) { - no strict 'refs'; - - my($table, $key, $class) = @$aref; - *$sub = sub { - my $self = shift; - my %hash = @_; - - my($list,$type); - my $tmpl = { - allow => { required => 1, default => [ ], strict_type => 1, - store => \$list }, - type => { required => 1, allow => [$class->accessors()], - store => \$type }, - }; - - check( $tmpl, \%hash ) or return; - - - ### we aliased 'module' to 'name', so change that here too - $type = 'module' if $type eq 'name'; - - my $meth = $table .'_tree'; - - { - my $throw = $self->$meth; - } - - my $dbh = $self->__sqlite_dbh; - my $res = $dbh->query( "SELECT * from $table" ); - - my @rv = map { $self->$meth( $_->{$key} ) } - grep { allow( $_->{$type} => $list ) } $res->hashes; - - return @rv; - } - } -} - - - -sub __sqlite_create_db { - my $self = shift; - my $dbh = $self->__sqlite_dbh; - - ### we can ignore the result/error; not all sqlite implementations - ### support this - $dbh->query( qq[ - DROP TABLE IF EXISTS author; - \n] - ) or do { - msg( $dbh->error ); - }; - $dbh->query( qq[ - DROP TABLE IF EXISTS module; - \n] - ) or do { - msg( $dbh->error ); - }; - - - - $dbh->query( qq[ - /* the author information */ - CREATE TABLE author ( - id INTEGER PRIMARY KEY AUTOINCREMENT, - - author varchar(255), - email varchar(255), - cpanid varchar(255) - ); - \n] - - ) or do { - error( $dbh->error ); - return; - }; - - $dbh->query( qq[ - /* the module information */ - CREATE TABLE module ( - id INTEGER PRIMARY KEY AUTOINCREMENT, - - module varchar(255), - version varchar(255), - path varchar(255), - comment varchar(255), - author varchar(255), - package varchar(255), - description varchar(255), - dslip varchar(255), - mtime varchar(255) - ); - - \n] - - ) or do { - error( $dbh->error ); - return; - }; - - $dbh->query( qq[ - /* the module index */ - CREATE INDEX IX_module_module ON module ( - module - ); - - \n] - - ) or do { - error( $dbh->error ); - return; - }; - - $dbh->query( qq[ - /* the version index */ - CREATE INDEX IX_module_version ON module ( - version - ); - - \n] - - ) or do { - error( $dbh->error ); - return; - }; - - $dbh->query( qq[ - /* the module-version index */ - CREATE INDEX IX_module_module_version ON module ( - module, version - ); - - \n] - - ) or do { - error( $dbh->error ); - return; - }; - - return 1; -} - -1; diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm deleted file mode 100644 index b44b04bd58e..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm +++ /dev/null @@ -1,143 +0,0 @@ -package CPANPLUS::Internals::Source::SQLite::Tie; -use deprecate; - -use strict; -use warnings; - -use CPANPLUS::Error; -use CPANPLUS::Module; -use CPANPLUS::Module::Fake; -use CPANPLUS::Module::Author::Fake; -use CPANPLUS::Internals::Constants; - -use Params::Check qw[check]; -use Module::Load::Conditional qw[can_load]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -use vars qw[@ISA $VERSION]; -$VERSION = "0.9135"; - -require Tie::Hash; -push @ISA, 'Tie::StdHash'; - - -sub TIEHASH { - my $class = shift; - my %hash = @_; - - my $tmpl = { - dbh => { required => 1 }, - table => { required => 1 }, - key => { required => 1 }, - cb => { required => 1 }, - offset => { default => 0 }, - }; - - my $args = check( $tmpl, \%hash ) or return; - my $obj = bless { %$args, store => {} } , $class; - - return $obj; -} - -sub FETCH { - my $self = shift; - my $key = shift or return; - my $dbh = $self->{dbh}; - my $cb = $self->{cb}; - my $table = $self->{table}; - - - ### did we look this one up before? - if( my $obj = $self->{store}->{$key} ) { - return $obj; - } - - my $res = $dbh->query( - "SELECT * from $table where $self->{key} = ?", $key - ) or do { - error( $dbh->error ); - return; - }; - - my $href = $res->hash; - - ### get rid of the primary key - delete $href->{'id'}; - - ### no results? - return unless keys %$href; - - ### expand author if needed - ### XXX no longer generic :( - if( $table eq 'module' ) { - $href->{author} = $cb->author_tree( $href->{author } ) or return; - } - - my $class = { - module => 'CPANPLUS::Module', - author => 'CPANPLUS::Module::Author', - }->{ $table }; - - my $obj = $self->{store}->{$key} = $class->new( %$href, _id => $cb->_id ); - - return $obj; -} - -sub STORE { - my $self = shift; - my $key = shift; - my $val = shift; - - $self->{store}->{$key} = $val; -} - -1; - -sub FIRSTKEY { - my $self = shift; - my $dbh = $self->{'dbh'}; - - my $res = $dbh->query( - "select $self->{key} from $self->{table} order by $self->{key} limit 1" - ); - - $self->{offset} = 0; - - my $key = $res->flat->[0]; - - return $key; -} - -sub NEXTKEY { - my $self = shift; - my $dbh = $self->{'dbh'}; - - my $res = $dbh->query( - "select $self->{key} from $self->{table} ". - "order by $self->{key} limit 1 offset $self->{offset}" - ); - - $self->{offset} +=1; - - my $key = $res->flat->[0]; - my $val = $self->FETCH( $key ); - - ### use each() semantics - return wantarray ? ( $key, $val ) : $key; -} - -sub EXISTS { !!$_[0]->FETCH( $_[1] ) } - -sub SCALAR { - my $self = shift; - my $dbh = $self->{'dbh'}; - - my $res = $dbh->query( "select count(*) from $self->{table}" ); - - return $res->flat; -} - -### intentionally left blank -sub DELETE { } -sub CLEAR { } - diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm deleted file mode 100644 index 58ece81ee6a..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm +++ /dev/null @@ -1,680 +0,0 @@ -package CPANPLUS::Internals::Utils; -use deprecate; - -use strict; - -use CPANPLUS::Error; -use CPANPLUS::Internals::Constants; - -use Cwd qw[chdir cwd]; -use File::Copy; -use Params::Check qw[check]; -use Module::Load::Conditional qw[can_load]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; -use version; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -local $Params::Check::VERBOSE = 1; - -=pod - -=head1 NAME - -CPANPLUS::Internals::Utils - convenience functions for CPANPLUS - -=head1 SYNOPSIS - - my $bool = $cb->_mkdir( dir => 'blah' ); - my $bool = $cb->_chdir( dir => 'blah' ); - my $bool = $cb->_rmdir( dir => 'blah' ); - - my $bool = $cb->_move( from => '/some/file', to => '/other/file' ); - my $bool = $cb->_move( from => '/some/dir', to => '/other/dir' ); - - my $cont = $cb->_get_file_contents( file => '/path/to/file' ); - - - my $version = $cb->_perl_version( perl => $^X ); - -=head1 DESCRIPTION - -C<CPANPLUS::Internals::Utils> holds a few convenience functions for -CPANPLUS libraries. - -=head1 METHODS - -=head2 $cb->_mkdir( dir => '/some/dir' ) - -C<_mkdir> creates a full path to a directory. - -Returns true on success, false on failure. - -=cut - -sub _mkdir { - my $self = shift; - - my %hash = @_; - - my $tmpl = { - dir => { required => 1 }, - }; - - my $args = check( $tmpl, \%hash ) or ( - error(loc( Params::Check->last_error ) ), return - ); - - unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { - error( loc("Could not use File::Path! This module should be core!") ); - return; - } - - eval { File::Path::mkpath($args->{dir}) }; - - if($@) { - chomp($@); - error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ )); - return; - } - - return 1; -} - -=pod - -=head2 $cb->_chdir( dir => '/some/dir' ) - -C<_chdir> changes directory to a dir. - -Returns true on success, false on failure. - -=cut - -sub _chdir { - my $self = shift; - my %hash = @_; - - my $tmpl = { - dir => { required => 1, allow => DIR_EXISTS }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - unless( chdir $args->{dir} ) { - error( loc(q[Could not chdir into '%1'], $args->{dir}) ); - return; - } - - return 1; -} - -=pod - -=head2 $cb->_rmdir( dir => '/some/dir' ); - -Removes a directory completely, even if it is non-empty. - -Returns true on success, false on failure. - -=cut - -sub _rmdir { - my $self = shift; - my %hash = @_; - - my $tmpl = { - dir => { required => 1, allow => IS_DIR }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { - error( loc("Could not use File::Path! This module should be core!") ); - return; - } - - eval { File::Path::rmtree($args->{dir}) }; - - if($@) { - chomp($@); - error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ )); - return; - } - - return 1; -} - -=pod - -=head2 $cb->_perl_version ( perl => 'some/perl/binary' ); - -C<_perl_version> returns the version of a certain perl binary. -It does this by actually running a command. - -Returns the perl version on success and false on failure. - -=cut - -sub _perl_version { - my $self = shift; - my %hash = @_; - - my $perl; - my $tmpl = { - perl => { required => 1, store => \$perl }, - }; - - check( $tmpl, \%hash ) or return; - - my $perl_version; - ### special perl, or the one we are running under? - if( $perl eq $^X ) { - ### just load the config - require Config; - $perl_version = $Config::Config{version}; - - } else { - my $cmd = $perl . - ' -MConfig -eprint+Config::config_vars+version'; - ($perl_version) = (`$cmd` =~ /version='(.*)'/); - } - - return $perl_version if defined $perl_version; - return; -} - -=pod - -=head2 $cb->_version_to_number( version => $version ); - -Returns a proper module version, or '0.0' if none was available. - -=cut - -sub _version_to_number { - my $self = shift; - my %hash = @_; - - my $version; - my $tmpl = { - version => { default => '0.0', store => \$version }, - }; - - check( $tmpl, \%hash ) or return; - - $version =~ s!_!!g; # *sigh* - return $version if $version =~ /^\d*(?:\.\d+)?$/; - if ( my ($vers) = $version =~ /^(v?\d+(?:\.\d+(?:\.\d+)?)?)/ ) { - return eval { version->parse($vers)->numify }; - } - return '0.0'; -} - -=pod - -=head2 $cb->_whoami - -Returns the name of the subroutine you're currently in. - -=cut - -sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name } - -=pod - -=head2 _get_file_contents( file => $file ); - -Returns the contents of a file - -=cut - -sub _get_file_contents { - my $self = shift; - my %hash = @_; - - my $file; - my $tmpl = { - file => { required => 1, store => \$file } - }; - - check( $tmpl, \%hash ) or return; - - my $fh = OPEN_FILE->($file) or return; - my $contents = do { local $/; <$fh> }; - - return $contents; -} - -=pod - -=head2 $cb->_move( from => $file|$dir, to => $target ); - -Moves a file or directory to the target. - -Returns true on success, false on failure. - -=cut - -sub _move { - my $self = shift; - my %hash = @_; - - my $from; my $to; - my $tmpl = { - file => { required => 1, allow => [IS_FILE,IS_DIR], - store => \$from }, - to => { required => 1, store => \$to } - }; - - check( $tmpl, \%hash ) or return; - - if( File::Copy::move( $from, $to ) ) { - return 1; - } else { - error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!)); - return; - } -} - -=pod - -=head2 $cb->_copy( from => $file|$dir, to => $target ); - -Moves a file or directory to the target. - -Returns true on success, false on failure. - -=cut - -sub _copy { - my $self = shift; - my %hash = @_; - - my($from,$to); - my $tmpl = { - file =>{ required => 1, allow => [IS_FILE,IS_DIR], - store => \$from }, - to => { required => 1, store => \$to } - }; - - check( $tmpl, \%hash ) or return; - - if( File::Copy::copy( $from, $to ) ) { - return 1; - } else { - error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!)); - return; - } -} - -=head2 $cb->_mode_plus_w( file => '/path/to/file' ); - -Sets the +w bit for the file. - -Returns true on success, false on failure. - -=cut - -sub _mode_plus_w { - my $self = shift; - my %hash = @_; - - require File::stat; - - my $file; - my $tmpl = { - file => { required => 1, allow => IS_FILE, store => \$file }, - }; - - check( $tmpl, \%hash ) or return; - - ### set the mode to +w for a file and +wx for a dir - my $x = File::stat::stat( $file ); - my $mask = -d $file ? 0100 : 0200; - - if( $x and chmod( $x->mode|$mask, $file ) ) { - return 1; - - } else { - error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!)); - return; - } -} - -=head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH ); - -Turns a CPANPLUS::Config style C<host> entry into an URI string. - -Returns the uri on success, and false on failure - -=cut - -sub _host_to_uri { - my $self = shift; - my %hash = @_; - - my($scheme, $host, $path); - my $tmpl = { - scheme => { required => 1, store => \$scheme }, - host => { default => 'localhost', store => \$host }, - path => { default => '', store => \$path }, - }; - - check( $tmpl, \%hash ) or return; - - ### it's an URI, so unixify the path. - ### VMS has a special method for just that - $path = ON_VMS - ? VMS::Filespec::unixify($path) - : File::Spec::Unix->catdir( File::Spec->splitdir( $path ) ); - - return "$scheme://" . File::Spec::Unix->catdir( $host, $path ); -} - -=head2 $cb->_vcmp( VERSION, VERSION ); - -Normalizes the versions passed and does a '<=>' on them, returning the result. - -=cut - -sub _vcmp { - my $self = shift; - my ($x, $y) = @_; - - $x = $self->_version_to_number(version => $x); - $y = $self->_version_to_number(version => $y); - - return $x <=> $y; -} - -=head2 $cb->_home_dir - -Returns the user's homedir, or C<cwd> if it could not be found - -=cut - -sub _home_dir { - - if ( can_load( modules => { 'File::HomeDir' => 0.0 } ) ) { - if ( defined $ENV{APPDATA} && length $ENV{APPDATA} && !ON_WIN32 ) { - msg("'APPDATA' env var is set and not on MSWin32, " . - "please use 'PERL5_CPANPLUS_HOME' instead to change .cpanplus location", 1 ); - } - return File::HomeDir->my_home if -d File::HomeDir->my_home; - } - - my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN ); - - for my $env ( @os_home_envs ) { - next unless exists $ENV{ $env }; - next unless defined $ENV{ $env } && length $ENV{ $env }; - return $ENV{ $env } if -d $ENV{ $env }; - } - - return cwd(); -} - -=head2 $path = $cb->_safe_path( path => $path ); - -Returns a path that's safe to us on Win32 and VMS. - -Only cleans up the path on Win32 if the path exists. - -On VMS, it encodes dots to _ using C<VMS::Filespec::vmsify> - -=cut - -sub _safe_path { - my $self = shift; - - my %hash = @_; - - my $path; - my $tmpl = { - path => { required => 1, store => \$path }, - }; - - check( $tmpl, \%hash ) or return; - - if( ON_WIN32 ) { - ### only need to fix it up if there's spaces in the path - return $path unless $path =~ /\s+/; - - ### clean up paths if we are on win32 - return Win32::GetShortPathName( $path ) || $path; - - } elsif ( ON_VMS ) { - ### XXX According to John Malmberg, there's an VMS issue: - ### catdir on VMS can not currently deal with directory components - ### with dots in them. - ### Fixing this is a 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/lib/CPANPLUS/Internals/Utils/Autoflush.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils/Autoflush.pm deleted file mode 100644 index 8aa9030dfa3..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils/Autoflush.pm +++ /dev/null @@ -1,9 +0,0 @@ -package CPANPLUS::Internals::Utils::Autoflush; -use deprecate; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -BEGIN { $|++ }; - -1; |