diff options
| author | Chris 'BinGOs' Williams <chris@bingosnet.co.uk> | 2011-05-18 11:12:21 +0100 |
|---|---|---|
| committer | Chris 'BinGOs' Williams <chris@bingosnet.co.uk> | 2011-06-09 12:17:04 +0100 |
| commit | 5c920a492077b8ae4576a7edbcb5b54c4820ca48 (patch) | |
| tree | 238bdf09a59144e774d8da841071249a6022834a | |
| parent | 4e05616f0f3312cedef3f6e964c196d4763d5714 (diff) | |
| download | perl-5c920a492077b8ae4576a7edbcb5b54c4820ca48.tar.gz | |
Update CPANPLUS to CPAN version 0.9105
[DELTA]
Changes for 0.9105 Thu May 5 21:47:45 2011
================================================
* remove any pointers to the sourceforge mailing list
* point to the github repo instead
* Only enable custom sources in the tests where it is actually
required for testing
* Added support to parse_module() for 'Module/Type.pm' parsing
Changes for 0.9104 Tue Apr 19 15:13:57 2011
================================================
* Force Parse::CPAN::Meta to use a sane default for JSON backend
* Make sure that test failures aren't reported twice to the terminal
58 files changed, 2362 insertions, 2336 deletions
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 31144489a4..a6cd0cd349 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -454,7 +454,7 @@ use File::Glob qw(:case); 'CPANPLUS' => { 'MAINTAINER' => 'kane', - 'DISTRIBUTION' => 'BINGOS/CPANPLUS-0.9103.tar.gz', + 'DISTRIBUTION' => 'BINGOS/CPANPLUS-0.9105.tar.gz', 'FILES' => q[cpan/CPANPLUS], 'EXCLUDED' => [ qr{^inc/}, qr{^t/dummy-.*\.hidden$}, diff --git a/cpan/CPANPLUS/bin/cpan2dist b/cpan/CPANPLUS/bin/cpan2dist index 276473949f..b4fadf552b 100644 --- a/cpan/CPANPLUS/bin/cpan2dist +++ b/cpan/CPANPLUS/bin/cpan2dist @@ -40,7 +40,7 @@ GetOptions( $opts, 'default-ignorelist!', 'edit-metafile!', 'install!' ); - + die usage() if exists $opts->{'help'}; ### parse options @@ -49,8 +49,8 @@ my $keep = $opts->{'keepsource'} ? 1 : 0; my $prereqbuild = exists $opts->{'buildprereq'} ? $opts->{'buildprereq'} : 0; -my $timeout = exists $opts->{'timeout'} - ? $opts->{'timeout'} +my $timeout = exists $opts->{'timeout'} + ? $opts->{'timeout'} : 300; ### use default answers? @@ -64,7 +64,7 @@ my $format; $conf->set_conf( dist_type => $format ); ### is this a valid format?? - die loc("Invalid format: " . ($format || "[NONE]") ) . usage() + die loc("Invalid format: " . ($format || "[NONE]") ) . usage() unless $formats{$format}; ### any options to fix config entries @@ -72,14 +72,14 @@ my $format; 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', @@ -87,54 +87,54 @@ my $format; skiptest => 'skiptest', makefile => 'prefer_makefile' ); - - ### set config options from arguments + + ### set config options from arguments while (my($key,$val) = each %map) { - my $bool = exists $opts->{$key} - ? $opts->{$key} + 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'} }; -} + 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"; } @@ -144,13 +144,13 @@ die usage() unless @modules; my $fh; LOGFILE: { if( my $file = $opts->{logfile} ) { - open $fh, ">$file" or ( + 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; } @@ -159,7 +159,7 @@ LOGFILE: { ### reload indices if so desired $cb->reload_indices() if $opts->{'flushcache'}; -{ my @ban = exists $opts->{'ban'} +{ my @ban = exists $opts->{'ban'} ? map { qr/$_/ } @{ $opts->{'ban'} } : (); @@ -167,54 +167,54 @@ $cb->reload_indices() if $opts->{'flushcache'}; 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() + map { split /\n/ } _default_ban_list() if $opts->{'default-banlist'}; - - ### use our prereq install callback + + ### 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 ) + $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'} +{ my @ignore = exists $opts->{'ignore'} ? map { qr/$_/ } @{ $opts->{'ignore'} } : (); @@ -225,10 +225,10 @@ $cb->reload_indices() if $opts->{'flushcache'}; push @ignore, map { s/\s+//; $_ } map { [split /\s*#\s*/]->[0] } grep { /#/ } - map { split /\n/ } _default_ignore_list() + map { split /\n/ } _default_ignore_list() if $opts->{'default-ignorelist'}; - + ### register install callback ### $cb->_register_callback( name => 'filter_prereqs', @@ -238,7 +238,7 @@ $cb->reload_indices() if $opts->{'flushcache'}; 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 ". @@ -249,44 +249,44 @@ $cb->reload_indices() if $opts->{'flushcache'}; warn loc("'%1' found in your ignore list (%2) ". "-- filtering it out\n", $name, $pat); - delete $href->{ $name }; + 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 ); + $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), @@ -303,7 +303,7 @@ for my $name (@modules) { ### set the location of the tarball $obj->status->fetch($name); - ### plain old cpan module? + ### plain old cpan module? } else { ### find the corresponding module object ### @@ -318,26 +318,26 @@ for my $name (@modules) { warn loc("'%1' found in your ban list (%2) -- skipping\n", $obj->module, $pat ); next; - } - - ### or just ignored it? + } + + ### 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 { + 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( + my $rv = $obj->install( prereq_target => $target, target => $target, keep_source => $keep, @@ -346,32 +346,32 @@ for my $name (@modules) { ### any passed arbitrary options %$dist_opts, ); - - alarm 0; + + 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'", + 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; + 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) { @@ -398,7 +398,7 @@ sub parse_file { s/^(\S+).*/$1/; # skip extra info push @rv, $qr ? qr/$_/ : $_; # add pattern to the list } - + return @rv; } @@ -430,11 +430,11 @@ sub usage { 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] + 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. @@ -446,21 +446,21 @@ $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. + 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 + 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 @@ -484,7 +484,7 @@ Options: 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 + 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) @@ -497,71 +497,71 @@ Options: --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 + 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 + 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 + 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 + 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. + --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, + ### 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 + + ### 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 + ### 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 + 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; } @@ -581,7 +581,7 @@ if you like, or supply your own if need be. =head2 Built-In Ignore List -=pod +=pod You can use this list of regexes to ignore modules matching to be listed as prerequisites of a package. Particularly useful @@ -601,9 +601,9 @@ sub _default_ignore_list { ^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 + ^ExtUtils::MakeMaker$ # Shipped with perl, recent versions # have bug 14721 (see rt.cpan.org) - ^ExtUtils::Install$ # Part of of EU::MM, same reason + ^ExtUtils::Install$ # Part of of EU::MM, same reason =cut @@ -657,10 +657,10 @@ 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) +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 +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.pm b/cpan/CPANPLUS/lib/CPANPLUS.pm index b012257265..ca2243c4a3 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS.pm @@ -13,7 +13,7 @@ BEGIN { use vars qw( @EXPORT @ISA $VERSION ); @EXPORT = qw( shell fetch get install ); @ISA = qw( Exporter ); - $VERSION = "0.9103"; #have to hardcode or cpan.org gets unhappy + $VERSION = "0.9105"; #have to hardcode or cpan.org gets unhappy } ### purely for backward compatibility, so we can call it from the commandline: @@ -124,21 +124,21 @@ that use this API. =head2 GENERAL USAGE -This is the document you are currently reading. It describes -basic usage and background information. Its main purpose is to +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 +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. +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 @@ -150,7 +150,7 @@ from your script to the CPANPLUS Shell. =head2 STARTING AN INTERACTIVE SHELL -You can start an interactive shell by running either of +You can start an interactive shell by running either of the two following commands: $ cpanp @@ -158,34 +158,34 @@ the two following commands: $ 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. +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 +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 +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>. +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, +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 +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>. +for example C<.deb> or C<FreeBSD ports>. See C<cpan2dist -h> for details. @@ -238,10 +238,10 @@ 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) +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 +This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO @@ -256,7 +256,7 @@ L<CPANPLUS::Shell::Default>, L<CPANPLUS::FAQ>, L<CPANPLUS::Backend>, L<CPANPLUS: I<bug-cpanplus@rt.cpan.org> =item * Questions & suggestions: -I<cpanplus-devel@lists.sourceforge.net> +I<bug-cpanplus@rt.cpan.org> =back diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Backend.pm b/cpan/CPANPLUS/lib/CPANPLUS/Backend.pm index 43e73b7b1f..0d945d5524 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Backend.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Backend.pm @@ -66,7 +66,7 @@ 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> +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. @@ -134,13 +134,13 @@ sub module_tree { my @rv; for my $name ( grep { defined } @_) { - ### From John Malmberg: This is failing on VMS - ### because ODS-2 does not retain the case of + ### 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 + ### 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 @@ -152,7 +152,7 @@ sub module_tree { ) : $modtree->{$name} }; - + push @rv, $modobj || ''; } return @rv == 1 ? $rv[0] : @rv; @@ -418,6 +418,8 @@ C<parse_module>; =item Text-Bastardize +=item Text/Bastardize.pm + =item Text-Bastardize-1.06 =item AYRNIEU/Text-Bastardize @@ -444,7 +446,7 @@ 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 +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. @@ -483,7 +485,7 @@ sub parse_module { error(loc("Can not parse module string from reference '%1'", $mod )); return; } - + ### check only for allowed characters in a module name unless( $mod =~ /[^\w:]/ ) { @@ -516,17 +518,17 @@ sub parse_module { ); ### better guess for the version - $modobj->version( $modobj->package_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 ) + $modobj->module( $pkgname ) if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/; - } + } $modobj->status->fetch( $parent ); $modobj->status->extract( $dir ); @@ -549,27 +551,37 @@ sub parse_module { 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 ) + $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 ) + $modobj->module( $pkgname ) if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/; - } - - return $modobj; + } + + 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, @@ -582,7 +594,7 @@ sub parse_module { ); 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} ); @@ -595,30 +607,30 @@ sub parse_module { 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 + 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 + $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) = + 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 $guess = $pkg; + $guess =~ s/-/::/g if $guess; my $maybe = $self->module_tree( $guess ); if( IS_MODOBJ->( module => $maybe ) ) { @@ -648,18 +660,18 @@ sub parse_module { } 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 + package => do { $ext + ? $full + : $full .'.'. $maybe->package_extension }, path => $path, author => $auth_obj, @@ -669,27 +681,27 @@ sub parse_module { ### you asked for a specific version? ### assume our $maybe is the one you wanted, - ### and fix up the version.. + ### and fix up the version.. } else { - + my $modobj = $maybe->clone; $modobj->version( $version ); - $modobj->package( - $maybe->package_name .'-'. - $version .'.'. - $maybe->package_extension + $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; @@ -734,7 +746,7 @@ sub parse_module { # This should catch edge-cases where the package name # is unrelated to the modules it contains. - my ($modobj) = grep { $_->package_name eq $mod } + my ($modobj) = grep { $_->package_name eq $mod } $self->search( type => 'package', allow => [ qr/^\Q$mod\E/ ], ); return $modobj if IS_MODOBJ->( module => $modobj ); @@ -829,7 +841,7 @@ 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 +This enables you to load them again after a failed load, if they somehow have become available. =item * C<all> @@ -904,7 +916,7 @@ 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 +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. @@ -1014,7 +1026,7 @@ 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; @@ -1077,7 +1089,7 @@ sub autobundle { 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; @@ -1139,7 +1151,7 @@ EOF =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 +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. @@ -1150,7 +1162,7 @@ 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, +The method will return true if it managed to save the state to disk, or false if it did not. =cut @@ -1168,7 +1180,7 @@ sub save_state { =head1 CUSTOM MODULE SOURCES -Besides the sources as provided by the general C<CPAN> mirrors, it's +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>. @@ -1195,13 +1207,13 @@ sub list_custom_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 +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 +not saved until you rebuild or save the tree to disk again. You can do this using the C<< $cb->reload_indices >> method. =cut @@ -1250,14 +1262,14 @@ 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 +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, @_) @@ -1265,11 +1277,11 @@ sub update_custom_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 +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. @@ -1278,7 +1290,7 @@ 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 +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 @@ -1301,15 +1313,15 @@ 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) +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 +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::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>, L<CPANPLUS::Selfupdate> =cut diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Backend/RV.pm b/cpan/CPANPLUS/lib/CPANPLUS/Backend/RV.pm index e861a093a2..f8bd7d75d0 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Backend/RV.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Backend/RV.pm @@ -117,7 +117,7 @@ sub _ok { return shift->ok } ### 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, +use overload bool => \&_ok, # '""' => \&_stringify, fallback => 1; @@ -133,10 +133,10 @@ 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) +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 +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/Config.pm b/cpan/CPANPLUS/lib/CPANPLUS/Config.pm index 5cf11d3e73..321e0659f2 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Config.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Config.pm @@ -31,12 +31,12 @@ CPANPLUS::Config ### 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' ); + $verbose = $conf->get_conf( 'verbose' ); $conf->set_conf( verbose => 1 ); ### values in 'program' section @@ -45,7 +45,7 @@ CPANPLUS::Config =head1 DESCRIPTION -This module contains defaults and heuristics for configuration +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>. @@ -62,7 +62,7 @@ my $Conf = { '_fetch' => { 'blacklist' => [ 'ftp' ], }, - + ### _source, _build and _mirror are supposed to be static ### no changes should be needed unless pause/cpan changes '_source' => { @@ -139,7 +139,7 @@ An example entry would like this: 'host' => 'ftp.funet.fi' } ]; - + =item allow_build_interactivity Boolean flag to indicate whether 'perl Makefile.PL' and similar @@ -199,7 +199,7 @@ Defaults to 'false'. =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 +or C<CPANPLUS::Dist> for details. An empty string will not use any package building software. Defaults to an empty string. =cut @@ -214,7 +214,7 @@ 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 @@ -231,7 +231,7 @@ Defaults to C<true> =item extractdir -String containing the directory where fetched archives should be +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. @@ -241,7 +241,7 @@ directory. Defaults to an empty string. =item fetchdir -String containing the directory where fetched archives should be +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. @@ -303,7 +303,7 @@ installed, 'false' otherwise. =cut - $Conf->{'conf'}->{'md5'} = ( + $Conf->{'conf'}->{'md5'} = ( check_install( module => 'Digest::SHA' ) ? 1 : 0 ); =item no_update @@ -326,8 +326,8 @@ Defaults to 'true'. =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 +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) @@ -335,20 +335,20 @@ C<.tar.gz> files) ### 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'} = + $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 +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 + $Conf->{'conf'}->{'prefer_makefile'} = + ( $] >= 5.010001 or ( check_install( module => 'Module::Build', version => '0.32' ) and check_install( module => INSTALLER_BUILD, version => '0.24' ) ) ? 0 : 1 ); @@ -382,7 +382,7 @@ Defaults to C<CPANPLUS::Shell::Default>, the default CPANPLUS shell. =item show_startup_tip -A boolean indicating whether or not to show start up tips in the +A boolean indicating whether or not to show start up tips in the interactive shell. Defaults to 'true'. =cut @@ -392,14 +392,14 @@ interactive shell. Defaults to 'true'. =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> +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') || + and ( can_run('gpg') || check_install(module => 'Crypt::OpenPGP') ); } ? 1 : 0; @@ -417,12 +417,12 @@ Defaults to 'false'. 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 +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'} = + $Conf->{'conf'}->{'storable'} = ( check_install( module => 'Storable' ) ? 1 : 0 ); =item timeout @@ -437,7 +437,7 @@ Defaults to 300. =item verbose A boolean indicating whether or not C<CPANPLUS> runs in verbose mode. -Defaults to 'true' if you have the environment variable +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 @@ -464,7 +464,7 @@ C<CPANPLUS::Internals::Source>. Default to C<CPANPLUS::Internals::Source::Memory =cut - $Conf->{'conf'}->{'source_engine'} = DEFAULT_SOURCE_ENGINE; + $Conf->{'conf'}->{'source_engine'} = DEFAULT_SOURCE_ENGINE; =item cpantest_reporter_args @@ -474,14 +474,14 @@ set it to: { transport => 'Net::SMTP::TLS', transport_args => [ User => 'Joe', Password => '123' ], - } + } =cut $Conf->{'conf'}->{'cpantest_reporter_args'} = {}; =back - + =head2 Section 'program' =cut @@ -510,7 +510,7 @@ program used to build perl or failing that, a C<make> in your path. =cut - $Conf->{'program'}->{'make'} = + $Conf->{'program'}->{'make'} = can_run($Config{'make'}) || can_run('make'); =item pager @@ -520,7 +520,7 @@ $ENV{PAGER}, 'less' or 'more' programs, in that order. =cut - $Conf->{'program'}->{'pager'} = + $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 @@ -534,14 +534,14 @@ $ENV{SHELL} setting, or $ENV{COMSPEC} on Windows. =cut - $Conf->{'program'}->{'shell'} = $^O eq 'MSWin32' - ? $ENV{COMSPEC} + $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 +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 @@ -550,19 +550,19 @@ remains empty if you do not require super user permissions to install. ### 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'} ) { - + if( -w $Config{'installsitelib'} && -w $Config{'installsitebin'} ) { + ### installsiteman3dir is a 5.8'ism.. don't check - ### it on 5.6.x... + ### it on 5.6.x... if( defined $Config{'installsiteman3dir'} ) { - $sudo = -w $Config{'installsiteman3dir'} + $sudo = -w $Config{'installsiteman3dir'} ? undef : can_run('sudo'); } else { @@ -572,17 +572,17 @@ remains empty if you do not require super user permissions to install. ### you have PERL_MM_OPT set to some alternate ### install place. You probably have write permissions ### to that - } elsif ( $ENV{'PERL_MM_OPT'} and + } elsif ( $ENV{'PERL_MM_OPT'} and $ENV{'PERL_MM_OPT'} =~ /INSTALL|LIB|PREFIX/ ) { $sudo = undef; ### you probably don't have write permissions - } else { + } else { $sudo = can_run('sudo'); } - } - + } + ### and return the value $sudo; }; @@ -594,14 +594,14 @@ with CPANPLUS, which is used to enable autoflushing in spawned processes. =cut - ### perlwrapper that allows us to turn on autoflushing - $Conf->{'program'}->{'perlwrapper'} = sub { + ### 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 @@ -618,17 +618,17 @@ with CPANPLUS, which is used to enable autoflushing in spawned processes. 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( + File::Spec->catfile( dirname($INC{'CPANPLUS.pm'}), '..', # lib dir 'bin', # bin dir @@ -636,14 +636,14 @@ with CPANPLUS, which is used to enable autoflushing in spawned processes. ) ); $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( + File::Spec->catfile( dirname( $INC{'CPANPLUS.pm'} ), '..', '..', '..', '..', # 4x updir 'bin', # bin dir @@ -660,8 +660,8 @@ with CPANPLUS, which is used to enable autoflushing in spawned processes. ### 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, - ) { + File::Spec->curdir, + ) { ### On VMS the path could be in UNIX format, and we ### currently need it to be in VMS format @@ -670,15 +670,15 @@ with CPANPLUS, which is used to enable autoflushing in spawned processes. $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; - + ### if not, warn about it and give sensible default. - ### XXX try to be a no-op instead then.. + ### XXX try to be a no-op instead then.. ### cross your fingers... - ### pass '-P' to perl: "run program through C + ### 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 @@ -690,13 +690,13 @@ with CPANPLUS, which is used to enable autoflushing in spawned processes. "From the default shell, you can do this by typing:\n\n". " %3\n". " %4\n", - $name, 'perlwrapper', + $name, 'perlwrapper', 's program perlwrapper FULL_PATH_TO_CPANP_RUN_PERL', 's save' - )); + )); return ''; }->(); - + =back =cut @@ -719,12 +719,12 @@ sub new { ### 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; } @@ -743,18 +743,18 @@ sub _clean_up_paths { ### patch from Steve Hay, 13nd of June 2007 ### msg-id: <467012A4.6060705@uk.radan.com> - ### windows directories are not allowed to end with + ### 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 ); } @@ -778,10 +778,10 @@ 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) +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 +This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Configure.pm b/cpan/CPANPLUS/lib/CPANPLUS/Configure.pm index ba1ca0785a..9ef8cb140f 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Configure.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Configure.pm @@ -26,12 +26,12 @@ $VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION; ### 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}; - } + } } @@ -74,7 +74,7 @@ a method call on a C<CPANPLUS::Backend> object. =item load_configs -Controls whether or not additional user configurations are to be loaded +Controls whether or not additional user configurations are to be loaded or not. Defaults to C<true>. =back @@ -89,7 +89,7 @@ or not. Defaults to C<true>. sub new { my $class = shift; my %hash = @_; - + ### XXX pass on options to ->init() like rescan? my ($load); my $tmpl = { @@ -99,7 +99,7 @@ or not. Defaults to C<true>. check( $tmpl, \%hash ) or ( warn Params::Check->last_error, return ); - + $Config ||= CPANPLUS::Config->new; my $self = bless {}, $class; $self->conf( $Config ); @@ -108,11 +108,11 @@ or not. Defaults to C<true>. ### these can override things in the default config $self->init if $load; - ### after processing the config files, check what + ### after processing the config files, check what ### @INC and PERL5LIB are set to. $self->_lib( \@INC ); $self->_perl5lib( $ENV{'PERL5LIB'} ); - + return $self; } } @@ -143,21 +143,21 @@ Returns true on success, false on failure. 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; @@ -169,17 +169,17 @@ Returns true on success, false on failure. "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 ) { + 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) ], @@ -187,54 +187,54 @@ Returns true on success, false on failure. 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 { $_ => $_ } + my %confs = map { $_ => $_ } grep { $_ !~ /::ISA::/ } __PACKAGE__->configs; - my @confs = grep { defined } + my @confs = grep { defined } map { delete $confs{$_} } CONFIG_SYSTEM, CONFIG_USER; - push @confs, sort keys %confs; - + 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 + + ### 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)", + 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; @@ -244,10 +244,10 @@ Returns true on success, false on failure. my %inc = map { $_ => $_ } @INC; for my $l ( @$lib ) { push @INC, $l unless $inc{$l}; - } + } $self->_lib( \@INC ); } - + return 1; } } @@ -265,7 +265,7 @@ Returns true if the file can be saved, false otherwise. sub can_save { my $self = shift; my $file = shift || CONFIG_USER_FILE->(); - + return 1 unless -e $file; chmod 0644, $file; @@ -284,7 +284,7 @@ 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, +Returns the full path to the file if the config was saved, false otherwise. =cut @@ -298,12 +298,12 @@ sub _config_pm_to_file { ### so figure out where to save them based on their type my $file; if( $pm eq CONFIG_USER ) { - $file = CONFIG_USER_FILE->(); + $file = CONFIG_USER_FILE->(); } elsif ( $pm eq CONFIG_SYSTEM ) { $file = CONFIG_SYSTEM_FILE->(); - - ### third party file + + ### third party file } else { my $cfg_pkg = CONFIG . '::'; unless( $pm =~ /^$cfg_pkg/ ) { @@ -311,13 +311,13 @@ sub _config_pm_to_file { "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'; + ) . '.pm'; } return $file; @@ -328,16 +328,16 @@ 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 @@ -345,18 +345,18 @@ sub save { ### 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, $/,$/; @@ -368,13 +368,13 @@ sub save { ### 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 -### +### +### Configuration structure for $pm +### ############################################### #last changed: $time GMT @@ -399,11 +399,11 @@ use strict; sub setup { my \$conf = shift; - + $str - return 1; -} + return 1; +} 1; @@ -447,7 +447,7 @@ sub options { my %seen; return sort grep { !$seen{$_}++ } - map { $_->$type->ls_accessors if $_->can($type) } + map { $_->$type->ls_accessors if $_->can($type) } $self->conf; return; } @@ -546,9 +546,9 @@ sub AUTOLOAD { ### 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 { + return $self->get_conf($key); + + } else { error( loc(q[No such key '%1' in field '%2'], $key, $type) ); return; } @@ -564,7 +564,7 @@ sub AUTOLOAD { if( $conf->can($type) and $conf->$type->can($key) ) { $conf->$type->$key( $val ); - + } else { error( loc(q[No such key '%1' in field '%2'], $key, $type) ); return; @@ -613,10 +613,10 @@ 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) +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 +This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Configure/Setup.pm b/cpan/CPANPLUS/lib/CPANPLUS/Configure/Setup.pm index b6f34f2a52..7720d85308 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Configure/Setup.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Configure/Setup.pm @@ -60,20 +60,20 @@ sub new { 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('') ) + $obj->term( Term::ReadLine->new('') ) unless $obj->term; ### enable autoreply if that was passed ### @@ -85,10 +85,10 @@ sub new { 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 = ( @@ -99,45 +99,45 @@ sub init { [ 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' ], + [ loc('Select mirrors'), => '_setup_hosts' ], + [ loc('Edit configuration file') => '_edit' ], [ $save => '_save' ], - [ $exit => 1 ], + [ $exit => 1 ], ); my @keys = map { $_->[0] } @map; # sorted keys my %map = map { @$_ } @map; # lookup hash - + PICK_SECTION: { print loc(" -=================> MAIN MENU <================= - +=================> 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 "); @@ -146,14 +146,14 @@ There was an error setting up this section. You might want to try again if( $choice eq $save and $rv ) { print loc(" Quitting setup, changes are saved to '%1' - ", $self->config_type + ", $self->config_type ); return 1; } ### otherwise, present choice again redo PICK_SECTION; - } + } return 1; } @@ -168,22 +168,22 @@ sub _save_where { ASK_CONFIG_TYPE: { - - print loc( q[ + + print loc( q[ Where would you like to save your CPANPLUS Configuration file? -If you want to configure CPANPLUS for this user only, +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, +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 +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( @@ -191,19 +191,19 @@ installation directory. 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 + "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 _ ) { @@ -214,18 +214,18 @@ I see you already have this file: The file will not be overwritten until you explicitly save it. ], $file ); - - redo ASK_CONFIG_TYPE + + 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); - } + } } @@ -237,10 +237,10 @@ sub _setup_base { 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. +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. @@ -266,7 +266,7 @@ For a single-user installation, we suggest using your home directory. print loc(" I see you already have a directory: %1 - + "), $where; my $yn = $term->ask_yn( @@ -338,7 +338,7 @@ First of all, I'd like to create this directory. print loc(q[ Your CPANPLUS build and cache directory has been set to: %1 - + ], $where); return 1; @@ -422,7 +422,7 @@ is required for the 'from' field, so choose wisely. 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], @@ -434,7 +434,7 @@ is required for the 'from' field, so choose wisely. $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! @@ -448,7 +448,7 @@ You did not enter a valid email address, please try again! print loc(" Your 'email' is now: %1 - + ", $email); $conf->set_conf( email => $email ); @@ -481,16 +481,16 @@ like '%1'. 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 + ); + + ### 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"; @@ -505,27 +505,27 @@ like '%1'. 'make' ); print loc("Please provide one!"); - + ### show win32 where to download - if ( $^O eq 'MSWin32' ) { + if ( $^O eq 'MSWin32' ) { print loc("You can get '%1' from:", NMAKE); print "\t". NMAKE_URL ."\n"; } print "\n"; - redo PROGRAM; + redo PROGRAM; } $conf->set_program( $prog => $cmd ); print $cmd - ? loc( "Your '%1' utility has been set to '%2'.", + ? loc( "Your '%1' utility has been set to '%2'.", $prog, $cmd ) - : loc( "Your '%1' has been disabled.", $prog ); + : loc( "Your '%1' has been disabled.", $prog ); print "\n"; } } - + return 1; -} +} sub _setup_installer { my $self = shift; @@ -533,7 +533,7 @@ sub _setup_installer { 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 @@ -543,7 +543,7 @@ 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'; @@ -670,7 +670,7 @@ Again, if you don't understand this question, just press ENTER. 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 +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 @@ -722,10 +722,10 @@ pathnames to be added to your @INC, quoting any with embedded whitespace. $conf->set_conf( $type => $lib ); } - + return 1; -} - +} + sub _setup_conf { my $self = shift; @@ -834,37 +834,37 @@ 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 + [ 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") + 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_ASK, + loc('Ask me before installing a prerequisite'), + loc("I will ask permission to install") ], - [ PREREQ_BUILD, + [ 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 }; @@ -880,7 +880,7 @@ 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 ), @@ -894,7 +894,7 @@ CPANPLUS can do for you later); } - + { ########################################### ## sally sells seashells by the seashore ## ########################################### @@ -909,7 +909,7 @@ please enter the full name for your shell module. my $type = 'shell'; my $other = 'Other'; my @choices = (qw| CPANPLUS::Shell::Default - CPANPLUS::Shell::Classic |, + CPANPLUS::Shell::Classic |, $other ); my $default = $conf->get_conf($type); @@ -929,9 +929,9 @@ please enter the full name for your shell module. ); unless( check_install( module => $reply ) ) { - print "\n", + print "\n", loc("Could not find '$reply' in your path " . - "-- please try again"), + "-- please try again"), "\n"; redo SHELL; } @@ -973,8 +973,8 @@ Would you like to do this? ################### print loc(" - -To limit the amount of RAM used by CPANPLUS, you can use the SQLite + +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? @@ -1197,26 +1197,26 @@ are done. } 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), + 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; @@ -1646,8 +1646,8 @@ post-configuration editing of the config 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 index 20c74fcd4a..9b85f29445 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Dist.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Dist.pm @@ -313,7 +313,7 @@ sub find_configure_requires { defaults => $mod->status->$meth || {}, ); - my @possibles = do { defined $mod->status->extract + my @possibles = do { defined $mod->status->extract ? ( META_JSON->( $mod->status->extract ), META_YML->( $mod->status->extract ) ) : () @@ -363,7 +363,7 @@ sub find_mymeta_requires { defaults => $mod->status->$meth || {}, ); - my @possibles = do { defined $mod->status->extract + my @possibles = do { defined $mod->status->extract ? ( MYMETA_JSON->( $mod->status->extract ), MYMETA_YML->( $mod->status->extract ) ) : () @@ -418,6 +418,9 @@ sub _prereqs_from_meta_file { ### 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 ) { @@ -465,6 +468,9 @@ sub _prereqs_from_meta_json { ### 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 ) { diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Dist/Autobundle.pm b/cpan/CPANPLUS/lib/CPANPLUS/Dist/Autobundle.pm index 9561dd9f32..bf1d24963e 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Dist/Autobundle.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Dist/Autobundle.pm @@ -29,13 +29,13 @@ All modules as mentioned in the snapshot will be installed on your system. 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; @@ -50,11 +50,11 @@ sub prepare { 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; + ### 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; @@ -62,25 +62,25 @@ sub create { my( $force, $verbose, $prereq_target, $prereq_format, $prereq_build); - my $args = do { + my $args = do { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { - force => { default => $conf->get_conf('force'), + force => { default => $conf->get_conf('force'), store => \$force }, - verbose => { default => $conf->get_conf('verbose'), + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, - prereq_target => { default => '', store => \$prereq_target }, + 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 }, - }; + 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; @@ -90,7 +90,7 @@ sub create { msg(loc("Resolving prerequisites mentioned in the bundle"), $verbose); ### this will set the directory back to the start - ### dir, so we must chdir /again/ + ### dir, so we must chdir /again/ my $ok = $dist->_resolve_prereqs( format => $prereq_format, verbose => $verbose, @@ -107,7 +107,7 @@ sub create { sub install { my $dist = shift; my %args = @_; - + ### store the arguments, so ->install can use them in recursive loops ### $dist->status->_install_args( \%args ); diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Dist/Base.pm b/cpan/CPANPLUS/lib/CPANPLUS/Dist/Base.pm index 904ab17226..8e4e02f1f5 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Dist/Base.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Dist/Base.pm @@ -19,13 +19,13 @@ CPANPLUS::Dist::Base - Base class for custom distribution classes 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 ); } @@ -34,7 +34,7 @@ CPANPLUS::Dist::Base - Base class for custom distribution classes =head1 DESCRIPTION CPANPLUS::Dist::Base functions as a base class for all custom -distribution implementations. It does all the mundane work +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. @@ -50,7 +50,7 @@ class are called: $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 @@ -64,8 +64,8 @@ override. =cut -sub methods { - return qw[format_available init prepare create install uninstall] +sub methods { + return qw[format_available init prepare create install uninstall] } =head2 $bool = $Class->format_available @@ -82,7 +82,7 @@ Simply return true if the request can proceed and false if it can not. The C<CPANPLUS::Dist::Base> implementation always returns true. -=cut +=cut sub format_available { return 1 } @@ -91,21 +91,21 @@ sub format_available { return 1 } 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. +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 +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 +The C<CPANPLUS::Dist::Base> implementation does not alter your object and always returns true. =cut @@ -116,14 +116,14 @@ sub init { return 1; } 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 +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 +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 +distribution class (Typically C<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build>). Sets C<< $dist->status->prepared >> to the return value of this function. @@ -131,7 +131,7 @@ If you override this method, you should make sure to set this value. =cut -sub prepare { +sub prepare { ### just in case you already did a create call for this module object ### just via a different dist object my $dist = shift; @@ -147,18 +147,18 @@ sub 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 +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 +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 +distribution class (Typically C<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build>). -Sets C<< $dist->status->dist >> to the location of the created +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. @@ -167,7 +167,7 @@ If you override this method, you should make sure to set this value. =cut -sub create { +sub create { ### just in case you already did a create call for this module object ### just via a different dist object my $dist = shift; @@ -193,13 +193,13 @@ sub create { 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 +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 +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 +distribution class (Typically C<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build>). Sets C<< $dist->status->installed >> to the return value of this function. @@ -207,12 +207,12 @@ If you override this method, you should make sure to set this value. =cut -sub install { +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 $dist_cpan = $self->status->dist_cpan; my $cb = $self->parent; my $conf = $cb->configure_object; @@ -223,14 +223,14 @@ sub 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 +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 +distribution class (Typically C<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build>). Sets C<< $dist->status->uninstalled >> to the return value of this function. @@ -238,12 +238,12 @@ If you override this method, you should make sure to set this value. =cut -sub uninstall { +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 $dist_cpan = $self->status->dist_cpan; my $cb = $self->parent; my $conf = $cb->configure_object; @@ -251,7 +251,7 @@ sub uninstall { $dist->status->uninstalled( $dist_cpan->uninstall( @_ ) ); } -1; +1; # Local variables: # c-indentation-style: bsd diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Dist/MM.pm b/cpan/CPANPLUS/lib/CPANPLUS/Dist/MM.pm index b2205e46f0..18c2418ada 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Dist/MM.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Dist/MM.pm @@ -28,7 +28,7 @@ CPANPLUS::Dist::MM =head1 SYNOPSIS $mm = CPANPLUS::Dist::MM->new( module => $modobj ); - + $mm->create; # runs make && make test $mm->install; # runs make install @@ -37,7 +37,7 @@ CPANPLUS::Dist::MM C<CPANPLUS::Dist::MM> is a distribution class for MakeMaker related modules. -Using this package, you can create, install and uninstall perl +Using this package, you can create, install and uninstall perl modules. It inherits from C<CPANPLUS::Dist>. =head1 ACCESSORS @@ -55,7 +55,7 @@ this module. =back -=head1 STATUS ACCESSORS +=head1 STATUS ACCESSORS All accessors can be accessed as follows: $mm->status->ACCESSOR @@ -64,7 +64,7 @@ All accessors can be accessed as follows: =item makefile () -Location of the Makefile (or Build file). +Location of the Makefile (or Build file). Set to 0 explicitly if something went wrong. =item make () @@ -73,7 +73,7 @@ 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 +BOOL indicating if the C<make test> (or C<Build test>) command was successful. =item prepared () @@ -84,7 +84,7 @@ 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>. +set after a call to C<prepare>. =item created () @@ -126,39 +126,39 @@ to create and install modules in your environment. ### 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( + 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__ ) ); + $mod, __PACKAGE__ ) ); return; } - + for my $pgm ( qw[make] ) { - unless( $conf->get_program( $pgm ) ) { + 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'", + "Please check your config entry for '%1'", $pgm, __PACKAGE__ , $pgm - )); + )); return; } } - return 1; + return 1; } =pod =head2 $bool = $dist->init(); -Sets up the C<CPANPLUS::Dist::MM> object for use. +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. @@ -168,24 +168,24 @@ Called automatically whenever you create a new C<CPANPLUS::Dist> object. 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 +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. +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 @@ -204,11 +204,11 @@ sub prepare { ### 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; + ### 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; @@ -219,7 +219,7 @@ sub prepare { error( loc( "No dir found to operate on!" ) ); return; } - + my $args; my( $force, $verbose, $perl, @mmflags, $prereq_target, $prereq_format, $prereq_build ); @@ -229,34 +229,34 @@ sub prepare { makemakerflags => { default => $conf->get_conf('makemakerflags') || '', store => \$mmflags[0] }, - force => { default => $conf->get_conf('force'), + force => { default => $conf->get_conf('force'), store => \$force }, - verbose => { default => $conf->get_conf('verbose'), + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, - prereq_target => { default => '', store => \$prereq_target }, + prereq_target => { default => '', store => \$prereq_target }, prereq_format => { default => '', - store => \$prereq_format }, - prereq_build => { default => 0, store => \$prereq_build }, - }; + store => \$prereq_format }, + prereq_build => { default => 0, store => \$prereq_build }, + }; $args = check( $tmpl, \%hash ) or return; } - - + + ### 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; + + my $fail; RUN: { ### we resolve 'configure requires' here, so we can run the 'perl @@ -266,7 +266,7 @@ sub prepare { ### 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 $configure_requires = $dist->find_configure_requires; my $ok = $dist->_resolve_prereqs( format => $prereq_format, verbose => $verbose, @@ -274,80 +274,80 @@ sub prepare { 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 ) ); + "-- aborting install", + 'configure_requires', $self->module ) ); $dist->status->prepared(0); - $fail++; + $fail++; last RUN; - } + } ### end of prereq resolving ### } - - ### don't run 'perl makefile.pl' again if there's a makefile already + + ### 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 + + $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", + 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 || + 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; - + 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 || ''; - + #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 @@ -356,10 +356,10 @@ sub prepare { ### XXX this fails under ipc::run due to the extra quotes, ### but it works in ipc::open3. however, ipc::open3 doesn't work ### on win32/cygwin. XXX TODO get a windows box and sort this out - # my $cmd = qq[$perl -MEnglish -le ] . + # my $cmd = qq[$perl -MEnglish -le ] . # QUOTE_PERL_ONE_LINER->( # qq[\$OUTPUT_AUTOFLUSH++,do(q($makefile_pl))] - # ) + # ) # . $mmflags; # my $flush = OPT_AUTOFLUSH; @@ -370,20 +370,20 @@ sub prepare { ### set ENV var to tell underlying code this is what we're ### executing. - my $captured; + 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 + 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; } @@ -391,7 +391,7 @@ sub prepare { ### 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 @@ -407,39 +407,39 @@ sub prepare { "$^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) ); - + $dist->status->makefile( MAKEFILE->($dir) ); + ### start resolving prereqs ### my $prereqs = $self->status->prereqs; - + ### a hashref of prereqs on success, undef on failure ### - $prereqs ||= $dist->_find_prereqs( + $prereqs ||= $dist->_find_prereqs( verbose => $verbose, - file => $dist->status->makefile + file => $dist->status->makefile ); - + unless( $prereqs ) { - error( loc( "Unable to scan '%1' for 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); } @@ -467,28 +467,28 @@ sub _find_prereqs { verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, file => { required => 1, allow => FILE_READABLE, store => \$file }, }; - - my $args = check( $tmpl, \%hash ) or return; + + 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+(.+)|; - + 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); @@ -496,7 +496,7 @@ sub _find_prereqs { if $cb->_vcmp( $ver, $p{$1} ) > 0; } else { - $p{$1} = $cb->_version_to_number(version => $2); + $p{$1} = $cb->_version_to_number(version => $2); } } last; @@ -505,23 +505,23 @@ sub _find_prereqs { my $href = $cb->_callbacks->filter_prereqs->( $cb, \%p ); $self->status->prereqs( $href ); - + ### just to make sure it's not the same reference ### - return { %$href }; -} + 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. +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 +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. @@ -536,11 +536,11 @@ sub create { ### 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; + ### 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; @@ -551,63 +551,63 @@ sub create { error( loc( "No dir found to operate on!" ) ); return; } - + my $args; - my( $force, $verbose, $make, $makeflags, $skiptest, $prereq_target, $perl, + 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'), + force => { default => $conf->get_conf('force'), store => \$force }, - verbose => { default => $conf->get_conf('verbose'), + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, - make => { default => $conf->get_program('make'), + make => { default => $conf->get_program('make'), store => \$make }, - makeflags => { default => $conf->get_conf('makeflags'), + makeflags => { default => $conf->get_conf('makeflags'), store => \$makeflags }, - skiptest => { default => $conf->get_conf('skiptest'), + skiptest => { default => $conf->get_conf('skiptest'), store => \$skiptest }, - prereq_target => { default => '', store => \$prereq_target }, + 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 }, - }; + store => \$prereq_format }, + prereq_build => { default => 0, store => \$prereq_build }, + }; $args = check( $tmpl, \%hash ) or return; } - + ### 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; RUN: { ### this will set the directory back to the start - ### dir, so we must chdir /again/ + ### dir, so we must chdir /again/ my $ok = $dist->_resolve_prereqs( format => $prereq_format, verbose => $verbose, @@ -616,40 +616,40 @@ sub create { 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 ) ); + "-- aborting install", $self->module ) ); $dist->status->make(0); $fail++; $prereq_fail++; last RUN; - } - ### end of prereq resolving ### - + } + ### end of prereq resolving ### + my $captured; - ### 'make' section ### + ### '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", + "not running again unless you force", $make, $self->module ), $verbose ); } else { unless(scalar run( command => [$make, $makeflags], buffer => \$captured, - verbose => $verbose ) + verbose => $verbose ) ) { error( loc( "MAKE failed: %1 %2", $!, $captured ) ); $dist->status->make(0); $fail++; last RUN; } - + ### put the output on the stack, don't print it msg( $captured, 0 ); @@ -657,12 +657,12 @@ sub create { ### 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 ### + + ### 'make test' section ### unless( $skiptest ) { ### turn off our PERL5OPT so no modules from CPANPLUS::inc get @@ -673,16 +673,16 @@ sub create { #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 + ### the config setting below, although it is really not ### recommended - my $run_verbose = - $verbose || + my $run_verbose = + $verbose || $conf->get_conf('allow_build_interactivity') || 0; - ### XXX need to add makeflags here too? + ### XXX need to add makeflags here too? ### yes, but they should really be split out -- see bug #4143 - if( scalar run( + if( scalar run( command => [$make, 'test', $makeflags], buffer => \$captured, verbose => $run_verbose, @@ -695,36 +695,36 @@ sub create { } else { msg( loc( "MAKE TEST passed: %1", $captured ), 0 ); } - + $dist->status->test(1); } else { - error( loc( "MAKE TEST failed: %1", $captured ) ); - + error( loc( "MAKE TEST failed: %1", $captured ), ( $run_verbose ? 0 : 1 ) ); + ### 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 ) + $self, $captured ) ) { - $fail++; last RUN; + $fail++; last RUN; } } } } #</RUN> - + unless( $cb->_chdir( dir => $orig ) ) { error( loc( "Could not chdir back to start dir '%1'", $orig ) ); - } - + } + ### 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( + $cb->_send_report( module => $self, failed => $test_fail || $fail, buffer => CPANPLUS::Error->stack_as_string, @@ -732,10 +732,10 @@ sub create { force => $force, ) or error(loc("Failed to send test report for '%1'", $self->module ) ); - } - + } + return $dist->status->created( $fail ? 0 : 1); -} +} =pod @@ -744,7 +744,7 @@ sub create { C<install> runs the following command: make install -Returns true on success, false on failure. +Returns true on success, false on failure. =cut @@ -754,64 +754,64 @@ sub install { ### to the same module object my $dist = shift(); my $self = $dist->parent; - $dist = $self->status->dist_cpan if $self->status->dist_cpan; - + $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'), + force => { default => $conf->get_conf('force'), store => \$force }, - verbose => { default => $conf->get_conf('verbose'), + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, - make => { default => $conf->get_program('make'), + make => { default => $conf->get_program('make'), store => \$make }, - makeflags => { default => $conf->get_conf('makeflags'), + 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 + 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; } - + $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? + ### 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'); @@ -821,33 +821,33 @@ sub install { unless(scalar run( command => $cmd, verbose => $verbose, buffer => \$captured, - ) ) { + ) ) { error( loc( "MAKE INSTALL failed: %1 %2", $!, $captured ) ); - $fail++; - } + $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 +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 +The file gets written to the directory the module's been extracted to. =cut @@ -857,9 +857,9 @@ sub write_makefile_pl { ### 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; - + $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 = @_; @@ -869,23 +869,23 @@ sub write_makefile_pl { error( loc( "No dir found to operate on!" ) ); return; } - + my ($force, $verbose); my $tmpl = { - force => { default => $conf->get_conf('force'), + force => { default => $conf->get_conf('force'), store => \$force }, - verbose => { default => $conf->get_conf('verbose'), - store => \$verbose }, - }; + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + my $args = check( $tmpl, \%hash ) or return; - 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", + 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; @@ -899,58 +899,58 @@ sub write_makefile_pl { 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; - + 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 +$prereqs }, ); - \n|; - + \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; - + $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 => \$make }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, - }; - - check( $tmpl, \%hash ) or return; + }; + + check( $tmpl, \%hash ) or return; } @@ -959,7 +959,7 @@ sub dist_dir { error( loc( "No dir found to operate on!" ) ); return; } - + ### chdir to work directory ### my $orig = cwd(); unless( $cb->_chdir( dir => $dir ) ) { @@ -968,14 +968,14 @@ sub dist_dir { } my $fail; my $distdir; - TRY: { + TRY: { $dist->prepare( @_ ) or (++$fail, last TRY); - my $captured; + my $captured; unless(scalar run( command => [$make, 'distdir'], buffer => \$captured, - verbose => $verbose ) + verbose => $verbose ) ) { error( loc( "MAKE DISTDIR failed: %1 %2", $!, $captured ) ); ++$fail, last TRY; @@ -998,7 +998,7 @@ sub dist_dir { return if $fail; return $distdir; -} +} 1; diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Error.pm b/cpan/CPANPLUS/lib/CPANPLUS/Error.pm index c42435f192..ee6cbd8ae2 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Error.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Error.pm @@ -79,17 +79,17 @@ BEGIN { 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, diff --git a/cpan/CPANPLUS/lib/CPANPLUS/FAQ.pod b/cpan/CPANPLUS/lib/CPANPLUS/FAQ.pod index 82bb57aaf4..f7c4128596 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/FAQ.pod +++ b/cpan/CPANPLUS/lib/CPANPLUS/FAQ.pod @@ -20,10 +20,10 @@ 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) +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 +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 index 6a754fb25e..130cfb76d0 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Hacking.pod +++ b/cpan/CPANPLUS/lib/CPANPLUS/Hacking.pod @@ -14,8 +14,8 @@ features or patches to CPANPLUS. =head1 OBTAINING CPANPLUS -Checkout CPANPLUS from its Subversion repository at -L<http://oss.dwim.org/cpanplus-devel> . +Checkout CPANPLUS from its GIT repository at +L<https://github.com/jib/cpanplus-devel> . =head1 INSTALLING CPANPLUS @@ -73,7 +73,7 @@ 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: - cpanplus-devel@lists.sourceforge.net + bug-cpanplus@rt.cpan.org A good C<patch> would have the following characteristics: @@ -115,7 +115,7 @@ We prefer patches in the following format: =item * Including patches for code + tests + docs -=item * Sent per mail to cpanplus-devel@lists.sourceforge.net +=item * Sent per mail to bug-cpanplus@rt.cpan.org =item * With subject containing C<[PATCH]> + description of the patch diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals.pm index 4756421a4a..2d55f1fd24 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals.pm @@ -42,7 +42,7 @@ use vars qw[@ISA $VERSION]; CPANPLUS::Internals::Report ]; -$VERSION = "0.9103"; +$VERSION = "0.9105"; =pod @@ -109,7 +109,7 @@ Returns the object on success, or dies on failure. ### if extra callbacks are added, don't forget to update the ### 02-internals.t test script with them! my $callback_map = { - ### name default value + ### 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? @@ -121,7 +121,7 @@ Returns the object on success, or dies on failure. proceed_on_test_failure => sub { return 0 }, munge_dist_metafile => sub { return $_[1] }, }; - + my $status = Object::Accessor->new; $status->mk_accessors(qw[pending_prereqs]); @@ -169,14 +169,14 @@ Returns the object on success, or dies on failure. 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} + $name, $rv), $args->_conf->get_conf('debug')); + return ref $callback_map->{$name} ? $callback_map->{$name}->( @_ ) : $callback_map->{$name}; - } + } ); } @@ -199,24 +199,24 @@ Returns the object on success, or dies on failure. } ### different source engines available now, so set them here - { my $store = $conf->get_conf( 'source_engine' ) + { 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; @@ -293,7 +293,7 @@ be flushed. ### if extra callbacks are added, don't forget to update the ### 02-internals.t test script with them! -=pod +=pod =head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF ); @@ -312,20 +312,20 @@ 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. 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 +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 +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 @@ -365,36 +365,36 @@ written to the metafile. } # =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; # } @@ -424,14 +424,14 @@ sub _add_to_includepath { 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 + ### 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|; } diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants.pm index 443d5a4ca8..556fb349df 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants.pm @@ -21,10 +21,10 @@ sub constants { @EXPORT }; use constant INSTALLER_BUILD => 'CPANPLUS::Dist::Build'; -use constant INSTALLER_MM => 'CPANPLUS::Dist::MM'; -use constant INSTALLER_SAMPLE +use constant INSTALLER_MM => 'CPANPLUS::Dist::MM'; +use constant INSTALLER_SAMPLE => 'CPANPLUS::Dist::Sample'; -use constant INSTALLER_BASE => 'CPANPLUS::Dist::Base'; +use constant INSTALLER_BASE => 'CPANPLUS::Dist::Base'; use constant INSTALLER_AUTOBUNDLE => 'CPANPLUS::Dist::Autobundle'; @@ -50,26 +50,26 @@ 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 DOT_CPANPLUS => ON_VMS ? '_cpanplus' : '.cpanplus'; use constant OPT_AUTOFLUSH => '-MCPANPLUS::Internals::Utils::Autoflush'; use constant UNKNOWN_DL_LOCATION - => 'UNKNOWN-ORIGIN'; + => 'UNKNOWN-ORIGIN'; use constant NMAKE => 'nmake.exe'; -use constant NMAKE_URL => +use constant NMAKE_URL => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe'; -use constant INSTALL_VIA_PACKAGE_MANAGER +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_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], @@ -83,48 +83,48 @@ use constant IS_CONFOBJ => sub { UNIVERSAL::isa($_[-1], 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] }; + 'CPANPLUS::Internals') }; + +use constant IS_FILE => sub { return 1 if -e $_[-1] }; -use constant FILE_EXISTS => sub { +use constant FILE_EXISTS => sub { my $file = $_[-1]; return 1 if IS_FILE->($file); - local $Carp::CarpLevel = + local $Carp::CarpLevel = $Carp::CarpLevel+2; error(loc( q[File '%1' does not exist], $file)); return; - }; + }; -use constant FILE_READABLE => sub { +use constant FILE_READABLE => sub { my $file = $_[-1]; return 1 if -e $file && -r _; - local $Carp::CarpLevel = + 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 { +use constant DIR_EXISTS => sub { my $dir = $_[-1]; return 1 if IS_DIR->($dir); - local $Carp::CarpLevel = - $Carp::CarpLevel+2; + 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 + }; + + ### 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 + (ON_VMS and $Config::Config{make} =~ /MM[S|K]/i) ? 'DESCRIP.MMS' : 'Makefile'; @@ -132,27 +132,27 @@ use constant MAKEFILE => sub { my $file = 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' ) @@ -167,41 +167,41 @@ use constant MYMETA_JSON => sub { return @_ 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 AUTO => 'auto'; use constant LIB_AUTO_DIR => sub { return @_ ? File::Spec->catdir(@_, LIB, AUTO) : File::Spec->catdir(LIB, AUTO) - }; + }; use constant ARCH => 'arch'; use constant ARCH_DIR => sub { return @_ ? File::Spec->catdir(@_, ARCH) : ARCH; - }; + }; use constant ARCH_AUTO_DIR => sub { return @_ ? File::Spec->catdir(@_,ARCH,AUTO) : File::Spec->catdir(ARCH,AUTO) - }; + }; use constant BLIB_LIBDIR => sub { return @_ ? File::Spec->catdir( @_, BLIB->(), LIB ) : File::Spec->catdir( BLIB->(), LIB ); - }; + }; -use constant CONFIG_USER_LIB_DIR => sub { +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->(), @@ -214,13 +214,13 @@ use constant CONFIG_SYSTEM_FILE => sub { my $dir = File::Basename::dirname( $INC{'CPANPLUS/Internals.pm'} ); - + ### XXX use constants - File::Spec->catfile( + File::Spec->catfile( $dir, qw[Config System.pm] ); - }; - + }; + use constant README => sub { my $obj = $_[0]; my $pkg = $obj->package_name; $pkg .= '-' . $obj->package_version . @@ -234,8 +234,8 @@ use constant META => sub { my $obj = $_[0]; $pkg .= '-' . $obj->package_version . '.' . META_EXT; return $pkg; - }; - + }; + use constant OPEN_FILE => sub { my($file, $mode) = (@_, ''); my $fh; @@ -245,23 +245,23 @@ use constant OPEN_FILE => sub { $file, $!)); return $fh if $fh; return; - }; - -use constant OPEN_DIR => sub { + }; + +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 { +use constant READ_DIR => sub { my $dir = shift; my $dh = OPEN_DIR->( $dir ) or return; - + ### exclude . and .. my @files = grep { $_ !~ /^\.{1,2}/ } readdir($dh); @@ -271,27 +271,27 @@ use constant READ_DIR => sub { if( ON_VMS ) { s/(?<!\^)\.$// for @files; } - + return @files; - }; + }; -use constant STRIP_GZ_SUFFIX +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 DEFAULT_EMAIL => 'cpanplus@example.com'; use constant CPANPLUS_UA => sub { ### for the version number ### require CPANPLUS::Internals; - "CPANPLUS/$CPANPLUS::Internals::VERSION" + "CPANPLUS/$CPANPLUS::Internals::VERSION" }; use constant TESTERS_URL => sub { 'http://cpantesters.org/distro/'. @@ -301,15 +301,15 @@ use constant TESTERS_DETAILS_URL => sub { 'http://cpantesters.org/distro/'. uc(substr($_[0],0,1)) .'/'. $_[0]; - }; + }; -use constant CREATE_FILE_URI - => sub { +use constant CREATE_FILE_URI + => sub { my $dir = $_[0] or return; - return $dir =~ m|^/| + return $dir =~ m|^/| ? 'file://' . $dir - : 'file:///' . $dir; - }; + : 'file:///' . $dir; + }; use constant EMPTY_DSLIP => ' '; @@ -318,18 +318,18 @@ use constant CUSTOM_AUTHOR_ID use constant DOT_SHELL_DEFAULT_RC => '.shell-default.rc'; - + use constant SOURCE_SQLITE_DB => 'db.sql'; -use constant PREREQ_IGNORE => 0; +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 +use constant CALLING_FUNCTION => sub { my $lvl = $_[0] || 0; - return join '::', (caller(2+$lvl))[3] + return join '::', (caller(2+$lvl))[3] }; use constant PERL_CORE => 'perl'; use constant STORABLE_EXT => '.stored'; @@ -337,45 +337,45 @@ use constant STORABLE_EXT => '.stored'; use constant GET_XS_FILES => sub { my $dir = $_[0] or return; require File::Find; my @files; - File::Find::find( + File::Find::find( sub { push @files, $File::Find::name if $File::Find::name =~ /\.xs$/i }, $dir ); - + return @files; - }; + }; -use constant INSTALL_LOG_FILE +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 +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 DOT_EXISTS => '.exists'; -use constant QUOTE_PERL_ONE_LINER +use constant QUOTE_PERL_ONE_LINER => sub { my $line = shift or return; ### use double quotes on these systems - return qq["$line"] + return qq["$line"] if ON_WIN32 || ON_NETWARE || ON_VMS; ### single quotes on the rest return qq['$line']; - }; + }; -1; +1; # Local variables: # c-indentation-style: bsd diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants/Report.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants/Report.pm index abdb3c98dd..562a5edb6b 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants/Report.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Constants/Report.pm @@ -100,7 +100,7 @@ use constant UNSUPPORTED_OS return 1; } return 0; - }; + }; use constant PERL_VERSION_TOO_LOW => sub { @@ -116,7 +116,7 @@ use constant PERL_VERSION_TOO_LOW return 1; } return 0; - }; + }; use constant NO_TESTS_DEFINED => sub { @@ -125,10 +125,10 @@ use constant NO_TESTS_DEFINED /(No tests defined( for [\w:]+ extension)?\.)/ and $buffer !~ /\*\.t/m and $buffer !~ /test\.pl/m - ) { - return $1 + ) { + return $1 } - + return; }; @@ -149,8 +149,8 @@ use constant MISSING_PREREQS_LIST my @list = map { s/.pm$//; s|/|::|g; $_ } ($last =~ m/\bCan\'t locate (\S+) in \@INC/g); - - ### make sure every missing prereq is only + + ### make sure every missing prereq is only ### listed once { my %seen; @list = grep { !$seen{$_}++ } @list @@ -162,7 +162,7 @@ use constant MISSING_PREREQS_LIST use constant MISSING_EXTLIBS_LIST => sub { my $buffer = shift; - my @list = + my @list = ($buffer =~ m/No library found for -l([-\w]+)/g); @@ -175,9 +175,9 @@ use constant REPORT_MESSAGE_HEADER return << "."; Dear $author, - + This is a computer-generated error report created automatically by -CPANPLUS, version $version. Testers personal comments may appear +CPANPLUS, version $version. Testers personal comments may appear at the end of this report. . @@ -203,12 +203,12 @@ $buffer use constant REPORT_MISSING_PREREQS => sub { my ($author,$email,@missing) = @_; - $author = ($author && $email) - ? "$author ($email)" + $author = ($author && $email) + ? "$author ($email)" : 'Your Name Here'; - + my $modules = join "\n", @missing; - my $prereqs = join "\n", + my $prereqs = join "\n", map {"\t'$_'\t=> '0',". " # or a minimum working version"} @missing; @@ -242,7 +242,7 @@ use constant REPORT_MISSING_TESTS return << "."; RECOMMENDATIONS: -It would be very helpful if you could include even a simple test +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? @@ -266,7 +266,7 @@ Thanks! :-) . }; -use constant REPORT_LOADED_PREREQS +use constant REPORT_LOADED_PREREQS => sub { my $mod = shift; my $cb = $mod->parent; @@ -274,13 +274,13 @@ use constant REPORT_LOADED_PREREQS ### not every prereq may be coming from CPAN ### so maybe we wont find it in our module - ### tree at all... + ### 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; @@ -288,27 +288,27 @@ use constant REPORT_LOADED_PREREQS my $str = << "."; PREREQUISITES: -Here is a list of prerequisites you specified and versions we +Here is a list of prerequisites you specified and versions we managed to load: - + . - $str .= join '', - map { sprintf "\t%s %-30s %8s %8s\n", + $str .= join '', + map { sprintf "\t%s %-30s %8s %8s\n", @$_ - + } [' ', 'Module Name', 'Have', 'Want'], map { my $want = $prq->{$_->name}; - [ do { $_->is_uptodate( + [ do { $_->is_uptodate( version => $want - ) ? ' ' : '!' + ) ? ' ' : '!' }, $_->name, $_->installed_version, $want ], ### might be empty entries in there - } grep { $_ } @prq; - + } grep { $_ } @prq; + return $str; }; @@ -348,23 +348,23 @@ use constant REPORT_TOOLCHAIN_VERSIONS Perl module toolchain versions installed: . - $str .= join '', - map { sprintf "\t%-30s %8s\n", + $str .= join '', + map { sprintf "\t%-30s %8s\n", @$_ - + } ['Module Name', 'Have'], map { [ $_->name, $_->installed_version, ], ### might be empty entries in there - } @toolchain; - + } @toolchain; + return $str; }; -use constant REPORT_TESTS_SKIPPED +use constant REPORT_TESTS_SKIPPED => sub { return << "."; @@ -376,7 +376,7 @@ use constant REPORT_TESTS_SKIPPED . }; - + use constant REPORT_MESSAGE_FOOTER => sub { return << "."; @@ -384,7 +384,7 @@ use constant REPORT_MESSAGE_FOOTER ******************************** 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 +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 @@ -393,7 +393,7 @@ it personally. We appreciate your patience. :) ********************************************************************** Additional comments: - + . }; diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Extract.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Extract.pm index f30911bab8..5447a5f333 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Extract.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Extract.pm @@ -25,15 +25,15 @@ CPANPLUS::Internals::Extract ### for source files ### $self->_gunzip( file => 'foo.gz', output => 'blah.txt' ); - + ### for modules/packages ### - $dir = $self->_extract( module => $modobj, + $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 +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>. @@ -47,7 +47,7 @@ The flow looks like this: =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 +if provided, or the default location which is obtained from your config. The file name is obtained by looking at C<< $modobj->status->fetch >> @@ -67,7 +67,7 @@ A C<CPANPLUS::Module> object. This is required. =item extractdir -The directory to extract the archive to. By default this looks +The directory to extract the archive to. By default this looks something like: /CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME @@ -105,26 +105,26 @@ 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'), + force => { default => $conf->get_conf('force'), store => \$force }, - verbose => { default => $conf->get_conf('verbose'), + 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", @@ -135,7 +135,7 @@ sub _extract { ### did we already fetch the file? ### my $file = $mod->status->fetch(); unless( -s $file ) { - error( loc( "File '%1' has zero size: cannot extract", $file ) ); + error( loc( "File '%1' has zero size: cannot extract", $file ) ); return; } @@ -146,7 +146,7 @@ sub _extract { $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'}; @@ -160,7 +160,7 @@ sub _extract { $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 ) { @@ -168,65 +168,65 @@ sub _extract { "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}; - + 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} ) { + + 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 '.' + ### 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, + ### 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 + 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 ) , + File::Spec->catdir( $self->_safe_path( path => $to ) , $self->_safe_path( path => - $mod->package_name .'-'. + $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 { + + } 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->extract( $dir ); $mod->status->files( $ae->files ); } - + ### also, figure out what kind of install we're dealing with ### $mod->get_installer_type(); diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Fetch.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Fetch.pm index 7dcb3c366b..b36eab5532 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Fetch.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Fetch.pm @@ -148,62 +148,62 @@ sub _fetch { ### 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, + + ### 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 + ### 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 ); @@ -222,18 +222,18 @@ sub _fetch { 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 + ### 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'); @@ -242,41 +242,41 @@ sub _fetch { 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' ) { - + if( $host->{'scheme'} eq 'file' ) { + ### the full path in the native format of the OS - my $host_spec = + 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 + + ### 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' + $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 + + ### 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:// @@ -284,89 +284,89 @@ sub _fetch { ### 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_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 ); + $host_spec = File::Spec::Unix->catdir( @host_dirs ); } - ### now create the file:// uri from the components + ### 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 { + } 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, + + my $abs = $self->__file_fetch( from => $where, to => $local_path, - verbose => $verbose ); - + 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 + ### 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; } @@ -382,7 +382,7 @@ sub __file_fetch { verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, }; - + check( $tmpl, \%hash ) or return; msg(loc("Trying to get '%1'", $where ), $verbose ); @@ -400,10 +400,10 @@ sub __file_fetch { } else { my $abs = File::Spec->rel2abs( $file ); - + ### so TTLs will work $self->_update_timestamp( file => $abs ); - + return $abs; } diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Search.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Search.pm index a93626b618..e10e66b09b 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Search.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Search.pm @@ -163,7 +163,7 @@ sub _search_module_tree { } or return; ### a list of module objects was supplied - if( @$mods ) { + if( @$mods ) { local $Params::Check::VERBOSE = 0; my @rv; @@ -242,7 +242,7 @@ sub _search_author_tree { my $args = check( $tmpl, \%hash ) or return; - if( @$authors ) { + if( @$authors ) { local $Params::Check::VERBOSE = 0; my @rv; @@ -258,7 +258,7 @@ sub _search_author_tree { my @rv = $self->_source_search_author_tree( allow => $list, type => $type, - ); + ); return \@rv; } } @@ -302,18 +302,18 @@ sub _all_installed { for my $dir (@INC ) { next if $dir eq '.'; - ### not a directory after all + ### 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 + + ### 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'; @@ -328,15 +328,15 @@ sub _all_installed { ### 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 = 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; diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source.pm index 9637004625..342df63d51 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source.pm @@ -21,22 +21,22 @@ use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; $Params::Check::VERBOSE = 1; ### list of methods the parent class must implement -{ for my $sub ( qw[_init_trees _finalize_trees +{ 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 { + *$sub = sub { my $self = shift; my $class = ref $self || $self; - - require Carp; - Carp::croak( loc( "Class %1 must implement method '%2'", + + require Carp; + Carp::croak( loc( "Class %1 must implement method '%2'", $class, $sub ) ); } } -} +} { my $recurse; # flag to prevent recursive calls to *_tree functions @@ -98,14 +98,14 @@ The flow looks like this: $cb->_check_trees $cb->__check_uptodate $cb->_update_source - $cb->__update_custom_module_sources + $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 } @@ -113,7 +113,7 @@ The flow looks like this: $cb->__create_dslip_tree ### engine methods { $cb->_add_module_object } - $cb->__create_custom_module_entries + $cb->__create_custom_module_entries $cb->_dslip_defs @@ -177,43 +177,43 @@ sub _build_trees { ) 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, + verbose => $verbose, ) or return; ### and now the module tree $self->_create_mod_tree( uptodate => $uptodate, path => $path, - verbose => $verbose, + 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 + ### 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 ) + $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') ) { @@ -226,13 +226,13 @@ sub _build_trees { $self->_finalize_trees( path => $path, uptodate => $uptodate, - verbose => $verbose, + 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 ); @@ -320,7 +320,7 @@ sub _check_trees { ### 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 ) + $self->__update_custom_module_sources( verbose => $verbose ) if $conf->get_conf('enable_custom_sources') and ( $update_source or !$uptodate ); return $uptodate; @@ -389,7 +389,7 @@ sub __check_uptodate { 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 + 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} ); @@ -647,11 +647,11 @@ sub _create_mod_tree { return; } $past_header = 1; - } - + } + ### we're still in the header -- find the amount of lines we expect unless( $past_header ) { - + ### if the line count doesn't match what we expect, bail out ### this should address: #45644: detect broken index $count = $1 if /^Line-Count:\s+(\d+)/; @@ -661,12 +661,12 @@ sub _create_mod_tree { "contains only %3 lines!", $count, $file, $lines )); return; - } + } } ### still in the header, keep moving next; } - + ### skip empty lines ### next unless /\S/; chomp; @@ -704,7 +704,7 @@ sub _create_mod_tree { ? $dslip_tree->{ $data[0] }->{$item} : ' '; } - + ### XXX this could be sped up if we used author names, not author ### objects in creation, and then look them up in the author tree ### when needed. This will need a fix to all the places that create @@ -713,9 +713,9 @@ sub _create_mod_tree { ### 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]), + version => ($data[1] eq 'undef' # version number + ? '0.0' + : $data[1]), path => File::Spec::Unix->catfile( $conf->_get_mirror('base'), $data[2], @@ -925,7 +925,7 @@ sub _dslip_defs { return $aref; } -=head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] ); +=head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] ); Adds a custom source index and updates it based on the provided URI. @@ -937,16 +937,16 @@ sub _add_custom_module_source { my $self = shift; my $conf = $self->configure_object; my %hash = @_; - + my($verbose,$uri); - my $tmpl = { + 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 ); @@ -954,29 +954,29 @@ sub _add_custom_module_source { if( IS_FILE->( $index ) ) { msg(loc("Source '%1' already added", $uri)); return 1; - } - - ### do we need to create the targe dir? + } + + ### 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 + + ### 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, @@ -985,9 +985,9 @@ sub _add_custom_module_source { ### we faild to update it, we probably have an empty ### possibly silly filename on disk now -- remove it 1 while unlink $index; - return; + return; }; - + return $index; } @@ -1002,24 +1002,24 @@ sub __custom_module_source_index_file { my $self = shift; my $conf = $self->configure_object; my %hash = @_; - + my($verbose,$uri); - my $tmpl = { + 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'), + $conf->_get_build('custom_sources'), $self->_uri_encode( uri => $uri ), - ); + ); return $index; } -=head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] ); +=head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] ); Removes a custom index file based on the URI provided. @@ -1031,19 +1031,19 @@ sub _remove_custom_module_source { my $self = shift; my $conf = $self->configure_object; my %hash = @_; - + my($verbose,$uri); - my $tmpl = { + 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 }; @@ -1053,15 +1053,15 @@ sub _remove_custom_module_source { 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; @@ -1081,12 +1081,12 @@ Returns a list of key value pairs as follows: sub __list_custom_module_sources { my $self = shift; my $conf = $self->configure_object; - + my($verbose); - my $tmpl = { + my $tmpl = { verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, - }; + }; my $dir = File::Spec->catdir( $conf->get_conf('base'), @@ -1097,16 +1097,16 @@ sub __list_custom_module_sources { 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 => $_ ); + my %files = map { + my $org = $_; + my $dec = $self->_uri_decode( uri => $_ ); File::Spec->catfile( $dir, $org ) => $dec - } grep { $_ !~ /^#/ } READ_DIR->( $dir ); + } grep { $_ !~ /^#/ } READ_DIR->( $dir ); - return %files; + return %files; } =head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] ); @@ -1124,35 +1124,35 @@ sub __update_custom_module_sources { my $self = shift; my $conf = $self->configure_object; my %hash = @_; - + my $verbose; - my $tmpl = { + 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. + + ### 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 ); + ) 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 +=head2 $ok = $cb->__update_custom_module_source Attempts to update all the index files to your custom module sources. @@ -1167,9 +1167,9 @@ sub __update_custom_module_source { my $self = shift; my $conf = $self->configure_object; my %hash = @_; - + my($verbose,$local,$remote); - my $tmpl = { + my $tmpl = { verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, local => { store => \$local, allow => FILE_EXISTS }, @@ -1179,7 +1179,7 @@ sub __update_custom_module_source { 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 { @@ -1187,7 +1187,7 @@ sub __update_custom_module_source { my %files = reverse $self->__list_custom_module_sources or do { error(loc("No custom modules sources defined -- need '%1' argument", 'local')); - return; + return; }; ### On VMS the case of key to %files can be either exact or lower case @@ -1200,16 +1200,16 @@ sub __update_custom_module_source { 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 ); + my $ff = File::Fetch->new( uri => $uri ); ### tempdir doesn't clean up by default, as opposed to tempfile() ### so add it explicitly. my $dir = tempdir( CLEANUP => 1 ); - + my $res = do { local $File::Fetch::WARN = 0; local $File::Fetch::WARN = 0; $ff->fetch( to => $dir ); @@ -1217,51 +1217,51 @@ sub __update_custom_module_source { ### 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; - + 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 { + } 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 +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. @@ -1273,29 +1273,29 @@ sub __write_custom_module_index { my $self = shift; my $conf = $self->configure_object; my %hash = @_; - + my ($verbose, $path, $to); - my $tmpl = { + 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; + + 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 { + 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; + 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; @@ -1305,11 +1305,11 @@ sub __write_custom_module_index { ### 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); + my $re = quotemeta($path); $copy =~ s|^$re[\\/]?||i; - + push @files, $copy; - + }, $path ); ### does the dir exist? if not, create it. @@ -1317,80 +1317,80 @@ sub __write_custom_module_index { 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] ) +=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 +=cut ### use $auth_obj as a persistent version, so we don't have to recreate ### modules all the time -{ my $auth_obj; +{ 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; - + + 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 ); + $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 ) ) { @@ -1401,15 +1401,15 @@ Returns true on success, false on failure. 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; } } diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/Memory.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/Memory.pm index cb3fd4f1e7..d589bbd1d8 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/Memory.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/Memory.pm @@ -22,7 +22,7 @@ use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; $Params::Check::VERBOSE = 1; -=head1 NAME +=head1 NAME CPANPLUS::Internals::Source::Memory - In memory implementation @@ -36,7 +36,7 @@ CPANPLUS::Internals::Source::Memory - In memory implementation 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 }, @@ -44,21 +44,21 @@ CPANPLUS::Internals::Source::Memory - In memory implementation 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->_atree( $stored->{_atree} || {} ); $self->_mtree( $stored->{_mtree} || {} ); return 1; @@ -71,7 +71,7 @@ CPANPLUS::Internals::Source::Memory - In memory implementation my $self = shift; my $conf = $self->configure_object; my %hash = @_; - + my($path,$uptodate,$verbose); my $tmpl = { path => { default => $conf->get_conf('base'), store => \$path }, @@ -79,34 +79,34 @@ CPANPLUS::Internals::Source::Memory - In memory implementation uptodate => { required => 1, store => \$uptodate }, }; - { local $Params::Check::ALLOW_UNKNOWN = 1; + { 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 } } + map { $_ => { required => 1 } } qw[ author cpanid email ] }; @@ -114,9 +114,9 @@ sub _add_author_object { 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; @@ -126,10 +126,10 @@ sub _add_module_object { my $self = shift; my %hash = @_; - my $class; + my $class; my $tmpl = { class => { default => 'CPANPLUS::Module', store => \$class }, - map { $_ => { required => 1 } } + map { $_ => { required => 1 } } qw[ module version path comment author package description dslip mtime ] }; @@ -137,30 +137,30 @@ sub _add_module_object { local $Params::Check::NO_DUPLICATES = 1; check( $tmpl, \%hash ) or return; }; - + my $obj = $class->new( %$href, _id => $self->_id ); - + ### Every module get's stored as a module object ### $self->module_tree->{ $href->{module} } = $obj or return; - return $obj; + 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 => [], @@ -172,9 +172,9 @@ sub _add_module_object { type => { required => 1, allow => [$class->accessors()], store => \$type }, }; - - my $args = check( $tmpl, \%hash ) or return; - + + my $args = check( $tmpl, \%hash ) or return; + my @rv; for my $obj ( values %{ $self->$meth } ) { #push @rv, $auth if check( @@ -182,8 +182,8 @@ sub _add_module_object { # { $type => $auth->$type } # ); push @rv, $obj if allow( $obj->$type() => $list ); - } - + } + return @rv; } } @@ -343,7 +343,7 @@ sub __memory_storable_file { : 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( @@ -351,7 +351,7 @@ sub __memory_storable_file { $path, #base dir $conf->_get_source('stored') #file . '.s' . - $Storable::VERSION #the version of storable + $Storable::VERSION #the version of storable . '.c' . $self->VERSION #the version of CPANPLUS . STORABLE_EXT #append a suffix diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/SQLite.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/SQLite.pm index 556be6456d..47bdbebfd7 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/SQLite.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/SQLite.pm @@ -18,7 +18,7 @@ use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use constant TXN_COMMIT => 1000; -=head1 NAME +=head1 NAME CPANPLUS::Internals::Source::SQLite - SQLite implementation @@ -27,23 +27,23 @@ CPANPLUS::Internals::Source::SQLite - SQLite implementation { my $Dbh; my $DbFile; - sub __sqlite_file { + sub __sqlite_file { return $DbFile if $DbFile; my $self = shift; my $conf = $self->configure_object; - $DbFile = File::Spec->catdir( + $DbFile = File::Spec->catdir( $conf->get_conf('base'), SOURCE_SQLITE_DB ); - + return $DbFile; }; - sub __sqlite_dbh { + sub __sqlite_dbh { return $Dbh if $Dbh; - + my $self = shift; $Dbh = DBIx::Simple->connect( "dbi:SQLite:dbname=" . $self->__sqlite_file, @@ -53,7 +53,7 @@ CPANPLUS::Internals::Source::SQLite - SQLite implementation #$Dbh->dbh->trace(1); $Dbh->query(qq{PRAGMA synchronous = OFF}); - return $Dbh; + return $Dbh; }; sub __sqlite_disconnect { @@ -70,7 +70,7 @@ CPANPLUS::Internals::Source::SQLite - SQLite implementation 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 }, @@ -78,60 +78,60 @@ CPANPLUS::Internals::Source::SQLite - SQLite implementation 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 ) { + 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; - } + 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', + 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', + dbh => $self->__sqlite_dbh, table => 'module', key => 'module', cb => $self; $self->_mtree( \%mt ); } - + ### start a transaction $self->__sqlite_dbh->query('BEGIN'); - - return 1; - + + 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__)); + sub _save_state { + error(loc("%1 has not implemented writing state to disk", __PACKAGE__)); return; } } @@ -145,7 +145,7 @@ CPANPLUS::Internals::Source::SQLite - SQLite implementation 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; @@ -154,9 +154,9 @@ CPANPLUS::Internals::Source::SQLite - SQLite implementation my $self = shift; my %hash = @_; my $dbh = $self->__sqlite_dbh; - + my $href = do { - local $Params::Check::NO_DUPLICATES = 1; + local $Params::Check::NO_DUPLICATES = 1; local $Params::Check::SANITY_CHECK_TEMPLATE = 0; check( $tmpl, \%hash ) or return; }; @@ -167,15 +167,15 @@ CPANPLUS::Internals::Source::SQLite - SQLite implementation $dbh->commit or error( $dbh->error ); # commit previous transaction $dbh->begin_work or error( $dbh->error ); # and start a new one } - - $dbh->query( + + $dbh->query( "INSERT INTO author (". join(',',keys(%$href)) .") VALUES ($ph)", values %$href ) or do { error( $dbh->error ); return; }; - + return 1; } } @@ -183,13 +183,13 @@ CPANPLUS::Internals::Source::SQLite - SQLite implementation { my $txn_count = 0; ### XXX move this outside the sub, so we only compute it once - my $class; + 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; @@ -197,13 +197,13 @@ CPANPLUS::Internals::Source::SQLite - SQLite implementation 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; @@ -213,35 +213,35 @@ CPANPLUS::Internals::Source::SQLite - SQLite implementation $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)", + + $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 + _source_search_module_tree => [ module => module => 'CPANPLUS::Module' ], - _source_search_author_tree + _source_search_author_tree => [ author => cpanid => 'CPANPLUS::Module::Author' ], - ); + ); while( my($sub, $aref) = each %map ) { no strict 'refs'; - + my($table, $key, $class) = @$aref; *$sub = sub { my $self = shift; my %hash = @_; my $dbh = $self->__sqlite_dbh; - + my($list,$type); my $tmpl = { allow => { required => 1, default => [ ], strict_type => 1, @@ -249,19 +249,19 @@ CPANPLUS::Internals::Source::SQLite - SQLite implementation type => { required => 1, allow => [$class->accessors()], store => \$type }, }; - + check( $tmpl, \%hash ) or return; - - + + ### we aliased 'module' to 'name', so change that here too $type = 'module' if $type eq 'name'; - + my $res = $dbh->query( "SELECT * from $table" ); - + my $meth = $table .'_tree'; - my @rv = map { $self->$meth( $_->{$key} ) } + my @rv = map { $self->$meth( $_->{$key} ) } grep { allow( $_->{$type} => $list ) } $res->hashes; - + return @rv; } } @@ -272,29 +272,29 @@ CPANPLUS::Internals::Source::SQLite - SQLite implementation sub __sqlite_create_db { my $self = shift; my $dbh = $self->__sqlite_dbh; - + ### we can ignore the result/error; not all sqlite implementations - ### support this + ### 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) @@ -310,7 +310,7 @@ sub __sqlite_create_db { /* the module information */ CREATE TABLE module ( id INTEGER PRIMARY KEY AUTOINCREMENT, - + module varchar(255), version varchar(255), path varchar(255), @@ -321,13 +321,13 @@ sub __sqlite_create_db { dslip varchar(255), mtime varchar(255) ); - + \n] ) or do { error( $dbh->error ); return; - }; + }; $dbh->query( qq[ /* the module index */ @@ -368,7 +368,7 @@ sub __sqlite_create_db { return; }; - return 1; + 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 index f908c9803e..7208e00ee1 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm @@ -26,7 +26,7 @@ push @ISA, 'Tie::StdHash'; sub TIEHASH { my $class = shift; my %hash = @_; - + my $tmpl = { dbh => { required => 1 }, table => { required => 1 }, @@ -34,12 +34,12 @@ sub TIEHASH { 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; @@ -47,28 +47,28 @@ sub FETCH { 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' ) { @@ -80,16 +80,16 @@ sub FETCH { author => 'CPANPLUS::Module::Author', }->{ $table }; - my $obj = $self->{store}->{$key} = $class->new( %$href, _id => $cb->_id ); - + my $obj = $self->{store}->{$key} = $class->new( %$href, _id => $cb->_id ); + return $obj; } -sub STORE { +sub STORE { my $self = shift; my $key = shift; my $val = shift; - + $self->{store}->{$key} = $val; } @@ -104,7 +104,7 @@ sub FIRSTKEY { ); $self->{offset} = 0; - + my $key = $res->flat->[0]; return $key; @@ -130,7 +130,7 @@ sub NEXTKEY { sub EXISTS { !!$_[0]->FETCH( $_[1] ) } -sub SCALAR { +sub SCALAR { my $self = shift; my $dbh = $self->{'dbh'}; diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Utils.pm b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Utils.pm index 31abaffed4..46ddec858e 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Internals/Utils.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Internals/Utils.pm @@ -59,7 +59,7 @@ sub _mkdir { 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!") ); @@ -162,20 +162,20 @@ sub _perl_version { }; 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 + ### 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; } @@ -282,7 +282,7 @@ Returns true on success, false on failure. sub _copy { my $self = shift; my %hash = @_; - + my($from,$to); my $tmpl = { file =>{ required => 1, allow => [IS_FILE,IS_DIR], @@ -311,28 +311,28 @@ Returns true on success, false on failure. 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 { + } else { error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!)); return; } -} +} =head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH ); @@ -345,23 +345,23 @@ Returns the uri on success, and false on failure 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) + ? VMS::Filespec::unixify($path) : File::Spec::Unix->catdir( File::Spec->splitdir( $path ) ); - return "$scheme://" . File::Spec::Unix->catdir( $host, $path ); + return "$scheme://" . File::Spec::Unix->catdir( $host, $path ); } =head2 $cb->_vcmp( VERSION, VERSION ); @@ -373,7 +373,7 @@ Normalizes the versions passed and does a '<=>' on them, returning the result. sub _vcmp { my $self = shift; my ($x, $y) = @_; - + s/_//g foreach $x, $y; return $x <=> $y; @@ -399,7 +399,7 @@ sub _home_dir { =head2 $path = $cb->_safe_path( path => $path ); -Returns a path that's safe to us on Win32 and VMS. +Returns a path that's safe to us on Win32 and VMS. Only cleans up the path on Win32 if the path exists. @@ -409,36 +409,36 @@ On VMS, it encodes dots to _ using C<VMS::Filespec::vmsify> 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 + ### 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 + ### 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 + ### 1. Make sure that the value to be converted, $path is ### in UNIX directory syntax by appending a '/' to it. $path .= '/' unless $path =~ m|/$|; @@ -448,17 +448,17 @@ sub _safe_path { ### filename translation, as filename translation leaves one dot. $path = VMS::Filespec::vmsify( $path ); - ### 3. Use $path = File::Spec->splitdir( VMS::Filespec::vmsify( + ### 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. + ### 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() + ### 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() @@ -469,14 +469,14 @@ sub _safe_path { ### 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 +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: @@ -488,27 +488,27 @@ For example, C<Foo-Bar-1.2.tar.gz> would return the following parts: =cut { my $del_re = qr/[-_\+]/i; # delimiter between elements - my $pkg_re = qr/[a-z] # any letters followed by + 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 + [a-z] # any letters followed by + [a-z\d]* # any letters, numbers (?i:\.pm)? # followed by '.pm'--authors do this :( )* - /xi; - + /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 @@ -521,20 +521,20 @@ For example, C<Foo-Bar-1.2.tar.gz> would return the following parts: ($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/ @@ -546,97 +546,97 @@ For example, C<Foo-Bar-1.2.tar.gz> would return the following parts: )? ) $ - /xi; + /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, + + + ### 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 $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; - + } 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; + + 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; + $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 @@ -646,7 +646,7 @@ sub _update_timestamp { error( loc("Couldn't touch %1", $file) ); return; } - + return 1; } diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Module.pm b/cpan/CPANPLUS/lib/CPANPLUS/Module.pm index 8d237efc05..c815d28b03 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Module.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Module.pm @@ -87,9 +87,9 @@ my $tmpl = { ### 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}; @@ -153,7 +153,7 @@ module -- again, only registered modules have this. =cut sub dslip { - my $self = shift; + my $self = shift; ### if this module has relevant dslip info, return it return $self->_dslip if $self->_dslip ne EMPTY_DSLIP; @@ -163,7 +163,7 @@ sub dslip { 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; } @@ -334,7 +334,7 @@ sub new { 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 @@ -395,19 +395,19 @@ 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 >>. +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 +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 +module. See the documentation about C<module_information()> in L<Module::ThirdParty> for more details. =cut @@ -417,22 +417,22 @@ L<Module::ThirdParty> for more details. 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; @@ -441,8 +441,8 @@ L<Module::ThirdParty> for more details. ### 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 + ### 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; @@ -450,10 +450,10 @@ L<Module::ThirdParty> for more details. 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, + + ### if the package is newer or equal to the corelist, ### then it's dual-lifed - return if $cb->_vcmp( $self->version, $core ) >= 0; + return if $cb->_vcmp( $self->version, $core ) >= 0; ### otherwise, it's older than corelist, thus unsuitable. return 1; @@ -475,9 +475,9 @@ L<Module::ThirdParty> for more details. ### 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 + + ### 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. @@ -493,13 +493,13 @@ L<Module::ThirdParty> for more details. ### 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; } @@ -516,16 +516,16 @@ L<Module::ThirdParty> for more details. 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 unless $self->is_third_party; return Module::ThirdParty::module_information( $self->name ); } @@ -543,15 +543,15 @@ a fake C<CPANPLUS::Module::Author> object. { ### 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; } } @@ -574,13 +574,13 @@ sub fetch { my %args = ( module => $self ); ### if a custom fetch location got specified before, add that here - $args{fetch_from} = $self->status->_fetch_from + $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 + if( !$self->status->_fetch_from and $cb->configure_object->get_conf('md5') and $self->package ne CHECKSUMS ) { @@ -613,16 +613,16 @@ sub 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 ); } @@ -649,16 +649,16 @@ sub get_installer_type { prefer_makefile => { default => $conf->get_conf('prefer_makefile'), store => \$prefer_makefile, allow => BOOLEANS }, verbose => { default => $conf->get_conf('verbose'), - store => \$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; + $type = INSTALLER_AUTOBUNDLE; } else { my $extract = $self->status->extract(); @@ -669,11 +669,11 @@ sub get_installer_type { )); 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; @@ -687,20 +687,20 @@ sub get_installer_type { or not $cb->module_tree( INSTALLER_BUILD ) ->is_uptodate( version => '0.24' ) ) ) { - + ### 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.24', %$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 ); + ), $verbose ); ### ok, actually we found neither ### @@ -747,7 +747,7 @@ sub dist { format => { default => $conf->get_conf('dist_type') || $self->status->installer_type, store => \$type }, - target => { default => TARGET_CREATE, store => \$target }, + target => { default => TARGET_CREATE, store => \$target }, args => { default => {}, store => \$args }, }; @@ -761,20 +761,20 @@ sub dist { ### 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; + 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)); @@ -782,40 +782,40 @@ sub dist { } 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 + ### make sure we don't overwrite it, just in case we came ### back from a ->save_state. This allows restoration to - ### work correctly + ### 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->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); @@ -834,7 +834,7 @@ sub dist { =head2 $bool = $mod->prepare( ) -Convenience method around C<install()> that prepares a module +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> @@ -842,22 +842,22 @@ Returns true on success, false on failure. =cut -sub prepare { +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 +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 { +sub create { my $self = shift; return $self->install( @_, target => TARGET_CREATE ); } @@ -923,7 +923,7 @@ sub install { } - ### if this target isn't 'install', we will need to at least 'create' + ### 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. @@ -964,7 +964,7 @@ sub install { $self->version, $self->package ) ); } return; - + ### it might be a known 3rd party module } elsif ( $self->is_third_party ) { my $info = $self->third_party_information; @@ -978,7 +978,7 @@ sub install { $self->name, $self->name, $info->{name}, $info->{author}, $info->{url} )); - + return; } @@ -1028,10 +1028,10 @@ sub install { "-- 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( + $cb->_send_report( module => $self, failed => 1, buffer => CPANPLUS::Error->stack_as_string, @@ -1039,8 +1039,8 @@ sub install { force => $args->{force}, ) or error(loc("Failed to send test report for '%1'", $self->module ) ); - } - + } + return; } else { @@ -1065,8 +1065,8 @@ sub install { } } - my $dist = $self->dist( format => $format, - target => $target, + my $dist = $self->dist( format => $format, + target => $target, args => $args ); unless( $dist ) { error( loc( "Unable to create a new distribution object for '%1' " . @@ -1105,7 +1105,7 @@ sub bundle_modules { } my @files; - + ### autobundles are special files generated by CPANPLUS. If we can ### read the file, we can determine the prereqs if( $self->is_autobundle ) { @@ -1114,11 +1114,11 @@ sub bundle_modules { error(loc("Don't know where '%1' was fetched to", $self->package)); return; } - + push @files, $where - + ### regular bundle::* upload - } else { + } else { my $dir; unless( $dir = $self->status->extract ) { error(loc("Don't know where '%1' was extracted to", $self->module)); @@ -1188,7 +1188,7 @@ success and returns false on failure. sub readme { my $self = shift; - my $conf = $self->parent->configure_object; + my $conf = $self->parent->configure_object; ### did we already dl the readme once? ### return $self->status->readme() if $self->status->readme(); @@ -1207,10 +1207,10 @@ sub readme { 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 ); @@ -1275,7 +1275,7 @@ Returns a boolean indicating if this module is uptodate or not. #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 @@ -1349,7 +1349,7 @@ sub details { =head2 @list = $self->contains() -Returns a list of module objects that represent the modules also +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: @@ -1366,7 +1366,7 @@ sub contains { my $pkg = $self->package; my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] ); - + return @mods; } @@ -1491,10 +1491,10 @@ sub uninstall { # 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, @@ -1619,19 +1619,19 @@ sub _extutils_installed { 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 + ### 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 + ### /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 @@ -1641,7 +1641,7 @@ sub _extutils_installed { ### /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; @@ -1653,15 +1653,15 @@ sub _extutils_installed { ### 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; + my $inst; unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) { error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) ); @@ -1694,15 +1694,15 @@ You can reset C<@INC> and C<$PERL5LIB> to its 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), @@ -1710,7 +1710,7 @@ sub add_to_includepath { BLIB->($dir), ] ) or return; - + } else { error(loc( "No extract dir registered for '%1' -- can not add ". "add builddir to search path!", $self->module )); @@ -1769,7 +1769,7 @@ sub best_path_to_module_build { # 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 @@ -1798,10 +1798,10 @@ 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) +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 +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/Module/Author.pm b/cpan/CPANPLUS/lib/CPANPLUS/Module/Author.pm index 0daac6716d..f466f02558 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Module/Author.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Module/Author.pm @@ -195,7 +195,7 @@ sub distributions { 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 diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Module/Author/Fake.pm b/cpan/CPANPLUS/lib/CPANPLUS/Module/Author/Fake.pm index 3156c5c7ab..f0d37818de 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Module/Author/Fake.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Module/Author/Fake.pm @@ -63,7 +63,7 @@ sub new { unless( $obj->_id ) { error(loc("No '%1' specified -- No CPANPLUS object associated!",'_id')); return; - } + } ### rebless object ### return bless $obj, $class; diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Module/Checksums.pm b/cpan/CPANPLUS/lib/CPANPLUS/Module/Checksums.pm index 3f9561e2df..55d6258853 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Module/Checksums.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Module/Checksums.pm @@ -28,7 +28,7 @@ CPANPLUS::Module::Checksums =head1 DESCRIPTION -This is a class that provides functions for checking the checksum +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>. @@ -102,7 +102,7 @@ sub _validate_checksum { } else { msg(loc("Archive size is not known for '%1'",$self->package),$verbose); } - + my $sha = $href->{ $self->package }->{'sha256'}; unless( defined $sha ) { diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Module/Fake.pm b/cpan/CPANPLUS/lib/CPANPLUS/Module/Fake.pm index 84d0233cf8..e6338e1bd6 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Module/Fake.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Module/Fake.pm @@ -49,9 +49,9 @@ are required. sub new { my $class = shift; my %hash = @_; - + local $Params::Check::ALLOW_UNKNOWN = 1; - + my $tmpl = { module => { required => 1 }, path => { required => 1 }, @@ -59,22 +59,22 @@ sub new { _id => { default => CPANPLUS::Internals->_last_id }, author => { default => '' }, }; - + my $args = check( $tmpl, \%hash ) or return; - - $args->{author} ||= CPANPLUS::Module::Author::Fake->new( + + $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; -} + return bless $obj, $class; +} 1; @@ -83,4 +83,4 @@ sub new { # c-basic-offset: 4 # indent-tabs-mode: nil # End: -# vim: expandtab shiftwidth=4: +# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Selfupdate.pm b/cpan/CPANPLUS/lib/CPANPLUS/Selfupdate.pm index 6f2015c504..963f8ba09e 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Selfupdate.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Selfupdate.pm @@ -18,20 +18,20 @@ CPANPLUS::Selfupdate =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!" + print "Installed version is not uptodate!" unless $_->is_installed_version_sufficient; } - + $ok = $su->selfupdate( update => 'all', latest => 0 ); =cut @@ -50,7 +50,7 @@ CPANPLUS::Selfupdate 'Module::Load::Conditional' => '0.38', # returns dir for loaded # modules 'version' => '0.73', # needed for M::L::C - # addresses #24630 and + # addresses #24630 and # #24675 # Address ~0 overflow issue 'Params::Check' => '0.22', @@ -68,10 +68,10 @@ CPANPLUS::Selfupdate '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' ) + ( check_install( module => 'CPANPLUS::Dist::Build' ) ? ( 'CPANPLUS::Dist::Build' => '0.24' ) : () ), }, - + features => { # config_key_name => [ # sub { } to list module key/value pairs @@ -80,29 +80,29 @@ CPANPLUS::Selfupdate prefer_makefile => [ sub { my $cb = shift; - $cb->configure_object->get_conf('prefer_makefile') + $cb->configure_object->get_conf('prefer_makefile') ? { } : { 'CPANPLUS::Dist::Build' => '0.24' }; }, sub { return 1 }, # always enabled - ], + ], cpantest => [ { 'Test::Reporter' => '1.34', 'Parse::CPAN::Meta' => '1.4200' }, - sub { + sub { my $cb = shift; return $cb->configure_object->get_conf('cpantest'); }, - ], + ], dist_type => [ - sub { + sub { my $cb = shift; my $dist = $cb->configure_object->get_conf('dist_type'); return { $dist => '0.0' } if $dist; return; - }, - sub { + }, + sub { my $cb = shift; return $cb->configure_object->get_conf('dist_type'); }, @@ -111,17 +111,17 @@ CPANPLUS::Selfupdate md5 => [ { 'Digest::SHA' => '0.0', - }, - sub { + }, + sub { my $cb = shift; return $cb->configure_object->get_conf('md5'); }, ], shell => [ - sub { + 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). @@ -130,9 +130,9 @@ CPANPLUS::Selfupdate 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; @@ -146,19 +146,19 @@ CPANPLUS::Selfupdate ### this change due to this ticket: #26914 # and $cb->configure_object->get_conf('prefer_bin'); - return { - 'Crypt::OpenPGP' => '0.0', + 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 { + { 'Storable' => '0.0' }, + sub { my $cb = shift; return $cb->configure_object->get_conf('storable'); }, @@ -170,10 +170,10 @@ CPANPLUS::Selfupdate sub { my $cb = shift; my $conf = $cb->configure_object; - return $conf->get_conf('source_engine') + return $conf->get_conf('source_engine') eq 'CPANPLUS::Internals::Source::SQLite' - }, - ], + }, + ], }, core => { 'CPANPLUS' => '0.0', @@ -196,35 +196,35 @@ sub new { my $class = shift; my $cb = shift or return; return bless sub { $cb }, $class; -} +} { ### cache to find the relevant modules my $cache = { - core + core => sub { my $self = shift; core => [ $self->list_core_modules ] }, - - dependencies + + dependencies => sub { my $self = shift; dependencies => [ $self->list_core_dependencies ] }, - enabled_features + enabled_features => sub { my $self = shift; map { $_ => [ $self->modules_for_feature( $_ ) ] } - $self->list_enabled_features + $self->list_enabled_features }, features => sub { my $self = shift; map { $_ => [ $self->modules_for_feature( $_ ) ] } - $self->list_features + $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. @@ -237,14 +237,14 @@ See C<selfupdate> for details. =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 +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: @@ -254,40 +254,40 @@ Would return: ( core => [ $module_object_for_cpanplus ] ); -=cut - +=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 }, - }; - + 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 ) + ### 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 + for my $aref ( values %list ) { + $aref = [ $latest ? grep { !$_->is_uptodate } @$aref : grep { !$_->is_installed_version_sufficient } @$aref ]; } - + return %list; } @@ -310,21 +310,21 @@ Returns true on success, false on error. 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 ) ) { @@ -332,10 +332,10 @@ Returns true on success, false on error. error(loc("Failed to update module '%1'", $mod->name)); } } - + return if $flag; return 1; - } + } } @@ -360,19 +360,19 @@ CPANPLUS installation. 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 +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. @@ -388,18 +388,18 @@ sub modules_for_feature { 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; @@ -409,7 +409,7 @@ sub modules_for_feature { =head2 @mods = $self->list_core_dependencies( [AS_HASH] ) -Returns a list of C<CPANPLUS::Selfupdate::Module> objects which +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 @@ -430,7 +430,7 @@ sub list_core_dependencies { =head2 @mods = $self->list_core_modules( [AS_HASH] ) -Returns a list of C<CPANPLUS::Selfupdate::Module> objects which +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 @@ -453,14 +453,14 @@ sub _hashref_to_module { my $self = shift; my $cb = $self->(); my $href = shift or return; - - return map { + + return map { CPANPLUS::Selfupdate::Module->new( $cb->module_tree($_) => $href->{$_} ) } keys %$href; -} - +} + =head1 CPANPLUS::Selfupdate::Module @@ -474,22 +474,22 @@ that return module objects. { 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; } @@ -498,12 +498,12 @@ that return module objects. 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 @@ -512,13 +512,13 @@ 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; @@ -534,10 +534,10 @@ 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) +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 +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/Shell.pm b/cpan/CPANPLUS/lib/CPANPLUS/Shell.pm index e3eb181c6d..e80a79e52f 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Shell.pm @@ -56,17 +56,17 @@ sub import { ### find out what shell we're supposed to load ### $SHELL = $option ? $class . '::' . $option - : do { ### XXX this should offer to reconfigure + : 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 + ### be ignored in favour of the one that was ### retrieved via ->new --kane - my $conf = CPANPLUS::Configure->new() or + 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: { @@ -294,13 +294,13 @@ sub _pager_close { 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 + ### of @_, as it will then miss the $fmt and return the ### number of elements in the list... =/ --kane $self->__print( sprintf( $fmt, @_ ) ); } @@ -320,10 +320,10 @@ 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) +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 +This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Classic.pm b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Classic.pm index 08c03bcf38..089d3de16b 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Classic.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Classic.pm @@ -1207,10 +1207,10 @@ 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) +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 +This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default.pm b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default.pm index 35c02aff2b..d736dfdac7 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default.pm @@ -26,7 +26,7 @@ local $Data::Dumper::Indent = 1; # for dumpering from ! BEGIN { use vars qw[ $VERSION @ISA ]; @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; - $VERSION = "0.9103"; + $VERSION = "0.9105"; } load CPANPLUS::Shell; @@ -119,8 +119,8 @@ CPANPLUS::Shell::Default 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> 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 @@ -143,7 +143,7 @@ CPANPLUS::Shell::Default cpanp> q # quit the shell cpanp> /plugins # list available plugins - cpanp> /? PLUGIN # list help test of <PLUGIN> + cpanp> /? PLUGIN # list help test of <PLUGIN> ### common options: cpanp> i ... --skiptest # skip tests @@ -250,11 +250,11 @@ sub _input_loop { } continue { ### clear the sigint count $self->_signals->{INT}{count}-- - if $self->_signals->{INT}{count}; - + if $self->_signals->{INT}{count}; + ### reset the 'install prereq?' cached answer - $self->settings->{'install_all_prereqs'} = undef; - + $self->settings->{'install_all_prereqs'} = undef; + } return 1; @@ -280,7 +280,7 @@ sub dispatch_on_input { $self->noninteractive($noninteractive) if defined $noninteractive; my $rv = 1; - + my @cmds = split ';', $string; while( my $input = shift @cmds ) { @@ -304,9 +304,9 @@ sub dispatch_on_input { if( $input and $input !~ s/^\s+// ) { $self->__print( loc("Could not understand command: %1\n". "Possibly missing command before argument(s)?\n", - $org_input) ); + $org_input) ); return; - } + } ### allow overrides from the config file ### if( defined $rc->{$key} ) { @@ -343,9 +343,9 @@ sub dispatch_on_input { if( $key eq 'z' or ($key eq 's' and $input =~ /^\s*edit/) ) { - $self->__print( "\n", + $self->__print( "\n", loc( "Command '%1' not supported over remote connection", - join ' ', $key, $input + join ' ', $key, $input ), "\n\n" ); } else { @@ -377,7 +377,7 @@ sub dispatch_on_input { unless grep {$key eq $_} qw[! m a v w x p s b / ? h]; ### keep track of failures - $rv *= defined eval { $self->$method( + $rv *= defined eval { $self->$method( modules => \@mods, options => $options, input => $input, @@ -502,7 +502,7 @@ sub __display_results { } else { $self->__print( loc("No results to display"), "\n" ); } - + return 1; } @@ -514,7 +514,7 @@ sub _quit { if defined $rc->{'logout'}; $self->__print( loc("Exiting CPANPLUS shell"), "\n" ); - + return 1; } @@ -529,17 +529,17 @@ sub _quit { 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' ), @@ -584,7 +584,7 @@ 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 " . @@ -592,7 +592,7 @@ loc(' /? [PLUGIN NAME] # show usage for (a particular) plugin(s)' ), $self->__print( map {"$_\n"} @help ); $self->__print( $/ ); $self->_pager_close; - + return 1; } } @@ -760,7 +760,7 @@ sub _fetch { $self->__print( "\n" ); } $self->_pager_close; - + return 1 if $rv; return; } @@ -860,16 +860,16 @@ sub _reload_indices { } 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 { @@ -906,20 +906,20 @@ sub _install { $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 ) + 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" + 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)); } @@ -930,26 +930,26 @@ sub _install { ### create the dir if it doesn't exit yet $cb->_mkdir( dir => $dir ) unless -d $dir; - my $file = File::Spec->catfile( + my $file = File::Spec->catfile( $dir, - INSTALL_LOG_FILE->( $mod ) + 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( + + $self->__print( loc("*** Install log written to:\n %1\n\n", $file) ); - } else { + } else { warn "Could not open '$file': $!\n"; next; - } + } } } @@ -961,7 +961,7 @@ sub _install { $self->__print( loc("Module '%1' %tense(%2,past) successfully\n", $mod->module, $action) - ); + ); } else { $flag++; $self->__print( @@ -981,8 +981,8 @@ sub _install { loc("Problem %tense(%1,present) one or more modules", $action) ); $self->__print( "\n" ); - - $self->__print( + + $self->__print( loc("*** You can view the complete error buffer by pressing ". "'%1' ***\n", 'p') ) unless $conf->get_conf('verbose') || $self->noninteractive; @@ -1001,13 +1001,13 @@ sub __ask_about_install { $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( + + + $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'", @@ -1025,9 +1025,9 @@ sub __ask_about_install { default => $yes, ); - ### if 'all' or 'none', save this, so we can apply it to + ### if 'all' or 'none', save this, so we can apply it to ### other prereqs in this chain. - $Shell->settings->{'install_all_prereqs'} = + $Shell->settings->{'install_all_prereqs'} = $reply eq $all ? 1 : $reply eq $none ? 0 : undef; @@ -1064,7 +1064,7 @@ sub __ask_about_edit_test_report { my $term = $Shell->term; $Shell->__print( "\n" ); - $Shell->__print( + $Shell->__print( loc("Test report prepared for module '%1'. You can edit this ". "report if you would like", $mod->module ) ); $Shell->__print("\n\n"); @@ -1082,11 +1082,11 @@ sub __ask_about_test_failure { my $term = $Shell->term; $Shell->__print( "\n" ); - $Shell->__print( + $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', @@ -1125,7 +1125,7 @@ sub _details { my @list = sort { $a->module cmp $b->module } $mod->contains; unless( $href ) { - $self->__print( + $self->__print( loc("No details for %1 - it might be outdated.", $mod->module), "\n" ); next; @@ -1135,11 +1135,11 @@ sub _details { for my $item ( sort keys %$href ) { $self->__printf( $format, $item, $href->{$item} ); } - + my $showed; for my $item ( @list ) { $self->__printf( - $cformat, ($showed ? '' : 'Contains:'), + $cformat, ($showed ? '' : 'Contains:'), $item->module, $item->version ); $showed++; @@ -1199,7 +1199,7 @@ sub _set_conf { ### possible options ### XXX hard coded, not optimal :( my %types = ( - reconfigure => '', + reconfigure => '', save => q([user | system | boxed]), edit => '', program => q([key => val]), @@ -1238,8 +1238,8 @@ sub _set_conf { user => CONFIG_USER, system => CONFIG_SYSTEM, boxed => CONFIG_BOXED, - }->{ $key } || CONFIG_USER; - + }->{ $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 @@ -1248,15 +1248,15 @@ sub _set_conf { 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$//; + $path =~ s/$file_re$//; $dir = $path; - } - + } + my $rv = $cb->configure_object->save( $where => $dir ); - $self->__print( + $self->__print( $rv ? loc("Configuration successfully saved to %1\n (%2)\n", $where, $rv) @@ -1272,7 +1272,7 @@ sub _set_conf { my $where = { user => CONFIG_USER, system => CONFIG_SYSTEM, - }->{ $key } || CONFIG_USER; + }->{ $key } || CONFIG_USER; my $file = $conf->_config_pm_to_file( $where ); system($editor,$file); @@ -1290,35 +1290,35 @@ sub _set_conf { return 1; } elsif ( $type eq 'mirrors' ) { - - $self->__print( + + $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; + 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 { + ( join $/, map { sprintf "\ts selfupdate %-17s " . - "[--latest=0] [--dryrun]", $_ - } sort keys %valid ) + "[--latest=0] [--dryrun]", $_ + } sort keys %valid ) ) - ); + ); } else { my %update_args = ( update => $key, @@ -1331,35 +1331,35 @@ sub _set_conf { ->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} + $valid{$feature} ? " " . ucfirst($feature) . ":\n" : " Modules for '$feature' support:\n" ); - - ### show what modules would be installed + + ### show what modules would be installed $self->__print( scalar @$aref - ? map { sprintf " %-42s %-6s -> %-6s \n", + ? map { sprintf " %-42s %-6s -> %-6s \n", $_->name, $_->installed_version, $_->version - } @$aref + } @$aref : " No upgrades required\n" - ); + ); $self->__print( $/ ); } - - - unless( $opts->{'dryrun'} ) { + + + 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' ) { @@ -1367,7 +1367,7 @@ sub _set_conf { my $format = { conf => '%-25s %s', program => '%-12s %s', - }->{ $type }; + }->{ $type }; unless( $key ) { my @list = grep { $_ ne 'hosts' } @@ -1386,7 +1386,7 @@ sub _set_conf { } } elsif ( $key eq 'hosts' or $key eq 'lib' ) { - $self->__print( + $self->__print( loc( "Setting %1 is not trivial.\n" . "It is suggested you use '%2' and edit the " . "configuration file manually", $key, 's edit') @@ -1402,8 +1402,8 @@ sub _set_conf { $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{$_} } + $self->__print( $/, join $/, + map { sprintf "\t%-11s %s", $_, $types{$_} } sort keys %types ); } } @@ -1491,7 +1491,7 @@ sub _autobundle { my $where = $cb->autobundle( %$opts ); - $self->__print( + $self->__print( $where ? loc("Wrote autobundle to '%1'", $where) : loc("Could not create autobundle" ) @@ -1550,25 +1550,25 @@ should use the same package manager to uninstall them ### then report whether all this went ok or not ### for my $mod (@$mods) { if( $mod->status->uninstall ) { - $self->__print( + $self->__print( loc("Module '%1' %tense(uninstall,past) successfully\n", $mod->module ) ); } else { $flag++; - $self->__print( + $self->__print( loc("Error %tense(uninstall,present) '%1'\n", $mod->module) ); } } if( !$flag ) { - $self->__print( + $self->__print( loc("All modules %tense(uninstall,past) successfully"), "\n" ); } else { - $self->__print( + $self->__print( loc("Problem %tense(uninstall,present) one or more modules" ), "\n" ); - - $self->__print( + + $self->__print( loc("*** You can view the complete error buffer by pressing '%1'". "***\n", 'p') ) unless $conf->get_conf('verbose'); } @@ -1617,13 +1617,13 @@ sub _reports { my %seen; for my $href (@list ) { - $self->__print( + $self->__print( "[" . $mod->author->cpanid .'/'. $href->{'dist'} . "]\n" ) unless $seen{ $href->{'dist'} }++; - $self->__printf( - $format, - $href->{'grade'}, + $self->__printf( + $format, + $href->{'grade'}, $href->{'platform'}, ($href->{'details'} ? '(*)' : '') ); @@ -1641,62 +1641,62 @@ sub _reports { ### Load plugins { my @PluginModules; - my %Dispatch = ( - showtip => [ __PACKAGE__, '_show_random_tip'], - plugins => [ __PACKAGE__, '_list_plugins' ], + 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'", + error(loc("'%1' is already registered by '%2'", $name, $Dispatch{$name}->[0])); - next; + next; } - + ### register name, package and function $Dispatch{$name} = [ $p, $func ]; } } } - + ### dispatch a plugin command to its function sub _meta { my $self = shift; @@ -1704,69 +1704,69 @@ sub _reports { 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"; - +### 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; + 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( $/ ); + + $self->__print( $/ ); } sub _list_plugins_help { @@ -1776,7 +1776,7 @@ sub _reports { ### 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; @@ -1785,9 +1785,9 @@ sub _reports { 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 @@ -1795,21 +1795,21 @@ sub _reports { 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( $/.$/ ); + } + + $self->__print( $/.$/ ); } - + sub _plugins_usage_help { return sprintf $help_format, '? [NAME ...]', loc("show usage for plugins"); @@ -1856,8 +1856,8 @@ sub _read_configuration_from_rc { eval { $href = Config::Auto::parse( $rc_file, format => 'space' ) }; - $self->__print( - loc( "Unable to read in config file '%1': %2", $rc_file, $@ ) + $self->__print( + loc( "Unable to read in config file '%1': %2", $rc_file, $@ ) ) if $@; } @@ -1867,34 +1867,34 @@ sub _read_configuration_from_rc { { 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'", + 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( "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 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 ' ), + 's selfupdate enabled_features ' ), ); - + sub _show_random_tip { my $self = shift; - $self->__print( $/, "Did you know...\n ", + $self->__print( $/, "Did you know...\n ", $tips[ int rand scalar @tips ], $/ ); return 1; } -} +} 1; @@ -1912,10 +1912,10 @@ 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) +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 +This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm index 7b54681907..7ec2978e07 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm @@ -9,7 +9,7 @@ use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; =head1 NAME -CPANPLUS::Shell::Default::Plugins::CustomSource +CPANPLUS::Shell::Default::Plugins::CustomSource =head1 SYNOPSIS @@ -18,10 +18,10 @@ CPANPLUS::Shell::Default::Plugins::CustomSource ### add a new custom source CPAN Terminal> /cs --add file:///path/to/releases - - ### list all your custom sources by + + ### 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 @@ -29,11 +29,11 @@ CPANPLUS::Shell::Default::Plugins::CustomSource ### 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 @@ -44,13 +44,13 @@ CPANPLUS::Shell::Default::Plugins::CustomSource =head1 DESCRIPTION -This is a C<CPANPLUS::Shell::Default> plugin that can add -custom sources to your CPANPLUS installation. This is a +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 +beyond what's available on C<CPAN> with your own local distributions, or ones offered by third parties. =cut @@ -68,8 +68,8 @@ sub _uri_from_cache { my $self = shift; my $input = shift or return; - ### you gave us a search number - my $uri = $input =~ /^\d+$/ + ### you gave us a search number + my $uri = $input =~ /^\d+$/ ? $Index[ $input - 1 ] # remember, off by 1! : $input; @@ -79,13 +79,13 @@ sub _uri_from_cache { ### 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 + return wantarray ? ($uri, $local) : $uri; } - + ### couldn't resolve the input error(loc("Unknown URI/index: '%1'", $input)); return; @@ -93,11 +93,11 @@ sub _uri_from_cache { 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 ); @@ -105,7 +105,7 @@ sub _list_custom_sources { ### remember, off by 1! push @Index, $remote; } - + $Shell->__print( $/ ); } @@ -117,7 +117,7 @@ sub _list_contents { unless( $uri ) { error(loc("--contents needs URI parameter")); return; - } + } my $fh = OPEN_FILE->( $local ) or return; @@ -139,45 +139,45 @@ sub custom_source { } elsif ( $opts->{'contents'} ) { $class->_list_contents( $input ); - - } elsif ( $opts->{'add'} ) { + + } elsif ( $opts->{'add'} ) { unless( $input ) { error(loc("--add needs URI parameter")); return; - } - - $cb->add_custom_source( uri => $input ) + } + + $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; - + } + + 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"), $/ ) }; + $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), $/); - + $shell->__print( loc("Wrote remote source index for '%1'", $input), $/); + } else { error(loc("Unrecognized command, see '%1' for help", '/? cs')); } - + return; } @@ -192,10 +192,10 @@ sub custom_source_help { ' /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' . $/ - ); + ' /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 index ca765f9e0a..8000aac988 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod +++ b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod @@ -5,20 +5,20 @@ CPANPLUS::Shell::Default::Plugins::HOWTO -- documentation on how to write your o =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>. +This pod text explains how to write your own plugins for +C<CPANPLUS::Shell::Default>. =head1 HOWTO @@ -34,18 +34,18 @@ 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 +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 @@ -60,7 +60,7 @@ 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 @@ -90,8 +90,8 @@ are all positional: For example, the following command: /helloworld bob --nofoo --bar=2 joe - -Would yield the following arguments: + +Would yield the following arguments: sub hw { my $class = shift; # CPANPLUS::Shell::Default::Plugins::HW @@ -115,10 +115,10 @@ 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) +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 +This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm index d2b829abde..239c4cd6e1 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm @@ -29,17 +29,17 @@ 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> @@ -139,7 +139,7 @@ sub disconnect { } sub connect_help { - return loc( + return loc( " /connect [HOST PORT] # Connect to the remote machine,\n" . " # defaults taken from your config\n" . " --user=USER # Optional username\n" . @@ -151,8 +151,8 @@ sub disconnect_help { " /disconnect # Disconnect from the remote server" ); } -1; - +1; + =pod =head1 BUG REPORTS @@ -165,10 +165,10 @@ 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) +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 +This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO diff --git a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Source.pm b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Source.pm index 889b3d3d9b..e0266cd692 100644 --- a/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Source.pm +++ b/cpan/CPANPLUS/lib/CPANPLUS/Shell/Default/Plugins/Source.pm @@ -6,7 +6,7 @@ use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; =head1 NAME -CPANPLUS::Shell::Default::Plugins::Source +CPANPLUS::Shell::Default::Plugins::Source =head1 SYNOPSIS @@ -23,12 +23,12 @@ 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 + # 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!" @@ -48,20 +48,20 @@ sub source { 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( + 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); + + msg(loc("Dispatching '%1'", $line), $verbose); return 1 if $shell->dispatch_on_input( input => $line ); } } @@ -86,10 +86,10 @@ 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) +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 +This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO diff --git a/cpan/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t b/cpan/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t index 8e372fe0fd..dc9dcffa21 100644 --- a/cpan/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t +++ b/cpan/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -67,11 +67,11 @@ rmdir $Dir if -d $Dir; } ### test _chdir ### -{ ok( $Class->_chdir( dir => $Dir), "Chdir to '$Dir'" ); +{ 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'"); + " Cwd() is '$Dir'"); ok( $Class->_chdir( dir => $Cwd), "Chdir back to '$Cwd'" ); paths_are_same( File::Spec->rel2abs(cwd()), $Cwd, @@ -83,18 +83,18 @@ rmdir $Dir if -d $Dir; "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'" ); @@ -107,13 +107,13 @@ rmdir $Dir if -d $Dir; 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', @@ -121,57 +121,57 @@ rmdir $Dir if -d $Dir; '.2' => '.2', 'foo' => '0.0', 'a.1' => '0.0', - }; + }; 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; +{ sub foo { + my $me = $Class->_whoami; ok( $me, "_whoami returned a result" ); - is( $me, 'foo', " Value as expected" ); - } + 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 +### 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 diff --git a/cpan/CPANPLUS/t/01_CPANPLUS-Configure.t b/cpan/CPANPLUS/t/01_CPANPLUS-Configure.t index 6ade0600f1..152a9ac632 100644 --- a/cpan/CPANPLUS/t/01_CPANPLUS-Configure.t +++ b/cpan/CPANPLUS/t/01_CPANPLUS-Configure.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -15,7 +15,7 @@ my $Config_pm = 'CPANPLUS/Config.pm'; 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'); @@ -38,33 +38,33 @@ for my $cat ( $r->ls_accessors ) { ### 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)" ); + " $addmeth('$add_key' => VAL)" ); ### this one now also exists ### push @options, $add_key } - ### poke in the object, get the actual hashref out ### + ### poke in the object, get the actual hashref out ### my %hash = map { - $_ => $r->$accessor->$_ + $_ => $r->$accessor->$_ } $r->$accessor->ls_accessors; - + while( my ($key,$val) = each %hash ) { - my $is = $c->$getmeth($key); + 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')" ); @@ -74,15 +74,15 @@ for my $cat ( $r->ls_accessors ) { ### 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" ); @@ -92,23 +92,23 @@ for my $cat ( $r->ls_accessors ) { 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; + 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" ); @@ -116,16 +116,16 @@ for my $cat ( $r->ls_accessors ) { { CPANPLUS::Error->flush; - - { ### try a bogus method call + + { ### 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: diff --git a/cpan/CPANPLUS/t/02_CPANPLUS-Internals.t b/cpan/CPANPLUS/t/02_CPANPLUS-Internals.t index 84b78f3ade..46a7cb6e20 100644 --- a/cpan/CPANPLUS/t/02_CPANPLUS-Internals.t +++ b/cpan/CPANPLUS/t/02_CPANPLUS-Internals.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -23,21 +23,21 @@ is($cb->_id, $cb->_last_id, "Comparing ID's"); 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" ); @@ -45,29 +45,29 @@ is($cb->_id, $cb->_last_id, "Comparing ID's"); 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" ); @@ -76,30 +76,30 @@ is($cb->_id, $cb->_last_id, "Comparing ID's"); ### 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 => [$$] ), + my $inc = "@INC"; + ok( $cb->$meth( directories => [$$] ), " CB->$meth( $$ )" ); - + my $new_p5lib = $ENV{PERL5LIB}; - my $new_inc = "@INC"; + 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 => [$$] ), + + 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 + ### 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? @@ -110,32 +110,32 @@ is($cb->_id, $cb->_last_id, "Comparing ID's"); }; 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" ); + 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" ); - } + } } diff --git a/cpan/CPANPLUS/t/03_CPANPLUS-Internals-Source.t b/cpan/CPANPLUS/t/03_CPANPLUS-Internals-Source.t index 65f1e54c35..d6ad2ea94f 100644 --- a/cpan/CPANPLUS/t/03_CPANPLUS-Internals-Source.t +++ b/cpan/CPANPLUS/t/03_CPANPLUS-Internals-Source.t @@ -1,14 +1,14 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +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 +use Test::More eval { + load $ENV{CPANPLUS_SOURCE_ENGINE} if $ENV{CPANPLUS_SOURCE_ENGINE}; 1 } ? 'no_plan' : (skip_all => "SQLite engine not available"); @@ -20,6 +20,7 @@ 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 @@ -35,12 +36,12 @@ my $modname = TEST_CONF_MODULE; ### source files should be copied from the 'server' now for my $name (qw[auth mod dslip] ) { - my $file = File::Spec->catfile( + 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" ); @@ -55,7 +56,7 @@ my $modname = TEST_CONF_MODULE; } ### save state tests -SKIP: { +SKIP: { skip "Save state tests for custom engine $ENV{CPANPLUS_SOURCE_ENGINE}", 7 if $ENV{CPANPLUS_SOURCE_ENGINE}; @@ -73,44 +74,44 @@ SKIP: { my $rv = $cb->save_state; ok( $rv, " State information saved" ); - - like( CPANPLUS::Error->stack_as_string, qr/Writing compiled source/, + + 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/, + 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: { +SKIP: { ### first, find a file to serve as a source my $mod = $cb->_module_tree->{$modname}; my $package = File::Spec->rel2abs( - File::Spec->catfile( + 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 + ### remote uri my $uri = $cb->_host_to_uri( scheme => 'file', host => '', @@ -118,25 +119,25 @@ SKIP: { ); 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 + + ### 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 + 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( + my $rv = $cb->$meth( path => dirname( $package ), to => $src_file ); @@ -145,26 +146,26 @@ SKIP: { 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 $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 @@ -178,7 +179,7 @@ SKIP: { my $add = $cb->_module_tree->{$add_name}; ok( $add, " Found added module" ); - ok( $add->status->_fetch_from, + ok( $add->status->_fetch_from, " Full download path set" ); is( $add->author->cpanid, CUSTOM_AUTHOR_ID, " Attributed to custom author" ); @@ -193,60 +194,60 @@ SKIP: { ### 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; + 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" ); + " Timestamp on sourcefile updated" ); } - + ### now update it individually - ### 3 tests + ### 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; + 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" ); + " Timestamp on sourcefile updated" ); } ### now update using the higher level API, see if it's part of the update - ### 3 tests + ### 3 tests { CPANPLUS::Error->flush; ### mark what time it is now, sleep 1 second for better measuring - my $now = time; + 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" ); + " 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 + ### 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" ); diff --git a/cpan/CPANPLUS/t/04_CPANPLUS-Module.t b/cpan/CPANPLUS/t/04_CPANPLUS-Module.t index f45755143b..1014e62bda 100644 --- a/cpan/CPANPLUS/t/04_CPANPLUS-Module.t +++ b/cpan/CPANPLUS/t/04_CPANPLUS-Module.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -21,7 +21,7 @@ my $Conf = gimme_conf(); my $CB = CPANPLUS::Backend->new( $Conf ); ### start with fresh sources ### -ok( $CB->reload_indices( update_source => 0 ), "Rebuilding trees" ); +ok( $CB->reload_indices( update_source => 0 ), "Rebuilding trees" ); my $AuthName = TEST_CONF_AUTHOR; my $Auth = $CB->author_tree( $AuthName ); @@ -48,17 +48,17 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); name => $ModName, comment => undef, package => 'Foo-Bar-0.01.tar.gz', - path => 'authors/id/EUNOXS', + path => 'authors/id/EUNOXS', version => '0.01', dslip => 'cdpO ', - description => 'CPANPLUS Test Package', + 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" ); @@ -71,7 +71,7 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); ### check accessor objects ### isa_ok( $Mod->parent, 'CPANPLUS::Backend' ); isa_ok( $Mod->author, 'CPANPLUS::Module::Author' ); - is( $Mod->author->author, $Auth->author, + is( $Mod->author->author, $Auth->author, "Module eq Author" ); } @@ -89,18 +89,18 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); { 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 + + ### 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, + is( $status, $clone->_status, " Object stored as expected" ); isa_ok( $status, 'Object::Accessor' ); } @@ -109,18 +109,18 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); 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); - + $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 ); } @@ -142,26 +142,26 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); 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 + + ### check ttl code for checksums; fetching it now means the cache ### should kick in { CPANPLUS::Error->flush; - ok( $Mod->checksums, + ok( $Mod->checksums, " Checksums re-fetched" ); like( CPANPLUS::Error->stack_as_string, qr/Using cached file/, " Cached file used" ); - } + } } } @@ -177,14 +177,14 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); 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; +{ my $dslip = $Mod->dslip; ok( $dslip, "Got dslip information from $ModName ($dslip)" ); ### now find it for a submodule @@ -193,33 +193,33 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); ok( $submod->dslip, " Got dslip info (".$submod->dslip.")" ); is( $submod->dslip, $dslip, " It's identical to $ModName" ); - } + } } -{ ### details() test ### +{ ### details() test ### my $href = { 'Support Level' => 'Developer', 'Package' => $Mod->package, 'Description' => $Mod->description, - 'Development Stage' => + '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' => + 'Language Used' => 'Perl-only, no compiler needed, should be platform independent', - 'Interface Style' => + 'Interface Style' => 'Object oriented using blessed references and/or inheritance', - 'Public License' => 'Unknown', + '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" ); + + is_deeply( $res, $href, "Details OK" ); } { ### contians() test ### @@ -227,9 +227,9 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); ### 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], + is_deeply( \@list, [$CoreMod], " Found all modules expected" ); } @@ -263,9 +263,9 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); my @objs = $bundle->bundle_modules; is( scalar(@objs), 5, " Found all prerequisites" ); - + for( @objs ) { - isa_ok( $_, 'CPANPLUS::Module', + isa_ok( $_, 'CPANPLUS::Module', " Prereq " . $_->module ); ok( defined $bundle->status->prereqs->{$_->module}, " Prereq was registered" ); @@ -273,21 +273,21 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); } { ### testing autobundles - my $file = File::Spec->catfile( - dummy_cpan_dir(), + my $file = File::Spec->catfile( + dummy_cpan_dir(), $Conf->_get_build('autobundle'), - 'Snapshot.pm' + '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, @@ -303,7 +303,7 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); 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" ); @@ -313,28 +313,28 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); ### test module from perl core ### { isa_ok( $CoreMod, 'CPANPLUS::Module', "Core module " . $CoreName ); - ok( $CoreMod->package_is_perl_core, + 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 + skip "Module::ThirdParty not installed", 10 unless eval { require Module::ThirdParty; 1 }; - ok( !$Mod->is_third_party, + 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, @@ -343,11 +343,11 @@ SKIP: { 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 ### diff --git a/cpan/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t b/cpan/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t index 9d648fc38f..7a6b1acb86 100644 --- a/cpan/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t +++ b/cpan/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -26,11 +26,11 @@ 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), + ok(!$cb->_host_ok( host => $host), " Host registered as failed" ); - ok( $cb->_host_ok( host => {} ), + ok( $cb->_host_ok( host => {} ), " Fresh host unregistered" ); } @@ -38,7 +38,7 @@ isa_ok( $mod, 'CPANPLUS::Module' ); { my $where = $cb->_fetch( module => $mod, force => 1 ); ok( $where, "File downloaded to '$where'" ); - ok( -s $where, " File exists" ); + ok( -s $where, " File exists" ); unlink $where; ok(!-e $where, " File removed" ); } @@ -46,24 +46,24 @@ isa_ok( $mod, 'CPANPLUS::Module' ); ### try to fetch something that doesn't exist ### { ### set up a bogus host first ### my $hosts = $conf->get_conf('hosts'); - my $fail = { scheme => 'file', + 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" ); - + 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" ); + " Error recorded appropriately" ); ### host marked as bad? ### - ok(!$cb->_host_ok( host => $fail ), - " Failed host logged properly" ); + ok(!$cb->_host_ok( host => $fail ), + " Failed host logged properly" ); ### restore the hosts ### shift @$hosts; $conf->set_conf( hosts => $hosts ); @@ -82,23 +82,23 @@ isa_ok( $mod, 'CPANPLUS::Module' ); : 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), + + ok( IS_FAKE_MODOBJ->(mod => $fake), "Fake module created from $0" ); is( $fake->status->_fetch_from, $target, - " Fetch from set ok" ); - + " 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" ); + like( $where, qr/$base$/, " Saved with proper name" ); } diff --git a/cpan/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t b/cpan/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t index 65bde1181a..993b2dc4ac 100644 --- a/cpan/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t +++ b/cpan/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -40,7 +40,7 @@ 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'; @@ -56,18 +56,18 @@ ok( DIR_EXISTS->( dir => cwd() ), "DIR_EXISTS finds dir" ); : '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: +# vim: expandtab shiftwidth=4: diff --git a/cpan/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t b/cpan/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t index b03befa8ac..3c18a3b944 100644 --- a/cpan/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t +++ b/cpan/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } diff --git a/cpan/CPANPLUS/t/08_CPANPLUS-Backend.t b/cpan/CPANPLUS/t/08_CPANPLUS-Backend.t index d2a93c1d51..aba3a475f7 100644 --- a/cpan/CPANPLUS/t/08_CPANPLUS-Backend.t +++ b/cpan/CPANPLUS/t/08_CPANPLUS-Backend.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -25,8 +25,8 @@ 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" ); +ok( scalar keys %$mt, "Module tree has entries" ); +ok( scalar keys %$at, "Author tree has entries" ); ### module_tree tests ### my $Name = TEST_CONF_MODULE; @@ -35,7 +35,7 @@ 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" ); @@ -46,7 +46,7 @@ my $mod = $cb->module_tree($Name); { 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" ); @@ -59,122 +59,122 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); ### parse_module tests ### -{ my @map = ( - $Name => [ +{ my @map = ( + $Name => [ $mod->author->cpanid, # author $mod->package_name, # package name $mod->version, # version ], - $mod => [ - $mod->author->cpanid, - $mod->package_name, - $mod->version, + $mod => [ + $mod->author->cpanid, + $mod->package_name, + $mod->version, ], - 'Foo-Bar-EU-NOXS' => [ - $mod->author->cpanid, - $mod->package_name, + 'Foo-Bar-EU-NOXS' => [ + $mod->author->cpanid, + $mod->package_name, $mod->version, ], - 'Foo-Bar-EU-NOXS-0.01' => [ - $mod->author->cpanid, - $mod->package_name, + 'Foo-Bar-EU-NOXS-0.01' => [ + $mod->author->cpanid, + $mod->package_name, '0.01', ], - 'EUNOXS/Foo-Bar-EU-NOXS' => [ + 'EUNOXS/Foo-Bar-EU-NOXS' => [ 'EUNOXS', - $mod->package_name, + $mod->package_name, $mod->version, ], - 'EUNOXS/Foo-Bar-EU-NOXS-0.01' => [ - 'EUNOXS', - $mod->package_name, + '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', + 'EUNOXS/Foo-Bar-0.02' => [ + 'EUNOXS', 'Foo-Bar', '0.02', ], - 'Foo-Bar-EU-NOXS-0.09' => [ - $mod->author->cpanid, - $mod->package_name, + '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, + 'MBXS/Foo-Bar-EU-NOXS-0.01' => [ + 'MBXS', + $mod->package_name, '0.01', ], - 'EUNOXS/Foo-Bar-EU-NOXS-0.09' => [ + 'EUNOXS/Foo-Bar-EU-NOXS-0.09' => [ 'EUNOXS', - $mod->package_name, + $mod->package_name, '0.09', ], - 'EUNOXS/Foo-Bar-EU-NOXS-0.09.zip' => [ + 'EUNOXS/Foo-Bar-EU-NOXS-0.09.zip' => [ 'EUNOXS', - $mod->package_name, + $mod->package_name, '0.09', ], - 'FROO/Flub-Flob-1.1.zip' => [ - 'FROO', - 'Flub-Flob', - '1.1', + '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', + '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', + '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/Net-Lite-FTP-0.091' => [ 'EYCK', - 'Net-Lite-FTP', + 'Net-Lite-FTP', '0.091', ], - 'M/MA/MAXDB/DBD-MaxDB-7.5.0.24a' => [ + 'M/MA/MAXDB/DBD-MaxDB-7.5.0.24a' => [ 'MAXDB', 'DBD-MaxDB', - '7.5.0.24a', + '7.5.0.24a', ], - 'EUNOXS/perl5.005_03.tar.gz' => [ - 'EUNOXS', + '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-v1.1.0.tbz' => [ + 'FROO', + 'Flub-Flub', + 'v1.1.0', ], - 'FROO/Flub-Flub-1.1_2.tbz' => [ - 'FROO', - 'Flub-Flub', + 'FROO/Flub-Flub-1.1_2.tbz' => [ + 'FROO', + 'Flub-Flub', '1.1_2', - ], - 'LDS/CGI.pm-3.27.tar.gz' => [ + ], + 'LDS/CGI.pm-3.27.tar.gz' => [ 'LDS', 'CGI', - '3.27', + '3.27', ], - 'FROO/Text-Tabs+Wrap-2006.1117.tar.gz' => [ - 'FROO', + 'FROO/Text-Tabs+Wrap-2006.1117.tar.gz' => [ + 'FROO', 'Text-Tabs+Wrap', - '2006.1117', - ], - 'JETTERO/Crypt-PBC-0.7.20.0-0.4.9' => [ + '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', + 'GRICHTER/HTML-Embperl-1.2.1.tar.gz' => [ + 'GRICHTER', + 'HTML-Embperl', '1.2.1', ], 'KANE/File-Fetch-0.15_03' => [ @@ -186,13 +186,18 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); '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; @@ -200,11 +205,11 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); 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'" ); - + ok( IS_MODOBJ->( mod => $obj ), + " parse_module success by '$guess'" ); + is( $obj->version, $version, " Proper version found: $version" ); is( $obj->package_version, $version, @@ -218,10 +223,10 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); { my $ext = $obj->package_extension; ok( $ext, " Has extension as well: $ext" ); } - - like( $obj->author->cpanid, "/$author/i", + + like( $obj->author->cpanid, "/$author/i", " Proper author found: $author"); - like( $obj->path, "/$author/i", + like( $obj->path, "/$author/i", " Proper path found: " . $obj->path ); } @@ -233,49 +238,49 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); [qr/Cannot find .+? in the module tree/,"Unable to find module"] ] ], [ {}, => [ - [ qr/module string from reference/,"Unable to parse ref"] + [ 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), + 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), + 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 %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( $rv->function, $method, " Function stored OK" ); is_deeply( $rv->args, \%args, " Arguments stored OK" ); is( $rv->rv->{$Name}, $mod->readme, " RV as expected" ); } @@ -285,18 +290,18 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); my $file = File::Spec->catfile( $conf->get_conf('base'), $conf->_get_source('mod'), ); - - ok( $cb->reload_indices( update_source => 0 ), "Rebuilding trees" ); + + 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 ), + ok( $cb->reload_indices( update_source => 1 ), "Rebuilding and refetching trees" ); - cmp_ok( $age, '>', -M $file, " Source file '$file' updated" ); + cmp_ok( $age, '>', -M $file, " Source file '$file' updated" ); } ### flush tests ### @@ -308,8 +313,8 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); ### installed tests ### { ok( scalar($cb->installed), "Found list of installed modules" ); -} - +} + ### autobudle tests ### { my $where = $cb->autobundle; @@ -318,17 +323,17 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); } ### local_mirror tests ### -{ ### turn off md5 checks for the 'fake' packages we have +{ ### 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 ); @@ -336,10 +341,10 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); 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 @@ -348,23 +353,23 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); is( $ENV{$name}, $$, " Set to current process id" ); } - ### Version + ### 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, + is( $ENV{$name}, $Class->VERSION, " Set to current process version" ); } - + } -__END__ - +__END__ + # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: -# vim: expandtab shiftwidth=4: - +# vim: expandtab shiftwidth=4: + diff --git a/cpan/CPANPLUS/t/09_CPANPLUS-Internals-Search.t b/cpan/CPANPLUS/t/09_CPANPLUS-Internals-Search.t index c00437d09a..e5ef37cb68 100644 --- a/cpan/CPANPLUS/t/09_CPANPLUS-Internals-Search.t +++ b/cpan/CPANPLUS/t/09_CPANPLUS-Internals-Search.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -37,7 +37,7 @@ for my $type ( CPANPLUS::Module->accessors() ) { ### 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 =~/^_/; diff --git a/cpan/CPANPLUS/t/10_CPANPLUS-Error.t b/cpan/CPANPLUS/t/10_CPANPLUS-Error.t index 800a126c0d..355ca7aad4 100644 --- a/cpan/CPANPLUS/t/10_CPANPLUS-Error.t +++ b/cpan/CPANPLUS/t/10_CPANPLUS-Error.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -19,7 +19,7 @@ my $map = { error => ["This is just a test error"], }; -### check if CPANPLUS::Error can do what we expect +### 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? @@ -28,8 +28,8 @@ my $map = { ### make sure we start with an empty stack { CPANPLUS::Error->flush; - is( scalar(()=CPANPLUS::Error->stack), 0, - "Starting with empty stack" ); + is( scalar(()=CPANPLUS::Error->stack), 0, + "Starting with empty stack" ); } ### global variables test ### @@ -37,9 +37,9 @@ my $map = { ### 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::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" ); @@ -51,40 +51,40 @@ my $map = { } ### must close it for Win32 tests! - close output_handle; + 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'" ); + " Contents matches for '$type'" ); like( $contents, qr/\Q$str/, - " Contents matches for '$type'" ); - + " Contents matches for '$type'" ); + like( $string, qr/\U\Q$tag/, - " String matches for '$type'" ); + " String matches for '$type'" ); like( $string, qr/\Q$str/, " String matches for '$type'" ); like( $trace, qr/\U\Q$tag/, - " Trace matches for '$type'" ); + " 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" ); @@ -92,17 +92,17 @@ my $map = { " 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)), + 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" ); - + is( scalar(()=CPANPLUS::Error->stack), 0, + "No items on stack" ); + } diff --git a/cpan/CPANPLUS/t/15_CPANPLUS-Shell.t b/cpan/CPANPLUS/t/15_CPANPLUS-Shell.t index fc8f9febe8..51283c6727 100644 --- a/cpan/CPANPLUS/t/15_CPANPLUS-Shell.t +++ b/cpan/CPANPLUS/t/15_CPANPLUS-Shell.t @@ -1,8 +1,8 @@ ### 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; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -17,7 +17,7 @@ BEGIN { sub _out { $out } sub _reset_out { $out = '' } -} +} use strict; use Test::More 'no_plan'; @@ -41,7 +41,7 @@ unless ( -t ) { ok('We are not on a terminal'); exit 0; } - + ### basic load tests use_ok( $Class, 'Default' ); is( $Class->which, SHELL_DEFAULT, @@ -52,10 +52,10 @@ 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( + File::Spec->catfile( $FindBin::Bin, TEST_CONF_CPAN_DIR, ) @@ -65,10 +65,10 @@ isa_ok( $Shell, $Default, " Object" ); host => '', path => $cs_path, ); - - my $base = $Conf->get_conf('base'); - ### XXX have to keep the list ordered, as some methods only work as + 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/, @@ -95,7 +95,7 @@ isa_ok( $Shell, $Default, " Object" ); '! 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|, @@ -113,21 +113,21 @@ isa_ok( $Shell, $Default, " Object" ); 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'" ); } @@ -137,16 +137,16 @@ __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 +'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', +'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 index 430e03db82..b551741eef 100644 --- a/cpan/CPANPLUS/t/19_CPANPLUS-Dist.t +++ b/cpan/CPANPLUS/t/19_CPANPLUS-Dist.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -21,7 +21,7 @@ BEGIN { require CPANPLUS::Dist; CPANPLUS::Dist->_add_dist_types( __PACKAGE__ ); - sub init { $_[0]->status->mk_accessors( + sub init { $_[0]->status->mk_accessors( qw[prepared created installed _prepare_args _install_args _create_args]); return $Init }; @@ -50,7 +50,7 @@ my $cb = CPANPLUS::Backend->new( $conf ); ### obsolete #my $Format = '_test'; my $Module = 'CPANPLUS::Dist::_Test'; -my $ModName = TEST_CONF_MODULE; +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' }; @@ -108,9 +108,9 @@ ok( $Mod, "Got module object" ); } { $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/, @@ -122,7 +122,7 @@ ok( $Mod, "Got module object" ); { 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, @@ -132,36 +132,36 @@ ok( $Mod, "Got module object" ); ### 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'; + + 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' => [ @@ -222,10 +222,10 @@ ok( $Mod, "Got module object" ); 'Perl binary version too low' => [ sub { $cb->module_tree( $ModName ) ->status->prereqs({ PERL_CORE, 10000000000 }); '' }, - sub { like( CPANPLUS::Error->stack_as_string, + sub { like( CPANPLUS::Error->stack_as_string, qr/needs perl version/, " Perl version not high enough" ) }, - ], + ], }, 1 => { 'Simple create' => [ @@ -316,10 +316,10 @@ ok( $Mod, "Got module object" ); 'Perl binary version sufficient' => [ sub { $cb->module_tree( $ModName ) ->status->prereqs({ PERL_CORE, 1 }); '' }, - sub { unlike( CPANPLUS::Error->stack_as_string, + sub { unlike( CPANPLUS::Error->stack_as_string, qr/needs perl version/, " Perl version sufficient" ) }, - ], + ], }, }; @@ -372,7 +372,7 @@ ok( $Mod, "Got module object" ); 0 => undef, 1 => undef, 2 => qr/have to resolve/, - }; + }; my $mod = CPANPLUS::Module::Fake->new( module => $$, @@ -382,37 +382,37 @@ ok( $Mod, "Got module object" ); 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; - - + 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" ); + + 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; } } diff --git a/cpan/CPANPLUS/t/20_CPANPLUS-Dist-MM.t b/cpan/CPANPLUS/t/20_CPANPLUS-Dist-MM.t index 7837f03d4d..5bba137159 100644 --- a/cpan/CPANPLUS/t/20_CPANPLUS-Dist-MM.t +++ b/cpan/CPANPLUS/t/20_CPANPLUS-Dist-MM.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -103,7 +103,7 @@ ok( $Mod->extract, "Extracting module to ".$Mod->status->extract ); ok( $dist, "Dist created with target => " . TARGET_INIT ); ok( !$dist->status->prepared, " Prepare was not run" ); -} +} ok( $Mod->test, "Testing module" ); @@ -141,20 +141,20 @@ SKIP: { ### 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 + ### 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, + + ok( $Mod->install( force => 1, + makemakerflags => 'PREFIX='.TEST_CONF_INSTALL_DIR, ), "Installing module" ); - } - + } + ok( $Mod->status->installed," Module installed according to status" ); @@ -164,8 +164,8 @@ SKIP: { ### #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; @@ -225,7 +225,7 @@ SKIP: { ### 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/, @@ -308,7 +308,7 @@ SKIP: { { 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" ); @@ -339,7 +339,7 @@ SKIP: { ### now let's write a makefile.pl that just does 'die' { local $^W; - local *CPANPLUS::Dist::MM::write_makefile_pl = + 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 @@ -360,8 +360,8 @@ SKIP: { { my $unlink_sts = unlink($makefile_pl); 1 while unlink $makefile_pl; ok( $unlink_sts, "Deleting Makefile.PL"); - } - + } + $dist->status->mk_flush; } @@ -370,21 +370,21 @@ SKIP: { 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 + ### clear errors CPANPLUS::Error->flush; my $rv = $dist->prepare( force => 1, verbose => 0 ); @@ -401,20 +401,20 @@ SKIP: { ### 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 $dist = shift; my $self = $dist->parent; my $fh = OPEN_FILE->( MAKEFILE_PL->($self->status->extract), '>' ); print $fh $txt; close $fh; - + return 1; } } diff --git a/cpan/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t b/cpan/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t index 5ccdf9f5e8..10a2745d80 100644 --- a/cpan/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t +++ b/cpan/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -27,27 +27,27 @@ my $Inst = INSTALLER_BUILD; my $Mod = $CB->module_tree( 'Foo::Bar::MB::NOXS' ); -ok( $Mod, "Module object retrieved" ); +ok( $Mod, "Module object retrieved" ); ok( not grep { $_ eq $Inst } CPANPLUS::Dist->dist_types, " $Inst installer not returned" ); - -### fetch the file first + +### fetch the file first { my $where = $Mod->fetch; ok( -e $where, " Tarball '$where' exists" ); } - -### extract it, silence warnings/messages + +### 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, +### 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}" ); @@ -55,7 +55,7 @@ ok( not grep { $_ eq $Inst } CPANPLUS::Dist->dist_types, my $err = CPANPLUS::Error->stack_as_string; like( $err, qr/$Inst/, " Message mentions $Inst" ); like( $err, qr/prerequisites list/, - " Message mentions adding prerequisites" ); + " Message mentions adding prerequisites" ); } ### now run the test, it should trigger the installation of the installer @@ -65,24 +65,24 @@ ok( not grep { $_ eq $Inst } CPANPLUS::Dist->dist_types, ### 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 { + 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" ); @@ -97,18 +97,18 @@ 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 { + 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; + 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 } diff --git a/cpan/CPANPLUS/t/25_CPANPLUS.t b/cpan/CPANPLUS/t/25_CPANPLUS.t index 9cbd15c7e3..b6723d35c6 100644 --- a/cpan/CPANPLUS/t/25_CPANPLUS.t +++ b/cpan/CPANPLUS/t/25_CPANPLUS.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -24,16 +24,16 @@ use_ok( $Class ); 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 }; @@ -45,7 +45,7 @@ for my $meth ( qw[fetch get install] ) { is( $ok, $rv, " Expected RV: $rv" ); like( CPANPLUS::Error->stack_as_string, $re, " With expected diagnostic" ); - } + } ### does not take objects / references { CPANPLUS::Error->flush; @@ -74,15 +74,15 @@ for my $meth ( qw[fetch get install] ) { { ### 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 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 index 4a6d6bcf1b..6347daa21c 100644 --- a/cpan/CPANPLUS/t/30_CPANPLUS-Internals-Selfupdate.t +++ b/cpan/CPANPLUS/t/30_CPANPLUS-Internals-Selfupdate.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -35,7 +35,7 @@ my $Prereq = { $Dep => 0 }; } -### check specifically if our bundled shells dont trigger a +### 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'; @@ -44,15 +44,15 @@ my $Prereq = { $Dep => 0 }; my $cur = $cobj->get_conf( $type ); for my $shell ( SHELL_DEFAULT, SHELL_CLASSIC ) { - ok( $cobj->set_conf( $type => $shell ), + 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 ), + ok( $cobj->set_conf( $type => $shell ), "Testing dependencies for '$shell'" ); my $rv = $CB->$Acc->$meth( $type => 1 ); @@ -62,7 +62,7 @@ my $Prereq = { $Dep => 0 }; 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 @@ -87,18 +87,18 @@ my $Prereq = { $Dep => 0 }; 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" ); @@ -106,7 +106,7 @@ my $Prereq = { $Dep => 0 }; is_deeply( $href, $Prereq, " With the proper entries" ); - } + } } ### see if we can get a list of modules to be updated @@ -124,7 +124,7 @@ my $Prereq = { $Dep => 0 }; 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, @@ -136,22 +136,22 @@ my $Prereq = { $Dep => 0 }; ### find enabled features { my $meth = 'list_enabled_features'; - can_ok( $Class, $meth ); - + 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 ); - + 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 ); + isa_ok( $list[0], $ModClass ); is( $list[0]->name, $Dep, " Correct module found" ); @@ -163,7 +163,7 @@ my $Prereq = { $Dep => 0 }; " With the proper entries" ); } } - + ### now selfupdate ourselves { ### XXX just test the mechanics, make sure install returns true @@ -171,11 +171,11 @@ my $Prereq = { $Dep => 0 }; ### 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'), + 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 index 066d5be8a0..a8823351d1 100644 --- a/cpan/CPANPLUS/t/40_CPANPLUS-Internals-Report.t +++ b/cpan/CPANPLUS/t/40_CPANPLUS-Internals-Report.t @@ -1,6 +1,6 @@ ### make sure we can find our conf.pl file -BEGIN { - use FindBin; +BEGIN { + use FindBin; require "$FindBin::Bin/inc/conf.pl"; } @@ -25,7 +25,7 @@ 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 +### 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 @@ -53,7 +53,7 @@ my $map = { check => 0, skiptests => 1, # did we skip the tests? - }, + }, missing_prereq => { buffer => missing_prereq_buffer(), failed => 1, @@ -87,7 +87,7 @@ my $map = { '/NA/', ], check => 0, - }, + }, perl_version_too_low_build1 => { buffer => perl_version_too_low_buffer_build(1), failed => 1, @@ -96,7 +96,7 @@ my $map = { '/NA/', ], check => 0, - }, + }, perl_version_too_low_build2 => { buffer => perl_version_too_low_buffer_build(2), failed => 1, @@ -105,7 +105,7 @@ my $map = { '/NA/', ], check => 0, - }, + }, prereq_versions_too_low => { ### set the prereq version incredibly high pre_hook => sub { @@ -119,14 +119,14 @@ my $map = { '/http://testers.cpan.org/', '/NA/', ], - check => 0, + check => 0, }, prereq_not_on_cpan => { pre_hook => sub { my $mod = shift; my $clone = $mod->clone; - $clone->status->prereqs( - { TEST_CONF_INVALID_MODULE, 0 } + $clone->status->prereqs( + { TEST_CONF_INVALID_MODULE, 0 } ); return $clone; }, @@ -135,14 +135,14 @@ my $map = { '/http://testers.cpan.org/', '/NA/', ], - check => 0, + 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 } + $clone->status->prereqs( + { TEST_CONF_PREREQ, 0 } ); return $clone; }, @@ -151,11 +151,11 @@ my $map = { '/http://testers.cpan.org/', '/UNKNOWN/', ], - check => 0, + check => 0, }, }; -### test config settings +### test config settings { for my $opt ( qw[cpantest cpantest_mx] ) { my $warnings; local $SIG{__WARN__} = sub { $warnings .= "@_" }; @@ -167,7 +167,7 @@ my $map = { " Retrieved properly" ); ok( $conf->set_conf( $opt => $org ), " Option $opt set back to original" ); - ok( !$warnings, " No warnings" ); + ok( !$warnings, " No warnings" ); } } @@ -219,15 +219,15 @@ my $map = { "Proper test fail stage found" ); } - ### test missing prereqs + ### 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 ); @@ -256,14 +256,14 @@ my $map = { { my $prereqs = REPORT_MISSING_PREREQS->('foo','bar@example.com','Foo::Bar'); ok( $prereqs, "Test output generated" ); - like( $prereqs, qr/'foo \(bar\@example\.com\)'/, + 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'); + { 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" ); @@ -291,15 +291,15 @@ my $map = { 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" ); @@ -308,7 +308,7 @@ my $map = { { 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/, @@ -317,10 +317,10 @@ my $map = { } ### callback tests -{ ### as reported in bug 13086, this callback returned the wrong item +{ ### 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 ); + ### $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" ); } @@ -334,14 +334,14 @@ SKIP: { unless $CB->_have_query_report_modules(verbose => 0); - SKIP: { + 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" ); @@ -389,7 +389,7 @@ SKIP: { : $Mod; my $file = do { - ### so T::R does not try to resolve our maildomain, which can + ### 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'; @@ -477,7 +477,7 @@ BEGIN failed--compilation aborted 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; @@ -493,7 +493,7 @@ 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 diff --git a/cpan/CPANPLUS/t/inc/conf.pl b/cpan/CPANPLUS/t/inc/conf.pl index a241bf160f..4977c39040 100644 --- a/cpan/CPANPLUS/t/inc/conf.pl +++ b/cpan/CPANPLUS/t/inc/conf.pl @@ -2,9 +2,9 @@ ### So reset it here explicitly my ($old_env_path, $old_env_perl5lib); BEGIN { - use FindBin; + 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]; @@ -12,40 +12,40 @@ BEGIN { ### 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( $_ ) + 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'}, + $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'}, + $ENV{'PATH'} = join $Config{'path_sep'}, grep { defined } "$FindBin::Bin/../../../utils", $ENV{'PATH'}; } else { - $ENV{'PATH'} = join $Config{'path_sep'}, + $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 ) + $^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 + ### 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" @@ -53,7 +53,7 @@ BEGIN { 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'; @@ -94,7 +94,7 @@ use File::Basename qw[basename]; 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_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'; @@ -104,7 +104,7 @@ 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( + File::Spec->catdir( TEST_CONF_CPANPLUS_DIR, 'install' ) @@ -118,15 +118,15 @@ sub dummy_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. + + ### 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 { +sub gimme_conf { ### don't load any other configs than the heuristic one ### during tests. They might hold broken/incorrect data @@ -134,20 +134,22 @@ sub gimme_conf { my $conf = CPANPLUS::Configure->new( load_configs => 0 ); my $dummy_cpan = dummy_cpan_dir(); - - $conf->set_conf( hosts => [ { + + $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( 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'); @@ -176,16 +178,16 @@ sub gimme_conf { $conf->set_conf( source_engine => $ENV{CPANPLUS_SOURCE_ENGINE} ) if $ENV{CPANPLUS_SOURCE_ENGINE}; - + _clean_test_dir( [ - $conf->get_conf('base'), + $conf->get_conf('base'), TEST_CONF_MIRROR_DIR, # TEST_INSTALL_DIR_LIB, # TEST_INSTALL_DIR_BIN, -# TEST_INSTALL_DIR_MAN1, +# TEST_INSTALL_DIR_MAN1, # TEST_INSTALL_DIR_MAN3, ], ( $ENV{PERL_CORE} ? 0 : 1 ) ); - + return $conf; }; @@ -194,47 +196,47 @@ sub gimme_conf { 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 { +END { if ( $ENV{PERL_CORE} ) { close output_handle(); 1 while unlink output_file(); _clean_test_dir( [ - gimme_conf->get_conf('base'), + gimme_conf->get_conf('base'), TEST_CONF_MIRROR_DIR, # TEST_INSTALL_DIR_LIB, # TEST_INSTALL_DIR_BIN, - # TEST_INSTALL_DIR_MAN1, + # TEST_INSTALL_DIR_MAN1, # TEST_INSTALL_DIR_MAN3, ], 0 ); # DO NOT be verbose under perl core -- makes tests fail } @@ -253,47 +255,47 @@ sub _clean_test_dir { my $dh; opendir $dh, $dir or die "Could not open basedir '$dir': $!"; - while( my $file = readdir $dh ) { + 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 + ### 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 + ### 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. - + ### 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. + ### 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'" + 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; |