summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPANPLUS/Internals
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Internals')
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants.pm391
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants/Report.pm426
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm247
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm476
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm696
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Search.pm367
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm1470
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm381
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite.pm383
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm143
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm680
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils/Autoflush.pm9
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;