diff options
| author | Chris 'BinGOs' Williams <chris@bingosnet.co.uk> | 2013-05-18 01:01:42 +0100 |
|---|---|---|
| committer | Ricardo Signes <rjbs@cpan.org> | 2013-05-18 15:24:51 -0400 |
| commit | fb598ba5e55920eb59105c932df653f4fea6966c (patch) | |
| tree | e6e09698d237c93f2c0b38d09b65750b66393edc | |
| parent | 664ba38731e2f5920049156e3bbc1d432b9ef080 (diff) | |
| download | perl-fb598ba5e55920eb59105c932df653f4fea6966c.tar.gz | |
Remove cpan/CPANPLUS and associated utilities
107 files changed, 17 insertions, 26607 deletions
@@ -2137,9 +2137,6 @@ make install will install the following: different versions of perl. cpan The CPAN shell. - cpan2dist The CPANPLUS distribution creator. - cpanp The CPANPLUS shell. - cpanp-run-perl A helper for cpanp. enc2xs Encoding module generator. find2perl find-to-perl translator. h2ph Extract constants and simple macros from C @@ -425,90 +425,6 @@ cpan/CPAN/PAUSE2005.pub CPAN public key cpan/CPAN/PAUSE2007.pub CPAN public key cpan/CPAN/PAUSE2009.pub CPAN public key cpan/CPAN/PAUSE2011.pub -cpan/CPANPLUS/bin/cpan2dist the cpan2dist utility -cpan/CPANPLUS/bin/cpanp the cpanp utility -cpan/CPANPLUS/bin/cpanp-run-perl the cpanp-run-perl utility -cpan/CPANPLUS/lib/CPANPLUS/Backend.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Backend/RV.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Config/HomeEnv.pm -cpan/CPANPLUS/lib/CPANPLUS/Config.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Configure.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Configure/Setup.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Dist/Autobundle.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Dist/Base.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Dist/MM.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Dist.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Dist/Sample.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Error.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/FAQ.pod CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Hacking.pod CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants/Report.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Internals/Extract.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Internals/Fetch.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Internals.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Internals/Report.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Internals/Search.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/Memory.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Internals/Source.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/SQLite.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Internals/Utils/Autoflush.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Internals/Utils.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Module/Author/Fake.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Module/Author.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Module/Checksums.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Module/Fake.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Module.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Module/Signature.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Selfupdate.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Shell/Classic.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Source.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Shell/Default.pm CPANPLUS -cpan/CPANPLUS/lib/CPANPLUS/Shell.pm CPANPLUS -cpan/CPANPLUS/Makefile.PL -cpan/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t CPANPLUS tests -cpan/CPANPLUS/t/01_CPANPLUS-Configure.t CPANPLUS tests -cpan/CPANPLUS/t/02_CPANPLUS-Internals.t CPANPLUS tests -cpan/CPANPLUS/t/03_CPANPLUS-Internals-Source.t CPANPLUS tests -cpan/CPANPLUS/t/04_CPANPLUS-Module.t CPANPLUS tests -cpan/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t CPANPLUS tests -cpan/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t CPANPLUS tests -cpan/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t CPANPLUS tests -cpan/CPANPLUS/t/08_CPANPLUS-Backend.t CPANPLUS tests -cpan/CPANPLUS/t/09_CPANPLUS-Internals-Search.t CPANPLUS tests -cpan/CPANPLUS/t/10_CPANPLUS-Error.t CPANPLUS tests -cpan/CPANPLUS/t/15_CPANPLUS-Shell.t CPANPLUS tests -cpan/CPANPLUS/t/19_CPANPLUS-Dist.t CPANPLUS tests -cpan/CPANPLUS/t/20_CPANPLUS-Dist-MM.t CPANPLUS tests -cpan/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t CPANPLUS tests -cpan/CPANPLUS/t/25_CPANPLUS.t CPANPLUS tests -cpan/CPANPLUS/t/30_CPANPLUS-Internals-Selfupdate.t CPANPLUS tests -cpan/CPANPLUS/t/40_CPANPLUS-Internals-Report.t CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.meta CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.readme CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/CHECKSUMS CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.readme CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/CHECKSUMS CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.readme CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/CHECKSUMS CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.readme CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/autobundle/Snapshot.pm CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz CPANPLUS tests -cpan/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz CPANPLUS tests -cpan/CPANPLUS/t/inc/conf.pl CPANPLUS tests cpan/CPAN/scripts/cpan easily interact with CPAN from the command line cpan/CPAN/t/01loadme.t See if CPAN the module works cpan/CPAN/t/02nox.t See if CPAN::Nox works @@ -5616,10 +5532,7 @@ util.h Dummy header utils/c2ph.PL program to translate dbx stabs to perl utils/config_data.PL Module::Build tool utils/corelist.PL Module::CoreList -utils/cpan2dist.PL the cpan2dist utility utils/cpan.PL easily interact with CPAN from the command line -utils/cpanp.PL the cpanp utility -utils/cpanp-run-perl.PL the cpanp-run-perl utility utils/enc2xs.PL Encode module generator utils/h2ph.PL A thing to turn C .h files into perl .ph files utils/h2xs.PL Program to make .xs files from C header files diff --git a/Makefile.SH b/Makefile.SH index 10bc742bfc..ad92da6750 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -1331,11 +1331,10 @@ _cleaner2: rm -f lib/ExtUtils/ParseXS/t/XSTest$(OBJ_EXT) rm -f lib/ExtUtils/ParseXS/t/XSTest$(DLSUFFIX) rm -fr lib/B - rm -fr lib/CPAN lib/CPANPLUS + rm -fr lib/CPAN rm -fr lib/ExtUtils/CBuilder rm -f pod2htmd.tmp rm -rf pod/perlfunc pod/perlipc - -rmdir cpan/CPANPLUS/t/dummy-cpanplus cpan/CPANPLUS/t/dummy-localmirror -rmdir ext/B/lib -rmdir lib/Archive/Tar lib/Archive lib/Attribute -rmdir lib/CGI lib/Carp diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 2e4a6373be..cc920e3e90 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -461,29 +461,6 @@ use File::Glob qw(:case); 'UPSTREAM' => 'cpan', }, - 'CPANPLUS' => { - 'MAINTAINER' => 'kane', - 'DISTRIBUTION' => 'BINGOS/CPANPLUS-0.9134.tar.gz', - 'FILES' => q[cpan/CPANPLUS], - 'EXCLUDED' => [ - qr{^inc/}, - qr{^t/dummy-.*\.hidden$}, - qr{^t/dummy-(cpanplus|perl|localmirror)/}, - 'bin/cpanp-boxed', - - # SQLite tests would be skipped in core, and - # the filenames are too long for VMS! - qw( t/031_CPANPLUS-Internals-Source-SQLite.t - t/032_CPANPLUS-Internals-Source-via-sqlite.t - ), - 'Makefile.PL', - ], - 'CUSTOMIZED' => ['Makefile.PL'], - 'UPSTREAM' => 'cpan', - 'BUGS' => 'bug-cpanplus@rt.cpan.org', - 'DEPRECATED' => '5.017009', - }, - 'CPAN::Meta' => { 'MAINTAINER' => 'dagolden', 'DISTRIBUTION' => 'DAGOLDEN/CPAN-Meta-2.120921.tar.gz', diff --git a/Porting/release_managers_guide.pod b/Porting/release_managers_guide.pod index 466a5c7613..7f03b69f07 100644 --- a/Porting/release_managers_guide.pod +++ b/Porting/release_managers_guide.pod @@ -930,19 +930,6 @@ Check that your perl can run this: 42 $ -=head4 Bootstrap the CPANPLUS client - -Bootstrap the CPANPLUS client on the clean install: - - $ bin/cpanp - -=head4 Install the DBI module with CPANPLUS - - CPAN Terminal> i DBI - CPAN Terminal> quit - $ bin/perl -MDBI -e 1 - $ - =head4 Make sure that perlbug works Test L<perlbug> with the following: diff --git a/README.cygwin b/README.cygwin index b2ea7bd713..0ad627fa91 100644 --- a/README.cygwin +++ b/README.cygwin @@ -664,15 +664,6 @@ be kept as clean as possible. ext/Win32CORE/Win32CORE.pm - History of Win32CORE under Cygwin lib/CGI.pm - binmode and path separator - lib/CPANPLUS/Dist/MM.pm - Commented out code that fails under Win32/Cygwin - lib/CPANPLUS/Internals/Constants/Report.pm - - OS classifications - lib/CPANPLUS/Internals/Constants.pm - - Constants for Cygwin - lib/CPANPLUS/Internals/Report.pm - - Example of Cygwin report - lib/CPANPLUS/Module.pm - - Abort if running on old Cygwin version lib/Cwd.pm - hook to internal Cwd::cwd lib/ExtUtils/CBuilder/Platform/cygwin.pm - use gcc for ld, and link to libperl.dll.a @@ -728,8 +719,6 @@ be kept as clean as possible. lib/AnyDBM_File.t lib/Archive/Extract/t/01_Archive-Extract.t lib/Archive/Tar/t/02_methods.t - lib/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t - lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t lib/ExtUtils/t/Embed.t lib/ExtUtils/t/eu_command.t lib/ExtUtils/t/MM_Cygwin.t diff --git a/configure.com b/configure.com index f3535f9cb3..259c567517 100644 --- a/configure.com +++ b/configure.com @@ -7281,10 +7281,6 @@ $ WRITE CONFIG "$ c2ph == """ + perl_setup_perl + " ''vms_prefix':[utils]c $ WRITE CONFIG "$ config_data== """ + perl_setup_perl + " ''vms_prefix':[utils]config_data.com""" $ WRITE CONFIG "$ corelist == """ + perl_setup_perl + " ''vms_prefix':[utils]corelist.com""" $ WRITE CONFIG "$ cpan == """ + perl_setup_perl + " ''vms_prefix':[utils]cpan.com""" -$ WRITE CONFIG "$ cpan2dist == """ + perl_setup_perl + " ''vms_prefix':[utils]cpan2dist.com""" -$! FIXME: "-" is an operator and illegal in a symbol name -- cpanp-run-perl can't work -$!$ WRITE CONFIG "$ cpanp-run-perl == """ + perl_setup_perl + " ''vms_prefix':[utils]cpanp-run-perl.com""" -$ WRITE CONFIG "$ cpanp == """ + perl_setup_perl + " ''vms_prefix':[utils]cpanp.com""" $ WRITE CONFIG "$ enc2xs == """ + perl_setup_perl + " ''vms_prefix':[utils]enc2xs.com""" $ WRITE CONFIG "$ find2perl == """ + perl_setup_perl + " ''vms_prefix':[utils]find2perl.com""" $ WRITE CONFIG "$ h2ph == """ + perl_setup_perl + " ''vms_prefix':[utils]h2ph.com""" diff --git a/cpan/CPANPLUS/Makefile.PL b/cpan/CPANPLUS/Makefile.PL deleted file mode 100644 index d69b40d9a0..0000000000 --- a/cpan/CPANPLUS/Makefile.PL +++ /dev/null @@ -1,11 +0,0 @@ -use strict; -use ExtUtils::MakeMaker; - -WriteMakefile ( - NAME => 'CPANPLUS', - VERSION_FROM => 'lib/CPANPLUS/Internals.pm', # finds $VERSION - EXE_FILES => ['bin/cpan2dist','bin/cpanp','bin/cpanp-run-perl'], - INSTALLDIRS => ( $] >= 5.009005 ? 'perl' : 'site' ), - AUTHOR => 'Jos Boumans <kane[at]cpan.org>', - ABSTRACT => 'Ameliorated interface to the CPAN' -); diff --git a/cpan/CPANPLUS/bin/cpan2dist b/cpan/CPANPLUS/bin/cpan2dist deleted file mode 100644 index b4fadf552b..0000000000 --- a/cpan/CPANPLUS/bin/cpan2dist +++ /dev/null @@ -1,673 +0,0 @@ -#!/usr/bin/perl -w -use strict; -use CPANPLUS::Backend; -use CPANPLUS::Dist; -use CPANPLUS::Internals::Constants; -use Data::Dumper; -use Getopt::Long; -use File::Spec; -use File::Temp qw|tempfile|; -use File::Basename; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -local $Data::Dumper::Indent = 1; - -use constant PREREQ_SKIP_CLASS => 'CPANPLUS::To::Dist::PREREQ_SKIP'; -use constant ALARM_CLASS => 'CPANPLUS::To::Dist::ALARM'; - -### print when you can -$|++; - -my $cb = CPANPLUS::Backend->new - or die loc("Could not create new CPANPLUS::Backend object"); -my $conf = $cb->configure_object; - -my %formats = map { $_ => $_ } CPANPLUS::Dist->dist_types; - -my $opts = {}; -GetOptions( $opts, - 'format=s', 'archive', - 'verbose!', 'force!', - 'skiptest!', 'keepsource!', - 'makefile!', 'buildprereq!', - 'help', 'flushcache', - 'ban=s@', 'banlist=s@', - 'ignore=s@', 'ignorelist=s@', - 'defaults', 'modulelist=s@', - 'logfile=s', 'timeout=s', - 'dist-opts=s%', 'set-config=s%', - 'default-banlist!', 'set-program=s%', - 'default-ignorelist!', 'edit-metafile!', - 'install!' - ); - -die usage() if exists $opts->{'help'}; - -### parse options -my $tarball = $opts->{'archive'} || 0; -my $keep = $opts->{'keepsource'} ? 1 : 0; -my $prereqbuild = exists $opts->{'buildprereq'} - ? $opts->{'buildprereq'} - : 0; -my $timeout = exists $opts->{'timeout'} - ? $opts->{'timeout'} - : 300; - -### use default answers? -unless ( $ENV{'PERL_MM_USE_DEFAULT'} ) { - $ENV{'PERL_MM_USE_DEFAULT'} = $opts->{'defaults'} ? 1 : 0; -} - -my $format; -### if provided, we go with the command line option, fall back to conf setting -{ $format = $opts->{'format'} || $conf->get_conf('dist_type'); - $conf->set_conf( dist_type => $format ); - - ### is this a valid format?? - die loc("Invalid format: " . ($format || "[NONE]") ) . usage() - unless $formats{$format}; - - ### any options to fix config entries - { my $set_conf = $opts->{'set-config'} || {}; - while( my($key,$val) = each %$set_conf ) { - $conf->set_conf( $key => $val ); - } - } - - ### any options to fix program entries - { my $set_prog = $opts->{'set-program'} || {}; - while( my($key,$val) = each %$set_prog ) { - $conf->set_program( $key => $val ); - } - } - - ### any other options passed - { my %map = ( verbose => 'verbose', - force => 'force', - skiptest => 'skiptest', - makefile => 'prefer_makefile' - ); - - ### set config options from arguments - while (my($key,$val) = each %map) { - my $bool = exists $opts->{$key} - ? $opts->{$key} - : $conf->get_conf($val); - $conf->set_conf( $val => $bool ); - } - } -} - -my @modules = @ARGV; -if( exists $opts->{'modulelist'} ) { - push @modules, map { parse_file( $_ ) } @{ $opts->{'modulelist'} }; -} - -die usage() unless @modules; - -### set up munge callback if requested -{ if( $opts->{'edit-metafile'} ) { - my $editor = $conf->get_program('editor'); - - if( $editor ) { - - ### register install callback ### - $cb->_register_callback( - name => 'munge_dist_metafile', - code => sub { - my $self = shift; - my $text = shift or return; - - my($fh,$file) = tempfile( UNLINK => 1 ); - - unless( print $fh $text ) { - warn "Could not print metafile information: $!"; - return; - } - - close $fh; - - system( $editor => $file ); - - my $cont = $cb->_get_file_contents( file => $file ); - - return $cont; - }, - ); - - } else { - warn "No editor configured. Can not edit metafiles!\n"; - } - } -} - -my $fh; -LOGFILE: { - if( my $file = $opts->{logfile} ) { - open $fh, ">$file" or ( - warn loc("Could not open '%1' for writing: %2", $file,$!), - last LOGFILE - ); - - warn "Logging to '$file'\n"; - - *STDERR = $fh; - *STDOUT = $fh; - } -} - -### reload indices if so desired -$cb->reload_indices() if $opts->{'flushcache'}; - -{ my @ban = exists $opts->{'ban'} - ? map { qr/$_/ } @{ $opts->{'ban'} } - : (); - - - if( exists $opts->{'banlist'} ) { - push @ban, map { parse_file( $_, 1 ) } @{ $opts->{'banlist'} }; - } - - push @ban, map { s/\s+//; $_ } - map { [split /\s*#\s*/]->[0] } - grep { /#/ } - map { split /\n/ } _default_ban_list() - if $opts->{'default-banlist'}; - - ### use our prereq install callback - $conf->set_conf( prereqs => PREREQ_ASK ); - - ### register install callback ### - $cb->_register_callback( - name => 'install_prerequisite', - code => \&__ask_about_install, - ); - - - ### check for ban patterns when handling prereqs - sub __ask_about_install { - - my $mod = shift or return; - my $prereq = shift or return; - - - ### die with an error object, so we can verify that - ### the die came from this location, and that it's an - ### 'acceptable' death - my $pat = ban_me( $prereq ); - die bless sub { loc("Module '%1' requires '%2' to be installed " . - "but found in your ban list (%3) -- skipping", - $mod->module, $prereq->module, $pat ) - }, PREREQ_SKIP_CLASS if $pat; - return 1; - } - - ### should we skip this module? - sub ban_me { - my $mod = shift; - - for my $pat ( @ban ) { - return $pat if $mod->module =~ /$pat/i; - } - return; - } -} - -### patterns to strip from prereq lists -{ my @ignore = exists $opts->{'ignore'} - ? map { qr/$_/ } @{ $opts->{'ignore'} } - : (); - - if( exists $opts->{'ignorelist'} ) { - push @ignore, map { parse_file( $_, 1 ) } @{ $opts->{'ignorelist'} }; - } - - push @ignore, map { s/\s+//; $_ } - map { [split /\s*#\s*/]->[0] } - grep { /#/ } - map { split /\n/ } _default_ignore_list() - if $opts->{'default-ignorelist'}; - - - ### register install callback ### - $cb->_register_callback( - name => 'filter_prereqs', - code => \&__filter_prereqs, - ); - - sub __filter_prereqs { - my $cb = shift; - my $href = shift; - - for my $name ( keys %$href ) { - my $obj = $cb->parse_module( module => $name ) or ( - warn "Cannot make a module object out of ". - "'$name' -- skipping\n", - next ); - - if( my $pat = ignore_me( $obj ) ) { - warn loc("'%1' found in your ignore list (%2) ". - "-- filtering it out\n", $name, $pat); - - delete $href->{ $name }; - } - } - - return $href; - } - - ### should we skip this module? - sub ignore_me { - my $mod = shift; - - for my $pat ( @ignore ) { - return $pat if $mod->module =~ /$pat/i; - return $pat if $mod->package_name =~ /$pat/i; - } - return; - } -} - - -my %done; -for my $name (@modules) { - - my $obj; - - ### is it a tarball? then we get it locally and transform it - ### and its dependencies into .debs - if( $tarball ) { - ### make sure we use an absolute path, so chdirs() dont - ### mess things up - $name = File::Spec->rel2abs( $name ); - - ### ENOTARBALL? - unless( -e $name ) { - warn loc("Archive '$name' does not exist"); - next; - } - - $obj = CPANPLUS::Module::Fake->new( - module => basename($name), - path => dirname($name), - package => basename($name), - ); - - ### if it's a traditional CPAN package, we can tidy - ### up the module name some - $obj->module( $obj->package_name ) if $obj->package_name; - - ### get the version from the package name - $obj->version( $obj->package_version || 0 ); - - ### set the location of the tarball - $obj->status->fetch($name); - - ### plain old cpan module? - } else { - - ### find the corresponding module object ### - $obj = $cb->parse_module( module => $name ) or ( - warn "Cannot make a module object out of ". - "'$name' -- skipping\n", - next ); - } - - ### you banned it? - if( my $pat = ban_me( $obj ) ) { - warn loc("'%1' found in your ban list (%2) -- skipping\n", - $obj->module, $pat ); - next; - } - - ### or just ignored it? - if( my $pat = ignore_me( $obj ) ) { - warn loc("'%1' found in your ignore list (%2) -- skipping\n", - $obj->module, $pat ); - next; - } - - - my $target = $opts->{'install'} ? 'install' : 'create'; - my $dist = eval { - local $SIG{ALRM} = sub { die bless {}, ALARM_CLASS } - if $timeout; - - alarm $timeout || 0; - - my $dist_opts = $opts->{'dist-opts'} || {}; - - my $rv = $obj->install( - prereq_target => $target, - target => $target, - keep_source => $keep, - prereq_build => $prereqbuild, - - ### any passed arbitrary options - %$dist_opts, - ); - - alarm 0; - - $rv; - }; - - ### set here again, in case the install dies - alarm 0; - - ### install failed due to a 'die' in our prereq skipper? - if( $@ and ref $@ and $@->isa( PREREQ_SKIP_CLASS ) ) { - warn loc("Dist creation of '%1' skipped: '%2'", - $obj->module, $@->() ); - next; - - } elsif ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) { - warn loc("\nDist creation of '%1' skipped, build time exceeded: ". - "%2 seconds\n", $obj->module, $timeout ); - next; - - ### died for some other reason? just report and skip - } elsif ( $@ ) { - warn loc("Dist creation of '%1' failed: '%2'", - $obj->module, $@ ); - next; - } - - ### we didn't get a dist object back? - unless ($dist and $obj->status->dist) { - warn loc("Unable to create '%1' dist of '%2'", $format, $obj->module); - next - } - - print "Created '$format' distribution for ", $obj->module, - " to:\n\t", $obj->status->dist->status->dist, "\n"; -} - - -sub parse_file { - my $file = shift or return; - my $qr = shift() ? 1 : 0; - - my $fh = OPEN_FILE->( $file ) or return; - - my @rv; - while( <$fh> ) { - chomp; - next if /^#/; # skip comments - next unless /\S/; # skip empty lines - s/^(\S+).*/$1/; # skip extra info - push @rv, $qr ? qr/$_/ : $_; # add pattern to the list - } - - return @rv; -} - -=head1 NAME - -cpan2dist - The CPANPLUS distribution creator - -=head1 DESCRIPTION - -This script will create distributions of C<CPAN> modules of the format -you specify, including its prerequisites. These packages can then be -installed using the corresponding package manager for the format. - -Note, you can also do this interactively from the default shell, -C<CPANPLUS::Shell::Default>. See the C<CPANPLUS::Dist> documentation, -as well as the documentation of your format of choice for any format -specific documentation. - -=head1 USAGE - -=cut - -sub usage { - my $me = basename($0); - my $formats = join "\n", map { "\t\t$_" } sort keys %formats; - - my $usage = << '=cut'; -=pod - - Usage: cpan2dist [--format FMT] [OPTS] Mod::Name [Mod::Name, ...] - cpan2dist [--format FMT] [OPTS] --modulelist /tmp/mods.list - cpan2dist [--format FMT] [OPTS] --archive /tmp/dist [/tmp/dist2] - - Will create a distribution of type FMT of the modules - specified on the command line, and all their prerequisites. - - Can also create a distribution of type FMT from a local - archive and all of its prerequisites. - -=cut - - $usage .= qq[ - Possible formats are: -$formats - - You can install more formats from CPAN! - \n]; - - $usage .= << '=cut'; -=pod - -Options: - - ### take no argument: - --help Show this help message - --install Install this package (and any prerequisites you built) - after building it. - --skiptest Skip tests. Can be negated using --noskiptest - --force Force operation. Can be negated using --noforce - --verbose Be verbose. Can be negated using --noverbose - --keepsource Keep sources after building distribution. Can be - negated by --nokeepsource. May not be supported - by all formats - --makefile Prefer Makefile.PL over Build.PL. Can be negated - using --nomakefile. Defaults to your config setting - --buildprereq Build packages of any prerequisites, even if they are - already uptodate on the local system. Can be negated - using --nobuildprereq. Defaults to false. - --archive Indicate that all modules listed are actually archives - --flushcache Update CPANPLUS' cache before commencing any operation - --defaults Instruct ExtUtils::MakeMaker and Module::Build to use - default answers during 'perl Makefile.PL' or 'perl - Build.PL' calls where possible - --edit-metafile Edit the distributions metafile(s) before the distribution - is built. Requires a configured editor. - - ### take argument: - --format Installer format to use (defaults to config setting) - --ban Patterns of module names to skip during installation, - case-insensitive (affects prerequisites too) - May be given multiple times - --banlist File containing patterns that could be given to --ban - Are appended to the ban list built up by --ban - May be given multiple times. - --ignore Patterns of modules to exclude from prereq list. Useful - for when a prereq listed by a CPAN module is resolved - in another way than from its corresponding CPAN package - (Match is done on both module name, and package name of - the package the module is in, case-insensitive) - --ignorelist File containing patterns that may be given to --ignore. - Are appended to the ban list built up by --ignore. - May be given multiple times. - --modulelist File containing a list of modules that should be built. - Are appended to the list of command line modules. - May be given multiple times. - --logfile File to log all output to. By default, all output goes - to the console. - --timeout The allowed time for buliding a distribution before - aborting. This is useful to terminate any build that - hang or happen to be interactive despite being told not - to be. Defaults to 300 seconds. To turn off, you can - set it to 0. - --set-config Change any options as specified in your config for this - invocation only. See CPANPLUS::Config for a list of - supported options. - --set-program Change any programs as specified in your config for this - invocation only. See CPANPLUS::Config for a list of - supported programs. - --dist-opts Arbitrary options passed along to the chosen installer - format's prepare()/create() routine. Please see the - documentation of the installer of your choice for - options it accepts. - - ### builtin lists - --default-banlist Use our builtin banlist. Works just like --ban - and --banlist, but with pre-set lists. See the - "Builtin Lists" section for details. - --default-ignorelist Use our builtin ignorelist. Works just like - --ignore and --ignorelist but with pre-set lists. - See the "Builtin Lists" section for details. - -Examples: - - ### build a debian package of DBI and its prerequisites, - ### don't bother running tests - cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --skiptest DBI - - ### build a debian package of DBI and its prerequisites and install them - cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --install DBI - - ### Build a package, whose format is determined by your config, of - ### the local tarball, reloading cpanplus' indices first and using - ### the tarballs Makefile.PL if it has one. - cpan2dist --makefile --flushcache --archive /path/to/Cwd-1.0.tgz - - ### build a package from Net::FTP, but dont build any packages or - ### dependencies whose name match 'Foo', 'Bar' or any of the - ### patterns mentioned in /tmp/ban - cpan2dist --ban Foo --ban Bar --banlist /tmp/ban Net::FTP - - ### build a package from Net::FTP, but ignore its listed dependency - ### on IO::Socket, as it's shipped per default with the OS we're on - cpan2dist --ignore IO::Socket Net::FTP - - ### building all modules listed, plus their prerequisites - cpan2dist --ignorelist /tmp/modules.ignore --banlist /tmp/modules.ban - --modulelist /tmp/modules.list --buildprereq --flushcache - --makefile --defaults - - ### pass arbitrary options to the format's prepare()/create() routine - cpan2dist --dist-opts deb_version=3 --dist-opts prefix=corp - -=cut - - $usage .= qq[ -Builtin Lists: - - Ignore list:] . _default_ignore_list() . qq[ - Ban list:] . _default_ban_list(); - - ### strip the pod directives - $usage =~ s/=pod\n//g; - - return $usage; -} - -=pod - -=head1 Built-In Filter Lists - -Some modules you'd rather not package. Some because they -are part of core-perl and you dont want a new package. -Some because they won't build on your system. Some because -your package manager of choice already packages them for you. - -There may be a myriad of reasons. You can use the C<--ignore> -and C<--ban> options for this, but we provide some built-in -lists that catch common cases. You can use these built-in lists -if you like, or supply your own if need be. - -=head2 Built-In Ignore List - -=pod - -You can use this list of regexes to ignore modules matching -to be listed as prerequisites of a package. Particularly useful -if they are bundled with core-perl anyway and they have known -issues building. - -Toggle it by supplying the C<--default-ignorelist> option. - -=cut - -sub _default_ignore_list { - - my $list = << '=cut'; -=pod - - ^IO$ # Provided with core anyway - ^Cwd$ # Provided with core anyway - ^File::Spec # Provided with core anyway - ^Config$ # Perl's own config, not shipped separately - ^ExtUtils::MakeMaker$ # Shipped with perl, recent versions - # have bug 14721 (see rt.cpan.org) - ^ExtUtils::Install$ # Part of of EU::MM, same reason - -=cut - - return $list; -} - -=head2 Built-In Ban list - -You can use this list of regexes to disable building of these -modules altogether. - -Toggle it by supplying the C<--default-banlist> option. - -=cut - -sub _default_ban_list { - - my $list = << '=cut'; -=pod - - ^GD$ # Needs c libaries - ^Berk.*DB # DB packages require specific options & linking - ^DBD:: # DBD drivers require database files/headers - ^XML:: # XML modules usually require expat libraries - Apache # These usually require apache libraries - SSL # These usually require SSL certificates & libs - Image::Magick # Needs ImageMagick C libraries - Mail::ClamAV # Needs ClamAV C Libraries - ^Verilog # Needs Verilog C Libraries - ^Authen::PAM$ # Needs PAM C libraries & Headers - -=cut - - return $list; -} - -__END__ - -=head1 SEE ALSO - -L<CPANPLUS::Dist>, L<CPANPLUS::Module>, L<CPANPLUS::Shell::Default>, -C<cpanp> - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/bin/cpanp b/cpan/CPANPLUS/bin/cpanp deleted file mode 100644 index a493322cc2..0000000000 --- a/cpan/CPANPLUS/bin/cpanp +++ /dev/null @@ -1,104 +0,0 @@ -#!/usr/bin/perl -# $File: //depot/cpanplus/dist/bin/cpanp $ -# $Revision: #8 $ $Change: 8345 $ $DateTime: 2003/10/05 19:25:48 $ - -use strict; -use vars '$VERSION'; - -use CPANPLUS; -$VERSION = CPANPLUS->VERSION; - -use CPANPLUS::Shell qw[Default]; -my $shell = CPANPLUS::Shell->new; - -### if we're given a command, run it; otherwise, open a shell. -if (@ARGV) { - ### take the command line arguments as a command - my $input = "@ARGV"; - ### if they said "--help", fix it up to work. - $input = 'h' if $input =~ /^\s*--?h(?:elp)?\s*$/i; - ### strip the leading dash - $input =~ s/^\s*-//; - ### pass the command line to the shell - ### exit with a useful return value on return - exit not $shell->dispatch_on_input(input => $input, noninteractive => 1); -} else { - ### open a shell for the user - $shell->shell(); -} - -=head1 NAME - -cpanp - The CPANPLUS launcher - -=head1 SYNOPSIS - -B<cpanp> - -B<cpanp> S<[-]B<a>> S<[ --[B<no>-]I<option>... ]> S< I<author>... > - -B<cpanp> S<[-]B<mfitulrcz>> S<[ --[B<no>-]I<option>... ]> S< I<module>... > - -B<cpanp> S<[-]B<d>> S<[ --[B<no>-]I<option>... ]> S<[ --B<fetchdir>=... ]> S< I<module>... > - -B<cpanp> S<[-]B<xb>> S<[ --[B<no>-]I<option>... ]> - -B<cpanp> S<[-]B<o>> S<[ --[B<no>-]I<option>... ]> S<[ I<module>... ]> - -=head1 DESCRIPTION - -This script launches the B<CPANPLUS> utility to perform various operations -from the command line. If it's invoked without arguments, an interactive -shell is executed by default. - -Optionally, it can take a single-letter switch and one or more argument, -to perform the associated action on each arguments. A summary of the -available commands is listed below; C<cpanp -h> provides a detailed list. - - h # help information - v # version information - - a AUTHOR ... # search by author(s) - m MODULE ... # search by module(s) - f MODULE ... # list all releases of a module - - i MODULE ... # install module(s) - t MODULE ... # test module(s) - u MODULE ... # uninstall module(s) - d MODULE ... # download module(s) - l MODULE ... # display detailed information about module(s) - r MODULE ... # display README files of module(s) - c MODULE ... # check for module report(s) from cpan-testers - z MODULE ... # extract module(s) and open command prompt in it - - x # reload CPAN indices - - o [ MODULE ... ] # list installed module(s) that aren't up to date - b # write a bundle file for your configuration - -Each command may be followed by one or more I<options>. If preceded by C<no>, -the corresponding option will be set to C<0>, otherwise it's set to C<1>. - -Example: To skip a module's tests, - - cpanp -i --skiptest MODULE ... - -Valid options for most commands are C<cpantest>, C<debug>, C<flush>, C<force>, -C<prereqs>, C<storable>, C<verbose>, C<md5>, C<signature>, and C<skiptest>; the -'d' command also accepts C<fetchdir>. Please consult L<CPANPLUS::Configure> -for an explanation to their meanings. - -Example: To download a module's tarball to the current directory, - - cpanp -d --fetchdir=. MODULE ... - -=cut - -1; - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/bin/cpanp-run-perl b/cpan/CPANPLUS/bin/cpanp-run-perl deleted file mode 100644 index b6b4dc6920..0000000000 --- a/cpan/CPANPLUS/bin/cpanp-run-perl +++ /dev/null @@ -1,11 +0,0 @@ -use strict; -BEGIN { -my $old = select STDERR; $|++; # turn on autoflush -select $old; $|++; # turn on autoflush -$0 = shift(@ARGV); # rename the script -my $rv = do($0); # execute the file -die $@ if $@; # die on parse/execute error -} -### XXX 'do' returns last statement evaluated, which may be -### undef as well. So don't die in that case. -#die $! if not defined $rv; # die on execute error diff --git a/cpan/CPANPLUS/lib/CPANPLUS.pm b/cpan/CPANPLUS/lib/CPANPLUS.pm deleted file mode 100644 index e0ff071b34..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS.pm +++ /dev/null @@ -1,272 +0,0 @@ -package CPANPLUS; -use deprecate; - -use strict; -use Carp; - -use CPANPLUS::Error; -use CPANPLUS::Backend; - -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -BEGIN { - use Exporter (); - use vars qw( @EXPORT @ISA $VERSION ); - @EXPORT = qw( shell fetch get install ); - @ISA = qw( Exporter ); - $VERSION = "0.9135"; #have to hardcode or cpan.org gets unhappy -} - -### purely for backward compatibility, so we can call it from the commandline: -### perl -MCPANPLUS -e 'install Net::SMTP' -sub install { - my $cpan = CPANPLUS::Backend->new; - my $mod = shift or ( - error(loc("No module specified!")), return - ); - - if ( ref $mod ) { - error( loc( "You passed an object. Use %1 for OO style interaction", - 'CPANPLUS::Backend' )); - return; - - } else { - my $obj = $cpan->module_tree($mod) or ( - error(loc("No such module '%1'", $mod)), - return - ); - - my $ok = $obj->install; - - $ok - ? msg(loc("Installing of %1 successful", $mod),1) - : msg(loc("Installing of %1 failed", $mod),1); - - return $ok; - } -} - -### simply downloads a module and stores it -sub fetch { - my $cpan = CPANPLUS::Backend->new; - - my $mod = shift or ( - error(loc("No module specified!")), return - ); - - if ( ref $mod ) { - error( loc( "You passed an object. Use %1 for OO style interaction", - 'CPANPLUS::Backend' )); - return; - - } else { - my $obj = $cpan->module_tree($mod) or ( - error(loc("No such module '%1'", $mod)), - return - ); - - my $ok = $obj->fetch( fetchdir => '.' ); - - $ok - ? msg(loc("Fetching of %1 successful", $mod),1) - : msg(loc("Fetching of %1 failed", $mod),1); - - return $ok; - } -} - -### alias to fetch() due to compatibility with cpan.pm ### -sub get { fetch(@_) } - - -### purely for backwards compatibility, so we can call it from the commandline: -### perl -MCPANPLUS -e 'shell' -sub shell { - my $option = shift; - - ### since the user can specify the type of shell they wish to start - ### when they call the shell() function, we have to eval the usage - ### of CPANPLUS::Shell so we can set up all the checks properly - eval { require CPANPLUS::Shell; CPANPLUS::Shell->import($option) }; - die $@ if $@; - - my $cpan = CPANPLUS::Shell->new(); - - $cpan->shell(); -} - -1; - -__END__ - -=pod - -=head1 NAME - -CPANPLUS - API & CLI access to the CPAN mirrors - -=head1 SYNOPSIS - - ### standard invocation from the command line - $ cpanp - $ cpanp -i Some::Module - - $ perl -MCPANPLUS -eshell - $ perl -MCPANPLUS -e'fetch Some::Module' - - -=head1 DESCRIPTION - -The C<CPANPLUS> library is an API to the C<CPAN> mirrors and a -collection of interactive shells, commandline programs, etc, -that use this API. - -=head1 GUIDE TO DOCUMENTATION - -=head2 GENERAL USAGE - -This is the document you are currently reading. It describes -basic usage and background information. Its main purpose is to -assist the user who wants to learn how to invoke CPANPLUS -and install modules from the commandline and to point you -to more indepth reading if required. - -=head2 API REFERENCE - -The C<CPANPLUS> API is meant to let you programmatically -interact with the C<CPAN> mirrors. The documentation in -L<CPANPLUS::Backend> shows you how to create an object -capable of interacting with those mirrors, letting you -create & retrieve module objects. -L<CPANPLUS::Module> shows you how you can use these module -objects to perform actions like installing and testing. - -The default shell, documented in L<CPANPLUS::Shell::Default> -is also scriptable. You can use its API to dispatch calls -from your script to the CPANPLUS Shell. - -=cut - -=head1 COMMANDLINE TOOLS - -=head2 STARTING AN INTERACTIVE SHELL - -You can start an interactive shell by running either of -the two following commands: - - $ cpanp - - $ perl -MCPANPLUS -eshell - -All commands available are listed in the interactive shells -help menu. See C<cpanp -h> or L<CPANPLUS::Shell::Default> -for instructions on using the default shell. - -=head2 CHOOSE A SHELL - -By running C<cpanp> without arguments, you will start up -the shell specified in your config, which defaults to -L<CPANPLUS::Shell::Default>. There are more shells available. -C<CPANPLUS> itself ships with an emulation shell called -L<CPANPLUS::Shell::Classic> that looks and feels just like -the old C<CPAN.pm> shell. - -You can start this shell by typing: - - $ perl -MCPANPLUS -e'shell Classic' - -Even more shells may be available from C<CPAN>. - -Note that if you have changed your default shell in your -configuration, that shell will be used instead. If for -some reason there was an error with your specified shell, -you will be given the default shell. - -=head2 BUILDING PACKAGES - -C<cpan2dist> is a commandline tool to convert any distribution -from C<CPAN> into a package in the format of your choice, like -for example C<.deb> or C<FreeBSD ports>. - -See C<cpan2dist -h> for details. - - -=head1 FUNCTIONS - -For quick access to common commands, you may use this module, -C<CPANPLUS> rather than the full programmatic API situated in -C<CPANPLUS::Backend>. This module offers the following functions: - -=head2 $bool = install( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz ) - -This function requires the full name of the module, which is case -sensitive. The module name can also be provided as a fully -qualified file name, beginning with a I</>, relative to -the /authors/id directory on a CPAN mirror. - -It will download, extract and install the module. - -=head2 $where = fetch( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz ) - -Like install, fetch needs the full name of a module or the fully -qualified file name, and is case sensitive. - -It will download the specified module to the current directory. - -=head2 $where = get( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz ) - -Get is provided as an alias for fetch for compatibility with -CPAN.pm. - -=head2 shell() - -Shell starts the default CPAN shell. You can also start the shell -by using the C<cpanp> command, which will be installed in your -perl bin. - -=head1 FAQ - -For frequently asked questions and answers, please consult the -C<CPANPLUS::FAQ> manual. - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=head1 SEE ALSO - -L<CPANPLUS::Shell::Default>, L<CPANPLUS::FAQ>, L<CPANPLUS::Backend>, L<CPANPLUS::Module>, L<cpanp>, L<cpan2dist> - -=head1 CONTACT INFORMATION - -=over 4 - -=item * Bug reporting: -I<bug-cpanplus@rt.cpan.org> - -=item * Questions & suggestions: -I<bug-cpanplus@rt.cpan.org> - -=back - - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Backend.pm b/cpan/CPANPLUS/lib/CPANPLUS/Backend.pm deleted file mode 100644 index 85559dc04f..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Backend.pm +++ /dev/null @@ -1,1344 +0,0 @@ -package CPANPLUS::Backend; -use deprecate; - -use strict; - - -use CPANPLUS::Error; -use CPANPLUS::Configure; -use CPANPLUS::Internals; -use CPANPLUS::Internals::Constants; -use CPANPLUS::Module; -use CPANPLUS::Module::Author; -use CPANPLUS::Backend::RV; - -use FileHandle; -use File::Spec (); -use File::Spec::Unix (); -use File::Basename (); -use Params::Check qw[check]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -$Params::Check::VERBOSE = 1; - -use vars qw[@ISA $VERSION]; - -@ISA = qw[CPANPLUS::Internals]; -$VERSION = "0.9135"; - -### mark that we're running under CPANPLUS to spawned processes -$ENV{'PERL5_CPANPLUS_IS_RUNNING'} = $$; - -### XXX version.pm MAY format this version, if it's in use... :( -### so for consistency, just call ->VERSION ourselves as well. -$ENV{'PERL5_CPANPLUS_IS_VERSION'} = __PACKAGE__->VERSION; - -=pod - -=head1 NAME - -CPANPLUS::Backend - programmer's interface to CPANPLUS - -=head1 SYNOPSIS - - my $cb = CPANPLUS::Backend->new; - my $conf = $cb->configure_object; - - my $author = $cb->author_tree('KANE'); - my $mod = $cb->module_tree('Some::Module'); - my $mod = $cb->parse_module( module => 'Some::Module' ); - - my @objs = $cb->search( type => TYPE, - allow => [...] ); - - $cb->flush('all'); - $cb->reload_indices; - $cb->local_mirror; - - -=head1 DESCRIPTION - -This module provides the programmer's interface to the C<CPANPLUS> -libraries. - -=head1 ENVIRONMENT - -When C<CPANPLUS::Backend> is loaded, which is necessary for just -about every <CPANPLUS> operation, the environment variable -C<PERL5_CPANPLUS_IS_RUNNING> is set to the current process id. - -Additionally, the environment variable C<PERL5_CPANPLUS_IS_VERSION> -will be set to the version of C<CPANPLUS::Backend>. - -This information might be useful somehow to spawned processes. - -=head1 METHODS - -=head2 $cb = CPANPLUS::Backend->new( [CONFIGURE_OBJ] ) - -This method returns a new C<CPANPLUS::Backend> object. -This also initialises the config corresponding to this object. -You have two choices in this: - -=over 4 - -=item Provide a valid C<CPANPLUS::Configure> object - -This will be used verbatim. - -=item No arguments - -Your default config will be loaded and used. - -=back - -New will return a C<CPANPLUS::Backend> object on success and die on -failure. - -=cut - -sub new { - my $class = shift; - my $conf; - - if( $_[0] && IS_CONFOBJ->( conf => $_[0] ) ) { - $conf = shift; - } else { - $conf = CPANPLUS::Configure->new() or return; - } - - my $self = $class->SUPER::_init( _conf => $conf ); - - return $self; -} - -=pod - -=head2 $href = $cb->module_tree( [@modules_names_list] ) - -Returns a reference to the CPANPLUS module tree. - -If you give it any arguments, they will be treated as module names -and C<module_tree> will try to look up these module names and -return the corresponding module objects instead. - -See L<CPANPLUS::Module> for the operations you can perform on a -module object. - -=cut - -sub module_tree { - my $self = shift; - my $modtree = $self->_module_tree; - - if( @_ ) { - my @rv; - for my $name ( grep { defined } @_) { - - ### From John Malmberg: This is failing on VMS - ### because ODS-2 does not retain the case of - ### filenames that are created. - ### The problem is the filename is being converted - ### to a module name and then looked up in the - ### %$modtree hash. - ### - ### As a fix, we do a search on VMS instead -- - ### more cpu cycles, but it gets around the case - ### problem --kane - my ($modobj) = do { - ON_VMS - ? $self->search( - type => 'module', - allow => [qr/^$name$/i], - ) - : $modtree->{$name} - }; - - push @rv, $modobj || ''; - } - return @rv == 1 ? $rv[0] : @rv; - } else { - return $modtree; - } -} - -=pod - -=head2 $href = $cb->author_tree( [@author_names_list] ) - -Returns a reference to the CPANPLUS author tree. - -If you give it any arguments, they will be treated as author names -and C<author_tree> will try to look up these author names and -return the corresponding author objects instead. - -See L<CPANPLUS::Module::Author> for the operations you can perform on -an author object. - -=cut - -sub author_tree { - my $self = shift; - my $authtree = $self->_author_tree; - - if( @_ ) { - my @rv; - for my $name (@_) { - push @rv, $authtree->{$name} || ''; - } - return @rv == 1 ? $rv[0] : @rv; - } else { - return $authtree; - } -} - -=pod - -=head2 $conf = $cb->configure_object; - -Returns a copy of the C<CPANPLUS::Configure> object. - -See L<CPANPLUS::Configure> for operations you can perform on a -configure object. - -=cut - -sub configure_object { return shift->_conf() }; - -=head2 $su = $cb->selfupdate_object; - -Returns a copy of the C<CPANPLUS::Selfupdate> object. - -See the L<CPANPLUS::Selfupdate> manpage for the operations -you can perform on the selfupdate object. - -=cut - -sub selfupdate_object { return shift->_selfupdate() }; - -=pod - -=head2 @mods = $cb->search( type => TYPE, allow => AREF, [data => AREF, verbose => BOOL] ) - -C<search> enables you to search for either module or author objects, -based on their data. The C<type> you can specify is any of the -accessors specified in C<CPANPLUS::Module::Author> or -C<CPANPLUS::Module>. C<search> will determine by the C<type> you -specified whether to search by author object or module object. - -You have to specify an array reference of regular expressions or -strings to match against. The rules used for this array ref are the -same as in C<Params::Check>, so read that manpage for details. - -The search is an C<or> search, meaning that if C<any> of the criteria -match, the search is considered to be successful. - -You can specify the result of a previous search as C<data> to limit -the new search to these module or author objects, rather than the -entire module or author tree. This is how you do C<and> searches. - -Returns a list of module or author objects on success and false -on failure. - -See L<CPANPLUS::Module> for the operations you can perform on a -module object. -See L<CPANPLUS::Module::Author> for the operations you can perform on -an author object. - -=cut - -sub search { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my ($type); - my $args = do { - local $Params::Check::NO_DUPLICATES = 0; - local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - type => { required => 1, allow => [CPANPLUS::Module->accessors(), - CPANPLUS::Module::Author->accessors()], store => \$type }, - allow => { required => 1, default => [ ], strict_type => 1 }, - }; - - check( $tmpl, \%hash ) - } or return; - - ### figure out whether it was an author or a module search - ### when ambiguous, it'll be an author search. - my $aref; - if( grep { $type eq $_ } CPANPLUS::Module::Author->accessors() ) { - $aref = $self->_search_author_tree( %$args ); - } else { - $aref = $self->_search_module_tree( %$args ); - } - - return @$aref if $aref; - return; -} - -=pod - -=head2 $backend_rv = $cb->fetch( modules => \@mods ) - -Fetches a list of modules. C<@mods> can be a list of distribution -names, module names or module objects--basically anything that -L<parse_module> can understand. - -See the equivalent method in C<CPANPLUS::Module> for details on -other options you can pass. - -Since this is a multi-module method call, the return value is -implemented as a C<CPANPLUS::Backend::RV> object. Please consult -that module's documentation on how to interpret the return value. - -=head2 $backend_rv = $cb->extract( modules => \@mods ) - -Extracts a list of modules. C<@mods> can be a list of distribution -names, module names or module objects--basically anything that -L<parse_module> can understand. - -See the equivalent method in C<CPANPLUS::Module> for details on -other options you can pass. - -Since this is a multi-module method call, the return value is -implemented as a C<CPANPLUS::Backend::RV> object. Please consult -that module's documentation on how to interpret the return value. - -=head2 $backend_rv = $cb->install( modules => \@mods ) - -Installs a list of modules. C<@mods> can be a list of distribution -names, module names or module objects--basically anything that -L<parse_module> can understand. - -See the equivalent method in C<CPANPLUS::Module> for details on -other options you can pass. - -Since this is a multi-module method call, the return value is -implemented as a C<CPANPLUS::Backend::RV> object. Please consult -that module's documentation on how to interpret the return value. - -=head2 $backend_rv = $cb->readme( modules => \@mods ) - -Fetches the readme for a list of modules. C<@mods> can be a list of -distribution names, module names or module objects--basically -anything that L<parse_module> can understand. - -See the equivalent method in C<CPANPLUS::Module> for details on -other options you can pass. - -Since this is a multi-module method call, the return value is -implemented as a C<CPANPLUS::Backend::RV> object. Please consult -that module's documentation on how to interpret the return value. - -=head2 $backend_rv = $cb->files( modules => \@mods ) - -Returns a list of files used by these modules if they are installed. -C<@mods> can be a list of distribution names, module names or module -objects--basically anything that L<parse_module> can understand. - -See the equivalent method in C<CPANPLUS::Module> for details on -other options you can pass. - -Since this is a multi-module method call, the return value is -implemented as a C<CPANPLUS::Backend::RV> object. Please consult -that module's documentation on how to interpret the return value. - -=head2 $backend_rv = $cb->distributions( modules => \@mods ) - -Returns a list of module objects representing all releases for this -module on success. -C<@mods> can be a list of distribution names, module names or module -objects, basically anything that L<parse_module> can understand. - -See the equivalent method in C<CPANPLUS::Module> for details on -other options you can pass. - -Since this is a multi-module method call, the return value is -implemented as a C<CPANPLUS::Backend::RV> object. Please consult -that module's documentation on how to interpret the return value. - -=cut - -### XXX add direcotry_tree, packlist etc? or maybe remove files? ### -for my $func (qw[fetch extract install readme files distributions]) { - no strict 'refs'; - - *$func = sub { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my ($mods); - my $args = do { - local $Params::Check::NO_DUPLICATES = 1; - local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - modules => { default => [], strict_type => 1, - required => 1, store => \$mods }, - }; - - check( $tmpl, \%hash ); - } or return; - - ### make them all into module objects ### - my %mods = map { $_ => $self->parse_module(module => $_) || '' } @$mods; - - my $flag; my $href; - while( my($name,$obj) = each %mods ) { - $href->{$name} = IS_MODOBJ->( mod => $obj ) - ? $obj->$func( %$args ) - : undef; - - $flag++ unless $href->{$name}; - } - - return CPANPLUS::Backend::RV->new( - function => $func, - ok => ( !$flag ? 1 : 0 ), - rv => $href, - args => \%hash, - ); - } -} - -=pod - -=head2 $mod_obj = $cb->parse_module( module => $modname|$distname|$modobj|URI|PATH ) - -C<parse_module> tries to find a C<CPANPLUS::Module> object that -matches your query. Here's a list of examples you could give to -C<parse_module>; - -=over 4 - -=item Text::Bastardize - -=item Text-Bastardize - -=item Text/Bastardize.pm - -=item Text-Bastardize-1.06 - -=item AYRNIEU/Text-Bastardize - -=item AYRNIEU/Text-Bastardize-1.06 - -=item AYRNIEU/Text-Bastardize-1.06.tar.gz - -=item http://example.com/Text-Bastardize-1.06.tar.gz - -=item file:///tmp/Text-Bastardize-1.06.tar.gz - -=item /tmp/Text-Bastardize-1.06 - -=item ./Text-Bastardize-1.06 - -=item . - -=back - -These items would all come up with a C<CPANPLUS::Module> object for -C<Text::Bastardize>. The ones marked explicitly as being version 1.06 -would give back a C<CPANPLUS::Module> object of that version. -Even if the version on CPAN is currently higher. - -The last three are examples of PATH resolution. In the first, we supply -an absolute path to the unwrapped distribution. In the second the -distribution is relative to the current working directory. -In the third, we will use the current working directory. - -If C<parse_module> is unable to actually find the module you are looking -for in its module tree, but you supplied it with an author, module -and version part in a distribution name or URI, it will create a fake -C<CPANPLUS::Module> object for you, that you can use just like the -real thing. - -See L<CPANPLUS::Module> for the operations you can perform on a -module object. - -If even this fancy guessing doesn't enable C<parse_module> to create -a fake module object for you to use, it will warn about an error and -return false. - -=cut - -sub parse_module { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my $mod; - my $tmpl = { - module => { required => 1, store => \$mod }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - return $mod if IS_MODOBJ->( module => $mod ); - - ### ok, so it's not a module object, but a ref nonetheless? - ### what are you smoking? - if( ref $mod ) { - error(loc("Can not parse module string from reference '%1'", $mod )); - return; - } - - ### check only for allowed characters in a module name - unless( $mod =~ /[^\w:]/ ) { - - ### perhaps we can find it in the module tree? - my $maybe = $self->module_tree($mod); - return $maybe if IS_MODOBJ->( module => $maybe ); - } - - ### Special case arbitrary file paths such as '.' etc. - if ( $mod and -d File::Spec->rel2abs($mod) ) { - my $dir = File::Spec->rel2abs($mod); - my $parent = File::Spec->rel2abs( File::Spec->catdir( $dir, '..' ) ); - - ### fix paths on VMS - if (ON_VMS) { - $dir = VMS::Filespec::unixify($dir); - $parent = VMS::Filespec::unixify($parent); - } - - my $dist = $mod = File::Basename::basename($dir); - $dist .= '-0' unless $dist =~ /\-[0-9._]+$/; - $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/; - - my $modobj = CPANPLUS::Module::Fake->new( - module => $mod, - version => 0, - package => $dist, - path => $parent, - author => CPANPLUS::Module::Author::Fake->new - ); - - ### better guess for the version - $modobj->version( $modobj->package_version ) - if defined $modobj->package_version; - - ### better guess at module name, if possible - if ( my $pkgname = $modobj->package_name ) { - $pkgname =~ s/-/::/g; - - ### no sense replacing it unless we changed something - $modobj->module( $pkgname ) - if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/; - } - - $modobj->status->fetch( $parent ); - $modobj->status->extract( $dir ); - $modobj->get_installer_type; - return $modobj; - } - - ### ok, so it looks like a distribution then? - my @parts = split '/', $mod; - my $dist = pop @parts; - - ### ah, it's a URL - if( $mod =~ m|\w+://.+| ) { - my $modobj = CPANPLUS::Module::Fake->new( - module => $dist, - version => 0, - package => $dist, - path => File::Spec::Unix->catdir( - $conf->_get_mirror('base'), - UNKNOWN_DL_LOCATION ), - author => CPANPLUS::Module::Author::Fake->new - ); - - ### set the fetch_from accessor so we know to by pass the - ### usual mirrors - $modobj->status->_fetch_from( $mod ); - - ### better guess for the version - $modobj->version( $modobj->package_version ) - if defined $modobj->package_version; - - ### better guess at module name, if possible - if ( my $pkgname = $modobj->package_name ) { - $pkgname =~ s/-/::/g; - - ### no sense replacing it unless we changed something - $modobj->module( $pkgname ) - if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/; - } - - return $modobj; - } - - # Stolen from cpanminus to support 'Module/Install.pm' - # type input - if ( ( my $tmpmod = $mod ) =~ s/\.pm$//i ) { - my ($volume, $dirs, $file) = File::Spec->splitpath( $tmpmod ); - $tmpmod = join '::', grep { $_ } File::Spec->splitdir( $dirs ), $file; - ### perhaps we can find it in the module tree? - my $maybe = $self->module_tree( $tmpmod ); - return $maybe if IS_MODOBJ->( module => $maybe ); - } - - ### perhaps we can find it's a third party module? - { my $modobj = CPANPLUS::Module::Fake->new( - module => $mod, - version => 0, - package => $dist, - path => File::Spec::Unix->catdir( - $conf->_get_mirror('base'), - UNKNOWN_DL_LOCATION ), - author => CPANPLUS::Module::Author::Fake->new - ); - if( $modobj->is_third_party ) { - my $info = $modobj->third_party_information; - - $modobj->author->author( $info->{author} ); - $modobj->author->email( $info->{author_url} ); - $modobj->description( $info->{url} ); - - return $modobj; - } - } - - unless( $dist ) { - error( loc("%1 is not a proper distribution name!", $mod) ); - return; - } - - ### there's wonky uris out there, like this: - ### E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091 - ### compensate for that - my $author; - ### you probably have an A/AB/ABC/....../Dist.tgz type uri - if( (defined $parts[0] and length $parts[0] == 1) and - (defined $parts[1] and length $parts[1] == 2) and - $parts[2] =~ /^$parts[0]/i and $parts[2] =~ /^$parts[1]/i - ) { - splice @parts, 0, 2; # remove the first 2 entries from the list - $author = shift @parts; # this is the actual author name then - - ### we''ll assume a ABC/..../Dist.tgz - } else { - $author = shift @parts || ''; - } - - my($pkg, $version, $ext, $full) = - $self->_split_package_string( package => $dist ); - - ### translate a distribution into a module name ### - my $guess = $pkg; - $guess =~ s/-/::/g if $guess; - - my $maybe = $self->module_tree( $guess ); - if( IS_MODOBJ->( module => $maybe ) ) { - - ### maybe you asked for a package instead - if ( $maybe->package eq $mod ) { - return $maybe; - - ### perhaps an outdated version instead? - } elsif ( $version ) { - my $auth_obj; my $path; - - ### did you give us an author part? ### - if( $author ) { - $auth_obj = CPANPLUS::Module::Author::Fake->new( - _id => $maybe->_id, - cpanid => uc $author, - author => uc $author, - ); - $path = File::Spec::Unix->catdir( - $conf->_get_mirror('base'), - substr(uc $author, 0, 1), - substr(uc $author, 0, 2), - uc $author, - @parts, #possible sub dirs - ); - } else { - $auth_obj = $maybe->author; - $path = $maybe->path; - } - - if( $maybe->package_name eq $pkg ) { - - my $modobj = CPANPLUS::Module::Fake->new( - module => $maybe->module, - version => $version, - ### no extension? use the extension the original package - ### had instead - package => do { $ext - ? $full - : $full .'.'. $maybe->package_extension - }, - path => $path, - author => $auth_obj, - _id => $maybe->_id - ); - return $modobj; - - ### you asked for a specific version? - ### assume our $maybe is the one you wanted, - ### and fix up the version.. - } else { - - my $modobj = $maybe->clone; - $modobj->version( $version ); - $modobj->package( - $maybe->package_name .'-'. - $version .'.'. - $maybe->package_extension - ); - - ### you wanted a specific author, but it's not the one - ### from the module tree? we'll fix it up - if( $author and $author ne $modobj->author->cpanid ) { - $modobj->author( $auth_obj ); - $modobj->path( $path ); - } - - return $modobj; - } - - ### you didn't care about a version, so just return the object then - } elsif ( !$version ) { - return $maybe; - } - - ### ok, so we can't find it, and it's not an outdated dist either - ### perhaps we can fake one based on the author name and so on - } elsif ( $author and $version ) { - - ### be extra friendly and pad the .tar.gz suffix where needed - ### it's just a guess of course, but most dists are .tar.gz - $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/; - - ### XXX duplication from above for generating author obj + path... - my $modobj = CPANPLUS::Module::Fake->new( - module => $guess, - version => $version, - package => $dist, - author => CPANPLUS::Module::Author::Fake->new( - author => uc $author, - cpanid => uc $author, - _id => $self->_id, - ), - path => File::Spec::Unix->catdir( - $conf->_get_mirror('base'), - substr(uc $author, 0, 1), - substr(uc $author, 0, 2), - uc $author, - @parts, #possible subdirs - ), - _id => $self->_id, - ); - - return $modobj; - - ### face it, we have /no/ idea what he or she wants... - ### let's start putting the blame somewhere - } else { - - # Lets not give up too easily. There is one last chance - # http://perlmonks.org/?node_id=805957 - # This should catch edge-cases where the package name - # is unrelated to the modules it contains. - - my ($modobj) = grep { $_->package_name eq $mod } - $self->search( type => 'package', allow => [ qr/^\Q$mod\E/ ], ); - return $modobj if IS_MODOBJ->( module => $modobj ); - - unless( $author ) { - error( loc( "'%1' does not contain an author part", $mod ) ); - } - - error( loc( "Cannot find '%1' in the module tree", $mod ) ); - } - - return; -} - -=pod - -=head2 $bool = $cb->reload_indices( [update_source => BOOL, verbose => BOOL] ); - -This method reloads the source files. - -If C<update_source> is set to true, this will fetch new source files -from your CPAN mirror. Otherwise, C<reload_indices> will do its -usual cache checking and only update them if they are out of date. - -By default, C<update_source> will be false. - -The verbose setting defaults to what you have specified in your -config file. - -Returns true on success and false on failure. - -=cut - -sub reload_indices { - my $self = shift; - my %hash = @_; - my $conf = $self->configure_object; - - my $tmpl = { - update_source => { default => 0, allow => [qr/^\d$/] }, - verbose => { default => $conf->get_conf('verbose') }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - ### make a call to the internal _module_tree, so it triggers cache - ### file age - my $uptodate = $self->_check_trees( %$args ); - - - return 1 if $self->_build_trees( - uptodate => $uptodate, - use_stored => 0, - verbose => $conf->get_conf('verbose'), - ); - - error( loc( "Error rebuilding source trees!" ) ); - - return; -} - -=pod - -=head2 $bool = $cb->flush(CACHE_NAME) - -This method allows flushing of caches. -There are several things which can be flushed: - -=over 4 - -=item * C<methods> - -The return status of methods which have been attempted, such as -different ways of fetching files. It is recommended that automatic -flushing be used instead. - -=item * C<hosts> - -The return status of URIs which have been attempted, such as -different hosts of fetching files. It is recommended that automatic -flushing be used instead. - -=item * C<modules> - -Information about modules such as prerequisites and whether -installation succeeded, failed, or was not attempted. - -=item * C<lib> - -This resets PERL5LIB, which is changed to ensure that while installing -modules they are in our @INC. - -=item * C<load> - -This resets the cache of modules we've attempted to load, but failed. -This enables you to load them again after a failed load, if they -somehow have become available. - -=item * C<all> - -Flush all of the aforementioned caches. - -=back - -Returns true on success and false on failure. - -=cut - -sub flush { - my $self = shift; - my $type = shift or return; - - my $cache = { - methods => [ qw( methods load ) ], - hosts => [ qw( hosts ) ], - modules => [ qw( modules lib) ], - lib => [ qw( lib ) ], - load => [ qw( load ) ], - all => [ qw( hosts lib modules methods load ) ], - }; - - my $aref = $cache->{$type} - or ( - error( loc("No such cache '%1'", $type) ), - return - ); - - return $self->_flush( list => $aref ); -} - -=pod - -=head2 @mods = $cb->installed() - -Returns a list of module objects of all your installed modules. -If an error occurs, it will return false. - -See L<CPANPLUS::Module> for the operations you can perform on a -module object. - -=cut - -sub installed { - my $self = shift; - my $aref = $self->_all_installed; - - return @$aref if $aref; - return; -} - -=pod - -=head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] ) - -Creates a local mirror of CPAN, of only the most recent sources in a -location you specify. If you set this location equal to a custom host -in your C<CPANPLUS::Config> you can use your local mirror to install -from. - -It takes the following arguments: - -=over 4 - -=item path - -The location where to create the local mirror. - -=item index_files - -Enable/disable fetching of index files. You can disable fetching of the -index files if you don't plan to use the local mirror as your primary -site, or if you'd like up-to-date index files be fetched from elsewhere. - -Defaults to true. - -=item force - -Forces refetching of packages, even if they are there already. - -Defaults to whatever setting you have in your C<CPANPLUS::Config>. - -=item verbose - -Prints more messages about what its doing. - -Defaults to whatever setting you have in your C<CPANPLUS::Config>. - -=back - -Returns true on success and false on error. - -=cut - -sub local_mirror { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my($path, $index, $force, $verbose); - my $tmpl = { - path => { default => $conf->get_conf('base'), - store => \$path }, - index_files => { default => 1, store => \$index }, - force => { default => $conf->get_conf('force'), - store => \$force }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - }; - - check( $tmpl, \%hash ) or return; - - unless( -d $path ) { - $self->_mkdir( dir => $path ) - or( error( loc( "Could not create '%1', giving up", $path ) ), - return - ); - } elsif ( ! -w _ ) { - error( loc( "Could not write to '%1', giving up", $path ) ); - return; - } - - my $flag; - AUTHOR: { - for my $auth ( sort { $a->cpanid cmp $b->cpanid } - values %{$self->author_tree} - ) { - - MODULE: { - my $i; - for my $mod ( $auth->modules ) { - my $fetchdir = File::Spec->catdir( $path, $mod->path ); - - my %opts = ( - verbose => $verbose, - force => $force, - fetchdir => $fetchdir, - ); - - ### only do this the for the first module ### - unless( $i++ ) { - $mod->_get_checksums_file( - %opts - ) or ( - error( loc( "Could not fetch %1 file, " . - "skipping author '%2'", - CHECKSUMS, $auth->cpanid ) ), - $flag++, next AUTHOR - ); - } - - $mod->fetch( %opts ) - or( error( loc( "Could not fetch '%1'", $mod->module ) ), - $flag++, next MODULE - ); - } } - } } - - if( $index ) { - for my $name (qw[auth dslip mod]) { - $self->_update_source( - name => $name, - verbose => $verbose, - path => $path, - ) or ( $flag++, next ); - } - } - - return !$flag; -} - -=pod - -=head2 $file = $cb->autobundle([path => OUTPUT_PATH, force => BOOL, verbose => BOOL]) - -Writes out a snapshot of your current installation in C<CPAN> bundle -style. This can then be used to install the same modules for a -different or on a different machine by issuing the following commands: - - ### using the default shell: - CPAN Terminal> i file://path/to/Snapshot_XXYY.pm - - ### using the API - $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' ); - $modobj->install; - -It will, by default, write to an 'autobundle' directory under your -cpanplus homedirectory, but you can override that by supplying a -C<path> argument. - -It will return the location of the output file on success and false on -failure. - -=cut - -sub autobundle { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my($path,$force,$verbose); - my $tmpl = { - force => { default => $conf->get_conf('force'), store => \$force }, - verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, - path => { default => File::Spec->catdir( - $conf->get_conf('base'), - $self->_perl_version( perl => $^X ), - $conf->_get_build('distdir'), - $conf->_get_build('autobundle') ), - store => \$path }, - }; - - check($tmpl, \%hash) or return; - - unless( -d $path ) { - $self->_mkdir( dir => $path ) - or( error(loc("Could not create directory '%1'", $path ) ), - return - ); - } - - my $name; my $file; - { ### default filename for the bundle ### - my($year,$month,$day) = (localtime)[5,4,3]; - $year += 1900; $month++; - - my $ext = 0; - - my $prefix = $conf->_get_build('autobundle_prefix'); - my $format = "${prefix}_%04d_%02d_%02d_%02d"; - - BLOCK: { - $name = sprintf( $format, $year, $month, $day, $ext); - - $file = File::Spec->catfile( $path, $name . '.pm' ); - - -f $file ? ++$ext && redo BLOCK : last BLOCK; - } - } - my $fh; - unless( $fh = FileHandle->new( ">$file" ) ) { - error( loc( "Could not open '%1' for writing: %2", $file, $! ) ); - return; - } - - ### make sure we load the module tree *before* doing this, as it - ### starts to chdir all over the place - $self->module_tree; - - my $string = join "\n\n", - map { - join ' ', - $_->module, - ($_->installed_version(verbose => 0) || 'undef') - } sort { - $a->module cmp $b->module - } $self->installed; - - my $now = scalar localtime; - my $head = '=head1'; - my $pkg = __PACKAGE__; - my $version = $self->VERSION; - my $perl_v = join '', `$^X -V`; - - print $fh <<EOF; -package $name; - -\$VERSION = '0.01'; - -1; - -__END__ - -$head NAME - -$name - Snapshot of your installation at $now - -$head SYNOPSIS - -To install the modules from this snapshot, run: - - cpanp -i file://full/path/to/${name}.pm - -$head CONTENTS - -$string - -$head CONFIGURATION - -$perl_v - -$head AUTHOR - -This bundle has been generated autotomatically by - $pkg $version - -EOF - - close $fh; - - return $file; -} - -=head2 $bool = $cb->save_state - -Explicit command to save memory state to disk. This can be used to save -information to disk about where a module was extracted, the result of -C<make test>, etc. This will then be re-loaded into memory when a new -session starts. - -The capability of saving state to disk depends on the source engine -being used (See C<CPANPLUS::Config> for the option to choose your -source engine). The default storage engine supports this option. - -Most users will not need this command, but it can handy for automated -systems like setting up CPAN smoke testers. - -The method will return true if it managed to save the state to disk, -or false if it did not. - -=cut - -sub save_state { - my $self = shift; - return $self->_save_state( @_ ); -} - - -### XXX these wrappers are not individually tested! only the underlying -### code through source.t and indirectly through he CustomSource plugin. - -=pod - -=head1 CUSTOM MODULE SOURCES - -Besides the sources as provided by the general C<CPAN> mirrors, it's -possible to add your own sources list to your C<CPANPLUS> index. - -The methodology behind this works much like C<Debian's apt-sources>. - -The methods below show you how to make use of this functionality. Also -note that most of these methods are available through the default shell -plugin command C</cs>, making them available as shortcuts through the -shell and via the commandline. - -=head2 %files = $cb->list_custom_sources - -Returns a mapping of registered custom sources and their local indices -as follows: - - /full/path/to/local/index => http://remote/source - -Note that any file starting with an C<#> is being ignored. - -=cut - -sub list_custom_sources { - return shift->__list_custom_module_sources( @_ ); -} - -=head2 $local_index = $cb->add_custom_source( uri => URI, [verbose => BOOL] ); - -Adds an C<URI> to your own sources list and mirrors its index. See the -documentation on C<< $cb->update_custom_source >> on how this is done. - -Returns the full path to the local index on success, or false on failure. - -Note that when adding a new C<URI>, the change to the in-memory tree is -not saved until you rebuild or save the tree to disk again. You can do -this using the C<< $cb->reload_indices >> method. - -=cut - -sub add_custom_source { - return shift->_add_custom_module_source( @_ ); -} - -=head2 $local_index = $cb->remove_custom_source( uri => URI, [verbose => BOOL] ); - -Removes an C<URI> from your own sources list and removes its index. - -To find out what C<URI>s you have as part of your own sources list, use -the C<< $cb->list_custom_sources >> method. - -Returns the full path to the deleted local index file on success, or false -on failure. - -=cut - -### XXX do clever dispatching based on arg number? -sub remove_custom_source { - return shift->_remove_custom_module_source( @_ ); -} - -=head2 $bool = $cb->update_custom_source( [remote => URI] ); - -Updates the indexes for all your custom sources. It does this by fetching -a file called C<packages.txt> in the root of the custom sources's C<URI>. -If you provide the C<remote> argument, it will only update the index for -that specific C<URI>. - -Here's an example of how custom sources would resolve into index files: - - file:///path/to/sources => file:///path/to/sources/packages.txt - http://example.com/sources => http://example.com/sources/packages.txt - ftp://example.com/sources => ftp://example.com/sources/packages.txt - -The file C<packages.txt> simply holds a list of packages that can be found -under the root of the C<URI>. This file can be automatically generated for -you when the remote source is a C<file:// URI>. For C<http://>, C<ftp://>, -and similar, the administrator of that repository should run the method -C<< $cb->write_custom_source_index >> on the repository to allow remote -users to index it. - -For details, see the C<< $cb->write_custom_source_index >> method below. - -All packages that are added via this mechanism will be attributed to the -author with C<CPANID> C<LOCAL>. You can use this id to search for all -added packages. - -=cut - -sub update_custom_source { - my $self = shift; - - ### if it mentions /remote/, the request is to update a single uri, - ### not all the ones we have, so dispatch appropriately - my $rv = grep( /remote/i, @_) - ? $self->__update_custom_module_source( @_ ) - : $self->__update_custom_module_sources( @_ ); - - return $rv; -} - -=head2 $file = $cb->write_custom_source_index( path => /path/to/package/root, [to => /path/to/index/file, verbose => BOOL] ); - -Writes the index for a custom repository root. Most users will not have to -worry about this, but administrators of a repository will need to make sure -their indexes are up to date. - -The index will be written to a file called C<packages.txt> in your repository -root, which you can specify with the C<path> argument. You can override this -location by specifying the C<to> argument, but in normal operation, that should -not be required. - -Once the index file is written, users can then add the C<URI> pointing to -the repository to their custom list of sources and start using it right away. See the C<< $cb->add_custom_source >> method for user details. - -=cut - -sub write_custom_source_index { - return shift->__write_custom_module_index( @_ ); -} - -1; - -=pod - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=head1 SEE ALSO - -L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>, -L<CPANPLUS::Selfupdate> - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - -__END__ - -todo: -sub dist { # not sure about this one -- probably already done - enough in Module.pm -sub reports { # in Module.pm, wrapper here - - diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Backend/RV.pm b/cpan/CPANPLUS/lib/CPANPLUS/Backend/RV.pm deleted file mode 100644 index e7310ee418..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Backend/RV.pm +++ /dev/null @@ -1,145 +0,0 @@ -package CPANPLUS::Backend::RV; -use deprecate; - -use strict; -use vars qw[$STRUCT $VERSION]; -$VERSION = "0.9135"; - -use CPANPLUS::Error; -use CPANPLUS::Internals::Constants; - -use IPC::Cmd qw[can_run run]; -use Params::Check qw[check]; - -use base 'Object::Accessor'; - -local $Params::Check::VERBOSE = 1; - - -=pod - -=head1 NAME - -CPANPLUS::Backend::RV - return value objects - -=head1 SYNOPSIS - - ### create a CPANPLUS::Backend::RV object - $backend_rv = CPANPLUS::Backend::RV->new( - ok => $boolean, - args => $args, - rv => $return_value - function => $calling_function ); - - ### if you have a CPANPLUS::Backend::RV object - $passed_args = $backend_rv->args; # args passed to function - $ok = $backend_rv->ok; # boolean indication overall - # result of the call - $function = $backend_rv->function # name of the calling - # function - $rv = $backend_rv->rv # the actual return value - # of the calling function - -=head1 DESCRIPTION - -This module provides return value objects for multi-module -calls to CPANPLUS::Backend. In boolean context, it returns the status -of the overall result (ie, the same as the C<ok> method would). - -=head1 METHODS - -=head2 new( ok => BOOL, args => DATA, rv => DATA, [function => $method_name] ) - -Creates a new CPANPLUS::Backend::RV object from the data provided. -This method should only be called by CPANPLUS::Backend functions. -The accessors may be used by users inspecting an RV object. - -All the argument names can be used as accessors later to retrieve the -data. - -Arguments: - -=over 4 - -=item ok - -Boolean indicating overall success - -=item args - -The arguments provided to the function that returned this rv object. -Useful to inspect later to see what was actually passed to the function -in case of an error. - -=item rv - -An arbitrary data structure that has the detailed return values of each -of your multi-module calls. - -=item function - -The name of the function that created this rv object. -Can be explicitly passed. If not, C<new()> will try to deduce the name -from C<caller()> information. - -=back - -=cut - -sub new { - my $class = shift; - my %hash = @_; - - my $tmpl = { - ok => { required => 1, allow => BOOLEANS }, - args => { required => 1 }, - rv => { required => 1 }, - function => { default => CALLING_FUNCTION->() }, - }; - - my $args = check( $tmpl, \%hash ) or return; - my $self = bless {}, $class; - -# $self->mk_accessors( qw[ok args function rv] ); - $self->mk_accessors( keys %$tmpl ); - - ### set the values passed in the struct ### - while( my($key,$val) = each %$args ) { - $self->$key( $val ); - } - - return $self; -} - -sub _ok { return shift->ok } -#sub _stringify { Carp::carp( "stringifying!" ); overload::StrVal( shift ) } - -### make it easier to check if($rv) { foo() } -### this allows people to not have to explicitly say -### if( $rv->ok ) { foo() } -### XXX add an explicit stringify, so it doesn't fall back to "bool"? :( -use overload bool => \&_ok, -# '""' => \&_stringify, - fallback => 1; - -=pod - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=cut - -1; diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Config.pm b/cpan/CPANPLUS/lib/CPANPLUS/Config.pm deleted file mode 100644 index 26a056fe03..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Config.pm +++ /dev/null @@ -1,834 +0,0 @@ -package CPANPLUS::Config; -use deprecate; - -use strict; -use warnings; - -use base 'Object::Accessor'; -use base 'CPANPLUS::Internals::Utils'; - -use Config; -use File::Spec; -use Module::Load; -use CPANPLUS; -use CPANPLUS::Error; -use CPANPLUS::Internals::Constants; - -use File::Basename qw[dirname]; -use IPC::Cmd qw[can_run]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; -use Module::Load::Conditional qw[check_install]; -use version; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -=pod - -=head1 NAME - -CPANPLUS::Config - configuration defaults and heuristics for CPANPLUS - -=head1 SYNOPSIS - - ### conf object via CPANPLUS::Backend; - $cb = CPANPLUS::Backend->new; - $conf = $cb->configure_object; - - ### or as a standalone object - $conf = CPANPLUS::Configure->new; - - ### values in 'conf' section - $verbose = $conf->get_conf( 'verbose' ); - $conf->set_conf( verbose => 1 ); - - ### values in 'program' section - $editor = $conf->get_program( 'editor' ); - $conf->set_program( editor => '/bin/vi' ); - -=head1 DESCRIPTION - -This module contains defaults and heuristics for configuration -information for CPANPLUS. To change any of these values, please -see the documentation in C<CPANPLUS::Configure>. - -Below you'll find a list of configuration types and keys, and -their meaning. - -=head1 CONFIGURATION - -=cut - -### BAH! you can't have POD interleaved with a hash -### declaration.. so declare every entry separately :( -my $Conf = { - '_fetch' => { - 'blacklist' => [ 'ftp' ], - }, - - ### _source, _build and _mirror are supposed to be static - ### no changes should be needed unless pause/cpan changes - '_source' => { - 'hosts' => 'MIRRORED.BY', - 'auth' => '01mailrc.txt.gz', - 'stored' => 'sourcefiles', - 'dslip' => '03modlist.data.gz', - 'update' => '86400', - 'mod' => '02packages.details.txt.gz', - 'custom_index' => 'packages.txt', - }, - '_build' => { - 'plugins' => 'plugins', - 'moddir' => 'build', - 'startdir' => '', - 'distdir' => 'dist', - 'autobundle' => 'autobundle', - 'autobundle_prefix' => 'Snapshot', - 'autdir' => 'authors', - 'install_log_dir' => 'install-logs', - 'custom_sources' => 'custom-sources', - 'sanity_check' => 1, - }, - '_mirror' => { - 'base' => 'authors/id/', - 'auth' => 'authors/01mailrc.txt.gz', - 'dslip' => 'modules/03modlist.data.gz', - 'mod' => 'modules/02packages.details.txt.gz' - }, -}; - -=head2 Section 'conf' - -=over 4 - -=item hosts - -An array ref containing hosts entries to be queried for packages. - -An example entry would like this: - - { 'scheme' => 'ftp', - 'path' => '/pub/CPAN/', - 'host' => 'ftp.cpan.org' - }, - -=cut - - ### default host list - $Conf->{'conf'}->{'hosts'} = [ - { - 'scheme' => 'ftp', - 'path' => '/pub/CPAN/', - 'host' => 'ftp.cpan.org' - }, - { - 'scheme' => 'http', - 'path' => '/', - 'host' => 'www.cpan.org' - }, - { - 'scheme' => 'ftp', - 'path' => '/', - 'host' => 'cpan.hexten.net' - }, - { - 'scheme' => 'ftp', - 'path' => '/CPAN/', - 'host' => 'cpan.cpantesters.org' - }, - { - 'scheme' => 'ftp', - 'path' => '/pub/languages/perl/CPAN/', - 'host' => 'ftp.funet.fi' - } - ]; - -=item allow_build_interactivity - -Boolean flag to indicate whether 'perl Makefile.PL' and similar -are run interactively or not. Defaults to 'true'. - -=cut - - $Conf->{'conf'}->{'allow_build_interactivity'} = 1; - -=item allow_unknown_prereqs - -Boolean flag to indicate that unresolvable prereqs are acceptable. -If C<true> then only warnings will be issued (the behaviour before 0.9114) -when a module is unresolvable from any our sources (CPAN and/or -C<custom_sources>). If C<false> then an unresolvable prereq will fail -during the C<prepare> stage of distribution installation. -Defaults to C<true>. - -=cut - - $Conf->{'conf'}->{'allow_unknown_prereqs'} = 1; - -=item base - -The directory CPANPLUS keeps all its build and state information in. -Defaults to ~/.cpanplus. If L<File::HomeDir> is available, that will -be used to work out your C<HOME> directory. This may be overriden by -setting the C<PERL5_CPANPLUS_HOME> environment variable, see -L<CPANPLUS::Config::HomeEnv> for more details. - -=cut - - $Conf->{'conf'}->{'base'} = File::Spec->catdir( - __PACKAGE__->_home_dir, DOT_CPANPLUS ); - -=item buildflags - -Any flags to be passed to 'perl Build.PL'. See C<perldoc Module::Build> -for details. Defaults to an empty string. - -=cut - - $Conf->{'conf'}->{'buildflags'} = ''; - -=item cpantest - -Boolean flag to indicate whether or not to mail test results of module -installations to C<http://testers.cpan.org>. Defaults to 'false'. - -=cut - - $Conf->{'conf'}->{'cpantest'} = 0; - -=item cpantest_mx - -String holding an explicit mailserver to use when sending out emails -for C<http://testers.cpan.org>. An empty string will use your system -settings. Defaults to an empty string. - -=cut - - $Conf->{'conf'}->{'cpantest_mx'} = ''; - -=item debug - -Boolean flag to enable or disable extensive debuggging information. -Defaults to 'false'. - -=cut - - $Conf->{'conf'}->{'debug'} = 0; - -=item dist_type - -Default distribution type to use when building packages. See C<cpan2dist> -or C<CPANPLUS::Dist> for details. An empty string will not use any -package building software. Defaults to an empty string. - -=cut - - $Conf->{'conf'}->{'dist_type'} = ''; - -=item email - -Email address to use for anonymous ftp access and as C<from> address -when sending emails. Defaults to an C<example.com> address. - -=cut - - $Conf->{'conf'}->{'email'} = DEFAULT_EMAIL; - -=item enable_custom_sources - -Boolean flag indicating whether custom sources should be enabled or -not. See the C<CUSTOM MODULE SOURCES> in C<CPANPLUS::Backend> for -details on how to use them. - -Defaults to C<true> - -=cut - - ### this addresses #32248 which requests a possibility to - ### turn off custom sources - $Conf->{'conf'}->{'enable_custom_sources'} = 1; - -=item extractdir - -String containing the directory where fetched archives should be -extracted. An empty string will use a directory under your C<base> -directory. Defaults to an empty string. - -=cut - - $Conf->{'conf'}->{'extractdir'} = ''; - -=item fetchdir - -String containing the directory where fetched archives should be -stored. An empty string will use a directory under your C<base> -directory. Defaults to an empty string. - -=cut - - $Conf->{'conf'}->{'fetchdir'} = ''; - -=item flush - -Boolean indicating whether build failures, cache dirs etc should -be flushed after every operation or not. Defaults to 'true'. - -=cut - - $Conf->{'conf'}->{'flush'} = 1; - -=item force - -Boolean indicating whether files should be forcefully overwritten -if they exist, modules should be installed when they fail tests, -etc. Defaults to 'false'. - -=cut - - $Conf->{'conf'}->{'force'} = 0; - -=item histfile - -A string containing the history filename of the CPANPLUS readline instance. - -=cut - - $Conf->{'conf'}->{'histfile'} = File::Spec->catdir( - __PACKAGE__->_home_dir, DOT_CPANPLUS, 'history' ); - -=item lib - -An array ref holding directories to be added to C<@INC> when CPANPLUS -starts up. Defaults to an empty array reference. - -=cut - - $Conf->{'conf'}->{'lib'} = []; - -=item makeflags - -A string holding flags that will be passed to the C<make> program -when invoked. Defaults to an empty string. - -=cut - - $Conf->{'conf'}->{'makeflags'} = ''; - -=item makemakerflags - -A string holding flags that will be passed to C<perl Makefile.PL> -when invoked. Defaults to an empty string. - -=cut - - $Conf->{'conf'}->{'makemakerflags'} = ''; - -=item md5 - -A boolean indicating whether or not sha256 checks should be done when -an archive is fetched. Defaults to 'true' if you have C<Digest::SHA> -installed, 'false' otherwise. - -=cut - - $Conf->{'conf'}->{'md5'} = ( - check_install( module => 'Digest::SHA' ) ? 1 : 0 ); - -=item no_update - -A boolean indicating whether or not C<CPANPLUS>' source files should be -updated or not. Defaults to 'false'. - -=cut - - $Conf->{'conf'}->{'no_update'} = 0; - -=item passive - -A boolean indicating whether or not to use passive ftp connections. -Defaults to 'true'. - -=cut - - $Conf->{'conf'}->{'passive'} = 1; - -=item prefer_bin - -A boolean indicating whether or not to prefer command line programs -over perl modules. Defaults to 'false' unless you do not have -C<Compress::Zlib> installed (as that would mean we could not extract -C<.tar.gz> files) - -=cut - - ### if we dont have c::zlib, we'll need to use /bin/tar or we - ### can not extract any files. Good time to change the default - $Conf->{'conf'}->{'prefer_bin'} = - (eval {require Compress::Zlib; 1} ? 0 : 1 ); - -=item prefer_makefile - -A boolean indicating whether or not prefer a C<Makefile.PL> over a -C<Build.PL> file if both are present. Defaults to 'true', unless -the perl version is at least 5.10.1 or appropriate versions of L<Module::Build> -and L<CPANPLUS::Dist::Build> are available. - -=cut - - $Conf->{'conf'}->{'prefer_makefile'} = - ( $] >= 5.010001 or - ( check_install( module => 'Module::Build', version => '0.32' ) and - check_install( module => INSTALLER_BUILD, version => '0.60' ) ) - ? 0 : 1 ); - -=item prereqs - -A digit indicating what to do when a package you are installing has a -prerequisite. Options are: - - 0 Do not install - 1 Install - 2 Ask - 3 Ignore (dangerous, install will probably fail!) - -The default is to ask. - -=cut - - $Conf->{'conf'}->{'prereqs'} = PREREQ_ASK; - -=item shell - -A string holding the shell class you wish to start up when starting -C<CPANPLUS> in interactive mode. - -Defaults to C<CPANPLUS::Shell::Default>, the default CPANPLUS shell. - -=cut - - $Conf->{'conf'}->{'shell'} = 'CPANPLUS::Shell::Default'; - -=item show_startup_tip - -A boolean indicating whether or not to show start up tips in the -interactive shell. Defaults to 'true'. - -=cut - - $Conf->{'conf'}->{'show_startup_tip'} = 1; - -=item signature - -A boolean indicating whether or not check signatures if packages are -signed. Defaults to 'true' if you have C<gpg> or C<Crypt::OpenPGP> -installed, 'false' otherwise. - -=cut - - $Conf->{'conf'}->{'signature'} = do { - check_install( module => 'Module::Signature', version => '0.06' ) - and ( can_run('gpg') || - check_install(module => 'Crypt::OpenPGP') - ); - } ? 1 : 0; - -=item skiptest - -A boolean indicating whether or not to skip tests when installing modules. -Defaults to 'false'. - -=cut - - $Conf->{'conf'}->{'skiptest'} = 0; - -=item storable - -A boolean indicating whether or not to use C<Storable> to write compiled -source file information to disk. This makes for faster startup and look -up times, but takes extra diskspace. Defaults to 'true' if you have -C<Storable> installed and 'false' if you don't. - -=cut - - $Conf->{'conf'}->{'storable'} = - ( check_install( module => 'Storable' ) ? 1 : 0 ); - -=item timeout - -Digit indicating the time before a fetch request times out (in seconds). -Defaults to 300. - -=cut - - $Conf->{'conf'}->{'timeout'} = 300; - -=item verbose - -A boolean indicating whether or not C<CPANPLUS> runs in verbose mode. -Defaults to 'true' if you have the environment variable -C<PERL5_CPANPLUS_VERBOSE> set to true, 'false' otherwise. - -It is recommended you run with verbose enabled, but it is disabled -for historical reasons. - -=cut - - $Conf->{'conf'}->{'verbose'} = $ENV{PERL5_CPANPLUS_VERBOSE} || 0; - -=item write_install_log - -A boolean indicating whether or not to write install logs after installing -a module using the interactive shell. Defaults to 'true'. - - -=cut - - $Conf->{'conf'}->{'write_install_logs'} = 1; - -=item source_engine - -Class to use as the source engine, which is generally a subclass of -C<CPANPLUS::Internals::Source>. Default to C<CPANPLUS::Internals::Source::Memory>. - -=cut - - $Conf->{'conf'}->{'source_engine'} = DEFAULT_SOURCE_ENGINE; - -=item cpantest_reporter_args - -A hashref of key => value pairs that are passed to the constructor -of C<Test::Reporter>. If you'd want to enable TLS for example, you'd -set it to: - - { transport => 'Net::SMTP::TLS', - transport_args => [ User => 'Joe', Password => '123' ], - } - -=cut - - $Conf->{'conf'}->{'cpantest_reporter_args'} = {}; - -=back - -=head2 Section 'program' - -=cut - - ### Paths get stripped of whitespace on win32 in the constructor - ### sudo gets emptied if there's no need for it in the constructor - -=over 4 - -=item editor - -A string holding the path to your editor of choice. Defaults to your -$ENV{EDITOR}, $ENV{VISUAL}, 'vi' or 'pico' programs, in that order. - -=cut - - $Conf->{'program'}->{'editor'} = do { - $ENV{'EDITOR'} || $ENV{'VISUAL'} || - can_run('vi') || can_run('pico') - }; - -=item make - -A string holding the path to your C<make> binary. Looks for the C<make> -program used to build perl or failing that, a C<make> in your path. - -=cut - - $Conf->{'program'}->{'make'} = - can_run($Config{'make'}) || can_run('make'); - -=item pager - -A string holding the path to your pager of choice. Defaults to your -$ENV{PAGER}, 'less' or 'more' programs, in that order. - -=cut - - $Conf->{'program'}->{'pager'} = - $ENV{'PAGER'} || can_run('less') || can_run('more'); - - ### no one uses this feature anyway, and it's only working for EU::MM - ### and not for module::build - #'perl' => '', - -=item shell - -A string holding the path to your login shell of choice. Defaults to your -$ENV{SHELL} setting, or $ENV{COMSPEC} on Windows. - -=cut - - $Conf->{'program'}->{'shell'} = $^O eq 'MSWin32' - ? $ENV{COMSPEC} - : $ENV{SHELL}; - -=item sudo - -A string holding the path to your C<sudo> binary if your install path -requires super user permissions. Looks for C<sudo> in your path, or -remains empty if you do not require super user permissions to install. - -=cut - - $Conf->{'program'}->{'sudo'} = do { - ### let's assume you dont need sudo, - ### unless one of the below criteria tells us otherwise - my $sudo = undef; - - ### you're a normal user, you might need sudo - if( $> ) { - - ### check for all install dirs! - ### you have write permissions to the installdir, - ### you don't need sudo - if( -w $Config{'installsitelib'} && -w $Config{'installsitebin'} ) { - - ### installsiteman3dir is a 5.8'ism.. don't check - ### it on 5.6.x... - if( defined $Config{'installsiteman3dir'} ) { - $sudo = -w $Config{'installsiteman3dir'} - ? undef - : can_run('sudo'); - } else { - $sudo = undef; - } - - ### you have PERL_MM_OPT set to some alternate - ### install place. You probably have write permissions - ### to that - } elsif ( $ENV{'PERL_MM_OPT'} and - $ENV{'PERL_MM_OPT'} =~ /INSTALL|LIB|PREFIX/ - ) { - $sudo = undef; - - ### you probably don't have write permissions - } else { - $sudo = can_run('sudo'); - } - } - - ### and return the value - $sudo; - }; - -=item perlwrapper - -B<DEPRECATED> - -A string holding the path to the C<cpanp-run-perl> utility bundled -with CPANPLUS, which is used to enable autoflushing in spawned processes. - -=cut - - ### perlwrapper that allows us to turn on autoflushing - $Conf->{'program'}->{'perlwrapper'} = sub { - my $name = 'cpanp-run-perl'; - - my @bins = do{ - require Config; - my $ver = $Config::Config{version}; - - ### if we are running with 'versiononly' enabled, - ### all binaries will have the perlversion appended - ### ie, cpanp will become cpanp5.9.5 - ### so prefer the versioned binary in that case - $Config::Config{versiononly} - ? ($name.$ver, $name) - : ($name, $name.$ver); - }; - - ### patch from Steve Hay Fri 29 Jun 2007 14:26:02 GMT+02:00 - ### Msg-Id: <4684FA5A.7030506@uk.radan.com> - ### look for files with a ".bat" extension as well on Win32 - @bins = map { $_, "$_.bat" } @bins if $^O eq 'MSWin32'; - - my $path; - BIN: for my $bin (@bins) { - - ### parallel to your cpanp/cpanp-boxed - my $maybe = File::Spec->rel2abs( - File::Spec->catfile( dirname($0), $bin ) - ); - $path = $maybe and last BIN if -f $maybe; - - ### parallel to your CPANPLUS.pm: - ### $INC{cpanplus}/../bin/cpanp-run-perl - $maybe = File::Spec->rel2abs( - File::Spec->catfile( - dirname($INC{'CPANPLUS.pm'}), - '..', # lib dir - 'bin', # bin dir - $bin, # script - ) - ); - $path = $maybe and last BIN if -f $maybe; - - ### you installed CPANPLUS in a custom prefix, - ### so go parallel to /that/. PREFIX=/tmp/cp - ### would put cpanp-run-perl in /tmp/cp/bin and - ### CPANPLUS.pm in - ### /tmp/cp/lib/perl5/site_perl/5.8.8 - $maybe = File::Spec->rel2abs( - File::Spec->catfile( - dirname( $INC{'CPANPLUS.pm'} ), - '..', '..', '..', '..', # 4x updir - 'bin', # bin dir - $bin, # script - ) - ); - $path = $maybe and last BIN if -f $maybe; - - ### in your path -- take this one last, the - ### previous two assume extracted tarballs - ### or user installs - ### note that we don't use 'can_run' as it's - ### not an executable, just a wrapper... - ### prefer anything that's found in the path paralel to your $^X - for my $dir (File::Spec->rel2abs( dirname($^X) ), - split(/\Q$Config::Config{path_sep}\E/, $ENV{PATH}), - File::Spec->curdir, - ) { - - ### On VMS the path could be in UNIX format, and we - ### currently need it to be in VMS format - $dir = VMS::Filespec::vmspath($dir) if ON_VMS; - - $maybe = File::Spec->catfile( $dir, $bin ); - $path = $maybe and last BIN if -f $maybe; - } - } - - ### we should have a $path by now ideally, if so return it - return $path if defined $path; - - ### CPANPLUS::Dist::MM doesn't require this anymore - ### but CPANPLUS::Dist::Build might if it is less than 0.60 - my $cpdb = check_install( module => INSTALLER_BUILD ); - return '' unless - $cpdb and eval { version->parse($cpdb->{version}) < version->parse('0.60') }; - - ### if not, warn about it and give sensible default. - ### XXX try to be a no-op instead then.. - ### cross your fingers... - ### pass '-P' to perl: "run program through C - ### preprocessor before compilation" - ### XXX using -P actually changes the way some Makefile.PLs - ### are executed, so don't do that... --kane - error(loc( - "Could not find the '%1' binary in your path". - "--this may be a problem.\n". - "Please locate this program and set ". - "your '%2' config entry to its path.\n". - "From the default shell, you can do this by typing:\n\n". - " %3\n". - " %4\n", - $name, 'perlwrapper', - 's program perlwrapper FULL_PATH_TO_CPANP_RUN_PERL', - 's save' - )); - return ''; - }->(); - -=back - -=cut - -sub new { - my $class = shift; - my $obj = $class->SUPER::new; - - $obj->mk_accessors( keys %$Conf ); - - for my $acc ( keys %$Conf ) { - my $subobj = Object::Accessor->new; - $subobj->mk_accessors( keys %{$Conf->{$acc}} ); - - ### read in all the settings from the sub accessors; - for my $subacc ( $subobj->ls_accessors ) { - $subobj->$subacc( $Conf->{$acc}->{$subacc} ); - } - - ### now store it in the parent object - $obj->$acc( $subobj ); - } - - $obj->_clean_up_paths; - - ### shut up IPC::Cmd warning about not findin IPC::Run on win32 - $IPC::Cmd::WARN = 0; - - return $obj; -} - -sub _clean_up_paths { - my $self = shift; - - ### clean up paths if we are on win32 - if( $^O eq 'MSWin32' ) { - for my $pgm ( $self->program->ls_accessors ) { - my $path = $self->program->$pgm; - - ### paths with whitespace needs to be shortened - ### for shell outs. - if ($path and $path =~ /\s+/) { - my($prog, $args); - - ### patch from Steve Hay, 13nd of June 2007 - ### msg-id: <467012A4.6060705@uk.radan.com> - ### windows directories are not allowed to end with - ### a space, so any occurrence of '\w\s+/\w+' means - ### we're dealing with arguments, not directory - ### names. - if ($path =~ /^(.*?)(\s+\/.*$)/) { - ($prog, $args) = ($1, $2); - - ### otherwise, there are no arguments - } else { - ($prog, $args) = ($path, ''); - } - - $prog = Win32::GetShortPathName( $prog ); - $self->program->$pgm( $prog . $args ); - } - } - } - - return 1; -} - -1; - -=pod - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=head1 SEE ALSO - -L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Configure> - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Config/HomeEnv.pm b/cpan/CPANPLUS/lib/CPANPLUS/Config/HomeEnv.pm deleted file mode 100644 index 90703a066d..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Config/HomeEnv.pm +++ /dev/null @@ -1,63 +0,0 @@ -package CPANPLUS::Config::HomeEnv; -use deprecate; - -use strict; -use File::Spec; -use vars qw($VERSION); - -$VERSION = "0.9135"; - -sub setup { - my $conf = shift; - $conf->set_conf( base => File::Spec->catdir( $ENV{PERL5_CPANPLUS_HOME}, '.cpanplus' ) ) - if $ENV{PERL5_CPANPLUS_HOME}; - return 1; -} - -qq'Wherever I hang my hat is home'; - -__END__ - -=head1 NAME - -CPANPLUS::Config::HomeEnv - Set the environment for the CPANPLUS base dir - -=head1 SYNOPSIS - - export PERL5_CPANPLUS_HOME=/home/moo/perls/conf/perl-5.8.9/ - -=head1 DESCRIPTION - -CPANPLUS::Config::HomeEnv is a L<CPANPLUS::Config> file that allows the CPANPLUS user to -specify where L<CPANPLUS> gets its configuration from. - -Setting the environment variable C<PERL5_CPANPLUS_HOME> to a path location, determines -where the C<.cpanplus> directory will be located. - -=head1 METHODS - -=over - -=item C<setup> - -Called by L<CPANPLUS::Configure>. - -=back - -=head1 AUTHOR - -Chris C<BinGOs> Williams <chris@bingosnet.co.uk> - -Contributions and patience from Jos Boumans the L<CPANPLUS> guy! - -=head1 LICENSE - -Copyright E<copy> Chris Williams and Jos Boumans. - -This module may be used, modified, and distributed under the same terms as Perl itself. Please see the license that came with your Perl distribution for details. - -=head1 SEE ALSO - -L<CPANPLUS> - -=cut diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Configure.pm b/cpan/CPANPLUS/lib/CPANPLUS/Configure.pm deleted file mode 100644 index 1abf759ef7..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Configure.pm +++ /dev/null @@ -1,637 +0,0 @@ -package CPANPLUS::Configure; -use deprecate; -use strict; - - -use CPANPLUS::Internals::Constants; -use CPANPLUS::Error; -use CPANPLUS::Config; - -use Log::Message; -use Module::Load qw[load]; -use Params::Check qw[check]; -use File::Basename qw[dirname]; -use Module::Loaded (); -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -use vars qw[$AUTOLOAD $VERSION $MIN_CONFIG_VERSION]; -use base qw[CPANPLUS::Internals::Utils]; - -local $Params::Check::VERBOSE = 1; - -### require, avoid circular use ### -require CPANPLUS::Internals; -$VERSION = "0.9135"; - -### can't use O::A as we're using our own AUTOLOAD to get to -### the config options. -for my $meth ( qw[conf _lib _perl5lib]) { - no strict 'refs'; - - *$meth = sub { - my $self = shift; - $self->{'_'.$meth} = $_[0] if @_; - return $self->{'_'.$meth}; - } -} - - -=pod - -=head1 NAME - -CPANPLUS::Configure - configuration for CPANPLUS - -=head1 SYNOPSIS - - $conf = CPANPLUS::Configure->new( ); - - $bool = $conf->can_save; - $bool = $conf->save( $where ); - - @opts = $conf->options( $type ); - - $make = $conf->get_program('make'); - $verbose = $conf->set_conf( verbose => 1 ); - -=head1 DESCRIPTION - -This module deals with all the configuration issues for CPANPLUS. -Users can use objects created by this module to alter the behaviour -of CPANPLUS. - -Please refer to the C<CPANPLUS::Backend> documentation on how to -obtain a C<CPANPLUS::Configure> object. - -=head1 METHODS - -=head2 $Configure = CPANPLUS::Configure->new( load_configs => BOOL ) - -This method returns a new object. Normal users will never need to -invoke the C<new> method, but instead retrieve the desired object via -a method call on a C<CPANPLUS::Backend> object. - -=over 4 - -=item load_configs - -Controls whether or not additional user configurations are to be loaded -or not. Defaults to C<true>. - -=back - -=cut - -### store the CPANPLUS::Config object in a closure, so we only -### initialize it once.. otherwise, on a 2nd ->new, settings -### from configs on top of this one will be reset -{ my $Config; - - sub new { - my $class = shift; - my %hash = @_; - - ### XXX pass on options to ->init() like rescan? - my ($load); - my $tmpl = { - load_configs => { default => 1, store => \$load }, - }; - - check( $tmpl, \%hash ) or ( - warn Params::Check->last_error, return - ); - - $Config ||= CPANPLUS::Config->new; - my $self = bless {}, $class; - $self->conf( $Config ); - - ### you want us to load other configs? - ### these can override things in the default config - $self->init if $load; - - ### after processing the config files, check what - ### @INC and PERL5LIB are set to. - $self->_lib( \@INC ); - $self->_perl5lib( $ENV{'PERL5LIB'} ); - - return $self; - } -} - -=head2 $bool = $Configure->init( [rescan => BOOL]) - -Initialize the configure with other config files than just -the default 'CPANPLUS::Config'. - -Called from C<new()> to load user/system configurations - -If the C<rescan> option is provided, your disk will be -examined again to see if there are new config files that -could be read. Defaults to C<false>. - -Returns true on success, false on failure. - -=cut - -### move the Module::Pluggable detection to runtime, rather -### than compile time, so that a simple 'require CPANPLUS' -### doesn't start running over your filesystem for no good -### reason. Make sure we only do the M::P call once though. -### we use $loaded to mark it -{ my $loaded; - my $warned; - sub init { - my $self = shift; - my $obj = $self->conf; - my %hash = @_; - - my ($rescan); - my $tmpl = { - rescan => { default => 0, store => \$rescan }, - }; - - check( $tmpl, \%hash ) or ( - warn Params::Check->last_error, return - ); - - ### if the base dir is changed, we have to rescan it - ### for any CPANPLUS::Config::* files as well, so keep - ### track of it - my $cur_base = $self->get_conf('base'); - - ### warn if we find an old style config specified - ### via environment variables - { my $env = ENV_CPANPLUS_CONFIG; - if( $ENV{$env} and not $warned ) { - $warned++; - error(loc("Specifying a config file in your environment " . - "using %1 is obsolete.\nPlease follow the ". - "directions outlined in %2 or use the '%3' command\n". - "in the default shell to use custom config files.", - $env, "CPANPLUS::Configure->save", 's save')); - } - } - - { ### make sure that the homedir is included now - local @INC = ( LIB_DIR->($cur_base), @INC ); - - ### only set it up once - if( !$loaded++ or $rescan ) { - ### find plugins & extra configs - ### check $home/.cpanplus/lib as well - require Module::Pluggable; - - Module::Pluggable->import( - search_path => ['CPANPLUS::Config'], - search_dirs => [ LIB_DIR->($cur_base) ], - except => qr/::SUPER$/, - sub_name => 'configs' - ); - } - - - ### do system config, user config, rest.. in that order - ### apparently, on a 2nd invocation of -->configs, a - ### ::ISA::CACHE package can appear.. that's bad... - my %confs = map { $_ => $_ } - grep { $_ !~ /::ISA::/ } __PACKAGE__->configs; - my @confs = grep { defined } - map { delete $confs{$_} } CONFIG_SYSTEM, CONFIG_USER; - push @confs, sort keys %confs; - - for my $plugin ( @confs ) { - msg(loc("Found config '%1'", $plugin),0); - - ### if we already did this the /last/ time around dont - ### run the setup agian. - if( my $loc = Module::Loaded::is_loaded( $plugin ) ) { - msg(loc(" Already loaded '%1' (%2)", $plugin, $loc), 0); - next; - } else { - msg(loc(" Loading config '%1'", $plugin),0); - - if( eval { load $plugin; 1 } ) { - msg(loc(" Loaded '%1' (%2)", - $plugin, Module::Loaded::is_loaded( $plugin ) ), 0); - } else { - error(loc(" Error loading '%1': %2", $plugin, $@)); - } - } - - if( $@ ) { - error(loc("Could not load '%1': %2", $plugin, $@)); - next; - } - - my $sub = $plugin->can('setup'); - $sub->( $self ) if $sub; - } - } - - ### did one of the plugins change the base dir? then we should - ### scan the dirs again - if( $cur_base ne $self->get_conf('base') ) { - msg(loc("Base dir changed from '%1' to '%2', rescanning", - $cur_base, $self->get_conf('base')), 0); - $self->init( @_, rescan => 1 ); - } - - ### clean up the paths once more, just in case - $obj->_clean_up_paths; - - ### XXX in case the 'lib' param got changed, we need to - ### add that now, or it's not propagating ;( - { my $lib = $self->get_conf('lib'); - my %inc = map { $_ => $_ } @INC; - for my $l ( @$lib ) { - push @INC, $l unless $inc{$l}; - } - $self->_lib( \@INC ); - } - - return 1; - } -} -=pod - -=head2 can_save( [$config_location] ) - -Check if we can save the configuration to the specified file. -If no file is provided, defaults to your personal config. - -Returns true if the file can be saved, false otherwise. - -=cut - -sub can_save { - my $self = shift; - my $file = shift || CONFIG_USER_FILE->(); - - return 1 unless -e $file; - - chmod 0644, $file; - return (-w $file); -} - -=pod - -=head2 $file = $conf->save( [$package_name] ) - -Saves the configuration to the package name you provided. -If this package is not C<CPANPLUS::Config::System>, it will -be saved in your C<.cpanplus> directory, otherwise it will -be attempted to be saved in the system wide directory. - -If no argument is provided, it will default to your personal -config. - -Returns the full path to the file if the config was saved, -false otherwise. - -=cut - -sub _config_pm_to_file { - my $self = shift; - my $pm = shift or return; - my $dir = shift || CONFIG_USER_LIB_DIR->(); - - ### only 3 types of files know: home, system and 'other' - ### so figure out where to save them based on their type - my $file; - if( $pm eq CONFIG_USER ) { - $file = CONFIG_USER_FILE->(); - - } elsif ( $pm eq CONFIG_SYSTEM ) { - $file = CONFIG_SYSTEM_FILE->(); - - ### third party file - } else { - my $cfg_pkg = CONFIG . '::'; - unless( $pm =~ /^$cfg_pkg/ ) { - error(loc( - "WARNING: Your config package '%1' is not in the '%2' ". - "namespace and will not be automatically detected by %3", - $pm, $cfg_pkg, 'CPANPLUS' - )); - } - - $file = File::Spec->catfile( - $dir, - split( '::', $pm ) - ) . '.pm'; - } - - return $file; -} - - -sub save { - my $self = shift; - my $pm = shift || CONFIG_USER; - my $savedir = shift || ''; - - my $file = $self->_config_pm_to_file( $pm, $savedir ) or return; - my $dir = dirname( $file ); - - unless( -d $dir ) { - $self->_mkdir( dir => $dir ) or ( - error(loc("Can not create directory '%1' to save config to",$dir)), - return - ) - } - return unless $self->can_save($file); - - ### find only accessors that are not private - my @acc = sort grep { $_ !~ /^_/ } $self->conf->ls_accessors; - - ### for dumping the values - use Data::Dumper; - - my @lines; - for my $acc ( @acc ) { - - push @lines, "### $acc section", $/; - - for my $key ( $self->conf->$acc->ls_accessors ) { - my $val = Dumper( $self->conf->$acc->$key ); - - $val =~ s/\$VAR1\s+=\s+//; - $val =~ s/;\n//; - - push @lines, '$'. "conf->set_${acc}( $key => $val );", $/; - } - push @lines, $/,$/; - - } - - my $str = join '', map { " $_" } @lines; - - ### use a variable to make sure the pod parser doesn't snag it - my $is = '='; - my $time = gmtime; - - - my $msg = <<_END_OF_CONFIG_; -############################################### -### -### Configuration structure for $pm -### -############################################### - -#last changed: $time GMT - -### minimal pod, so you can find it with perldoc -l, etc -${is}pod - -${is}head1 NAME - -$pm - -${is}head1 DESCRIPTION - -This is a CPANPLUS configuration file. Editing this -config changes the way CPANPLUS will behave - -${is}cut - -package $pm; - -use strict; - -sub setup { - my \$conf = shift; - -$str - - return 1; -} - -1; - -_END_OF_CONFIG_ - - $self->_move( file => $file, to => "$file~" ) if -f $file; - - my $fh = new FileHandle; - $fh->open(">$file") - or (error(loc("Could not open '%1' for writing: %2", $file, $!)), - return ); - - $fh->print($msg); - $fh->close; - - return $file; -} - -=pod - -=head2 options( type => TYPE ) - -Returns a list of all valid config options given a specific type -(like for example C<conf> of C<program>) or false if the type does -not exist - -=cut - -sub options { - my $self = shift; - my $conf = $self->conf; - my %hash = @_; - - my $type; - my $tmpl = { - type => { required => 1, default => '', - strict_type => 1, store => \$type }, - }; - - check($tmpl, \%hash) or return; - - my %seen; - return sort grep { !$seen{$_}++ } - map { $_->$type->ls_accessors if $_->can($type) } - $self->conf; - return; -} - -=pod - -=head1 ACCESSORS - -Accessors that start with a C<_> are marked private -- regular users -should never need to use these. - -See the C<CPANPLUS::Config> documentation for what items can be -set and retrieved. - -=head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] ); - -The C<get_*> style accessors merely retrieves one or more desired -config options. - -=head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] ); - -The C<set_*> style accessors set the current value for one -or more config options and will return true upon success, false on -failure. - -=head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] ); - -The C<add_*> style accessor adds a new key to a config key. - -Currently, the following accessors exist: - -=over 4 - -=item set|get_conf - -Simple configuration directives like verbosity and favourite shell. - -=item set|get_program - -Location of helper programs. - -=item _set|_get_build - -Locations of where to put what files for CPANPLUS. - -=item _set|_get_source - -Locations and names of source files locally. - -=item _set|_get_mirror - -Locations and names of source files remotely. - -=item _set|_get_fetch - -Special settings pertaining to the fetching of files. - -=back - -=cut - -sub AUTOLOAD { - my $self = shift; - my $conf = $self->conf; - - my $name = $AUTOLOAD; - $name =~ s/.+:://; - - my ($private, $action, $field) = - $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/; - - my $type = ''; - $type .= '_' if $private; - $type .= $field if $field; - - my $type_code = $conf->can($type); - unless ( $type_code ) { - error( loc("Invalid method type: '%1'", $name) ); - return; - } - my $type_obj = $type_code->(); - - unless( scalar @_ ) { - error( loc("No arguments provided!") ); - return; - } - - ### retrieve a current value for an existing key ### - if( $action eq 'get' ) { - for my $key (@_) { - my @list = (); - - ### get it from the user config first - if( my $code = $type_obj->can($key) ) { - push @list, $code->(); - - ### XXX EU::AI compatibility hack to provide lookups like in - ### cpanplus 0.04x; we renamed ->_get_build('base') to - ### ->get_conf('base') - } elsif ( $type eq '_build' and $key eq 'base' ) { - return $self->get_conf($key); - - } else { - error( loc(q[No such key '%1' in field '%2'], $key, $type) ); - return; - } - - return wantarray ? @list : $list[0]; - } - - ### set an existing key to a new value ### - } elsif ( $action eq 'set' ) { - my %args = @_; - - while( my($key,$val) = each %args ) { - - if( my $code = $type_obj->can($key) ) { - $code->( $val ); - - } else { - error( loc(q[No such key '%1' in field '%2'], $key, $type) ); - return; - } - } - - return 1; - - ### add a new key to the config ### - } elsif ( $action eq 'add' ) { - my %args = @_; - - while( my($key,$val) = each %args ) { - - if( $type_obj->can($key) ) { - error( loc( q[Key '%1' already exists for field '%2'], - $key, $type)); - return; - } else { - $type_obj->mk_accessors( $key ); - $type_obj->$key( $val ); - } - } - return 1; - - } else { - - error( loc(q[Unknown action '%1'], $action) ); - return; - } -} - -sub DESTROY { 1 }; - -1; - -=pod - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=head1 SEE ALSO - -L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Config> - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Configure/Setup.pm b/cpan/CPANPLUS/lib/CPANPLUS/Configure/Setup.pm deleted file mode 100644 index 8ac565a70e..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Configure/Setup.pm +++ /dev/null @@ -1,1654 +0,0 @@ -package CPANPLUS::Configure::Setup; -use deprecate; - -use strict; -use vars qw[@ISA $VERSION]; -$VERSION = "0.9135"; - -use base qw[CPANPLUS::Internals::Utils]; -use base qw[Object::Accessor]; - -use Config; -use Term::UI; -use Module::Load; -use Term::ReadLine; - -use CPANPLUS::Internals::Utils; -use CPANPLUS::Internals::Constants; -use CPANPLUS::Error; - -use IPC::Cmd qw[can_run]; -use Params::Check qw[check]; -use Module::Load::Conditional qw[check_install]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -### silence Term::UI -$Term::UI::VERBOSE = 0; - -#Can't ioctl TIOCGETP: Unknown error -#Consider installing Term::ReadKey from CPAN site nearby -# at http://www.perl.com/CPAN -#Or use -# perl -MCPAN -e shell -#to reach CPAN. Falling back to 'stty'. -# If you do not want to see this warning, set PERL_READLINE_NOWARN -#in your environment. -#'stty' is not recognized as an internal or external command, -#operable program or batch file. -#Cannot call `stty': No such file or directory at C:/Perl/site/lib/Term/ReadLine/ - -### setting this var in the meantime to avoid this warning ### -$ENV{PERL_READLINE_NOWARN} = 1; - - -sub new { - my $class = shift; - my %hash = @_; - - my $tmpl = { - configure_object => { }, - term => { }, - backend => { }, - autoreply => { default => 0, }, - skip_mirrors => { default => 0, }, - use_previous => { default => 1, }, - config_type => { default => CONFIG_USER }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - ### initialize object - my $obj = $class->SUPER::new( keys %$tmpl ); - for my $acc ( $obj->ls_accessors ) { - $obj->$acc( $args->{$acc} ); - } - - ### otherwise there's a circular use ### - load CPANPLUS::Configure; - load CPANPLUS::Backend; - - $obj->configure_object( CPANPLUS::Configure->new() ) - unless $obj->configure_object; - - $obj->backend( CPANPLUS::Backend->new( $obj->configure_object ) ) - unless $obj->backend; - - ### use empty string in case user only has T::R::Stub -- it complains - $obj->term( Term::ReadLine->new('') ) - unless $obj->term; - - ### enable autoreply if that was passed ### - $Term::UI::AUTOREPLY = $obj->autoreply; - - return $obj; -} - -sub init { - my $self = shift; - my $term = $self->term; - - ### default setting, unless changed - $self->config_type( CONFIG_USER ) unless $self->config_type; - - my $save = loc('Save & exit'); - my $exit = loc('Quit without saving'); - my @map = ( - # key on the display # method to dispatch to - [ loc('Select Configuration file') => '_save_where' ], - [ loc('Setup CLI Programs') => '_setup_program' ], - [ loc('Setup CPANPLUS Home directory') => '_setup_base' ], - [ loc('Setup FTP/Email settings') => '_setup_ftp' ], - [ loc('Setup basic preferences') => '_setup_conf' ], - [ loc('Setup installer settings') => '_setup_installer' ], - [ loc('Select mirrors'), => '_setup_hosts' ], - [ loc('Edit configuration file') => '_edit' ], - [ $save => '_save' ], - [ $exit => 1 ], - ); - - my @keys = map { $_->[0] } @map; # sorted keys - my %map = map { @$_ } @map; # lookup hash - - PICK_SECTION: { - print loc(" -=================> MAIN MENU <================= - -Welcome to the CPANPLUS configuration. Please select which -parts you wish to configure - -Defaults are taken from your current configuration. -If you would save now, your settings would be written to: - - %1 - - ", $self->config_type ); - - my $choice = $term->get_reply( - prompt => "Section to configure:", - choices => \@keys, - default => $keys[0] - ); - - ### exit configuration? - if( $choice eq $exit ) { - print loc(" -Quitting setup, changes will not be saved. - "); - return 1; - } - - my $method = $map{$choice}; - - my $rv = $self->$method or print loc(" -There was an error setting up this section. You might want to try again - "); - - ### was it save & exit? - if( $choice eq $save and $rv ) { - print loc(" -Quitting setup, changes are saved to '%1' - ", $self->config_type - ); - return 1; - } - - ### otherwise, present choice again - redo PICK_SECTION; - } - - return 1; -} - - - -### sub that figures out what kind of config type the user wants -sub _save_where { - my $self = shift; - my $term = $self->term; - my $conf = $self->configure_object; - - - ASK_CONFIG_TYPE: { - - print loc( q[ -Where would you like to save your CPANPLUS Configuration file? - -If you want to configure CPANPLUS for this user only, -select the '%1' option. -The file will then be saved in your homedirectory. - -If you are the system administrator of this machine, -and would like to make this config available globally, -select the '%2' option. -The file will be then be saved in your CPANPLUS -installation directory. - - ], CONFIG_USER, CONFIG_SYSTEM ); - - - ### ask what config type we should save to - my $type = $term->get_reply( - prompt => loc("Type of configuration file"), - default => $self->config_type || CONFIG_USER, - choices => [CONFIG_USER, CONFIG_SYSTEM], - ); - - my $file = $conf->_config_pm_to_file( $type ); - - ### can we save to this file? - unless( $conf->can_save( $file ) ) { - error(loc( - "Can not save to file '%1'-- please check permissions " . - "and try again", $file - )); - - redo ASK_CONFIG_FILE; - } - - ### you already have the file -- are we allowed to overwrite - ### or should we try again? - if ( -e $file and -w _ ) { - print loc(q[ -I see you already have this file: - %1 - -The file will not be overwritten until you explicitly save it. - - ], $file ); - - redo ASK_CONFIG_TYPE - unless $term->ask_yn( - prompt => loc( "Do you wish to use this file?"), - default => 'n', - ); - } - - print $/, loc("Using '%1' as your configuration type", $type); - - return $self->config_type($type); - } -} - - -### setup the build & cache dirs -sub _setup_base { - my $self = shift; - my $term = $self->term; - my $conf = $self->configure_object; - - my $base = $conf->get_conf('base'); - my $home = File::Spec->catdir( $self->_home_dir, DOT_CPANPLUS ); - - print loc(" -CPANPLUS needs a directory of its own to cache important index -files and maybe keep a temporary mirror of CPAN files. -This may be a site-wide directory or a personal directory. - -For a single-user installation, we suggest using your home directory. - -"); - - my $where; - ASK_HOME_DIR: { - my $other = loc('Somewhere else'); - if( $base and ($base ne $home) ) { - print loc("You have several choices:"); - - $where = $term->get_reply( - prompt => loc('Please pick one'), - choices => [$home, $base, $other], - default => $home, - ); - } else { - $where = $base; - } - - if( $where and -d $where ) { - print loc(" -I see you already have a directory: - %1 - - "), $where; - - my $yn = $term->ask_yn( - prompt => loc('Should I use it?'), - default => 'y', - ); - $where = '' unless $yn; - } - - if( $where and ($where ne $other) and not -d $where ) { - if (!$self->_mkdir( dir => $where ) ) { - print "\n", loc("Unable to create directory '%1'", $where); - redo ASK_HOME_DIR; - } - - } elsif( not $where or ($where eq $other) ) { - print loc(" -First of all, I'd like to create this directory. - - "); - - NEW_HOME: { - $where = $term->get_reply( - prompt => loc('Where shall I create it?'), - default => $home, - ); - - my $again; - if( -d $where and not -w _ ) { - print "\n", loc("I can't seem to write in this directory"); - $again++; - } elsif (!$self->_mkdir( dir => $where ) ) { - print "\n", loc("Unable to create directory '%1'", $where); - $again++; - } - - if( $again ) { - print "\n", loc('Please select another directory'), "\n\n"; - redo NEW_HOME; - } - } - } - } - - ### tidy up the path and store it - $where = File::Spec->rel2abs($where); - $conf->set_conf( base => $where ); - - ### create subdirectories ### - my @dirs = - File::Spec->catdir( $where, $self->_perl_version(perl => $^X), - $conf->_get_build('moddir') ), - map { - File::Spec->catdir( $where, $conf->_get_build($_) ) - } qw[autdir distdir]; - - for my $dir ( @dirs ) { - unless( $self->_mkdir( dir => $dir ) ) { - warn loc("I wasn't able to create '%1'", $dir), "\n"; - } - } - - ### clear away old storable images before 0.031 - for my $src (qw[dslip mailrc packages]) { - 1 while unlink File::Spec->catfile( $where, $src ); - - } - - print loc(q[ -Your CPANPLUS build and cache directory has been set to: - %1 - - ], $where); - - return 1; -} - -sub _setup_ftp { - my $self = shift; - my $term = $self->term; - my $conf = $self->configure_object; - - ######################### - ## are you a pacifist? ## - ######################### - - print loc(" -If you are connecting through a firewall or proxy that doesn't handle -FTP all that well you can use passive FTP. - -"); - - my $yn = $term->ask_yn( - prompt => loc("Use passive FTP?"), - default => $conf->get_conf('passive'), - ); - - $conf->set_conf(passive => $yn); - - ### set the ENV var as well, else it won't get set till AFTER - ### the configuration is saved. but we fetch files BEFORE that. - $ENV{FTP_PASSIVE} = $yn; - - print "\n"; - print $yn - ? loc("I will use passive FTP.") - : loc("I won't use passive FTP."); - print "\n"; - - ############################# - ## should fetches timeout? ## - ############################# - - print loc(" -CPANPLUS can specify a network timeout for downloads (in whole seconds). -If none is desired (or to skip this question), enter '0'. - -"); - - my $timeout = 0 + $term->get_reply( - prompt => loc("Network timeout for downloads"), - default => $conf->get_conf('timeout') || 0, - allow => qr/(?!\D)/, ### whole numbers only - ); - - $conf->set_conf(timeout => $timeout); - - print "\n"; - print $timeout - ? loc("The network timeout for downloads is %1 seconds.", $timeout) - : loc("The network timeout for downloads is not set."); - print "\n"; - - ############################ - ## where can I reach you? ## - ############################ - - print loc(" -What email address should we send as our anonymous password when -fetching modules from CPAN servers? Some servers will NOT allow you to -connect without a valid email address, or at least something that looks -like one. -Also, if you choose to report test results at some point, a valid email -is required for the 'from' field, so choose wisely. - - "); - - my $other = 'Something else'; - my @choices = (DEFAULT_EMAIL, $Config{cf_email}, $other); - my $current = $conf->get_conf('email'); - - ### if your current address is not in the list, add it to the choices - unless (grep { $_ eq $current } @choices) { - unshift @choices, $current; - } - - my $email = $term->get_reply( - prompt => loc('Which email address shall I use?'), - default => $current || $choices[0], - choices => \@choices, - ); - - if( $email eq $other ) { - EMAIL: { - $email = $term->get_reply( - prompt => loc('Email address: '), - ); - - unless( $self->_valid_email($email) ) { - print loc(" -You did not enter a valid email address, please try again! - ") if length $email; - - redo EMAIL; - } - } - } - - print loc(" -Your 'email' is now: - %1 - - ", $email); - - $conf->set_conf( email => $email ); - - return 1; -} - - -### commandline programs -sub _setup_program { - my $self = shift; - my $term = $self->term; - my $conf = $self->configure_object; - - print loc(" -CPANPLUS can use command line utilities to do certain -tasks, rather than use perl modules. - -If you wish to use a certain command utility, just enter -the full path (or accept the default). If you do not wish -to use it, enter a single space. - -Note that the paths you provide should not contain spaces, which is -needed to make a distinction between program name and options to that -program. For Win32 machines, you can use the short name for a path, -like '%1'. -", 'c:\Progra~1\prog.exe' ); - - for my $prog ( sort $conf->options( type => 'program') ) { - PROGRAM: { - print "\n", loc("Where can I find your '%1' utility? ". - "(Enter a single space to disable)", $prog ), "\n"; - - my $loc = $term->get_reply( - prompt => "Path to your '$prog'", - default => $conf->get_program( $prog ), - ); - - ### empty line clears it - my $cmd = $loc =~ /^\s*$/ ? undef : $loc; - my ($bin) = $cmd =~ /^(\S+)/; - - ### did you provide a valid program ? - if( $bin and not can_run( $bin ) ) { - print "\n"; - print loc("Can not find the binary '%1' in your path!", $bin); - redo PROGRAM; - } - - ### make is special -- we /need/ it! - if( $prog eq 'make' and not $bin ) { - print loc( - "==> Without your '%1' utility, I can not function! <==", - 'make' - ); - print loc("Please provide one!"); - - ### show win32 where to download - if ( $^O eq 'MSWin32' ) { - print loc("You can get '%1' from:", NMAKE); - print "\t". NMAKE_URL ."\n"; - } - print "\n"; - redo PROGRAM; - } - - $conf->set_program( $prog => $cmd ); - print $cmd - ? loc( "Your '%1' utility has been set to '%2'.", - $prog, $cmd ) - : loc( "Your '%1' has been disabled.", $prog ); - print "\n"; - } - } - - return 1; -} - -sub _setup_installer { - my $self = shift; - my $term = $self->term; - my $conf = $self->configure_object; - - my $none = 'None'; - { - print loc(" -CPANPLUS uses binary programs as well as Perl modules to accomplish -various tasks. Normally, CPANPLUS will prefer the use of Perl modules -over binary programs. - -You can change this setting by making CPANPLUS prefer the use of -certain binary programs if they are available. - - "); - - ### default to using binaries if we don't have compress::zlib only - ### -- it'll get very noisy otherwise - my $type = 'prefer_bin'; - my $yn = $term->ask_yn( - prompt => loc("Should I prefer the use of binary programs?"), - default => $conf->get_conf( $type ), - ); - - print $yn - ? loc("Ok, I will prefer to use binary programs if possible.") - : loc("Ok, I will prefer to use Perl modules if possible."); - print "\n\n"; - - - $conf->set_conf( $type => $yn ); - } - - { - print loc(" -Makefile.PL is run by perl in a separate process, and accepts various -flags that controls the module's installation. For instance, if you -would like to install modules to your private user directory, set -'makemakerflags' to: - -LIB=~/perl/lib INSTALLMAN1DIR=~/perl/man/man1 INSTALLMAN3DIR=~/perl/man/man3 - -and be sure that you do NOT set UNINST=1 in 'makeflags' below. - -Enter a name=value list separated by whitespace, but quote any embedded -spaces that you want to preserve. (Enter a space to clear any existing -settings.) - -If you don't understand this question, just press ENTER. - - "); - - my $type = 'makemakerflags'; - my $flags = $term->get_reply( - prompt => 'Makefile.PL flags?', - default => $conf->get_conf($type), - ); - - $flags = '' if $flags eq $none || $flags !~ /\S/; - - print "\n", loc("Your '%1' have been set to:", 'Makefile.PL flags'), - "\n ", ( $flags ? $flags : loc('*nothing entered*')), - "\n\n"; - - $conf->set_conf( $type => $flags ); - } - - { - print loc(" -Like Makefile.PL, we run 'make' and 'make install' as separate processes. -If you have any parameters (e.g. '-j3' in dual processor systems) you want -to pass to the calls, please specify them here. - -In particular, 'UNINST=1' is recommended for root users, unless you have -fine-tuned ideas of where modules should be installed in the \@INC path. - -Enter a name=value list separated by whitespace, but quote any embedded -spaces that you want to preserve. (Enter a space to clear any existing -settings.) - -Again, if you don't understand this question, just press ENTER. - - "); - my $type = 'makeflags'; - my $flags = $term->get_reply( - prompt => 'make flags?', - default => $conf->get_conf($type), - ); - - $flags = '' if $flags eq $none || $flags !~ /\S/; - - print "\n", loc("Your '%1' have been set to:", $type), - "\n ", ( $flags ? $flags : loc('*nothing entered*')), - "\n\n"; - - $conf->set_conf( $type => $flags ); - } - - { - print loc(" -An alternative to ExtUtils::MakeMaker and Makefile.PL there's a module -called Module::Build which uses a Build.PL. - -If you would like to specify any flags to pass when executing the -Build.PL (and Build) script, please enter them below. - -For instance, if you would like to install modules to your private -user directory, you could enter: - - install_base=/my/private/path - -Or to uninstall old copies of modules before updating, you might -want to enter: - - uninst=1 - -Again, if you don't understand this question, just press ENTER. - - "); - - my $type = 'buildflags'; - my $flags = $term->get_reply( - prompt => 'Build.PL and Build flags?', - default => $conf->get_conf($type), - ); - - $flags = '' if $flags eq $none || $flags !~ /\S/; - - print "\n", loc("Your '%1' have been set to:", - 'Build.PL and Build flags'), - "\n ", ( $flags ? $flags : loc('*nothing entered*')), - "\n\n"; - - $conf->set_conf( $type => $flags ); - } - - ### use EU::MM or module::build? ### - { - print loc(" -Some modules provide both a Build.PL (Module::Build) and a Makefile.PL -(ExtUtils::MakeMaker). By default, CPANPLUS prefers Makefile.PL. - -Module::Build support is not bundled standard with CPANPLUS, but -requires you to install 'CPANPLUS::Dist::Build' from CPAN. - -Although Module::Build is a pure perl solution, which means you will -not need a 'make' binary, it does have some limitations. The most -important is that CPANPLUS is unable to uninstall any modules installed -by Module::Build. - -Again, if you don't understand this question, just press ENTER. - - "); - my $type = 'prefer_makefile'; - my $yn = $term->ask_yn( - prompt => loc("Prefer Makefile.PL over Build.PL?"), - default => $conf->get_conf($type), - ); - - $conf->set_conf( $type => $yn ); - } - - { - print loc(' -If you like, CPANPLUS can add extra directories to your @INC list during -startup. These will just be used by CPANPLUS and will not change your -external environment or perl interpreter. Enter a space separated list of -pathnames to be added to your @INC, quoting any with embedded whitespace. -(To clear the current value enter a single space.) - - '); - - my $type = 'lib'; - my $flags = $term->get_reply( - prompt => loc('Additional @INC directories to add?'), - default => (join " ", @{$conf->get_conf($type) || []} ), - ); - - my $lib; - unless( $flags =~ /\S/ ) { - $lib = []; - } else { - (@$lib) = $flags =~ m/\s*("[^"]+"|'[^']+'|[^\s]+)/g; - } - - print "\n", loc("Your additional libs are now:"), "\n"; - - print scalar @$lib - ? map { " $_\n" } @$lib - : " ", loc("*nothing entered*"), "\n"; - print "\n\n"; - - $conf->set_conf( $type => $lib ); - } - - return 1; -} - - -sub _setup_conf { - my $self = shift; - my $term = $self->term; - my $conf = $self->configure_object; - - my $none = 'None'; - { - ############ - ## noisy? ## - ############ - - print loc(" -In normal operation I can just give you basic information about what I -am doing, or I can be more verbose and give you every little detail. - - "); - - my $type = 'verbose'; - my $yn = $term->ask_yn( - prompt => loc("Should I be verbose?"), - default => $conf->get_conf( $type ), ); - - print "\n"; - print $yn - ? loc("You asked for it!") - : loc("I'll try to be quiet"); - - $conf->set_conf( $type => $yn ); - } - - { - ####################### - ## flush you animal! ## - ####################### - - print loc(" -In the interest of speed, we keep track of what modules were installed -successfully and which failed in the current session. We can flush this -data automatically, or you can explicitly issue a 'flush' when you want -to purge it. - - "); - - my $type = 'flush'; - my $yn = $term->ask_yn( - prompt => loc("Flush automatically?"), - default => $conf->get_conf( $type ), - ); - - print "\n"; - print $yn - ? loc("I'll flush after every full module install.") - : loc("I won't flush until you tell me to."); - - $conf->set_conf( $type => $yn ); - } - - { - ##################### - ## force installs? ## - ##################### - - print loc(" -Usually, when a test fails, I won't install the module, but if you -prefer, I can force the install anyway. - - "); - - my $type = 'force'; - my $yn = $term->ask_yn( - prompt => loc("Force installs?"), - default => $conf->get_conf( $type ), - ); - - print "\n"; - print $yn - ? loc("I will force installs.") - : loc("I won't force installs."); - - $conf->set_conf( $type => $yn ); - } - - { - ################### - ## about prereqs ## - ################### - - print loc(" -Sometimes a module will require other modules to be installed before it -will work. CPANPLUS can attempt to install these for you automatically -if you like, or you can do the deed yourself. - -If you would prefer that we NEVER try to install extra modules -automatically, select NO. (Usually you will want this set to YES.) - -If you would like to build modules to satisfy testing or prerequisites, -but not actually install them, select BUILD. - -NOTE: This feature requires you to flush the 'lib' cache for longer -running programs (refer to the CPANPLUS::Backend documentations for -more details). - -Otherwise, select ASK to have us ask your permission to install them. - - "); - - my $type = 'prereqs'; - - my @map = ( - [ PREREQ_IGNORE, # conf value - loc('No, do not install prerequisites'), # UI Value - loc("I won't install prerequisites") # diag message - ], - [ PREREQ_INSTALL, - loc('Yes, please install prerequisites'), - loc("I will install prerequisites") - ], - [ PREREQ_ASK, - loc('Ask me before installing a prerequisite'), - loc("I will ask permission to install") - ], - [ PREREQ_BUILD, - loc('Build prerequisites, but do not install them'), - loc( "I will only build, but not install prerequisites" ) - ], - ); - - my %reply = map { $_->[1] => $_->[0] } @map; # choice => value - my %diag = map { $_->[1] => $_->[2] } @map; # choice => diag message - my %conf = map { $_->[0] => $_->[1] } @map; # value => ui choice - - my $reply = $term->get_reply( - prompt => loc('Follow prerequisites?'), - default => $conf{ $conf->get_conf( $type ) }, - choices => [ @conf{ sort keys %conf } ], - ); - print "\n"; - - my $value = $reply{ $reply }; - my $diag = $diag{ $reply }; - - $conf->set_conf( $type => $value ); - print $diag, "\n"; - } - - { print loc(" -Modules in the CPAN archives are protected with md5 checksums. - -This requires the Perl module Digest::MD5 to be installed (which -CPANPLUS can do for you later); - - "); - my $type = 'md5'; - - my $yn = $term->ask_yn( - prompt => loc("Shall I use the MD5 checksums?"), - default => $conf->get_conf( $type ), - ); - - print $yn - ? loc("I will use the MD5 checksums if you have it") - : loc("I won't use the MD5 checksums"); - - $conf->set_conf( $type => $yn ); - - } - - - { ########################################### - ## sally sells seashells by the seashore ## - ########################################### - - print loc(" -By default CPANPLUS uses its own shell when invoked. If you would prefer -a different shell, such as one you have written or otherwise acquired, -please enter the full name for your shell module. - - "); - - my $type = 'shell'; - my $other = 'Other'; - my @choices = (qw| CPANPLUS::Shell::Default - CPANPLUS::Shell::Classic |, - $other ); - my $default = $conf->get_conf($type); - - unshift @choices, $default unless grep { $_ eq $default } @choices; - - my $reply = $term->get_reply( - prompt => loc('Which CPANPLUS shell do you want to use?'), - default => $default, - choices => \@choices, - ); - - if( $reply eq $other ) { - SHELL: { - $reply = $term->get_reply( - prompt => loc( 'Please enter the name of the shell '. - 'you wish to use: '), - ); - - unless( check_install( module => $reply ) ) { - print "\n", - loc("Could not find '$reply' in your path " . - "-- please try again"), - "\n"; - redo SHELL; - } - } - } - - print "\n", loc("Your shell is now: %1", $reply), "\n\n"; - - $conf->set_conf( $type => $reply ); - } - - { - ################### - ## use storable? ## - ################### - - print loc(" -To speed up the start time of CPANPLUS, and maintain a cache over -multiple runs, we can use Storable to freeze some information. -Would you like to do this? - -"); - my $type = 'storable'; - my $yn = $term->ask_yn( - prompt => loc("Use Storable?"), - default => $conf->get_conf( $type ) ? 1 : 0, - ); - print "\n"; - print $yn - ? loc("I will use Storable if you have it") - : loc("I will not use Storable"); - - $conf->set_conf( $type => $yn ); - } - - { - ################### - ## use sqlite ? ## - ################### - - print loc(" - -To limit the amount of RAM used by CPANPLUS, you can use the SQLite -source backend instead. Note that it is currently still experimental. -Would you like to do this? - -"); - my $type = 'source_engine'; - my $class = 'CPANPLUS::Internals::Source::SQLite'; - my $yn = $term->ask_yn( - prompt => loc("Use SQLite?"), - default => $conf->get_conf( $type ) eq $class ? 1 : 0, - ); - print "\n"; - print $yn - ? loc("I will use SQLite") - : loc("I will not use SQLite"); - - $conf->set_conf( $type => $class ); - } - - { - ################### - ## use cpantest? ## - ################### - - print loc(" -CPANPLUS has support for the Test::Reporter module, which can be utilized -to report success and failures of modules installed by CPANPLUS. Would -you like to do this? Note that you will still be prompted before -sending each report. - -If you don't have all the required modules installed yet, you should -consider installing '%1' - -This package bundles all the required modules to enable test reporting -and querying from CPANPLUS. -You can do so straight after this installation. - - ", 'Bundle::CPANPLUS::Test::Reporter'); - - my $type = 'cpantest'; - my $yn = $term->ask_yn( - prompt => loc('Report test results?'), - default => $conf->get_conf( $type ) ? 1 : 0, - ); - - print "\n"; - print $yn - ? loc("I will prompt you to report test results") - : loc("I won't prompt you to report test results"); - - $conf->set_conf( $type => $yn ); - } - - { - ################################### - ## use cryptographic signatures? ## - ################################### - - print loc(" -The Module::Signature extension allows CPAN authors to sign their -distributions using PGP signatures. Would you like to check for -module's cryptographic integrity before attempting to install them? -Note that this requires either the 'gpg' utility or Crypt::OpenPGP -to be installed. - - "); - my $type = 'signature'; - - my $yn = $term->ask_yn( - prompt => loc('Shall I check module signatures?'), - default => $conf->get_conf($type) ? 1 : 0, - ); - - print "\n"; - print $yn - ? loc("Ok, I will attempt to check module signatures.") - : loc("Ok, I won't attempt to check module signatures."); - - $conf->set_conf( $type => $yn ); - } - - return 1; -} - -sub _setup_hosts { - my $self = shift; - my $term = $self->term; - my $conf = $self->configure_object; - - - if( scalar @{ $conf->get_conf('hosts') } ) { - - my $hosts; - for my $href ( @{$conf->get_conf('hosts')} ) { - $hosts .= "\t$href->{scheme}://$href->{host}$href->{path}\n"; - } - - print loc(" -I see you already have some hosts selected: - -$hosts - -If you'd like to stick with your current settings, just select 'Yes'. -Otherwise, select 'No' and you can reconfigure your hosts - -"); - my $yn = $term->ask_yn( - prompt => loc("Would you like to keep your current hosts?"), - default => 'y', - ); - return 1 if $yn; - } - - my @hosts; - MAIN: { - - print loc(" -Now we need to know where your favorite CPAN sites are located. Make a -list of a few sites (just in case the first on the array won't work). - -If you are mirroring CPAN to your local workstation, specify a file: -URI by picking the CUSTOM option. - -Otherwise, let us fetch the official CPAN mirror list and you can pick -the mirror that suits you best from a list by using the MIRROR option; -First, pick a nearby continent and country. Then, you will be presented -with a list of URLs of CPAN mirrors in the country you selected. Select -one or more of those URLs. - -Note, the latter option requires a working net connection. - -You can select VIEW to see your current selection and QUIT when you -are done. - -"); - - my $reply = $term->get_reply( - prompt => loc('Please choose an option'), - choices => [qw|Mirror Custom View Quit|], - default => 'Mirror', - ); - - goto MIRROR if $reply eq 'Mirror'; - goto CUSTOM if $reply eq 'Custom'; - goto QUIT if $reply eq 'Quit'; - - $self->_view_hosts(@hosts) if $reply eq 'View'; - redo MAIN; - } - - my $mirror_file; - my $hosts; - MIRROR: { - $mirror_file ||= $self->_get_mirrored_by or return; - $hosts ||= $self->_parse_mirrored_by($mirror_file) or return; - - my ($continent, $country, $host) = $self->_guess_from_timezone( $hosts ); - - CONTINENT: { - my %seen; - my @choices = sort map { - $_->{'continent'} - } grep { - not $seen{$_->{'continent'}}++ - } values %$hosts; - push @choices, qw[Custom Up Quit]; - - my $reply = $term->get_reply( - prompt => loc('Pick a continent'), - default => $continent, - choices => \@choices, - ); - - goto MAIN if $reply eq 'Up'; - goto CUSTOM if $reply eq 'Custom'; - goto QUIT if $reply eq 'Quit'; - - $continent = $reply; - } - - COUNTRY: { - my %seen; - my @choices = sort map { - $_->{'country'} - } grep { - not $seen{$_->{'country'}}++ - } grep { - ($_->{'continent'} eq $continent) - } values %$hosts; - push @choices, qw[Custom Up Quit]; - - my $reply = $term->get_reply( - prompt => loc('Pick a country'), - default => $country, - choices => \@choices, - ); - - goto CONTINENT if $reply eq 'Up'; - goto CUSTOM if $reply eq 'Custom'; - goto QUIT if $reply eq 'Quit'; - - $country = $reply; - } - - HOST: { - my @list = grep { - $_->{'continent'} eq $continent and - $_->{'country'} eq $country - } values %$hosts; - - my %map; my $default; - for my $href (@list) { - for my $con ( @{$href->{'connections'}} ) { - next unless length $con->{'host'}; - - my $entry = $con->{'scheme'} . '://' . $con->{'host'}; - $default = $entry if $con->{'host'} eq $host; - - $map{$entry} = $con; - } - } - - CHOICE: { - - ### doesn't play nice with Term::UI :( - ### should make t::ui figure out pager opens - #$self->_pager_open; # host lists might be long - - print loc(" -You can enter multiple sites by separating them by a space. -For example: - 1 4 2 5 - "); - - my @reply = $term->get_reply( - prompt => loc('Please pick a site: '), - choices => [sort(keys %map), - qw|Custom View Up Quit|], - default => $default, - multi => 1, - ); - #$self->_pager_close; - - - goto COUNTRY if grep { $_ eq 'Up' } @reply; - goto CUSTOM if grep { $_ eq 'Custom' } @reply; - goto QUIT if grep { $_ eq 'Quit' } @reply; - - ### add the host, but only if it's not on the stack already ### - unless( grep { $_ eq 'View' } @reply ) { - for my $reply (@reply) { - if( grep { $_ eq $map{$reply} } @hosts ) { - print loc("Host '%1' already selected", $reply); - print "\n\n"; - } else { - push @hosts, $map{$reply} - } - } - } - - $self->_view_hosts(@hosts); - - goto QUIT if $self->autoreply; - redo CHOICE; - } - } - } - - CUSTOM: { - print loc(" -If there are any additional URLs you would like to use, please add them -now. You may enter them separately or as a space delimited list. - -We provide a default fall-back URL, but you are welcome to override it -with e.g. 'http://www.cpan.org/' if LWP, wget or curl is installed. - -(Enter a single space when you are done, or to simply skip this step.) - -Note that if you want to use a local depository, you will have to enter -as follows: - -file://server/path/to/cpan - -if the file is on a server on your local network or as: - -file:///path/to/cpan - -if the file is on your local disk. Note the three /// after the file: bit - -"); - - CHOICE: { - my $reply = $term->get_reply( - prompt => loc("Additionals host(s) to add: "), - default => '', - ); - - last CHOICE unless $reply =~ /\S/; - - my $href = $self->_parse_host($reply); - - if( $href ) { - push @hosts, $href - unless grep { - $href->{'scheme'} eq $_->{'scheme'} and - $href->{'host'} eq $_->{'host'} and - $href->{'path'} eq $_->{'path'} - } @hosts; - - last CHOICE if $self->autoreply; - } else { - print loc("Invalid uri! Please try again!"); - } - - $self->_view_hosts(@hosts); - - redo CHOICE; - } - - DONE: { - - print loc(" -Where would you like to go now? - -Please pick one of the following options or Quit when you are done - -"); - my $answer = $term->get_reply( - prompt => loc("Where to now?"), - default => 'Quit', - choices => [qw|Mirror Custom View Quit|], - ); - - if( $answer eq 'View' ) { - $self->_view_hosts(@hosts); - redo DONE; - } - - goto MIRROR if $answer eq 'Mirror'; - goto CUSTOM if $answer eq 'Custom'; - goto QUIT if $answer eq 'Quit'; - } - } - - QUIT: { - $conf->set_conf( hosts => \@hosts ); - - print loc(" -Your host configuration has been saved - -"); - } - - return 1; -} - -sub _view_hosts { - my $self = shift; - my @hosts = @_; - - print "\n\n"; - - if( scalar @hosts ) { - my $i = 1; - for my $host (@hosts) { - - ### show full path on file uris, otherwise, just show host - my $path = join '', ( - $host->{'scheme'} eq 'file' - ? ( ($host->{'host'} || '[localhost]'), - $host->{path} ) - : $host->{'host'} - ); - - printf "%-40s %30s\n", - loc("Selected %1",$host->{'scheme'} . '://' . $path ), - loc("%quant(%2,host) selected thus far.", $i); - $i++; - } - } else { - print loc("No hosts selected so far."); - } - - print "\n\n"; - - return 1; -} - -sub _get_mirrored_by { - my $self = shift; - my $cpan = $self->backend; - my $conf = $self->configure_object; - - print loc(" -Now, we are going to fetch the mirror list for first-time configurations. -This may take a while... - -"); - - ### use the new configuration ### - $cpan->configure_object( $conf ); - - load CPANPLUS::Module::Fake; - load CPANPLUS::Module::Author::Fake; - - my $mb = CPANPLUS::Module::Fake->new( - module => $conf->_get_source('hosts'), - path => '', - package => $conf->_get_source('hosts'), - author => CPANPLUS::Module::Author::Fake->new( - _id => $cpan->_id ), - _id => $cpan->_id, - ); - - my $file = $cpan->_fetch( fetchdir => $conf->get_conf('base'), - module => $mb ); - - return $file if $file; - return; -} - -sub _parse_mirrored_by { - my $self = shift; - my $file = shift; - - -s $file or return; - - my $fh = new FileHandle; - $fh->open("$file") - or ( - warn(loc('Could not open file "%1": %2', $file, $!)), - return - ); - - ### slurp the file in ### - { local $/; $file = <$fh> } - - ### remove comments ### - $file =~ s/#.*$//gm; - - $fh->close; - - ### sample host entry ### - # ftp.sun.ac.za: - # frequency = "daily" - # dst_ftp = "ftp://ftp.sun.ac.za/CPAN/CPAN/" - # dst_location = "Stellenbosch, South Africa, Africa (-26.1992 28.0564)" - # dst_organisation = "University of Stellenbosch" - # dst_timezone = "+2" - # dst_contact = "ftpadm@ftp.sun.ac.za" - # dst_src = "ftp.funet.fi" - # - # # dst_dst = "ftp://ftp.sun.ac.za/CPAN/CPAN/" - # # dst_contact = "mailto:ftpadm@ftp.sun.ac.za - # # dst_src = "ftp.funet.fi" - - ### host name as key, rest of the entry as value ### - my %hosts = $file =~ m/([a-zA-Z0-9\-\.]+):\s+((?:\w+\s+=\s+".*?"\s+)+)/gs; - - while (my($host,$data) = each %hosts) { - - my $href; - map { - s/^\s*//; - my @a = split /\s*=\s*/; - $a[1] =~ s/^"(.+?)"$/$1/g; - $href->{ pop @a } = pop @a; - } grep /\S/, split /\n/, $data; - - ($href->{city_area}, $href->{country}, $href->{continent}, - $href->{latitude}, $href->{longitude} ) = - $href->{dst_location} =~ - m/ - #Aizu-Wakamatsu, Tohoku-chiho, Fukushima - ^"?( - (?:[^,]+?)\s* # city - (?: - (?:,\s*[^,]+?)\s* # optional area - )*? # some have multiple areas listed - ) - - #Japan - ,\s*([^,]+?)\s* # country - - #Asia - ,\s*([^,]+?)\s* # continent - - # (37.4333 139.9821) - \((\S+)\s+(\S+?)\)"?$ # (latitude longitude) - /sx; - - ### parse the different hosts, store them in config format ### - my @list; - - for my $type (qw[dst_ftp dst_rsync dst_http]) { - my $path = $href->{$type}; - next unless $path =~ /\w/; - if ($type eq 'dst_rsync' && $path !~ /^rsync:/) { - $path =~ s{::}{/}; - $path = "rsync://$path/"; - } - my $parts = $self->_parse_host($path); - push @list, $parts; - } - - $href->{connections} = \@list; - $hosts{$host} = $href; - } - - return \%hosts; -} - -sub _parse_host { - my $self = shift; - my $host = shift; - - my @parts = $host =~ m|^(\w*)://([^/]*)(/.*)$|s; - - my $href; - for my $key (qw[scheme host path]) { - $href->{$key} = shift @parts; - } - - return if lc($href->{'scheme'}) ne 'file' and !$href->{'host'}; - return if !$href->{'path'}; - - return $href; -} - -## tries to figure out close hosts based on your timezone -## -## Currently can only report on unique items for each of zones, countries, and -## sites. In the future this will be combined with something else (perhaps a -## ping?) to narrow down multiple choices. -## -## Tries to return the best zone, country, and site for your location. Any non- -## unique items will be set to undef instead. -## -## (takes hashref, returns array) -## -sub _guess_from_timezone { - my $self = shift; - my $hosts = shift; - my (%zones, %countries, %sites); - - ### autrijus - build time zone table - my %freq_weight = ( - 'hourly' => 2400, - '4 times a day' => 400, - '4x daily' => 400, - 'daily' => 100, - 'twice daily' => 50, - 'weekly' => 15, - ); - - while (my ($site, $host) = each %{$hosts}) { - my ($zone, $continent, $country, $frequency) = - @{$host}{qw/dst_timezone continent country frequency/}; - - - # skip non-well-formed ones - next unless $continent and $country and $zone =~ /^[-+]?\d+(?::30)?/; - ### fix style - chomp $zone; - $zone =~ s/:30/.5/; - $zone =~ s/^\+//; - $zone =~ s/"//g; - - $zones{$zone}{$continent}++; - $countries{$zone}{$continent}{$country}++; - $sites{$zone}{$continent}{$country}{$site} = $freq_weight{$frequency}; - } - - use Time::Local; - my $offset = ((timegm(localtime) - timegm(gmtime)) / 3600); - - local $_; - - ## pick the entry with most country/site/frequency, one level each; - ## note it has to be sorted -- otherwise we're depending on the hash order. - ## also, the list context assignment (pick first one) is deliberate. - - my ($continent) = map { - (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_})) - } $zones{$offset}; - - my ($country) = map { - (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_})) - } $countries{$offset}{$continent}; - - my ($site) = map { - (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_})) - } $sites{$offset}{$continent}{$country}; - - return ($continent, $country, $site); -} # _guess_from_timezone - - -### big big regex, stolen to check if you enter a valid address -{ - my $RFC822PAT; # RFC pattern to match for valid email address - - sub _valid_email { - my $self = shift; - if (!$RFC822PAT) { - my $esc = '\\\\'; my $Period = '\.'; my $space = '\040'; - my $tab = '\t'; my $OpenBR = '\['; my $CloseBR = '\]'; - my $OpenParen = '\('; my $CloseParen = '\)'; my $NonASCII = '\x80-\xff'; - my $ctrl = '\000-\037'; my $CRlist = '\012\015'; - - my $qtext = qq/[^$esc$NonASCII$CRlist\"]/; - my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/; - my $quoted_pair = qq< $esc [^$NonASCII] >; # an escaped character - my $ctext = qq< [^$esc$NonASCII$CRlist()] >; - my $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >; - my $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >; - my $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >; - my $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/; - my $atom = qq< $atom_char+ (?!$atom_char) >; - my $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >; - my $word = qq< (?: $atom | $quoted_str ) >; - my $domain_ref = $atom; - my $domain_lit = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >; - my $sub_domain = qq< (?: $domain_ref | $domain_lit) $X >; - my $domain = qq< $sub_domain (?: $Period $X $sub_domain)* >; - my $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >; - my $local_part = qq< $word $X (?: $Period $X $word $X )* >; - my $addr_spec = qq< $local_part \@ $X $domain >; - my $route_addr = qq[ < $X (?: $route )? $addr_spec > ]; - my $phrase_ctrl = '\000-\010\012-\037'; # like ctrl, but without tab - my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/; - my $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >; - $RFC822PAT = qq< $X (?: $addr_spec | $phrase $route_addr) >; - } - - return scalar ($_[0] =~ /$RFC822PAT/ox); - } -} - - - - - - -1; - - -sub _edit { - my $self = shift; - my $conf = $self->configure_object; - my $file = shift || $conf->_config_pm_to_file( $self->config_type ); - my $editor = shift || $conf->get_program('editor'); - my $term = $self->term; - - unless( $editor ) { - print loc(" -I'm sorry, I can't find a suitable editor, so I can't offer you -post-configuration editing of the config file - -"); - return 1; - } - - ### save the thing first, so there's something to edit - $self->_save; - - return !system("$editor $file"); -} - -sub _save { - my $self = shift; - my $conf = $self->configure_object; - - return $conf->save( $self->config_type ); -} - -1; diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Dist.pm b/cpan/CPANPLUS/lib/CPANPLUS/Dist.pm deleted file mode 100644 index 51ee5fb9ca..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Dist.pm +++ /dev/null @@ -1,808 +0,0 @@ -package CPANPLUS::Dist; -use deprecate; - -use strict; - -use CPANPLUS::Error; -use CPANPLUS::Internals::Constants; - -use Cwd (); -use Object::Accessor; -use Parse::CPAN::Meta; - -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"; - -use base 'Object::Accessor'; - -local $Params::Check::VERBOSE = 1; - -=pod - -=head1 NAME - -CPANPLUS::Dist - base class for plugins - -=head1 SYNOPSIS - - my $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new( - module => $modobj, - ); - -=head1 DESCRIPTION - -C<CPANPLUS::Dist> is a base class for C<CPANPLUS::Dist::MM> -and C<CPANPLUS::Dist::Build>. Developers of other C<CPANPLUS::Dist::*> -plugins should look at C<CPANPLUS::Dist::Base>. - -=head1 ACCESSORS - -=over 4 - -=item parent() - -Returns the C<CPANPLUS::Module> object that parented this object. - -=item status() - -Returns the C<Object::Accessor> object that keeps the status for -this module. - -=back - -=head1 STATUS ACCESSORS - -All accessors can be accessed as follows: - $deb->status->ACCESSOR - -=over 4 - -=item created() - -Boolean indicating whether the dist was created successfully. -Explicitly set to C<0> when failed, so a value of C<undef> may be -interpreted as C<not yet attempted>. - -=item installed() - -Boolean indicating whether the dist was installed successfully. -Explicitly set to C<0> when failed, so a value of C<undef> may be -interpreted as C<not yet attempted>. - -=item uninstalled() - -Boolean indicating whether the dist was uninstalled successfully. -Explicitly set to C<0> when failed, so a value of C<undef> may be -interpreted as C<not yet attempted>. - -=item dist() - -The location of the final distribution. This may be a file or -directory, depending on how your distribution plug in of choice -works. This will be set upon a successful create. - -=cut - -=back - -=head2 $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new( module => MODOBJ ); - -Create a new C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object based on the -provided C<MODOBJ>. - -*** DEPRECATED *** -The optional argument C<format> is used to indicate what type of dist -you would like to create (like C<CPANPLUS::Dist::MM> or -C<CPANPLUS::Dist::Build> and so on ). - -C<< CPANPLUS::Dist->new >> is exclusively meant as a method to be -inherited by C<CPANPLUS::Dist::MM|Build>. - -Returns a C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object on success -and false on failure. - -=cut - -sub new { - my $self = shift; - my $class = ref $self || $self; - my %hash = @_; - - ### first verify we got a module object ### - my( $mod, $format ); - my $tmpl = { - module => { required => 1, allow => IS_MODOBJ, store => \$mod }, - ### for backwards compatibility - format => { default => $class, store => \$format, - allow => [ __PACKAGE__->dist_types ], - }, - }; - check( $tmpl, \%hash ) or return; - - unless( can_load( modules => { $format => '0.0' }, verbose => 1 ) ) { - error(loc("'%1' not found -- you need '%2' version '%3' or higher ". - "to detect plugins", $format, 'Module::Pluggable','2.4')); - return; - } - - ### get an empty o::a object for this class - my $obj = $format->SUPER::new; - - $obj->mk_accessors( qw[parent status] ); - - ### set the parent - $obj->parent( $mod ); - - ### create a status object ### - { my $acc = Object::Accessor->new; - $obj->status($acc); - - ### add minimum supported accessors - $acc->mk_accessors( qw[prepared created installed uninstalled - distdir dist] ); - } - - ### get the conf object ### - my $conf = $mod->parent->configure_object(); - - ### check if the format is available in this environment ### - if( $conf->_get_build('sanity_check') and not $obj->format_available ) { - error( loc( "Format '%1' is not available", $format) ); - return; - } - - ### now initialize it or admit failure - unless( $obj->init ) { - error(loc("Dist initialization of '%1' failed for '%2'", - $format, $mod->module)); - return; - } - - ### return the object - return $obj; -} - -=head2 @dists = CPANPLUS::Dist->dist_types; - -Returns a list of the CPANPLUS::Dist::* classes available - -=cut - -### returns a list of dist_types we support -### will get overridden by Module::Pluggable if loaded -### XXX add support for 'plugin' dir in config as well -{ my $Loaded; - my @Dists = (INSTALLER_MM); - my @Ignore = (); - - ### backdoor method to add more dist types - sub _add_dist_types { my $self = shift; push @Dists, @_ }; - - ### backdoor method to exclude dist types - sub _ignore_dist_types { my $self = shift; push @Ignore, @_ }; - sub _reset_dist_ignore { @Ignore = () }; - - ### locally add the plugins dir to @INC, so we can find extra plugins - #local @INC = @INC, File::Spec->catdir( - # $conf->get_conf('base'), - # $conf->_get_build('plugins') ); - - ### load any possible plugins - sub dist_types { - - if ( !$Loaded++ and check_install( module => 'Module::Pluggable', - version => '2.4') - ) { - require Module::Pluggable; - - my $only_re = __PACKAGE__ . '::\w+$'; - my %except = map { $_ => 1 } - INSTALLER_SAMPLE, - INSTALLER_BASE; - - Module::Pluggable->import( - sub_name => '_dist_types', - search_path => __PACKAGE__, - only => qr/$only_re/, - require => 1, - except => [ keys %except ] - ); - my %ignore = map { $_ => $_ } @Ignore; - - push @Dists, grep { not $ignore{$_} and not $except{$_} } - __PACKAGE__->_dist_types; - } - - return @Dists; - } - -=head2 $bool = CPANPLUS::Dist->rescan_dist_types; - -Rescans C<@INC> for available dist types. Useful if you've installed new -C<CPANPLUS::Dist::*> classes and want to make them available to the -current process. - -=cut - - sub rescan_dist_types { - my $dist = shift; - $Loaded = 0; # reset the flag; - return $dist->dist_types; - } -} - -=head2 $bool = CPANPLUS::Dist->has_dist_type( $type ) - -Returns true if distribution type C<$type> is loaded/supported. - -=cut - -sub has_dist_type { - my $dist = shift; - my $type = shift or return; - - return scalar grep { $_ eq $type } CPANPLUS::Dist->dist_types; -} - -=head2 $bool = $dist->prereq_satisfied( modobj => $modobj, version => $version_spec ) - -Returns true if this prereq is satisfied. Returns false if it's not. -Also issues an error if it seems "unsatisfiable," i.e. if it can't be -found on CPAN or the latest CPAN version doesn't satisfy it. - -=cut - -sub prereq_satisfied { - my $dist = shift; - my $cb = $dist->parent->parent; - my %hash = @_; - - my($mod,$ver); - my $tmpl = { - version => { required => 1, store => \$ver }, - modobj => { required => 1, store => \$mod, allow => IS_MODOBJ }, - }; - - check( $tmpl, \%hash ) or return; - - return 1 if $mod->is_uptodate( version => $ver ); - - if ( $cb->_vcmp( $ver, $mod->version ) > 0 ) { - - error(loc( - "This distribution depends on %1, but the latest version". - " of %2 on CPAN (%3) doesn't satisfy the specific version". - " dependency (%4). You may have to resolve this dependency ". - "manually.", - $mod->module, $mod->module, $mod->version, $ver )); - - } - - return; -} - -=head2 $configure_requires = $dist->find_configure_requires( [file => /path/to/META.yml] ) - -Reads the configure_requires for this distribution from the META.yml or META.json -file in the root directory and returns a hashref with module names -and versions required. - -=cut - -sub find_configure_requires { - my $self = shift; - my $mod = $self->parent; - my %hash = @_; - - my ($meta); - my $href = {}; - - my $tmpl = { - file => { store => \$meta }, - }; - - check( $tmpl, \%hash ) or return; - - my $meth = 'configure_requires'; - - { - - ### the prereqs as we have them now - my @args = ( - defaults => $mod->status->$meth || {}, - ); - - my @possibles = do { defined $mod->status->extract - ? ( META_JSON->( $mod->status->extract ), - META_YML->( $mod->status->extract ) ) - : () - }; - - unshift @possibles, $meta if $meta; - - META: foreach my $mfile ( grep { -e } @possibles ) { - push @args, ( file => $mfile ); - if ( $mfile =~ /\.json/ ) { - $href = $self->_prereqs_from_meta_json( @args, keys => [ 'configure' ] ); - } - else { - $href = $self->_prereqs_from_meta_file( @args, keys => [ $meth ] ); - } - last META; - } - - } - - ### and store it in the module - $mod->status->$meth( $href ); - - return { %$href }; -} - -sub find_mymeta_requires { - my $self = shift; - my $mod = $self->parent; - my %hash = @_; - - my ($meta); - my $href = {}; - - my $tmpl = { - file => { store => \$meta }, - }; - - check( $tmpl, \%hash ) or return; - - my $meth = 'prereqs'; - - { - - ### the prereqs as we have them now - my @args = ( - defaults => $mod->status->$meth || {}, - ); - - my @possibles = do { defined $mod->status->extract - ? ( MYMETA_JSON->( $mod->status->extract ), - MYMETA_YML->( $mod->status->extract ) ) - : () - }; - - unshift @possibles, $meta if $meta; - - META: foreach my $mfile ( grep { -e } @possibles ) { - push @args, ( file => $mfile ); - if ( $mfile =~ /\.json/ ) { - $href = $self->_prereqs_from_meta_json( @args, - keys => [ qw|build test runtime| ] ); - } - else { - $href = $self->_prereqs_from_meta_file( @args, - keys => [ qw|build_requires requires| ] ); - } - last META; - } - - } - - ### and store it in the module - $mod->status->$meth( $href ); - - return { %$href }; -} - -sub _prereqs_from_meta_file { - my $self = shift; - my $mod = $self->parent; - my %hash = @_; - - my( $meta, $defaults, $keys ); - my $tmpl = { ### check if we have an extract path. if not, we - ### get 'undef value' warnings from file::spec - file => { default => do { defined $mod->status->extract - ? META_YML->( $mod->status->extract ) - : '' }, - store => \$meta, - }, - defaults => { required => 1, default => {}, strict_type => 1, - store => \$defaults }, - keys => { required => 1, default => [], strict_type => 1, - store => \$keys }, - }; - - check( $tmpl, \%hash ) or return; - - ### if there's a meta file, we read it; - if( -e $meta ) { - - ### Parse::CPAN::Meta uses exceptions for errors - ### hash returned in list context!!! - - local $ENV{PERL_JSON_BACKEND}; - - my ($doc) = eval { Parse::CPAN::Meta::LoadFile( $meta ) }; - - unless( $doc ) { - error(loc( "Could not read %1: '%2'", $meta, $@ )); - return $defaults; - } - - ### read the keys now, make sure not to throw - ### away anything that was already added - for my $key ( @$keys ) { - $defaults = { - %$defaults, - %{ $doc->{$key} }, - } if $doc->{ $key }; - } - } - - ### and return a copy - return \%{ $defaults }; -} - -sub _prereqs_from_meta_json { - my $self = shift; - my $mod = $self->parent; - my %hash = @_; - - my( $meta, $defaults, $keys ); - my $tmpl = { ### check if we have an extract path. if not, we - ### get 'undef value' warnings from file::spec - file => { default => do { defined $mod->status->extract - ? META_JSON->( $mod->status->extract ) - : '' }, - store => \$meta, - }, - defaults => { required => 1, default => {}, strict_type => 1, - store => \$defaults }, - keys => { required => 1, default => [], strict_type => 1, - store => \$keys }, - }; - - check( $tmpl, \%hash ) or return; - - ### if there's a meta file, we read it; - if( -e $meta ) { - - ### Parse::CPAN::Meta uses exceptions for errors - ### hash returned in list context!!! - - local $ENV{PERL_JSON_BACKEND}; - - my ($doc) = eval { Parse::CPAN::Meta->load_file( $meta ) }; - - unless( $doc ) { - error(loc( "Could not read %1: '%2'", $meta, $@ )); - return $defaults; - } - - ### read the keys now, make sure not to throw - ### away anything that was already added - #for my $key ( @$keys ) { - # $defaults = { - # %$defaults, - # %{ $doc->{$key} }, - # } if $doc->{ $key }; - #} - my $prereqs = $doc->{prereqs} || {}; - for my $key ( @$keys ) { - $defaults = { - %$defaults, - %{ $prereqs->{$key}->{requires} }, - } if $prereqs->{ $key }->{requires}; - } - } - - ### and return a copy - return \%{ $defaults }; -} - -=head2 $bool = $dist->_resolve_prereqs( ... ) - -Makes sure prerequisites are resolved - - format The dist class to use to make the prereqs - (ie. CPANPLUS::Dist::MM) - - prereqs Hash of the prerequisite modules and their versions - - target What to do with the prereqs. - create => Just build them - install => Install them - ignore => Ignore them - - prereq_build If true, always build the prereqs even if already - resolved - - verbose Be verbose - - force Force the prereq to be built, even if already resolved - -=cut - -sub _resolve_prereqs { - my $dist = shift; - my $self = $dist->parent; - my $cb = $self->parent; - my $conf = $cb->configure_object; - my %hash = @_; - - my ($prereqs, $format, $verbose, $target, $force, $prereq_build,$tolerant); - my $tmpl = { - ### XXX perhaps this should not be required, since it may not be - ### packaged, just installed... - ### Let it be empty as well -- that means the $modobj->install - ### routine will figure it out, which is fine if we didn't have any - ### very specific wishes (it will even detect the favourite - ### dist_type). - format => { required => 1, store => \$format, - allow => ['',__PACKAGE__->dist_types], }, - prereqs => { required => 1, default => { }, - strict_type => 1, store => \$prereqs }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - force => { default => $conf->get_conf('force'), - store => \$force }, - ### make sure allow matches with $mod->install's list - target => { default => '', store => \$target, - allow => ['',qw[create ignore install]] }, - prereq_build => { default => 0, store => \$prereq_build }, - tolerant => { default => $conf->get_conf('allow_unknown_prereqs'), - store => \$tolerant }, - }; - - check( $tmpl, \%hash ) or return; - - ### so there are no prereqs? then don't even bother - return 1 unless keys %$prereqs; - - ### Make sure we wound up where we started. - my $original_wd = Cwd::cwd; - - ### so you didn't provide an explicit target. - ### maybe your config can tell us what to do. - $target ||= { - PREREQ_ASK, TARGET_INSTALL, # we'll bail out if the user says no - PREREQ_BUILD, TARGET_CREATE, - PREREQ_IGNORE, TARGET_IGNORE, - PREREQ_INSTALL, TARGET_INSTALL, - }->{ $conf->get_conf('prereqs') } || ''; - - ### XXX BIG NASTY HACK XXX FIXME at some point. - ### when installing Bundle::CPANPLUS::Dependencies, we want to - ### install all packages matching 'cpanplus' to be installed last, - ### as all CPANPLUS' prereqs are being installed as well, but are - ### being loaded for bootstrapping purposes. This means CPANPLUS - ### can find them, but for example cpanplus::dist::build won't, - ### which gets messy FAST. So, here we sort our prereqs only IF - ### the parent module is Bundle::CPANPLUS::Dependencies. - ### Really, we would wnat some sort of sorted prereq mechanism, - ### but Bundle:: doesn't support it, and we flatten everything - ### to a hash internally. A sorted hash *might* do the trick if - ### we got a transparent implementation.. that would mean we would - ### just have to remove the 'sort' here, and all will be well - my @sorted_prereqs; - - ### use regex, could either be a module name, or a package name - if( $self->module =~ /^Bundle(::|-)CPANPLUS(::|-)Dependencies/ ) { - my (@first, @last); - for my $mod ( sort keys %$prereqs ) { - $mod =~ /CPANPLUS/ - ? push @last, $mod - : push @first, $mod; - } - @sorted_prereqs = (@first, @last); - } else { - @sorted_prereqs = sort keys %$prereqs; - } - - ### first, transfer this key/value pairing into a - ### list of module objects + desired versions - my @install_me; - - my $flag; - - for my $mod ( @sorted_prereqs ) { - ( my $version = $prereqs->{$mod} ) =~ s#[^0-9\._]+##g; - - ### 'perl' is a special case, there's no mod object for it - if( $mod eq PERL_CORE ) { - - unless( $cb->_vcmp( sprintf('v%vd',$^V), $version ) >= 0 ) { - error(loc( "Module '%1' needs perl version '%2', but you ". - "only have version '%3' -- can not proceed", - $self->module, $version, - $cb->_perl_version( perl => $^X ) ) ); - return; - } - - next; - } - - my $modobj = $cb->module_tree($mod); - - #### XXX we ignore the version, and just assume that the latest - #### version from cpan will meet your requirements... dodgy =/ - unless( $modobj ) { - # Check if it is a core module - my $sub = CPANPLUS::Module->can( - 'module_is_supplied_with_perl_core' ); - my $core = $sub->( $mod ); - unless ( defined $core ) { - error( loc( "No such module '%1' found on CPAN", $mod ) ); - $flag++ unless $tolerant; - next; - } - if ( $cb->_vcmp( $version, $core ) > 0 ) { - error(loc( "Version of core module '%1' ('%2') is too low for ". - "'%3' (needs '%4') -- carrying on but this may be a problem", - $mod, $core, - $self->module, $version )); - } - next; - } - - ### it's not uptodate, we need to install it - if( !$dist->prereq_satisfied(modobj => $modobj, version => $version)) { - msg(loc("Module '%1' requires '%2' version '%3' to be installed ", - $self->module, $modobj->module, $version), $verbose ); - - push @install_me, [$modobj, $version]; - - ### it's not an MM or Build format, that means it's a package - ### manager... we'll need to install it as well, via the PM - } elsif ( INSTALL_VIA_PACKAGE_MANAGER->($format) and - !$modobj->package_is_perl_core and - ($target ne TARGET_IGNORE) - ) { - msg(loc("Module '%1' depends on '%2', may need to build a '%3' ". - "package for it as well", $self->module, $modobj->module, - $format)); - push @install_me, [$modobj, $version]; - } - } - - - - ### so you just want to ignore prereqs? ### - if( $target eq TARGET_IGNORE ) { - - ### but you have modules you need to install - if( @install_me ) { - msg(loc("Ignoring prereqs, this may mean your install will fail"), - $verbose); - msg(loc("'%1' listed the following dependencies:", $self->module), - $verbose); - - for my $aref (@install_me) { - my ($mod,$version) = @$aref; - - my $str = sprintf "\t%-35s %8s\n", $mod->module, $version; - msg($str,$verbose); - } - - return; - - ### ok, no problem, you have all needed prereqs anyway - } else { - return 1; - } - } - - for my $aref (@install_me) { - my($modobj,$version) = @$aref; - - ### another prereq may have already installed this one... - ### so dont ask again if the module turns out to be uptodate - ### see bug [#11840] - ### if either force or prereq_build are given, the prereq - ### should be built anyway - next if (!$force and !$prereq_build) && - $dist->prereq_satisfied(modobj => $modobj, version => $version); - - ### either we're told to ignore the prereq, - ### or the user wants us to ask him - if( ( $conf->get_conf('prereqs') == PREREQ_ASK and not - $cb->_callbacks->install_prerequisite->($self, $modobj) - ) - ) { - msg(loc("Will not install prerequisite '%1' -- Note " . - "that the overall install may fail due to this", - $modobj->module), $verbose); - next; - } - - ### value set and false -- means failure ### - if( defined $modobj->status->installed - && !$modobj->status->installed - ) { - error( loc( "Prerequisite '%1' failed to install before in " . - "this session", $modobj->module ) ); - $flag++; - last; - } - - ### part of core? - if( $modobj->package_is_perl_core ) { - error(loc("Prerequisite '%1' is perl-core (%2) -- not ". - "installing that. -- Note that the overall ". - "install may fail due to this.", - $modobj->module, $modobj->package ) ); - next; - } - - ### circular dependency code ### - my $pending = $cb->_status->pending_prereqs || {}; - - ### recursive dependency ### - if ( $pending->{ $modobj->module } ) { - error( loc( "Recursive dependency detected (%1) -- skipping", - $modobj->module ) ); - next; - } - - ### register this dependency as pending ### - $pending->{ $modobj->module } = $modobj; - $cb->_status->pending_prereqs( $pending ); - - ### call $modobj->install rather than doing - ### CPANPLUS::Dist->new and the like ourselves, - ### since ->install will take care of fetch && - ### extract as well - my $pa = $dist->status->_prepare_args || {}; - my $ca = $dist->status->_create_args || {}; - my $ia = $dist->status->_install_args || {}; - - unless( $modobj->install( %$pa, %$ca, %$ia, - force => $force, - verbose => $verbose, - format => $format, - target => $target ) - ) { - error(loc("Failed to install '%1' as prerequisite " . - "for '%2'", $modobj->module, $self->module ) ); - $flag++; - } - - ### unregister the pending dependency ### - $pending->{ $modobj->module } = 0; - $cb->_status->pending_prereqs( $pending ); - - last if $flag; - - ### don't want us to install? ### - if( $target ne TARGET_INSTALL ) { - my $dir = $modobj->status->extract - or error(loc("No extraction dir for '%1' found ". - "-- weird", $modobj->module)); - - $modobj->add_to_includepath(); - - next; - } - } - - ### reset the $prereqs iterator, in case we bailed out early ### - keys %$prereqs; - - ### chdir back to where we started - $cb->_chdir( dir => $original_wd ); - - return 1 unless $flag; - return; -} - -1; - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Dist/Autobundle.pm b/cpan/CPANPLUS/lib/CPANPLUS/Dist/Autobundle.pm deleted file mode 100644 index d5e45f3eca..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Dist/Autobundle.pm +++ /dev/null @@ -1,120 +0,0 @@ -package CPANPLUS::Dist::Autobundle; -use deprecate; - -use strict; -use warnings; -use CPANPLUS::Error qw[error msg]; -use Params::Check qw[check]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -use base qw[CPANPLUS::Dist::Base]; - -=head1 NAME - -CPANPLUS::Dist::Autobundle - distribution class for installation snapshots - -=head1 SYNOPSIS - - $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' ); - $modobj->install; - -=head1 DESCRIPTION - -C<CPANPLUS::Dist::Autobundle> is a distribution class for installing installation -snapshots as created by C<CPANPLUS>' C<autobundle> command. - -All modules as mentioned in the snapshot will be installed on your system. - -=cut - -sub init { - my $dist = shift; - my $status = $dist->status; - - $status->mk_accessors( - qw[prepared created installed _prepare_args _create_args _install_args] - ); - - return 1; -} - -sub prepare { - my $dist = shift; - my %args = @_; - - ### store the arguments, so ->install can use them in recursive loops ### - $dist->status->_prepare_args( \%args ); - - return $dist->status->prepared( 1 ); -} - -sub create { - my $dist = shift; - my $self = $dist->parent; - - ### we're also the cpan_dist, since we don't need to have anything - ### prepared - $dist = $self->status->dist_cpan if $self->status->dist_cpan; - $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; - - my $cb = $self->parent; - my $conf = $cb->configure_object; - my %hash = @_; - - my( $force, $verbose, $prereq_target, $prereq_format, $prereq_build); - - my $args = do { - local $Params::Check::ALLOW_UNKNOWN = 1; - my $tmpl = { - force => { default => $conf->get_conf('force'), - store => \$force }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - prereq_target => { default => '', store => \$prereq_target }, - - ### don't set the default prereq format to 'makemaker' -- wrong! - prereq_format => { #default => $self->status->installer_type, - default => '', - store => \$prereq_format }, - prereq_build => { default => 0, store => \$prereq_build }, - }; - - check( $tmpl, \%hash ) or return; - }; - - ### maybe we already ran a create on this object? ### - return 1 if $dist->status->created && !$force; - - ### store the arguments, so ->install can use them in recursive loops ### - $dist->status->_create_args( \%hash ); - - msg(loc("Resolving prerequisites mentioned in the bundle"), $verbose); - - ### this will set the directory back to the start - ### dir, so we must chdir /again/ - my $ok = $dist->_resolve_prereqs( - format => $prereq_format, - verbose => $verbose, - prereqs => $self->status->prereqs, - target => $prereq_target, - force => $force, - prereq_build => $prereq_build, - ); - - ### if all went well, mark it & return - return $dist->status->created( $ok ? 1 : 0); -} - -sub install { - my $dist = shift; - my %args = @_; - - ### store the arguments, so ->install can use them in recursive loops ### - $dist->status->_install_args( \%args ); - - return $dist->status->installed( 1 ); -} - -1; diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Dist/Base.pm b/cpan/CPANPLUS/lib/CPANPLUS/Dist/Base.pm deleted file mode 100644 index 73736d9e4d..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Dist/Base.pm +++ /dev/null @@ -1,261 +0,0 @@ -package CPANPLUS::Dist::Base; -use deprecate; - -use strict; - -use base qw[CPANPLUS::Dist]; -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -=head1 NAME - -CPANPLUS::Dist::Base - Base class for custom distribution classes - -=head1 SYNOPSIS - - package CPANPLUS::Dist::MY_IMPLEMENTATION - - use base 'CPANPLUS::Dist::Base'; - - sub prepare { - my $dist = shift; - - ### do the 'standard' things - $dist->SUPER::prepare( @_ ) or return; - - ### do MY_IMPLEMENTATION specific things - ... - - ### don't forget to set the status! - return $dist->status->prepared( $SUCCESS ? 1 : 0 ); - } - - -=head1 DESCRIPTION - -CPANPLUS::Dist::Base functions as a base class for all custom -distribution implementations. It does all the mundane work -CPANPLUS would have done without a custom distribution, so you -can override just the parts you need to make your own implementation -work. - -=head1 FLOW - -Below is a brief outline when and in which order methods in this -class are called: - - $Class->format_available; # can we use this class on this system? - - $dist->init; # set up custom accessors, etc - $dist->prepare; # find/write meta information - $dist->create; # write the distribution file - $dist->install; # install the distribution file - - $dist->uninstall; # remove the distribution (OPTIONAL) - -=head1 METHODS - -=cut - -=head2 @subs = $Class->methods - -Returns a list of methods that this class implements that you can -override. - -=cut - -sub methods { - return qw[format_available init prepare create install uninstall] -} - -=head2 $bool = $Class->format_available - -This method is called when someone requests a module to be installed -via the superclass. This gives you the opportunity to check if all -the needed requirements to build and install this distribution have -been met. - -For example, you might need a command line program, or a certain perl -module installed to do your job. Now is the time to check. - -Simply return true if the request can proceed and false if it can not. - -The C<CPANPLUS::Dist::Base> implementation always returns true. - -=cut - -sub format_available { return 1 } - - -=head2 $bool = $dist->init - -This method is called just after the new dist object is set up and -before the C<prepare> method is called. This is the time to set up -the object so it can be used with your class. - -For example, you might want to add extra accessors to the C<status> -object, which you might do as follows: - - $dist->status->mk_accessors( qw[my_implementation_accessor] ); - -The C<status> object is implemented as an instance of the -C<Object::Accessor> class. Please refer to its documentation for -details. - -Return true if the initialization was successful, and false if it was -not. - -The C<CPANPLUS::Dist::Base> implementation does not alter your object -and always returns true. - -=cut - -sub init { return 1; } - -=head2 $bool = $dist->prepare - -This runs the preparation step of your distribution. This step is meant -to set up the environment so the C<create> step can create the actual -distribution(file). -A C<prepare> call in the standard C<ExtUtils::MakeMaker> distribution -would, for example, run C<perl Makefile.PL> to find the dependencies -for a distribution. For a C<debian> distribution, this is where you -would write all the metafiles required for the C<dpkg-*> tools. - -The C<CPANPLUS::Dist::Base> implementation simply calls the underlying -distribution class (Typically C<CPANPLUS::Dist::MM> or -C<CPANPLUS::Dist::Build>). - -Sets C<< $dist->status->prepared >> to the return value of this function. -If you override this method, you should make sure to set this value. - -=cut - -sub prepare { - ### just in case you already did a create call for this module object - ### just via a different dist object - my $dist = shift; - my $self = $dist->parent; - my $dist_cpan = $self->status->dist_cpan; - - my $cb = $self->parent; - my $conf = $cb->configure_object; - - $dist->status->prepared( $dist_cpan->prepare( @_ ) ); -} - -=head2 $bool = $dist->create - -This runs the creation step of your distribution. This step is meant -to follow up on the C<prepare> call, that set up your environment so -the C<create> step can create the actual distribution(file). -A C<create> call in the standard C<ExtUtils::MakeMaker> distribution -would, for example, run C<make> and C<make test> to build and test -a distribution. For a C<debian> distribution, this is where you -would create the actual C<.deb> file using C<dpkg>. - -The C<CPANPLUS::Dist::Base> implementation simply calls the underlying -distribution class (Typically C<CPANPLUS::Dist::MM> or -C<CPANPLUS::Dist::Build>). - -Sets C<< $dist->status->dist >> to the location of the created -distribution. -If you override this method, you should make sure to set this value. - -Sets C<< $dist->status->created >> to the return value of this function. -If you override this method, you should make sure to set this value. - -=cut - -sub create { - ### just in case you already did a create call for this module object - ### just via a different dist object - my $dist = shift; - my $self = $dist->parent; - my $dist_cpan = $self->status->dist_cpan; - $dist = $self->status->dist if $self->status->dist; - $self->status->dist( $dist ) unless $self->status->dist; - - my $cb = $self->parent; - my $conf = $cb->configure_object; - my $format = ref $dist; - - ### make sure to set this variable, if the caller hasn't yet - ### just so we have some clue where the dist left off. - $dist->status->dist( $dist_cpan->status->distdir ) - unless defined $dist->status->dist; - - $dist->status->created( $dist_cpan->create(prereq_format => $format, @_) ); -} - -=head2 $bool = $dist->install - -This runs the install step of your distribution. This step is meant -to follow up on the C<create> call, which prepared a distribution(file) -to install. -A C<create> call in the standard C<ExtUtils::MakeMaker> distribution -would, for example, run C<make install> to copy the distribution files -to their final destination. For a C<debian> distribution, this is where -you would run C<dpkg --install> on the created C<.deb> file. - -The C<CPANPLUS::Dist::Base> implementation simply calls the underlying -distribution class (Typically C<CPANPLUS::Dist::MM> or -C<CPANPLUS::Dist::Build>). - -Sets C<< $dist->status->installed >> to the return value of this function. -If you override this method, you should make sure to set this value. - -=cut - -sub install { - ### just in case you already did a create call for this module object - ### just via a different dist object - my $dist = shift; - my $self = $dist->parent; - my $dist_cpan = $self->status->dist_cpan; - - my $cb = $self->parent; - my $conf = $cb->configure_object; - - $dist->status->installed( $dist_cpan->install( @_ ) ); -} - -=head2 $bool = $dist->uninstall - -This runs the uninstall step of your distribution. This step is meant -to remove the distribution from the file system. -A C<uninstall> call in the standard C<ExtUtils::MakeMaker> distribution -would, for example, run C<make uninstall> to remove the distribution -files the file system. For a C<debian> distribution, this is where you -would run C<dpkg --uninstall PACKAGE>. - -The C<CPANPLUS::Dist::Base> implementation simply calls the underlying -distribution class (Typically C<CPANPLUS::Dist::MM> or -C<CPANPLUS::Dist::Build>). - -Sets C<< $dist->status->uninstalled >> to the return value of this function. -If you override this method, you should make sure to set this value. - -=cut - -sub uninstall { - ### just in case you already did a create call for this module object - ### just via a different dist object - my $dist = shift; - my $self = $dist->parent; - my $dist_cpan = $self->status->dist_cpan; - - my $cb = $self->parent; - my $conf = $cb->configure_object; - - $dist->status->uninstalled( $dist_cpan->uninstall( @_ ) ); -} - -1; - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Dist/MM.pm b/cpan/CPANPLUS/lib/CPANPLUS/Dist/MM.pm deleted file mode 100644 index 35f31b7b08..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Dist/MM.pm +++ /dev/null @@ -1,1044 +0,0 @@ -package CPANPLUS::Dist::MM; -use deprecate; - -use strict; -use warnings; -use vars qw[@ISA $STATUS $VERSION]; -use base 'CPANPLUS::Dist::Base'; -$VERSION = "0.9135"; - -use CPANPLUS::Internals::Constants; -use CPANPLUS::Internals::Constants::Report; -use CPANPLUS::Error; -use FileHandle; -use Cwd; - -use IPC::Cmd qw[run]; -use Params::Check qw[check]; -use File::Basename qw[dirname]; -use Module::Load::Conditional qw[can_load check_install]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -local $Params::Check::VERBOSE = 1; - -=pod - -=head1 NAME - -CPANPLUS::Dist::MM - distribution class for MakeMaker related modules - -=head1 SYNOPSIS - - $mm = CPANPLUS::Dist::MM->new( module => $modobj ); - - $mm->create; # runs make && make test - $mm->install; # runs make install - - -=head1 DESCRIPTION - -C<CPANPLUS::Dist::MM> is a distribution class for MakeMaker related -modules. -Using this package, you can create, install and uninstall perl -modules. It inherits from C<CPANPLUS::Dist>. - -=head1 ACCESSORS - -=over 4 - -=item parent() - -Returns the C<CPANPLUS::Module> object that parented this object. - -=item status() - -Returns the C<Object::Accessor> object that keeps the status for -this module. - -=back - -=head1 STATUS ACCESSORS - -All accessors can be accessed as follows: - $mm->status->ACCESSOR - -=over 4 - -=item makefile () - -Location of the Makefile (or Build file). -Set to 0 explicitly if something went wrong. - -=item make () - -BOOL indicating if the C<make> (or C<Build>) command was successful. - -=item test () - -BOOL indicating if the C<make test> (or C<Build test>) command was -successful. - -=item prepared () - -BOOL indicating if the C<prepare> call exited successfully -This gets set after C<perl Makefile.PL> - -=item distdir () - -Full path to the directory in which the C<prepare> call took place, -set after a call to C<prepare>. - -=item created () - -BOOL indicating if the C<create> call exited successfully. This gets -set after C<make> and C<make test>. - -=item installed () - -BOOL indicating if the module was installed. This gets set after -C<make install> (or C<Build install>) exits successfully. - -=item uninstalled () - -BOOL indicating if the module was uninstalled properly. - -=item _create_args () - -Storage of the arguments passed to C<create> for this object. Used -for recursive calls when satisfying prerequisites. - -=item _install_args () - -Storage of the arguments passed to C<install> for this object. Used -for recursive calls when satisfying prerequisites. - -=back - -=cut - -=head1 METHODS - -=head2 $bool = $dist->format_available(); - -Returns a boolean indicating whether or not you can use this package -to create and install modules in your environment. - -=cut - -### check if the format is available ### -sub format_available { - my $dist = shift; - - ### we might be called as $class->format_available =/ - require CPANPLUS::Internals; - my $cb = CPANPLUS::Internals->_retrieve_id( - CPANPLUS::Internals->_last_id ); - my $conf = $cb->configure_object; - - my $mod = "ExtUtils::MakeMaker"; - unless( can_load( modules => { $mod => 0.0 } ) ) { - error( loc( "You do not have '%1' -- '%2' not available", - $mod, __PACKAGE__ ) ); - return; - } - - for my $pgm ( qw[make] ) { - unless( $conf->get_program( $pgm ) ) { - error(loc( - "You do not have '%1' in your path -- '%2' not available\n" . - "Please check your config entry for '%1'", - $pgm, __PACKAGE__ , $pgm - )); - return; - } - } - - return 1; -} - -=pod - -=head2 $bool = $dist->init(); - -Sets up the C<CPANPLUS::Dist::MM> object for use. -Effectively creates all the needed status accessors. - -Called automatically whenever you create a new C<CPANPLUS::Dist> object. - -=cut - -sub init { - my $dist = shift; - my $status = $dist->status; - - $status->mk_accessors(qw[makefile make test created installed uninstalled - bin_make _prepare_args _create_args _install_args] - ); - - return 1; -} - -=pod - -=head2 $bool = $dist->prepare([perl => '/path/to/perl', makemakerflags => 'EXTRA=FLAGS', force => BOOL, verbose => BOOL]) - -C<prepare> preps a distribution for installation. This means it will -run C<perl Makefile.PL> and determine what prerequisites this distribution -declared. - -If you set C<force> to true, it will go over all the stages of the -C<prepare> process again, ignoring any previously cached results. - -When running C<perl Makefile.PL>, the environment variable -C<PERL5_CPANPLUS_IS_EXECUTING> will be set to the full path of the -C<Makefile.PL> that is being executed. This enables any code inside -the C<Makefile.PL> to know that it is being installed via CPANPLUS. - -Returns true on success and false on failure. - -You may then call C<< $dist->create >> on the object to create the -installable files. - -=cut - -sub prepare { - ### just in case you already did a create call for this module object - ### just via a different dist object - my $dist = shift; - my $self = $dist->parent; - - ### we're also the cpan_dist, since we don't need to have anything - ### prepared - $dist = $self->status->dist_cpan if $self->status->dist_cpan; - $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; - - my $cb = $self->parent; - my $conf = $cb->configure_object; - my %hash = @_; - - my $dir; - unless( $dir = $self->status->extract ) { - error( loc( "No dir found to operate on!" ) ); - return; - } - - my $args; - my( $force, $verbose, $perl, $mmflags, $prereq_target, $prereq_format, - $prereq_build ); - { local $Params::Check::ALLOW_UNKNOWN = 1; - my $tmpl = { - perl => { default => $^X, store => \$perl }, - makemakerflags => { default => - $conf->get_conf('makemakerflags') || '', - store => \$mmflags }, - force => { default => $conf->get_conf('force'), - store => \$force }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - prereq_target => { default => '', store => \$prereq_target }, - prereq_format => { default => '', - store => \$prereq_format }, - prereq_build => { default => 0, store => \$prereq_build }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - my @mmflags = $dist->_split_like_shell( $mmflags ); - - ### maybe we already ran a create on this object? ### - return 1 if $dist->status->prepared && !$force; - - ### store the arguments, so ->install can use them in recursive loops ### - $dist->status->_prepare_args( $args ); - - ### chdir to work directory ### - my $orig = cwd(); - unless( $cb->_chdir( dir => $dir ) ) { - error( loc( "Could not chdir to build directory '%1'", $dir ) ); - return; - } - - my $fail; - RUN: { - - ### we resolve 'configure requires' here, so we can run the 'perl - ### Makefile.PL' command - ### XXX for tests: mock f_c_r to something that *can* resolve and - ### something that *doesn't* resolve. Check the error log for ok - ### on this step or failure - ### XXX make a separate tarball to test for this scenario: simply - ### containing a makefile.pl/build.pl for test purposes? - { my $configure_requires = $dist->find_configure_requires; - my $ok = $dist->_resolve_prereqs( - format => $prereq_format, - verbose => $verbose, - prereqs => $configure_requires, - target => $prereq_target, - force => $force, - prereq_build => $prereq_build, - ); - - unless( $ok ) { - - #### use $dist->flush to reset the cache ### - error( loc( "Unable to satisfy '%1' for '%2' " . - "-- aborting install", - 'configure_requires', $self->module ) ); - $dist->status->prepared(0); - $fail++; - last RUN; - } - ### end of prereq resolving ### - } - - - - ### don't run 'perl makefile.pl' again if there's a makefile already - if( -e MAKEFILE->() && (-M MAKEFILE->() < -M $dir) && !$force ) { - msg(loc("'%1' already exists, not running '%2 %3' again ". - " unless you force", - MAKEFILE->(), $perl, MAKEFILE_PL->() ), $verbose ); - - } else { - unless( -e MAKEFILE_PL->() ) { - msg(loc("No '%1' found - attempting to generate one", - MAKEFILE_PL->() ), $verbose ); - - $dist->write_makefile_pl( - verbose => $verbose, - force => $force - ); - - ### bail out if there's no makefile.pl ### - unless( -e MAKEFILE_PL->() ) { - error( loc( "Could not find '%1' - cannot continue", - MAKEFILE_PL->() ) ); - - ### mark that we screwed up ### - $dist->status->makefile(0); - $fail++; last RUN; - } - } - - ### you can turn off running this verbose by changing - ### the config setting below, although it is really not - ### recommended - my $run_verbose = $verbose || - $conf->get_conf('allow_build_interactivity') || - 0; - - ### this makes MakeMaker use defaults if possible, according - ### to schwern. See ticket 8047 for details. - local $ENV{PERL_MM_USE_DEFAULT} = 1 unless $run_verbose; - - ### turn off our PERL5OPT so no modules from CPANPLUS::inc get - ### included in the makefile.pl -- it should build without - ### also, modules that run in taint mode break if we leave - ### our code ref in perl5opt - ### XXX we've removed the ENV settings from cp::inc, so only need - ### to reset the @INC - #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt || ''; - - ### make sure it's a string, so that mmflags that have more than - ### one key value pair are passed as is, rather than as: - ### perl Makefile.PL "key=val key=>val" - - - #### XXX this needs to be the absolute path to the Makefile.PL - ### since cpanp-run-perl uses 'do' to execute the file, and do() - ### checks your @INC.. so, if there's _another_ makefile.pl in - ### your @INC, it will execute that one... - my $makefile_pl = MAKEFILE_PL->( $cb->_safe_path( path => $dir ) ); - - ### setting autoflush to true fixes issue from rt #8047 - ### XXX this means that we need to keep the path to CPANPLUS - ### in @INC, stopping us from resolving dependencies on CPANPLUS - ### at bootstrap time properly. - - my @run_perl = ( '-e', PERL_WRAPPER ); - my $cmd = [$perl, @run_perl, $makefile_pl, @mmflags]; - - ### set ENV var to tell underlying code this is what we're - ### executing. - my $captured; - my $rv = do { - my $env = ENV_CPANPLUS_IS_EXECUTING; - local $ENV{$env} = $makefile_pl; - scalar run( command => $cmd, - buffer => \$captured, - verbose => $run_verbose, # may be interactive - ); - }; - - unless( $rv ) { - error( loc( "Could not run '%1 %2': %3 -- cannot continue", - $perl, MAKEFILE_PL->(), $captured ) ); - - $dist->status->makefile(0); - $fail++; last RUN; - } - - ### put the output on the stack, don't print it - msg( $captured, 0 ); - } - - ### so, nasty feature in Module::Build, that when a Makefile.PL - ### is a disguised Build.PL, it generates a Build file, not a - ### Makefile. this breaks everything :( see rt bug #19741 - if( not -e MAKEFILE->( $dir ) and -e BUILD_PL->( $dir ) ) { - error(loc( - "We just ran '%1' without errors, but no '%2' is ". - "present. However, there is a '%3' file, so this may ". - "be related to bug #19741 in %4, which describes a ". - "fake '%5' which generates a '%6' file instead of a '%7'. ". - "You could try to work around this issue by setting '%8' ". - "to false and trying again. This will attempt to use the ". - "'%9' instead.", - "$^X ".MAKEFILE_PL->(), MAKEFILE->(), BUILD_PL->(), - 'Module::Build', MAKEFILE_PL->(), 'Build', MAKEFILE->(), - 'prefer_makefile', BUILD_PL->() - )); - - $fail++, last RUN; - } - - ### if we got here, we managed to make a 'makefile' ### - $dist->status->makefile( MAKEFILE->($dir) ); - - ### Make (haha) sure that Makefile.PL is older than the Makefile - ### we just generated. - eval { - my $makestat = ( stat MAKEFILE->( $dir ) )[9]; - my $mplstat = ( stat MAKEFILE_PL->( $cb->_safe_path( path => $dir ) ) )[9]; - if ( $makestat < $mplstat ) { - my $ftime = $makestat - 60; - utime $ftime, $ftime, MAKEFILE_PL->( $cb->_safe_path( path => $dir ) ); - } - }; - - ### start resolving prereqs ### - my $prereqs = $self->status->prereqs; - - ### a hashref of prereqs on success, undef on failure ### - $prereqs ||= $dist->_find_prereqs( - verbose => $verbose, - file => $dist->status->makefile - ); - - unless( $prereqs ) { - error( loc( "Unable to scan '%1' for prereqs", - $dist->status->makefile ) ); - - $fail++; last RUN; - } - } - - unless( $cb->_chdir( dir => $orig ) ) { - error( loc( "Could not chdir back to start dir '%1'", $orig ) ); - } - - ### save where we wrote this stuff -- same as extract dir in normal - ### installer circumstances - $dist->status->distdir( $self->status->extract ); - - return $dist->status->prepared( $fail ? 0 : 1); -} - -=pod - -=head2 $href = $dist->_find_prereqs( file => '/path/to/Makefile', [verbose => BOOL]) - -Parses a C<Makefile> for C<PREREQ_PM> entries and distills from that -any prerequisites mentioned in the C<Makefile> - -Returns a hash with module-version pairs on success and false on -failure. - -=cut - -sub _find_prereqs { - my $dist = shift; - my $self = $dist->parent; - my $cb = $self->parent; - my $conf = $cb->configure_object; - my %hash = @_; - - my ($verbose, $file); - my $tmpl = { - verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, - file => { required => 1, allow => FILE_READABLE, store => \$file }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - ### see if we got prereqs from MYMETA - my $prereqs = $dist->find_mymeta_requires(); - - ### we found some prereqs, we'll trust MYMETA - ### but we do need to run it through the callback - return $cb->_callbacks->filter_prereqs->( $cb, $prereqs ) if keys %$prereqs; - - my $fh = FileHandle->new(); - unless( $fh->open( $file ) ) { - error( loc( "Cannot open '%1': %2", $file, $! ) ); - return; - } - - my %p; - while( local $_ = <$fh> ) { - my ($found) = m|^[\#]\s+PREREQ_PM\s+=>\s+(.+)|; - - next unless $found; - - while( $found =~ m/(?:\s)([\w\:]+)=>(?:q\[(.*?)\],?|undef)/g ) { - if( defined $p{$1} ) { - my $ver = $cb->_version_to_number(version => $2); - $p{$1} = $ver - if $cb->_vcmp( $ver, $p{$1} ) > 0; - } - else { - $p{$1} = $cb->_version_to_number(version => $2); - } - } - last; - } - - my $href = $cb->_callbacks->filter_prereqs->( $cb, \%p ); - - $self->status->prereqs( $href ); - - ### just to make sure it's not the same reference ### - return { %$href }; -} - -=pod - -=head2 $bool = $dist->create([perl => '/path/to/perl', make => '/path/to/make', makeflags => 'EXTRA=FLAGS', prereq_target => TARGET, skiptest => BOOL, force => BOOL, verbose => BOOL]) - -C<create> creates the files necessary for installation. This means -it will run C<make> and C<make test>. This will also scan for and -attempt to satisfy any prerequisites the module may have. - -If you set C<skiptest> to true, it will skip the C<make test> stage. -If you set C<force> to true, it will go over all the stages of the -C<make> process again, ignoring any previously cached results. It -will also ignore a bad return value from C<make test> and still allow -the operation to return true. - -Returns true on success and false on failure. - -You may then call C<< $dist->install >> on the object to actually -install it. - -=cut - -sub create { - ### just in case you already did a create call for this module object - ### just via a different dist object - my $dist = shift; - my $self = $dist->parent; - - ### we're also the cpan_dist, since we don't need to have anything - ### prepared - $dist = $self->status->dist_cpan if $self->status->dist_cpan; - $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; - - my $cb = $self->parent; - my $conf = $cb->configure_object; - my %hash = @_; - - my $dir; - unless( $dir = $self->status->extract ) { - error( loc( "No dir found to operate on!" ) ); - return; - } - - my $args; - my( $force, $verbose, $make, $makeflags, $skiptest, $prereq_target, $perl, - @mmflags, $prereq_format, $prereq_build); - { local $Params::Check::ALLOW_UNKNOWN = 1; - my $tmpl = { - perl => { default => $^X, store => \$perl }, - force => { default => $conf->get_conf('force'), - store => \$force }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - make => { default => $conf->get_program('make'), - store => \$make }, - makeflags => { default => $conf->get_conf('makeflags'), - store => \$makeflags }, - skiptest => { default => $conf->get_conf('skiptest'), - store => \$skiptest }, - prereq_target => { default => '', store => \$prereq_target }, - ### don't set the default prereq format to 'makemaker' -- wrong! - prereq_format => { #default => $self->status->installer_type, - default => '', - store => \$prereq_format }, - prereq_build => { default => 0, store => \$prereq_build }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - my @makeflags = $dist->_split_like_shell( $makeflags ); - - ### maybe we already ran a create on this object? - ### make sure we add to include path again, just in case we came from - ### ->save_state, at which point we need to restore @INC/$PERL5LIB - if( $dist->status->created && !$force ) { - $self->add_to_includepath; - return 1; - } - - ### store the arguments, so ->install can use them in recursive loops ### - $dist->status->_create_args( $args ); - - unless( $dist->status->prepared ) { - error( loc( "You have not successfully prepared a '%2' distribution ". - "yet -- cannot create yet", __PACKAGE__ ) ); - return; - } - - - ### chdir to work directory ### - my $orig = cwd(); - unless( $cb->_chdir( dir => $dir ) ) { - error( loc( "Could not chdir to build directory '%1'", $dir ) ); - return; - } - - my $fail; my $prereq_fail; my $test_fail; - my $status = { }; - RUN: { - ### this will set the directory back to the start - ### dir, so we must chdir /again/ - my $ok = $dist->_resolve_prereqs( - format => $prereq_format, - verbose => $verbose, - prereqs => $self->status->prereqs, - target => $prereq_target, - force => $force, - prereq_build => $prereq_build, - ); - - unless( $cb->_chdir( dir => $dir ) ) { - error( loc( "Could not chdir to build directory '%1'", $dir ) ); - return; - } - - unless( $ok ) { - - #### use $dist->flush to reset the cache ### - error( loc( "Unable to satisfy prerequisites for '%1' " . - "-- aborting install", $self->module ) ); - $dist->status->make(0); - $fail++; $prereq_fail++; - last RUN; - } - ### end of prereq resolving ### - - my $captured; - - ### 'make' section ### - if( -d BLIB->($dir) && (-M BLIB->($dir) < -M $dir) && !$force ) { - msg(loc("Already ran '%1' for this module [%2] -- " . - "not running again unless you force", - $make, $self->module ), $verbose ); - } else { - unless(scalar run( command => [$make, @makeflags], - buffer => \$captured, - verbose => $verbose ) - ) { - error( loc( "MAKE failed: %1 %2", $!, $captured ) ); - if ( $conf->get_conf('cpantest') ) { - $status->{stage} = 'build'; - $status->{capture} = $captured; - } - $dist->status->make(0); - $fail++; last RUN; - } - - ### put the output on the stack, don't print it - msg( $captured, 0 ); - - $dist->status->make(1); - - ### add this directory to your lib ### - $self->add_to_includepath(); - - ### dont bail out here, there's a conditional later on - #last RUN if $skiptest; - } - - ### 'make test' section ### - unless( $skiptest ) { - - ### turn off our PERL5OPT so no modules from CPANPLUS::inc get - ### included in make test -- it should build without - ### also, modules that run in taint mode break if we leave - ### our code ref in perl5opt - ### XXX CPANPLUS::inc functionality is now obsolete. - #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt || ''; - - ### you can turn off running this verbose by changing - ### the config setting below, although it is really not - ### recommended - my $run_verbose = - $verbose || - $conf->get_conf('allow_build_interactivity') || - 0; - - ### XXX need to add makeflags here too? - ### yes, but they should really be split out -- see bug #4143 - if( scalar run( - command => [$make, 'test', @makeflags], - buffer => \$captured, - verbose => $run_verbose, - ) ) { - ### tests might pass because it doesn't have any tests defined - ### log this occasion non-verbosely, so our test reporter can - ### pick up on this - if ( NO_TESTS_DEFINED->( $captured ) ) { - msg( NO_TESTS_DEFINED->( $captured ), 0 ) - } else { - msg( loc( "MAKE TEST passed: %1", $captured ), 0 ); - } - - if ( $conf->get_conf('cpantest') ) { - $status->{stage} = 'test'; - $status->{capture} = $captured; - } - - $dist->status->test(1); - } else { - error( loc( "MAKE TEST failed: %1", $captured ), ( $run_verbose ? 0 : 1 ) ); - - if ( $conf->get_conf('cpantest') ) { - $status->{stage} = 'test'; - $status->{capture} = $captured; - } - - ### send out error report here? or do so at a higher level? - ### --higher level --kane. - $dist->status->test(0); - - ### mark specifically *test* failure.. so we dont - ### send success on force... - $test_fail++; - - if( !$force and !$cb->_callbacks->proceed_on_test_failure->( - $self, $captured ) - ) { - $fail++; last RUN; - } - } - } - } #</RUN> - - unless( $cb->_chdir( dir => $orig ) ) { - error( loc( "Could not chdir back to start dir '%1'", $orig ) ); - } - - ### TODO: Add $stage to _send_report() - ### send out test report? - ### only do so if the failure is this module, not its prereq - if( $conf->get_conf('cpantest') and not $prereq_fail) { - $cb->_send_report( - module => $self, - failed => $test_fail || $fail, - buffer => CPANPLUS::Error->stack_as_string, - status => $status, - verbose => $verbose, - force => $force, - ) or error(loc("Failed to send test report for '%1'", - $self->module ) ); - } - - return $dist->status->created( $fail ? 0 : 1); -} - -=pod - -=head2 $bool = $dist->install([make => '/path/to/make', makemakerflags => 'EXTRA=FLAGS', force => BOOL, verbose => BOOL]) - -C<install> runs the following command: - make install - -Returns true on success, false on failure. - -=cut - -sub install { - - ### just in case you did the create with ANOTHER dist object linked - ### to the same module object - my $dist = shift(); - my $self = $dist->parent; - $dist = $self->status->dist_cpan if $self->status->dist_cpan; - - my $cb = $self->parent; - my $conf = $cb->configure_object; - my %hash = @_; - - - unless( $dist->status->created ) { - error(loc("You have not successfully created a '%2' distribution yet " . - "-- cannot install yet", __PACKAGE__ )); - return; - } - - my $dir; - unless( $dir = $self->status->extract ) { - error( loc( "No dir found to operate on!" ) ); - return; - } - - my $args; - my($force,$verbose,$make,$makeflags); - { local $Params::Check::ALLOW_UNKNOWN = 1; - my $tmpl = { - force => { default => $conf->get_conf('force'), - store => \$force }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - make => { default => $conf->get_program('make'), - store => \$make }, - makeflags => { default => $conf->get_conf('makeflags'), - store => \$makeflags }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - ### value set and false -- means failure ### - if( defined $self->status->installed && - !$self->status->installed && !$force - ) { - error( loc( "Module '%1' has failed to install before this session " . - "-- aborting install", $self->module ) ); - return; - } - - my @makeflags = $dist->_split_like_shell( $makeflags ); - - $dist->status->_install_args( $args ); - - my $orig = cwd(); - unless( $cb->_chdir( dir => $dir ) ) { - error( loc( "Could not chdir to build directory '%1'", $dir ) ); - return; - } - - my $fail; my $captured; - - ### 'make install' section ### - ### XXX need makeflags here too? - ### yes, but they should really be split out.. see bug #4143 - my $cmd = [$make, 'install', @makeflags]; - my $sudo = $conf->get_program('sudo'); - unshift @$cmd, $sudo if $sudo and $>; - - $cb->flush('lib'); - unless(scalar run( command => $cmd, - verbose => $verbose, - buffer => \$captured, - ) ) { - error( loc( "MAKE INSTALL failed: %1 %2", $!, $captured ) ); - $fail++; - } - - ### put the output on the stack, don't print it - msg( $captured, 0 ); - - unless( $cb->_chdir( dir => $orig ) ) { - error( loc( "Could not chdir back to start dir '%1'", $orig ) ); - } - - return $dist->status->installed( $fail ? 0 : 1 ); - -} - -=pod - -=head2 $bool = $dist->write_makefile_pl([force => BOOL, verbose => BOOL]) - -This routine can write a C<Makefile.PL> from the information in a -module object. It is used to write a C<Makefile.PL> when the original -author forgot it (!!). - -Returns 1 on success and false on failure. - -The file gets written to the directory the module's been extracted -to. - -=cut - -sub write_makefile_pl { - ### just in case you already did a call for this module object - ### just via a different dist object - my $dist = shift; - my $self = $dist->parent; - $dist = $self->status->dist_cpan if $self->status->dist_cpan; - $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; - - my $cb = $self->parent; - my $conf = $cb->configure_object; - my %hash = @_; - - my $dir; - unless( $dir = $self->status->extract ) { - error( loc( "No dir found to operate on!" ) ); - return; - } - - my ($force, $verbose); - my $tmpl = { - force => { default => $conf->get_conf('force'), - store => \$force }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - my $file = MAKEFILE_PL->($dir); - if( -s $file && !$force ) { - msg(loc("Already created '%1' - not doing so again without force", - $file ), $verbose ); - return 1; - } - - ### due to a bug with AS perl 5.8.4 built 810 (and maybe others) - ### opening files with content in them already does nasty things; - ### seek to pos 0 and then print, but not truncating the file - ### bug reported to activestate on 19 sep 2004: - ### http://bugs.activestate.com/show_bug.cgi?id=34051 - unlink $file if $force; - - my $fh = new FileHandle; - unless( $fh->open( ">$file" ) ) { - error( loc( "Could not create file '%1': %2", $file, $! ) ); - return; - } - - my $mf = MAKEFILE_PL->(); - my $name = $self->module; - my $version = $self->version; - my $author = $self->author->author; - my $href = $self->status->prereqs; - my $prereqs = join ",\n", map { - (' ' x 25) . "'$_'\t=> '$href->{$_}'" - } keys %$href; - $prereqs ||= ''; # just in case there are none; - - print $fh qq| - ### Auto-generated $mf by CPANPLUS ### - - use ExtUtils::MakeMaker; - - WriteMakefile( - NAME => '$name', - VERSION => '$version', - AUTHOR => '$author', - PREREQ_PM => { -$prereqs - }, - ); - \n|; - - $fh->close; - return 1; -} - -sub dist_dir { - ### just in case you already did a call for this module object - ### just via a different dist object - my $dist = shift; - my $self = $dist->parent; - $dist = $self->status->dist_cpan if $self->status->dist_cpan; - $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; - - my $cb = $self->parent; - my $conf = $cb->configure_object; - my %hash = @_; - - my $make; my $verbose; - { local $Params::Check::ALLOW_UNKNOWN = 1; - my $tmpl = { - make => { default => $conf->get_program('make'), - store => \$make }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - }; - - check( $tmpl, \%hash ) or return; - } - - - my $dir; - unless( $dir = $self->status->extract ) { - error( loc( "No dir found to operate on!" ) ); - return; - } - - ### chdir to work directory ### - my $orig = cwd(); - unless( $cb->_chdir( dir => $dir ) ) { - error( loc( "Could not chdir to build directory '%1'", $dir ) ); - return; - } - - my $fail; my $distdir; - TRY: { - $dist->prepare( @_ ) or (++$fail, last TRY); - - - my $captured; - unless(scalar run( command => [$make, 'distdir'], - buffer => \$captured, - verbose => $verbose ) - ) { - error( loc( "MAKE DISTDIR failed: %1 %2", $!, $captured ) ); - ++$fail, last TRY; - } - - ### /path/to/Foo-Bar-1.2/Foo-Bar-1.2 - $distdir = File::Spec->catdir( $dir, $self->package_name . '-' . - $self->package_version ); - - unless( -d $distdir ) { - error(loc("Do not know where '%1' got created", 'distdir')); - ++$fail, last TRY; - } - } - - unless( $cb->_chdir( dir => $orig ) ) { - error( loc( "Could not chdir to start directory '%1'", $orig ) ); - return; - } - - return if $fail; - return $distdir; -} - -sub _split_like_shell { - my ($self, $string) = @_; - - return () unless defined($string); - return @$string if ref $string eq 'ARRAY'; - $string =~ s/^\s+|\s+$//g; - return () unless length($string); - - require Text::ParseWords; - return Text::ParseWords::shellwords($string); -} - -1; - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Dist/Sample.pm b/cpan/CPANPLUS/lib/CPANPLUS/Dist/Sample.pm deleted file mode 100644 index e03d66f983..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Dist/Sample.pm +++ /dev/null @@ -1,20 +0,0 @@ -package CPANPLUS::Dist::Sample; -use deprecate; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -=pod - -=head1 NAME - -CPANPLUS::Dist::Sample -- Sample code to create your own Dist::* plugin - -=head1 Description. - -This document is B<Obsolete>. Please read the documentation and code -in C<CPANPLUS::Dist::Base>. - -=cut - -1; diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Error.pm b/cpan/CPANPLUS/lib/CPANPLUS/Error.pm deleted file mode 100644 index 0df6f33468..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Error.pm +++ /dev/null @@ -1,210 +0,0 @@ -package CPANPLUS::Error; -use deprecate; - -use strict; -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -use Log::Message private => 0;; - -=pod - -=head1 NAME - -CPANPLUS::Error - error handling for CPANPLUS - -=head1 SYNOPSIS - - use CPANPLUS::Error qw[cp_msg cp_error]; - -=head1 DESCRIPTION - -This module provides the error handling code for the CPANPLUS -libraries, and is mainly intended for internal use. - -=head1 FUNCTIONS - -=head2 cp_msg("message string" [,VERBOSE]) - -Records a message on the stack, and prints it to C<STDOUT> (or actually -C<$MSG_FH>, see the C<GLOBAL VARIABLES> section below), if the -C<VERBOSE> option is true. -The C<VERBOSE> option defaults to false. - -=head2 msg() - -An alias for C<cp_msg>. - -=head2 cp_error("error string" [,VERBOSE]) - -Records an error on the stack, and prints it to C<STDERR> (or actually -C<$ERROR_FH>, see the C<GLOBAL VARIABLES> sections below), if the -C<VERBOSE> option is true. -The C<VERBOSE> options defaults to true. - -=head2 error() - -An alias for C<cp_error>. - -=head1 CLASS METHODS - -=head2 CPANPLUS::Error->stack() - -Retrieves all the items on the stack. Since C<CPANPLUS::Error> is -implemented using C<Log::Message>, consult its manpage for the -function C<retrieve> to see what is returned and how to use the items. - -=head2 CPANPLUS::Error->stack_as_string([TRACE]) - -Returns the whole stack as a printable string. If the C<TRACE> option is -true all items are returned with C<Carp::longmess> output, rather than -just the message. -C<TRACE> defaults to false. - -=head2 CPANPLUS::Error->flush() - -Removes all the items from the stack and returns them. Since -C<CPANPLUS::Error> is implemented using C<Log::Message>, consult its -manpage for the function C<retrieve> to see what is returned and how -to use the items. - -=cut - -BEGIN { - use Exporter; - use Params::Check qw[check]; - use vars qw[@EXPORT @ISA $ERROR_FH $MSG_FH]; - - @ISA = 'Exporter'; - @EXPORT = qw[cp_error cp_msg error msg]; - - my $log = new Log::Message; - - for my $func ( @EXPORT ) { - no strict 'refs'; - - my $prefix = 'cp_'; - my $name = $func; - $name =~ s/^$prefix//g; - - *$func = sub { - my $msg = shift; - - ### no point storing non-messages - return unless defined $msg; - - $log->store( - message => $msg, - tag => uc $name, - level => $prefix . $name, - extra => [@_] - ); - }; - } - - sub flush { - my @foo = $log->flush; - return unless @foo; - return reverse @foo; - } - - sub stack { - return $log->retrieve( chrono => 1 ); - } - - sub stack_as_string { - my $class = shift; - my $trace = shift() ? 1 : 0; - - return join $/, map { - '[' . $_->tag . '] [' . $_->when . '] ' . - ($trace ? $_->message . ' ' . $_->longmess - : $_->message); - } __PACKAGE__->stack; - } -} - -=head1 GLOBAL VARIABLES - -=over 4 - -=item $ERROR_FH - -This is the filehandle all the messages sent to C<error()> are being -printed. This defaults to C<*STDERR>. - -=item $MSG_FH - -This is the filehandle all the messages sent to C<msg()> are being -printed. This default to C<*STDOUT>. - -=back - -=cut - -local $| = 1; -$ERROR_FH = \*STDERR; -$MSG_FH = \*STDOUT; - -package # Hide from Pause - Log::Message::Handlers; -use Carp (); - -{ - - sub cp_msg { - my $self = shift; - my $verbose = shift; - - ### so you don't want us to print the msg? ### - return if defined $verbose && $verbose == 0; - - my $old_fh = select $CPANPLUS::Error::MSG_FH; - - print '['. $self->tag . '] ' . $self->message . "\n"; - select $old_fh; - - return; - } - - sub cp_error { - my $self = shift; - my $verbose = shift; - - ### so you don't want us to print the error? ### - return if defined $verbose && $verbose == 0; - - my $old_fh = select $CPANPLUS::Error::ERROR_FH; - - ### is only going to be 1 for now anyway ### - ### C::I may not be loaded, so do a can() check first - my $cb = CPANPLUS::Internals->can('_return_all_objects') - ? (CPANPLUS::Internals->_return_all_objects)[0] - : undef; - - ### maybe we didn't initialize an internals object (yet) ### - my $debug = $cb ? $cb->configure_object->get_conf('debug') : 0; - my $msg = '['. $self->tag . '] ' . $self->message . "\n"; - - ### i'm getting this warning in the test suite: - ### Ambiguous call resolved as CORE::warn(), qualify as such or - ### use & at CPANPLUS/Error.pm line 57. - ### no idea where it's coming from, since there's no 'sub warn' - ### anywhere to be found, but i'll mark it explicitly nonetheless - ### --kane - print $debug ? Carp::shortmess($msg) : $msg . "\n"; - - select $old_fh; - - return; - } -} - -1; - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/FAQ.pod b/cpan/CPANPLUS/lib/CPANPLUS/FAQ.pod deleted file mode 100644 index 00c186ab0d..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/FAQ.pod +++ /dev/null @@ -1,34 +0,0 @@ -=pod - -=head1 NAME - -CPANPLUS::FAQ - CPANPLUS Frequently Asked Questions - -=head1 NAME - -CPANPLUS::FAQ - -=head1 DESCRIPTION - -This document attempts to provide answers to commonly asked questions. - - XXX Work in progress - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=cut - diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Hacking.pod b/cpan/CPANPLUS/lib/CPANPLUS/Hacking.pod deleted file mode 100644 index c226b07169..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Hacking.pod +++ /dev/null @@ -1,135 +0,0 @@ -=pod - -=head1 NAME - -CPANPLUS::Hacking - developing CPANPLUS - -=head1 DESCRIPTION - -This document attempts to describe how to develop with the -CPANPLUS environment most easily, how certain things work and why. - -This is basically a quick-start guide to people who want to add -features or patches to CPANPLUS. - -=head1 OBTAINING CPANPLUS - -Checkout CPANPLUS from its GIT repository at -L<https://github.com/jib/cpanplus-devel> . - -=head1 INSTALLING CPANPLUS - -CPANPLUS follows the standard perl module installation process: - - perl Makefile.PL - make - make test - make install - -=head1 CONFIGURING CPANPLUS - -When running C<perl Makefile.PL> you will be prompted to configure. -If you have already done so, and merely wish to update the C<Makefile>, -simply run: - - perl Makefile.PL JFDI=1 - -This will keep your configuration intact. Note however, if there are -changes to the default configuration file C<Config.pm-orig>, you should -either delete your current config file and reconfigure, or patch your -config file from the new entries in C<Config.pm-orig>. - -=head1 RUNNING CPANPLUS FROM DEVELOPMENT ENVIRONMENT - -If you'd rather not install the development version to your -C<site_perl> directory, that's no problem. You can set your C<PERL5LIB> -environment variable to CPANPLUS' C<lib> directory, and you can run it -from there. - -=head1 RUNNING CPANPLUS TESTS - -Tests are what tells us if CPANPLUS is working. If a test is not working, -try to run it explicitly like this: - - perl -I/path/to/cpanplus/lib t/XX_name_of_test.t 1 - -The extra '1' makes sure that all the messages and errors (they might -be errors we're testing for!) are being printed rather than kept quiet. -This is a great way to find out the context of any failures that may -occur. - -If you believe this test failure proves a bug in CPANPLUS, the long -output of the test file is something we'd like to see alongside your -bug report. - -=head1 FINDING BUGS - -Sometimes you might find bugs in CPANPLUS' behaviour. If you encounter -these in a development snapshot, we'd appreciate a complete patch (as -described below in the L<SENDING PATCHES> section. - -If it's way over your head, then of course reporting the bug is always -better than not reporting it at all. Before you do so though, make -sure you have the B<latest> development snapshot, and the bug still -persists there. If so, report the bug to this address: - - bug-cpanplus@rt.cpan.org - -A good C<patch> would have the following characteristics: - -=over 4 - -=item Problem description - -Describe clearly what the bug is you found, and what it should have -done instead. - -=item Program demonstrating the bug - -Show us how to reproduce the bug, in a simple of a program as possible - -=item [OPTIONAL] A patch to the test suite to test for the bug - -Amend our test suite by making sure this bug will be found in this, and -future versions of CPANPLUS (see L<SUPPLYING PATCHES>) - -=item [OPTIONAL] A patch to the code + tests + documentation - -Fix the bug, update the docs & tests. That way your bug will be gone -forever :) - -=back - -=head1 SUPPLYING PATCHES - -Patches are a good thing, and they are welcome. Especially if they fix -bugs you've found along the way, or that others have reported. - -We prefer patches in the following format: - -=over 4 - -=item * In C<diff -u> or C<diff -c> format - -=item * From the root of the snapshot - -=item * Including patches for code + tests + docs - -=item * Sent per mail to bug-cpanplus@rt.cpan.org - -=item * With subject containing C<[PATCH]> + description of the patch - -=back - -You will always be informed if a patch is applied or rejected, and in -case of rejection why that is (perhaps you can tweak the patch to have -it accepted after all). - -=cut - -__END__ - -* perl5lib -* perl t/foo 1 -* patches to cpanplus-devel -* snap/devel.tgz diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals.pm deleted file mode 100644 index 5c53e67e74..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals.pm +++ /dev/null @@ -1,556 +0,0 @@ -package CPANPLUS::Internals; -use deprecate; - -### we /need/ perl5.6.1 or higher -- we use coderefs in @INC, -### and 5.6.0 is just too buggy -use 5.006001; - -use strict; -use Config; - -use CPANPLUS::Error; - -use CPANPLUS::Selfupdate; - -use CPANPLUS::Internals::Extract; -use CPANPLUS::Internals::Fetch; -use CPANPLUS::Internals::Utils; -use CPANPLUS::Internals::Constants; -use CPANPLUS::Internals::Search; -use CPANPLUS::Internals::Report; - -require base; -use Cwd qw[cwd]; -use Module::Load qw[load]; -use Params::Check qw[check]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; -use Module::Load::Conditional qw[can_load]; - -use Object::Accessor; - -local $Params::Check::VERBOSE = 1; - -use vars qw[@ISA $VERSION]; - -@ISA = qw[ - CPANPLUS::Internals::Extract - CPANPLUS::Internals::Fetch - CPANPLUS::Internals::Utils - CPANPLUS::Internals::Search - CPANPLUS::Internals::Report - ]; - -$VERSION = "0.9135"; - -=pod - -=head1 NAME - -CPANPLUS::Internals - CPANPLUS internals - -=head1 SYNOPSIS - - my $internals = CPANPLUS::Internals->_init( _conf => $conf ); - my $backend = CPANPLUS::Internals->_retrieve_id( $ID ); - -=head1 DESCRIPTION - -This module is the guts of CPANPLUS -- it inherits from all other -modules in the CPANPLUS::Internals::* namespace, thus defying normal -rules of OO programming -- but if you're reading this, you already -know what's going on ;) - -Please read the C<CPANPLUS::Backend> documentation for the normal API. - -=head1 ACCESSORS - -=over 4 - -=item _conf - -Get/set the configure object - -=item _id - -Get/set the id - -=cut - -### autogenerate accessors ### -for my $key ( qw[_conf _id _modules _hosts _methods _status _path - _callbacks _selfupdate _mtree _atree] -) { - no strict 'refs'; - *{__PACKAGE__."::$key"} = sub { - $_[0]->{$key} = $_[1] if @_ > 1; - return $_[0]->{$key}; - } -} - -=pod - -=back - -=head1 METHODS - -=head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ ) - -C<_init> creates a new CPANPLUS::Internals object. - -You have to pass it a valid C<CPANPLUS::Configure> object. - -Returns the object on success, or dies on failure. - -=cut - -{ ### NOTE: - ### if extra callbacks are added, don't forget to update the - ### 02-internals.t test script with them! - my $callback_map = { - ### name default value - install_prerequisite => 1, # install prereqs when 'ask' is set? - edit_test_report => 0, # edit the prepared test report? - send_test_report => 1, # send the test report? - # munge the test report - munge_test_report => sub { return $_[1] }, - # filter out unwanted prereqs - filter_prereqs => sub { return $_[1] }, - # continue if 'make test' fails? - proceed_on_test_failure => sub { return 0 }, - munge_dist_metafile => sub { return $_[1] }, - }; - - my $status = Object::Accessor->new; - $status->mk_accessors(qw[pending_prereqs]); - - my $callback = Object::Accessor->new; - $callback->mk_accessors(keys %$callback_map); - - my $conf; - my $Tmpl = { - _conf => { required => 1, store => \$conf, - allow => IS_CONFOBJ }, - _id => { default => '', no_override => 1 }, - _authortree => { default => '', no_override => 1 }, - _modtree => { default => '', no_override => 1 }, - _hosts => { default => {}, no_override => 1 }, - _methods => { default => {}, no_override => 1 }, - _status => { default => '<empty>', no_override => 1 }, - _callbacks => { default => '<empty>', no_override => 1 }, - _path => { default => $ENV{PATH} || '', no_override => 1 }, - }; - - sub _init { - my $class = shift; - my %hash = @_; - - ### temporary warning until we fix the storing of multiple id's - ### and their serialization: - ### probably not going to happen --kane - if( my $id = $class->_last_id ) { - # make it a singleton. - warn loc(q[%1 currently only supports one %2 object per ] . - qq[running program\n], 'CPANPLUS', $class); - - return $class->_retrieve_id( $id ); - } - - my $args = check($Tmpl, \%hash) - or die loc(qq[Could not initialize '%1' object], $class); - - bless $args, $class; - - $args->{'_id'} = $args->_inc_id; - $args->{'_status'} = $status; - $args->{'_callbacks'} = $callback; - - ### initialize callbacks to default state ### - for my $name ( $callback->ls_accessors ) { - my $rv = ref $callback_map->{$name} ? 'sub return value' : - $callback_map->{$name} ? 'true' : 'false'; - - $args->_callbacks->$name( - sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'", - $name, $rv), $args->_conf->get_conf('debug')); - return ref $callback_map->{$name} - ? $callback_map->{$name}->( @_ ) - : $callback_map->{$name}; - } - ); - } - - ### create a selfupdate object - $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) ); - - ### initialize it as an empty hashref ### - $args->_status->pending_prereqs( {} ); - - $conf->_set_build( startdir => cwd() ), - or error( loc("couldn't locate current dir!") ); - - $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive'); - - my $id = $args->_store_id( $args ); - - unless ( $id == $args->_id ) { - error( loc("IDs do not match: %1 != %2. Storage failed!", - $id, $args->_id) ); - } - - ### different source engines available now, so set them here - { my $store = $conf->get_conf( 'source_engine' ) - || DEFAULT_SOURCE_ENGINE; - - unless( can_load( modules => { $store => '0.0' }, verbose => 1 ) ) { - error( loc( "Could not load source engine '%1'", $store ) ); - - if( $store ne DEFAULT_SOURCE_ENGINE ) { - msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 ); - - load DEFAULT_SOURCE_ENGINE; - - base->import( DEFAULT_SOURCE_ENGINE ); - } else { - return; - } - } else { - base->import( $store ); - } - } - - return $args; - } - -=pod - -=head2 $bool = $internals->_flush( list => \@caches ) - -Flushes the designated caches from the C<CPANPLUS> object. - -Returns true on success, false if one or more caches could not be -be flushed. - -=cut - - sub _flush { - my $self = shift; - my $conf = $self->configure_object; - my %hash = @_; - - my $aref; - my $tmpl = { - list => { required => 1, default => [], - strict_type => 1, store => \$aref }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - my $flag = 0; - for my $what (@$aref) { - my $cache = '_' . $what; - - ### set the include paths back to their original ### - if( $what eq 'lib' ) { - $ENV{PERL5LIB} = $conf->_perl5lib || ''; - @INC = @{$conf->_lib}; - $ENV{PATH} = $self->_path || ''; - - ### give all modules a new status object -- this is slightly - ### costly, but the best way to make sure all statuses are - ### forgotten --kane - } elsif ( $what eq 'modules' ) { - for my $modobj ( values %{$self->module_tree} ) { - - $modobj->_flush; - } - - ### blow away the methods cache... currently, that's only - ### File::Fetch's method fail list - } elsif ( $what eq 'methods' ) { - - ### still unbelievably p4 :( ### - $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {}; - - ### blow away the m::l::c cache, so modules can be (re)loaded - ### again if they become available - } elsif ( $what eq 'load' ) { - undef $Module::Load::Conditional::CACHE; - - } else { - unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) { - error( loc( "No such cache: '%1'", $what ) ); - $flag++; - next; - } else { - $self->$cache( {} ); - } - } - } - return !$flag; - } - -### NOTE: -### if extra callbacks are added, don't forget to update the -### 02-internals.t test script with them! - -=pod - -=head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF ); - -Registers a callback for later use by the internal libraries. - -Here is a list of the currently used callbacks: - -=over 4 - -=item install_prerequisite - -Is called when the user wants to be C<asked> about what to do with -prerequisites. Should return a boolean indicating true to install -the prerequisite and false to skip it. - -=item send_test_report - -Is called when the user should be prompted if he wishes to send the -test report. Should return a boolean indicating true to send the -test report and false to skip it. - -=item munge_test_report - -Is called when the test report message has been composed, giving -the user a chance to programatically alter it. Should return the -(munged) message to be sent. - -=item edit_test_report - -Is called when the user should be prompted to edit test reports -about to be sent out by Test::Reporter. Should return a boolean -indicating true to edit the test report in an editor and false -to skip it. - -=item proceed_on_test_failure - -Is called when 'make test' or 'Build test' fails. Should return -a boolean indicating whether the install should continue even if -the test failed. - -=item munge_dist_metafile - -Is called when the C<CPANPLUS::Dist::*> metafile is created, like -C<control> for C<CPANPLUS::Dist::Deb>, giving the user a chance to -programatically alter it. Should return the (munged) text to be -written to the metafile. - -=back - -=cut - - sub _register_callback { - my $self = shift or return; - my %hash = @_; - - my ($name,$code); - my $tmpl = { - name => { required => 1, store => \$name, - allow => [$callback->ls_accessors] }, - code => { required => 1, allow => IS_CODEREF, - store => \$code }, - }; - - check( $tmpl, \%hash ) or return; - - $self->_callbacks->$name( $code ) or return; - - return 1; - } - -# =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF ); -# -# Adds a new callback to be used from anywhere in the system. If the callback -# is already known, an error is raised and false is returned. If the callback -# is not yet known, it is added, and the corresponding coderef is registered -# using the -# -# =cut -# -# sub _add_callback { -# my $self = shift or return; -# my %hash = @_; -# -# my ($name,$code); -# my $tmpl = { -# name => { required => 1, store => \$name, }, -# code => { required => 1, allow => IS_CODEREF, -# store => \$code }, -# }; -# -# check( $tmpl, \%hash ) or return; -# -# if( $callback->can( $name ) ) { -# error(loc("Callback '%1' is already registered")); -# return; -# } -# -# $callback->mk_accessor( $name ); -# -# $self->_register_callback( name => $name, code => $code ) or return; -# -# return 1; -# } - -} - -=pod - -=head2 $bool = $internals->_add_to_includepath( directories => \@dirs ) - -Adds a list of directories to the include path. -This means they get added to C<@INC> as well as C<$ENV{PERL5LIB}>. - -Returns true on success, false on failure. - -=cut - -sub _add_to_includepath { - my $self = shift; - my %hash = @_; - - my $dirs; - my $tmpl = { - directories => { required => 1, default => [], store => \$dirs, - strict_type => 1 }, - }; - - check( $tmpl, \%hash ) or return; - - my $s = $Config{'path_sep'}; - - ### only add if it's not added yet - for my $lib (@$dirs) { - push @INC, $lib unless grep { $_ eq $lib } @INC; - # - ### it will be complaining if $ENV{PERL5LIB] is not defined (yet). - local $^W; - $ENV{'PERL5LIB'} .= $s . $lib - unless $ENV{'PERL5LIB'} =~ qr|\Q$s$lib\E|; - } - - return 1; -} - -=pod - -=head2 $bool = $internals->_add_to_path( directories => \@dirs ) - -Adds a list of directories to the PATH, but only if they actually -contain anything. - -Returns true on success, false on failure. - -=cut - -sub _add_to_path { - my $self = shift; - my %hash = @_; - - my $dirs; - my $tmpl = { - directories => { required => 1, default => [], store => \$dirs, - strict_type => 1 }, - }; - - check( $tmpl, \%hash ) or return; - - my $s = $Config{'path_sep'}; - - require File::Glob; - - ### only add if it's not added yet - for my $dir (@$dirs) { - $dir =~ s![\\/]*$!!g; - next if $ENV{PATH} =~ qr|\Q$dir\E|; - next unless -d $dir; - next unless File::Glob::bsd_glob( $dir . q{/*} ); - $ENV{PATH} = join $s, $dir, $ENV{PATH}; - } - - return 1; -} - -=pod - -=head2 $id = CPANPLUS::Internals->_last_id - -Return the id of the last object stored. - -=head2 $id = CPANPLUS::Internals->_store_id( $internals ) - -Store this object; return its id. - -=head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID ) - -Retrieve an object based on its ID -- return false on error. - -=head2 CPANPLUS::Internals->_remove_id( $ID ) - -Remove the object marked by $ID from storage. - -=head2 @objs = CPANPLUS::Internals->_return_all_objects - -Return all stored objects. - -=cut - - -### code for storing multiple objects -### -- although we only support one right now -### XXX when support for multiple objects comes, saving source will have -### to change -{ - my $idref = {}; - my $count = 0; - - sub _inc_id { return ++$count; } - - sub _last_id { $count } - - sub _store_id { - my $self = shift; - my $obj = shift or return; - - unless( IS_INTERNALS_OBJ->($obj) ) { - error( loc("The object you passed has the wrong ref type: '%1'", - ref $obj) ); - return; - } - - $idref->{ $obj->_id } = $obj; - return $obj->_id; - } - - sub _retrieve_id { - my $self = shift; - my $id = shift or return; - - my $obj = $idref->{$id}; - return $obj; - } - - sub _remove_id { - my $self = shift; - my $id = shift or return; - - return delete $idref->{$id}; - } - - sub _return_all_objects { return values %$idref } -} - -1; - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants.pm deleted file mode 100644 index 09501c78e8..0000000000 --- a/cpan/CPANPLUS/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/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants/Report.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants/Report.pm deleted file mode 100644 index dc92ec6c31..0000000000 --- a/cpan/CPANPLUS/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/cpan/CPANPLUS/lib/CPANPLUS/Internals/Extract.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Extract.pm deleted file mode 100644 index 4028aacfa7..0000000000 --- a/cpan/CPANPLUS/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/cpan/CPANPLUS/lib/CPANPLUS/Internals/Fetch.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Fetch.pm deleted file mode 100644 index 098d1e3761..0000000000 --- a/cpan/CPANPLUS/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/cpan/CPANPLUS/lib/CPANPLUS/Internals/Report.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Report.pm deleted file mode 100644 index c5892f93bb..0000000000 --- a/cpan/CPANPLUS/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/cpan/CPANPLUS/lib/CPANPLUS/Internals/Search.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Search.pm deleted file mode 100644 index 2a99dbfde3..0000000000 --- a/cpan/CPANPLUS/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/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source.pm deleted file mode 100644 index 8f8ad7bd4c..0000000000 --- a/cpan/CPANPLUS/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/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/Memory.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/Memory.pm deleted file mode 100644 index a28532e02c..0000000000 --- a/cpan/CPANPLUS/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/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/SQLite.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/SQLite.pm deleted file mode 100644 index 50f82f485c..0000000000 --- a/cpan/CPANPLUS/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/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm deleted file mode 100644 index b44b04bd58..0000000000 --- a/cpan/CPANPLUS/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/cpan/CPANPLUS/lib/CPANPLUS/Internals/Utils.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Utils.pm deleted file mode 100644 index 58ece81ee6..0000000000 --- a/cpan/CPANPLUS/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/cpan/CPANPLUS/lib/CPANPLUS/Internals/Utils/Autoflush.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Utils/Autoflush.pm deleted file mode 100644 index 8aa9030dfa..0000000000 --- a/cpan/CPANPLUS/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; diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Module.pm b/cpan/CPANPLUS/lib/CPANPLUS/Module.pm deleted file mode 100644 index 4eda894629..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Module.pm +++ /dev/null @@ -1,1839 +0,0 @@ -package CPANPLUS::Module; -use deprecate; - -use strict; -use vars qw[@ISA $VERSION]; -$VERSION = "0.9135"; - -use CPANPLUS::Dist; -use CPANPLUS::Error; -use CPANPLUS::Module::Signature; -use CPANPLUS::Module::Checksums; -use CPANPLUS::Internals::Constants; - -use FileHandle; - -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; -use IPC::Cmd qw[can_run run]; -use File::Find qw[find]; -use Params::Check qw[check]; -use File::Basename qw[dirname]; -use Module::Load::Conditional qw[can_load check_install]; - -$Params::Check::VERBOSE = 1; - -@ISA = qw[ CPANPLUS::Module::Signature CPANPLUS::Module::Checksums]; - -=pod - -=head1 NAME - -CPANPLUS::Module - CPAN module objects for CPANPLUS - -=head1 SYNOPSIS - - ### get a module object from the CPANPLUS::Backend object - my $mod = $cb->module_tree('Some::Module'); - - ### accessors - $mod->version; - $mod->package; - - ### methods - $mod->fetch; - $mod->extract; - $mod->install; - - -=head1 DESCRIPTION - -C<CPANPLUS::Module> creates objects from the information in the -source files. These can then be used to query and perform actions -on, like fetching or installing. - -These objects should only be created internally. For C<fake> objects, -there's the C<CPANPLUS::Module::Fake> class. To obtain a module object -consult the C<CPANPLUS::Backend> documentation. - -=cut - -my $tmpl = { - module => { default => '', required => 1 }, # full module name - version => { default => '0.0' }, # version number - path => { default => '', required => 1 }, # extended path on the - # cpan mirror, like - # /author/id/K/KA/KANE - comment => { default => ''}, # comment on module - package => { default => '', required => 1 }, # package name, like - # 'bar-baz-1.03.tgz' - description => { default => '' }, # description of the - # module - dslip => { default => EMPTY_DSLIP }, # dslip information - _id => { required => 1 }, # id of the Internals - # parent object - _status => { no_override => 1 }, # stores status object - author => { default => '', required => 1, - allow => IS_AUTHOBJ }, # module author - mtime => { default => '' }, -}; - -### some of these will be resolved by wrapper functions that -### do Clever Things to find the actual value, so don't create -### an autogenerated sub for that just here, take an alternate -### name to allow for a wrapper -{ my %rename = ( - dslip => '_dslip' - ); - - ### autogenerate accessors ### - for my $key ( keys %$tmpl ) { - no strict 'refs'; - - my $sub = $rename{$key} || $key; - - *{__PACKAGE__."::$sub"} = sub { - $_[0]->{$key} = $_[1] if @_ > 1; - return $_[0]->{$key}; - } - } -} - - -=pod - -=head1 CLASS METHODS - -=head2 accessors () - -Returns a list of all accessor methods to the object - -=cut - -### *name is an alias, include it explicitly -sub accessors { return ('name', keys %$tmpl) }; - -=head1 ACCESSORS - -An objects of this class has the following accessors: - -=over 4 - -=item name - -Name of the module. - -=item module - -Name of the module. - -=item version - -Version of the module. Defaults to '0.0' if none was provided. - -=item path - -Extended path on the mirror. - -=item comment - -Any comment about the module -- largely unused. - -=item package - -The name of the package. - -=item description - -Description of the module -- only registered modules have this. - -=item dslip - -The five character dslip string, that represents meta-data of the -module -- again, only registered modules have this. - -=cut - -sub dslip { - my $self = shift; - - ### if this module has relevant dslip info, return it - return $self->_dslip if $self->_dslip ne EMPTY_DSLIP; - - ### if not, look at other modules in the same package, - ### see if *they* have any dslip info - for my $mod ( $self->contains ) { - return $mod->_dslip if $mod->_dslip ne EMPTY_DSLIP; - } - - ### ok, really no dslip info found, return the default - return EMPTY_DSLIP; -} - - -=pod - -=item status - -The C<CPANPLUS::Module::Status> object associated with this object. -(see below). - -=item author - -The C<CPANPLUS::Module::Author> object associated with this object. - -=item parent - -The C<CPANPLUS::Internals> object that spawned this module object. - -=back - -=cut - -### Alias ->name to ->module, for human beings. -*name = *module; - -sub parent { - my $self = shift; - my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id ); - - return $obj; -} - -=head1 STATUS ACCESSORS - -C<CPANPLUS> caches a lot of results from method calls and saves data -it collected along the road for later reuse. - -C<CPANPLUS> uses this internally, but it is also available for the end -user. You can get a status object by calling: - - $modobj->status - -You can then query the object as follows: - -=over 4 - -=item installer_type - -The installer type used for this distribution. Will be one of -'makemaker' or 'build'. This determines whether C<CPANPLUS::Dist::MM> -or C<CPANPLUS::Dist::Build> will be used to build this distribution. - -=item dist_cpan - -The dist object used to do the CPAN-side of the installation. Either -a C<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build> object. - -=item dist - -The custom dist object used to do the operating specific side of the -installation, if you've chosen to use this. For example, if you've -chosen to install using the C<ports> format, this may be a -C<CPANPLUS::Dist::Ports> object. - -Undefined if you didn't specify a separate format to install through. - -=item prereqs | requires - -A hashref of prereqs this distribution was found to have. Will look -something like this: - - { Carp => 0.01, strict => 0 } - -Might be undefined if the distribution didn't have any prerequisites. - -=item configure_requires - -Like prereqs, but these are necessary to be installed before the -build process can even begin. - -=item signature - -Flag indicating, if a signature check was done, whether it was OK or -not. - -=item extract - -The directory this distribution was extracted to. - -=item fetch - -The location this distribution was fetched to. - -=item readme - -The text of this distributions README file. - -=item uninstall - -Flag indicating if an uninstall call was done successfully. - -=item created - -Flag indicating if the C<create> call to your dist object was done -successfully. - -=item installed - -Flag indicating if the C<install> call to your dist object was done -successfully. - -=item checksums - -The location of this distributions CHECKSUMS file. - -=item checksum_ok - -Flag indicating if the checksums check was done successfully. - -=item checksum_value - -The checksum value this distribution is expected to have - -=back - -=head1 METHODS - -=head2 $self = CPANPLUS::Module->new( OPTIONS ) - -This method returns a C<CPANPLUS::Module> object. Normal users -should never call this method directly, but instead use the -C<CPANPLUS::Backend> to obtain module objects. - -This example illustrates a C<new()> call with all required arguments: - - CPANPLUS::Module->new( - module => 'Foo', - path => 'authors/id/A/AA/AAA', - package => 'Foo-1.0.tgz', - author => $author_object, - _id => INTERNALS_OBJECT_ID, - ); - -Every accessor is also a valid option to pass to C<new>. - -Returns a module object on success and false on failure. - -=cut - - -sub new { - my($class, %hash) = @_; - - ### 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; - - my $object = check( $tmpl, \%hash ) or return; - - bless $object, $class; - - return $object; -} - -### only create status objects when they're actually asked for -sub status { - my $self = shift; - return $self->_status if $self->_status; - - my $acc = Object::Accessor->new; - $acc->mk_accessors( qw[ installer_type dist_cpan dist prereqs - signature extract fetch readme uninstall - created installed prepared checksums files - checksum_ok checksum_value _fetch_from - configure_requires - ] ); - - ### create an alias from 'requires' to 'prereqs', so it's more in - ### line with 'configure_requires'; - $acc->mk_aliases( requires => 'prereqs' ); - - $self->_status( $acc ); - - return $self->_status; -} - - -### flush the cache of this object ### -sub _flush { - my $self = shift; - $self->status->mk_flush; - return 1; -} - -=head2 $mod->package_name( [$package_string] ) - -Returns the name of the package a module is in. For C<Acme::Bleach> -that might be C<Acme-Bleach>. - -=head2 $mod->package_version( [$package_string] ) - -Returns the version of the package a module is in. For a module -in the package C<Acme-Bleach-1.1.tar.gz> this would be C<1.1>. - -=head2 $mod->package_extension( [$package_string] ) - -Returns the suffix added by the compression method of a package a -certain module is in. For a module in C<Acme-Bleach-1.1.tar.gz>, this -would be C<tar.gz>. - -=head2 $mod->package_is_perl_core - -Returns a boolean indicating of the package a particular module is in, -is actually a core perl distribution. - -=head2 $mod->module_is_supplied_with_perl_core( [version => $]] ) - -Returns a boolean indicating whether C<ANY VERSION> of this module -was supplied with the current running perl's core package. - -=head2 $mod->is_bundle - -Returns a boolean indicating if the module you are looking at, is -actually a bundle. Bundles are identified as modules whose name starts -with C<Bundle::>. - -=head2 $mod->is_autobundle; - -Returns a boolean indicating if the module you are looking at, is -actually an autobundle as generated by C<< $cb->autobundle >>. - -=head2 $mod->is_third_party - -Returns a boolean indicating whether the package is a known third-party -module (i.e. it's not provided by the standard Perl distribution and -is not available on the CPAN, but on a third party software provider). -See L<Module::ThirdParty> for more details. - -=head2 $mod->third_party_information - -Returns a reference to a hash with more information about a third-party -module. See the documentation about C<module_information()> in -L<Module::ThirdParty> for more details. - -=cut - -{ ### fetches the test reports for a certain module ### - my %map = ( - name => 0, - version => 1, - extension => 2, - ); - - while ( my($type, $index) = each %map ) { - my $name = 'package_' . $type; - - no strict 'refs'; - *$name = sub { - my $self = shift; - my $val = shift || $self->package; - my @res = $self->parent->_split_package_string( package => $val ); - - ### return the corresponding index from the result - return $res[$index] if @res; - return; - }; - } - - sub package_is_perl_core { - my $self = shift; - my $cb = $self->parent; - - ### check if the package looks like a perl core package - return 1 if $self->package_name eq PERL_CORE; - - ### address #44562: ::Module->package_is_perl_code : problem comparing - ### version strings -- use $cb->_vcmp to avoid warnings when version - ### have _ in them - - my $core = $self->module_is_supplied_with_perl_core; - ### ok, so it's found in the core, BUT it could be dual-lifed - if (defined $core) { - ### if the package is newer than installed, then it's dual-lifed - return if $cb->_vcmp($self->version, $self->installed_version) > 0; - - ### if the package is newer or equal to the corelist, - ### then it's dual-lifed - return if $cb->_vcmp( $self->version, $core ) >= 0; - - ### otherwise, it's older than corelist, thus unsuitable. - return 1; - } - - ### not in corelist, not a perl core package. - return; - } - - sub module_is_supplied_with_perl_core { - my $self = shift; - my $ver = shift || $]; - - ### allow it to be called as a package function as well like: - ### CPANPLUS::Module::module_is_supplied_with_perl_core('Config') - ### so that we can check the status of modules that aren't released - ### to CPAN, but are part of the core. - my $name = ref $self ? $self->module : $self; - - ### check Module::CoreList to see if it's a core package - require Module::CoreList; - - ### Address #41157: Module::module_is_supplied_with_perl_core() - ### broken for perl 5.10: Module::CoreList's version key for the - ### hash has a different number of trailing zero than $] aka - ### $PERL_VERSION. - - my $core; - - if ( exists $Module::CoreList::version{ 0+$ver }->{ $name } ) { - $core = $Module::CoreList::version{ 0+$ver }->{ $name }; - $core = 0 unless $core; - } - return $core; - } - - ### make sure Bundle-Foo also gets flagged as bundle - sub is_bundle { - my $self = shift; - - ### cpan'd bundle - return 1 if $self->module =~ /^bundle(?:-|::)/i; - - ### autobundle - return 1 if $self->is_autobundle; - - ### neither - return; - } - - ### full path to a generated autobundle - sub is_autobundle { - my $self = shift; - my $conf = $self->parent->configure_object; - my $prefix = $conf->_get_build('autobundle_prefix'); - - return 1 if $self->module eq $prefix; - return; - } - - sub is_third_party { - my $self = shift; - - return unless can_load( modules => { 'Module::ThirdParty' => 0 } ); - - return Module::ThirdParty::is_3rd_party( $self->name ); - } - - sub third_party_information { - my $self = shift; - - return unless $self->is_third_party; - - return Module::ThirdParty::module_information( $self->name ); - } -} - -=pod - -=head2 $clone = $self->clone - -Clones the current module object for tinkering with. -It will have a clean C<CPANPLUS::Module::Status> object, as well as -a fake C<CPANPLUS::Module::Author> object. - -=cut - -{ ### accessors dont change during run time, so only compute once - my @acc = grep !/status/, __PACKAGE__->accessors(); - - sub clone { - my $self = shift; - - ### clone the object ### - my %data = map { $_ => $self->$_ } @acc; - - my $obj = CPANPLUS::Module::Fake->new( %data ); - - return $obj; - } -} - -=pod - -=head2 $where = $self->fetch - -Fetches the module from a CPAN mirror. -Look at L<CPANPLUS::Internals::Fetch::_fetch()> for details on the -options you can pass. - -=cut - -sub fetch { - my $self = shift; - my $cb = $self->parent; - - ### custom args - my %args = ( module => $self ); - - ### if a custom fetch location got specified before, add that here - $args{fetch_from} = $self->status->_fetch_from - if $self->status->_fetch_from; - - my $where = $cb->_fetch( @_, %args ) or return; - - ### do an md5 check ### - if( !$self->status->_fetch_from and - $cb->configure_object->get_conf('md5') and - $self->package ne CHECKSUMS - ) { - unless( $self->_validate_checksum ) { - error( loc( "Checksum error for '%1' -- will not trust package", - $self->package) ); - return; - } - } - - return $where; -} - -=pod - -=head2 $path = $self->extract - -Extracts the fetched module. -Look at L<CPANPLUS::Internals::Extract::_extract()> for details on -the options you can pass. - -=cut - -sub extract { - my $self = shift; - my $cb = $self->parent; - - unless( $self->status->fetch ) { - error( loc( "You have not fetched '%1' yet -- cannot extract", - $self->module) ); - return; - } - - ### can't extract these, so just use the basedir for the file - if( $self->is_autobundle ) { - - ### this is expected to be set after an extract call - $self->get_installer_type; - - return $self->status->extract( dirname( $self->status->fetch ) ); - } - - return $cb->_extract( @_, module => $self ); -} - -=head2 $type = $self->get_installer_type([prefer_makefile => BOOL]) - -Gets the installer type for this module. This may either be C<build> or -C<makemaker>. If C<Module::Build> is unavailable or no installer type -is available, it will fall back to C<makemaker>. If both are available, -it will pick the one indicated by your config, or by the -C<prefer_makefile> option you can pass to this function. - -Returns the installer type on success, and false on error. - -=cut - -sub get_installer_type { - my $self = shift; - my $cb = $self->parent; - my $conf = $cb->configure_object; - my %hash = @_; - - my ($prefer_makefile,$verbose); - my $tmpl = { - prefer_makefile => { default => $conf->get_conf('prefer_makefile'), - store => \$prefer_makefile, allow => BOOLEANS }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - }; - - check( $tmpl, \%hash ) or return; - - my $type; - - ### autobundles use their own installer, so return that - if( $self->is_autobundle ) { - $type = INSTALLER_AUTOBUNDLE; - - } else { - my $extract = $self->status->extract(); - unless( $extract ) { - error(loc( - "Cannot determine installer type of unextracted module '%1'", - $self->module - )); - return; - } - - ### check if it's a makemaker or a module::build type dist ### - my $found_build = -e BUILD_PL->( $extract ); - my $found_makefile = -e MAKEFILE_PL->( $extract ); - - $type = INSTALLER_BUILD if !$prefer_makefile && $found_build; - $type = INSTALLER_BUILD if $found_build && !$found_makefile; - $type = INSTALLER_MM if $prefer_makefile && $found_makefile; - $type = INSTALLER_MM if $found_makefile && !$found_build; - # Special case Module::Build to always use INSTALLER_MM - $type = INSTALLER_MM if $self->package =~ m{^Module-Build-\d}; - - } - - ### ok, so it's a 'build' installer, but you don't /have/ module build - ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow? - if( $type and $type eq INSTALLER_BUILD and ( - not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD ) - or not $cb->module_tree( INSTALLER_BUILD ) - ->is_uptodate( version => '0.60' ) - ) ) { - - ### XXX this is for recording purposes only. We *have* to install - ### these before even creating a dist object, or we'll get an error - ### saying 'no such dist type'; - ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow? - my $href = $self->status->configure_requires || {}; - my $deps = { INSTALLER_BUILD, '0.60', %$href }; - - $self->status->configure_requires( $deps ); - - msg(loc("This module requires '%1' and '%2' to be installed first. ". - "Adding these modules to your prerequisites list", - 'Module::Build', INSTALLER_BUILD - ), $verbose ); - - - ### ok, actually we found neither ### - } elsif ( !$type ) { - error( loc( "Unable to find '%1' or '%2' for '%3'; ". - "Will default to '%4' but might be unable ". - "to install!", BUILD_PL->(), MAKEFILE_PL->(), - $self->module, INSTALLER_MM ) ); - $type = INSTALLER_MM; - } - - return $self->status->installer_type( $type ) if $type; - return; -} - -=pod - -=head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]); - -Create a distribution object, ready to be installed. -Distribution type defaults to your config settings - -The optional C<args> hashref is passed on to the specific distribution -types' C<create> method after being dereferenced. - -Returns a distribution object on success, false on failure. - -See C<CPANPLUS::Dist> for details. - -=cut - -sub dist { - my $self = shift; - my $cb = $self->parent; - my $conf = $cb->configure_object; - my %hash = @_; - - ### have you determined your installer type yet? if not, do it here, - ### we need the info - $self->get_installer_type unless $self->status->installer_type; - - my($type,$args,$target); - my $tmpl = { - format => { default => $conf->get_conf('dist_type') || - $self->status->installer_type, - store => \$type }, - target => { default => TARGET_CREATE, store => \$target }, - args => { default => {}, store => \$args }, - }; - - check( $tmpl, \%hash ) or return; - - ### ok, check for $type. Do we have it? - unless( CPANPLUS::Dist->has_dist_type( $type ) ) { - - ### ok, we don't have it. Is it C::D::Build? if so we can install the - ### whole thing now - ### XXX we _could_ do this for any type we dont have actually... - if( $type eq INSTALLER_BUILD ) { - msg(loc("Bootstrapping installer '%1'", $type)); - - ### don't propagate the format, it's the one we're trying to - ### bootstrap, so it'll be an infinite loop if we do - - $cb->module_tree( $type )->install( target => $target, %$args ) or - do { - error(loc("Could not bootstrap installer '%1' -- ". - "can not continue", $type)); - return; - }; - - ### re-scan for available modules now - CPANPLUS::Dist->rescan_dist_types; - - unless( CPANPLUS::Dist->has_dist_type( $type ) ) { - error(loc("Newly installed installer type '%1' should be ". - "available, but is not! -- aborting", $type)); - return; - } else { - msg(loc("Installer '%1' successfully bootstrapped", $type)); - } - - ### some other plugin you dont have. Abort - } else { - error(loc("Installer type '%1' not found. Please verify your ". - "installation -- aborting", $type )); - return; - } - } - - ### make sure we don't overwrite it, just in case we came - ### back from a ->save_state. This allows restoration to - ### work correctly - my( $dist, $dist_cpan ); - - unless( $dist = $self->status->dist ) { - $dist = $type->new( module => $self ) or return; - $self->status->dist( $dist ); - } - - unless( $dist_cpan = $self->status->dist_cpan ) { - - $dist_cpan = $type eq $self->status->installer_type - ? $self->status->dist - : $self->status->installer_type->new( module => $self ); - - - $self->status->dist_cpan( $dist_cpan ); - } - - - DIST: { - ### just wanted the $dist object? - last DIST if $target eq TARGET_INIT; - - ### first prepare the dist - $dist->prepare( %$args ) or return; - $self->status->prepared(1); - - ### you just wanted us to prepare? - last DIST if $target eq TARGET_PREPARE; - - $dist->create( %$args ) or return; - $self->status->created(1); - } - - return $dist; -} - -=pod - -=head2 $bool = $mod->prepare( ) - -Convenience method around C<install()> that prepares a module -without actually building it. This is equivalent to invoking C<install> -with C<target> set to C<prepare> - -Returns true on success, false on failure. - -=cut - -sub prepare { - my $self = shift; - return $self->install( @_, target => TARGET_PREPARE ); -} - -=head2 $bool = $mod->create( ) - -Convenience method around C<install()> that creates a module. -This is equivalent to invoking C<install> with C<target> set to -C<create> - -Returns true on success, false on failure. - -=cut - -sub create { - my $self = shift; - return $self->install( @_, target => TARGET_CREATE ); -} - -=head2 $bool = $mod->test( ) - -Convenience wrapper around C<install()> that tests a module, without -installing it. -It's the equivalent to invoking C<install()> with C<target> set to -C<create> and C<skiptest> set to C<0>. - -Returns true on success, false on failure. - -=cut - -sub test { - my $self = shift; - return $self->install( @_, target => TARGET_CREATE, skiptest => 0 ); -} - -=pod - -=head2 $bool = $self->install([ target => 'init|prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]); - -Installs the current module. This includes fetching it and extracting -it, if this hasn't been done yet, as well as creating a distribution -object for it. - -This means you can pass it more arguments than described above, which -will be passed on to the relevant methods as they are called. - -See C<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and -C<CPANPLUS::Dist> for details. - -Returns true on success, false on failure. - -=cut - -sub install { - my $self = shift; - my $cb = $self->parent; - my $conf = $cb->configure_object; - my %hash = @_; - - my $args; my $target; my $format; - { ### so we can use the rest of the args to the create calls etc ### - local $Params::Check::NO_DUPLICATES = 1; - local $Params::Check::ALLOW_UNKNOWN = 1; - - ### targets 'dist' and 'test' are now completely ignored ### - my $tmpl = { - ### match this allow list with Dist->_resolve_prereqs - target => { default => TARGET_INSTALL, store => \$target, - allow => [TARGET_PREPARE, TARGET_CREATE, - TARGET_INSTALL, TARGET_INIT ] }, - force => { default => $conf->get_conf('force'), }, - verbose => { default => $conf->get_conf('verbose'), }, - format => { default => $conf->get_conf('dist_type'), - store => \$format }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - - ### if this target isn't 'install', we will need to at least 'create' - ### every prereq, so it can build - ### XXX prereq_target of 'prepare' will do weird things here, and is - ### not supported. - $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL; - - ### check if it's already upto date ### - if( $target eq TARGET_INSTALL and !$args->{'force'} and - !$self->package_is_perl_core() and # separate rules apply - ( $self->status->installed() or $self->is_uptodate ) and - !INSTALL_VIA_PACKAGE_MANAGER->($format) - ) { - msg(loc("Module '%1' already up to date, won't install without force", - $self->module), $args->{'verbose'} ); - return $self->status->installed(1); - } - - # if it's a non-installable core package, abort the install. - if( $self->package_is_perl_core() ) { - # if the installed is newer, say so. - if( $self->installed_version > $self->version ) { - error(loc("The core Perl %1 module '%2' (%3) is more ". - "recent than the latest release on CPAN (%4). ". - "Aborting install.", - $], $self->module, $self->installed_version, - $self->version ) ); - # if the installed matches, say so. - } elsif( $self->installed_version == $self->version ) { - error(loc("The core Perl %1 module '%2' (%3) can only ". - "be installed by Perl itself. ". - "Aborting install.", - $], $self->module, $self->installed_version ) ); - # otherwise, the installed is older; say so. - } else { - error(loc("The core Perl %1 module '%2' can only be ". - "upgraded from %3 to %4 by Perl itself (%5). ". - "Aborting install.", - $], $self->module, $self->installed_version, - $self->version, $self->package ) ); - } - return; - - ### it might be a known 3rd party module - } elsif ( $self->is_third_party ) { - my $info = $self->third_party_information; - error(loc( - "%1 is a known third-party module.\n\n". - "As it isn't available on the CPAN, CPANPLUS can't install " . - "it automatically. Therefore you need to install it manually " . - "before proceeding.\n\n". - "%2 is part of %3, published by %4, and should be available ". - "for download at the following address:\n\t%5", - $self->name, $self->name, $info->{name}, $info->{author}, - $info->{url} - )); - - return; - } - - ### fetch it if need be ### - unless( $self->status->fetch ) { - my $params; - for (qw[prefer_bin fetchdir]) { - $params->{$_} = $args->{$_} if exists $args->{$_}; - } - for (qw[force verbose]) { - $params->{$_} = $args->{$_} if defined $args->{$_}; - } - $self->fetch( %$params ) or return; - } - - ### extract it if need be ### - unless( $self->status->extract ) { - my $params; - for (qw[prefer_bin extractdir]) { - $params->{$_} = $args->{$_} if exists $args->{$_}; - } - for (qw[force verbose]) { - $params->{$_} = $args->{$_} if defined $args->{$_}; - } - $self->extract( %$params ) or return; - } - - $args->{'prereq_format'} = $format if $format; - $format ||= $self->status->installer_type; - - unless( $format ) { - error( loc( "Don't know what installer to use; " . - "Couldn't find either '%1' or '%2' in the extraction " . - "directory '%3' -- will be unable to install", - BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) ); - - $self->status->installed(0); - return; - } - - - ### do SIGNATURE checks? ### - ### XXX check status and not recheck EVERY time? - if( $conf->get_conf('signature') ) { - unless( $self->check_signature( verbose => $args->{verbose} ) ) { - error( loc( "Signature check failed for module '%1' ". - "-- Not trusting this module, aborting install", - $self->module ) ); - $self->status->signature(0); - - ### send out test report on broken sig - if( $conf->get_conf('cpantest') ) { - $cb->_send_report( - module => $self, - failed => 1, - buffer => CPANPLUS::Error->stack_as_string, - verbose => $args->{verbose}, - force => $args->{force}, - ) or error(loc("Failed to send test report for '%1'", - $self->module ) ); - } - - return; - - } else { - ### signature OK ### - $self->status->signature(1); - } - } - - ### a target of 'create' basically means not to run make test ### - ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1. - #$args->{'skiptest'} = 1 if $target eq 'create'; - - ### bundle rules apply ### - if( $self->is_bundle ) { - ### check what we need to install ### - my @prereqs = $self->bundle_modules(); - unless( @prereqs ) { - error( loc( "Bundle '%1' does not specify any modules to install", - $self->module ) ); - - ### XXX mark an error here? ### - } - } - - my $dist = $self->dist( format => $format, - target => $target, - args => $args ); - unless( $dist ) { - error( loc( "Unable to create a new distribution object for '%1' " . - "-- cannot continue", $self->module ) ); - return; - } - - return 1 if $target ne TARGET_INSTALL; - - my $ok = $dist->install( %$args ) ? 1 : 0; - - $self->status->installed($ok); - - return 1 if $ok; - return; -} - -=pod @list = $self->bundle_modules() - -Returns a list of module objects the Bundle specifies. - -This requires you to have extracted the bundle already, using the -C<extract()> method. - -Returns false on error. - -=cut - -sub bundle_modules { - my $self = shift; - my $cb = $self->parent; - - unless( $self->is_bundle ) { - error( loc("'%1' is not a bundle", $self->module ) ); - return; - } - - my @files; - - ### autobundles are special files generated by CPANPLUS. If we can - ### read the file, we can determine the prereqs - if( $self->is_autobundle ) { - my $where; - unless( $where = $self->status->fetch ) { - error(loc("Don't know where '%1' was fetched to", $self->package)); - return; - } - - push @files, $where - - ### regular bundle::* upload - } else { - my $dir; - unless( $dir = $self->status->extract ) { - error(loc("Don't know where '%1' was extracted to", $self->module)); - return; - } - - find( { - wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i }, - no_chdir => 1, - }, $dir ); - } - - my $prereqs = {}; my @list; my $seen = {}; - for my $file ( @files ) { - my $fh = FileHandle->new($file) - or( error(loc("Could not open '%1' for reading: %2", - $file,$!)), next ); - - my $flag; - while( local $_ = <$fh> ) { - ### quick hack to read past the header of the file ### - last if $flag && m|^=head|i; - - ### from perldoc cpan: - ### =head1 CONTENTS - ### In this pod section each line obeys the format - ### Module_Name [Version_String] [- optional text] - $flag = 1 if m|^=head1 CONTENTS|i; - - if ($flag && /^(?!=)(\S+)\s*(\S+)?/) { - my $module = $1; - my $version = $cb->_version_to_number( version => $2 ); - - my $obj = $cb->module_tree($module); - - unless( $obj ) { - error(loc("Cannot find bundled module '%1'", $module), - loc("-- it does not seem to exist") ); - next; - } - - ### make sure we list no duplicates ### - unless( $seen->{ $obj->module }++ ) { - push @list, $obj; - $prereqs->{ $module } = - $cb->_version_to_number( version => $version ); - } - } - } - } - - ### store the prereqs we just found ### - $self->status->prereqs( $prereqs ); - - return @list; -} - -=pod - -=head2 $text = $self->readme - -Fetches the readme belonging to this module and stores it under -C<< $obj->status->readme >>. Returns the readme as a string on -success and returns false on failure. - -=cut - -sub readme { - my $self = shift; - my $conf = $self->parent->configure_object; - - ### did we already dl the readme once? ### - return $self->status->readme() if $self->status->readme(); - - ### this should be core ### - return unless can_load( modules => { FileHandle => '0.0' }, - verbose => 1, - ); - - ### get a clone of the current object, with a fresh status ### - my $obj = $self->clone or return; - - ### munge the package name - my $pkg = README->( $obj ); - $obj->package($pkg); - - my $file; - { ### disable checksum fetches on readme downloads - - my $tmp = $conf->get_conf( 'md5' ); - $conf->set_conf( md5 => 0 ); - - $file = $obj->fetch; - - $conf->set_conf( md5 => $tmp ); - - return unless $file; - } - - ### read the file into a scalar, to store in the original object ### - my $fh = new FileHandle; - unless( $fh->open($file) ) { - error( loc( "Could not open file '%1': %2", $file, $! ) ); - return; - } - - my $in = do{ local $/; <$fh> }; - $fh->close; - - return $self->status->readme( $in ); -} - -=pod - -=head2 $version = $self->installed_version() - -Returns the currently installed version of this module, if any. - -=head2 $where = $self->installed_file() - -Returns the location of the currently installed file of this module, -if any. - -=head2 $dir = $self->installed_dir() - -Returns the directory (or more accurately, the C<@INC> handle) from -which this module was loaded, if any. - -=head2 $bool = $self->is_uptodate([version => VERSION_NUMBER]) - -Returns a boolean indicating if this module is uptodate or not. - -=cut - -### uptodate/installed functions -{ my $map = { # hashkey, alternate rv - installed_version => ['version', 0 ], - installed_file => ['file', ''], - installed_dir => ['dir', ''], - is_uptodate => ['uptodate', 0 ], - }; - - while( my($method, $aref) = each %$map ) { - my($key,$alt_rv) = @$aref; - - no strict 'refs'; - *$method = sub { - ### 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, so this should not - ### be needed anymore - #local @INC = CPANPLUS::inc->original_inc; - - my $self = shift; - - ### make sure check_install is not looking in %INC, as - ### that may contain some of our sneakily loaded modules - ### that aren't installed as such. -- kane - local $Module::Load::Conditional::CHECK_INC_HASH = 0; - ### this should all that is required for deprecated core modules - local $Module::Load::Conditional::DEPRECATED = 1; - my $href = check_install( - module => $self->module, - version => $self->version, - @_, - ); - - ### Don't trust modules which are the result of @INC hooks - ### FatPacker uses this trickery and it causes WTF moments - return $alt_rv if defined $href->{dir} && ref $href->{dir}; - - return $href->{$key} || $alt_rv; - } - } -} - - - -=pod - -=head2 $href = $self->details() - -Returns a hashref with key/value pairs offering more information about -a particular module. For example, for C<Time::HiRes> it might look like -this: - - Author Jarkko Hietaniemi (jhi@iki.fi) - Description High resolution time, sleep, and alarm - Development Stage Released - Installed File /usr/local/perl/lib/Time/Hires.pm - Interface Style plain Functions, no references used - Language Used C and perl, a C compiler will be needed - Package Time-HiRes-1.65.tar.gz - Public License Unknown - Support Level Developer - Version Installed 1.52 - Version on CPAN 1.65 - -=cut - -sub details { - my $self = shift; - my $conf = $self->parent->configure_object(); - my $cb = $self->parent; - my %hash = @_; - - my $res = { - Author => loc("%1 (%2)", $self->author->author(), - $self->author->email() ), - Package => $self->package, - Description => $self->description || loc('None given'), - 'Version on CPAN' => $self->version, - }; - - ### check if we have the module installed - ### if so, add version have and version on cpan - $res->{'Version Installed'} = $self->installed_version - if $self->installed_version; - $res->{'Installed File'} = $self->installed_file if $self->installed_file; - - my $i = 0; - for my $item( split '', $self->dslip ) { - $res->{ $cb->_dslip_defs->[$i]->[0] } = - $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown'); - $i++; - } - - return $res; -} - -=head2 @list = $self->contains() - -Returns a list of module objects that represent the modules also -present in the package of this module. - -For example, for C<Archive::Tar> this might return: - - Archive::Tar - Archive::Tar::Constant - Archive::Tar::File - -=cut - -sub contains { - my $self = shift; - my $cb = $self->parent; - my $pkg = $self->package; - - my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] ); - - return @mods; -} - -=pod - -=head2 @list_of_hrefs = $self->fetch_report() - -This function queries the CPAN testers database at -I<http://testers.cpan.org/> for test results of specified module -objects, module names or distributions. - -Look at L<CPANPLUS::Internals::Report::_query_report()> for details on -the options you can pass and the return value to expect. - -=cut - -sub fetch_report { - my $self = shift; - my $cb = $self->parent; - - return $cb->_query_report( @_, module => $self ); -} - -=pod - -=head2 $bool = $self->uninstall([type => [all|man|prog]) - -This function uninstalls the specified module object. - -You can install 2 types of files, either C<man> pages or C<prog>ram -files. Alternately you can specify C<all> to uninstall both (which -is the default). - -Returns true on success and false on failure. - -Do note that this does an uninstall via the so-called C<.packlist>, -so if you used a module installer like say, C<ports> or C<apt>, you -should not use this, but use your package manager instead. - -=cut - -sub uninstall { - my $self = shift; - my $conf = $self->parent->configure_object(); - my %hash = @_; - - my ($type,$verbose); - my $tmpl = { - type => { default => 'all', allow => [qw|man prog all|], - store => \$type }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - force => { default => $conf->get_conf('force') }, - }; - - ### XXX add a warning here if your default install dist isn't - ### makefile or build -- that means you are using a package manager - ### and this will not do what you think! - - my $args = check( $tmpl, \%hash ) or return; - - if( $conf->get_conf('dist_type') and ( - ($conf->get_conf('dist_type') ne INSTALLER_BUILD) or - ($conf->get_conf('dist_type') ne INSTALLER_MM)) - ) { - msg(loc("You have a default installer type set (%1) ". - "-- you should probably use that package manager to " . - "uninstall modules", $conf->get_conf('dist_type')), $verbose); - } - - ### check if we even have the module installed -- no point in continuing - ### otherwise - unless( $self->installed_version ) { - error( loc( "Module '%1' is not installed, so cannot uninstall", - $self->module ) ); - return; - } - - ### nothing to uninstall ### - my $files = $self->files( type => $type ) or return; - my $dirs = $self->directory_tree( type => $type ) or return; - my $sudo = $conf->get_program('sudo'); - - ### just in case there's no file; M::B doesn't provide .packlists yet ### - my $pack = $self->packlist; - $pack = $pack->[0]->packlist_file() if $pack; - - ### first remove the files, then the dirs if they are empty ### - my $flag = 0; - for my $file( @$files, $pack ) { - next unless defined $file && -f $file; - - msg(loc("Unlinking '%1'", $file), $verbose); - - my @cmd = ($^X, "-eunlink+q[$file]"); - unshift @cmd, $sudo if $sudo; - - my $buffer; - unless ( run( command => \@cmd, - verbose => $verbose, - buffer => \$buffer ) - ) { - error(loc("Failed to unlink '%1': '%2'",$file, $buffer)); - $flag++; - } - } - - for my $dir ( sort @$dirs ) { - local *DIR; - opendir DIR, $dir or next; - my @count = readdir(DIR); - close DIR; - - next unless @count == 2; # . and .. - - msg(loc("Removing '%1'", $dir), $verbose); - - ### this fails on my win2k machines.. it indeed leaves the - ### dir, but it's not a critical error, since the files have - ### been removed. --kane - #unless( rmdir $dir ) { - # error( loc( "Could not remove '%1': %2", $dir, $! ) ) - # unless $^O eq 'MSWin32'; - #} - - my @cmd = ($^X, "-e", "rmdir q[$dir]"); - unshift @cmd, $sudo if $sudo; - - my $buffer; - unless ( run( command => \@cmd, - verbose => $verbose, - buffer => \$buffer ) - ) { - error(loc("Failed to rmdir '%1': %2",$dir,$buffer)); - $flag++; - } - } - - $self->status->uninstall(!$flag); - $self->status->installed( $flag ? 1 : undef); - - return !$flag; -} - -=pod - -=head2 @modobj = $self->distributions() - -Returns a list of module objects representing all releases for this -module on success, false on failure. - -=cut - -sub distributions { - my $self = shift; - my %hash = @_; - - my @list = $self->author->distributions( %hash, module => $self ) or return; - - ### it's another release then by the same author ### - return grep { $_->package_name eq $self->package_name } @list; -} - -=pod - -=head2 @list = $self->files () - -Returns a list of files used by this module, if it is installed. - -=head2 @list = $self->directory_tree () - -Returns a list of directories used by this module. - -=head2 @list = $self->packlist () - -Returns the C<ExtUtils::Packlist> object for this module. - -=head2 @list = $self->validate () - -Returns a list of files that are missing for this modules, but -are present in the .packlist file. - -=cut - -for my $sub (qw[files directory_tree packlist validate]) { - no strict 'refs'; - *$sub = sub { - return shift->_extutils_installed( @_, method => $sub ); - } -} - -### generic method to call an ExtUtils::Installed method ### -sub _extutils_installed { - my $self = shift; - my $cb = $self->parent; - my $conf = $cb->configure_object; - my $home = $cb->_home_dir; # may be needed to fix up prefixes - my %hash = @_; - - my ($verbose,$type,$method); - my $tmpl = { - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose, }, - type => { default => 'all', - allow => [qw|prog man all|], - store => \$type, }, - method => { required => 1, - store => \$method, - allow => [qw|files directory_tree packlist - validate|], - }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - ### old versions of cygwin + perl < 5.8 are buggy here. bail out if we - ### find we're being used by them - { my $err = ON_OLD_CYGWIN; - if($err) { error($err); return }; - } - - return unless can_load( - modules => { 'ExtUtils::Installed' => '0.0' }, - verbose => $verbose, - ); - - my @config_names = ( - ### lib - { lib => 'privlib', # perl-only - arch => 'archlib', # compiled code - prefix => 'prefix', # prefix to both - }, - ### site - { lib => 'sitelib', - arch => 'sitearch', - prefix => 'siteprefix', - }, - ### vendor - { lib => 'vendorlib', - arch => 'vendorarch', - prefix => 'vendorprefix', - }, - ); - - ### search in your regular @INC, and anything you added to your config. - ### this lets EU::Installed find .packlists that are *not* in the standard - ### compiled in @INC path. Requires EU::I 1.42 or up. this addresses #33438 - ### make sure the archname path is also added, as that's where the .packlist - ### files are written - my @libs; - for my $lib ( @{ $conf->get_conf('lib') } ) { - require Config; - - ### and just the standard dir - push @libs, $lib; - - ### figure out what an MM prefix expands to. Basically, it's the - ### site install target from %Config, ie: /opt/lib/perl5/site_perl/5.8.8 - ### minus the site wide prefix, ie: /opt - ### this lets users add the dir they have set as their EU::MM PREFIX - ### to our 'lib' config and it Just Works - ### the arch specific dir, ie: - ### /opt/lib/perl5/site_perl/5.8.8/darwin-2level - ### XXX is this the right thing to do? - - ### we add all 6 dir combos for prefixes: - ### /foo/lib - ### /foo/lib/arch - ### /foo/site/lib - ### /foo/site/lib/arch - ### /foo/vendor/lib - ### /foo/vendor/lib/arch - for my $href ( @config_names ) { - for my $key ( qw[lib arch] ) { - - ### look up the config value -- use EXP for the EXPANDED - ### version, so no ~ etc are found in there - my $dir = $Config::Config{ $href->{ $key } .'exp' } or next; - my $prefix = $Config::Config{ $href->{prefix} }; - - ### prefix may be relative to home, and contain a ~ - ### if so, fix it up. - $prefix =~ s/^~/$home/; - - ### remove the prefix from it, so we can append to our $lib - $dir =~ s/^\Q$prefix\E//; - - ### do the appending - push @libs, File::Spec->catdir( $lib, $dir ); - - } - } - } - - my $inst; - unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) { - error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) ); - - ### in case it's being used directly... ### - return; - } - - - { ### EU::Installed can die =/ - my @files; - eval { @files = $inst->$method( $self->module, $type ) }; - - if( $@ ) { - chomp $@; - error( loc("Could not get '%1' for '%2': %3", - $method, $self->module, $@ ) ); - return; - } - - return wantarray ? @files : \@files; - } -} - -=head2 $bool = $self->add_to_includepath; - -Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows -you to add the module from its build dir to your path. - -It also adds the current modules C<bin> and/or C<script> paths to -the PATH. - -You can reset C<$PATH>, C<@INC> and C<$PERL5LIB> to their original state when you -started the program, by calling: - - $self->parent->flush('lib'); - -=cut - -sub add_to_includepath { - my $self = shift; - my $cb = $self->parent; - - if( my $dir = $self->status->extract ) { - - $cb->_add_to_includepath( - directories => [ - File::Spec->catdir(BLIB->($dir), LIB), - File::Spec->catdir(BLIB->($dir), ARCH), - BLIB->($dir), - ] - ) or return; - - $cb->_add_to_path( - directories => [ - File::Spec->catdir(BLIB->($dir), SCRIPT), - File::Spec->catdir(BLIB->($dir), BIN), - ] - ) or return; - - } else { - error(loc( "No extract dir registered for '%1' -- can not add ". - "add builddir to search path!", $self->module )); - return; - } - - return 1; - -} - -=pod - -=head2 $path = $self->best_path_to_module_build(); - -B<OBSOLETE> - -If a newer version of Module::Build is found in your path, it will -return this C<special> path. If the newest version of C<Module::Build> -is found in your regular C<@INC>, the method will return false. This -indicates you do not need to add a special directory to your C<@INC>. - -Note that this is only relevant if you're building your own -C<CPANPLUS::Dist::*> plugin -- the built-in dist types already have -this taken care of. - -=cut - -### make sure we're always running 'perl Build.PL' and friends -### against the highest version of module::build available -sub best_path_to_module_build { - my $self = shift; - - ### Since M::B will actually shell out and run the Build.PL, we must - ### make sure it refinds the proper version of M::B in the path. - ### that may be either in our cp::inc or in site_perl, or even a - ### new M::B being installed. - ### don't add anything else here, as that might screw up prereq checks - - ### XXX this might be needed for Dist::MM too, if a makefile.pl is - ### masquerading as a Build.PL - - ### did we find the most recent module::build in our installer path? - - ### XXX can't do changes to @INC, they're being ignored by - ### new_from_context when writing a Build script. see ticket: - ### #8826 Module::Build ignores changes to @INC when writing Build - ### from new_from_context - ### XXX applied schwern's patches (as seen on CPANPLUS::Devel 10/12/04) - ### and upped the version to 0.26061 of the bundled version, and things - ### work again - - ### this functionality is now obsolete -- prereqs should be installed - ### and we no longer use the CPANPLUS::inc magic.. so comment this out. -# require Module::Build; -# if( CPANPLUS::inc->path_to('Module::Build') and ( -# CPANPLUS::inc->path_to('Module::Build') eq -# CPANPLUS::inc->installer_path ) -# ) { -# -# ### if the module being installed is *not* Module::Build -# ### itself -- as that would undoubtedly be newer -- add -# ### the path to the installers to @INC -# ### if it IS module::build itself, add 'lib' to its path, -# ### as the Build.PL would do as well, but the API doesn't. -# ### this makes self updates possible -# return $self->module eq 'Module::Build' -# ? 'lib' -# : CPANPLUS::inc->installer_path; -# } - - ### otherwise, the path was found through a 'normal' way of - ### scanning @INC. - return; -} - -=pod - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - -1; - -__END__ - -todo: -reports(); diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Module/Author.pm b/cpan/CPANPLUS/lib/CPANPLUS/Module/Author.pm deleted file mode 100644 index c95de4064c..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Module/Author.pm +++ /dev/null @@ -1,235 +0,0 @@ -package CPANPLUS::Module::Author; -use deprecate; - -use strict; - -use CPANPLUS::Error; -use CPANPLUS::Internals::Constants; -use Params::Check qw[check]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -local $Params::Check::VERBOSE = 1; - -=pod - -=head1 NAME - -CPANPLUS::Module::Author - CPAN author object for CPANPLUS - -=head1 SYNOPSIS - - my $author = CPANPLUS::Module::Author->new( - author => 'Jack Ashton', - cpanid => 'JACKASH', - _id => INTERNALS_OBJECT_ID, - ); - - $author->cpanid; - $author->author; - $author->email; - - @dists = $author->distributions; - @mods = $author->modules; - - @accessors = CPANPLUS::Module::Author->accessors; - -=head1 DESCRIPTION - -C<CPANPLUS::Module::Author> creates objects from the information in the -source files. These can then be used to query on. - -These objects should only be created internally. For C<fake> objects, -there's the C<CPANPLUS::Module::Author::Fake> class. - -=head1 ACCESSORS - -An objects of this class has the following accessors: - -=over 4 - -=item author - -Name of the author. - -=item cpanid - -The CPAN id of the author. - -=item email - -The email address of the author, which defaults to '' if not provided. - -=item parent - -The C<CPANPLUS::Internals::Object> that spawned this module object. - -=back - -=cut - -my $tmpl = { - author => { required => 1 }, # full name of the author - cpanid => { required => 1 }, # cpan id - email => { default => '' }, # email address of the author - _id => { required => 1 }, # id of the Internals object that spawned us -}; - -### autogenerate accessors ### -for my $key ( keys %$tmpl ) { - no strict 'refs'; - *{__PACKAGE__."::$key"} = sub { - my $self = shift; - $self->{$key} = $_[0] if @_; - return $self->{$key}; - } -} - -sub parent { - my $self = shift; - my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id ); - - return $obj; -} - -=pod - -=head1 METHODS - -=head2 $auth = CPANPLUS::Module::Author->new( author => AUTHOR_NAME, cpanid => CPAN_ID, _id => INTERNALS_ID [, email => AUTHOR_EMAIL] ) - -This method returns a C<CPANPLUS::Module::Author> object, based on the given -parameters. - -Returns false on failure. - -=cut - -sub new { - my $class = shift; - my %hash = @_; - - ### 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; - - my $object = check( $tmpl, \%hash ) or return; - - return bless $object, $class; -} - -=pod - -=head2 @mod_objs = $auth->modules() - -Return a list of module objects this author has released. - -=cut - -sub modules { - my $self = shift; - my $cb = $self->parent; - - my $aref = $cb->_search_module_tree( - type => 'author', - ### XXX, depending on backend, this is either an object - ### or the cpanid string. Don't know an elegant way to - ### solve this right now, so passing both - allow => [$self, $self->cpanid], - ); - return @$aref if $aref; - return; -} - -=pod - -=head2 @dists = $auth->distributions() - -Returns a list of module objects representing all the distributions -this author has released. - -=cut - -sub distributions { - my $self = shift; - my %hash = @_; - - local $Params::Check::ALLOW_UNKNOWN = 1; - local $Params::Check::NO_DUPLICATES = 1; - - my $mod; - my $tmpl = { - module => { default => '', store => \$mod }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - ### if we didn't get a module object passed, we'll find one ourselves ### - unless( $mod ) { - my @list = $self->modules; - if( @list ) { - $mod = $list[0]; - } else { - error( loc( "This author has released no modules" ) ); - return; - } - } - - my $file = $mod->checksums( %hash ); - my $href = $mod->_parse_checksums_file( file => $file ) or return; - - my @rv; - for my $name ( keys %$href ) { - - ### shortcut asap, so we avoid extra ops. On big checksums files - ### the call to clone() takes up a lot of time. - ### .meta files are now also in the checksums file, - ### which means we have to filter out things that dont - ### match our regex - next if $mod->package_extension( $name ) eq META_EXT; - - ### used to do this wiht ->clone. However, that calls ->dslip, - ### (which is wrong anyway, as we're doing a different module), - ### which in turn calls ->contains, which scans the entire - ### module tree using _search_module_tree, which uses P::C - ### and is therefor VERY VERY slow. - ### so let's do this the direct way for speed ups. - my $dist = CPANPLUS::Module::Fake->new( - module => do { my $m = $mod->package_name( $name ); - $m =~ s/-/::/g; $m; - }, - version => $mod->package_version( $name ), - package => $name, - path => $mod->path, # same author after all - author => $mod->author, # same author after all - mtime => $href->{$name}->{'mtime'}, # release date - ); - - push @rv, $dist; - } - - return @rv; -} - - -=pod - -=head1 CLASS METHODS - -=head2 accessors () - -Returns a list of all accessor methods to the object - -=cut - -sub accessors { return keys %$tmpl }; - -1; - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Module/Author/Fake.pm b/cpan/CPANPLUS/lib/CPANPLUS/Module/Author/Fake.pm deleted file mode 100644 index 15de66b0dc..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Module/Author/Fake.pm +++ /dev/null @@ -1,83 +0,0 @@ -package CPANPLUS::Module::Author::Fake; -use deprecate; - - -use CPANPLUS::Module::Author; -use CPANPLUS::Internals; -use CPANPLUS::Error; - -use strict; -use vars qw[@ISA $VERSION]; -use Params::Check qw[check]; - -$VERSION = "0.9135"; - -@ISA = qw[CPANPLUS::Module::Author]; - -$Params::Check::VERBOSE = 1; - -=pod - -=head1 NAME - -CPANPLUS::Module::Author::Fake - dummy author object for CPANPLUS - -=head1 SYNOPSIS - - my $auth = CPANPLUS::Module::Author::Fake->new( - author => 'Foo Bar', - email => 'luser@foo.com', - cpanid => 'FOO', - _id => $cpan->id, - ); - -=head1 DESCRIPTION - -A class for creating fake author objects, for shortcut use internally -by CPANPLUS. - -Inherits from C<CPANPLUS::Module::Author>. - -=head1 METHODS - -=head2 new( _id => DIGIT ) - -Creates a dummy author object. It can take the same options as -C<< CPANPLUS::Module::Author->new >>, but will fill in default ones -if none are provided. Only the _id key is required. - -=cut - -sub new { - my $class = shift; - my %hash = @_; - - my $tmpl = { - author => { default => 'CPANPLUS Internals' }, - email => { default => 'cpanplus-info@lists.sf.net' }, - cpanid => { default => 'CPANPLUS' }, - _id => { default => CPANPLUS::Internals->_last_id }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - my $obj = CPANPLUS::Module::Author->new( %$args ) or return; - - unless( $obj->_id ) { - error(loc("No '%1' specified -- No CPANPLUS object associated!",'_id')); - return; - } - - ### rebless object ### - return bless $obj, $class; -} - -1; - - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Module/Checksums.pm b/cpan/CPANPLUS/lib/CPANPLUS/Module/Checksums.pm deleted file mode 100644 index 51263b4d25..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Module/Checksums.pm +++ /dev/null @@ -1,260 +0,0 @@ -package CPANPLUS::Module::Checksums; -use deprecate; - -use strict; -use vars qw[@ISA $VERSION]; - -use CPANPLUS::Error; -use CPANPLUS::Internals::Constants; - -use FileHandle; - -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; -use Params::Check qw[check]; -use Module::Load::Conditional qw[can_load]; - -$Params::Check::VERBOSE = 1; - -@ISA = qw[ CPANPLUS::Module::Signature ]; -$VERSION = "0.9135"; - -=head1 NAME - -CPANPLUS::Module::Checksums - checking the checksum of a distribution - -=head1 SYNOPSIS - - $file = $modobj->checksums; - $bool = $mobobj->_validate_checksum; - -=head1 DESCRIPTION - -This is a class that provides functions for checking the checksum -of a distribution. Should not be loaded directly, but used via the -interface provided via C<CPANPLUS::Module>. - -=head1 METHODS - -=head2 $mod->checksums - -Fetches the checksums file for this module object. -For the options it can take, see C<CPANPLUS::Module::fetch()>. - -Returns the location of the checksums file on success and false -on error. - -The location of the checksums file is also stored as - - $mod->status->checksums - -=cut - -sub checksums { - my $mod = shift or return; - - my $file = $mod->_get_checksums_file( @_ ); - - return $mod->status->checksums( $file ) if $file; - - return; -} - -### checks if the package checksum matches the one -### from the checksums file -sub _validate_checksum { - my $self = shift; #must be isa CPANPLUS::Module - my $conf = $self->parent->configure_object; - my %hash = @_; - - my $verbose; - my $tmpl = { - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - }; - - check( $tmpl, \%hash ) or return; - - ### if we can't check it, we must assume it's ok ### - return $self->status->checksum_ok(1) - unless can_load( modules => { 'Digest::SHA' => '0.0' } ); - #class CPANPLUS::Module::Status is runtime-generated - - my $file = $self->_get_checksums_file( verbose => $verbose ) or ( - error(loc(q[Could not fetch '%1' file], CHECKSUMS)), return ); - - $self->_check_signature_for_checksum_file( file => $file ) or ( - error(loc(q[Could not verify '%1' file], CHECKSUMS)), return ); - #for whole CHECKSUMS file - - my $href = $self->_parse_checksums_file( file => $file ) or ( - error(loc(q[Could not parse '%1' file], CHECKSUMS)), return ); - - my $size = $href->{ $self->package }->{'size'}; - - ### the checksums file tells us the size of the archive - ### but the downloaded file is of different size - if( defined $size ) { - if( not (-s $self->status->fetch == $size) ) { - error(loc( "Archive size does not match for '%1': " . - "size is '%2' but should be '%3'", - $self->package, -s $self->status->fetch, $size)); - return $self->status->checksum_ok(0); - } - } else { - msg(loc("Archive size is not known for '%1'",$self->package),$verbose); - } - - my $sha = $href->{ $self->package }->{'sha256'}; - - unless( defined $sha ) { - msg(loc("No 'sha256' checksum known for '%1'",$self->package),$verbose); - - return $self->status->checksum_ok(1); - } - - $self->status->checksum_value($sha); - - - my $fh = FileHandle->new( $self->status->fetch ) or return; - binmode $fh; - - my $ctx = Digest::SHA->new(256); - $ctx->addfile( $fh ); - - my $hexdigest = $ctx->hexdigest; - my $flag = $hexdigest eq $sha; - $flag - ? msg(loc("Checksum matches for '%1'", $self->package),$verbose) - : error(loc("Checksum does not match for '%1': " . - "SHA256 is '%2' but should be '%3'", - $self->package, $hexdigest, $sha),$verbose); - - - return $self->status->checksum_ok(1) if $flag; - return $self->status->checksum_ok(0); -} - - -### fetches the module objects checksum file ### -sub _get_checksums_file { - my $self = shift; - my %hash = @_; - - my $clone = $self->clone; - $clone->package( CHECKSUMS ); - - # If the user specified a fetchdir, then every CHECKSUMS file will always - # be stored there, not in an author-specific subdir. Thus, in this case, - # we need to always re-fetch the CHECKSUMS file and hence need to set the - # TTL to something small. - my $have_fetchdir = - $self->parent->configure_object->get_conf('fetchdir') ne ''; - my $ttl = $have_fetchdir ? 0.001 : 3600; - my $file = $clone->fetch( ttl => $ttl, %hash ) or return; - - return $file; -} - -sub _parse_checksums_file { - my $self = shift; - my %hash = @_; - - my $file; - my $tmpl = { - file => { required => 1, allow => FILE_READABLE, store => \$file }, - }; - my $args = check( $tmpl, \%hash ); - - my $fh = OPEN_FILE->( $file ) or return; - - ### loop over the header, there might be a pgp signature ### - my $signed; - while (local $_ = <$fh>) { - last if /^\$cksum = \{\s*$/; # skip till this line - my $header = PGP_HEADER; # but be tolerant of whitespace - $signed = 1 if /^${header}\s*$/;# due to crossplatform linebreaks - } - - ### read the filehandle, parse it rather than eval it, even though it - ### *should* be valid perl code - my $dist; - my $cksum = {}; - while (local $_ = <$fh>) { - - if (/^\s*'([^']+)' => \{\s*$/) { - $dist = $1; - - } elsif (/^\s*'([^']+)' => '?([^'\n]+)'?,?\s*$/ and defined $dist) { - $cksum->{$dist}{$1} = $2; - - } elsif (/^\s*}[,;]?\s*$/) { - undef $dist; - - } elsif (/^__END__\s*$/) { - last; - - } else { - error( loc("Malformed %1 line: %2", CHECKSUMS, $_) ); - } - } - - return $cksum; -} - -sub _check_signature_for_checksum_file { - my $self = shift; - - my $conf = $self->parent->configure_object; - my %hash = @_; - - ### you don't want to check signatures, - ### so let's just return true; - return 1 unless $conf->get_conf('signature'); - - my($force,$file,$verbose); - my $tmpl = { - file => { required => 1, allow => FILE_READABLE, store => \$file }, - force => { default => $conf->get_conf('force'), store => \$force }, - verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - my $fh = OPEN_FILE->($file) or return; - - my $signed; - while (local $_ = <$fh>) { - my $header = PGP_HEADER; - $signed = 1 if /^$header$/; - } - - if ( !$signed ) { - msg(loc("No signature found in %1 file '%2'", - CHECKSUMS, $file), $verbose); - - return 1 unless $force; - - error( loc( "%1 file '%2' is not signed -- aborting", - CHECKSUMS, $file ) ); - return; - - } - - if( can_load( modules => { 'Module::Signature' => '0.06' } ) ) { - # local $Module::Signature::SIGNATURE = $file; - # ... check signatures ... - } - - return 1; -} - - - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - -1; diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Module/Fake.pm b/cpan/CPANPLUS/lib/CPANPLUS/Module/Fake.pm deleted file mode 100644 index d6c94a50e0..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Module/Fake.pm +++ /dev/null @@ -1,88 +0,0 @@ -package CPANPLUS::Module::Fake; -use deprecate; - - -use CPANPLUS::Error; -use CPANPLUS::Module; -use CPANPLUS::Module::Author::Fake; -use CPANPLUS::Internals; - -use strict; -use vars qw[@ISA $VERSION]; -use Params::Check qw[check]; - -$VERSION = "0.9135"; -@ISA = qw[CPANPLUS::Module]; -$Params::Check::VERBOSE = 1; - -=pod - -=head1 NAME - -CPANPLUS::Module::Fake - fake module object for internal use - -=head1 SYNOPSIS - - my $obj = CPANPLUS::Module::Fake->new( - module => 'Foo', - path => 'ftp/path/to/foo', - author => CPANPLUS::Module::Author::Fake->new, - package => 'fake-1.1.tgz', - _id => $cpan->_id, - ); - -=head1 DESCRIPTION - -A class for creating fake module objects, for shortcut use internally -by CPANPLUS. - -Inherits from C<CPANPLUS::Module>. - -=head1 METHODS - -=head2 new( module => $mod, path => $path, package => $pkg, [_id => DIGIT] ) - -Creates a dummy module object from the above parameters. It can -take more options (same as C<< CPANPLUS::Module->new >> but the above -are required. - -=cut - -sub new { - my $class = shift; - my %hash = @_; - - local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - module => { required => 1 }, - path => { required => 1 }, - package => { required => 1 }, - _id => { default => CPANPLUS::Internals->_last_id }, - author => { default => '' }, - }; - - my $args = check( $tmpl, \%hash ) or return; - - $args->{author} ||= CPANPLUS::Module::Author::Fake->new( - _id => $args->{_id} ); - - my $obj = CPANPLUS::Module->new( %$args ) or return; - - unless( $obj->_id ) { - error(loc("No '%1' specified -- No CPANPLUS object associated!",'_id')); - return; - } - - ### rebless object ### - return bless $obj, $class; -} - -1; - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Module/Signature.pm b/cpan/CPANPLUS/lib/CPANPLUS/Module/Signature.pm deleted file mode 100644 index 802d8cc2a6..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Module/Signature.pm +++ /dev/null @@ -1,66 +0,0 @@ -package CPANPLUS::Module::Signature; -use deprecate; - -use strict; - -use Cwd; -use CPANPLUS::Error; -use Params::Check qw[check]; -use Module::Load::Conditional qw[can_load]; -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -### detached sig, not actually used afaik --kane ### -#sub get_signature { -# my $self = shift; -# -# my $clone = $self->clone; -# $clone->package( $self->package . '.sig' ); -# -# return $clone->fetch; -#} - -sub check_signature { - my $self = shift; - my $cb = $self->parent; - my $conf = $cb->configure_object; - my %hash = @_; - - my $verbose; - my $tmpl = { - verbose => {default => $conf->get_conf('verbose'), store => \$verbose}, - }; - - check( $tmpl, \%hash ) or return; - - my $dir = $self->status->extract or ( - error( loc( "Do not know what dir '%1' was extracted to; ". - "Cannot check signature", $self->module ) ), - return ); - - my $cwd = cwd(); - unless( $cb->_chdir( dir => $dir ) ) { - error(loc( "Could not chdir to '%1', cannot verify distribution '%2'", - $dir, $self->module )); - return; - } - - - ### check prerequisites - my $flag; - my $use_list = { 'Module::Signature' => '0.06' }; - if( can_load( modules => $use_list, verbose => 1 ) ) { - my $rv = Module::Signature::verify(); - - unless ($rv eq Module::Signature::SIGNATURE_OK() or - $rv eq Module::Signature::SIGNATURE_MISSING() - ) { - $flag++; # whoops, bad sig - } - } - - $cb->_chdir( dir => $cwd ); - return $flag ? 0 : 1; -} - -1; diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Selfupdate.pm b/cpan/CPANPLUS/lib/CPANPLUS/Selfupdate.pm deleted file mode 100644 index 8915712179..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Selfupdate.pm +++ /dev/null @@ -1,554 +0,0 @@ -package CPANPLUS::Selfupdate; -use deprecate; - -use strict; -use Params::Check qw[check]; -use IPC::Cmd qw[can_run]; -use CPANPLUS::Error qw[error msg]; -use Module::Load::Conditional qw[check_install]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -use CPANPLUS::Internals::Constants; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -$Params::Check::VERBOSE = 1; - -=head1 NAME - -CPANPLUS::Selfupdate - self-updating for CPANPLUS - -=head1 SYNOPSIS - - $su = $cb->selfupdate_object; - - @feats = $su->list_features; - @feats = $su->list_enabled_features; - - @mods = map { $su->modules_for_feature( $_ ) } @feats; - @mods = $su->list_core_dependencies; - @mods = $su->list_core_modules; - - for ( @mods ) { - print $_->name " should be version " . $_->version_required; - print "Installed version is not uptodate!" - unless $_->is_installed_version_sufficient; - } - - $ok = $su->selfupdate( update => 'all', latest => 0 ); - -=cut - -### a config has describing our deps etc -{ - - my $Modules = { - dependencies => { - 'File::Fetch' => '0.15_02', # lynx & 404 handling - 'File::Spec' => '0.82', - 'IPC::Cmd' => '0.36', # 5.6.2 compat: 2-arg open - 'Locale::Maketext::Simple' => '0.01', - 'Log::Message' => '0.01', - 'Module::Load' => '0.10', - 'Module::Load::Conditional' => '0.50', # returns dir for loaded - # modules - 'version' => '0.77', # needed for M::L::C - # addresses #24630 and - # #24675 - # Address ~0 overflow issue - 'Params::Check' => '0.36', - 'Package::Constants' => '0.01', - 'Term::UI' => '0.18', # option parsing - 'Test::Harness' => '2.62', # due to bug #19505 - # only 2.58 and 2.60 are bad - 'Test::More' => '0.47', # to run our tests - 'Archive::Extract' => '0.16', # ./Dir bug fix - 'Archive::Tar' => '1.23', - 'IO::Zlib' => '1.04', # needed for Archive::Tar - 'Object::Accessor' => '0.44', # mk_aliases support - 'Module::CoreList' => '2.22', # deprecated core modules - 'Module::Pluggable' => '2.4', - 'Module::Loaded' => '0.01', - 'Parse::CPAN::Meta' => '1.4200', # config_requires support - 'ExtUtils::Install' => '1.42', # uninstall outside @INC - ( check_install( module => 'CPANPLUS::Dist::Build' ) - ? ( 'CPANPLUS::Dist::Build' => '0.60' ) : () ), - }, - - features => { - # config_key_name => [ - # sub { } to list module key/value pairs - # sub { } to check if feature is enabled - # ] - prefer_makefile => [ - sub { - my $cb = shift; - $cb->configure_object->get_conf('prefer_makefile') - ? { } - : { 'CPANPLUS::Dist::Build' => '0.60' }; - }, - sub { return 1 }, # always enabled - ], - cpantest => [ - { 'Test::Reporter' => '1.34', - 'Parse::CPAN::Meta' => '1.4200' - }, - sub { - my $cb = shift; - return $cb->configure_object->get_conf('cpantest'); - }, - ], - dist_type => [ - sub { - my $cb = shift; - my $dist = $cb->configure_object->get_conf('dist_type'); - return { $dist => '0.0' } if $dist; - return; - }, - sub { - my $cb = shift; - return $cb->configure_object->get_conf('dist_type'); - }, - ], - - md5 => [ - { - 'Digest::SHA' => '0.0', - }, - sub { - my $cb = shift; - return $cb->configure_object->get_conf('md5'); - }, - ], - shell => [ - sub { - my $cb = shift; - my $dist = $cb->configure_object->get_conf('shell'); - - ### we bundle these shells, so don't bother having a dep - ### on them... If we don't do this, CPAN.pm actually detects - ### a recursive dependency and breaks (see #26077). - ### This is not an issue for CPANPLUS itself, it handles - ### it smartly. - return if $dist eq SHELL_DEFAULT or $dist eq SHELL_CLASSIC; - return { $dist => '0.0' } if $dist; - return; - }, - sub { return 1 }, - ], - signature => [ - sub { - my $cb = shift; - return { - 'Module::Signature' => '0.06', - } if can_run('gpg'); - ### leave this out -- Crypt::OpenPGP is fairly - ### painful to install, and broken on some platforms - ### so we'll just always fall back to gpg. It may - ### issue a warning or 2, but that's about it. - ### this change due to this ticket: #26914 - # and $cb->configure_object->get_conf('prefer_bin'); - - return { - 'Crypt::OpenPGP' => '0.0', - 'Module::Signature' => '0.06', - }; - }, - sub { - my $cb = shift; - return $cb->configure_object->get_conf('signature'); - }, - ], - storable => [ - { 'Storable' => '0.0' }, - sub { - my $cb = shift; - return $cb->configure_object->get_conf('storable'); - }, - ], - sqlite_backend => [ - { 'DBIx::Simple' => '0.0', - 'DBD::SQLite' => '0.0', - }, - sub { - my $cb = shift; - my $conf = $cb->configure_object; - return $conf->get_conf('source_engine') - eq 'CPANPLUS::Internals::Source::SQLite' - }, - ], - }, - core => { - 'CPANPLUS' => '0.0', - }, - }; - - sub _get_config { return $Modules } -} - -=head1 METHODS - -=head2 $self = CPANPLUS::Selfupdate->new( $backend_object ); - -Sets up a new selfupdate object. Called automatically when -a new backend object is created. - -=cut - -sub new { - my $class = shift; - my $cb = shift or return; - return bless sub { $cb }, $class; -} - - -{ ### cache to find the relevant modules - my $cache = { - core - => sub { my $self = shift; - core => [ $self->list_core_modules ] }, - - dependencies - => sub { my $self = shift; - dependencies => [ $self->list_core_dependencies ] }, - - enabled_features - => sub { my $self = shift; - map { $_ => [ $self->modules_for_feature( $_ ) ] } - $self->list_enabled_features - }, - features - => sub { my $self = shift; - map { $_ => [ $self->modules_for_feature( $_ ) ] } - $self->list_features - }, - ### make sure to do 'core' first, in case - ### we are out of date ourselves - all => [ qw|core dependencies enabled_features| ], - }; - - -=head2 @cat = $self->list_categories - -Returns a list of categories that the C<selfupdate> method accepts. - -See C<selfupdate> for details. - -=cut - - sub list_categories { return sort keys %$cache } - -=head2 %list = $self->list_modules_to_update( update => "core|dependencies|enabled_features|features|all", [latest => BOOL] ) - -List which modules C<selfupdate> would upgrade. You can update either -the core (CPANPLUS itself), the core dependencies, all features you have -currently turned on, or all features available, or everything. - -The C<latest> option determines whether it should update to the latest -version on CPAN, or if the minimal required version for CPANPLUS is -good enough. - -Returns a hash of feature names and lists of module objects to be -upgraded based on the category you provided. For example: - - %list = $self->list_modules_to_update( update => 'core' ); - -Would return: - - ( core => [ $module_object_for_cpanplus ] ); - -=cut - - sub list_modules_to_update { - my $self = shift; - my $cb = $self->(); - my $conf = $cb->configure_object; - my %hash = @_; - - my($type, $latest); - my $tmpl = { - update => { required => 1, store => \$type, - allow => [ keys %$cache ], }, - latest => { default => 0, store => \$latest, allow => BOOLEANS }, - }; - - { local $Params::Check::ALLOW_UNKNOWN = 1; - check( $tmpl, \%hash ) or return; - } - - my $ref = $cache->{$type}; - - ### a list of ( feature1 => \@mods, feature2 => \@mods, etc ) - my %list = UNIVERSAL::isa( $ref, 'ARRAY' ) - ? map { $cache->{$_}->( $self ) } @$ref - : $ref->( $self ); - - ### filter based on whether we need the latest ones or not - for my $aref ( values %list ) { - $aref = [ $latest - ? grep { !$_->is_uptodate } @$aref - : grep { !$_->is_installed_version_sufficient } @$aref - ]; - } - - return %list; - } - -=head2 $bool = $self->selfupdate( update => "core|dependencies|enabled_features|features|all", [latest => BOOL, force => BOOL] ) - -Selfupdate CPANPLUS. You can update either the core (CPANPLUS itself), -the core dependencies, all features you have currently turned on, or -all features available, or everything. - -The C<latest> option determines whether it should update to the latest -version on CPAN, or if the minimal required version for CPANPLUS is -good enough. - -Returns true on success, false on error. - -=cut - - sub selfupdate { - my $self = shift; - my $cb = $self->(); - my $conf = $cb->configure_object; - my %hash = @_; - - my $force; - my $tmpl = { - force => { default => $conf->get_conf('force'), store => \$force }, - }; - - { local $Params::Check::ALLOW_UNKNOWN = 1; - check( $tmpl, \%hash ) or return; - } - - my %list = $self->list_modules_to_update( %hash ) or return; - - ### just the modules please - my @mods = map { @$_ } values %list; - - my $flag; - for my $mod ( @mods ) { - unless( $mod->install( force => $force ) ) { - $flag++; - error(loc("Failed to update module '%1'", $mod->name)); - } - } - - return if $flag; - return 1; - } - -} - -=head2 @features = $self->list_features - -Returns a list of features that are supported by CPANPLUS. - -=cut - -sub list_features { - my $self = shift; - return keys %{ $self->_get_config->{'features'} }; -} - -=head2 @features = $self->list_enabled_features - -Returns a list of features that are enabled in your current -CPANPLUS installation. - -=cut - -sub list_enabled_features { - my $self = shift; - my $cb = $self->(); - - my @enabled; - for my $feat ( $self->list_features ) { - my $ref = $self->_get_config->{'features'}->{$feat}->[1]; - push @enabled, $feat if $ref->($cb); - } - - return @enabled; -} - -=head2 @mods = $self->modules_for_feature( FEATURE [,AS_HASH] ) - -Returns a list of C<CPANPLUS::Selfupdate::Module> objects which -represent the modules required to support this feature. - -For a list of features, call the C<list_features> method. - -If the C<AS_HASH> argument is provided, no module objects are -returned, but a hashref where the keys are names of the modules, -and values are their minimum versions. - -=cut - -sub modules_for_feature { - my $self = shift; - my $feature = shift or return; - my $as_hash = shift || 0; - my $cb = $self->(); - - unless( exists $self->_get_config->{'features'}->{$feature} ) { - error(loc("Unknown feature '%1'", $feature)); - return; - } - - my $ref = $self->_get_config->{'features'}->{$feature}->[0]; - - ### it's either a list of modules/versions or a subroutine that - ### returns a list of modules/versions - my $href = UNIVERSAL::isa( $ref, 'HASH' ) ? $ref : $ref->( $cb ); - - return unless $href; # nothing needed for the feature? - - return $href if $as_hash; - return $self->_hashref_to_module( $href ); -} - - -=head2 @mods = $self->list_core_dependencies( [AS_HASH] ) - -Returns a list of C<CPANPLUS::Selfupdate::Module> objects which -represent the modules that comprise the core dependencies of CPANPLUS. - -If the C<AS_HASH> argument is provided, no module objects are -returned, but a hashref where the keys are names of the modules, -and values are their minimum versions. - -=cut - -sub list_core_dependencies { - my $self = shift; - my $as_hash = shift || 0; - my $cb = $self->(); - my $href = $self->_get_config->{'dependencies'}; - - return $href if $as_hash; - return $self->_hashref_to_module( $href ); -} - -=head2 @mods = $self->list_core_modules( [AS_HASH] ) - -Returns a list of C<CPANPLUS::Selfupdate::Module> objects which -represent the modules that comprise the core of CPANPLUS. - -If the C<AS_HASH> argument is provided, no module objects are -returned, but a hashref where the keys are names of the modules, -and values are their minimum versions. - -=cut - -sub list_core_modules { - my $self = shift; - my $as_hash = shift || 0; - my $cb = $self->(); - my $href = $self->_get_config->{'core'}; - - return $href if $as_hash; - return $self->_hashref_to_module( $href ); -} - -sub _hashref_to_module { - my $self = shift; - my $cb = $self->(); - my $href = shift or return; - - return map { - CPANPLUS::Selfupdate::Module->new( - $cb->module_tree($_) => $href->{$_} - ) - } keys %$href; -} - - -=head1 CPANPLUS::Selfupdate::Module - -C<CPANPLUS::Selfupdate::Module> extends C<CPANPLUS::Module> objects -by providing accessors to aid in selfupdating CPANPLUS. - -These objects are returned by all methods of C<CPANPLUS::Selfupdate> -that return module objects. - -=cut - -{ package CPANPLUS::Selfupdate::Module; - use base 'CPANPLUS::Module'; - - ### stores module name -> cpanplus required version - ### XXX only can deal with 1 pair! - my %Cache = (); - my $Acc = 'version_required'; - - sub new { - my $class = shift; - my $mod = shift or return; - my $ver = shift; return unless defined $ver; - - my $obj = $mod->clone; # clone the module object - bless $obj, $class; # rebless it to our class - - $obj->$Acc( $ver ); - - return $obj; - } - -=head2 $version = $mod->version_required - -Returns the version of this module required for CPANPLUS. - -=cut - - sub version_required { - my $self = shift; - $Cache{ $self->name } = shift() if @_; - return $Cache{ $self->name }; - } - -=head2 $bool = $mod->is_installed_version_sufficient - -Returns true if the installed version of this module is sufficient -for CPANPLUS, or false if it is not. - -=cut - - - sub is_installed_version_sufficient { - my $self = shift; - return $self->is_uptodate( version => $self->$Acc ); - } - -} - -1; - -=pod - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Shell.pm b/cpan/CPANPLUS/lib/CPANPLUS/Shell.pm deleted file mode 100644 index bf7482d3da..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell.pm +++ /dev/null @@ -1,343 +0,0 @@ -package CPANPLUS::Shell; -use deprecate; - -use strict; - -use CPANPLUS::Error; -use CPANPLUS::Configure; -use CPANPLUS::Internals::Constants; - -use Module::Load qw[load]; -use Params::Check qw[check]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -$Params::Check::VERBOSE = 1; - -use vars qw[@ISA $SHELL $DEFAULT $VERSION]; - -$VERSION = "0.9135"; -$DEFAULT = SHELL_DEFAULT; - -=pod - -=head1 NAME - -CPANPLUS::Shell - base class for CPANPLUS shells - -=head1 SYNOPSIS - - use CPANPLUS::Shell; # load the shell indicated by your - # config -- defaults to - # CPANPLUS::Shell::Default - - use CPANPLUS::Shell qw[Classic] # load CPANPLUS::Shell::Classic; - - my $ui = CPANPLUS::Shell->new(); - my $name = $ui->which; # Find out what shell you loaded - - $ui->shell; # run the ui shell - - -=head1 DESCRIPTION - -This module is the generic loading (and base class) for all C<CPANPLUS> -shells. Through this module you can load any installed C<CPANPLUS> -shell. - -Just about all the functionality is provided by the shell that you have -loaded, and not by this class (which merely functions as a generic -loading class), so please consult the documentation of your shell of -choice. - -=cut - -sub import { - my $class = shift; - my $option = shift; - - ### find out what shell we're supposed to load ### - $SHELL = $option - ? $class . '::' . $option - : do { ### XXX this should offer to reconfigure - ### CPANPLUS, somehow. --rs - ### XXX load Configure only if we really have to - ### as that means any $Conf passed later on will - ### be ignored in favour of the one that was - ### retrieved via ->new --kane - my $conf = CPANPLUS::Configure->new() or - die loc("No configuration available -- aborting") . $/; - $conf->get_conf('shell') || $DEFAULT; - }; - - ### load the shell, fall back to the default if required - ### and die if even that doesn't work - EVAL: { - eval { load $SHELL }; - - if( $@ ) { - my $err = $@; - - die loc("Your default shell '%1' is not available: %2", - $DEFAULT, $err) . - loc("Check your installation!") . "\n" - if $SHELL eq $DEFAULT; - - warn loc("Failed to use '%1': %2", $SHELL, $err), - loc("Switching back to the default shell '%1'", $DEFAULT), - "\n"; - - $SHELL = $DEFAULT; - redo EVAL; - } - } - @ISA = ($SHELL); -} - -sub which { return $SHELL } - -1; - -########################################################################### -### abstracted out subroutines available to programmers of other shells ### -########################################################################### - -package CPANPLUS::Shell::_Base::ReadLine; - -use strict; -use vars qw($AUTOLOAD $TMPL); - -use FileHandle; -use CPANPLUS::Error; -use Params::Check qw[check]; -use Module::Load::Conditional qw[can_load]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -$Params::Check::VERBOSE = 1; - - -$TMPL = { - brand => { default => '', strict_type => 1 }, - prompt => { default => '> ', strict_type => 1 }, - pager => { default => '' }, - backend => { default => '' }, - term => { default => '' }, - format => { default => '' }, - dist_format => { default => '' }, - remote => { default => undef }, - noninteractive => { default => '' }, - cache => { default => [ ] }, - settings => { default => { install_all_prereqs => undef }, - no_override => 1 }, - _old_sigpipe => { default => '', no_override => 1 }, - _old_outfh => { default => '', no_override => 1 }, - _signals => { default => { INT => { } }, no_override => 1 }, -}; - -### autogenerate accessors ### -for my $key ( keys %$TMPL ) { - no strict 'refs'; - *{__PACKAGE__."::$key"} = sub { - my $self = shift; - $self->{$key} = $_[0] if @_; - return $self->{$key}; - } -} - -sub _init { - my $class = shift; - my %hash = @_; - - my $self = check( $TMPL, \%hash ) or return; - - bless $self, $class; - - ### signal handler ### - $SIG{INT} = $self->_signals->{INT}->{handler} = - sub { - unless ( $self->_signals->{INT}->{count}++ ) { - warn loc("Caught SIGINT"), "\n"; - } else { - warn loc("Got another SIGINT"), "\n"; die; - } - }; - ### end sig handler ### - - return $self; -} - -### display shell's banner, takes the Backend object as argument -sub _show_banner { - my $self = shift; - my $cpan = $self->backend; - my $term = $self->term; - - ### Tries to probe for our ReadLine support status - # a) under an interactive shell? - my $rl_avail = (!$term->isa('CPANPLUS::Shell::_Faked')) - # b) do we have a tty terminal? - ? (-t STDIN) - # c) should we enable the term? - ? (!$self->__is_bad_terminal($term)) - # d) external modules available? - ? ($term->ReadLine ne "Term::ReadLine::Stub") - # a+b+c+d => "Smart" terminal - ? loc("enabled") - # a+b+c => "Stub" terminal - : loc("available (try 'i Term::ReadLine::Perl')") - # a+b => "Bad" terminal - : loc("disabled") - # a => "Dumb" terminal - : loc("suppressed") - # none => "Faked" terminal - : loc("suppressed in batch mode"); - - $rl_avail = loc("ReadLine support %1.", $rl_avail); - $rl_avail = "\n*** $rl_avail" if (length($rl_avail) > 45); - - $self->__print( - loc("%1 -- CPAN exploration and module installation (v%2)", - $self->which, $self->which->VERSION()), "\n", - loc("*** Please report bugs to <bug-cpanplus\@rt.cpan.org>."), "\n", - loc("*** Using CPANPLUS::Backend v%1. %2", - $cpan->VERSION, $rl_avail), "\n\n" - ); -} - -### checks whether the Term::ReadLine is broken and needs to fallback to Stub -sub __is_bad_terminal { - my $self = shift; - my $term = $self->term; - - return unless $^O eq 'MSWin32'; - - ### replace the term with the default (stub) one - return $self->term(Term::ReadLine::Stub->new( $self->brand ) ); -} - -### open a pager handle -sub _pager_open { - my $self = shift; - my $cpan = $self->backend; - my $cmd = $cpan->configure_object->get_program('pager') or return; - - $self->_old_sigpipe( $SIG{PIPE} ); - $SIG{PIPE} = 'IGNORE'; - - my $fh = new FileHandle; - unless ( $fh->open("| $cmd") ) { - error(loc("could not pipe to %1: %2\n", $cmd, $!) ); - return; - } - - $fh->autoflush(1); - - $self->pager( $fh ); - $self->_old_outfh( select $fh ); - - return $fh; -} - -### print to the current pager handle, or STDOUT if it's not opened -sub _pager_close { - my $self = shift; - my $pager = $self->pager or return; - - $pager->close if (ref($pager) and $pager->can('close')); - - $self->pager( undef ); - - select $self->_old_outfh; - $SIG{PIPE} = $self->_old_sigpipe; - - return 1; -} - - - -{ - my $win32_console; - - ### determines row count of current terminal; defaults to 25. - ### used by the pager functions - sub _term_rowcount { - my $self = shift; - my $cpan = $self->backend; - my %hash = @_; - - my $default; - my $tmpl = { - default => { default => 25, allow => qr/^\d$/, - store => \$default } - }; - - check( $tmpl, \%hash ) or return; - - if ( $^O eq 'MSWin32' ) { - if ( can_load( modules => { 'Win32::Console' => '0.0' } ) ) { - $win32_console ||= Win32::Console->new(); - my $rows = ($win32_console->Info)[-1]; - return $rows; - } - - } else { - local $Module::Load::Conditional::VERBOSE = 0; - if ( can_load(modules => {'Term::Size' => '0.0'}) ) { - my ($cols, $rows) = Term::Size::chars(); - return $rows; - } - } - return $default; - } -} - -### Custom print routines, mainly to be able to catch output -### in test cases, or redirect it if need be -{ sub __print { - my $self = shift; - print @_; - } - - sub __printf { - my $self = shift; - my $fmt = shift; - - ### MUST specify $fmt as a separate param, and not as part - ### of @_, as it will then miss the $fmt and return the - ### number of elements in the list... =/ --kane - $self->__print( sprintf( $fmt, @_ ) ); - } -} - -1; - -=pod - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=head1 SEE ALSO - -L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell::Classic>, L<cpanp> - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Classic.pm b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Classic.pm deleted file mode 100644 index 6cdc6f69cc..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Classic.pm +++ /dev/null @@ -1,1269 +0,0 @@ -################################################## -### CPANPLUS/Shell/Classic.pm ### -### Backwards compatible shell for CPAN++ ### -### Written 08-04-2002 by Jos Boumans ### -################################################## - -package CPANPLUS::Shell::Classic; -use deprecate; - -use strict; - - -use CPANPLUS::Error; -use CPANPLUS::Backend; -use CPANPLUS::Configure::Setup; -use CPANPLUS::Internals::Constants; - -use Cwd; -use IPC::Cmd; -use Term::UI; -use Data::Dumper; -use Term::ReadLine; - -use Module::Load qw[load]; -use Params::Check qw[check]; -use Module::Load::Conditional qw[can_load]; - -$Params::Check::VERBOSE = 1; -$Params::Check::ALLOW_UNKNOWN = 1; - -BEGIN { - use vars qw[ $VERSION @ISA ]; - @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; - $VERSION = "0.9135"; -} - -load CPANPLUS::Shell; - - -### our command set ### -my $map = { - a => '_author', - b => '_bundle', - d => '_distribution', - 'm' => '_module', - i => '_find_all', - r => '_uptodate', - u => '_not_supported', - ls => '_ls', - get => '_fetch', - make => '_install', - test => '_install', - install => '_install', - clean => '_not_supported', - look => '_shell', - readme => '_readme', - h => '_help', - '?' => '_help', - o => '_set_conf', - reload => '_reload', - autobundle => '_autobundle', - '!' => '_bang', - #'q' => '_quit', # done it the loop itself -}; - -### the shell object, scoped to the file ### -my $Shell; -my $Brand = 'cpan'; -my $Prompt = $Brand . '> '; - -sub new { - my $class = shift; - - my $cb = new CPANPLUS::Backend; - my $self = $class->SUPER::_init( - brand => $Brand, - term => Term::ReadLine->new( $Brand ), - prompt => $Prompt, - backend => $cb, - format => "%5s %-50s %8s %-10s\n", - ); - ### make it available package wide ### - $Shell = $self; - - ### enable verbose, it's the cpan.pm way - $cb->configure_object->set_conf( verbose => 1 ); - - - ### register install callback ### - $cb->_register_callback( - name => 'install_prerequisite', - code => \&__ask_about_install, - ); - - ### register test report callback ### - $cb->_register_callback( - name => 'edit_test_report', - code => \&__ask_about_test_report, - ); - - if (my $histfile = $self->configure_object->get_conf( 'histfile' )) { - my $term = $self->term; - if ($term->can('AddHistory')) { - if (open my $fh, '<', $histfile) { - local $/ = "\n"; - while (my $line = <$fh>) { - chomp($line); - $term->AddHistory($line); - } - close($fh); - } - } - } - - return $self; -} - -sub shell { - my $self = shift; - my $term = $self->term; - - $self->_show_banner; - $self->_input_loop && print "\n"; - $self->_quit; -} - -sub _input_loop { - my $self = shift; - my $term = $self->term; - my $cb = $self->backend; - - my $normal_quit = 0; - while ( - defined (my $input = eval { $term->readline($self->prompt) } ) - or $self->_signals->{INT}{count} == 1 - ) { - ### re-initiate all signal handlers - while (my ($sig, $entry) = each %{$self->_signals} ) { - $SIG{$sig} = $entry->{handler} if exists($entry->{handler}); - } - - last if $self->_dispatch_on_input( input => $input ); - - ### flush the lib cache ### - $cb->_flush( list => [qw|lib load|] ); - - } continue { - $self->_signals->{INT}{count}-- - if $self->_signals->{INT}{count}; # clear the sigint count - } - - return 1; -} - -sub _dispatch_on_input { - my $self = shift; - my $conf = $self->backend->configure_object(); - my $term = $self->term; - my %hash = @_; - - my $string; - my $tmpl = { - input => { required => 1, store => \$string } - }; - - check( $tmpl, \%hash ) or return; - - ### the original force setting; - my $force_store = $conf->get_conf( 'force' ); - - ### parse the input: the first part before the space - ### is the command, followed by arguments. - ### see the usage below - my $key; - PARSE_INPUT: { - $string =~ s|^\s*([\w\?\!]+)\s*||; - chomp $string; - $key = lc($1); - } - - ### you prefixed the input with 'force' - ### that means we set the force flag, and - ### reparse the input... - ### YAY goto block :) - if( $key eq 'force' ) { - $conf->set_conf( force => 1 ); - goto PARSE_INPUT; - } - - ### you want to quit - return 1 if $key =~ /^q/; - - my $method = $map->{$key}; - unless( $self->can( $method ) ) { - print "Unknown command '$key'. Type ? for help.\n"; - return; - } - - ### dispatch the method call - eval { $self->$method( - command => $key, - result => [ split /\s+/, $string ], - input => $string ); - }; - warn $@ if $@; - - return; -} - -### displays quit message -sub _quit { - my $self = shift; - my $term = $self->term; - - if ($term->can('GetHistory')) { - my @history = $term->GetHistory; - - my $histfile = $self->configure_object->get_conf('histfile'); - - if (open my $fh, '>', $histfile) { - foreach my $line (@history) { - print {$fh} "$line\n"; - } - close($fh); - } - else { - warn "Cannot open history file '$histfile' - $!"; - } - } - - ### well, that's what CPAN.pm says... - print "Lockfile removed\n"; -} - -sub _not_supported { - my $self = shift; - my %hash = @_; - - my $cmd; - my $tmpl = { - command => { required => 1, store => \$cmd } - }; - - check( $tmpl, \%hash ) or return; - - print "Sorry, the command '$cmd' is not supported\n"; - - return; -} - -sub _fetch { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my($aref, $input); - my $tmpl = { - result => { store => \$aref, default => [] }, - input => { default => 'all', store => \$input }, - }; - - check( $tmpl, \%hash ) or return; - - for my $mod (@$aref) { - my $obj; - - unless( $obj = $cb->module_tree($mod) ) { - print "Warning: Cannot get $input, don't know what it is\n"; - print "Try the command\n\n"; - print "\ti /$mod/\n\n"; - print "to find objects with matching identifiers.\n"; - - next; - } - - $obj->fetch && $obj->extract; - } - - return $aref; -} - -sub _install { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my $mapping = { - make => { target => TARGET_CREATE, skiptest => 1 }, - test => { target => TARGET_CREATE }, - install => { target => TARGET_INSTALL }, - }; - - my($aref,$cmd); - my $tmpl = { - result => { store => \$aref, default => [] }, - command => { required => 1, store => \$cmd, allow => [keys %$mapping] }, - }; - - check( $tmpl, \%hash ) or return; - - for my $mod (@$aref) { - my $obj = $cb->module_tree( $mod ); - - unless( $obj ) { - print "No such module '$mod'\n"; - next; - } - - my $opts = $mapping->{$cmd}; - $obj->install( %$opts ); - } - - return $aref; -} - -sub _shell { - my $self = shift; - my $cb = $self->backend; - my $conf = $cb->configure_object; - my %hash = @_; - - my($aref, $cmd); - my $tmpl = { - result => { store => \$aref, default => [] }, - command => { required => 1, store => \$cmd }, - - }; - - check( $tmpl, \%hash ) or return; - - - my $shell = $conf->get_program('shell'); - unless( $shell ) { - print "Your configuration does not define a value for subshells.\n". - qq[Please define it with "o conf shell <your shell>"\n]; - return; - } - - my $cwd = Cwd::cwd(); - - for my $mod (@$aref) { - print "Running $cmd for $mod\n"; - - my $obj = $cb->module_tree( $mod ) or next; - $obj->fetch or next; - $obj->extract or next; - - $cb->_chdir( dir => $obj->status->extract ) or next; - - #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt; - if( system($shell) and $! ) { - print "Error executing your subshell '$shell': $!\n"; - next; - } - } - $cb->_chdir( dir => $cwd ); - - return $aref; -} - -sub _readme { - my $self = shift; - my $cb = $self->backend; - my $conf = $cb->configure_object; - my %hash = @_; - - my($aref, $cmd); - my $tmpl = { - result => { store => \$aref, default => [] }, - command => { required => 1, store => \$cmd }, - - }; - - check( $tmpl, \%hash ) or return; - - for my $mod (@$aref) { - my $obj = $cb->module_tree( $mod ) or next; - - if( my $readme = $obj->readme ) { - - $self->_pager_open; - print $readme; - $self->_pager_close; - } - } - - return 1; -} - -sub _reload { - my $self = shift; - my $cb = $self->backend; - my $conf = $cb->configure_object; - my %hash = @_; - - my($input, $cmd); - my $tmpl = { - input => { default => 'all', store => \$input }, - command => { required => 1, store => \$cmd }, - - }; - - check( $tmpl, \%hash ) or return; - - if ( $input =~ /cpan/i ) { - print qq[You want to reload the CPAN code\n]; - print qq[Just type 'q' and then restart... ] . - qq[Trust me, it is MUCH safer\n]; - - } elsif ( $input =~ /index/i ) { - $cb->reload_indices(update_source => 1); - - } else { - print qq[cpan re-evals the CPANPLUS.pm file\n]; - print qq[index re-reads the index files\n]; - } - - return 1; -} - -sub _autobundle { - my $self = shift; - my $cb = $self->backend; - - print qq[Writing bundle file... This may take a while\n]; - - my $where = $cb->autobundle(); - - print $where - ? qq[\nWrote autobundle to $where\n] - : qq[\nCould not create autobundle\n]; - - return 1; -} - -sub _set_conf { - my $self = shift; - my $cb = $self->backend; - my $conf = $cb->configure_object; - my %hash = @_; - - my($aref, $input); - my $tmpl = { - result => { store => \$aref, default => [] }, - input => { default => 'all', store => \$input }, - }; - - check( $tmpl, \%hash ) or return; - - my $type = shift @$aref; - - if( $type eq 'debug' ) { - print qq[Sorry you cannot set debug options through ] . - qq[this shell in CPANPLUS\n]; - return; - - } elsif ( $type eq 'conf' ) { - - ### from CPAN.pm :o) - # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf' - # should have been called set and 'o debug' maybe 'set debug' - - # commit Commit changes to disk - # defaults Reload defaults from disk - # init Interactive setting of all options - - my $name = shift @$aref; - my $value = "@$aref"; - - if( $name eq 'init' ) { - my $setup = CPANPLUS::Configure::Setup->new( - conf => $cb->configure_object, - term => $self->term, - backend => $cb, - ); - return $setup->init; - - } elsif ($name eq 'commit' ) {; - $cb->configure_object->save; - print "Your CPAN++ configuration info has been saved!\n\n"; - return; - - } elsif ($name eq 'defaults' ) { - print qq[Sorry, CPANPLUS cannot restore default for you.\n] . - qq[Perhaps you should run the interactive setup again.\n] . - qq[\ttry running 'o conf init'\n]; - return; - - ### we're just supplying things in the 'conf' section now, - ### not the program section.. it's a bit of a hassle to make that - ### work cleanly with the original CPAN.pm interface, so we'll fix - ### it when people start complaining, which is hopefully never. - } else { - unless( $name ) { - my @list = grep { $_ ne 'hosts' } - $conf->options( type => $type ); - - my $method = 'get_' . $type; - - local $Data::Dumper::Indent = 0; - for my $name ( @list ) { - my $val = $conf->$method($name); - ($val) = ref($val) - ? (Data::Dumper::Dumper($val) =~ /= (.*);$/) - : "'$val'"; - printf " %-25s %s\n", $name, $val; - } - - } elsif ( $name eq 'hosts' ) { - print "Setting hosts is not trivial.\n" . - "It is suggested you edit the " . - "configuration file manually"; - - } else { - my $method = 'set_' . $type; - if( $conf->$method($name => defined $value ? $value : '') ) { - my $set_to = defined $value ? $value : 'EMPTY STRING'; - print "Key '$name' was set to '$set_to'\n"; - } - } - } - } else { - print qq[Known options:\n] . - qq[ conf set or get configuration variables\n] . - qq[ debug set or get debugging options\n]; - } - - return; -} - -######################## -### search functions ### -######################## - -sub _author { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my($aref, $short, $input, $class); - my $tmpl = { - result => { store => \$aref, default => ['/./'] }, - short => { default => 0, store => \$short }, - input => { default => 'all', store => \$input }, - class => { default => 'Author', no_override => 1, - store => \$class }, - }; - - check( $tmpl, \%hash ) or return; - - my @regexes = map { m|/(.+)/| ? qr/$1/ : $_ } @$aref; - - - my @rv; - for my $type (qw[author cpanid]) { - push @rv, $cb->search( type => $type, allow => \@regexes ); - } - - unless( @rv ) { - print "No object of type $class found for argument $input\n" - unless $short; - return; - } - - return $self->_pp_author( - result => \@rv, - class => $class, - short => $short, - input => $input ); - -} - -### find all modules matching a query ### -sub _module { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my($aref, $short, $input, $class); - my $tmpl = { - result => { store => \$aref, default => ['/./'] }, - short => { default => 0, store => \$short }, - input => { default => 'all', store => \$input }, - class => { default => 'Module', no_override => 1, - store => \$class }, - }; - - check( $tmpl, \%hash ) or return; - - my @rv; - for my $module (@$aref) { - if( $module =~ m|/(.+)/| ) { - push @rv, $cb->search( type => 'module', - allow => [qr/$1/i] ); - } else { - my $obj = $cb->module_tree( $module ) or next; - push @rv, $obj; - } - } - - return $self->_pp_module( - result => \@rv, - class => $class, - short => $short, - input => $input ); -} - -### find all bundles matching a query ### -sub _bundle { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my($aref, $short, $input, $class); - my $tmpl = { - result => { store => \$aref, default => ['/./'] }, - short => { default => 0, store => \$short }, - input => { default => 'all', store => \$input }, - class => { default => 'Bundle', no_override => 1, - store => \$class }, - }; - - check( $tmpl, \%hash ) or return; - - my @rv; - for my $bundle (@$aref) { - if( $bundle =~ m|/(.+)/| ) { - push @rv, $cb->search( type => 'module', - allow => [qr/Bundle::.*?$1/i] ); - } else { - my $obj = $cb->module_tree( "Bundle::${bundle}" ) or next; - push @rv, $obj; - } - } - - return $self->_pp_module( - result => \@rv, - class => $class, - short => $short, - input => $input ); -} - -sub _distribution { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my($aref, $short, $input, $class); - my $tmpl = { - result => { store => \$aref, default => ['/./'] }, - short => { default => 0, store => \$short }, - input => { default => 'all', store => \$input }, - class => { default => 'Distribution', no_override => 1, - store => \$class }, - }; - - check( $tmpl, \%hash ) or return; - - my @rv; - for my $module (@$aref) { - ### if it's a regex... ### - if ( my ($match) = $module =~ m|^/(.+)/$|) { - - ### something like /FOO/Bar.tar.gz/ was entered - if (my ($path,$package) = $match =~ m|^/?(.+)/(.+)$|) { - my $seen; - - my @data = $cb->search( type => 'package', - allow => [qr/$package/i] ); - - my @list = $cb->search( type => 'path', - allow => [qr/$path/i], - data => \@data ); - - ### make sure we dont list the same dist twice - for my $val ( @list ) { - next if $seen->{$val->package}++; - - push @rv, $val; - } - - ### something like /FOO/ or /Bar.tgz/ was entered - ### so we look both in the path, as well as in the package name - } else { - my $seen; - { my @list = $cb->search( type => 'package', - allow => [qr/$match/i] ); - - ### make sure we dont list the same dist twice - for my $val ( @list ) { - next if $seen->{$val->package}++; - - push @rv, $val; - } - } - - { my @list = $cb->search( type => 'path', - allow => [qr/$match/i] ); - - ### make sure we dont list the same dist twice - for my $val ( @list ) { - next if $seen->{$val->package}++; - - push @rv, $val; - } - - } - } - - } else { - - ### user entered a full dist, like: R/RC/RCAPUTO/POE-0.19.tar.gz - if (my ($path,$package) = $module =~ m|^/?(.+)/(.+)$|) { - my @data = $cb->search( type => 'package', - allow => [qr/^$package$/] ); - my @list = $cb->search( type => 'path', - allow => [qr/$path$/i], - data => \@data); - - ### make sure we dont list the same dist twice - my $seen; - for my $val ( @list ) { - next if $seen->{$val->package}++; - - push @rv, $val; - } - } - } - } - - return $self->_pp_distribution( - result => \@rv, - class => $class, - short => $short, - input => $input ); -} - -sub _find_all { - my $self = shift; - - my @rv; - for my $method (qw[_author _bundle _module _distribution]) { - my $aref = $self->$method( @_, short => 1 ); - - push @rv, @$aref if $aref; - } - - print scalar(@rv). " items found\n" -} - -sub _uptodate { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my($aref, $short, $input, $class); - my $tmpl = { - result => { store => \$aref, default => ['/./'] }, - short => { default => 0, store => \$short }, - input => { default => 'all', store => \$input }, - class => { default => 'Uptodate', no_override => 1, - store => \$class }, - }; - - check( $tmpl, \%hash ) or return; - - - my @rv; - if( @$aref) { - for my $module (@$aref) { - if( $module =~ m|/(.+)/| ) { - my @list = $cb->search( type => 'module', - allow => [qr/$1/i] ); - - ### only add those that are installed and not core - push @rv, grep { not $_->package_is_perl_core } - grep { $_->installed_file } - @list; - - } else { - my $obj = $cb->module_tree( $module ) or next; - push @rv, $obj; - } - } - } else { - @rv = @{$cb->_all_installed}; - } - - return $self->_pp_uptodate( - result => \@rv, - class => $class, - short => $short, - input => $input ); -} - -sub _ls { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my($aref, $short, $input, $class); - my $tmpl = { - result => { store => \$aref, default => [] }, - short => { default => 0, store => \$short }, - input => { default => 'all', store => \$input }, - class => { default => 'Uptodate', no_override => 1, - store => \$class }, - }; - - check( $tmpl, \%hash ) or return; - - my @rv; - for my $name (@$aref) { - my $auth = $cb->author_tree( uc $name ); - - unless( $auth ) { - print qq[ls command rejects argument $name: not an author\n]; - next; - } - - push @rv, $auth->distributions; - } - - return $self->_pp_ls( - result => \@rv, - class => $class, - short => $short, - input => $input ); -} - -############################ -### pretty printing subs ### -############################ - - -sub _pp_author { - my $self = shift; - my %hash = @_; - - my( $aref, $short, $class, $input ); - my $tmpl = { - result => { required => 1, default => [], strict_type => 1, - store => \$aref }, - short => { default => 0, store => \$short }, - class => { required => 1, store => \$class }, - input => { required => 1, store => \$input }, - }; - - check( $tmpl, \%hash ) or return; - - ### no results - if( !@$aref ) { - print "No objects of type $class found for argument $input\n" - unless $short; - - ### one result, long output desired; - } elsif( @$aref == 1 and !$short ) { - - ### should look like this: - #cpan> a KANE - #Author id = KANE - # EMAIL boumans@frg.eur.nl - # FULLNAME Jos Boumans - - my $obj = shift @$aref; - - print "$class id = ", $obj->cpanid(), "\n"; - printf " %-12s %s\n", 'EMAIL', $obj->email(); - printf " %-12s %s%s\n", 'FULLNAME', $obj->author(); - - } else { - - ### should look like this: - #Author KANE (Jos Boumans) - #Author LBROCARD (Leon Brocard) - #2 items found - - for my $obj ( @$aref ) { - printf qq[%-15s %s ("%s" (%s))\n], - $class, $obj->cpanid, $obj->author, $obj->email; - } - print scalar(@$aref)." items found\n" unless $short; - } - - return $aref; -} - -sub _pp_module { - my $self = shift; - my %hash = @_; - - my( $aref, $short, $class, $input ); - my $tmpl = { - result => { required => 1, default => [], strict_type => 1, - store => \$aref }, - short => { default => 0, store => \$short }, - class => { required => 1, store => \$class }, - input => { required => 1, store => \$input }, - }; - - check( $tmpl, \%hash ) or return; - - - ### no results - if( !@$aref ) { - print "No objects of type $class found for argument $input\n" - unless $short; - - ### one result, long output desired; - } elsif( @$aref == 1 and !$short ) { - - - ### should look like this: - #Module id = LWP - # DESCRIPTION Libwww-perl - # CPAN_USERID GAAS (Gisle Aas <gisle@ActiveState.com>) - # CPAN_VERSION 5.64 - # CPAN_FILE G/GA/GAAS/libwww-perl-5.64.tar.gz - # DSLI_STATUS RmpO (released,mailing-list,perl,object-oriented) - # MANPAGE LWP - The World-Wide Web library for Perl - # INST_FILE C:\Perl\site\lib\LWP.pm - # INST_VERSION 5.62 - - my $obj = shift @$aref; - my $aut_obj = $obj->author; - my $format = " %-12s %s%s\n"; - - print "$class id = ", $obj->module(), "\n"; - printf $format, 'DESCRIPTION', $obj->description() - if $obj->description(); - - printf $format, 'CPAN_USERID', $aut_obj->cpanid() . " (" . - $aut_obj->author() . " <" . $aut_obj->email() . ">)"; - - printf $format, 'CPAN_VERSION', $obj->version(); - printf $format, 'CPAN_FILE', $obj->path() . '/' . $obj->package(); - - printf $format, 'DSLI_STATUS', $self->_pp_dslip($obj->dslip) - if $obj->dslip() =~ /\w/; - - #printf $format, 'MANPAGE', $obj->foo(); - ### this is for bundles... CPAN.pm downloads them, - #printf $format, 'CONATAINS, - # parses and goes from there... - - printf $format, 'INST_FILE', $obj->installed_file || - '(not installed)'; - printf $format, 'INST_VERSION', $obj->installed_version; - - - - } else { - - ### should look like this: - #Module LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz) - #Module POE (R/RC/RCAPUTO/POE-0.19.tar.gz) - #2 items found - - for my $obj ( @$aref ) { - printf "%-15s %-15s (%s)\n", $class, $obj->module(), - $obj->path() .'/'. $obj->package(); - } - print scalar(@$aref). " items found\n" unless $short; - } - - return $aref; -} - -sub _pp_dslip { - my $self = shift; - my $dslip = shift or return; - - my (%_statusD, %_statusS, %_statusL, %_statusI); - - @_statusD{qw(? i c a b R M S)} = - qw(unknown idea pre-alpha alpha beta released mature standard); - - @_statusS{qw(? m d u n)} = - qw(unknown mailing-list developer comp.lang.perl.* none); - - @_statusL{qw(? p c + o h)} = qw(unknown perl C C++ other hybrid); - @_statusI{qw(? f r O h)} = - qw(unknown functions references+ties object-oriented hybrid); - - my @status = split("", $dslip); - - my $results = sprintf( "%s (%s,%s,%s,%s)", - $dslip, - $_statusD{$status[0]}, - $_statusS{$status[1]}, - $_statusL{$status[2]}, - $_statusI{$status[3]} - ); - - return $results; -} - -sub _pp_distribution { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my( $aref, $short, $class, $input ); - my $tmpl = { - result => { required => 1, default => [], strict_type => 1, - store => \$aref }, - short => { default => 0, store => \$short }, - class => { required => 1, store => \$class }, - input => { required => 1, store => \$input }, - }; - - check( $tmpl, \%hash ) or return; - - - ### no results - if( !@$aref ) { - print "No objects of type $class found for argument $input\n" - unless $short; - - ### one result, long output desired; - } elsif( @$aref == 1 and !$short ) { - - - ### should look like this: - #Distribution id = S/SA/SABECK/POE-Component-Client-POP3-0.02.tar.gz - # CPAN_USERID SABECK (Scott Beck <scott@gossamer-threads.com>) - # CONTAINSMODS POE::Component::Client::POP3 - - my $obj = shift @$aref; - my $aut_obj = $obj->author; - my $pkg = $obj->package; - my $format = " %-12s %s\n"; - - my @list = $cb->search( type => 'package', - allow => [qr/^$pkg$/] ); - - - print "$class id = ", $obj->path(), '/', $obj->package(), "\n"; - printf $format, 'CPAN_USERID', - $aut_obj->cpanid .' ('. $aut_obj->author . - ' '. $aut_obj->email .')'; - - ### yes i know it's ugly, but it's what cpan.pm does - printf $format, 'CONTAINSMODS', join (' ', map { $_->module } @list); - - } else { - - ### should look like this: - #Distribution LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz) - #Distribution POE (R/RC/RCAPUTO/POE-0.19.tar.gz) - #2 items found - - for my $obj ( @$aref ) { - printf "%-15s %s\n", $class, $obj->path() .'/'. $obj->package(); - } - - print scalar(@$aref). " items found\n" unless $short; - } - - return $aref; -} - -sub _pp_uptodate { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my( $aref, $short, $class, $input ); - my $tmpl = { - result => { required => 1, default => [], strict_type => 1, - store => \$aref }, - short => { default => 0, store => \$short }, - class => { required => 1, store => \$class }, - input => { required => 1, store => \$input }, - }; - - check( $tmpl, \%hash ) or return; - - my $format = "%-25s %9s %9s %s\n"; - - my @not_uptodate; - my $no_version; - - my %seen; - for my $mod (@$aref) { - next if $mod->package_is_perl_core; - next if $seen{ $mod->package }++; - - - if( $mod->installed_file and not $mod->installed_version ) { - $no_version++; - next; - } - - push @not_uptodate, $mod unless $mod->is_uptodate; - } - - unless( @not_uptodate ) { - my $string = $input - ? "for $input" - : ''; - print "All modules are up to date $string\n"; - return; - - } else { - printf $format, ( 'Package namespace', - 'installed', - 'latest', - 'in CPAN file' - ); - } - - for my $mod ( sort { $a->module cmp $b->module } @not_uptodate ) { - printf $format, ( $mod->module, - $mod->installed_version, - $mod->version, - $mod->path .'/'. $mod->package, - ); - } - - print "$no_version installed modules have no (parsable) version number\n" - if $no_version; - - return \@not_uptodate; -} - -sub _pp_ls { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my( $aref, $short, $class, $input ); - my $tmpl = { - result => { required => 1, default => [], strict_type => 1, - store => \$aref }, - short => { default => 0, store => \$short }, - class => { required => 1, store => \$class }, - input => { required => 1, store => \$input }, - }; - - check( $tmpl, \%hash ) or return; - - ### should look something like this: - #6272 2002-05-12 KANE/Acme-Comment-1.00.tar.gz - #8171 2002-08-13 KANE/Acme-Comment-1.01.zip - #7110 2002-09-04 KANE/Acme-Comment-1.02.tar.gz - #7571 2002-09-08 KANE/Acme-Intraweb-1.01.tar.gz - #6625 2001-08-23 KANE/Acme-POE-Knee-1.10.zip - #3058 2003-10-05 KANE/Acme-Test-0.02.tar.gz - - ### don't know size or mtime - #my $format = "%8d %10s %s/%s\n"; - - for my $mod ( sort { $a->package cmp $b->package } @$aref ) { - print "\t" . $mod->package . "\n"; - } - - return $aref; -} - - -############################# -### end pretty print subs ### -############################# - - -sub _bang { - my $self = shift; - my %hash = @_; - - my( $input ); - my $tmpl = { - input => { required => 1, store => \$input }, - }; - - check( $tmpl, \%hash ) or return; - - eval $input; - warn $@ if $@; - - print "\n"; - - return; -} - -sub _help { - print qq[ -Display Information - a authors - b string display bundles - d or info distributions - m /regex/ about modules - i or anything of above - r none reinstall recommendations - u uninstalled distributions - -Download, Test, Make, Install... - get download - make make (implies get) - test modules, make test (implies make) - install dists, bundles make install (implies test) - clean make clean - look open subshell in these dists' directories - readme display these dists' README files - -Other - h,? display this menu ! perl-code eval a perl command - o conf [opt] set and query options q quit the cpan shell - reload cpan load CPAN.pm again reload index load newer indices - autobundle Snapshot force cmd unconditionally do cmd -]; - -} - - - -1; -__END__ - -=pod - -=head1 NAME - -CPANPLUS::Shell::Classic - CPAN.pm emulation for CPANPLUS - -=head1 DESCRIPTION - -The Classic shell is designed to provide the feel of the CPAN.pm shell -using CPANPLUS underneath. - -For detailed documentation, refer to L<CPAN>. - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=head1 SEE ALSO - -L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author> - -=cut - - -=head1 SEE ALSO - -L<CPAN> - -=cut - - - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default.pm b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default.pm deleted file mode 100644 index 4c9991d529..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default.pm +++ /dev/null @@ -1,1978 +0,0 @@ -package CPANPLUS::Shell::Default; -use deprecate; - -use strict; - - -use CPANPLUS::Error; -use CPANPLUS::Backend; -use CPANPLUS::Configure::Setup; -use CPANPLUS::Internals::Constants; -use CPANPLUS::Internals::Constants::Report qw[GRADE_FAIL]; - -use Cwd; -use IPC::Cmd; -use Term::UI; -use Data::Dumper; -use Term::ReadLine; - -use Module::Load qw[load]; -use Params::Check qw[check]; -use Module::Load::Conditional qw[can_load check_install]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -local $Params::Check::VERBOSE = 1; -local $Data::Dumper::Indent = 1; # for dumpering from ! - -BEGIN { - use vars qw[ $VERSION @ISA ]; - @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; - $VERSION = "0.9135"; -} - -load CPANPLUS::Shell; - - -my $map = { - 'm' => '_search_module', - 'a' => '_search_author', - '!' => '_bang', - '?' => '_help', - 'h' => '_help', - 'q' => '_quit', - 'r' => '_readme', - 'v' => '_show_banner', - 'w' => '__display_results', - 'd' => '_fetch', - 'z' => '_shell', - 'f' => '_distributions', - 'x' => '_reload_indices', - 'i' => '_install', - 't' => '_install', - 'l' => '_details', - 'p' => '_print', - 's' => '_set_conf', - 'o' => '_uptodate', - 'b' => '_autobundle', - 'u' => '_uninstall', - '/' => '_meta', # undocumented for now - 'c' => '_reports', - 'e' => '_reload_shell', -}; -### free letters: e g j k n y ### - - -### will be filled if you have a .default-shell.rc and -### Config::Auto installed -my $rc = {}; - -### the shell object, scoped to the file ### -my $Shell; -my $Brand = loc('CPAN Terminal'); -my $Prompt = $Brand . '> '; - -=pod - -=head1 NAME - -CPANPLUS::Shell::Default - the default CPANPLUS shell - -=head1 SYNOPSIS - - ### loading the shell: - $ cpanp # run 'cpanp' from the command line - $ perl -MCPANPLUS -eshell # load the shell from the command line - - - use CPANPLUS::Shell qw[Default]; # load this shell via the API - # always done via CPANPLUS::Shell - - my $ui = CPANPLUS::Shell->new; - $ui->shell; # run the shell - $ui->dispatch_on_input( input => 'x'); # update the source using the - # dispatch method - - ### when in the shell: - ### Note that all commands can also take options. - ### Look at their underlying CPANPLUS::Backend methods to see - ### what options those are. - cpanp> h # show help messages - cpanp> ? # show help messages - - cpanp> m Acme # find acme modules, allows regexes - cpanp> a KANE # find modules by kane, allows regexes - cpanp> f Acme::Foo # get a list of all releases of Acme::Foo - - cpanp> i Acme::Foo # install Acme::Foo - cpanp> i Acme-Foo-1.3 # install version 1.3 of Acme::Foo - cpanp> i <URI> # install from URI, like ftp://foo.com/X.tgz - cpanp> i <DIR> # install from an absolute or relative directory - cpanp> i 1 3..5 # install search results 1, 3, 4 and 5 - cpanp> i * # install all search results - cpanp> a KANE; i *; # find modules by kane, install all results - cpanp> t Acme::Foo # test Acme::Foo, without installing it - cpanp> u Acme::Foo # uninstall Acme::Foo - cpanp> d Acme::Foo # download Acme::Foo - cpanp> z Acme::Foo # download & extract Acme::Foo, then open a - # shell in the extraction directory - - cpanp> c Acme::Foo # get a list of test results for Acme::Foo - cpanp> l Acme::Foo # view details about the Acme::Foo package - cpanp> r Acme::Foo # view Acme::Foo's README file - cpanp> o # get a list of all installed modules that - # are out of date - cpanp> o 1..3 # list uptodateness from a previous search - - cpanp> s conf # show config settings - cpanp> s conf md5 1 # enable md5 checks - cpanp> s program # show program settings - cpanp> s edit # edit config file - cpanp> s reconfigure # go through initial configuration again - cpanp> s selfupdate # update your CPANPLUS install - cpanp> s save # save config to disk - cpanp> s mirrors # show currently selected mirrors - - cpanp> ! [PERL CODE] # execute the following perl code - - cpanp> b # create an autobundle for this computers - # perl installation - cpanp> x # reload index files (purges cache) - cpanp> x --update_source # reload index files, get fresh source files - cpanp> p [FILE] # print error stack (to a file) - cpanp> v # show the banner - cpanp> w # show last search results again - - cpanp> q # quit the shell - cpanp> e # exit the shell and reload - - cpanp> /plugins # list available plugins - cpanp> /? PLUGIN # list help test of <PLUGIN> - - ### common options: - cpanp> i ... --skiptest # skip tests - cpanp> i ... --force # force all operations - cpanp> i ... --verbose # run in verbose mode - -=head1 DESCRIPTION - -This module provides the default user interface to C<CPANPLUS>. You -can start it via the C<cpanp> binary, or as detailed in the L<SYNOPSIS>. - -=cut - -sub new { - my $class = shift; - - my $cb = CPANPLUS::Backend->new( @_ ); - my $self = $class->SUPER::_init( - brand => $Brand, - term => Term::ReadLine->new( $Brand ), - prompt => $Prompt, - backend => $cb, - format => "%4s %-55s %8s %-10s\n", - dist_format => "%4s %-42s %-12s %8s %-10s\n", - ); - ### make it available package wide ### - $Shell = $self; - - my $rc_file = File::Spec->catfile( - $cb->configure_object->get_conf('base'), - DOT_SHELL_DEFAULT_RC, - ); - - - if( -e $rc_file && -r _ ) { - $rc = $self->_read_configuration_from_rc( $rc_file ); - } - - ### register install callback ### - $cb->_register_callback( - name => 'install_prerequisite', - code => \&__ask_about_install, - ); - - ### execute any login commands specified ### - $self->dispatch_on_input( input => $rc->{'login'} ) - if defined $rc->{'login'}; - - ### register test report callbacks ### - $cb->_register_callback( - name => 'edit_test_report', - code => \&__ask_about_edit_test_report, - ); - - $cb->_register_callback( - name => 'send_test_report', - code => \&__ask_about_send_test_report, - ); - - $cb->_register_callback( - name => 'proceed_on_test_failure', - code => \&__ask_about_test_failure, - ); - - ### load all the plugins - $self->_plugins_init; - - if (my $histfile = $cb->configure_object->get_conf( 'histfile' )) { - my $term = $self->term; - if ($term->can('AddHistory')) { - if (open my $fh, '<', $histfile) { - local $/ = "\n"; - while (my $line = <$fh>) { - chomp($line); - $term->AddHistory($line); - } - close($fh); - } - } - } - - return $self; -} - -sub shell { - my $self = shift; - my $term = $self->term; - my $conf = $self->backend->configure_object; - - $self->_show_banner; - $self->__print( "*** Type 'p' now to show start up log\n" ); # XXX add to banner? - $self->_show_random_tip if $conf->get_conf('show_startup_tip'); - $self->_input_loop && $self->__print( "\n" ); - $self->_quit; -} - -sub _input_loop { - my $self = shift; - my $term = $self->term; - my $cb = $self->backend; - - my $normal_quit = 0; - while ( - defined (my $input = eval { $term->readline($self->prompt) } ) - or $self->_signals->{INT}{count} == 1 - ) { - ### re-initiate all signal handlers - while (my ($sig, $entry) = each %{$self->_signals} ) { - $SIG{$sig} = $entry->{handler} if exists($entry->{handler}); - } - - $self->__print( "\n" ); - last if $self->dispatch_on_input( input => $input ); - - ### flush the lib cache ### - $cb->_flush( list => [qw|lib load|] ); - - } continue { - ### clear the sigint count - $self->_signals->{INT}{count}-- - if $self->_signals->{INT}{count}; - - ### reset the 'install prereq?' cached answer - $self->settings->{'install_all_prereqs'} = undef; - - } - - return 1; -} - -### return 1 to quit ### -sub dispatch_on_input { - my $self = shift; - my $conf = $self->backend->configure_object(); - my $term = $self->term; - my %hash = @_; - - my($string, $noninteractive); - my $tmpl = { - input => { required => 1, store => \$string }, - noninteractive => { required => 0, store => \$noninteractive }, - }; - - check( $tmpl, \%hash ) or return; - - ### indicates whether or not the user will receive a shell - ### prompt after the command has finished. - $self->noninteractive($noninteractive) if defined $noninteractive; - - my $rv = 1; - - my @cmds = split ';', $string; - while( my $input = shift @cmds ) { - - ### to send over the socket ### - my $org_input = $input; - - my $key; my $options; - { ### make whitespace not count when using special chars - { $input =~ s|^\s*([!?/])|$1 |; } - - ### get the first letter of the input - $input =~ s|^\s*([\w\?\!/])\w*||; - - chomp $input; - $key = lc($1); - - ### we figured out what the command was... - ### if we have more input, that DOES NOT start with a white - ### space char, we misparsed.. like 'Test::Foo::Bar', which - ### would turn into 't', '::Foo::Bar'... - if( $input and $input !~ s/^\s+// ) { - $self->__print( loc("Could not understand command: %1\n". - "Possibly missing command before argument(s)?\n", - $org_input) ); - return; - } - - ### allow overrides from the config file ### - if( defined $rc->{$key} ) { - $input = $rc->{$key} . $input; - } - - ### grab command line options like --no-force and --verbose ### - ($options,$input) = $term->parse_options($input) - unless $key eq '!'; - } - - ### emtpy line? ### - return unless $key; - - ### time to quit ### - return 1 if $key eq 'q'; - - my $method = $map->{$key}; - - ### dispatch meta locally at all times ### - if( $key eq '/' ) { - ### keep track of failures - $rv *= length $self->$method(input => $input, options => $options); - next; - } - - ### flush unless we're trying to print the stack - CPANPLUS::Error->flush unless $key eq 'p'; - - ### connected over a socket? ### - if( $self->remote ) { - - ### unsupported commands ### - if( $key eq 'z' or - ($key eq 's' and $input =~ /^\s*edit/) - ) { - $self->__print( "\n", - loc( "Command '%1' not supported over remote connection", - join ' ', $key, $input - ), "\n\n" ); - - } else { - my($status,$buff) = $self->__send_remote_command($org_input); - - $self->__print( "\n", loc("Command failed!"), "\n\n" ) - unless $status; - - ### keep track of failures - $rv *= length $status; - - $self->_pager_open if $buff =~ tr/\n// > $self->_term_rowcount; - $self->__print( $buff ); - $self->_pager_close; - } - - ### or just a plain local shell? ### - } else { - - unless( $self->can($method) ) { - $self->__print(loc("Unknown command '%1'. Usage:", $key), "\n"); - $self->_help; - - } else { - - ### some methods don't need modules ### - my @mods; - @mods = $self->_select_modules($input) - unless grep {$key eq $_} qw[! m a v w x p s b / ? h]; - - ### keep track of failures - $rv *= defined eval { $self->$method( - modules => \@mods, - options => $options, - input => $input, - choice => $key ) - }; - error( $@ ) if $@; - } - } - } - - ### outside the shell loop, we can return the actual return value; - return $rv if $self->noninteractive; - - return; -} - -sub _select_modules { - my $self = shift; - my $input = shift or return; - my $cache = $self->cache; - my $cb = $self->backend; - - ### expand .. in $input - $input =~ s{\b(\d+)\s*\.\.\s*(\d+)\b} - {join(' ', ($1 < 1 ? 1 : $1) .. ($2 > $#{$cache} ? $#{$cache} : $2))}eg; - - $input = join(' ', 1 .. $#{$cache}) if $input eq '*'; - $input =~ s/'/::/g; # perl 4 convention - - my @rv; - for my $mod (split /\s+/, $input) { - - ### it's a cache look up ### - if( $mod =~ /^\d+/ and $mod > 0 ) { - unless( scalar @$cache ) { - $self->__print( loc("No search was done yet!"), "\n" ); - - } elsif ( my $obj = $cache->[$mod] ) { - push @rv, $obj; - - } else { - $self->__print( loc("No such module: %1", $mod), "\n" ); - } - - } else { - my $obj = $cb->parse_module( module => $mod ); - - unless( $obj ) { - $self->__print( loc("No such module: %1", $mod), "\n" ); - - } else { - push @rv, $obj; - } - } - } - - unless( scalar @rv ) { - $self->__print( loc("No modules found to operate on!\n") ); - return; - } else { - return @rv; - } -} - -sub _format_version { - my $self = shift; - my $version = shift || 0; - - ### fudge $version into the 'optimal' format - $version = 0 if $version eq 'undef'; - $version =~ s/_//g; # everything after gets stripped off otherwise - - ### allow 6 digits after the dot, as that's how perl stringifies - ### x.y.z numbers. - $version = sprintf('%3.6f', $version); - $version = '' if $version == '0.00'; - $version =~ s/(00{0,3})$/' ' x (length $1)/e; - - return $version; -} - -sub __display_results { - my $self = shift; - my $cache = $self->cache; - - my @rv = @$cache; - - if( scalar @rv ) { - - $self->_pager_open if $#{$cache} >= $self->_term_rowcount; - - my $i = 1; - for my $mod (@rv) { - next unless $mod; # first one is undef - # humans start counting at 1 - - ### for dists only -- we have checksum info - if( $mod->mtime ) { - $self->__printf( - $self->dist_format, - $i, - $mod->module, - $mod->mtime, - $self->_format_version( $mod->version ), - $mod->author->cpanid - ); - - } else { - $self->__printf( - $self->format, - $i, - $mod->module, - $self->_format_version( $mod->version ), - $mod->author->cpanid - ); - } - $i++; - } - - $self->_pager_close; - - } else { - $self->__print( loc("No results to display"), "\n" ); - } - - return 1; -} - - -sub _quit { - my $self = shift; - my $term = $self->term; - - $self->dispatch_on_input( input => $rc->{'logout'} ) - if defined $rc->{'logout'}; - - if ($term->can('GetHistory')) { - my @history = $term->GetHistory; - - my $histfile = $self->backend->configure_object->get_conf('histfile'); - - if (open my $fh, '>', $histfile) { - foreach my $line (@history) { - print {$fh} "$line\n"; - } - close($fh); - } - else { - warn "Cannot open history file '$histfile' - $!"; - } - } - - $self->__print( loc("Exiting CPANPLUS shell"), "\n" ); - - return 1; -} - -########################### -### actual command subs ### -########################### - - -### print out the help message ### -### perhaps, '?' should be a slightly different version ### -{ my @help; - sub _help { - my $self = shift; - my %hash = @_; - - my $input; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - input => { required => 0, store => \$input } - }; - - my $args = check( $tmpl, \%hash ) or return; - } - - @help = ( -loc('[General]' ), -loc(' h | ? # display help' ), -loc(' q # exit' ), -loc(' e # exit and reload' ), -loc(' v # version information' ), -loc('[Search]' ), -loc(' a AUTHOR ... # search by author(s)' ), -loc(' m MODULE ... # search by module(s)' ), -loc(' f MODULE ... # list all releases of a module' ), -loc(" o [ MODULE ... ] # list installed module(s) that aren't up to date" ), -loc(' w # display the result of your last search again' ), -loc('[Operations]' ), -loc(' i MODULE | NUMBER ... # install module(s), by name or by search number' ), -loc(' i URI | ... # install module(s), by URI (ie http://foo.com/X.tgz)' ), -loc(' i DIR | ... # install module(s), by path (ie ./Module-1.0)' ), -loc(' t MODULE | NUMBER ... # test module(s), by name or by search number' ), -loc(' u MODULE | NUMBER ... # uninstall module(s), by name or by search number' ), -loc(' d MODULE | NUMBER ... # download module(s)' ), -loc(' l MODULE | NUMBER ... # display detailed information about module(s)' ), -loc(' r MODULE | NUMBER ... # display README files of module(s)' ), -loc(' c MODULE | NUMBER ... # check for module report(s) from cpan-testers' ), -loc(' z MODULE | NUMBER ... # extract module(s) and open command prompt in it' ), -loc('[Local Administration]' ), -loc(' b # write a bundle file for your configuration' ), -loc(' s program [OPT VALUE] # set program locations for this session' ), -loc(' s conf [OPT VALUE] # set config options for this session' ), -loc(' s mirrors # show currently selected mirrors' ), -loc(' s reconfigure # reconfigure settings ' ), -loc(' s selfupdate # update your CPANPLUS install '), -loc(' s save [user|system] # save settings for this user or systemwide' ), -loc(' s edit [user|system] # open configuration file in editor and reload' ), -loc(' ! EXPR # evaluate a perl statement' ), -loc(' p [FILE] # print the error stack (optionally to a file)' ), -loc(' x # reload CPAN indices (purges cache)' ), -loc(' x --update_source # reload CPAN indices, get fresh source files' ), -loc('[Common Options]' ), -loc(' i ... --skiptest # skip tests' ), -loc(' i ... --force # force all operations' ), -loc(' i ... --verbose # run in verbose mode' ), -loc('[Plugins]' ), -loc(' /plugins # list available plugins' ), -loc(' /? [PLUGIN NAME] # show usage for (a particular) plugin(s)' ), - - ) unless @help; - - $self->_pager_open if (@help >= $self->_term_rowcount); - ### XXX: functional placeholder for actual 'detailed' help. - $self->__print( "Detailed help for the command '$input' is " . - "not available.\n\n" ) if length $input; - $self->__print( map {"$_\n"} @help ); - $self->__print( $/ ); - $self->_pager_close; - - return 1; - } -} - -### eval some code ### -sub _bang { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - - my $input; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - input => { required => 1, store => \$input } - }; - - my $args = check( $tmpl, \%hash ) or return; - } - - local $Data::Dumper::Indent = 1; # for dumpering from ! - eval $input; - error( $@ ) if $@; - $self->__print( "\n" ); - - return if $@; - return 1; -} - -sub _search_module { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my $args; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - input => { required => 1, }, - options => { default => { } }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'}; - - ### XXX this is rather slow, because (probably) - ### of the many method calls - ### XXX need to profile to speed it up =/ - - ### find the modules ### - my @rv = sort { $a->module cmp $b->module } - $cb->search( - %{$args->{'options'}}, - type => 'module', - allow => \@regexes, - ); - - ### store the result in the cache ### - $self->cache([undef,@rv]); - - $self->__display_results; - - return 1; -} - -sub _search_author { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my $args; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - input => { required => 1, }, - options => { default => { } }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'}; - - my @rv; - for my $type (qw[author cpanid]) { - push @rv, $cb->search( - %{$args->{'options'}}, - type => $type, - allow => \@regexes, - ); - } - - my %seen; - my @list = sort { $a->module cmp $b->module } - grep { defined } - map { $_->modules } - grep { not $seen{$_}++ } @rv; - - $self->cache([undef,@list]); - - $self->__display_results; - return 1; -} - -sub _readme { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my $args; my $mods; my $opts; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - modules => { required => 1, store => \$mods }, - options => { default => { }, store => \$opts }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - return unless scalar @$mods; - - $self->_pager_open; - for my $mod ( @$mods ) { - $self->__print( $mod->readme( %$opts ) ); - } - - $self->_pager_close; - - return 1; -} - -sub _fetch { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my $args; my $mods; my $opts; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - modules => { required => 1, store => \$mods }, - options => { default => { }, store => \$opts }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - $self->_pager_open if @$mods >= $self->_term_rowcount; - my $rv = 1; - for my $mod (@$mods) { - my $where = $mod->fetch( %$opts ); - - $rv *= length $where; - - $self->__print( - $where - ? loc("Successfully fetched '%1' to '%2'", - $mod->module, $where ) - : loc("Failed to fetch '%1'", $mod->module) - ); - $self->__print( "\n" ); - } - $self->_pager_close; - - return 1 if $rv; - return; -} - -sub _shell { - my $self = shift; - my $cb = $self->backend; - my $conf = $cb->configure_object; - my %hash = @_; - - my $shell = $conf->get_program('shell'); - unless( $shell ) { - $self->__print( - loc("Your config does not specify a subshell!"), "\n", - loc("Perhaps you need to re-run your setup?"), "\n" - ); - return; - } - - my $args; my $mods; my $opts; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - modules => { required => 1, store => \$mods }, - options => { default => { }, store => \$opts }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - my $cwd = Cwd::cwd(); - for my $mod (@$mods) { - $mod->fetch( %$opts ) or next; - $mod->extract( %$opts ) or next; - - $cb->_chdir( dir => $mod->status->extract() ) or next; - - #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt; - - if( system($shell) and $! ) { - $self->__print( - loc("Error executing your subshell '%1': %2", - $shell, $!),"\n" - ); - next; - } - } - $cb->_chdir( dir => $cwd ); - - return 1; -} - -sub _distributions { - my $self = shift; - my $cb = $self->backend; - my $conf = $cb->configure_object; - my %hash = @_; - - my $args; my $mods; my $opts; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - modules => { required => 1, store => \$mods }, - options => { default => { }, store => \$opts }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - my @list; - for my $mod (@$mods) { - push @list, sort { $a->version <=> $b->version } - grep { defined } $mod->distributions( %$opts ); - } - - my @rv = sort { $a->module cmp $b->module } @list; - - $self->cache([undef,@rv]); - $self->__display_results; - - return 1; -} - -sub _reload_indices { - my $self = shift; - my $cb = $self->backend; - my %hash = @_; - - my $args; my $opts; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - options => { default => { }, store => \$opts }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - my $rv = $cb->reload_indices( %$opts ); - - ### so the update failed, but you didnt give it any options either - if( !$rv and !(keys %$opts) ) { - $self->__print( - "\nFailure may be due to corrupt source files\n" . - "Try this:\n\tx --update_source\n\n" ); - } - - return $rv; - -} - -sub _install { - my $self = shift; - my $cb = $self->backend; - my $conf = $cb->configure_object; - my %hash = @_; - - my $args; my $mods; my $opts; my $choice; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - modules => { required => 1, store => \$mods }, - options => { default => { }, store => \$opts }, - choice => { required => 1, store => \$choice, - allow => [qw|i t|] }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - unless( scalar @$mods ) { - $self->__print( loc("Nothing done\n") ); - return; - } - - my $target = $choice eq 'i' ? TARGET_INSTALL : TARGET_CREATE; - my $prompt = $choice eq 'i' ? loc('Installing ') : loc('Testing '); - my $action = $choice eq 'i' ? 'install' : 'test'; - - my $status = {}; - ### first loop over the mods to install them ### - for my $mod (@$mods) { - $self->__print( $prompt, $mod->module, " (".$mod->version.")", "\n" ); - - my $log_length = length CPANPLUS::Error->stack_as_string; - - ### store the status for look up when we're done with all - ### install calls - $status->{$mod} = $mod->install( %$opts, target => $target ); - - ### would you like a log file of what happened? - if( $conf->get_conf('write_install_logs') ) { - - if ( ON_WIN32 and !check_install( - module => 'IPC::Run', version => 0.55 ) - ) { - error(loc("IPC::Run version '%1' is required on MSWin32" - . " in order to capture buffers." - . " The logfile generated may not contain" - . " any useful data, until it is installed", 0.55)); - } - - my $dir = File::Spec->catdir( - $conf->get_conf('base'), - $conf->_get_build('install_log_dir'), - ); - ### create the dir if it doesn't exit yet - $cb->_mkdir( dir => $dir ) unless -d $dir; - - my $file = File::Spec->catfile( - $dir, - INSTALL_LOG_FILE->( $mod ) - ); - if ( open my $fh, ">$file" ) { - my $stack = CPANPLUS::Error->stack_as_string; - ### remove everything in the log that was there *before* - ### we started this install - substr( $stack, 0, $log_length, '' ); - - print $fh $stack; - close $fh; - - $self->__print( - loc("*** Install log written to:\n %1\n\n", $file) - ); - } else { - warn "Could not open '$file': $!\n"; - next; - } - } - } - - my $flag; - ### then report whether all this went ok or not ### - for my $mod (@$mods) { - # if( $mod->status->installed ) { - if( $status->{$mod} ) { - $self->__print( - loc("Module '%1' %tense(%2,past) successfully\n", - $mod->module, $action) - ); - } else { - $flag++; - $self->__print( - loc("Error %tense(%1,present) '%2'\n", $action, $mod->module) - ); - } - } - - - - if( !$flag ) { - $self->__print( - loc("No errors %tense(%1,present) all modules", $action), "\n" - ); - } else { - $self->__print( - loc("Problem %tense(%1,present) one or more modules", $action) - ); - $self->__print( "\n" ); - - $self->__print( - loc("*** You can view the complete error buffer by pressing ". - "'%1' ***\n", 'p') - ) unless $conf->get_conf('verbose') || $self->noninteractive; - } - $self->__print( "\n" ); - - return !$flag; -} - -sub __ask_about_install { - my $mod = shift or return; - my $prereq = shift or return; - my $term = $Shell->term; - - $Shell->__print( "\n" ); - $Shell->__print( loc("Module '%1' requires '%2' to be installed", - $mod->module, $prereq->module ) ); - $Shell->__print( "\n\n" ); - - ### previously cached answer? - return $Shell->settings->{'install_all_prereqs'} - if defined $Shell->settings->{'install_all_prereqs'}; - - - $Shell->__print( - loc( "If you don't wish to see this question anymore\n". - "you can disable it by entering the following ". - "commands on the prompt:\n '%1'", - 's conf prereqs 1; s save' ) ); - $Shell->__print("\n\n"); - - my $yes = loc("Yes"); - my $no = loc("No"); - my $all = loc("Yes to all (for this module)"); - my $none = loc("No to all (for this module)"); - - my $reply = $term->get_reply( - prompt => loc("Should I install this module?"), - choices => [ $yes, $no, $all, $none ], - default => $yes, - ); - - ### if 'all' or 'none', save this, so we can apply it to - ### other prereqs in this chain. - $Shell->settings->{'install_all_prereqs'} = - $reply eq $all ? 1 : - $reply eq $none ? 0 : - undef; - - ### if 'yes' or 'all', the user wants it installed - return $reply eq $all ? 1 : - $reply eq $yes ? 1 : - 0; -} - -sub __ask_about_send_test_report { - my($mod, $grade) = @_; - return 1 unless $grade eq GRADE_FAIL; - - my $term = $Shell->term; - - $Shell->__print( "\n" ); - $Shell->__print( - loc("Test report prepared for module '%1'.\n Would you like to ". - "send it? (You can edit it if you like)", $mod->module ) ); - $Shell->__print( "\n\n" ); - my $bool = $term->ask_yn( - prompt => loc("Would you like to send the test report?"), - default => 'n' - ); - - return $bool; -} - -sub __ask_about_edit_test_report { - my($mod, $grade) = @_; - return 0 unless $grade eq GRADE_FAIL; - - my $term = $Shell->term; - - $Shell->__print( "\n" ); - $Shell->__print( - loc("Test report prepared for module '%1'. You can edit this ". - "report if you would like", $mod->module ) ); - $Shell->__print("\n\n"); - my $bool = $term->ask_yn( - prompt => loc("Would you like to edit the test report?"), - default => 'y' - ); - - return $bool; -} - -sub __ask_about_test_failure { - my $mod = shift; - my $captured = shift || ''; - my $term = $Shell->term; - - $Shell->__print( "\n" ); - $Shell->__print( - loc( "The tests for '%1' failed. Would you like me to proceed ". - "anyway or should we abort?", $mod->module ) ); - $Shell->__print( "\n\n" ); - - my $bool = $term->ask_yn( - prompt => loc("Proceed anyway?"), - default => 'n', - ); - - return $bool; -} - - -sub _details { - my $self = shift; - my $cb = $self->backend; - my $conf = $cb->configure_object; - my %hash = @_; - - my $args; my $mods; my $opts; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - modules => { required => 1, store => \$mods }, - options => { default => { }, store => \$opts }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - ### every module has about 10 lines of details - ### maybe more later with Module::CPANTS etc - $self->_pager_open if scalar @$mods * 10 > $self->_term_rowcount; - - - my $format = "%-24s %-45s\n"; - my $cformat = "%-24s %-45s %-10s\n"; - for my $mod (@$mods) { - my $href = $mod->details( %$opts ); - my @list = sort { $a->module cmp $b->module } $mod->contains; - - unless( $href ) { - $self->__print( - loc("No details for %1 - it might be outdated.", - $mod->module), "\n" ); - next; - - } else { - $self->__print( loc( "Details for '%1'\n", $mod->module ) ); - for my $item ( sort keys %$href ) { - $self->__printf( $format, $item, $href->{$item} ); - } - - my $showed; - for my $item ( @list ) { - $self->__printf( - $cformat, ($showed ? '' : 'Contains:'), - $item->module, $item->version - ); - $showed++; - } - $self->__print( "\n" ); - } - } - $self->_pager_close; - $self->__print( "\n" ); - - return 1; -} - -sub _print { - my $self = shift; - my %hash = @_; - - my $args; my $opts; my $file; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - options => { default => { }, store => \$opts }, - input => { default => '', store => \$file }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - my $old; my $fh; - if( $file ) { - $fh = FileHandle->new( ">$file" ) - or( warn loc("Could not open '%1': '%2'", $file, $!), - return - ); - $old = select $fh; - } - - - $self->_pager_open if !$file; - - $self->__print( CPANPLUS::Error->stack_as_string ); - - $self->_pager_close; - - select $old if $old; - $self->__print( "\n" ); - - return 1; -} - -sub _set_conf { - my $self = shift; - my %hash = @_; - my $cb = $self->backend; - my $conf = $cb->configure_object; - - ### possible options - ### XXX hard coded, not optimal :( - my %types = ( - reconfigure => '', - save => q([user | system | boxed]), - edit => '', - program => q([key => val]), - conf => q([key => val]), - mirrors => '', - selfupdate => '', # XXX add all opts here? - ); - - - my $args; my $opts; my $input; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - options => { default => { }, store => \$opts }, - input => { default => '', store => \$input }, - }; - - $args = check( $tmpl, \%hash ) or return; - } - - my ($type,$key,$value) = $input =~ m/(\w+)\s*(\w*)\s*(.*?)$/; - $value =~ s/\s+$//g if $value; - $type = '' unless defined $type; - $type = lc $type; - - if( $type eq 'reconfigure' ) { - my $setup = CPANPLUS::Configure::Setup->new( - configure_object => $conf, - term => $self->term, - backend => $cb, - ); - return $setup->init; - - } elsif ( $type eq 'save' ) { - my $where = { - user => CONFIG_USER, - system => CONFIG_SYSTEM, - boxed => CONFIG_BOXED, - }->{ $key } || CONFIG_USER; - - ### boxed is special, so let's get its value from %INC - ### so we can tell it where to save - ### XXX perhaps this logic should be generic for all - ### types, and put in the ->save() routine - my $dir; - if( $where eq CONFIG_BOXED ) { - my $file = join( '/', split( '::', CONFIG_BOXED ) ) . '.pm'; - my $file_re = quotemeta($file); - - my $path = $INC{$file} || ''; - $path =~ s/$file_re$//; - $dir = $path; - } - - my $rv = $cb->configure_object->save( $where => $dir ); - - $self->__print( - $rv - ? loc("Configuration successfully saved to %1\n (%2)\n", - $where, $rv) - : loc("Failed to save configuration\n" ) - ); - return $rv; - - } elsif ( $type eq 'edit' ) { - - my $editor = $conf->get_program('editor') - or( print(loc("No editor specified")), return ); - - my $where = { - user => CONFIG_USER, - system => CONFIG_SYSTEM, - }->{ $key } || CONFIG_USER; - - my $file = $conf->_config_pm_to_file( $where ); - system($editor,$file); - - ### now reload it - ### disable warnings for this - { require Module::Loaded; - Module::Loaded::mark_as_unloaded( $where ); - - ### reinitialize the config - local $^W; - $conf->init; - } - - return 1; - - } elsif ( $type eq 'mirrors' ) { - - $self->__print( - loc("Readonly list of mirrors (in order of preference):\n\n" ) ); - - my $i; - for my $host ( @{$conf->get_conf('hosts')} ) { - my $uri = $cb->_host_to_uri( %$host ); - - $i++; - $self->__print( "\t[$i] $uri\n" ); - } - - $self->__print( - loc("\nTo edit this list, please type: '%1'\n", 's edit') ); - - } elsif ( $type eq 'selfupdate' ) { - my %valid = map { $_ => $_ } - $cb->selfupdate_object->list_categories; - - unless( $valid{$key} ) { - $self->__print( - loc( "To update your current CPANPLUS installation, ". - "choose one of the these options:\n%1", - ( join $/, map { - sprintf "\ts selfupdate %-17s " . - "[--latest=0] [--dryrun]", $_ - } sort keys %valid ) - ) - ); - } else { - my %update_args = ( - update => $key, - latest => 1, - %$opts - ); - - - my %list = $cb->selfupdate_object - ->list_modules_to_update( %update_args ); - - $self->__print(loc("The following updates will take place:"),$/.$/); - - for my $feature ( sort keys %list ) { - my $aref = $list{$feature}; - - ### is it a 'feature' or a built in? - $self->__print( - $valid{$feature} - ? " " . ucfirst($feature) . ":\n" - : " Modules for '$feature' support:\n" - ); - - ### show what modules would be installed - $self->__print( - scalar @$aref - ? map { sprintf " %-42s %-6s -> %-6s \n", - $_->name, $_->installed_version, $_->version - } @$aref - : " No upgrades required\n" - ); - $self->__print( $/ ); - } - - - unless( $opts->{'dryrun'} ) { - $self->__print( loc("Updating your CPANPLUS installation\n") ); - $cb->selfupdate_object->selfupdate( %update_args ); - } - } - - } else { - - if ( $type eq 'program' or $type eq 'conf' ) { - - my $format = { - conf => '%-25s %s', - program => '%-12s %s', - }->{ $type }; - - unless( $key ) { - my @list = grep { $_ ne 'hosts' } - $conf->options( type => $type ); - - my $method = 'get_' . $type; - - local $Data::Dumper::Indent = 0; - for my $name ( @list ) { - my $val = $conf->$method($name) || ''; - ($val) = ref($val) - ? (Data::Dumper::Dumper($val) =~ /= (.*);$/) - : "'$val'"; - - $self->__printf( " $format\n", $name, $val ); - } - - } elsif ( $key eq 'hosts' or $key eq 'lib' ) { - $self->__print( - loc( "Setting %1 is not trivial.\n" . - "It is suggested you use '%2' and edit the " . - "configuration file manually", $key, 's edit') - ); - } else { - my $method = 'set_' . $type; - $conf->$method( $key => defined $value ? $value : '' ) - and $self->__print( loc("Key '%1' was set to '%2'", $key, - defined $value ? $value : 'EMPTY STRING') ); - } - - } else { - $self->__print( loc("Unknown type '%1'",$type || 'EMPTY' ) ); - $self->__print( $/ ); - $self->__print( loc("Try one of the following:") ); - $self->__print( $/, join $/, - map { sprintf "\t%-11s %s", $_, $types{$_} } - sort keys %types ); - } - } - $self->__print( "\n" ); - return 1; -} - -sub _uptodate { - my $self = shift; - my %hash = @_; - my $cb = $self->backend; - my $conf = $cb->configure_object; - - my $opts; my $mods; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - options => { default => { }, store => \$opts }, - modules => { required => 1, store => \$mods }, - }; - - check( $tmpl, \%hash ) or return; - } - - ### long listing? short is default ### - my $long = $opts->{'long'} ? 1 : 0; - - my @list = scalar @$mods ? @$mods : @{$cb->_all_installed}; - - my @rv; my %seen; - for my $mod (@list) { - ### skip this mod if it's up to date ### - next if $mod->is_uptodate; - ### skip this mod if it's core ### - next if $mod->package_is_perl_core; - - if( $long or !$seen{$mod->package}++ ) { - push @rv, $mod; - } - } - - @rv = sort { $a->module cmp $b->module } @rv; - - $self->cache([undef,@rv]); - - $self->_pager_open if scalar @rv >= $self->_term_rowcount; - - my $format = "%5s %12s %12s %-36s %-10s\n"; - - my $i = 1; - for my $mod ( @rv ) { - $self->__printf( - $format, - $i, - $self->_format_version($mod->installed_version) || 'Unparsable', - $self->_format_version( $mod->version ), - $mod->module, - $mod->author->cpanid - ); - $i++; - } - $self->_pager_close; - - return 1; -} - -sub _autobundle { - my $self = shift; - my %hash = @_; - my $cb = $self->backend; - my $conf = $cb->configure_object; - - my $opts; my $input; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - options => { default => { }, store => \$opts }, - input => { default => '', store => \$input }, - }; - - check( $tmpl, \%hash ) or return; - } - - $opts->{'path'} = $input if $input; - - my $where = $cb->autobundle( %$opts ); - - $self->__print( - $where - ? loc("Wrote autobundle to '%1'", $where) - : loc("Could not create autobundle" ) - ); - $self->__print( "\n" ); - - return $where ? 1 : 0; -} - -sub _uninstall { - my $self = shift; - my %hash = @_; - my $cb = $self->backend; - my $term = $self->term; - my $conf = $cb->configure_object; - - my $opts; my $mods; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - options => { default => { }, store => \$opts }, - modules => { default => [], store => \$mods }, - }; - - check( $tmpl, \%hash ) or return; - } - - my $force = $opts->{'force'} || $conf->get_conf('force'); - - unless( $force ) { - my $list = join "\n", map { ' ' . $_->module } @$mods; - - $self->__print( loc(" -This will uninstall the following modules: -%1 - -Note that if you installed them via a package manager, you probably -should use the same package manager to uninstall them - -", $list) ); - - return unless $term->ask_yn( - prompt => loc("Are you sure you want to continue?"), - default => 'n', - ); - } - - ### first loop over all the modules to uninstall them ### - for my $mod (@$mods) { - $self->__print( loc("Uninstalling '%1'", $mod->module), "\n" ); - - $mod->uninstall( %$opts ); - } - - my $flag; - ### then report whether all this went ok or not ### - for my $mod (@$mods) { - if( $mod->status->uninstall ) { - $self->__print( - loc("Module '%1' %tense(uninstall,past) successfully\n", - $mod->module ) ); - } else { - $flag++; - $self->__print( - loc("Error %tense(uninstall,present) '%1'\n", $mod->module) ); - } - } - - if( !$flag ) { - $self->__print( - loc("All modules %tense(uninstall,past) successfully"), "\n" ); - } else { - $self->__print( - loc("Problem %tense(uninstall,present) one or more modules" ), - "\n" ); - - $self->__print( - loc("*** You can view the complete error buffer by pressing '%1'". - "***\n", 'p') ) unless $conf->get_conf('verbose'); - } - $self->__print( "\n" ); - - return !$flag; -} - -sub _reports { - my $self = shift; - my %hash = @_; - my $cb = $self->backend; - my $term = $self->term; - my $conf = $cb->configure_object; - - my $opts; my $mods; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - options => { default => { }, store => \$opts }, - modules => { default => '', store => \$mods }, - }; - - check( $tmpl, \%hash ) or return; - } - - ### XXX might need to be conditional ### - $self->_pager_open; - - for my $mod (@$mods) { - my @list = $mod->fetch_report( %$opts ) - or( print(loc("No reports available for this distribution.")), - next - ); - - @list = reverse - map { $_->[0] } - sort { $a->[1] cmp $b->[1] } - map { [$_, $_->{'dist'}.':'.$_->{'platform'}] } @list; - - - - ### XXX this may need to be sorted better somehow ### - my $url; - my $format = "%8s %s %s\n"; - - my %seen; - for my $href (@list ) { - $self->__print( - "[" . $mod->author->cpanid .'/'. $href->{'dist'} . "]\n" - ) unless $seen{ $href->{'dist'} }++; - - $self->__printf( - $format, - $href->{'grade'}, - $href->{'platform'}, - ($href->{'details'} ? '(*)' : '') - ); - - $url ||= $href->{'details'}; - } - - $self->__print( "\n==> $url\n" ) if $url; - $self->__print( "\n" ); - } - $self->_pager_close; - - return 1; -} - -### Load plugins -{ my @PluginModules; - my %Dispatch = ( - showtip => [ __PACKAGE__, '_show_random_tip'], - plugins => [ __PACKAGE__, '_list_plugins' ], - '?' => [ __PACKAGE__, '_plugins_usage' ], - ); - - sub plugin_modules { return @PluginModules } - sub plugin_table { return %Dispatch } - - my $init_done; - sub _plugins_init { - - ### only initialize once - return if $init_done++; - - ### find all plugins first - if( check_install( module => 'Module::Pluggable', version => '2.4') ) { - require Module::Pluggable; - - my $only_re = __PACKAGE__ . '::Plugins::\w+$'; - - Module::Pluggable->import( - sub_name => '_plugins', - search_path => __PACKAGE__, - only => qr/$only_re/, - #except => [ INSTALLER_MM, INSTALLER_SAMPLE ] - ); - - push @PluginModules, __PACKAGE__->_plugins; - } - - ### now try to load them - for my $p ( __PACKAGE__->plugin_modules ) { - my %map = eval { load $p; $p->import; $p->plugins }; - error(loc("Could not load plugin '$p': $@")), next if $@; - - ### register each plugin - while( my($name, $func) = each %map ) { - - if( not length $name or not length $func ) { - error(loc("Empty plugin name or dispatch function detected")); - next; - } - - if( exists( $Dispatch{$name} ) ) { - error(loc("'%1' is already registered by '%2'", - $name, $Dispatch{$name}->[0])); - next; - } - - ### register name, package and function - $Dispatch{$name} = [ $p, $func ]; - } - } - } - - ### dispatch a plugin command to its function - sub _meta { - my $self = shift; - my %hash = @_; - my $cb = $self->backend; - my $term = $self->term; - my $conf = $cb->configure_object; - - my $opts; my $input; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - options => { default => { }, store => \$opts }, - input => { default => '', store => \$input }, - }; - - check( $tmpl, \%hash ) or return; - } - - $input =~ s/\s*(\S+)\s*//; - my $cmd = $1; - - ### look up the command, or go to the default - my $aref = $Dispatch{ $cmd } || [ __PACKAGE__, '_plugin_default' ]; - - my($pkg,$func) = @$aref; - - my $rv = eval { $pkg->$func( $self, $cb, $cmd, $input, $opts ) }; - - error( $@ ) if $@; - - ### return $rv instead, so input loop can be terminated? - return 1; - } - - sub _plugin_default { error(loc("No such plugin command")) } -} - -### plugin commands -{ my $help_format = " /%-21s # %s\n"; - - sub _list_plugins { - my $self = shift; - - $self->__print( loc("Available plugins:\n") ); - $self->__print( loc(" List usage by using: /? PLUGIN_NAME\n" ) ); - $self->__print( $/ ); - - my %table = __PACKAGE__->plugin_table; - for my $name( sort keys %table ) { - my $pkg = $table{$name}->[0]; - my $this = __PACKAGE__; - - my $who = $pkg eq $this - ? "Standard Plugin" - : do { my $v = $self->_format_version($pkg->VERSION) || ''; - $pkg =~ s/^$this/../; - sprintf "Provided by: %-30s %-10s", $pkg, $v; - }; - - $self->__printf( $help_format, $name, $who ); - } - - $self->__print( $/.$/ ); - - $self->__print( - " Write your own plugins? Read the documentation of:\n" . - " CPANPLUS::Shell::Default::Plugins::HOWTO\n" ); - - $self->__print( $/ ); - } - - sub _list_plugins_help { - return sprintf $help_format, 'plugins', loc("lists available plugins"); - } - - ### registered as a plugin too - sub _show_random_tip_help { - return sprintf $help_format, 'showtip', loc("show usage tips" ); - } - - sub _plugins_usage { - my $self = shift; - my $shell = shift; - my $cb = shift; - my $cmd = shift; - my $input = shift; - my %table = $self->plugin_table; - - my @list = length $input ? split /\s+/, $input : sort keys %table; - - for my $name( @list ) { - - ### no such plugin? skip - error(loc("No such plugin '$name'")), next unless $table{$name}; - - my $pkg = $table{$name}->[0]; - my $func = $table{$name}->[1] . '_help'; - - if ( my $sub = $pkg->can( $func ) ) { - eval { $self->__print( $sub->() ) }; - error( $@ ) if $@; - - } else { - $self->__print(" No usage for '$name' -- try perldoc $pkg"); - } - - $self->__print( $/ ); - } - - $self->__print( $/.$/ ); - } - - sub _plugins_usage_help { - return sprintf $help_format, '? [NAME ...]', - loc("show usage for plugins"); - } -} - -### send a command to a remote host, retrieve the answer; -sub __send_remote_command { - my $self = shift; - my $cmd = shift; - my $remote = $self->remote or return; - my $user = $remote->{'username'}; - my $pass = $remote->{'password'}; - my $conn = $remote->{'connection'}; - my $end = "\015\012"; - my $answer; - - my $send = join "\0", $user, $pass, $cmd; - - print $conn $send . $end; - - ### XXX why doesn't something like this just work? - #1 while recv($conn, $answer, 1024, 0); - while(1) { - my $buff; - $conn->recv( $buff, 1024, 0 ); - $answer .= $buff; - last if $buff =~ /$end$/; - } - - my($status,$buffer) = split "\0", $answer; - - return ($status, $buffer); -} - - -sub _read_configuration_from_rc { - my $self = shift; - my $rc_file = shift; - - my $href; - if( can_load( modules => { 'Config::Auto' => '0.0' } ) ) { - $Config::Auto::DisablePerl = 1; - - eval { $href = Config::Auto::parse( $rc_file, format => 'space' ) }; - - $self->__print( - loc( "Unable to read in config file '%1': %2", $rc_file, $@ ) - ) if $@; - } - - return $href || {}; -} - -{ my @tips = ( - loc( "You can update CPANPLUS by running: '%1'", 's selfupdate' ), - loc( "You can install modules by URL using '%1'", 'i URL' ), - loc( "You can turn off these tips using '%1'", - 's conf show_startup_tip 0' ), - loc( "You can use wildcards like '%1' and '%2' on search results", - '*', '2..5' ) , - loc( "You can use plugins. Type '%1' to list available plugins", - '/plugins' ), - loc( "You can show all your out of date modules using '%1'", 'o' ), - loc( "Many operations take options, like '%1', '%2' or '%3'", - '--verbose', '--force', '--skiptest' ), - loc( "The documentation in %1 and %2 is very useful", - "CPANPLUS::Module", "CPANPLUS::Backend" ), - loc( "You can type '%1' for help and '%2' to exit", 'h', 'q' ), - loc( "You can run an interactive setup using '%1'", 's reconfigure' ), - loc( "You can add custom sources to your index. See '%1' for details", - '/cs --help' ), - loc( "CPANPLUS now has an experimental SQLite backend. You can enable ". - "it via: '%1'. Update dependencies via '%2'", - 's conf source_engine CPANPLUS::Internals::Source::SQLite; s save', - 's selfupdate enabled_features ' ), - ); - - sub _show_random_tip { - my $self = shift; - $self->__print( $/, "Did you know...\n ", - $tips[ int rand scalar @tips ], $/ ); - return 1; - } -} - -sub _reload_shell { - { exec ($^X, '-MCPANPLUS', '-e', 'shell') }; print STDERR "couldn't exec foo: $!"; -} - -1; - -__END__ - -=pod - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=head1 SEE ALSO - -L<CPANPLUS::Shell::Classic>, L<CPANPLUS::Shell>, L<cpanp> - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - -__END__ - -TODO: - e => "_expand_inc", # scratch it, imho -- not used enough - -### free letters: g j k n y ### diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm deleted file mode 100644 index 1c77ae24f5..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm +++ /dev/null @@ -1,205 +0,0 @@ -package CPANPLUS::Shell::Default::Plugins::CustomSource; -use deprecate; - -use strict; -use CPANPLUS::Error qw[error msg]; -use CPANPLUS::Internals::Constants; - -use Data::Dumper; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -=head1 NAME - -CPANPLUS::Shell::Default::Plugins::CustomSource - add custom sources to CPANPLUS - -=head1 SYNOPSIS - - ### elaborate help text - CPAN Terminal> /? cs - - ### add a new custom source - CPAN Terminal> /cs --add file:///path/to/releases - - ### list all your custom sources by - CPAN Terminal> /cs --list - - ### display the contents of a custom source by URI or ID - CPAN Terminal> /cs --contents file:///path/to/releases - CPAN Terminal> /cs --contents 1 - - ### Update a custom source by URI or ID - CPAN Terminal> /cs --update file:///path/to/releases - CPAN Terminal> /cs --update 1 - - ### Remove a custom source by URI or ID - CPAN Terminal> /cs --remove file:///path/to/releases - CPAN Terminal> /cs --remove 1 - - ### Write an index file for a custom source, to share - ### with 3rd parties or remote users - CPAN Terminal> /cs --write file:///path/to/releases - - ### Make sure to save your sources when adding/removing - ### sources, so your changes are reflected in the cache: - CPAN Terminal> x - -=head1 DESCRIPTION - -This is a C<CPANPLUS::Shell::Default> plugin that can add -custom sources to your CPANPLUS installation. This is a -wrapper around the C<custom module sources> code as outlined -in L<CPANPLUS::Backend/CUSTOM MODULE SOURCES>. - -This allows you to extend your index of available modules -beyond what's available on C<CPAN> with your own local -distributions, or ones offered by third parties. - -=cut - - -sub plugins { - return ( cs => 'custom_source' ) -} - -my $Cb; -my $Shell; -my @Index = (); - -sub _uri_from_cache { - my $self = shift; - my $input = shift or return; - - ### you gave us a search number - my $uri = $input =~ /^\d+$/ - ? $Index[ $input - 1 ] # remember, off by 1! - : $input; - - my %files = reverse $Cb->list_custom_sources; - - ### it's an URI we know - ### VMS can lower case all files, so make sure we check that too - my $local = $files{ $uri }; - $local = $files{ lc $uri } if !$local && ON_VMS; - - if( $local ) { - return wantarray - ? ($uri, $local) - : $uri; - } - - ### couldn't resolve the input - error(loc("Unknown URI/index: '%1'", $input)); - return; -} - -sub _list_custom_sources { - my $class = shift; - - my %files = $Cb->list_custom_sources; - - $Shell->__print( loc("Your remote sources:"), $/ ) if keys %files; - - my $i = 0; - while(my($local,$remote) = each %files) { - $Shell->__printf( " [%2d] %s\n", ++$i, $remote ); - - ### remember, off by 1! - push @Index, $remote; - } - - $Shell->__print( $/ ); -} - -sub _list_contents { - my $class = shift; - my $input = shift; - - my ($uri,$local) = $class->_uri_from_cache( $input ); - unless( $uri ) { - error(loc("--contents needs URI parameter")); - return; - } - - my $fh = OPEN_FILE->( $local ) or return; - - $Shell->__printf( " %s", $_ ) for sort <$fh>; - $Shell->__print( $/ ); -} - -sub custom_source { - my $class = shift; - my $shell = shift; $Shell = $shell; # available to all methods now - my $cb = shift; $Cb = $cb; # available to all methods now - my $cmd = shift; - my $input = shift || ''; - my $opts = shift || {}; - - ### show a list - if( $opts->{'list'} ) { - $class->_list_custom_sources; - - } elsif ( $opts->{'contents'} ) { - $class->_list_contents( $input ); - - } elsif ( $opts->{'add'} ) { - unless( $input ) { - error(loc("--add needs URI parameter")); - return; - } - - $cb->add_custom_source( uri => $input ) - and $shell->__print(loc("Added remote source '%1'", $input), $/); - - $Shell->__print($/, loc("Remote source contains:"), $/, $/); - $class->_list_contents( $input ); - - } elsif ( $opts->{'remove'} ) { - my($uri,$local) = $class->_uri_from_cache( $input ); - unless( $uri ) { - error(loc("--remove needs URI parameter")); - return; - } - - 1 while unlink $local; - - $shell->__print( loc("Removed remote source '%1'", $uri), $/ ); - - } elsif ( $opts->{'update'} ) { - ### did we get input? if so, it's a remote part - my $uri = $class->_uri_from_cache( $input ); - - $cb->update_custom_source( $uri ? ( remote => $uri ) : () ) - and do { $shell->__print( loc("Updated remote sources"), $/ ) }; - - } elsif ( $opts->{'write'} ) { - $cb->write_custom_source_index( path => $input ) and - $shell->__print( loc("Wrote remote source index for '%1'", $input), $/); - - } else { - error(loc("Unrecognized command, see '%1' for help", '/? cs')); - } - - return; -} - -sub custom_source_help { - return loc( - $/ . - ' # Plugin to manage custom sources from the default shell' . $/ . - " # See the 'CUSTOM MODULE SOURCES' section in the " . $/ . - ' # CPANPLUS::Backend documentation for details.' . $/ . - ' /cs --list # list available sources' . $/ . - ' /cs --add URI # add source' . $/ . - ' /cs --remove URI | INDEX # remove source' . $/ . - ' /cs --contents URI | INDEX # show packages from source'. $/ . - ' /cs --update [URI | INDEX] # update source index' . $/ . - ' /cs --write PATH # write source index' . $/ - ); - -} - -1; - diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod deleted file mode 100644 index 8000aac988..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod +++ /dev/null @@ -1,136 +0,0 @@ -=head1 NAME - -CPANPLUS::Shell::Default::Plugins::HOWTO -- documentation on how to write your own plugins - -=head1 SYNOPSIS - - package CPANPLUS::Shell::Default::Plugins::MyPlugin; - - ### return command => method mapping - sub plugins { ( myplugin1 => 'mp1', myplugin2 => 'mp2' ) } - - ### method called when the command '/myplugin1' is issued - sub mp1 { .... } - - ### method called when the command '/? myplugin1' is issued - sub mp1_help { return "Help Text" } - -=head1 DESCRIPTION - -This pod text explains how to write your own plugins for -C<CPANPLUS::Shell::Default>. - -=head1 HOWTO - -=head2 Registering Plugin Modules - -Plugins are detected by using C<Module::Pluggable>. Every module in -the C<CPANPLUS::Shell::Default::Plugins::*> namespace is considered a -plugin, and is attempted to be loaded. - -Therefor, any plugin must be declared in that namespace, in a corresponding -C<.pm> file. - -=head2 Registering Plugin Commands - -To register any plugin commands, a list of key value pairs must be returned -by a C<plugins> method in your package. The keys are the commands you wish -to register, the values are the methods in the plugin package you wish to have -called when the command is issued. - -For example, a simple 'Hello, World!' plugin: - - package CPANPLUS::Shell::Default::Plugins::HW; - - sub plugins { return ( helloworld => 'hw' ) }; - - sub hw { print "Hello, world!\n" } - -When the user in the default shell now issues the C</helloworld> command, -this command will be dispatched to the plugin, and its C<hw> method will -be called - -=head2 Registering Plugin Help - -To provide usage information for your plugin, the user of the default shell -can type C</? PLUGIN_COMMAND>. In that case, the function C<PLUGIN_COMMAND_help> -will be called in your plugin package. - -For example, extending the above example, when a user calls C</? helloworld>, -the function C<hw_help> will be called, which might look like this: - - sub hw_help { " /helloworld # prints "Hello, world!\n" } - -If you dont provide a corresponding _help function to your commands, the -default shell will handle it gracefully, but the user will be stuck without -usage information on your commands, so it's considered undesirable to omit -the help functions. - -=head2 Arguments to Plugin Commands - -Any plugin function will receive the following arguments when called, which -are all positional: - -=over 4 - -=item Classname -- The name of your plugin class - -=item Shell -- The CPANPLUS::Shell::Default object - -=item Backend -- The CPANPLUS::Backend object - -=item Command -- The command issued by the user - -=item Input -- The input string from the user - -=item Options -- A hashref of options provided by the user - -=back - -For example, the following command: - - /helloworld bob --nofoo --bar=2 joe - -Would yield the following arguments: - - sub hw { - my $class = shift; # CPANPLUS::Shell::Default::Plugins::HW - my $shell = shift; # CPANPLUS::Shell::Default object - my $cb = shift; # CPANPLUS::Backend object - my $cmd = shift; # 'helloworld' - my $input = shift; # 'bob joe' - my $opts = shift; # { foo => 0, bar => 2 } - - .... - } - - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=head1 SEE ALSO - -L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell>, L<cpanp> - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm deleted file mode 100644 index 0e749646c8..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm +++ /dev/null @@ -1,190 +0,0 @@ -package CPANPLUS::Shell::Default::Plugins::Remote; -use deprecate; - -use strict; - -use Module::Load; -use Params::Check qw[check]; -use CPANPLUS::Error qw[error msg]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -=head1 NAME - -CPANPLUS::Shell::Default::Plugins::Remote - connect to a remote CPANPLUS - -=head1 SYNOPSIS - - CPAN Terminal> /connect localhost 1337 --user=foo --pass=bar - ... - CPAN Terminal@localhost> /disconnect - -=head1 DESCRIPTION - -This is a C<CPANPLUS::Shell::Default> plugin that allows you to connect -to a machine running an instance of C<CPANPLUS::Daemon>, allowing remote -usage of the C<CPANPLUS Shell>. - -A sample session, updating all modules on a remote machine, might look -like this: - - CPAN Terminal> /connect --user=my_user --pass=secret localhost 1337 - - Connection accepted - - Successfully connected to 'localhost' on port '11337' - - Note that no output will appear until a command has completed - -- this may take a while - - - CPAN Terminal@localhost> o; i * - - [....] - - CPAN Terminal@localhost> /disconnect - - CPAN Terminal> - -=cut - -### store the original prompt here, so we can restore it on disconnect -my $Saved_Prompt; - -sub plugins { ( connect => 'connect', disconnect => 'disconnect' ) } - -sub connect { - my $class = shift; - my $shell = shift; - my $cb = shift; - my $cmd = shift; - my $input = shift || ''; - my $opts = shift || {}; - my $conf = $cb->configure_object; - - my $user; my $pass; - { local $Params::Check::ALLOW_UNKNOWN = 1; - - my $tmpl = { - user => { default => 'cpanpd', store => \$user }, - pass => { required => 1, store => \$pass }, - }; - - check( $tmpl, $opts ) or return; - } - - my @parts = split /\s+/, $input; - my $host = shift @parts || 'localhost'; - my $port = shift @parts || '1337'; - - load IO::Socket; - - my $remote = IO::Socket::INET->new( - Proto => "tcp", - PeerAddr => $host, - PeerPort => $port, - ) or ( - error( loc( "Cannot connect to port '%1' ". - "on host '%2'", $port, $host ) ), - return - ); - - my $con = { - connection => $remote, - username => $user, - password => $pass, - }; - - ### store the connection - $shell->remote( $con ); - - my($status,$buffer) = $shell->__send_remote_command( - "VERSION=$CPANPLUS::Shell::Default::VERSION"); - - if( $status ) { - print "\n$buffer\n\n"; - - print loc( "Successfully connected to '%1' on port '%2'", - $host, $port ); - print "\n\n"; - print loc( "Note that no output will appear until a command ". - "has completed\n-- this may take a while" ); - print "\n\n"; - - ### save the original prompt - $Saved_Prompt = $shell->prompt; - - $shell->prompt( $shell->brand .'@'. $host .':'. $port .'> ' ); - - } else { - print "\n$buffer\n\n"; - - print loc( "Failed to connect to '%1' on port '%2'", - $host, $port ); - print "\n\n"; - - $shell->remote( undef ); - } -} - -sub disconnect { - my $class = shift; - my $shell = shift; - - print "\n", ( $shell->remote - ? loc( "Disconnecting from remote host" ) - : loc( "Not connected to remote host" ) - ), "\n\n"; - - $shell->remote( undef ); - $shell->prompt( $Saved_Prompt ); -} - -sub connect_help { - return loc( - " /connect [HOST PORT] # Connect to the remote machine,\n" . - " # defaults taken from your config\n" . - " --user=USER # Optional username\n" . - " --pass=PASS # Optional password" ); -} - -sub disconnect_help { - return loc( - " /disconnect # Disconnect from the remote server" ); -} - -1; - -=pod - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=head1 SEE ALSO - -L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell>, L<cpanp> - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Source.pm b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Source.pm deleted file mode 100644 index 30383398eb..0000000000 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Source.pm +++ /dev/null @@ -1,111 +0,0 @@ -package CPANPLUS::Shell::Default::Plugins::Source; -use deprecate; - -use strict; -use CPANPLUS::Error qw[error msg]; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; - -use vars qw[$VERSION]; -$VERSION = "0.9135"; - -=head1 NAME - -CPANPLUS::Shell::Default::Plugins::Source - read in CPANPLUS commands - -=head1 SYNOPSIS - - CPAN Terminal> /source /tmp/list_of_commands /tmp/more_commands - -=head1 DESCRIPTION - -This is a C<CPANPLUS::Shell::Default> plugin that works just like -your unix shells source(1) command; it reads in a file that has -commands in it to execute, and then executes them. - -A sample file might look like this: - - # first, update all the source files - x --update_source - - # find all of my modules that are on the CPAN - # test them, and store the error log - a ^KANE$' - t * - p /home/kane/cpan-autotest/log - - # and inform us we're good to go - ! print "Autotest complete, log stored; please enter your commands!" - -Note how empty lines, and lines starting with a '#' are being skipped -in the execution. - -=cut - - -sub plugins { return ( source => 'source' ) } - -sub source { - my $class = shift; - my $shell = shift; - my $cb = shift; - my $cmd = shift; - my $input = shift || ''; - my $opts = shift || {}; - my $verbose = $cb->configure_object->get_conf('verbose'); - - for my $file ( split /\s+/, $input ) { - my $fh = FileHandle->new("$file") or( - error(loc("Could not open file '%1': %2", $file, $!)), - next - ); - - while( my $line = <$fh> ) { - chomp $line; - - next if $line !~ /\S+/; # skip empty/whitespace only lines - next if $line =~ /^#/; # skip comments - - msg(loc("Dispatching '%1'", $line), $verbose); - return 1 if $shell->dispatch_on_input( input => $line ); - } - } -} - -sub source_help { - return loc(' /source FILE [FILE ..] '. - '# read in commands from the specified file' ), -} - -1; - -=pod - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=head1 SEE ALSO - -L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell>, L<cpanp> - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - diff --git a/cpan/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t b/cpan/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t deleted file mode 100644 index e15dcb2fc0..0000000000 --- a/cpan/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t +++ /dev/null @@ -1,185 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; - -### make sure to keep the plan -- this is the only test -### supported for 'older' T::H (pre 2.28) -- see Makefile.PL for details -use Test::More tests => 48; - -use Cwd; -use Data::Dumper; -use File::Spec; -use File::Basename; - -use CPANPLUS::Error; -use CPANPLUS::Internals::Utils; - -# File::Spec and Cwd might return different values for a -# symlinked directory, so we need to be careful. -sub paths_are_same { - my($have, $want, $name) = @_; - - $have = _resolve_symlinks($have); - $want = _resolve_symlinks($want); - - my $builder = Test::More->builder; - return $builder->like( $have, qr/\Q$want/i, $name ); -} - -# Resolve any symlinks in a path -sub _resolve_symlinks { - my $path = shift; - my($vol, $dirs, $file) = File::Spec->splitpath($path); - - my $resolved = File::Spec->catpath( $vol, "", "" ); - - for my $dir (File::Spec->splitdir($dirs)) { - # Resolve the next part of the path - my $next = File::Spec->catdir( $resolved, $dir ); - $next = eval { readlink $next } || $next; - - # If its absolute, use it. - # Otherwise tack it onto the end of the previous path. - $resolved = File::Spec->file_name_is_absolute($next) - ? $next - : File::Spec->catdir( $resolved, $next ); - } - - return File::Spec->catfile($resolved, $file); -} - -my $Cwd = File::Spec->rel2abs(cwd()); -my $Class = 'CPANPLUS::Internals::Utils'; -my $Dir = 'foo'; -my $Move = 'bar'; -my $File = 'zot'; - -rmdir $Move if -d $Move; -rmdir $Dir if -d $Dir; - -### test _mdkir ### -{ ok( $Class->_mkdir( dir => $Dir), "Created dir '$Dir'" ); - ok( -d $Dir, " '$Dir' is a dir" ); -} - -### test _chdir ### -{ ok( $Class->_chdir( dir => $Dir), "Chdir to '$Dir'" ); - - my $abs = File::Spec->rel2abs(File::Spec->catdir($Cwd,$Dir)); - paths_are_same( File::Spec->rel2abs(cwd()), $abs, - " Cwd() is '$Dir'"); - - ok( $Class->_chdir( dir => $Cwd), "Chdir back to '$Cwd'" ); - paths_are_same( File::Spec->rel2abs(cwd()), $Cwd, - " Cwd() is '$Cwd'" ); -} - -### test _move ### -{ ok( $Class->_move( file => $Dir, to => $Move ), - "Move from '$Dir' to '$Move'" ); - ok( -d $Move, " Dir '$Move' exists" ); - ok( !-d $Dir, " Dir '$Dir' no longer exists" ); - - - { local $CPANPLUS::Error::ERROR_FH = output_handle(); - - ### now try to move it somewhere it can't ### - ok( !$Class->_move( file => $Move, to => 'inc' ), - " Impossible move detected" ); - like( CPANPLUS::Error->stack_as_string, qr/Failed to move/, - " Expected error found" ); - } -} - -### test _rmdir ### -{ ok( -d $Move, "Dir '$Move' exists" ); - ok( $Class->_rmdir( dir => $Move ), " Deleted dir '$Move'" ); - ok(!-d $Move, " Dir '$Move' no longer exists" ); -} - -### _get_file_contents tests ### -{ my $contents = $Class->_get_file_contents( file => basename($0) ); - ok( $contents, "Got file contents" ); - like( $contents, qr/BEGIN/, " Proper contents found" ); - like( $contents, qr/CPANPLUS/, " Proper contents found" ); -} - -### _perl_version tests ### -{ my $version = $Class->_perl_version( perl => $^X ); - ok( $version, "Perl version found" ); - like( $version, qr/\d.\d+.\d+/, " Looks like a proper version" ); -} - -### _version_to_number tests ### -{ my $map = { - '1' => '1', - '1.2' => '1.2', - '.2' => '.2', - 'foo' => '0.0', - 'a.1' => '0.0', - '1.2.3' => '1.002003', - 'v1.2.3' => '1.002003', - 'v1.5' => '1.005000', - '1.5-a' => '1.500', - }; - - while( my($try,$expect) = each %$map ) { - my $ver = $Class->_version_to_number( version => $try ); - ok( $ver, "Version returned" ); - is( $ver, $expect, " Value as expected" ); - } -} - -### _whoami tests ### -{ sub foo { - my $me = $Class->_whoami; - ok( $me, "_whoami returned a result" ); - is( $me, 'foo', " Value as expected" ); - } - - foo(); -} - -### _mode_plus_w tests ### -{ open my $fh, ">$File" or die "Could not open $File for writing: $!"; - close $fh; - - ### remove perms - ok( -e $File, "File '$File' created" ); - ok( chmod( 000, $File ), " File permissions set to 000" ); - - ok( $Class->_mode_plus_w( file => $File ), - " File permissions set to +w" ); - ok( -w $File, " File is writable" ); - - 1 while unlink $File; - - ok( !-e $File, " File removed" ); -} - -### uri encode/decode tests -{ my $org = 'file://foo/bar'; - - my $enc = $Class->_uri_encode( uri => $org ); - - ok( $enc, "String '$org' encoded" ); - like( $enc, qr/%/, " Contents as expected" ); - - my $dec = $Class->_uri_decode( uri => $enc ); - ok( $dec, "String '$enc' decoded" ); - is( $dec, $org, " Decoded properly" ); -} - - - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - diff --git a/cpan/CPANPLUS/t/01_CPANPLUS-Configure.t b/cpan/CPANPLUS/t/01_CPANPLUS-Configure.t deleted file mode 100644 index 152a9ac632..0000000000 --- a/cpan/CPANPLUS/t/01_CPANPLUS-Configure.t +++ /dev/null @@ -1,136 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use Test::More 'no_plan'; -use Data::Dumper; -use strict; -use CPANPLUS::Internals::Constants; - -my $Config_pm = 'CPANPLUS/Config.pm'; - -### DO NOT FLUSH TILL THE END!!! we depend on all warnings being logged.. - -for my $mod (qw[CPANPLUS::Configure]) { - use_ok($mod) or diag qq[Can't load $mod]; -} - -my $c = CPANPLUS::Configure->new(); -isa_ok($c, 'CPANPLUS::Configure'); - -my $r = $c->conf; -isa_ok( $r, 'CPANPLUS::Config' ); - - -### EU::AI compatibility test ### -{ my $base = $c->_get_build('base'); - ok( defined($base), "Base retrieved by old compat API"); - is( $base, $c->get_conf('base'), " Value as expected" ); -} - -for my $cat ( $r->ls_accessors ) { - - ### what field can they take? ### - my @options = $c->options( type => $cat ); - - ### copy for use on the config object itself - my $accessor = $cat; - my $prepend = ($cat =~ s/^_//) ? '_' : ''; - - my $getmeth = $prepend . 'get_'. $cat; - my $setmeth = $prepend . 'set_'. $cat; - my $addmeth = $prepend . 'add_'. $cat; - - ok( scalar(@options), "Possible options obtained" ); - - ### test adding keys too ### - { my $add_key = 'test_key'; - my $add_val = [1..3]; - - my $found = grep { $add_key eq $_ } @options; - ok( !$found, "Key '$add_key' not yet defined" ); - ok( $c->$addmeth( $add_key => $add_val ), - " $addmeth('$add_key' => VAL)" ); - - ### this one now also exists ### - push @options, $add_key - } - - ### poke in the object, get the actual hashref out ### - my %hash = map { - $_ => $r->$accessor->$_ - } $r->$accessor->ls_accessors; - - while( my ($key,$val) = each %hash ) { - my $is = $c->$getmeth($key); - is_deeply( $val, $is, "deep check for '$key'" ); - ok( $c->$setmeth($key => 1 ), " $setmeth('$key' => 1)" ); - is( $c->$getmeth($key), 1, " $getmeth('$key')" ); - ok( $c->$setmeth($key => $val), " $setmeth('$key' => ORGVAL)" ); - } - - ### now check if we found all the keys with options or not ### - delete $hash{$_} for @options; - ok( !(scalar keys %hash), "All possible keys found" ); - -} - - -### see if we can save the config ### -{ my $dir = File::Spec->rel2abs('dummy-cpanplus'); - my $pm = 'CPANPLUS::Config::Test' . $$; - my $file = $c->save( $pm, $dir ); - - ok( $file, "Config $pm saved" ); - ok( -e $file, " File exists" ); - ok( -s $file, " File has size" ); - - ### include our dummy dir when re-scanning - { local @INC = ( $dir, @INC ); - ok( $c->init( rescan => 1 ), - "Reran ->init()" ); - } - - ### make sure this file is now loaded - ### XXX can't trust bloody dir separators on Win32 in %INC, - ### so rather than an exact match, do a grep... - my ($found) = grep /\bTest$$/, values %INC; - ok( $found, " Found $file in \%INC" ); - ok( -e $file, " File exists" ); - 1 while unlink $file; - ok(!-e $file, " File removed" ); - -} - -{ my $env = ENV_CPANPLUS_CONFIG; - local $ENV{$env} = $$; - my $ok = $c->init; - my $stack = CPANPLUS::Error->stack_as_string; - - ok( $ok, "Reran init again" ); - like( $stack, qr/Specifying a config file in your environment/, - " Warning logged" ); -} - - -{ CPANPLUS::Error->flush; - - { ### try a bogus method call - my $x = $c->flubber('foo'); - my $err = CPANPLUS::Error->stack_as_string; - is ($x, undef, "Bogus method call returns undef"); - like($err, "/flubber/", " Bogus method call recognized"); - } - - CPANPLUS::Error->flush; -} - - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/t/02_CPANPLUS-Internals.t b/cpan/CPANPLUS/t/02_CPANPLUS-Internals.t deleted file mode 100644 index 46a7cb6e20..0000000000 --- a/cpan/CPANPLUS/t/02_CPANPLUS-Internals.t +++ /dev/null @@ -1,147 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; -use Test::More 'no_plan'; - -use CPANPLUS::Configure; -use CPANPLUS::Backend; -use CPANPLUS::Internals::Constants; -use Module::Load::Conditional qw[can_load]; -use Data::Dumper; - -my $cb = CPANPLUS::Backend->new( CPANPLUS::Configure->new() ); - -isa_ok($cb, 'CPANPLUS::Internals'); -is($cb->_id, $cb->_last_id, "Comparing ID's"); - -### delete/store/retrieve id tests ### -{ my $del = $cb->_remove_id( $cb->_id ); - ok( $del, "ID deleted" ); - isa_ok( $del, "CPANPLUS::Internals" ); - is( $del, $cb, " Deleted ID matches last object" ); - - my $id = $cb->_store_id( $del ); - ok( $id, "ID stored" ); - is( $id, $cb->_id, " Stored proper ID" ); - - my $obj = $cb->_retrieve_id( $id ); - ok( $obj, "Object retrieved from ID" ); - isa_ok( $obj, 'CPANPLUS::Internals' ); - is( $obj->_id, $id, " Retrieved ID properly" ); - - my @obs = $cb->_return_all_objects(); - ok( scalar(@obs), "Returned objects" ); - is( scalar(@obs), 1, " Proper amount of objects found" ); - is( $obs[0]->_id, $id, " Proper ID found on object" ); - - my $lid = $cb->_last_id; - ok( $lid, "Found last registered ID" ); - is( $lid, $id, " ID matches last object" ); - - my $iid = $cb->_inc_id; - ok( $iid, "Incremented ID" ); - is( $iid, $id+1, " ID matched last ID + 1" ); -} - -### host ok test ### -{ - my $host = $cb->configure_object->get_conf('hosts')->[0]; - - is( $cb->_host_ok( host => $host ), 1, "Host ok" ); - is( $cb->_add_fail_host(host => $host), 1, " Host now marked as bad" ); - is( $cb->_host_ok( host => $host ), 0, " Host still bad" ); - ok( $cb->_flush( list => ['hosts'] ), " Hosts flushed" ); - is( $cb->_host_ok( host => $host ), 1, " Host now ok again" ); -} - -### flush loads test -{ my $mod = 'Benchmark'; - my $file = $mod . '.pm'; - - ### XXX whitebox test -- mark this module as unloadable - $Module::Load::Conditional::CACHE->{$mod}->{usable} = 0; - - ok( !can_load( modules => { $mod => 0 }, verbose => 0 ), - "'$mod' not loaded" ); - - ok( $cb->flush('load'), " 'load' cache flushed" ); - ok( can_load( modules => { $mod => 0 }, verbose => 0 ), - " '$mod' loaded" ); -} - -### add to inc path tests -{ my $meth = '_add_to_includepath'; - can_ok( $cb, $meth ); - - my $p5lib = $ENV{PERL5LIB} || ''; - my $inc = "@INC"; - ok( $cb->$meth( directories => [$$] ), - " CB->$meth( $$ )" ); - - my $new_p5lib = $ENV{PERL5LIB}; - my $new_inc = "@INC"; - isnt( $p5lib, $new_p5lib, " PERL5LIB is now: $new_p5lib" ); - like( $new_p5lib, qr/$$/, " Matches $$" ); - - isnt( $inc, $new_inc, ' @INC is expanded with: ' . $$ ); - like( $new_inc, qr/$$/, " Matches $$" ); - - ok( $cb->$meth( directories => [$$] ), - " CB->$meth( $$ ) again" ); - is( "@INC", $new_inc, ' @INC unchanged' ); - is( $new_p5lib, $ENV{PERL5LIB}, - " PERL5LIB unchanged" ); -} - -### callback registering tests ### -{ my $callback_map = { - ### name default value - install_prerequisite => 1, # install prereqs when 'ask' is set? - edit_test_report => 0, # edit the prepared test report? - send_test_report => 1, # send the test report? - munge_test_report => $$, # munge the test report - filter_prereqs => $$, # limit prereqs - proceed_on_test_failure => 0, # continue on failed 'make test'? - munge_dist_metafile => $$, # munge the metailfe - }; - - for my $callback ( keys %$callback_map ) { - - { my $rv = $callback_map->{$callback}; - - is( $rv, $cb->_callbacks->$callback->( $0, $$ ), - "Default callback '$callback' called" ); - like( CPANPLUS::Error->stack_as_string, qr/DEFAULT '\S+' HANDLER/s, - " Default handler warning recorded" ); - CPANPLUS::Error->flush; - } - - ### try to register the callback - my $ok = $cb->_register_callback( - name => $callback, - code => sub { return $callback } - ); - - ok( $ok, "Registered callback '$callback' ok" ); - - my $sub = $cb->_callbacks->$callback; - ok( $sub, " Retrieved callback" ); - ok( IS_CODEREF->($sub), " Callback is a sub" ); - - my $rv = $sub->(); - ok( $rv, " Callback called ok" ); - is( $rv, $callback, " Got expected return value" ); - } -} - - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/t/03_CPANPLUS-Internals-Source.t b/cpan/CPANPLUS/t/03_CPANPLUS-Internals-Source.t deleted file mode 100644 index d6ad2ea94f..0000000000 --- a/cpan/CPANPLUS/t/03_CPANPLUS-Internals-Source.t +++ /dev/null @@ -1,262 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; - -use Module::Load; -use Test::More eval { - load $ENV{CPANPLUS_SOURCE_ENGINE} if $ENV{CPANPLUS_SOURCE_ENGINE}; 1 - } ? 'no_plan' - : (skip_all => "SQLite engine not available"); - -use CPANPLUS::Error; -use CPANPLUS::Backend; -use CPANPLUS::Internals::Constants; - -use Data::Dumper; -use File::Basename qw[dirname]; - -my $conf = gimme_conf(); -$conf->set_conf( enable_custom_sources => 1 ); -my $cb = CPANPLUS::Backend->new( $conf ); - -### XXX temp -# $conf->set_conf( verbose => 1 ); - -isa_ok($cb, "CPANPLUS::Internals" ); - -my $modname = TEST_CONF_MODULE; - -### test lookups -{ my $mt = $cb->_module_tree; - my $at = $cb->_author_tree; - - ### source files should be copied from the 'server' now - for my $name (qw[auth mod dslip] ) { - my $file = File::Spec->catfile( - $conf->get_conf('base'), - $conf->_get_source($name) - ); - ok( (-e $file && -f _ && -s _), "$file exists" ); - } - - ok( $at, "Authortree loaded successfully" ); - ok( scalar keys %$at, " Authortree has items in it" ); - ok( $mt, "Moduletree loaded successfully" ); - ok( scalar keys %$mt, " Moduletree has items in it" ); - - my $auth = $at->{'EUNOXS'}; - my $mod = $mt->{$modname}; - - isa_ok( $auth, 'CPANPLUS::Module::Author' ); - isa_ok( $mod, 'CPANPLUS::Module' ); -} - -### save state tests -SKIP: { - skip "Save state tests for custom engine $ENV{CPANPLUS_SOURCE_ENGINE}", 7 - if $ENV{CPANPLUS_SOURCE_ENGINE}; - - ok( 1, "Testing save state functionality" ); - - - ### check we dont have a status set yet - { my $mod = $cb->_module_tree->{$modname}; - ok( !$mod->_status, " No status set yet in module object" ); - ok( $mod->status, " Status now set" ); - } - - ### now save this to disk - { CPANPLUS::Error->flush; - - my $rv = $cb->save_state; - ok( $rv, " State information saved" ); - - like( CPANPLUS::Error->stack_as_string, qr/Writing compiled source/, - " Diagnostics confirmed" ); - } - - ### now we rebuild the trees from disk and - ### check if the module object has a status saved with it - { CPANPLUS::Error->flush; - ok( $cb->_build_trees( uptodate => 1, use_stored => 1), - " Trees are rebuilt" ); - - like( CPANPLUS::Error->stack_as_string, qr/Retrieving/, - " Diagnostics confirmed" ); - - - my $mod = $cb->_module_tree->{$modname}; - ok( $mod->status, " Status now set in module object" ); - } -} - -### check custom sources -### XXX whitebox test -SKIP: { - ### first, find a file to serve as a source - my $mod = $cb->_module_tree->{$modname}; - my $package = File::Spec->rel2abs( - File::Spec->catfile( - $FindBin::Bin, - TEST_CONF_CPAN_DIR, - $mod->path, - $mod->package, - ) - ); - - ok( $package, "Found file for custom source" ); - ok( -e $package, " File '$package' exists" ); - - ### remote uri - my $uri = $cb->_host_to_uri( - scheme => 'file', - host => '', - path => File::Spec->catfile( dirname($package) ) - ); - - my $expected_file = $cb->__custom_module_source_index_file( uri => $uri ); - - ok( $expected_file, "Sources should be written to '$uri'" ); - - skip( "Index file size too long (>260 chars). Can't write to disk", 28 ) - if length $expected_file > 260 and ON_WIN32; - - - ### local file - ### 2 tests - my $src_file = $cb->_add_custom_module_source( uri => $uri ); - ok( $src_file, "Sources written to '$src_file'" ); - ok( -e $src_file, " File exists" ); - - ### and write the file - ### 5 tests - { my $meth = '__write_custom_module_index'; - can_ok( $cb, $meth ); - - my $rv = $cb->$meth( - path => dirname( $package ), - to => $src_file - ); - - ok( $rv, " Sources written" ); - is( $rv, $src_file, " Written to expected file" ); - ok( -e $src_file, " Source file exists" ); - ok( -s $src_file, " File has non-zero size" ); - } - - ### let's see if we can find our custom files - ### 3 tests - { my $meth = '__list_custom_module_sources'; - can_ok( $cb, $meth ); - - my %files = $cb->$meth; - ok( scalar(keys(%files)), - " Got list of sources" ); - - ### on VMS, we can't predict the case unfortunately - ### so grep for it instead; - my $found = map { - my $src_re = quotemeta($src_file); - $_ =~ /$src_re/i; - } keys %files; - - ok( $found, " Found proper entry for $src_file" ); - } - - ### now we can have it be loaded in - ### 6 tests - { my $meth = '__create_custom_module_entries'; - can_ok( $cb, $meth ); - - ### now add our own sources - ok( $cb->$meth, "Sources file loaded" ); - - my $add_name = TEST_CONF_INST_MODULE; - my $add = $cb->_module_tree->{$add_name}; - ok( $add, " Found added module" ); - - ok( $add->status->_fetch_from, - " Full download path set" ); - is( $add->author->cpanid, CUSTOM_AUTHOR_ID, - " Attributed to custom author" ); - - ### since we replaced an existing module, there should be - ### a message on the stack - like( CPANPLUS::Error->stack_as_string, qr/overwrite module tree/i, - " Addition message recorded" ); - } - - ### test updating custom sources - ### 3 tests - { my $meth = '__update_custom_module_sources'; - can_ok( $cb, $meth ); - - ### mark what time it is now, sleep 1 second for better measuring - my $now = time; - sleep 1; - - my $ok = $cb->$meth; - - ok( $ok, "Custom sources updated" ); - cmp_ok( [stat $src_file]->[9], '>=', $now, - " Timestamp on sourcefile updated" ); - } - - ### now update it individually - ### 3 tests - { my $meth = '__update_custom_module_source'; - can_ok( $cb, $meth ); - - ### mark what time it is now, sleep 1 second for better measuring - my $now = time; - sleep 1; - - my $ok = $cb->$meth( remote => $uri ); - - ok( $ok, "Custom source for '$uri' updated" ); - cmp_ok( [stat $src_file]->[9], '>=', $now, - " Timestamp on sourcefile updated" ); - } - - ### now update using the higher level API, see if it's part of the update - ### 3 tests - { CPANPLUS::Error->flush; - - ### mark what time it is now, sleep 1 second for better measuring - my $now = time; - sleep 1; - - my $ok = $cb->_build_trees( - uptodate => 0, - use_stored => 0, - ); - - ok( $ok, "All sources updated" ); - cmp_ok( [stat $src_file]->[9], '>=', $now, - " Timestamp on sourcefile updated" ); - - like( CPANPLUS::Error->stack_as_string, qr/Updating sources from/, - " Update recorded in the log" ); - } - - ### now remove the index file; - ### 3 tests - { my $meth = '_remove_custom_module_source'; - can_ok( $cb, $meth ); - - my $file = $cb->$meth( uri => $uri ); - ok( $file, "Index file removed" ); - ok( ! -e $file, " File '$file' no longer on disk" ); - } -} - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/t/04_CPANPLUS-Module.t b/cpan/CPANPLUS/t/04_CPANPLUS-Module.t deleted file mode 100644 index 1014e62bda..0000000000 --- a/cpan/CPANPLUS/t/04_CPANPLUS-Module.t +++ /dev/null @@ -1,360 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; - -use CPANPLUS::Configure; -use CPANPLUS::Backend; -use CPANPLUS::Module::Fake; -use CPANPLUS::Module::Author::Fake; -use CPANPLUS::Internals::Constants; - -use Test::More 'no_plan'; -use Data::Dumper; -use File::Spec; -use File::Path (); - -my $Conf = gimme_conf(); -my $CB = CPANPLUS::Backend->new( $Conf ); - -### start with fresh sources ### -ok( $CB->reload_indices( update_source => 0 ), "Rebuilding trees" ); - -my $AuthName = TEST_CONF_AUTHOR; -my $Auth = $CB->author_tree( $AuthName ); -my $ModName = TEST_CONF_MODULE; -my $Mod = $CB->module_tree( $ModName ); -my $CoreName = TEST_CONF_PREREQ; -my $CoreMod = $CB->module_tree( $CoreName ); - -isa_ok( $Auth, 'CPANPLUS::Module::Author' ); -isa_ok( $Mod, 'CPANPLUS::Module' ); -isa_ok( $CoreMod, 'CPANPLUS::Module' ); - -### author accessors ### -is( $Auth->author, 'ExtUtils::MakeMaker No XS Code', - "Author name: " . $Auth->author ); -is( $Auth->cpanid, $AuthName, "Author CPANID: " . $Auth->cpanid ); -is( $Auth->email, DEFAULT_EMAIL,"Author email: " . $Auth->email ); -isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); - -### module accessors ### -{ my %map = ( - ### method ### result - module => $ModName, - name => $ModName, - comment => undef, - package => 'Foo-Bar-0.01.tar.gz', - path => 'authors/id/EUNOXS', - version => '0.01', - dslip => 'cdpO ', - description => 'CPANPLUS Test Package', - mtime => '', - author => $Auth, - ); - - my @acc = $Mod->accessors; - ok( scalar(@acc), "Retrieved module accessors" ); - - ### remove private accessors - is_deeply( [ sort keys %map ], [ sort grep { $_ !~ /^_/ } @acc ], - " About to test all accessors" ); - - ### check all the accessors - while( my($meth,$res) = each %map ) { - is( $Mod->$meth, $res, " Mod->$meth: " . ($res || '<empty>') ); - } - - ### check accessor objects ### - isa_ok( $Mod->parent, 'CPANPLUS::Backend' ); - isa_ok( $Mod->author, 'CPANPLUS::Module::Author' ); - is( $Mod->author->author, $Auth->author, - "Module eq Author" ); -} - -### convenience methods ### -{ ok( 1, "Convenience functions" ); - is( $Mod->package_name, 'Foo-Bar', " Package name"); - is( $Mod->package_version, '0.01', " Package version"); - is( $Mod->package_extension, 'tar.gz', " Package extension"); - ok( !$Mod->package_is_perl_core, " Package not core"); - ok( !$Mod->module_is_supplied_with_perl_core, " Module not core" ); - ok( !$Mod->is_bundle, " Package not bundle"); -} - -### clone & status tests -{ my $clone = $Mod->clone; - ok( $clone, "Module cloned" ); - isa_ok( $clone, 'CPANPLUS::Module' ); - - for my $acc ( $Mod->accessors ) { - is( $clone->$acc, $Mod->$acc, - " Clone->$acc matches Mod->$acc " ); - } - - ### XXX whitebox test - ok( !$clone->_status, "Status object empty on start" ); - - my $status = $clone->status; - ok( $status, " Status object defined after query" ); - is( $status, $clone->_status, - " Object stored as expected" ); - isa_ok( $status, 'Object::Accessor' ); -} - -{ ### extract + error test ### - ok( !$Mod->extract(), "Cannot extract unfetched file" ); - like( CPANPLUS::Error->stack_as_string, qr/You have not fetched/, - " Error properly logged" ); -} - -{ ### fetch tests ### - ### enable signature checks for checksums ### - my $old = $Conf->get_conf('signature'); - $Conf->set_conf(signature => 1); - - my $where = $Mod->fetch( force => 1 ); - ok( $where, "Module fetched" ); - ok( -f $where, " Module is a file" ); - ok( -s $where, " Module has size" ); - - $Conf->set_conf( signature => $old ); -} - -{ ### extract tests ### - my $dir = $Mod->extract( force => 1 ); - ok( $dir, "Module extracted" ); - ok( -d $dir, " Dir exsits" ); -} - - -{ ### readme tests ### - my $readme = $Mod->readme; - ok( length $readme, "Readme found" ); - is( $readme, $Mod->status->readme, - " Readme stored in module object" ); -} - -{ ### checksums tests ### - SKIP: { - skip(q[You chose not to enable checksum verification], 5) - unless $Conf->get_conf('md5'); - - my $cksum_file = $Mod->checksums; - ok( $cksum_file, "Checksum file found" ); - is( $cksum_file, $Mod->status->checksums, - " File stored in module object" ); - ok( -e $cksum_file, " File exists" ); - ok( -s $cksum_file, " File has size" ); - - ### XXX test checksum_value if there's digest::md5 + config wants it - ok( $Mod->status->checksum_ok, - " Checksum is ok" ); - - ### check ttl code for checksums; fetching it now means the cache - ### should kick in - { CPANPLUS::Error->flush; - ok( $Mod->checksums, - " Checksums re-fetched" ); - like( CPANPLUS::Error->stack_as_string, qr/Using cached file/, - " Cached file used" ); - } - } -} - - -{ ### installer type tests ### - my $installer = $Mod->get_installer_type; - ok( $installer, "Installer found" ); - is( $installer, INSTALLER_MM, - " Proper installer found" ); -} - -{ ### check signature tests ### - SKIP: { - skip(q[You chose not to enable signature checks], 1) - unless $Conf->get_conf('signature'); - - ok( $Mod->check_signature, - "Signature check OK" ); - } -} - -### dslip & related -{ my $dslip = $Mod->dslip; - ok( $dslip, "Got dslip information from $ModName ($dslip)" ); - - ### now find it for a submodule - { my $submod = $CB->module_tree( TEST_CONF_MODULE_SUB ); - ok( $submod, " Found submodule " . $submod->name ); - ok( $submod->dslip, " Got dslip info (".$submod->dslip.")" ); - is( $submod->dslip, $dslip, - " It's identical to $ModName" ); - } -} - -{ ### details() test ### - my $href = { - 'Support Level' => 'Developer', - 'Package' => $Mod->package, - 'Description' => $Mod->description, - 'Development Stage' => - 'under construction but pre-alpha (not yet released)', - 'Author' => sprintf("%s (%s)", $Auth->author, $Auth->email), - 'Version on CPAN' => $Mod->version, - 'Language Used' => - 'Perl-only, no compiler needed, should be platform independent', - 'Interface Style' => - 'Object oriented using blessed references and/or inheritance', - 'Public License' => 'Unknown', - ### XXX we can't really know what you have installed ### - #'Version Installed' => '0.06', - }; - - my $res = $Mod->details; - - ### delete they key of which we don't know the value ### - delete $res->{'Version Installed'}; - - is_deeply( $res, $href, "Details OK" ); -} - -{ ### contians() test ### - ### XXX ->contains works based on package name. in our sourcefiles - ### we use 4x the same package name for different modules. So use - ### the only unique package name here, which is the one for the core mod - my @list = $CoreMod->contains; - - ok( scalar(@list), "Found modules contained in this one" ); - is_deeply( \@list, [$CoreMod], - " Found all modules expected" ); -} - -{ ### testing distributions() ### - my @mdists = $Mod->distributions; - is( scalar @mdists, 1, "Distributions found via module" ); - - my @adists = $Auth->distributions; - is( scalar @adists, 3, "Distributions found via author" ); -} - -{ ### test status->flush ### - ok( $Mod->status->mk_flush, - "Status flushed" ); - ok(!$Mod->status->fetch," Fetch status empty" ); - ok(!$Mod->status->extract, - " Extract status empty" ); - ok(!$Mod->status->checksums, - " Checksums status empty" ); - ok(!$Mod->status->readme, - " Readme status empty" ); -} - -{ ### testing bundles ### - my $bundle = $CB->module_tree('Bundle::Foo::Bar'); - isa_ok( $bundle, 'CPANPLUS::Module' ); - - ok( $bundle->is_bundle, " It's a Bundle:: module" ); - ok( $bundle->fetch, " Fetched the bundle" ); - ok( $bundle->extract, " Extracted the bundle" ); - - my @objs = $bundle->bundle_modules; - is( scalar(@objs), 5, " Found all prerequisites" ); - - for( @objs ) { - isa_ok( $_, 'CPANPLUS::Module', - " Prereq " . $_->module ); - ok( defined $bundle->status->prereqs->{$_->module}, - " Prereq was registered" ); - } -} - -{ ### testing autobundles - my $file = File::Spec->catfile( - dummy_cpan_dir(), - $Conf->_get_build('autobundle'), - 'Snapshot.pm' - ); - my $uri = $CB->_host_to_uri( scheme => 'file', path => $file ); - my $bundle = $CB->parse_module( module => $uri ); - - ok( -e $file, "Creating bundle from '$file'" ); - ok( $bundle, " Object created" ); - isa_ok( $bundle, 'CPANPLUS::Module', - " Object" ); - ok( $bundle->is_bundle, " Recognized as bundle" ); - ok( $bundle->is_autobundle, " Recognized as autobundle" ); - - my $type = $bundle->get_installer_type; - ok( $type, " Found installer type" ); - is( $type, INSTALLER_AUTOBUNDLE, - " Installer type is $type" ); - - my $where = $bundle->fetch; - ok( $where, " Autobundle fetched" ); - ok( -e $where, " File exists" ); - - - my @list = $bundle->bundle_modules; - ok( scalar(@list), " Prereqs found" ); - is( scalar(@list), 1, " Right number of prereqs" ); - isa_ok( $list[0], 'CPANPLUS::Module', - " Object" ); - - ### skiptests to make sure we don't get any test header mismatches - my $rv = $bundle->create( prereq_target => 'create', skiptest => 1 ); - ok( $rv, " Tested prereqs" ); - -} - -### test module from perl core ### -{ isa_ok( $CoreMod, 'CPANPLUS::Module', - "Core module " . $CoreName ); - ok( $CoreMod->package_is_perl_core, - " Package found in perl core" ); - - ### check if it's core with 5.6.1 - { local $] = '5.006001'; - ok( $CoreMod->module_is_supplied_with_perl_core, - " Module also found in perl core"); - } - - ok( !$CoreMod->install, " Package not installed" ); - like( CPANPLUS::Error->stack_as_string, qr/core Perl/, - " Error properly logged" ); -} - -### test third-party modules -SKIP: { - skip "Module::ThirdParty not installed", 10 - unless eval { require Module::ThirdParty; 1 }; - - ok( !$Mod->is_third_party, - "Not a 3rd party module: ". $Mod->name ); - - my $fake = $CB->parse_module( module => 'LOCAL/SVN-Core-1.0' ); - ok( $fake, "Created module object for ". $fake->name ); - ok( $fake->is_third_party, - " It is a 3rd party module" ); - - my $info = $fake->third_party_information; - ok( $info, "Got 3rd party package information" ); - isa_ok( $info, 'HASH' ); - - for my $item ( qw[name url author author_url] ) { - ok( length($info->{$item}), - " $item field is filled" ); - } -} - -### testing EU::Installed methods in Dist::MM tests ### - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t b/cpan/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t deleted file mode 100644 index 7a6b1acb86..0000000000 --- a/cpan/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t +++ /dev/null @@ -1,110 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; - -use CPANPLUS::Backend; - -use Test::More 'no_plan'; -use Data::Dumper; -use File::Spec; -use Cwd; -use File::Basename; -use CPANPLUS::Internals::Constants; - -my $conf = gimme_conf(); - -my $cb = CPANPLUS::Backend->new( $conf ); -isa_ok($cb, "CPANPLUS::Internals" ); - -my $mod = $cb->module_tree( TEST_CONF_MODULE ); -isa_ok( $mod, 'CPANPLUS::Module' ); - -### fail host tests ### -{ my $host = {}; - my $rv = $cb->_add_fail_host( host => $host ); - - ok( $rv, "Failed host added " ); - ok(!$cb->_host_ok( host => $host), - " Host registered as failed" ); - ok( $cb->_host_ok( host => {} ), - " Fresh host unregistered" ); -} - -### refetch, even if it's there already ### -{ my $where = $cb->_fetch( module => $mod, force => 1 ); - - ok( $where, "File downloaded to '$where'" ); - ok( -s $where, " File exists" ); - unlink $where; - ok(!-e $where, " File removed" ); -} - -### try to fetch something that doesn't exist ### -{ ### set up a bogus host first ### - my $hosts = $conf->get_conf('hosts'); - my $fail = { scheme => 'file', - path => "$0/$0" }; - - unshift @$hosts, $fail; - $conf->set_conf( hosts => $hosts ); - - ### the fallback host will get it ### - my $where = $cb->_fetch( module => $mod, force => 1, verbose => 0 ); - ok($where, "File downloaded to '$where'" ); - ok( -s $where, " File exists" ); - - ### but the error should be recorded ### - like( CPANPLUS::Error->stack_as_string, qr/Fetching of .*? failed/s, - " Error recorded appropriately" ); - - ### host marked as bad? ### - ok(!$cb->_host_ok( host => $fail ), - " Failed host logged properly" ); - - ### restore the hosts ### - shift @$hosts; $conf->set_conf( hosts => $hosts ); -} - -### try and fetch a URI -{ my $base = basename($0); - - ### do an ON_UNIX test, cygwin will fail tests otherwise (#14553) - ### create a file URI. Make sure to split it by LOCAL rules - ### and JOIN by unix rules, so we get a proper file uri - ### otherwise, we might break win32. See bug #18702 - my $cwd = cwd(); - my $in_file = $^O eq 'VMS' - ? VMS::Filespec::unixify( File::Spec->catfile($cwd, $base) ) - : File::Spec::Unix->catfile( - File::Spec::Unix->catdir( File::Spec->splitdir( $cwd ) ), - $base - ); - - my $target = CREATE_FILE_URI->($in_file); - - my $fake = $cb->parse_module( module => $target ); - - ok( IS_FAKE_MODOBJ->(mod => $fake), - "Fake module created from $0" ); - is( $fake->status->_fetch_from, $target, - " Fetch from set ok" ); - - my $where = $fake->fetch; - ok( $where, " $target fetched ok" ); - ok( -s $where, " $where exists" ); - like( $where, '/'. UNKNOWN_DL_LOCATION .'/', - " Saved to proper location" ); - like( $where, qr/$base$/, " Saved with proper name" ); -} - - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t b/cpan/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t deleted file mode 100644 index 993b2dc4ac..0000000000 --- a/cpan/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t +++ /dev/null @@ -1,73 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; -use Test::More 'no_plan'; -use Cwd; -use Config; -use File::Basename; - -use CPANPLUS::Internals::Constants; -use CPANPLUS::Module::Fake; -use CPANPLUS::Module::Author::Fake; -use CPANPLUS::Configure; -use CPANPLUS::Backend; - -my $conf = gimme_conf(); - -my $cb = CPANPLUS::Backend->new( $conf ); - -my $f_auth = CPANPLUS::Module::Author::Fake->new( _id => $cb->_id ); -ok( $f_auth, "Fake auth object created" ); -ok( IS_AUTHOBJ->( $f_auth ), " IS_AUTHOBJ recognizes it" ); -ok( IS_FAKE_AUTHOBJ->( $f_auth ), " IS_FAKE_AUTHOBJ recognizes it" ); - -my $f_mod = CPANPLUS::Module::Fake->new( - module => TEST_CONF_INST_MODULE , - path => 'some/where', - package => 'Foo-Bar-1.2.tgz', - _id => $cb->_id, - ); -ok( $f_mod, "Fake mod object created" ); -ok( IS_MODOBJ->( $f_mod ), " IS_MODOBJ recognizes it" ); -ok( IS_FAKE_MODOBJ->( $f_mod ), " IS_FAKE_MODOJB recognizes it" ); - -ok( IS_CONFOBJ->( conf => $conf ), "IS_CONFOBJ recognizes conf object" ); - -ok( FILE_EXISTS->( file => basename($0) ), "FILE_EXISTS finds file" ); -ok( FILE_READABLE->( file => basename($0) ), "FILE_READABLE finds file" ); -ok( DIR_EXISTS->( dir => cwd() ), "DIR_EXISTS finds dir" ); - - -{ no strict 'refs'; - - my $tmpl = { - MAKEFILE_PL => 'Makefile.PL', - BUILD_PL => 'Build.PL', - BLIB => 'blib', - MAKEFILE => do { - ### On vms, it's a different name. See constants - ### file for details - (ON_VMS and $Config::Config{make} =~ /MM[S|K]/i) - ? 'DESCRIP.MMS' - : 'Makefile' - }, - }; - - while ( my($sub,$res) = each %$tmpl ) { - is( &{$sub}->(), $res, "$sub returns proper result without args" ); - - my $long = File::Spec->catfile( cwd(), $res ); - is( &{$sub}->( cwd() ), $long, "$sub returns proper result with args" ); - } -} - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t b/cpan/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t deleted file mode 100644 index 3c18a3b944..0000000000 --- a/cpan/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t +++ /dev/null @@ -1,36 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; - -use CPANPLUS::Configure; -use CPANPLUS::Backend; -use CPANPLUS::Internals::Constants; -use Test::More 'no_plan'; -use Data::Dumper; - -my $conf = gimme_conf(); - -my $cb = CPANPLUS::Backend->new( $conf ); - -### XXX SOURCEFILES FIX -my $mod = $cb->module_tree( TEST_CONF_MODULE ); - -isa_ok( $mod, 'CPANPLUS::Module' ); - -my $where = $mod->fetch; -ok( $where, "Module fetched" ); - -my $dir = $cb->_extract( module => $mod ); -ok( $dir, "Module extracted" ); -ok( DIR_EXISTS->($dir), " Dir exists" ); - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/t/08_CPANPLUS-Backend.t b/cpan/CPANPLUS/t/08_CPANPLUS-Backend.t deleted file mode 100644 index aba3a475f7..0000000000 --- a/cpan/CPANPLUS/t/08_CPANPLUS-Backend.t +++ /dev/null @@ -1,375 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; -use Test::More 'no_plan'; -use File::Basename 'dirname'; - -use Data::Dumper; -use CPANPLUS::Error; -use CPANPLUS::Internals::Constants; - -my $conf = gimme_conf(); - -my $Class = 'CPANPLUS::Backend'; -### D::C has troubles with the 'use_ok' -- it finds the wrong paths. -### for now, do a 'use' instead -#use_ok( $Class ) or diag "$Class not found"; -use CPANPLUS::Backend; - -my $cb = $Class->new( $conf ); -isa_ok( $cb, $Class ); - -my $mt = $cb->module_tree; -my $at = $cb->author_tree; -ok( scalar keys %$mt, "Module tree has entries" ); -ok( scalar keys %$at, "Author tree has entries" ); - -### module_tree tests ### -my $Name = TEST_CONF_MODULE; -my $mod = $cb->module_tree($Name); - -### XXX SOURCEFILES FIX -{ my @mods = $cb->module_tree($Name,$Name); - my $none = $cb->module_tree( TEST_CONF_INVALID_MODULE ); - - ok( IS_MODOBJ->(mod => $mod), "Module object found" ); - is( scalar(@mods), 2, " Module list found" ); - ok( IS_MODOBJ->(mod => $mods[0]), " ISA module object" ); - ok( !IS_MODOBJ->(mod => $none), " Bogus module detected"); -} - -### author_tree tests ### -{ my @auths = $cb->author_tree( $mod->author->cpanid, - $mod->author->cpanid ); - my $none = $cb->author_tree( 'fnurk' ); - - ok( IS_AUTHOBJ->(auth => $mod->author), "Author object found" ); - is( scalar(@auths), 2, " Author list found" ); - ok( IS_AUTHOBJ->( author => $auths[0] )," ISA author object" ); - is( $mod->author, $auths[0], " Objects are identical" ); - ok( !IS_AUTHOBJ->( author => $none ), " Bogus author detected" ); -} - -my $conf_obj = $cb->configure_object; -ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); - - -### parse_module tests ### -{ my @map = ( - $Name => [ - $mod->author->cpanid, # author - $mod->package_name, # package name - $mod->version, # version - ], - $mod => [ - $mod->author->cpanid, - $mod->package_name, - $mod->version, - ], - 'Foo-Bar-EU-NOXS' => [ - $mod->author->cpanid, - $mod->package_name, - $mod->version, - ], - 'Foo-Bar-EU-NOXS-0.01' => [ - $mod->author->cpanid, - $mod->package_name, - '0.01', - ], - 'EUNOXS/Foo-Bar-EU-NOXS' => [ - 'EUNOXS', - $mod->package_name, - $mod->version, - ], - 'EUNOXS/Foo-Bar-EU-NOXS-0.01' => [ - 'EUNOXS', - $mod->package_name, - '0.01', - ], - ### existing module, no extension given - ### this used to create a modobj with no package extension - 'EUNOXS/Foo-Bar-0.02' => [ - 'EUNOXS', - 'Foo-Bar', - '0.02', - ], - 'Foo-Bar-EU-NOXS-0.09' => [ - $mod->author->cpanid, - $mod->package_name, - '0.09', - ], - 'MBXS/Foo-Bar-EU-NOXS-0.01' => [ - 'MBXS', - $mod->package_name, - '0.01', - ], - 'EUNOXS/Foo-Bar-EU-NOXS-0.09' => [ - 'EUNOXS', - $mod->package_name, - '0.09', - ], - 'EUNOXS/Foo-Bar-EU-NOXS-0.09.zip' => [ - 'EUNOXS', - $mod->package_name, - '0.09', - ], - 'FROO/Flub-Flob-1.1.zip' => [ - 'FROO', - 'Flub-Flob', - '1.1', - ], - 'G/GO/GOYALI/SMS_API_3_01.tar.gz' => [ - 'GOYALI', - 'SMS_API', - '3_01', - ], - 'E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091' => [ - 'EYCK', - 'Net-Lite-FTP', - '0.091', - ], - 'EYCK/Net/Lite/Net-Lite-FTP-0.091' => [ - 'EYCK', - 'Net-Lite-FTP', - '0.091', - ], - 'M/MA/MAXDB/DBD-MaxDB-7.5.0.24a' => [ - 'MAXDB', - 'DBD-MaxDB', - '7.5.0.24a', - ], - 'EUNOXS/perl5.005_03.tar.gz' => [ - 'EUNOXS', - 'perl', - '5.005_03', - ], - 'FROO/Flub-Flub-v1.1.0.tbz' => [ - 'FROO', - 'Flub-Flub', - 'v1.1.0', - ], - 'FROO/Flub-Flub-1.1_2.tbz' => [ - 'FROO', - 'Flub-Flub', - '1.1_2', - ], - 'LDS/CGI.pm-3.27.tar.gz' => [ - 'LDS', - 'CGI', - '3.27', - ], - 'FROO/Text-Tabs+Wrap-2006.1117.tar.gz' => [ - 'FROO', - 'Text-Tabs+Wrap', - '2006.1117', - ], - 'JETTERO/Crypt-PBC-0.7.20.0-0.4.9' => [ - 'JETTERO', - 'Crypt-PBC', - '0.7.20.0-0.4.9' , - ], - 'GRICHTER/HTML-Embperl-1.2.1.tar.gz' => [ - 'GRICHTER', - 'HTML-Embperl', - '1.2.1', - ], - 'KANE/File-Fetch-0.15_03' => [ - 'KANE', - 'File-Fetch', - '0.15_03', - ], - 'AUSCHUTZ/IO-Stty-.02.tar.gz' => [ - 'AUSCHUTZ', - 'IO-Stty', - '.02', - ], - '.' => [ - 'CPANPLUS', - 't', - '', - ], - 'Foo/Bar.pm' => [ - $mod->author->cpanid, # author - $mod->package_name, # package name - $mod->version, # version - ], - ); - - while ( my($guess, $attr) = splice @map, 0, 2 ) { - my( $author, $pkg_name, $version ) = @$attr; - - ok( $guess, "Attempting to parse $guess" ); - - my $obj = $cb->parse_module( module => $guess ); - - ok( $obj, " Result returned" ); - ok( IS_MODOBJ->( mod => $obj ), - " parse_module success by '$guess'" ); - - is( $obj->version, $version, - " Proper version found: $version" ); - is( $obj->package_version, $version, - " Found in package_version as well" ); - - ### VMS doesn't preserve case, so match them after normalizing case - is( uc($obj->package_name), uc($pkg_name), - " Proper package_name found: $pkg_name" ); - unlike( $obj->package_name, qr/\d/, - " No digits in package name" ); - { my $ext = $obj->package_extension; - ok( $ext, " Has extension as well: $ext" ); - } - - like( $obj->author->cpanid, "/$author/i", - " Proper author found: $author"); - like( $obj->path, "/$author/i", - " Proper path found: " . $obj->path ); - } - - - ### test for things that look like real modules, but aren't ### - { my @map = ( - [ $Name . $$ => [ - [qr/does not contain an author/,"Missing author part detected"], - [qr/Cannot find .+? in the module tree/,"Unable to find module"] - ] ], - [ {}, => [ - [ qr/module string from reference/,"Unable to parse ref"] - ] ], - ); - - for my $entry ( @map ) { - my($mod,$aref) = @$entry; - - my $none = $cb->parse_module( module => $mod ); - ok( !IS_MODOBJ->(mod => $none), - "Non-existent module detected" ); - ok( !IS_FAKE_MODOBJ->(mod => $none), - "Non-existent fake module detected" ); - - my $str = CPANPLUS::Error->stack_as_string; - for my $pair (@$aref) { - my($re,$diag) = @$pair; - like( $str, $re," $diag" ); - } - } - } - - ### test parsing of arbitrary URI - for my $guess ( qw[ http://foo/bar.gz - http://a/b/c/d/e/f/g/h/i/j - flub://floo ] - ) { - my $obj = $cb->parse_module( module => $guess ); - ok( IS_FAKE_MODOBJ->(mod => $obj), - "parse_module success by '$guess'" ); - is( $obj->status->_fetch_from, $guess, - " Fetch from set ok" ); - } -} - -### RV tests ### -{ my $method = 'readme'; - my %args = ( modules => [$Name] ); - - my $rv = $cb->$method( %args ); - ok( IS_RVOBJ->( $rv ), "Got an RV object" ); - ok( $rv->ok, " Overall OK" ); - cmp_ok( $rv, '==', 1, " Overload OK" ); - is( $rv->function, $method, " Function stored OK" ); - is_deeply( $rv->args, \%args, " Arguments stored OK" ); - is( $rv->rv->{$Name}, $mod->readme, " RV as expected" ); -} - -### reload_indices tests ### -{ - my $file = File::Spec->catfile( $conf->get_conf('base'), - $conf->_get_source('mod'), - ); - - ok( $cb->reload_indices( update_source => 0 ), "Rebuilding trees" ); - my $age = -M $file; - - ### make sure we are 'newer' on faster machines with a sleep.. - ### apparently Win32's FAT isn't granual enough on intervals - ### < 2 seconds, so it may give the same answer before and after - ### the sleep, causing the test to fail. so sleep atleast 2 seconds. - sleep 2; - ok( $cb->reload_indices( update_source => 1 ), - "Rebuilding and refetching trees" ); - cmp_ok( $age, '>', -M $file, " Source file '$file' updated" ); -} - -### flush tests ### -{ - for my $cache( qw[methods hosts modules lib all] ) { - ok( $cb->flush($cache), "Cache $cache flushed ok" ); - } -} - -### installed tests ### -{ ok( scalar($cb->installed), "Found list of installed modules" ); -} - -### autobudle tests ### -{ - my $where = $cb->autobundle; - ok( $where, "Autobundle written" ); - ok( -s $where, " File has size" ); -} - -### local_mirror tests ### -{ ### turn off md5 checks for the 'fake' packages we have - my $old_md5 = $conf->get_conf('md5'); - $conf->set_conf( md5 => 0 ); - - ### otherwise 'status->fetch' might be undef! ### - my $rv = $cb->local_mirror( path => 'dummy-localmirror' ); - ok( $rv, "Local mirror created" ); - - for my $mod ( values %{ $cb->module_tree } ) { - my $name = $mod->module; - - my $cksum = File::Spec->catfile( - dirname($mod->status->fetch), - CHECKSUMS ); - ok( -e $mod->status->fetch, " Module '$name' fetched" ); - ok( -s _, " Module '$name' has size" ); - ok( -e $cksum, " Checksum fetched for '$name'" ); - ok( -s _, " Checksum for '$name' has size" ); - } - - $conf->set_conf( md5 => $old_md5 ); -} - -### check ENV variable -{ ### process id - { my $name = 'PERL5_CPANPLUS_IS_RUNNING'; - ok( $ENV{$name}, "Env var '$name' set" ); - is( $ENV{$name}, $$, " Set to current process id" ); - } - - ### Version - { my $name = 'PERL5_CPANPLUS_IS_VERSION'; - ok( $ENV{$name}, "Env var '$name' set" ); - - ### version.pm formats ->VERSION output... *sigh* - is( $ENV{$name}, $Class->VERSION, - " Set to current process version" ); - } - -} - -__END__ - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - diff --git a/cpan/CPANPLUS/t/09_CPANPLUS-Internals-Search.t b/cpan/CPANPLUS/t/09_CPANPLUS-Internals-Search.t deleted file mode 100644 index e5ef37cb68..0000000000 --- a/cpan/CPANPLUS/t/09_CPANPLUS-Internals-Search.t +++ /dev/null @@ -1,83 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; -use Test::More 'no_plan'; -use Data::Dumper; -use CPANPLUS::Backend; -use CPANPLUS::Internals::Constants; - -my $Conf = gimme_conf(); -my $CB = CPANPLUS::Backend->new($Conf); -my $ModName = TEST_CONF_MODULE; -my $Mod = $CB->module_tree( $ModName ); - - -### search for modules ### -for my $type ( CPANPLUS::Module->accessors() ) { - - ### don't muck around with references/objects - ### or private identifiers - next if ref $Mod->$type() or $type =~/^_/; - - my @aref = $CB->search( - type => $type, - allow => [$Mod->$type()], - ); - - ok( scalar @aref, "Module found by '$type'" ); - for( @aref ) { - ok( IS_MODOBJ->($_)," Module isa module object" ); - } -} - -### search for authors ### -my $auth = $Mod->author; -for my $type ( CPANPLUS::Module::Author->accessors() ) { - - ### don't muck around with references/objects - ### or private identifiers - next if ref $auth->$type() or $type =~/^_/; - - my @aref = $CB->search( - type => $type, - allow => [$auth->$type()], - ); - - ok( @aref, "Author found by '$type'" ); - for( @aref ) { - ok( IS_AUTHOBJ->($_), " Author isa author object" ); - } -} - - -{ my $warning = ''; - local $SIG{__WARN__} = sub { $warning .= "@_"; }; - - { ### try search that will yield nothing ### - ### XXX SOURCEFILES FIX - my @list = $CB->search( type => 'module', - allow => [$ModName.$$] ); - - is( scalar(@list), 0, "Valid search yields no results" ); - is( $warning, '', " No warnings issued" ); - } - - { ### try bogus arguments ### - my @list = $CB->search( type => '', allow => ['foo'] ); - - is( scalar(@list), 0, "Broken search yields no results" ); - like( $warning, qr/^Key 'type'.* is of invalid type for/, - " Got a warning for wrong arguments" ); - } -} - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/t/10_CPANPLUS-Error.t b/cpan/CPANPLUS/t/10_CPANPLUS-Error.t deleted file mode 100644 index 355ca7aad4..0000000000 --- a/cpan/CPANPLUS/t/10_CPANPLUS-Error.t +++ /dev/null @@ -1,114 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; -use Test::More 'no_plan'; -use Data::Dumper; -use FileHandle; -use CPANPLUS::Error; - -my $conf = gimme_conf(); - -my $map = { - cp_msg => ["This is just a test message"], - msg => ["This is just a test message"], - cp_error => ["This is just a test error"], - error => ["This is just a test error"], -}; - -### check if CPANPLUS::Error can do what we expect -{ for my $name ( keys %$map ) { - can_ok('CPANPLUS::Error', $name); - can_ok('main', $name); # did it get exported? - } -} - -### make sure we start with an empty stack -{ CPANPLUS::Error->flush; - is( scalar(()=CPANPLUS::Error->stack), 0, - "Starting with empty stack" ); -} - -### global variables test ### -{ my $file = output_file(); - - ### this *has* to be set, as we're testing the contents of the file - ### to see if it matches what's stored in the buffer. - local $CPANPLUS::Error::MSG_FH = output_handle(); - local $CPANPLUS::Error::ERROR_FH = output_handle(); - - ok( -e $file, "Output redirect file exists" ); - ok( !-s $file, " Output file is empty" ); - - ### print a msg & error ### - for my $name ( keys %$map ) { - my $sub = __PACKAGE__->can( $name ); - - $sub->( $map->{$name}->[0], 1 ); - } - - ### must close it for Win32 tests! - close output_handle; - - ok( -s $file, " Output file now has size" ); - - my $fh = FileHandle->new( $file ); - ok( $fh, "Opened output file for reading " ); - - my $contents = do { local $/; <$fh> }; - my $string = CPANPLUS::Error->stack_as_string; - my $trace = CPANPLUS::Error->stack_as_string(1); - - ok( $contents, " Got the file contents" ); - ok( $string, "Got the error stack as string" ); - - - for my $type ( keys %$map ) { - my $tag = $type; $tag =~ s/.+?_//g; - - for my $str (@{ $map->{$type} } ) { - like( $contents, qr/\U\Q$tag/, - " Contents matches for '$type'" ); - like( $contents, qr/\Q$str/, - " Contents matches for '$type'" ); - - like( $string, qr/\U\Q$tag/, - " String matches for '$type'" ); - like( $string, qr/\Q$str/, - " String matches for '$type'" ); - - like( $trace, qr/\U\Q$tag/, - " Trace matches for '$type'" ); - like( $trace, qr/\Q$str/, - " Trace matches for '$type'" ); - - ### extra trace tests ### - like( $trace, qr/\Q$str\E.*?\Q$str/s, - " Trace holds proper traceback" ); - like( $trace, qr/\Q$0/, - " Trace holds program name" ); - like( $trace, qr/line/, - " Trace holds line number information" ); - } - } - - ### check the stack, flush it, check again ### - is( scalar(()=CPANPLUS::Error->stack), scalar(keys(%$map)), - "All items on stack" ); - is( scalar(()=CPANPLUS::Error->flush), scalar(keys(%$map)), - "All items flushed" ); - is( scalar(()=CPANPLUS::Error->stack), 0, - "No items on stack" ); - -} - - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/t/15_CPANPLUS-Shell.t b/cpan/CPANPLUS/t/15_CPANPLUS-Shell.t deleted file mode 100644 index 51283c6727..0000000000 --- a/cpan/CPANPLUS/t/15_CPANPLUS-Shell.t +++ /dev/null @@ -1,152 +0,0 @@ -### the shell prints to STDOUT, so capture that here -### and we can check the output -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -### this lets us capture output from the default shell -{ no warnings 'redefine'; - - my $out; - *CPANPLUS::Shell::Default::__print = sub { - my $self = shift; - $out .= "@_"; - }; - - sub _out { $out } - sub _reset_out { $out = '' } -} - -use strict; -use Test::More 'no_plan'; -use CPANPLUS::Internals::Constants; - -### in some subprocesses, the Term::ReadKey code will go -### balistic and die because it can't figure out terminal -### dimensions. If we add these env vars, it'll use them -### as a default and not die. Thanks to Slaven Rezic for -### reporting this. -local $ENV{'COLUMNS'} = 80 unless $ENV{'COLUMNS'}; -local $ENV{'LINES'} = 40 unless $ENV{'LINES'}; - -my $Conf = gimme_conf(); -my $Class = 'CPANPLUS::Shell'; -my $Default = SHELL_DEFAULT; -my $TestMod = TEST_CONF_MODULE; -my $TestAuth= TEST_CONF_AUTHOR; - -unless ( -t ) { - ok('We are not on a terminal'); - exit 0; -} - -### basic load tests -use_ok( $Class, 'Default' ); -is( $Class->which, SHELL_DEFAULT, - "Default shell loaded" ); -### create an object -my $Shell = $Class->new( $Conf ); -ok( $Shell, " New object created" ); -isa_ok( $Shell, $Default, " Object" ); - -### method tests -{ - ### uri to use for /cs tests - my $cs_path = File::Spec->rel2abs( - File::Spec->catfile( - $FindBin::Bin, - TEST_CONF_CPAN_DIR, - ) - ); - my $cs_uri = $Shell->backend->_host_to_uri( - scheme => 'file', - host => '', - path => $cs_path, - ); - - my $base = $Conf->get_conf('base'); - - ### XXX have to keep the list ordered, as some methods only work as - ### expected *after* others have run - my @map = ( - 'v' => qr/CPANPLUS/, - '! $self->__print($$)' => qr/$$/, - '?' => qr/\[General\]/, - 'h' => qr/\[General\]/, - 's' => qr/Unknown type/, - 's conf' => qr/$Default/, - 's program' => qr/sudo/, - 's mirrors' => do { my $re = TEST_CONF_CPAN_DIR; qr/$re/ }, - 's selfupdate' => qr/selfupdate/, - 'b' => qr/autobundle/, - "a $TestAuth" => qr/$TestAuth/, - "m $TestMod" => qr/$TestMod/, - "w" => qr/$TestMod/, - "r 1" => qr/README/, - "r $TestMod" => qr/README/, - "f $TestMod" => qr/$TestAuth/, - "d $TestMod" => qr/$TestMod/, - ### XXX this one prints to stdout in a subprocess -- skipping this - ### for now due to possible PERL_CORE issues - #"t $TestMod" => qr/$TestMod.*tested successfully/i, - "l $TestMod" => qr/$TestMod/, - '! die $$; p' => qr/$$/, - '/plugins' => qr/Available plugins:/i, - '/? ?' => qr/usage/i, - - ### custom source plugin tests - ### lower case path matching, as on VMS we can't predict case - "/? cs" => qr|/cs|, - "/cs --add $cs_uri" => qr/Added remote source/, - "/cs --list" => do { my $re = quotemeta($cs_uri); qr/$re/i }, - "/cs --contents $cs_uri" => qr/$TestAuth/i, - "/cs --update" => qr/Updated remote sources/, - "/cs --update $cs_uri" => qr/Updated remote sources/, - - ### --write leaves a file that we should clean up, so make - ### sure it's in the path that we clean up already anyway - "/cs --write $base" => qr/Wrote remote source index/, - "/cs --remove $cs_uri" => qr/Removed remote source/, - ); - - my $meth = 'dispatch_on_input'; - can_ok( $Shell, $meth ); - - while( my($input,$out_re) = splice(@map, 0, 2) ) { - - ### empty output cache - __PACKAGE__->_reset_out; - CPANPLUS::Error->flush; - - ok( 1, "Testing '$input'" ); - $Shell->$meth( input => $input ); - - my $out = __PACKAGE__->_out; - - ### XXX remove me - #diag( $out ); - - ok( $out, " Output received" ); - like( $out, $out_re, " Output matches '$out_re'" ); - } -} - -__END__ - -#### test separately, they have side effects -'q' => qr/^$/, # no output! -'s save boxed' => do { my $re = CONFIG_BOXED; qr/$re/ }, -### this doens't write any output -'x --update_source' => qr/module tree/i, -s edit -s reconfigure -'c' => '_reports', -'i' => '_install', -'u' => '_uninstall', -'z' => '_shell', -### might not have any out of date modules... -'o' => '_uptodate', - - diff --git a/cpan/CPANPLUS/t/19_CPANPLUS-Dist.t b/cpan/CPANPLUS/t/19_CPANPLUS-Dist.t deleted file mode 100644 index b551741eef..0000000000 --- a/cpan/CPANPLUS/t/19_CPANPLUS-Dist.t +++ /dev/null @@ -1,441 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -### dummy class for testing dist api ### -BEGIN { - - package CPANPLUS::Dist::_Test; - use strict; - use vars qw[$Available $Create $Install $Init $Prepare @ISA]; - - @ISA = qw[CPANPLUS::Dist]; - $Available = 1; - $Create = 1; - $Install = 1; - $Init = 1; - $Prepare = 1; - - require CPANPLUS::Dist; - CPANPLUS::Dist->_add_dist_types( __PACKAGE__ ); - - sub init { $_[0]->status->mk_accessors( - qw[prepared created installed - _prepare_args _install_args _create_args]); - return $Init }; - sub format_available { return $Available } - sub prepare { return shift->status->prepared( $Prepare ) } - sub create { return shift->status->created( $Create ) } - sub install { return shift->status->installed( $Install ) } -} - -use strict; - -use CPANPLUS::Configure; -use CPANPLUS::Backend; -use CPANPLUS::Internals::Constants; - -use Test::More 'no_plan'; -use Cwd; -use Data::Dumper; -use File::Basename (); -use File::Spec (); -use Module::Load::Conditional qw[check_install]; - -my $conf = gimme_conf(); -my $cb = CPANPLUS::Backend->new( $conf ); - -### obsolete -#my $Format = '_test'; -my $Module = 'CPANPLUS::Dist::_Test'; -my $ModName = TEST_CONF_MODULE; -my $ModPrereq = TEST_CONF_INST_MODULE; -### XXX this version doesn't exist, but we don't check for it either ### -my $Prereq = { $ModPrereq => '1000' }; - -### since it's in this file, not in its own module file, -### make M::L::C think it already was loaded -$Module::Load::Conditional::CACHE->{$Module}->{usable} = 1; - - -use_ok('CPANPLUS::Dist'); - -### start with fresh sources ### -ok( $cb->reload_indices( update_source => 0 ), - "Rebuilding trees" ); - -my $Mod = $cb->module_tree( $ModName ); -ok( $Mod, "Got module object" ); - - -### straight forward dist build - prepare, create, install -{ my $dist = $Module->new( module => $Mod ); - - ok( $dist, "New dist object created" ); - isa_ok( $dist, 'CPANPLUS::Dist' ); - isa_ok( $dist, $Module ); - - my $status = $dist->status; - ok( $status, "Status object found" ); - isa_ok( $status, "Object::Accessor" ); - - ok( $dist->prepare, "Prepare call" ); - ok( $dist->status->prepared," Status registered OK" ); - - ok( $dist->create, "Create call" ); - ok( $dist->status->created, " Status registered OK" ); - - ok( $dist->install, "Install call" ); - ok( $dist->status->installed, - " Status registered OK" ); -} - -### check 'sanity check' option ### -{ local $CPANPLUS::Dist::_Test::Available = 0; - - ok( !$Module->format_available, - "Format availability turned off" ); - - { $conf->_set_build('sanity_check' => 0); - - my $dist = $Module->new( module => $Mod ); - - ok( $dist, "Dist created with sanity check off" ); - isa_ok( $dist, $Module ); - - } - - { $conf->_set_build('sanity_check' => 1); - - my $dist = $Module->new( module => $Mod ); - - ok( !$dist, "Dist not created with sanity check on" ); - like( CPANPLUS::Error->stack_as_string, - qr/Format '$Module' is not available/, - " Error recorded as expected" ); - } -} - -### undef the status hash, make sure it complains ### -{ local $CPANPLUS::Dist::_Test::Init = 0; - - my $dist = $Module->new( module => $Mod ); - - ok( !$dist, "No dist created by failed init" ); - like( CPANPLUS::Error->stack_as_string, - qr/Dist initialization of '$Module' failed for/s, - " Error recorded as expected" ); -} - -### configure_requires tests -{ my $meta = META->( $Mod ); - ok( $meta, "Reading 'configure_requires' from '$meta'" ); - - my $clone = $Mod->clone; - ok( $clone, " Package cloned" ); - - ### set the new location to fetch from - $clone->package( $meta ); - - my $file = $clone->fetch; - ok( $file, " Meta file fetched" ); - ok( -e $file, " File '$file' exits" ); - - my $dist = $Module->new( module => $Mod ); - - ok( $dist, " Dist object created" ); - - my $meth = 'find_configure_requires'; - can_ok( $dist, $meth ); - - my $href = $dist->$meth( file => $file ); - ok( $href, " '$meth' returned hashref" ); - - ok( scalar(keys(%$href)), " Contains entries" ); - ok( $href->{ +TEST_CONF_PREREQ }, - " Contains the right prereq" ); -} - - -### test _resolve prereqs, in a somewhat simulated set of circumstances -{ my $old_prereq = $conf->get_conf('prereqs'); - - my $map = { - 0 => { - 'Previous install failed' => [ - sub { $cb->module_tree($ModPrereq)->status->installed(0); - 'install' }, - sub { like( CPANPLUS::Error->stack_as_string, - qr/failed to install before in this session/s, - " Previous install failed recorded ok" ) }, - ], - - "Set $Module->prepare to false" => [ - sub { $CPANPLUS::Dist::_Test::Prepare = 0; 'install' }, - sub { like( CPANPLUS::Error->stack_as_string, - qr/Unable to create a new distribution object/s, - " Dist creation failed recorded ok" ) }, - sub { like( CPANPLUS::Error->stack_as_string, - qr/Failed to install '$ModPrereq' as prerequisite/s, - " Dist creation failed recorded ok" ) }, - ], - - "Set $Module->create to false" => [ - sub { $CPANPLUS::Dist::_Test::Create = 0; 'install' }, - sub { like( CPANPLUS::Error->stack_as_string, - qr/Unable to create a new distribution object/s, - " Dist creation failed recorded ok" ) }, - sub { like( CPANPLUS::Error->stack_as_string, - qr/Failed to install '$ModPrereq' as prerequisite/s, - " Dist creation failed recorded ok" ) }, - ], - - "Set $Module->install to false" => [ - sub { $CPANPLUS::Dist::_Test::Install = 0; 'install' }, - sub { like( CPANPLUS::Error->stack_as_string, - qr/Failed to install '$ModPrereq' as/s, - " Dist installation failed recorded ok" ) }, - ], - - 'Simple ignore' => [ - sub { 'ignore' }, - sub { ok( !$_[0]->status->prepared, - " Module status says not prepared" ) }, - sub { ok( !$_[0]->status->created, - " Module status says not created" ) }, - sub { ok( !$_[0]->status->installed, - " Module status says not installed" ) }, - ], - 'Ignore from conf' => [ - sub { $conf->set_conf(prereqs => PREREQ_IGNORE); '' }, - sub { ok( !$_[0]->status->prepared, - " Module status says not prepared" ) }, - sub { ok( !$_[0]->status->created, - " Module status says not created" ) }, - sub { ok( !$_[0]->status->installed, - " Module status says not installed" ) }, - ### set the conf back ### - sub { $conf->set_conf(prereqs => PREREQ_INSTALL); }, - ], - 'Perl binary version too low' => [ - sub { $cb->module_tree( $ModName ) - ->status->prereqs({ PERL_CORE, 10000000000 }); '' }, - sub { like( CPANPLUS::Error->stack_as_string, - qr/needs perl version/, - " Perl version not high enough" ) }, - ], - }, - 1 => { - 'Simple create' => [ - sub { 'create' }, - sub { ok( $_[0]->status->prepared, - " Module status says prepared" ) }, - sub { ok( $_[0]->status->created, - " Module status says created" ) }, - sub { ok( !$_[0]->status->installed, - " Module status says not installed" ) }, - ], - 'Simple install' => [ - sub { 'install' }, - sub { ok( $_[0]->status->prepared, - " Module status says prepared" ) }, - sub { ok( $_[0]->status->created, - " Module status says created" ) }, - sub { ok( $_[0]->status->installed, - " Module status says installed" ) }, - ], - - "Set dependency to be perl-core" => [ - sub { $cb->module_tree( $ModPrereq )->package( - 'perl-5.8.1.tar.gz' ); 'install' }, - sub { like( CPANPLUS::Error->stack_as_string, - qr/Prerequisite '$ModPrereq' is perl-core/s, - " Dist installation failed recorded ok" ) }, - ], - - 'Install from conf' => [ - sub { $conf->set_conf(prereqs => PREREQ_INSTALL); '' }, - sub { ok( $_[0]->status->prepared, - " Module status says prepared" ) }, - sub { ok( $_[0]->status->created, - " Module status says created" ) }, - sub { ok( $_[0]->status->installed, - " Module status says installed" ) }, - ], - 'Create from conf' => [ - sub { $conf->set_conf(prereqs => PREREQ_BUILD); '' }, - sub { ok( $_[0]->status->prepared, - " Module status says prepared" ) }, - sub { ok( $_[0]->status->created, - " Module status says created" ) }, - sub { ok( !$_[0]->status->installed, - " Module status says not installed" ) }, - ### set the conf back ### - sub { $conf->set_conf(prereqs => PREREQ_INSTALL); }, - ], - - 'Ask from conf' => [ - sub { $cb->_register_callback( - name => 'install_prerequisite', - code => sub {1} ); - $conf->set_conf(prereqs => PREREQ_ASK); '' }, - sub { ok( $_[0]->status->prepared, - " Module status says prepared" ) }, - sub { ok( $_[0]->status->created, - " Module status says created" ) }, - sub { ok( $_[0]->status->installed, - " Module status says installed" ) }, - ### set the conf back ### - sub { $conf->set_conf(prereqs => PREREQ_INSTALL); }, - - ], - - 'Ask from conf, but decline' => [ - sub { $cb->_register_callback( - name => 'install_prerequisite', - code => sub {0} ); - $conf->set_conf( prereqs => PREREQ_ASK); '' }, - sub { ok( !$_[0]->status->installed, - " Module status says not installed" ) }, - sub { like( CPANPLUS::Error->stack_as_string, - qr/Will not install prerequisite '$ModPrereq' -- Note/, - " Install skipped, recorded ok" ) }, - ### set the conf back ### - sub { $conf->set_conf(prereqs => PREREQ_INSTALL); }, - ], - - "Set recursive dependency" => [ - sub { $cb->_status->pending_prereqs({ $ModPrereq => 1 }); - 'install' }, - sub { like( CPANPLUS::Error->stack_as_string, - qr/Recursive dependency detected/, - " Recursive dependency recorded ok" ) }, - ], - 'Perl binary version sufficient' => [ - sub { $cb->module_tree( $ModName ) - ->status->prereqs({ PERL_CORE, 1 }); '' }, - sub { unlike( CPANPLUS::Error->stack_as_string, - qr/needs perl version/, - " Perl version sufficient" ) }, - ], - }, - }; - - for my $bool ( sort keys %$map ) { - - diag("Running ". ($bool?'success':'fail') . " tests") if @ARGV; - - my $href = $map->{$bool}; - while ( my($txt,$aref) = each %$href ) { - - ### reset everything ### - ok( $cb->reload_indices( update_source => 0 ), - "Rebuilding trees" ); - - $CPANPLUS::Dist::_Test::Available = 1; - $CPANPLUS::Dist::_Test::Prepare = 1; - $CPANPLUS::Dist::_Test::Create = 1; - $CPANPLUS::Dist::_Test::Install = 1; - - CPANPLUS::Error->flush; - $cb->_status->mk_flush; - - ### get a new dist from Text::Bastardize ### - my $mod = $cb->module_tree( $ModName ); - my $dist = $Module->new( module => $mod ); - - ### first sub returns target ### - my $sub = shift @$aref; - my $target = $sub->(); - - my $flag = $dist->_resolve_prereqs( - format => $Module, - force => 1, - target => $target, - prereqs => ($mod->status->prereqs || $Prereq) ); - - is( !!$flag, !!$bool, $txt ); - - ### any extra tests ### - $_->($cb->module_tree($ModPrereq)) for @$aref; - - } - } -} - - -### prereq satisfied tests -{ my $map = { - # version regex - 0 => undef, - 1 => undef, - 2 => qr/have to resolve/, - }; - - my $mod = CPANPLUS::Module::Fake->new( - module => $$, - package => $$, - path => $$, - version => 1 ); - - ok( $mod, "Fake module created" ); - is( $mod->version, 1, " Version set correctly" ); - - my $dist = $Module->new( module => $Mod ); - - ok( $dist, "Dist object created" ); - isa_ok( $dist, $Module ); - - - ### scope it for the locals - { local $^W; # quell sub redefined warnings; - - ### is_uptodate will need to return false for this test - local *CPANPLUS::Module::Fake::is_uptodate = sub { return }; - local *CPANPLUS::Module::Fake::is_uptodate = sub { return }; - CPANPLUS::Error->flush; - - - ### it's satisfied - while( my($ver, $re) = each %$map ) { - - my $rv = $dist->prereq_satisfied( - version => $ver, - modobj => $mod ); - - ok( 1, "Testing ver: $ver" ); - is( $rv, undef, " Return value as expected" ); - - if( $re ) { - like( CPANPLUS::Error->stack_as_string, $re, - " Error as expected" ); - } - - CPANPLUS::Error->flush; - } - } -} - - -### dist_types tests -{ can_ok( 'CPANPLUS::Dist', 'dist_types' ); - - SKIP: { - skip "You do not have Module::Pluggable installed", 2 - unless check_install( module => 'Module::Pluggable' ); - - my @types = CPANPLUS::Dist->dist_types; - ok( scalar(@types), " Dist types found" ); - ok( grep( /_Test/, @types), " Found our _Test dist type" ); - } -} -1; - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/t/20_CPANPLUS-Dist-MM.t b/cpan/CPANPLUS/t/20_CPANPLUS-Dist-MM.t deleted file mode 100644 index 5bba137159..0000000000 --- a/cpan/CPANPLUS/t/20_CPANPLUS-Dist-MM.t +++ /dev/null @@ -1,430 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; - -use CPANPLUS::Configure; -use CPANPLUS::Backend; -use CPANPLUS::Dist; -use CPANPLUS::Dist::MM; -use CPANPLUS::Internals::Constants; - -use Test::More 'no_plan'; -use Cwd; -use Config; -use Data::Dumper; -use File::Basename (); -use File::Spec (); - -my $conf = gimme_conf(); -my $cb = CPANPLUS::Backend->new( $conf ); -my $File = 'Bar.pm'; - -### if we need sudo that's no guarantee we can actually run it -### so set $noperms if sudo is required, as that may mean tests -### fail if you're not allowed to execute sudo. This resolves -### #29904: make test should not use sudo -my $noperms = $conf->get_program('sudo') || #you need sudo - $conf->get_conf('makemakerflags') || #you set some funky flags - not -w $Config{installsitelib}; #cant write to install target - -#$IPC::Cmd::DEBUG = $Verbose; - -### Make sure we get the _EUMM_NOXS_ version -my $ModName = TEST_CONF_MODULE; - -### This is the module name that gets /installed/ -my $InstName = TEST_CONF_INST_MODULE; - -### don't start sending test reports now... ### -$cb->_callbacks->send_test_report( sub { 0 } ); -$conf->set_conf( cpantest => 0 ); - -### Redirect errors to file ### -*STDERR = output_handle() unless $conf->get_conf('verbose'); - -### dont uncomment this, it screws up where STDOUT goes and makes -### test::harness create test counter mismatches -#*STDOUT = output_handle() unless @ARGV; -### for the same test-output counter mismatch, we disable verbose -### mode -$conf->set_conf( allow_build_interactivity => 0 ); - -### start with fresh sources ### -ok( $cb->reload_indices( update_source => 0 ), - "Rebuilding trees" ); - -### we might need this Some Day when we're going to install into -### our own sandbox dir.. but for now, no dice due to EU::I bug -# $conf->set_program( sudo => '' ); -# $conf->set_conf( makemakerflags => TEST_INSTALL_EU_MM_FLAGS ); - -### set alternate install dir ### -### XXX rather pointless, since we can't uninstall them, due to a bug -### in EU::Installed (6871). And therefor we can't test uninstall() or any of -### the EU::Installed functions. So, let's just install into sitelib... =/ -#my $prefix = File::Spec->rel2abs( File::Spec->catdir(cwd(),'dummy-perl') ); -#my $rv = $cb->configure_object->set_conf( makemakerflags => "PREFIX=$prefix" ); -#ok( $rv, "Alternate install path set" ); - -my $Mod = $cb->module_tree( $ModName ); -my $InstMod = $cb->module_tree( $InstName ); -ok( $Mod, "Loaded object for: " . $Mod->name ); -ok( $Mod, "Loaded object for: " . $InstMod->name ); - -### format_available tests ### -{ ok( CPANPLUS::Dist::MM->format_available, - "Format is available" ); - - ### whitebox test! - { local $^W; - local *CPANPLUS::Dist::MM::can_load = sub { 0 }; - ok(!CPANPLUS::Dist::MM->format_available, - " Making format unavailable" ); - } - - ### test if the error got logged ok ### - like( CPANPLUS::Error->stack_as_string, - qr/You do not have .+?'CPANPLUS::Dist::MM' not available/s, - " Format failure logged" ); - - ### flush the stack ### - CPANPLUS::Error->flush; -} - -ok( $Mod->fetch, "Fetching module to ".$Mod->status->fetch ); -ok( $Mod->extract, "Extracting module to ".$Mod->status->extract ); - -### test target => 'init' -{ my $dist = $Mod->dist( target => TARGET_INIT ); - ok( $dist, "Dist created with target => " . TARGET_INIT ); - ok( !$dist->status->prepared, - " Prepare was not run" ); -} - -ok( $Mod->test, "Testing module" ); - -ok( $Mod->status->dist_cpan->status->test, - " Test success registered as status" ); -ok( $Mod->status->dist_cpan->status->prepared, - " Prepared status registered" ); -ok( $Mod->status->dist_cpan->status->created, - " Created status registered" ); -is( $Mod->status->dist_cpan->status->distdir, $Mod->status->extract, - " Distdir status registered properly" ); - -### test the convenience methods -ok( $Mod->prepare, "Preparing module" ); -ok( $Mod->create, "Creating module" ); - -ok( $Mod->dist, "Building distribution" ); -ok( $Mod->status->dist_cpan, " Dist registered as status" ); -isa_ok( $Mod->status->dist_cpan, "CPANPLUS::Dist::MM" ); - -### flush the lib cache -### otherwise, cpanplus thinks the module's already installed -### since the blib is already in @INC -$cb->_flush( list => [qw|lib|] ); - -SKIP: { - - skip(q[No install tests under core perl], 10) if $ENV{PERL_CORE}; - skip(q[Possibly no permission to install, skipping], 10) if $noperms; - - ### we now say 'no perms' if sudo is configured, as per #29904 - #diag(q[Note: 'sudo' might ask for your password to do the install test]) - # if $conf->get_program('sudo'); - - ### make sure no options are set in PERL5_MM_OPT, as they might - ### change the installation target and therefor will 1. mess up - ### the tests and 2. leave an installed copy of our test module - ### lying around. This addresses bug #29716: 20_CPANPLUS-Dist-MM.t - ### fails (and leaves test files installed) when EUMM options - ### include INSTALL_BASE - { local $ENV{'PERL5_MM_OPT'}; local $ENV{'PERL_MM_OPT'}; - - ### add the new dir to the configuration too, so eu::installed tests - ### work as they should - $conf->set_conf( lib => [ TEST_CONF_INSTALL_DIR ] ); - - ok( $Mod->install( force => 1, - makemakerflags => 'PREFIX='.TEST_CONF_INSTALL_DIR, - ), "Installing module" ); - } - - ok( $Mod->status->installed," Module installed according to status" ); - - - SKIP: { ### EU::Installed tests ### - ### EU::I sometimes fails. See: - ### #43292: ~/CPANPLUS-0.85_04 fails t/20_CPANPLUS-Dist-MM.t - ### #46890: ExtUtils::Installed + EU::MM PREFIX= don't always work - ### well together - skip( "ExtUtils::Installed issue #46890 prevents these tests from running reliably", 8 ); - - - skip( "Old perl on cygwin detected " . - "-- tests will fail due to known bugs", 8 - ) if ON_OLD_CYGWIN; - - ### might need it Later when EU::I is fixed.. - #local @INC = ( TEST_INSTALL_DIR_LIB, @INC ); - - { ### validate - my @missing = $InstMod->validate; - - is_deeply( \@missing, [], - "No missing files" ); - } - - { ### files - my @files = $InstMod->files; - - ### number of files may vary from OS to OS - ok( scalar(@files), "All files accounted for" ); - ok( grep( /$File/, @files), - " Found the module" ); - - ### XXX does this work on all OSs? - #ok( grep( /man/, @files ), - # " Found the manpage" ); - } - - { ### packlist - my ($obj) = $InstMod->packlist; - isa_ok( $obj, "ExtUtils::Packlist" ); - } - - { ### directory_tree - my @dirs = $InstMod->directory_tree; - ok( scalar(@dirs), "Directory tree obtained" ); - - my $found; - for my $dir (@dirs) { - ok( -d $dir, " Directory exists" ); - - my $file = File::Spec->catfile( $dir, $File ); - $found = $file if -e $file; - } - - ok( -e $found, " Module found" ); - } - - SKIP: { - skip("Probably no permissions to uninstall", 1) - if $noperms; - - ok( $InstMod->uninstall,"Uninstalling module" ); - } - } -} - -### test exceptions in Dist::MM->create ### -{ ok( $Mod->status->mk_flush, "Old status info flushed" ); - my $dist = INSTALLER_MM->new( module => $Mod ); - - ok( $dist, "New dist object made" ); - ok(!$dist->prepare, " Dist->prepare failed" ); - like( CPANPLUS::Error->stack_as_string, qr/No dir found to operate on/, - " Failure logged" ); - - ### manually set the extract dir, - $Mod->status->extract($0); - - ok(!$dist->create, " Dist->create failed" ); - like( CPANPLUS::Error->stack_as_string, qr/not successfully prepared/s, - " Failure logged" ); - - ### pretend we've been prepared ### - $dist->status->prepared(1); - - ok(!$dist->create, " Dist->create failed" ); - like( CPANPLUS::Error->stack_as_string, qr/Could not chdir/s, - " Failure logged" ); -} - -### writemakefile.pl tests ### -{ ### remove old status info - ok( $Mod->status->mk_flush, "Old status info flushed" ); - ok( $Mod->fetch, "Module fetched again" ); - ok( $Mod->extract, "Module extracted again" ); - - ### cheat and add fake prereqs ### - my $prereq = TEST_CONF_PREREQ; - - $Mod->status->prereqs( { $prereq => 0 } ); - - my $makefile_pl = MAKEFILE_PL->( $Mod->status->extract ); - my $makefile = MAKEFILE->( $Mod->status->extract ); - - my $dist = $Mod->dist; - ok( $dist, "Dist object built" ); - - ### check for a makefile.pl and 'write' one - ok( -s $makefile_pl, " Makefile.PL present" ); - ok( $dist->write_makefile_pl( force => 0 ), - " Makefile.PL written" ); - like( CPANPLUS::Error->stack_as_string, qr/Already created/, - " Prior existence noted" ); - - ### ok, unlink the makefile.pl, now really write one - 1 while unlink $makefile; - - ### must do '1 while' for VMS - { my $unlink_sts = unlink($makefile_pl); - 1 while unlink $makefile_pl; - ok( $unlink_sts, "Deleting Makefile.PL"); - } - - ok( !-s $makefile_pl, " Makefile.PL deleted" ); - ok( !-s $makefile, " Makefile deleted" ); - ok($dist->write_makefile_pl," Makefile.PL written" ); - - ### see if we wrote anything sensible - my $fh = OPEN_FILE->( $makefile_pl ); - ok( $fh, "Makefile.PL open for read" ); - - my $str = do { local $/; <$fh> }; - like( $str, qr/### Auto-generated .+ by CPANPLUS ###/, - " Autogeneration noted" ); - like( $str, '/'. $Mod->module .'/', - " Contains module name" ); - like( $str, '/'. quotemeta($Mod->version) . '/', - " Contains version" ); - like( $str, '/'. $Mod->author->author .'/', - " Contains author" ); - like( $str, '/PREREQ_PM/', " Contains prereqs" ); - like( $str, qr/$prereq.+0/, " Contains prereqs" ); - - close $fh; - - ### seems ok, now delete it again and go via install() - ### to see if it picks up on the missing makefile.pl and - ### does the right thing - ### must do '1 while' for VMS - { my $unlink_sts = unlink($makefile_pl); - 1 while unlink $makefile_pl; - ok( $unlink_sts, "Deleting Makefile.PL"); - } - ok( !-s $makefile_pl, " Makefile.PL deleted" ); - ok( $dist->status->mk_flush,"Dist status flushed" ); - ok( $dist->prepare, " Dist->prepare run again" ); - ok( $dist->create, " Dist->create run again" ); - ok( -s $makefile_pl, " Makefile.PL present" ); - like( CPANPLUS::Error->stack_as_string, - qr/attempting to generate one/, - " Makefile.PL generation attempt logged" ); - - ### now let's throw away the makefile.pl, flush the status and not - ### write a makefile.pl - { local $^W; - local *CPANPLUS::Dist::MM::write_makefile_pl = sub { 1 }; - - 1 while unlink $makefile_pl; - 1 while unlink $makefile; - - ok(!-s $makefile_pl, "Makefile.PL deleted" ); - ok(!-s $makefile, "Makefile deleted" ); - ok( $dist->status->mk_flush,"Dist status flushed" ); - ok(!$dist->prepare, " Dist->prepare failed" ); - like( CPANPLUS::Error->stack_as_string, - qr/Could not find 'Makefile.PL'/i, - " Missing Makefile.PL noted" ); - is( $dist->status->makefile, 0, - " Did not manage to create Makefile" ); - } - - ### now let's write a makefile.pl that just does 'die' - { local $^W; - local *CPANPLUS::Dist::MM::write_makefile_pl = - __PACKAGE__->_custom_makefile_pl_sub( "exit 1;" ); - - ### there's no makefile.pl now, since the previous test failed - ### to create one - #ok( -e $makefile_pl, "Makefile.PL exists" ); - #ok( unlink($makefile_pl), " Deleting Makefile.PL"); - ok(!-s $makefile_pl, "Makefile.PL deleted" ); - ok( $dist->status->mk_flush,"Dist status flushed" ); - ok(!$dist->prepare, " Dist->prepare failed" ); - like( CPANPLUS::Error->stack_as_string, qr/Could not run/s, - " Logged failed 'perl Makefile.PL'" ); - is( $dist->status->makefile, 0, - " Did not manage to create Makefile" ); - } - - ### clean up afterwards ### - ### must do '1 while' for VMS - { my $unlink_sts = unlink($makefile_pl); - 1 while unlink $makefile_pl; - ok( $unlink_sts, "Deleting Makefile.PL"); - } - - $dist->status->mk_flush; -} - -### test ENV setting in Makefile.PL -{ ### use print() not die() -- we're redirecting STDERR in tests! - my $env = ENV_CPANPLUS_IS_EXECUTING; - my $sub = __PACKAGE__->_custom_makefile_pl_sub( - "print qq[ENV=\$ENV{$env}\n]; exit 1;" ); - - my $clone = $Mod->clone; - $clone->status->fetch( $Mod->status->fetch ); - - ok( $clone, 'Testing ENV settings $dist->prepare' ); - ok( $clone->extract, ' Files extracted' ); - ok( $clone->prepare, ' $mod->prepare worked first time' ); - - my $dist = $clone->status->dist; - my $makefile_pl = MAKEFILE_PL->( $clone->status->extract ); - - ok( $sub->($dist), " Custom Makefile.PL written" ); - ok( -e $makefile_pl, " File exists" ); - - ### clear errors - CPANPLUS::Error->flush; - - my $rv = $dist->prepare( force => 1, verbose => 0 ); - ok( !$rv, ' $dist->prepare failed' ); - - SKIP: { - skip( "Can't test ENV{$env} -- no buffers available", 1 ) - unless IPC::Cmd->can_capture_buffer; - - my $re = quotemeta( $makefile_pl ); - like( CPANPLUS::Error->stack_as_string, qr/ENV=$re/, - " \$ENV $env set correctly during execution"); - } - - ### and the ENV var should no longer be set now - ok( !$ENV{$env}, " ENV var now unset" ); -} - -sub _custom_makefile_pl_sub { - my $pkg = shift; - my $txt = shift or return; - - return sub { - my $dist = shift; - my $self = $dist->parent; - my $fh = OPEN_FILE->( - MAKEFILE_PL->($self->status->extract), '>' ); - print $fh $txt; - close $fh; - - return 1; - } -} - - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - - diff --git a/cpan/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t b/cpan/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t deleted file mode 100644 index 10a2745d80..0000000000 --- a/cpan/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t +++ /dev/null @@ -1,119 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; -use Test::More 'no_plan'; -use Module::Loaded; -use Object::Accessor; - -use CPANPLUS::Dist; -use CPANPLUS::Backend; -use CPANPLUS::Error; -use CPANPLUS::Internals::Constants; - -my $Conf = gimme_conf(); -my $CB = CPANPLUS::Backend->new( $Conf ); -my $Inst = INSTALLER_BUILD; - -### set the config so that we will ignore the build installer, -### but prefer it anyway -{ Module::Loaded::mark_as_loaded( $Inst ); - CPANPLUS::Dist->_ignore_dist_types( $Inst ); - $Conf->set_conf( prefer_makefile => 0 ); -} - -my $Mod = $CB->module_tree( 'Foo::Bar::MB::NOXS' ); - -ok( $Mod, "Module object retrieved" ); -ok( not grep { $_ eq $Inst } CPANPLUS::Dist->dist_types, - " $Inst installer not returned" ); - -### fetch the file first -{ my $where = $Mod->fetch; - ok( -e $where, " Tarball '$where' exists" ); -} - -### extract it, silence warnings/messages -{ my $where = $Mod->extract; - ok( -e $where, " Tarball extracted to '$where'" ); -} - -### check the installer type -{ is( $Mod->status->installer_type, $Inst, - "Proper installer type found: $Inst" ); - - my $href = $Mod->status->configure_requires; - ok( scalar(keys(%$href)), " Dependencies recorded" ); - - ok( defined $href->{$Inst}, " Dependency on $Inst" ); - cmp_ok( $href->{$Inst}, '>', 0, - " Minimum version: $href->{$Inst}" ); - - my $err = CPANPLUS::Error->stack_as_string; - like( $err, qr/$Inst/, " Message mentions $Inst" ); - like( $err, qr/prerequisites list/, - " Message mentions adding prerequisites" ); -} - -### now run the test, it should trigger the installation of the installer -### XXX whitebox test -{ no warnings 'redefine'; - - ### bootstrapping creates a call to $cb->module_tree('c::d::build')->install - ### we need to intercept that call - my $org_mt = CPANPLUS::Backend->can('module_tree'); - local *CPANPLUS::Backend::module_tree = sub { - my $self = shift; - my $mod = shift; - - ### return a dummy object if this is the bootstrap call - return CPANPLUS::Test::Module->new if $mod eq $Inst; - - ### otherwise do a regular call - return $org_mt->( $self, $mod, @_ ); - }; - - ### bootstrap install call will abort the ->create() call, so catch - ### that here - eval { $Mod->create( skiptest => 1) }; - - ok( $@, "Create call aborted at bootstrap phase" ); - like( $@, qr/$Inst/, " Diagnostics confirmed" ); - - my $diag = CPANPLUS::Error->stack_as_string; - like( $diag, qr/This module requires.*$Inst/, - " Dependency on $Inst recorded" ); - like( $diag, qr/Bootstrapping installer.*$Inst/, - " Bootstrap notice recorded" ); - like( $diag, qr/Installer '$Inst' successfully bootstrapped/, - " Successful bootstrap recorded" ); -} - -END { 1 while unlink output_file() } - -### place holder package to serve as a module object for C::D::Build -{ package CPANPLUS::Test::Module; - sub new { return bless {} } - sub install { - ### at load time we ignored C::D::Build. Reset the ignore here - ### so a 'rescan' after the 'install' picks up C::D::Build - CPANPLUS::Dist->_reset_dist_ignore; - return 1; - } -} - -### test package for cpanplus::dist::build -{ package CPANPLUS::Dist::Build; - use base 'CPANPLUS::Dist::Base'; - - ### shortcut out of the installation procedure - sub new { die __PACKAGE__ }; - sub format_available { 1 } - sub init { 1 } - sub prepare { 1 } - sub create { 1 } - sub install { 1 } -} diff --git a/cpan/CPANPLUS/t/25_CPANPLUS.t b/cpan/CPANPLUS/t/25_CPANPLUS.t deleted file mode 100644 index b6723d35c6..0000000000 --- a/cpan/CPANPLUS/t/25_CPANPLUS.t +++ /dev/null @@ -1,90 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; -use Test::More 'no_plan'; -use CPANPLUS::Error; -use CPANPLUS::Backend; - -my $Class = 'CPANPLUS'; -my $ModName = TEST_CONF_MODULE; -my $Conf = gimme_conf(); -my $CB = CPANPLUS::Backend->new( $Conf ); - -### so we get an object with *our* configuration -no warnings 'redefine'; -local *CPANPLUS::Backend::new = sub { $CB }; - -use_ok( $Class ); - -### install / get / fetch tests -for my $meth ( qw[fetch get install] ) { - my $sub = $Class->can( $meth ); - ok( $sub, "$Class->can( $meth )" ); - - my %map = ( - 0 => qr/failed/, - 1 => qr/successful/, - ); - - ok( 1, "Trying '$meth' in different configurations" ); - - while( my($rv, $re) = each %map ) { - - ### don't actually install, just test logic - no warnings 'redefine'; - local *CPANPLUS::Module::install = sub { $rv }; - local *CPANPLUS::Module::fetch = sub { $rv }; - - CPANPLUS::Error->flush; - - my $ok = $sub->( $ModName ); - is( $ok, $rv, " Expected RV: $rv" ); - like( CPANPLUS::Error->stack_as_string, $re, - " With expected diagnostic" ); - } - - ### does not take objects / references - { CPANPLUS::Error->flush; - - my $ok = $sub->( [] ); - ok( !$ok, "'$meth' with reference does not work" ); - like( CPANPLUS::Error->stack_as_string, qr/object/, - " Error as expected"); - } - - ### requires argument - { CPANPLUS::Error->flush; - - my $ok = $sub->( ); - ok( !$ok, "'$meth' without argument does not work" ); - like( CPANPLUS::Error->stack_as_string, qr/No module specified/, - " Error as expected"); - } -} - -### shell tests -{ my $meth = 'shell'; - my $sub = $Class->can( $meth ); - - ok( $sub, "$Class->can( $meth )" ); - - { ### test package for shell() method - package CPANPLUS::Shell::Test; - - ### ->shell() looks in %INC - use Module::Loaded qw[mark_as_loaded]; - mark_as_loaded( __PACKAGE__ ); - - sub new { bless {}, __PACKAGE__ }; - sub shell { $$ }; - } - - my $rv = $sub->( 'Test' ); - ok( $rv, " Shell started" ); - is( $rv, $$, " Proper shell called" ); -} - diff --git a/cpan/CPANPLUS/t/30_CPANPLUS-Internals-Selfupdate.t b/cpan/CPANPLUS/t/30_CPANPLUS-Internals-Selfupdate.t deleted file mode 100644 index 6347daa21c..0000000000 --- a/cpan/CPANPLUS/t/30_CPANPLUS-Internals-Selfupdate.t +++ /dev/null @@ -1,181 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; - -use CPANPLUS::Backend; -use CPANPLUS::Internals::Constants; -use Test::More 'no_plan'; -use Data::Dumper; - -my $conf = gimme_conf(); -$conf->set_conf( verbose => 0 ); - -my $Class = 'CPANPLUS::Selfupdate'; -my $ModClass = "CPANPLUS::Selfupdate::Module"; -my $CB = CPANPLUS::Backend->new( $conf ); -my $Acc = 'selfupdate_object'; -my $Conf = $Class->_get_config; -my $Dep = TEST_CONF_PREREQ; # has to be in our package file && core! -my $Feat = 'some_feature'; -my $Prereq = { $Dep => 0 }; - -### test the object -{ ok( $CB, "New backend object created" ); - can_ok( $CB, $Acc ); - - ok( $Conf, "Got configuration hash" ); - - my $su = $CB->$Acc; - ok( $su, "Selfupdate object retrieved" ); - isa_ok( $su, $Class ); -} - - -### check specifically if our bundled shells dont trigger a -### dependency (see #26077). -### do this _before_ changing the built in conf! -{ my $meth = 'modules_for_feature'; - my $type = 'shell'; - my $cobj = $CB->configure_object; - my $cur = $cobj->get_conf( $type ); - - for my $shell ( SHELL_DEFAULT, SHELL_CLASSIC ) { - ok( $cobj->set_conf( $type => $shell ), - "Testing dependencies for '$shell'" ); - - my $rv = $CB->$Acc->$meth( $type => 1); - ok( !$rv, " No dependencies for '$shell' -- bundled" ); - } - - for my $shell ( 'CPANPLUS::Test::Shell' ) { - ok( $cobj->set_conf( $type => $shell ), - "Testing dependencies for '$shell'" ); - - my $rv = $CB->$Acc->$meth( $type => 1 ); - ok( $rv, " Got prereq hash" ); - isa_ok( $rv, 'HASH', - " Return value" ); - is_deeply( $rv, { $shell => '0.0' }, - " With the proper entries" ); - } -} - -### test the feature list -{ ### start with defining our OWN type of config, as not all mentioned - ### modules will be present in our bundled package files. - ### XXX WHITEBOX TEST!!!! - { delete $Conf->{$_} for keys %$Conf; - $Conf->{'dependencies'} = $Prereq; - $Conf->{'core'} = $Prereq; - $Conf->{'features'}->{$Feat} = [ $Prereq, sub { 1 } ]; - } - - is_deeply( $Conf, $Class->_get_config, - "Config updated successfully" ); - - my @cat = $CB->$Acc->list_categories; - ok( scalar(@cat), "Category list returned" ); - - my @feat = $CB->$Acc->list_features; - ok( scalar(@feat), "Features list returned" ); - - ### test if we get modules for each feature - for my $feat (@feat) { - my $meth = 'modules_for_feature'; - my @mods = $CB->$Acc->$meth( $feat ); - - ok( $feat, "Testing feature '$feat'" ); - ok( scalar( @mods ), " Module list returned" ); - - my $acc = 'is_installed_version_sufficient'; - for my $mod (@mods) { - isa_ok( $mod, "CPANPLUS::Module" ); - isa_ok( $mod, $ModClass ); - can_ok( $mod, $acc ); - ok( $mod->$acc, " Module uptodate" ); - } - - ### check if we can get a hashref - { my $href = $CB->$Acc->$meth( $feat, 1 ); - ok( $href, "Got result as hash" ); - isa_ok( $href, 'HASH' ); - is_deeply( $href, $Prereq, - " With the proper entries" ); - - } - } - - ### see if we can get a list of modules to be updated - { my $cat = 'core'; - my $meth = 'list_modules_to_update'; - - ### XXX just test the mechanics, make sure is_uptodate - ### returns false - ### declare twice because warnings are hateful - ### declare in a block to quelch 'sub redefined' warnings. - { local *CPANPLUS::Selfupdate::Module::is_uptodate = sub { return }; } - local *CPANPLUS::Selfupdate::Module::is_uptodate = sub { return }; - - my %list = $CB->$Acc->$meth( update => $cat, latest => 1 ); - - cmp_ok( scalar(keys(%list)), '==', 1, - "Got modules for '$cat' from '$meth'" ); - - my $aref = $list{$cat}; - ok( $aref, " Got module list" ); - cmp_ok( scalar(@$aref), '==', 1, - " With right amount of modules" ); - isa_ok( $aref->[0], $ModClass ); - is( $aref->[0]->name, $Dep, - " With the right name ($Dep)" ); - } - - ### find enabled features - { my $meth = 'list_enabled_features'; - can_ok( $Class, $meth ); - - my @list = $CB->$Acc->$meth; - ok( scalar(@list), "Retrieved enabled features" ); - is_deeply( [$Feat], \@list, - " Proper features found" ); - } - - ### find dependencies/core modules - for my $meth ( qw[list_core_dependencies list_core_modules] ) { - can_ok( $Class, $meth ); - - my @list = $CB->$Acc->$meth; - ok( scalar(@list), "Retrieved modules" ); - is( scalar(@list), 1, " 1 Found" ); - isa_ok( $list[0], $ModClass ); - is( $list[0]->name, $Dep, - " Correct module found" ); - - ### check if we can get a hashref - { my $href = $CB->$Acc->$meth( 1 ); - ok( $href, "Got result as hash" ); - isa_ok( $href, 'HASH' ); - is_deeply( $href, $Prereq, - " With the proper entries" ); - } - } - - - ### now selfupdate ourselves - { ### XXX just test the mechanics, make sure install returns true - ### declare twice because warnings are hateful - ### declare in a block to quelch 'sub redefined' warnings. - { local *CPANPLUS::Selfupdate::Module::install = sub { 1 }; } - local *CPANPLUS::Selfupdate::Module::install = sub { 1 }; - - my $meth = 'selfupdate'; - can_ok( $Class, $meth ); - ok( $CB->$Acc->$meth( update => 'all'), - " Selfupdate successful" ); - } -} - diff --git a/cpan/CPANPLUS/t/40_CPANPLUS-Internals-Report.t b/cpan/CPANPLUS/t/40_CPANPLUS-Internals-Report.t deleted file mode 100644 index a8823351d1..0000000000 --- a/cpan/CPANPLUS/t/40_CPANPLUS-Internals-Report.t +++ /dev/null @@ -1,503 +0,0 @@ -### make sure we can find our conf.pl file -BEGIN { - use FindBin; - require "$FindBin::Bin/inc/conf.pl"; -} - -use strict; -use CPANPLUS::Backend; -use CPANPLUS::Internals::Constants::Report; - -my $send_tests = 55; -my $query_tests = 8; -my $total_tests = $send_tests + $query_tests; - -use Test::More 'no_plan'; -use Module::Load::Conditional qw[can_load]; - -use FileHandle; -use Data::Dumper; - -use constant NOBODY => 'nobody@xs4all.nl'; - -my $conf = gimme_conf(); -my $CB = CPANPLUS::Backend->new( $conf ); -my $ModName = TEST_CONF_MODULE; -my $ModPrereq = TEST_CONF_PREREQ; - -### pick a high number, but not ~0 as possibly ~0 is unsigned, and we cause -### an overflow, as happens to version.pm 0.7203 among others. -### ANOTHER bug in version.pm, this time for 64bit: -### https://rt.cpan.org/Ticket/Display.html?id=45241 -### so just use a 'big number'(tm) and go from there. -my $HighVersion = 1234567890; -my $Mod = $CB->module_tree($ModName); -my $int_ver = $CPANPLUS::Internals::VERSION; - -### explicitly enable testing if possible ### -$CB->configure_object->set_conf(cpantest =>1) if $ARGV[0]; - -my $map = { - all_ok => { - buffer => '', # output from build process - failed => 0, # indicate failure - match => [qw|/PASS/|], # list of regexes for the output - check => 0, # check if callbacks got called? - }, - skipped_test => { - buffer => '', - failed => 0, - match => ['/PASS/', - '/tests for this module were skipped during this build/', - ], - check => 0, - skiptests - => 1, # did we skip the tests? - }, - missing_prereq => { - buffer => missing_prereq_buffer(), - failed => 1, - match => ['/The comments above are created mechanically/', - '/computer-generated error report/', - '/Below is the error stack from stage/', - '/test suite seem to fail without these modules/', - '/floo/', - '/FAIL/', - '/make test/', - ], - check => 1, - }, - missing_tests => { - buffer => missing_tests_buffer(), - failed => 1, - match => ['/The comments above are created mechanically/', - '/computer-generated error report/', - '/Below is the error stack from stage/', - '/RECOMMENDATIONS/', - '/UNKNOWN/', - '/make test/', - ], - check => 0, - }, - perl_version_too_low_mm => { - buffer => perl_version_too_low_buffer_mm(), - failed => 1, - match => ['/This distribution has been tested/', - '/http://testers.cpan.org/', - '/NA/', - ], - check => 0, - }, - perl_version_too_low_build1 => { - buffer => perl_version_too_low_buffer_build(1), - failed => 1, - match => ['/This distribution has been tested/', - '/http://testers.cpan.org/', - '/NA/', - ], - check => 0, - }, - perl_version_too_low_build2 => { - buffer => perl_version_too_low_buffer_build(2), - failed => 1, - match => ['/This distribution has been tested/', - '/http://testers.cpan.org/', - '/NA/', - ], - check => 0, - }, - prereq_versions_too_low => { - ### set the prereq version incredibly high - pre_hook => sub { - my $mod = shift; - my $clone = $mod->clone; - $clone->status->prereqs({ $ModPrereq => $HighVersion }); - return $clone; - }, - failed => 1, - match => ['/This distribution has been tested/', - '/http://testers.cpan.org/', - '/NA/', - ], - check => 0, - }, - prereq_not_on_cpan => { - pre_hook => sub { - my $mod = shift; - my $clone = $mod->clone; - $clone->status->prereqs( - { TEST_CONF_INVALID_MODULE, 0 } - ); - return $clone; - }, - failed => 1, - match => ['/This distribution has been tested/', - '/http://testers.cpan.org/', - '/NA/', - ], - check => 0, - }, - prereq_not_on_cpan_but_core => { - pre_hook => sub { - my $mod = shift; - my $clone = $mod->clone; - $clone->status->prereqs( - { TEST_CONF_PREREQ, 0 } - ); - return $clone; - }, - failed => 1, - match => ['/This distribution has been tested/', - '/http://testers.cpan.org/', - '/UNKNOWN/', - ], - check => 0, - }, -}; - -### test config settings -{ for my $opt ( qw[cpantest cpantest_mx] ) { - my $warnings; - local $SIG{__WARN__} = sub { $warnings .= "@_" }; - - my $org = $conf->get_conf( $opt ); - ok( $conf->set_conf( $opt => $$ ), - "Setting option $opt to $$" ); - is( $conf->get_conf( $opt ), $$, - " Retrieved properly" ); - ok( $conf->set_conf( $opt => $org ), - " Option $opt set back to original" ); - ok( !$warnings, " No warnings" ); - } -} - -### test constants ### -{ { my $to = CPAN_MAIL_ACCOUNT->('foo'); - is( $to, 'foo@cpan.org', "Got proper mail account" ); - } - - { ok(RELEVANT_TEST_RESULT->($Mod),"Test is relevant" ); - - ### test non-relevant tests ### - my $cp = $Mod->clone; - $cp->module( ($^O eq 'beos' ? 'MSDOS' : 'Be') . '::' . $cp->module ); - ok(!RELEVANT_TEST_RESULT->($cp),"Test is irrelevant"); - } - - { my $support = "it works!"; - my @support = ( "No support for OS", - "OS unsupported", - "os unsupported", - ); - ok(!UNSUPPORTED_OS->($support), "OS supported"); - ok( UNSUPPORTED_OS->($_), "OS not supported") for(@support); - } - - { ok(PERL_VERSION_TOO_LOW->( perl_version_too_low_buffer_mm() ), - "Perl version too low" ); - ok(PERL_VERSION_TOO_LOW->( perl_version_too_low_buffer_build(1) ), - "Perl version too low" ); - ok(PERL_VERSION_TOO_LOW->( perl_version_too_low_buffer_build(2) ), - "Perl version too low" ); - ok(!PERL_VERSION_TOO_LOW->('foo'), - " Perl version adequate" ); - } - - { my $tests = "test.pl"; - my @none = ( "No tests defined for Foo extension.", - "'No tests defined for Foo::Bar extension.'", - "'No tests defined.'", - ); - ok(!NO_TESTS_DEFINED->($tests), "Tests defined"); - ok( NO_TESTS_DEFINED->($_), "No tests defined") for(@none); - } - - { my $fail = 'MAKE TEST'; my $unknown = 'foo'; - is( TEST_FAIL_STAGE->($fail), lc $fail, - "Proper test fail stage found" ); - is( TEST_FAIL_STAGE->($unknown), 'fetch', - "Proper test fail stage found" ); - } - - ### test missing prereqs - { my $str = q[Can't locate Foo/Bar.pm in @INC]; - - ### standard test - { my @list = MISSING_PREREQS_LIST->( $str ); - is( scalar(@list), 1, " List of missing prereqs found" ); - is( $list[0], 'Foo::Bar', " Proper prereq found" ); - } - - ### multiple mentions of same prereq - { my @list = MISSING_PREREQS_LIST->( $str . $str ); - - is( scalar(@list), 1, " 1 result for multiple mentions" ); - is( $list[0], 'Foo::Bar', " Proper prereq found" ); - } - } - - { # cp version, author - my $header = REPORT_MESSAGE_HEADER->($int_ver,'foo'); - ok( $header, "Test header generated" ); - like( $header, qr/Dear foo,/, " Proper content found" ); - like( $header, qr/puter-gen/, " Proper content found" ); - like( $header, qr/CPANPLUS,/, " Proper content found" ); - like( $header, qr/ments may/, " Proper content found" ); - } - - { # stage, buffer - my $header = REPORT_MESSAGE_FAIL_HEADER->('test','buffer'); - ok( $header, "Test header generated" ); - like( $header, qr/uploading/, " Proper content found" ); - like( $header, qr/RESULTS:/, " Proper content found" ); - like( $header, qr/stack/, " Proper content found" ); - like( $header, qr/buffer/, " Proper content found" ); - } - - { my $prereqs = REPORT_MISSING_PREREQS->('foo','bar@example.com','Foo::Bar'); - ok( $prereqs, "Test output generated" ); - like( $prereqs, qr/'foo \(bar\@example\.com\)'/, - " Proper content found" ); - like( $prereqs, qr/Foo::Bar/, " Proper content found" ); - like( $prereqs, qr/prerequisi/, " Proper content found" ); - like( $prereqs, qr/PREREQ_PM/, " Proper content found" ); - } - - { my $prereqs = REPORT_MISSING_PREREQS->(undef,undef,'Foo::Bar'); - ok( $prereqs, "Test output generated" ); - like( $prereqs, qr/Your Name/, " Proper content found" ); - like( $prereqs, qr/Foo::Bar/, " Proper content found" ); - like( $prereqs, qr/prerequisi/, " Proper content found" ); - like( $prereqs, qr/PREREQ_PM/, " Proper content found" ); - } - - { my $missing = REPORT_MISSING_TESTS->(); - ok( $missing, "Missing test string generated" ); - like( $missing, qr/tests/, " Proper content found" ); - like( $missing, qr/Test::More/, " Proper content found" ); - } - - { my $missing = REPORT_MESSAGE_FOOTER->(); - ok( $missing, "Message footer string generated" ); - like( $missing, qr/NOTE/, " Proper content found" ); - like( $missing, qr/identical/, " Proper content found" ); - like( $missing, qr/mistaken/, " Proper content found" ); - like( $missing, qr/appreciate/, " Proper content found" ); - like( $missing, qr/Additional/, " Proper content found" ); - } - - { my @libs = MISSING_EXTLIBS_LIST->("No library found for -lfoo\nNo library found for -lbar"); - ok( @libs, "Missing external libraries found" ); - my @list = qw(foo bar); - is_deeply( \@libs, \@list, " Proper content found" ); - } - - { my $clone = $Mod->clone; - - my $prereqs = { $ModPrereq => $HighVersion }; - - $clone->status->prereqs( $prereqs ); - - my $str = REPORT_LOADED_PREREQS->( $clone ); - - like($str, qr/PREREQUISITES:/, "Listed loaded prerequisites" ); - like($str, qr/\! $ModPrereq\s+\S+\s+\S+/, - " Proper content found" ); - } - - { my $clone = $Mod->clone; - - my $str = REPORT_TOOLCHAIN_VERSIONS->( $clone ); - - like($str, qr/toolchain/, "Correct message in report" ); - use Cwd; - like($str, qr/Cwd\s+\Q$Cwd::VERSION\E/, - "Cwd has correct version in report" ); - } -} - -### callback tests -{ ### as reported in bug 13086, this callback returned the wrong item - ### from the list: - ### $self->_callbacks->munge_test_report->($Mod, $message, $grade); - my $rv = $CB->_callbacks->munge_test_report->( 1..4 ); - is( $rv, 2, "Default 'munge_test_report' callback OK" ); -} - - -### test creating test reports ### -SKIP: { - skip "You have chosen not to enable test reporting", $total_tests, - unless $CB->configure_object->get_conf('cpantest'); - - skip "No report send & query modules installed", $total_tests - unless $CB->_have_query_report_modules(verbose => 0); - - - SKIP: { - my $mod = $CB->module_tree( TEST_CONF_PREREQ ); # is released to CPAN - ok( $mod, "Module retrieved" ); - - ### so we're not pinned down to this specific version of perl - my @list = $mod->fetch_report( all_versions => 1 ); - skip "Possibly no net connection, or server down", 7 unless @list; - - my $href = $list[0]; - ok( scalar(@list), "Fetched test report" ); - is( ref $href, ref {}, " Return value has hashrefs" ); - - ok( $href->{grade}, " Has a grade" ); - - ### XXX use constants for grades? - like( $href->{grade}, qr/pass|fail|unknown|na/i, - " Grade as expected" ); - - my $pkg_name = $mod->package_name; - ok( $href->{dist}, " Has a dist" ); - like( $href->{dist}, qr/$pkg_name/, " Dist as expected" ); - - ok( $href->{platform}, " Has a platform" ); - } - - skip "No report sending modules installed", $send_tests - unless $CB->_have_send_report_modules(verbose => 0); - - for my $type ( keys %$map ) { - - - ### never enter the editor for test reports - ### but check if the callback actually gets called; - my $called_edit; my $called_send; - $CB->_register_callback( - name => 'edit_test_report', - code => sub { $called_edit++; 0 } - ); - - $CB->_register_callback( - name => 'send_test_report', - code => sub { $called_send++; 1 } - ); - - ### reset from earlier tests - $CB->_register_callback( - name => 'munge_test_report', - code => sub { return $_[1] } - ); - - my $mod = $map->{$type}->{'pre_hook'} - ? $map->{$type}->{'pre_hook'}->( $Mod ) - : $Mod; - - my $file = do { - ### so T::R does not try to resolve our maildomain, which can - ### lead to large timeouts for *every* invocation in T::R < 1.51_01 - ### see: http://code.google.com/p/test-reporter/issues/detail?id=15 - local $ENV{MAILDOMAIN} ||= 'example.com'; - $CB->_send_report( - module => $mod, - buffer => $map->{$type}{'buffer'}, - failed => $map->{$type}{'failed'}, - tests_skipped => ($map->{$type}{'skiptests'} ? 1 : 0), - save => 1, - ); - }; - - ok( $file, "Type '$type' written to file" ); - ok( -e $file, " File exists" ); - - my $fh = FileHandle->new($file); - ok( $fh, " Opened file for reading" ); - - my $in = do { local $/; <$fh> }; - ok( $in, " File has contents" ); - - for my $regex ( @{$map->{$type}->{match}} ) { - like( $in, $regex, " File contains expected contents" ); - } - - ### check if our registered callback got called ### - if( $map->{$type}->{check} ) { - ok( $called_edit, " Callback to edit was called" ); - ok( $called_send, " Callback to send was called" ); - } - - #unlink $file; - - -### T::R tests don't even try to mail, let's not try and be smarter -### ourselves -# { ### use a dummy 'editor' and see if the editor -# ### invocation doesn't break things -# $conf->set_program( editor => "$^X -le1" ); -# $CB->_callbacks->edit_test_report( sub { 1 } ); -# -# ### XXX whitebox test!!! Might change =/ -# ### this makes test::reporter not ask for what editor to use -# ### XXX stupid lousy perl warnings; -# local $Test::Reporter::MacApp = 1; -# local $Test::Reporter::MacApp = 1; -# -# ### now try and mail the report to a /dev/null'd mailbox -# my $ok = $CB->_send_report( -# module => $Mod, -# buffer => $map->{$type}->{'buffer'}, -# failed => $map->{$type}->{'failed'}, -# address => NOBODY, -# ); -# ok( $ok, " Mailed report to NOBODY" ); -# } - } -} - - -sub missing_prereq_buffer { - return q[ -MAKE TEST: -Can't locate floo.pm in @INC (@INC contains: /Users/kane/sources/p4/other/archive-extract/lib /Users/kane/sources/p4/other/file-fetch/lib /Users/kane/sources/p4/other/archive-tar-new/lib /Users/kane/sources/p4/other/carp-trace/lib /Users/kane/sources/p4/other/log-message/lib /Users/kane/sources/p4/other/module-load/lib /Users/kane/sources/p4/other/params-check/lib /Users/kane/sources/p4/other/qmail-checkpassword/lib /Users/kane/sources/p4/other/module-load-conditional/lib /Users/kane/sources/p4/other/term-ui/lib /Users/kane/sources/p4/other/ipc-cmd/lib /Users/kane/sources/p4/other/config-auto/lib /Users/kane/sources/NSA /Users/kane/sources/NSA/misc /Users/kane/sources/NSA/test /Users/kane/sources/beheer/perl /opt/lib/perl5/5.8.3/darwin-2level /opt/lib/perl5/5.8.3 /opt/lib/perl5/site_perl/5.8.3/darwin-2level /opt/lib/perl5/site_perl/5.8.3 /opt/lib/perl5/site_perl .). -BEGIN failed--compilation aborted. - ]; -} - -sub missing_tests_buffer { - return q[ -cp lib/Acme/POE/Knee.pm blib/lib/Acme/POE/Knee.pm -cp demo_race.pl blib/lib/Acme/POE/demo_race.pl -cp demo_simple.pl blib/lib/Acme/POE/demo_simple.pl -MAKE TEST: -No tests defined for Acme::POE::Knee extension. - ]; -} - -sub perl_version_too_low_buffer_mm { - return q[ -Running [/usr/bin/perl5.8.1 Makefile.PL ]... -Perl v5.8.3 required--this is only v5.8.1, stopped at Makefile.PL line 1. -BEGIN failed--compilation aborted at Makefile.PL line 1. -[ERROR] Could not run '/usr/bin/perl5.8.1 Makefile.PL': Perl v5.8.3 required--this is only v5.8.1, stopped at Makefile.PL line 1. -BEGIN failed--compilation aborted at Makefile.PL line 1. - -- cannot continue - ]; -} - -sub perl_version_too_low_buffer_build { - my $type = shift; - return q[ -ERROR: perl: Version 5.006001 is installed, but we need version >= 5.008001 -ERROR: version: Prerequisite version isn't installed -ERRORS/WARNINGS FOUND IN PREREQUISITES. You may wish to install the versions - of the modules indicated above before proceeding with this installation. - ] if($type == 1); - return q[ -ERROR: Version 5.006001 of perl is installed, but we need version >= 5.008001 -ERROR: version: Prerequisite version isn't installed -ERRORS/WARNINGS FOUND IN PREREQUISITES. You may wish to install the versions - of the modules indicated above before proceeding with this installation. - ] if($type == 2); -} - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz b/cpan/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz Binary files differdeleted file mode 100644 index 593556d3a0..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz +++ /dev/null diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz Binary files differdeleted file mode 100644 index 20d8e2c73d..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz +++ /dev/null diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS deleted file mode 100644 index ea9aa57313..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS +++ /dev/null @@ -1,35 +0,0 @@ -0&&<<''; # this PGP-signed message is also valid perl ------BEGIN PGP SIGNED MESSAGE----- -Hash: SHA1 - -# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) -$cksum = { - 'Foo-Bar-0.01.tar.gz' => { - 'mtime' => '1999-05-13', - 'md5' => '5cfed19e324ef8379d092807f10e5903', - 'size' => 1118 - }, - 'Foo-Bar-0.01.meta' => { - 'mtime' => '1999-05-13', - 'size' => '389', - 'md5' => '6ca49cb8414b093e56515b1b65ccf718', - }, - 'perl5.005_03.tar.gz' => { - 'mtime' => '1999-05-13', - 'md5' => '2b70961796a2ed7ca21fbf7e0c615643', - 'size' => 119 - }, - 'Bundle-Foo-Bar-0.01.tar.gz' => { - 'mtime' => '1999-05-13', - 'md5' => '76f9c0eed0de9f533ed4d3922bac2f11', - 'size' => 850 - }, -}; -__END__ ------BEGIN PGP SIGNATURE----- -Version: GnuPG v1.2.3 (GNU/Linux) - -iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 -mAcaUP8yzmIvbpdn1cGUgpw= -=rrmL ------END PGP SIGNATURE----- diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.meta b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.meta deleted file mode 100644 index 870d7b73f8..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.meta +++ /dev/null @@ -1,13 +0,0 @@ -# http://module-build.sourceforge.net/META-spec.html -#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# -name: Foo-Bar -version: 0.01 -version_from: lib/Foo/Bar.pm -installdirs: site -requires: -# for configure_requires support -configure_requires: - Cwd: 0.01 - -distribution_type: module -generated_by: ExtUtils::MakeMaker version 6.25 diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.readme b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.readme deleted file mode 100644 index ba8894c152..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.readme +++ /dev/null @@ -1,2 +0,0 @@ -README - diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz Binary files differdeleted file mode 100644 index 0fa39972eb..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz +++ /dev/null diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz Binary files differdeleted file mode 100644 index 1d1e081ad6..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz +++ /dev/null diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/CHECKSUMS b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/CHECKSUMS deleted file mode 100644 index f124759db0..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/CHECKSUMS +++ /dev/null @@ -1,20 +0,0 @@ -0&&<<''; # this PGP-signed message is also valid perl ------BEGIN PGP SIGNED MESSAGE----- -Hash: SHA1 - -# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) -$cksum = { - 'Foo-Bar-0.01.tar.gz' => { - 'mtime' => '1999-05-13', - 'md5' => 'c7691a12e5faa70b3a0e83402d279bd6', - 'size' => 1589 - }, -}; -__END__ ------BEGIN PGP SIGNATURE----- -Version: GnuPG v1.2.3 (GNU/Linux) - -iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 -mAcaUP8yzmIvbpdn1cGUgpw= -=rrmL ------END PGP SIGNATURE----- diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.readme b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.readme deleted file mode 100644 index ba8894c152..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.readme +++ /dev/null @@ -1,2 +0,0 @@ -README - diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz Binary files differdeleted file mode 100644 index cef5d53455..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz +++ /dev/null diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/CHECKSUMS b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/CHECKSUMS deleted file mode 100644 index 042008cc56..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/CHECKSUMS +++ /dev/null @@ -1,20 +0,0 @@ -0&&<<''; # this PGP-signed message is also valid perl ------BEGIN PGP SIGNED MESSAGE----- -Hash: SHA1 - -# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) -$cksum = { - 'Foo-Bar-0.01.tar.gz' => { - 'mtime' => '1999-05-13', - 'md5' => '1f52c2e83140814f734c8674e8fae53f', - 'size' => 867 - }, -}; -__END__ ------BEGIN PGP SIGNATURE----- -Version: GnuPG v1.2.3 (GNU/Linux) - -iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 -mAcaUP8yzmIvbpdn1cGUgpw= -=rrmL ------END PGP SIGNATURE----- diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.readme b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.readme deleted file mode 100644 index ba8894c152..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.readme +++ /dev/null @@ -1,2 +0,0 @@ -README - diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz Binary files differdeleted file mode 100644 index 0d499cd40d..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz +++ /dev/null diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/CHECKSUMS b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/CHECKSUMS deleted file mode 100644 index 5d2a6d6ee3..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/CHECKSUMS +++ /dev/null @@ -1,20 +0,0 @@ -0&&<<''; # this PGP-signed message is also valid perl ------BEGIN PGP SIGNED MESSAGE----- -Hash: SHA1 - -# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) -$cksum = { - 'Foo-Bar-0.01.tar.gz' => { - 'mtime' => '1999-05-13', - 'md5' => '986e4316ac095d8a4d47d0d0dd2c408a', - 'size' => 1541 - }, -}; -__END__ ------BEGIN PGP SIGNATURE----- -Version: GnuPG v1.2.3 (GNU/Linux) - -iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 -mAcaUP8yzmIvbpdn1cGUgpw= -=rrmL ------END PGP SIGNATURE----- diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.readme b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.readme deleted file mode 100644 index ba8894c152..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.readme +++ /dev/null @@ -1,2 +0,0 @@ -README - diff --git a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz b/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz Binary files differdeleted file mode 100644 index a092523e36..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz +++ /dev/null diff --git a/cpan/CPANPLUS/t/dummy-CPAN/autobundle/Snapshot.pm b/cpan/CPANPLUS/t/dummy-CPAN/autobundle/Snapshot.pm deleted file mode 100644 index 5850371d78..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/autobundle/Snapshot.pm +++ /dev/null @@ -1,19 +0,0 @@ -package Snapshot; - -$VERSION = '0.01'; - -1; - -__END__ - -=head1 NAME - -Snapshot - Snapshot of your installation at Wed Jan 2 17:46:24 2008 - -=head1 SYNOPSIS - -perl -MCPANPLUS -e "install Snapshot" - -=head1 CONTENTS - -Foo::Bar 0.01 diff --git a/cpan/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz b/cpan/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz Binary files differdeleted file mode 100644 index ec0f69d8cb..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz +++ /dev/null diff --git a/cpan/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz b/cpan/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz Binary files differdeleted file mode 100644 index 6574e158bd..0000000000 --- a/cpan/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz +++ /dev/null diff --git a/cpan/CPANPLUS/t/inc/conf.pl b/cpan/CPANPLUS/t/inc/conf.pl deleted file mode 100644 index 4cce0efcb4..0000000000 --- a/cpan/CPANPLUS/t/inc/conf.pl +++ /dev/null @@ -1,304 +0,0 @@ -### On VMS, the ENV is not reset after the program terminates. -### So reset it here explicitly -my ($old_env_path, $old_env_perl5lib); -BEGIN { - use FindBin; - use File::Spec; - - ### paths to our own 'lib' and 'inc' dirs - ### include them, relative from t/ - my @paths = map { "$FindBin::Bin/$_" } qw[../lib inc]; - - ### absolute'ify the paths in @INC; - my @rel2abs = map { File::Spec->rel2abs( $_ ) } - grep { not File::Spec->file_name_is_absolute( $_ ) } @INC; - - ### use require to make devel::cover happy - require lib; - for ( @paths, @rel2abs ) { - my $l = 'lib'; - $l->import( $_ ) - } - - use Config; - - ### and add them to the environment, so shellouts get them - $old_env_perl5lib = $ENV{'PERL5LIB'}; - $ENV{'PERL5LIB'} = join $Config{'path_sep'}, - grep { defined } $ENV{'PERL5LIB'}, @paths, @rel2abs; - - ### add our own path to the front of $ENV{PATH}, so that cpanp-run-perl - ### and friends get picked up - $old_env_path = $ENV{PATH}; - if ( $ENV{PERL_CORE} ) { - $ENV{'PATH'} = join $Config{'path_sep'}, - grep { defined } "$FindBin::Bin/../../../utils", $ENV{'PATH'}; - } - else { - $ENV{'PATH'} = join $Config{'path_sep'}, - grep { defined } "$FindBin::Bin/../bin", $ENV{'PATH'}; - } - - ### Fix up the path to perl, as we're about to chdir - ### but only under perlcore, or if the path contains delimiters, - ### meaning it's relative, but not looked up in your $PATH - $^X = File::Spec->rel2abs( $^X ) - if $ENV{PERL_CORE} or ( $^X =~ m|[/\\]| ); - - ### chdir to our own test dir, so we know all files are relative - ### to this point, no matter whether run from perlcore tests or - ### regular CPAN installs - chdir "$FindBin::Bin" if -d "$FindBin::Bin" -} - -BEGIN { - use IPC::Cmd; - - ### Win32 has issues with redirecting FD's properly in IPC::Run: - ### Can't redirect fd #4 on Win32 at IPC/Run.pm line 2801 - $IPC::Cmd::USE_IPC_RUN = 0 if $^O eq 'MSWin32'; - $IPC::Cmd::USE_IPC_RUN = 0 if $^O eq 'MSWin32'; -} - -### Use a $^O comparison, as depending on module at this time -### may cause weird errors/warnings -END { - if ($^O eq 'VMS') { - ### VMS environment variables modified by this test need to be put back - ### path is "magic" on VMS, we can not tell if it really existed before - ### this was run, because VMS will magically pretend that a PATH - ### environment variable exists set to the current working directory - $ENV{PATH} = $old_env_path; - - if (defined $old_env_perl5lib) { - $ENV{PERL5LIB} = $old_env_perl5lib; - } else { - delete $ENV{PERL5LIB}; - } - } -} - -use strict; -use CPANPLUS::Configure; -use CPANPLUS::Error (); - -use File::Path qw[rmtree]; -use FileHandle; -use File::Basename qw[basename]; - -{ ### Force the ignoring of .po files for L::M::S - $INC{'Locale::Maketext::Lexicon.pm'} = __FILE__; - $Locale::Maketext::Lexicon::VERSION = 0; -} - -my $Env = 'PERL5_CPANPLUS_TEST_VERBOSE'; - -# prereq has to be in our package file && core! -use constant TEST_CONF_PREREQ => 'Cwd'; -use constant TEST_CONF_MODULE => 'Foo::Bar::EU::NOXS'; -use constant TEST_CONF_MODULE_SUB => 'Foo::Bar::EU::NOXS::Sub'; -use constant TEST_CONF_AUTHOR => 'EUNOXS'; -use constant TEST_CONF_INST_MODULE => 'Foo::Bar'; -use constant TEST_CONF_INVALID_MODULE => 'fnurk'; -use constant TEST_CONF_MIRROR_DIR => 'dummy-localmirror'; -use constant TEST_CONF_CPAN_DIR => 'dummy-CPAN'; -use constant TEST_CONF_CPANPLUS_DIR => 'dummy-cpanplus'; -use constant TEST_CONF_INSTALL_DIR => File::Spec->rel2abs( - File::Spec->catdir( - TEST_CONF_CPANPLUS_DIR, - 'install' - ) - ); - -sub dummy_cpan_dir { - ### VMS needs this in directory format for rel2abs - my $test_dir = $^O eq 'VMS' - ? File::Spec->catdir(TEST_CONF_CPAN_DIR) - : TEST_CONF_CPAN_DIR; - - ### Convert to an absolute file specification - my $abs_test_dir = File::Spec->rel2abs($test_dir); - - ### According to John M: the hosts path needs to be in UNIX format. - ### File::Spec::Unix->rel2abs does not work at all on VMS - $abs_test_dir = VMS::Filespec::unixify( $abs_test_dir ) if $^O eq 'VMS'; - - return $abs_test_dir; -} - -sub gimme_conf { - - ### don't load any other configs than the heuristic one - ### during tests. They might hold broken/incorrect data - ### for our test suite. Bug [perl #43629] showed this. - local $ENV{PERL5_CPANPLUS_HOME} = ''; - - my $conf = CPANPLUS::Configure->new( load_configs => 0 ); - - my $dummy_cpan = dummy_cpan_dir(); - - $conf->set_conf( hosts => [ { - path => $dummy_cpan, - scheme => 'file', - } ], - ); - $conf->set_conf( base => File::Spec->rel2abs(TEST_CONF_CPANPLUS_DIR)); - $conf->set_conf( dist_type => '' ); - $conf->set_conf( signature => 0 ); - $conf->set_conf( allow_unknown_prereqs => 1 ); # just to make sure, eh - $conf->set_conf( verbose => 1 ) if $ENV{ $Env }; - - ### never use a pager in the test suite - $conf->set_program( pager => '' ); - - $conf->set_conf( enable_custom_sources => 0 ); - - ### dmq tells us that we should run with /nologo - ### if using nmake, as it's very noisy otherwise. - { my $make = $conf->get_program('make'); - if( $make and basename($make) =~ /^nmake/i ) { - $conf->set_conf( makeflags => '/nologo' ); - } - } - - ### CPANPLUS::Config checks 3 specific scenarios first - ### when looking for cpanp-run-perl: parallel to cpanp, - ### parallel to CPANPLUS.pm, or installed into a custom - ### prefix like /tmp/foo. Only *THEN* does it check the - ### the path. - ### If the perl core is extracted to a directory that has - ### cpanp-run-perl installed the same amount of 'uplevels' - ### as the /tmp/foo prefix, we'll pull in the wrong script - ### by accident. - ### Since we set the path to cpanp-run-perl explicitly - ### at the top of this script, it's best to update the config - ### ourselves with a path lookup, rather than rely on its - ### heuristics. Thanks to David Wheeler, Josh Jore and Vincent - ### Pit for helping to track this down. - if( $ENV{PERL_CORE} ) { - $conf->set_program( "perlwrapper" => IPC::Cmd::can_run('cpanp-run-perl') ); - } - - $conf->set_conf( source_engine => $ENV{CPANPLUS_SOURCE_ENGINE} ) - if $ENV{CPANPLUS_SOURCE_ENGINE}; - - _clean_test_dir( [ - $conf->get_conf('base'), - TEST_CONF_MIRROR_DIR, -# TEST_INSTALL_DIR_LIB, -# TEST_INSTALL_DIR_BIN, -# TEST_INSTALL_DIR_MAN1, -# TEST_INSTALL_DIR_MAN3, - ], ( $ENV{PERL_CORE} ? 0 : 1 ) ); - - return $conf; -}; - -{ - my $fh; - my $file = ".".basename($0).".output"; - sub output_handle { - return $fh if $fh; - - $fh = FileHandle->new(">$file") - or warn "Could not open output file '$file': $!"; - - $fh->autoflush(1); - return $fh; - } - - sub output_file { return $file } - - - - ### redirect output from msg() and error() output to file - unless( $ENV{$Env} ) { - - print "# To run tests in verbose mode, set ". - "\$ENV{$Env} = 1\n" unless $ENV{PERL_CORE}; - - 1 while unlink $file; # just in case - - $CPANPLUS::Error::ERROR_FH = - $CPANPLUS::Error::ERROR_FH = output_handle(); - - $CPANPLUS::Error::MSG_FH = - $CPANPLUS::Error::MSG_FH = output_handle(); - - } -} - - -### clean these files if we're under perl core -END { - if ( $ENV{PERL_CORE} ) { - close output_handle(); 1 while unlink output_file(); - - _clean_test_dir( [ - gimme_conf->get_conf('base'), - TEST_CONF_MIRROR_DIR, - # TEST_INSTALL_DIR_LIB, - # TEST_INSTALL_DIR_BIN, - # TEST_INSTALL_DIR_MAN1, - # TEST_INSTALL_DIR_MAN3, - ], 0 ); # DO NOT be verbose under perl core -- makes tests fail - } -} - -### whenever we start a new script, we want to clean out our -### old files from the test '.cpanplus' dir.. -sub _clean_test_dir { - my $dirs = shift || []; - my $verbose = shift || 0; - - for my $dir ( @$dirs ) { - - ### no point if it doesn't exist; - next unless -d $dir; - - my $dh; - opendir $dh, $dir or die "Could not open basedir '$dir': $!"; - while( my $file = readdir $dh ) { - next if $file =~ /^\./; # skip dot files - - my $path = File::Spec->catfile( $dir, $file ); - - ### directory, rmtree it - if( -d $path ) { - - ### John Malmberg reports yet another VMS issue: - ### A directory name on VMS in VMS format ends with .dir - ### when it is referenced as a file. - ### In UNIX format traditionally PERL on VMS does not remove the - ### '.dir', however the VMS C library conversion routines do - ### remove the '.dir' and the VMS C library routines can not - ### handle the '.dir' being present on UNIX format filenames. - ### So code doing the fixup has on VMS has to be able to handle - ### both UNIX format names and VMS format names. - - ### XXX See http://www.xray.mpe.mpg.de/ - ### mailing-lists/perl5-porters/2007-10/msg00064.html - ### for details -- the below regex could use some touchups - ### according to John. M. - $file =~ s/\.dir$//i if $^O eq 'VMS'; - - my $dirpath = File::Spec->catdir( $dir, $file ); - - print "# Deleting directory '$dirpath'\n" if $verbose; - eval { rmtree( $dirpath ) }; - warn "Could not delete '$dirpath' while cleaning up '$dir'" - if $@; - - ### regular file - } else { - print "# Deleting file '$path'\n" if $verbose; - 1 while unlink $path; - } - } - - close $dh; - } - - return 1; -} -1; diff --git a/installperl b/installperl index e64b1c39bf..0e590e1e3a 100755 --- a/installperl +++ b/installperl @@ -691,7 +691,7 @@ sub installlib { # lib/Archive/Tar/bin, the config_data script in lib/Module/Build/scripts # and zipdetails in cpan/IO-Compress/bin # (they're installed later with other utils) - return if $name =~ /^(?:cpan|instmodsh|prove|corelist|ptar|cpan2dist|cpanp|cpanp-run-perl|ptardiff|ptargrep|config_data|zipdetails)\z/; + return if $name =~ /^(?:cpan|instmodsh|prove|corelist|ptar|ptardiff|ptargrep|config_data|zipdetails)\z/; # ignore the Makefiles return if $name =~ /^makefile$/i; # ignore the test extensions diff --git a/lib/.gitignore b/lib/.gitignore index 6674b80104..367156c75f 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -54,56 +54,6 @@ /CPAN/Tarzip.pm /CPAN/URL.pm /CPAN/Version.pm -/CPANPLUS.pm -/CPANPLUS/Backend -/CPANPLUS/Backend.pm -/CPANPLUS/Backend/RV.pm -/CPANPLUS/Config.pm -/CPANPLUS/Config/HomeEnv.pm -/CPANPLUS/Configure.pm -/CPANPLUS/Configure/Setup.pm -/CPANPLUS/Dist.pm -/CPANPLUS/Dist/Autobundle.pm -/CPANPLUS/Dist/Base.pm -/CPANPLUS/Dist/MM.pm -/CPANPLUS/Dist/Sample.pm -/CPANPLUS/Error.pm -/CPANPLUS/FAQ.pod -/CPANPLUS/Hacking.pod -/CPANPLUS/Internals.pm -/CPANPLUS/Internals/Constants -/CPANPLUS/Internals/Constants.pm -/CPANPLUS/Internals/Constants/Report.pm -/CPANPLUS/Internals/Extract.pm -/CPANPLUS/Internals/Fetch.pm -/CPANPLUS/Internals/Report.pm -/CPANPLUS/Internals/Search.pm -/CPANPLUS/Internals/Source -/CPANPLUS/Internals/Source.pm -/CPANPLUS/Internals/Source/Memory.pm -/CPANPLUS/Internals/Source/SQLite -/CPANPLUS/Internals/Source/SQLite.pm -/CPANPLUS/Internals/Source/SQLite/Tie.pm -/CPANPLUS/Internals/Utils -/CPANPLUS/Internals/Utils.pm -/CPANPLUS/Internals/Utils/Autoflush.pm -/CPANPLUS/Module.pm -/CPANPLUS/Module/Author -/CPANPLUS/Module/Author.pm -/CPANPLUS/Module/Author/Fake.pm -/CPANPLUS/Module/Checksums.pm -/CPANPLUS/Module/Fake.pm -/CPANPLUS/Module/Signature.pm -/CPANPLUS/Selfupdate.pm -/CPANPLUS/Shell.pm -/CPANPLUS/Shell/Classic.pm -/CPANPLUS/Shell/Default -/CPANPLUS/Shell/Default.pm -/CPANPLUS/Shell/Default/Plugins -/CPANPLUS/Shell/Default/Plugins/CustomSource.pm -/CPANPLUS/Shell/Default/Plugins/HOWTO.pod -/CPANPLUS/Shell/Default/Plugins/Remote.pm -/CPANPLUS/Shell/Default/Plugins/Source.pm /Carp.pm /Carp/Heavy.pm /Class/ISA.pm diff --git a/pod/perlutil.pod b/pod/perlutil.pod index 3f53ad0fa5..3d2b276a7c 100644 --- a/pod/perlutil.pod +++ b/pod/perlutil.pod @@ -278,18 +278,6 @@ a lot more. It is similar to the command line mode of the L<CPAN> module, perl -MCPAN -e shell -=item L<cpanp> - -F<cpanp> is, like F<cpan>, a command-line interface to the CPAN, using -the C<CPANPLUS> module as a back-end. It can be used interactively or -imperatively. - -=item L<cpan2dist> - -F<cpan2dist> is a tool to create distributions (or packages) from CPAN -modules, then suitable for your package manager of choice. Support for -specific formats are available from CPAN as C<CPANPLUS::Dist::*> modules. - =item L<instmodsh> A little interface to ExtUtils::Installed to examine installed modules, @@ -305,7 +293,7 @@ L<podchecker|podchecker>, L<splain|splain>, L<perldiag>, C<roffitall|roffitall>, L<a2p|a2p>, L<s2p|s2p>, L<find2perl|find2perl>, L<File::Find|File::Find>, L<pl2pm|pl2pm>, L<perlbug|perlbug>, L<h2ph|h2ph>, L<c2ph|c2ph>, L<h2xs|h2xs>, L<enc2xs>, L<xsubpp>, -L<cpan>, L<cpanp>, L<cpan2dist>, L<instmodsh>, L<piconv>, L<prove>, +L<cpan>, L<instmodsh>, L<piconv>, L<prove>, L<corelist>, L<ptar>, L<ptardiff>, L<shasum>, L<zipdetails> =cut @@ -119,7 +119,6 @@ if (@ARGV) { # par => [ # { seq => '../ext/DB_File/t/*' }, # { seq => '../ext/IO_Compress_Zlib/t/*' }, - # { seq => '../lib/CPANPLUS/*' }, # { seq => '../lib/ExtUtils/t/*' }, # '*' # ] diff --git a/t/porting/customized.dat b/t/porting/customized.dat index bdb8eb2130..910b432829 100644 --- a/t/porting/customized.dat +++ b/t/porting/customized.dat @@ -9,7 +9,6 @@ Text::Balanced cpan/Text-Balanced/t/08_extvar.t 0776ef2cbdad5b1fbefb300541d07921 Text::Balanced cpan/Text-Balanced/t/09_gentag.t 42361b5dfb3bb728bce20f4fb0d92ccfb27c2ba7 Module::Build cpan/Module-Build/lib/Module/Build/ConfigData.pm 2f3f07fd889077ebd51791ad6e195d9164b4baf3 Test::Harness cpan/Test-Harness/t/source.t 884890970fb850874213159df263ba483bac62e9 -CPANPLUS cpan/CPANPLUS/Makefile.PL 5d533f6722af6aae73204755beb8d6c008fc0d4a libnet cpan/libnet/Makefile.PL 5554b71464b45f5cc002e55f2464f7ff4abd05b6 podlators cpan/podlators/scripts/pod2man.PL f81acf53f3ff46cdcc5ebdd661c5d13eb35d20d6 podlators cpan/podlators/scripts/pod2text.PL b4693fcfe4a0a1b38a215cfb8985a65d5d025d69 diff --git a/t/porting/known_pod_issues.dat b/t/porting/known_pod_issues.dat index 6afa0495fa..93cc764350 100644 --- a/t/porting/known_pod_issues.dat +++ b/t/porting/known_pod_issues.dat @@ -31,6 +31,9 @@ Class::ISA Class::PseudoHash Classic::Perl Clone +cpan2dist(1) +cpanp(1) +CPANPLUS Crypt::Random curl(1) Data::Entropy @@ -219,11 +222,12 @@ pod/perlbook.pod Verbatim line length including indents exceeds 79 by 1 pod/perlcall.pod Verbatim line length including indents exceeds 79 by 2 pod/perlce.pod Verbatim line length including indents exceeds 79 by 2 pod/perlclib.pod Verbatim line length including indents exceeds 79 by 3 -pod/perlcygwin.pod Verbatim line length including indents exceeds 79 by 25 +pod/perlcygwin.pod Verbatim line length including indents exceeds 79 by 24 pod/perldbmfilter.pod Verbatim line length including indents exceeds 79 by 1 pod/perldebguts.pod Verbatim line length including indents exceeds 79 by 34 pod/perldebtut.pod Verbatim line length including indents exceeds 79 by 22 pod/perldebug.pod Verbatim line length including indents exceeds 79 by 3 +pod/perldelta.pod Apparent internal link is missing its forward slash 2 pod/perldiag.pod =item type mismatch 1 pod/perldiag.pod Verbatim line length including indents exceeds 79 by 1 pod/perldsc.pod Verbatim line length including indents exceeds 79 by 4 diff --git a/t/porting/utils.t b/t/porting/utils.t index 13a164950b..ba8ba235aa 100644 --- a/t/porting/utils.t +++ b/t/porting/utils.t @@ -77,11 +77,6 @@ printf "1..%d\n", scalar @victims; foreach my $victim (@victims) { SKIP: { - # Not clear to me *why* it needs the BEGIN block, given what it - # does, but not in an easy position to change it. - skip("$victim executes code in a BEGIN block which fails for empty \@ARGV") - if $victim =~ m{^utils/cpanp-run-perl}; - skip ("$victim uses $excuses{$victim}, so can't test with just core modules") if $excuses{$victim}; @@ -24,9 +24,6 @@ utils/prove utils/ptar utils/ptardiff utils/ptargrep -utils/cpanp-run-perl -utils/cpanp -utils/cpan2dist utils/shasum utils/splain utils/xsubpp diff --git a/utils/Makefile b/utils/Makefile index bf6bc804a2..f8934e8623 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -10,9 +10,9 @@ RUN = # Used mainly cross-compilation setups. # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). -pl = c2ph.PL config_data.PL corelist.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL json_pp.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL ptar.PL ptardiff.PL ptargrep.PL cpanp-run-perl.PL cpanp.PL cpan2dist.PL shasum.PL splain.PL libnetcfg.PL piconv.PL enc2xs.PL xsubpp.PL pod2html.PL zipdetails.PL -plextract = c2ph config_data corelist cpan h2ph h2xs instmodsh json_pp perlbug perldoc perlivp pl2pm prove ptar ptardiff ptargrep cpanp-run-perl cpanp cpan2dist shasum splain libnetcfg piconv enc2xs xsubpp pod2html zipdetails -plextractexe = ./c2ph ./config_data ./corelist ./cpan ./h2ph ./h2xs ./json_pp ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./ptar ./ptardiff ./ptargrep ./cpanp-run-perl ./cpanp ./cpan2dist ./shasum ./splain ./libnetcfg ./piconv ./enc2xs ./xsubpp ./pod2html ./zipdetails +pl = c2ph.PL config_data.PL corelist.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL json_pp.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL ptar.PL ptardiff.PL ptargrep.PL shasum.PL splain.PL libnetcfg.PL piconv.PL enc2xs.PL xsubpp.PL pod2html.PL zipdetails.PL +plextract = c2ph config_data corelist cpan h2ph h2xs instmodsh json_pp perlbug perldoc perlivp pl2pm prove ptar ptardiff ptargrep shasum splain libnetcfg piconv enc2xs xsubpp pod2html zipdetails +plextractexe = ./c2ph ./config_data ./corelist ./cpan ./h2ph ./h2xs ./json_pp ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./ptar ./ptardiff ./ptargrep ./shasum ./splain ./libnetcfg ./piconv ./enc2xs ./xsubpp ./pod2html ./zipdetails all: $(plextract) @@ -49,12 +49,6 @@ ptardiff: ptardiff.PL ../config.sh ptargrep: ptargrep.PL ../config.sh -cpanp-run-perl: cpanp-run-perl.PL ../config.sh - -cpanp: cpanp.PL ../config.sh - -cpan2dist: cpan2dist.PL ../config.sh - pl2pm: pl2pm.PL ../config.sh shasum: shasum.PL ../config.sh diff --git a/utils/Makefile.SH b/utils/Makefile.SH index ca683c2e14..a4a7e4a9d2 100644 --- a/utils/Makefile.SH +++ b/utils/Makefile.SH @@ -48,9 +48,9 @@ cat >>Makefile <<'!NO!SUBS!' # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). -pl = c2ph.PL config_data.PL corelist.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL json_pp.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL ptar.PL ptardiff.PL ptargrep.PL cpanp-run-perl.PL cpanp.PL cpan2dist.PL shasum.PL splain.PL libnetcfg.PL piconv.PL enc2xs.PL xsubpp.PL pod2html.PL zipdetails.PL -plextract = c2ph config_data corelist cpan h2ph h2xs instmodsh json_pp perlbug perldoc perlivp pl2pm prove ptar ptardiff ptargrep cpanp-run-perl cpanp cpan2dist shasum splain libnetcfg piconv enc2xs xsubpp pod2html zipdetails -plextractexe = ./c2ph ./config_data ./corelist ./cpan ./h2ph ./h2xs ./json_pp ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./ptar ./ptardiff ./ptargrep ./cpanp-run-perl ./cpanp ./cpan2dist ./shasum ./splain ./libnetcfg ./piconv ./enc2xs ./xsubpp ./pod2html ./zipdetails +pl = c2ph.PL config_data.PL corelist.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL json_pp.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL ptar.PL ptardiff.PL ptargrep.PL shasum.PL splain.PL libnetcfg.PL piconv.PL enc2xs.PL xsubpp.PL pod2html.PL zipdetails.PL +plextract = c2ph config_data corelist cpan h2ph h2xs instmodsh json_pp perlbug perldoc perlivp pl2pm prove ptar ptardiff ptargrep shasum splain libnetcfg piconv enc2xs xsubpp pod2html zipdetails +plextractexe = ./c2ph ./config_data ./corelist ./cpan ./h2ph ./h2xs ./json_pp ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./ptar ./ptardiff ./ptargrep ./shasum ./splain ./libnetcfg ./piconv ./enc2xs ./xsubpp ./pod2html ./zipdetails all: $(plextract) @@ -87,12 +87,6 @@ ptardiff: ptardiff.PL ../config.sh ptargrep: ptargrep.PL ../config.sh -cpanp-run-perl: cpanp-run-perl.PL ../config.sh - -cpanp: cpanp.PL ../config.sh - -cpan2dist: cpan2dist.PL ../config.sh - pl2pm: pl2pm.PL ../config.sh shasum: shasum.PL ../config.sh diff --git a/utils/cpan2dist.PL b/utils/cpan2dist.PL deleted file mode 100644 index 0533a01e40..0000000000 --- a/utils/cpan2dist.PL +++ /dev/null @@ -1,51 +0,0 @@ -#!/usr/local/bin/perl - -use Config; -use File::Basename qw(&basename &dirname); -use Cwd; - -# List explicitly here the variables you want Configure to -# generate. Metaconfig only looks for shell variables, so you -# have to mention them as if they were shell variables, not -# %Config entries. Thus you write -# $startperl -# to ensure Configure will look for $Config{startperl}. - -# This forces PL files to create target in same directory as PL file. -# This is so that make depend always knows where to find PL derivatives. -my $origdir = cwd; -chdir dirname($0); -my $file = basename($0, '.PL'); -$file .= '.com' if $^O eq 'VMS'; - -open OUT,">$file" or die "Can't create $file: $!"; - -print "Extracting $file (with variable substitutions)\n"; - -# In this section, perl variables will be expanded during extraction. -# You can use $Config{...} to use Configure variables. - -print OUT <<"!GROK!THIS!"; -$Config{startperl} - eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; -!GROK!THIS! - -use File::Spec; - -my $script = File::Spec->catfile( - File::Spec->catdir( - File::Spec->updir, qw[ cpan CPANPLUS bin ] - ), "cpan2dist"); - -if (open(IN, $script)) { - print OUT <IN>; - close IN; -} else { - die "$0: cannot find '$script'\n"; -} - -close OUT or die "Can't close $file: $!"; -chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; -exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; -chdir $origdir; diff --git a/utils/cpanp-run-perl.PL b/utils/cpanp-run-perl.PL deleted file mode 100644 index a72ac2b668..0000000000 --- a/utils/cpanp-run-perl.PL +++ /dev/null @@ -1,51 +0,0 @@ -#!/usr/local/bin/perl - -use Config; -use File::Basename qw(&basename &dirname); -use Cwd; - -# List explicitly here the variables you want Configure to -# generate. Metaconfig only looks for shell variables, so you -# have to mention them as if they were shell variables, not -# %Config entries. Thus you write -# $startperl -# to ensure Configure will look for $Config{startperl}. - -# This forces PL files to create target in same directory as PL file. -# This is so that make depend always knows where to find PL derivatives. -my $origdir = cwd; -chdir dirname($0); -my $file = basename($0, '.PL'); -$file .= '.com' if $^O eq 'VMS'; - -open OUT,">$file" or die "Can't create $file: $!"; - -print "Extracting $file (with variable substitutions)\n"; - -# In this section, perl variables will be expanded during extraction. -# You can use $Config{...} to use Configure variables. - -print OUT <<"!GROK!THIS!"; -$Config{startperl} - eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; -!GROK!THIS! - -use File::Spec; - -my $script = File::Spec->catfile( - File::Spec->catdir( - File::Spec->updir, qw[ cpan CPANPLUS bin ] - ), "cpanp-run-perl"); - -if (open(IN, $script)) { - print OUT <IN>; - close IN; -} else { - die "$0: cannot find '$script'\n"; -} - -close OUT or die "Can't close $file: $!"; -chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; -exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; -chdir $origdir; diff --git a/utils/cpanp.PL b/utils/cpanp.PL deleted file mode 100644 index ea3b4399d3..0000000000 --- a/utils/cpanp.PL +++ /dev/null @@ -1,51 +0,0 @@ -#!/usr/local/bin/perl - -use Config; -use File::Basename qw(&basename &dirname); -use Cwd; - -# List explicitly here the variables you want Configure to -# generate. Metaconfig only looks for shell variables, so you -# have to mention them as if they were shell variables, not -# %Config entries. Thus you write -# $startperl -# to ensure Configure will look for $Config{startperl}. - -# This forces PL files to create target in same directory as PL file. -# This is so that make depend always knows where to find PL derivatives. -my $origdir = cwd; -chdir dirname($0); -my $file = basename($0, '.PL'); -$file .= '.com' if $^O eq 'VMS'; - -open OUT,">$file" or die "Can't create $file: $!"; - -print "Extracting $file (with variable substitutions)\n"; - -# In this section, perl variables will be expanded during extraction. -# You can use $Config{...} to use Configure variables. - -print OUT <<"!GROK!THIS!"; -$Config{startperl} - eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; -!GROK!THIS! - -use File::Spec; - -my $script = File::Spec->catfile( - File::Spec->catdir( - File::Spec->updir, qw[ cpan CPANPLUS bin ] - ), "cpanp"); - -if (open(IN, $script)) { - print OUT <IN>; - close IN; -} else { - die "$0: cannot find '$script'\n"; -} - -close OUT or die "Can't close $file: $!"; -chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; -exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; -chdir $origdir; diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index 59c7c7cc72..607f1504ad 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -294,7 +294,7 @@ utils1 = [.utils]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils utils2 = [.utils]h2xs.com [.utils]libnetcfg.com [.lib]perlbug.com [.utils]json_pp.com utils3 = [.utils]perlivp.com [.lib]splain.com [.utils]pl2pm.com [.utils]xsubpp.com [.utils]pod2html.com [.utils]instmodsh.com utils4 = [.utils]enc2xs.com [.utils]piconv.com [.utils]cpan.com [.utils]prove.com [.utils]ptar.com [.utils]ptardiff.com [.utils]shasum.com -utils5 = [.utils]corelist.com [.utils]config_data.com [.utils]cpanp.com [.utils]cpan2dist.com [.utils]cpanp-run-perl.com [.utils]ptargrep.com [.utils]zipdetails.com +utils5 = [.utils]corelist.com [.utils]config_data.com [.utils]ptargrep.com [.utils]zipdetails.com .ifdef NOX2P all : base extras archcorefiles preplibrary [.pod]perltoc.pod @@ -468,15 +468,6 @@ nonxsext : $(LIBPREREQ) preplibrary $(MINIPERL_EXE) [.pod]perlfunc.pod [.utils]cpan.com : [.utils]cpan.PL $(ARCHDIR)Config.pm $(MINIPERL) -"I[-.lib]" $(MMS$SOURCE) -[.utils]cpanp.com : [.utils]cpanp.PL $(ARCHDIR)Config.pm - $(MINIPERL) -"I[-.lib]" $(MMS$SOURCE) - -[.utils]cpan2dist.com : [.utils]cpan2dist.PL $(ARCHDIR)Config.pm - $(MINIPERL) -"I[-.lib]" $(MMS$SOURCE) - -[.utils]cpanp-run-perl.com : [.utils]cpanp-run-perl.PL $(ARCHDIR)Config.pm - $(MINIPERL) -"I[-.lib]" $(MMS$SOURCE) - [.utils]prove.com : [.utils]prove.PL $(ARCHDIR)Config.pm $(MINIPERL) -"I[-.lib]" $(MMS$SOURCE) diff --git a/win32/Makefile b/win32/Makefile index 2e724892c5..ffcdfa6f3b 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -607,9 +607,6 @@ UTILS = \ ..\utils\ptardiff \ ..\utils\ptargrep \ ..\utils\zipdetails \ - ..\utils\cpanp-run-perl \ - ..\utils\cpanp \ - ..\utils\cpan2dist \ ..\utils\shasum \ ..\utils\instmodsh \ ..\utils\json_pp \ @@ -1201,7 +1198,6 @@ distclean: realclean -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B -if exist $(LIBDIR)\CGI rmdir /s /q $(LIBDIR)\CGI -if exist $(LIBDIR)\CPAN rmdir /s /q $(LIBDIR)\CPAN - -if exist $(LIBDIR)\CPANPLUS rmdir /s /q $(LIBDIR)\CPANPLUS -if exist $(LIBDIR)\Compress rmdir /s /q $(LIBDIR)\Compress -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data -if exist $(LIBDIR)\Devel rmdir /s /q $(LIBDIR)\Devel @@ -1263,7 +1259,7 @@ distclean: realclean perlvos.pod perlwin32.pod -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \ perldoc perlivp libnetcfg enc2xs piconv cpan *.bat \ - xsubpp pod2html instmodsh json_pp prove ptar ptardiff ptargrep cpanp-run-perl cpanp cpan2dist shasum corelist config_data zipdetails + xsubpp pod2html instmodsh json_pp prove ptar ptardiff ptargrep shasum corelist config_data zipdetails -cd ..\x2p && del /f find2perl s2p psed *.bat -del /f ..\config.sh perlmain.c dlutils.c config.h.new \ perlmainst.c diff --git a/win32/makefile.mk b/win32/makefile.mk index c58ce63064..dd29549e2d 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -699,9 +699,6 @@ UTILS = \ ..\utils\ptardiff \ ..\utils\ptargrep \ ..\utils\zipdetails \ - ..\utils\cpanp-run-perl \ - ..\utils\cpanp \ - ..\utils\cpan2dist \ ..\utils\shasum \ ..\utils\instmodsh \ ..\utils\json_pp \ @@ -1380,7 +1377,6 @@ distclean: realclean -if exist $(LIBDIR)\B rmdir /s /q $(LIBDIR)\B -if exist $(LIBDIR)\CGI rmdir /s /q $(LIBDIR)\CGI -if exist $(LIBDIR)\CPAN rmdir /s /q $(LIBDIR)\CPAN - -if exist $(LIBDIR)\CPANPLUS rmdir /s /q $(LIBDIR)\CPANPLUS -if exist $(LIBDIR)\Compress rmdir /s /q $(LIBDIR)\Compress -if exist $(LIBDIR)\Data rmdir /s /q $(LIBDIR)\Data -if exist $(LIBDIR)\Devel rmdir /s /q $(LIBDIR)\Devel @@ -1442,7 +1438,7 @@ distclean: realclean perlvos.pod perlwin32.pod -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \ perldoc perlivp libnetcfg enc2xs piconv cpan *.bat \ - xsubpp pod2html instmodsh json_pp prove ptar ptardiff ptargrep cpanp-run-perl cpanp cpan2dist shasum corelist config_data zipdetails + xsubpp pod2html instmodsh json_pp prove ptar ptardiff ptargrep shasum corelist config_data zipdetails -cd ..\x2p && del /f find2perl s2p psed *.bat -del /f ..\config.sh perlmain.c dlutils.c config.h.new \ perlmainst.c |