diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS')
39 files changed, 1961 insertions, 1749 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm index 43e73b7b1fe..bb11f473618 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm @@ -36,7 +36,7 @@ $ENV{'PERL5_CPANPLUS_IS_VERSION'} = __PACKAGE__->VERSION; =head1 NAME -CPANPLUS::Backend +CPANPLUS::Backend - programmer's interface to CPANPLUS =head1 SYNOPSIS @@ -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; @@ -397,7 +397,7 @@ for my $func (qw[fetch extract install readme files distributions]) { return CPANPLUS::Backend::RV->new( function => $func, - ok => !$flag, + ok => ( !$flag ? 1 : 0 ), rv => $href, args => \%hash, ); @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Backend/RV.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Backend/RV.pm index e861a093a27..4a7dec12f0d 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Backend/RV.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Backend/RV.pm @@ -19,7 +19,7 @@ local $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Backend::RV +CPANPLUS::Backend::RV - return value objects =head1 SYNOPSIS @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Config.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Config.pm index 5cf11d3e732..e148b8fca75 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Config.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Config.pm @@ -18,25 +18,26 @@ use File::Basename qw[dirname]; use IPC::Cmd qw[can_run]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; use Module::Load::Conditional qw[check_install]; +use version; =pod =head1 NAME -CPANPLUS::Config +CPANPLUS::Config - configuration defaults and heuristics for CPANPLUS =head1 SYNOPSIS ### conf object via CPANPLUS::Backend; $cb = CPANPLUS::Backend->new; $conf = $cb->configure_object; - + ### or as a standalone object $conf = CPANPLUS::Configure->new; ### values in 'conf' section - $verbose = $conf->get_conf( 'verbose' ); + $verbose = $conf->get_conf( 'verbose' ); $conf->set_conf( verbose => 1 ); ### values in 'program' section @@ -45,7 +46,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 +63,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 +140,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 @@ -149,6 +150,19 @@ are run interactively or not. Defaults to 'true'. $Conf->{'conf'}->{'allow_build_interactivity'} = 1; +=item allow_unknown_prereqs + +Boolean flag to indicate that unresolvable prereqs are acceptable. +If C<true> then only warnings will be issued (the behaviour before 0.9114) +when a module is unresolvable from any our sources (CPAN and/or +C<custom_sources>). If C<false> then an unresolvable prereq will fail +during the C<prepare> stage of distribution installation. +Defaults to C<true>. + +=cut + + $Conf->{'conf'}->{'allow_unknown_prereqs'} = 1; + =item base The directory CPANPLUS keeps all its build and state information in. @@ -199,7 +213,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 +228,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 +245,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 +255,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 +317,7 @@ installed, 'false' otherwise. =cut - $Conf->{'conf'}->{'md5'} = ( + $Conf->{'conf'}->{'md5'} = ( check_install( module => 'Digest::SHA' ) ? 1 : 0 ); =item no_update @@ -326,8 +340,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,22 +349,22 @@ 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' ) ) + check_install( module => INSTALLER_BUILD, version => '0.60' ) ) ? 0 : 1 ); =item prereqs @@ -382,7 +396,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 +406,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 +431,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 +451,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 +478,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 +488,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 +524,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 +534,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 +548,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 +564,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,36 +586,38 @@ 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; }; =item perlwrapper +B<DEPRECATED> + A string holding the path to the C<cpanp-run-perl> utility bundled with CPANPLUS, which is used to enable autoflushing in spawned processes. =cut - ### perlwrapper that allows us to turn on autoflushing - $Conf->{'program'}->{'perlwrapper'} = sub { + ### 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 +634,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 +652,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 +676,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 +686,21 @@ 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; - + + ### CPANPLUS::Dist::MM doesn't require this anymore + ### but CPANPLUS::Dist::Build might if it is less than 0.60 + my $cpdb = check_install( module => INSTALLER_BUILD ); + return '' unless + $cpdb and eval { version->parse($cpdb->{version}) < version->parse('0.60') }; + ### if not, warn about it and give sensible default. - ### XXX try to be a no-op instead then.. + ### 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 +712,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 +741,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 +765,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 +800,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/Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm index ba1ca0785ac..04a08753d55 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm +++ b/Master/tlpkg/tlperl/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}; - } + } } @@ -39,7 +39,7 @@ for my $meth ( qw[conf _lib _perl5lib]) { =head1 NAME -CPANPLUS::Configure +CPANPLUS::Configure - configuration for CPANPLUS =head1 SYNOPSIS @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm index b6f34f2a521..7720d853083 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm +++ b/Master/tlpkg/tlperl/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/Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm index 20c74fcd4ad..5df2ef0c64f 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm @@ -22,7 +22,7 @@ local $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Dist +CPANPLUS::Dist - base class for plugins =head1 SYNOPSIS @@ -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 ) { @@ -523,7 +529,7 @@ sub _resolve_prereqs { my $conf = $cb->configure_object; my %hash = @_; - my ($prereqs, $format, $verbose, $target, $force, $prereq_build); + my ($prereqs, $format, $verbose, $target, $force, $prereq_build,$tolerant); my $tmpl = { ### XXX perhaps this should not be required, since it may not be ### packaged, just installed... @@ -543,6 +549,8 @@ sub _resolve_prereqs { target => { default => '', store => \$target, allow => ['',qw[create ignore install]] }, prereq_build => { default => 0, store => \$prereq_build }, + tolerant => { default => $conf->get_conf('allow_unknown_prereqs'), + store => \$tolerant }, }; check( $tmpl, \%hash ) or return; @@ -594,6 +602,8 @@ sub _resolve_prereqs { ### list of module objects + desired versions my @install_me; + my $flag; + for my $mod ( @sorted_prereqs ) { ( my $version = $prereqs->{$mod} ) =~ s#[^0-9\._]+##g; @@ -626,6 +636,7 @@ sub _resolve_prereqs { my $core = $sub->( $mod ); unless ( defined $core ) { error( loc( "No such module '%1' found on CPAN", $mod ) ); + $flag++ unless $tolerant; next; } if ( $cb->_vcmp( $version, $core ) > 0 ) { @@ -684,7 +695,6 @@ sub _resolve_prereqs { } } - my $flag; for my $aref (@install_me) { my($modobj,$version) = @$aref; diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Autobundle.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Autobundle.pm index 9561dd9f325..546f1ba6382 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Autobundle.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Autobundle.pm @@ -10,7 +10,7 @@ use base qw[CPANPLUS::Dist::Base]; =head1 NAME -CPANPLUS::Dist::Autobundle +CPANPLUS::Dist::Autobundle - distribution class for installation snapshots =head1 SYNOPSIS @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Base.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Base.pm index 904ab172266..8e4e02f1f50 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Base.pm +++ b/Master/tlpkg/tlperl/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/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build.pm index 164bcb0a9ec..702d606115b 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build.pm @@ -10,7 +10,7 @@ use CPANPLUS::Internals::Constants; ### these constants were exported by CPANPLUS::Internals::Constants ### in previous versions.. they do the same though. If we want to have ### a normal 'use' here, up the dependency to CPANPLUS 0.056 or higher -BEGIN { +BEGIN { require CPANPLUS::Dist::Build::Constants; CPANPLUS::Dist::Build::Constants->import() if not __PACKAGE__->can('BUILD') && __PACKAGE__->can('BUILD_DIR'); @@ -30,7 +30,7 @@ use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; local $Params::Check::VERBOSE = 1; -$VERSION = '0.54'; +$VERSION = '0.62'; =pod @@ -44,8 +44,8 @@ CPANPLUS::Dist::Build - CPANPLUS plugin to install packages that use Build.PL format => 'CPANPLUS::Dist::Build', module => $modobj, ); - - $build->prepare; # runs Build.PL + + $build->prepare; # runs Build.PL $build->create; # runs build && build test $build->install; # runs build install @@ -58,7 +58,7 @@ Using this package, you can create, install and uninstall perl modules. It inherits from C<CPANPLUS::Dist>. Normal users won't have to worry about the interface to this module, -as it functions transparently as a plug-in to C<CPANPLUS> and will +as it functions transparently as a plug-in to C<CPANPLUS> and will just C<Do The Right Thing> when it's loaded. =head1 ACCESSORS @@ -104,7 +104,7 @@ This gets set after C<perl Build.PL> =item C<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 C<created ()> @@ -184,11 +184,11 @@ sub init { =head2 $bool = $dist->prepare([perl => '/path/to/perl', buildflags => 'EXTRA=FLAGS', force => BOOL, verbose => BOOL]) -C<prepare> prepares a distribution, running C<Build.PL> +C<prepare> prepares a distribution, running C<Build.PL> and establishing any prerequisites this distribution has. -The variable C<PERL5_CPANPLUS_IS_EXECUTING> will be set to the full path +The variable C<PERL5_CPANPLUS_IS_EXECUTING> will be set to the full path of the C<Build.PL> that is being executed. This enables any code inside the C<Build.PL> to know that it is being installed via CPANPLUS. @@ -232,9 +232,9 @@ sub prepare { perl => { default => $^X, store => \$perl }, buildflags => { default => $conf->get_conf('buildflags'), store => \$buildflags }, - prereq_target => { default => '', store => \$prereq_target }, + prereq_target => { default => '', store => \$prereq_target }, prereq_format => { default => '', - store => \$prereq_format }, + store => \$prereq_format }, prereq_build => { default => 0, store => \$prereq_build }, }; @@ -269,7 +269,8 @@ sub prepare { my @buildflags = $dist->_buildflags_as_list( $buildflags ); $dist->status->_buildflags( $buildflags ); - my $fail; + my $fail; my $prereq_fail; + my $status = { }; RUN: { # 0.85_01 ### we resolve 'configure requires' here, so we can run the 'perl @@ -281,7 +282,7 @@ sub prepare { ### containing a makefile.pl/build.pl for test purposes? my $safe_ver = version->new('0.85_01'); if ( version->new($CPANPLUS::Internals::VERSION) >= $safe_ver ) - { my $configure_requires = $dist->find_configure_requires; + { my $configure_requires = $dist->find_configure_requires; my $ok = $dist->_resolve_prereqs( format => $prereq_format, verbose => $verbose, @@ -289,18 +290,19 @@ 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++; + $prereq_fail++; + $fail++; last RUN; - } + } ### end of prereq resolving ### } @@ -310,14 +312,18 @@ sub prepare { my $env = ENV_CPANPLUS_IS_EXECUTING; local $ENV{$env} = BUILD_PL->( $dir ); - my $run_perl = $conf->get_program('perlwrapper'); - my $cmd = [$perl, $run_perl, BUILD_PL->($dir), @buildflags]; + my @run_perl = ( '-e', CPDB_PERL_WRAPPER ); + my $cmd = [$perl, @run_perl, BUILD_PL->($dir), @buildflags]; unless ( scalar run( command => $cmd, buffer => \$prep_output, - verbose => $verbose ) + verbose => $verbose ) ) { error( loc( "Build.PL failed: %1", $prep_output ) ); + if ( $conf->get_conf('cpantest') ) { + $status->{stage} = 'prepare'; + $status->{capture} = $prep_output; + } $fail++; last RUN; } @@ -325,19 +331,20 @@ sub prepare { my $prereqs = $self->status->prereqs; - $prereqs ||= $dist->_find_prereqs( verbose => $verbose, - dir => $dir, + $prereqs ||= $dist->_find_prereqs( verbose => $verbose, + dir => $dir, perl => $perl, buildflags => $buildflags ); } - + ### send out test report? ### - if( $fail and $conf->get_conf('cpantest') ) { - $cb->_send_report( + if( $fail and $conf->get_conf('cpantest') and not $prereq_fail ) { + $cb->_send_report( module => $self, failed => $fail, buffer => CPANPLUS::Error->stack_as_string, + status => $status, verbose => $verbose, force => $force, ) or error(loc("Failed to send test report for '%1'", @@ -370,7 +377,7 @@ sub _find_prereqs { buildflags => { default => $conf->get_conf('buildflags'), store => \$buildflags }, }; - + my $args = check( $tmpl, \%hash ) or return; my $prereqs = {}; @@ -389,11 +396,11 @@ sub _find_prereqs { my @buildflags = $dist->_buildflags_as_list( $buildflags ); # Use the new Build action 'prereq_data' - my $run_perl = $conf->get_program('perlwrapper'); + my @run_perl = ( '-e', CPDB_PERL_WRAPPER ); - unless ( scalar run( command => [$perl, $run_perl, BUILD->($dir), 'prereq_data', @buildflags], + unless ( scalar run( command => [$perl, @run_perl, BUILD->($dir), 'prereq_data', @buildflags], buffer => \$content, - verbose => 0 ) + verbose => 0 ) ) { error( loc( "Build 'prereq_data' failed: %1 %2", $!, $content ) ); #return; @@ -413,7 +420,7 @@ sub _find_prereqs { error( loc( "Cannot open '%1': %2", $file, $! ) ); return; } - + $content = do { local $/; <$fh> }; } @@ -511,7 +518,7 @@ sub create { prereq_format => { #default => $self->status->installer_type, default => '', store => \$prereq_format }, - prereq_build => { default => 0, store => \$prereq_build }, + prereq_build => { default => 0, store => \$prereq_build }, }; $args = check( $tmpl, \%hash ) or return; @@ -567,9 +574,10 @@ sub create { $dist->status->_buildflags( $buildflags ); my $fail; my $prereq_fail; my $test_fail; + my $status = { }; RUN: { - my $run_perl = $conf->get_program('perlwrapper'); + my @run_perl = ( '-e', CPDB_PERL_WRAPPER ); ### this will set the directory back to the start ### dir, so we must chdir /again/ @@ -601,15 +609,19 @@ sub create { $cmd = [$perl, BUILD->($dir), @buildflags]; } else { - $cmd = [$perl, $run_perl, BUILD->($dir), @buildflags]; + $cmd = [$perl, @run_perl, BUILD->($dir), @buildflags]; } unless ( scalar run( command => $cmd, buffer => \$captured, - verbose => $verbose ) + verbose => $verbose ) ) { error( loc( "MAKE failed:\n%1", $captured ) ); $dist->status->build(0); + if ( $conf->get_conf('cpantest') ) { + $status->{stage} = 'build'; + $status->{capture} = $captured; + } $fail++; last RUN; } @@ -620,8 +632,8 @@ sub create { ### add this directory to your lib ### $self->add_to_includepath(); - ### this buffer will not include what tests failed due to a - ### M::B/Test::Harness bug. Reported as #9793 with patch + ### this buffer will not include what tests failed due to a + ### M::B/Test::Harness bug. Reported as #9793 with patch ### against 0.2607 on 26/1/2005 unless( $skiptest ) { my $test_output; @@ -629,13 +641,13 @@ sub create { $cmd = [$perl, BUILD->($dir), "test", @buildflags]; } else { - $cmd = [$perl, $run_perl, BUILD->($dir), "test", @buildflags]; + $cmd = [$perl, @run_perl, BUILD->($dir), "test", @buildflags]; } unless ( scalar run( command => $cmd, buffer => \$test_output, - verbose => $verbose ) + verbose => $verbose ) ) { - error( loc( "MAKE TEST failed:\n%1 ", $test_output ) ); + error( loc( "MAKE TEST failed:\n%1 ", $test_output ), ( $verbose ? 0 : 1 ) ); ### mark specifically *test* failure.. so we dont ### send success on force... @@ -645,16 +657,23 @@ sub create { $self, $@ ) ) { $dist->status->test(0); + if ( $conf->get_conf('cpantest') ) { + $status->{stage} = 'test'; + $status->{capture} = $test_output; + } $fail++; last RUN; } - } + } else { msg( loc( "MAKE TEST passed:\n%1", $test_output ), 0 ); - #msg( $test_output, 0 ); $dist->status->test(1); + if ( $conf->get_conf('cpantest') ) { + $status->{stage} = 'test'; + $status->{capture} = $test_output; + } } - } + } else { msg(loc("Tests skipped"), $verbose); } @@ -670,6 +689,7 @@ sub create { module => $self, failed => $test_fail || $fail, buffer => CPANPLUS::Error->stack_as_string, + status => $status, verbose => $verbose, force => $force, tests_skipped => $skiptest, @@ -702,7 +722,7 @@ sub install { my $conf = $cb->configure_object; my %hash = @_; - + my $verbose; my $perl; my $force; my $buildflags; { local $Params::Check::ALLOW_UNKNOWN = 1; my $tmpl = { @@ -714,7 +734,7 @@ sub install { store => \$buildflags }, perl => { default => $^X, store => \$perl }, }; - + my $args = check( $tmpl, \%hash ) or return; $dist->status->_install_args( $args ); } @@ -733,7 +753,7 @@ sub install { } ### value set and false -- means failure ### - if( defined $self->status->installed && + if( defined $self->status->installed && !$self->status->installed && !$force ) { error( loc( "Module '%1' has failed to install before this session " . @@ -743,7 +763,7 @@ sub install { my $fail; my @buildflags = $dist->_buildflags_as_list( $buildflags ); - my $run_perl = $conf->get_program('perlwrapper'); + my @run_perl = ( '-e', CPDB_PERL_WRAPPER ); ### hmm, how is this going to deal with sudo? ### for now, check effective uid, if it's not root, @@ -758,11 +778,19 @@ sub install { $cmd = [$perl, BUILD->($dir), "install", @buildflags]; } else { - $cmd = [$perl, $run_perl, BUILD->($dir), "install", @buildflags]; + $cmd = [$perl, @run_perl, BUILD->($dir), "install", @buildflags]; } - my $sudo = $conf->get_program('sudo'); - unshift @$cmd, $sudo if $sudo; + ### Detect local::lib type behaviour. Do not use 'sudo' in these cases + my $sudo = $conf->get_program('sudo'); + SUDO: { + ### Actual local::lib in use + last SUDO if defined $ENV{PERL_MB_OPT} and $ENV{PERL_MB_OPT} =~ m!install_base!; + ### 'buildflags' is configured with '--install_base' + last SUDO if scalar grep { m!install_base! } @buildflags; + ### oh well 'sudo make me a sandwich' + unshift @$cmd, $sudo; + } my $buffer; unless( scalar run( command => $cmd, @@ -778,7 +806,7 @@ sub install { $cmd = [$perl, BUILD->($dir), "install", @buildflags]; } else { - $cmd = [$perl, $run_perl, BUILD->($dir), "install", @buildflags]; + $cmd = [$perl, @run_perl, BUILD->($dir), "install", @buildflags]; } unless( scalar run( command => $cmd, buffer => \$install_output, diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build/Constants.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build/Constants.pm index ba1ca8665c0..c0fa040ffc5 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build/Constants.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build/Constants.pm @@ -8,28 +8,31 @@ BEGIN { require Exporter; use vars qw[$VERSION @ISA @EXPORT]; - - $VERSION = '0.54'; + + $VERSION = '0.62'; @ISA = qw[Exporter]; - @EXPORT = qw[ BUILD_DIR BUILD ]; + @EXPORT = qw[ BUILD_DIR BUILD CPDB_PERL_WRAPPER]; } use constant BUILD_DIR => sub { return @_ ? File::Spec->catdir($_[0], '_build') : '_build'; - }; + }; use constant BUILD => sub { my $file = @_ ? File::Spec->catfile($_[0], 'Build') : 'Build'; - + ### on VMS, '.com' is appended when ### creating the Build file - $file .= '.com' if $^O eq 'VMS'; - + $file .= '.com' if $^O eq 'VMS'; + return $file; }; - + + +use constant CPDB_PERL_WRAPPER => 'use strict; BEGIN { my $old = select STDERR; $|++; select $old; $|++; $0 = shift(@ARGV); my $rv = do($0); die $@ if $@; }'; + 1; =head1 NAME diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/MM.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/MM.pm index b2205e46f0b..cd428691bcf 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/MM.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/MM.pm @@ -23,12 +23,12 @@ local $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Dist::MM +CPANPLUS::Dist::MM - distribution class for MakeMaker related modules =head1 SYNOPSIS $mm = CPANPLUS::Dist::MM->new( module => $modobj ); - + $mm->create; # runs make && make test $mm->install; # runs make install @@ -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,116 +274,104 @@ 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 ### at bootstrap time properly. - ### 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 ] . - # QUOTE_PERL_ONE_LINER->( - # qq[\$OUTPUT_AUTOFLUSH++,do(q($makefile_pl))] - # ) - # . $mmflags; - - # my $flush = OPT_AUTOFLUSH; - # my $cmd = "$perl $flush $makefile_pl $mmflags"; - - my $run_perl = $conf->get_program('perlwrapper'); - my $cmd = [$perl, $run_perl, $makefile_pl, @mmflags]; + my @run_perl = ( '-e', PERL_WRAPPER ); + my $cmd = [$perl, @run_perl, $makefile_pl, @mmflags]; ### set ENV var to tell underlying code this is what we're ### executing. - my $captured; + my $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 +379,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 +395,50 @@ 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) ); + + ### Make (haha) sure that Makefile.PL is older than the Makefile + ### we just generated. + eval { + my $makestat = ( stat MAKEFILE->( $dir ) )[9]; + my $mplstat = ( stat MAKEFILE_PL->( $cb->_safe_path( path => $dir ) ) )[9]; + if ( $makestat < $mplstat ) { + my $ftime = $makestat - 60; + utime $ftime, $ftime, MAKEFILE_PL->( $cb->_safe_path( path => $dir ) ); + } + }; + ### start resolving prereqs ### my $prereqs = $self->status->prereqs; - + ### a hashref of prereqs on success, undef on failure ### - $prereqs ||= $dist->_find_prereqs( + $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 +466,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 +495,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 +504,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 +535,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 +550,64 @@ 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; + my $status = { }; 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,44 @@ 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 ) ); + if ( $conf->get_conf('cpantest') ) { + $status->{stage} = 'build'; + $status->{capture} = $captured; + } $dist->status->make(0); $fail++; last RUN; } - + ### put the output on the stack, don't print it msg( $captured, 0 ); @@ -657,12 +661,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 +677,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,47 +699,59 @@ sub create { } else { msg( loc( "MAKE TEST passed: %1", $captured ), 0 ); } - + + if ( $conf->get_conf('cpantest') ) { + $status->{stage} = 'test'; + $status->{capture} = $captured; + } + $dist->status->test(1); } else { - error( loc( "MAKE TEST failed: %1", $captured ) ); - + error( loc( "MAKE TEST failed: %1", $captured ), ( $run_verbose ? 0 : 1 ) ); + + if ( $conf->get_conf('cpantest') ) { + $status->{stage} = 'test'; + $status->{capture} = $captured; + } + ### send out error report here? or do so at a higher level? ### --higher level --kane. $dist->status->test(0); - + ### mark specifically *test* failure.. so we dont ### send success on force... $test_fail++; - + if( !$force and !$cb->_callbacks->proceed_on_test_failure->( - $self, $captured ) + $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 ) ); - } - + } + + ### TODO: Add $stage to _send_report() ### send out test report? ### only do so if the failure is this module, not its prereq if( $conf->get_conf('cpantest') and not $prereq_fail) { - $cb->_send_report( + $cb->_send_report( module => $self, failed => $test_fail || $fail, buffer => CPANPLUS::Error->stack_as_string, + status => $status, verbose => $verbose, force => $force, ) or error(loc("Failed to send test report for '%1'", $self->module ) ); - } - + } + return $dist->status->created( $fail ? 0 : 1); -} +} =pod @@ -744,7 +760,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 +770,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 +837,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 +873,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 +885,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 +915,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 +975,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 +984,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 +1014,7 @@ sub dist_dir { return if $fail; return $distdir; -} +} 1; diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Error.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Error.pm index c42435f1922..968cead5605 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Error.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Error.pm @@ -8,7 +8,7 @@ use Log::Message private => 0;; =head1 NAME -CPANPLUS::Error +CPANPLUS::Error - error handling for CPANPLUS =head1 SYNOPSIS @@ -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, @@ -143,7 +143,8 @@ local $| = 1; $ERROR_FH = \*STDERR; $MSG_FH = \*STDOUT; -package Log::Message::Handlers; +package # Hide from Pause + Log::Message::Handlers; use Carp (); { diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/FAQ.pod b/Master/tlpkg/tlperl/lib/CPANPLUS/FAQ.pod index 82bb57aaf47..00c186ab0d7 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/FAQ.pod +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/FAQ.pod @@ -2,6 +2,10 @@ =head1 NAME +CPANPLUS::FAQ - CPANPLUS Frequently Asked Questions + +=head1 NAME + CPANPLUS::FAQ =head1 DESCRIPTION @@ -20,10 +24,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/Master/tlpkg/tlperl/lib/CPANPLUS/Hacking.pod b/Master/tlpkg/tlperl/lib/CPANPLUS/Hacking.pod index 6a754fb25ee..c226b071691 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Hacking.pod +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Hacking.pod @@ -2,7 +2,7 @@ =head1 NAME -CPANPLUS::Hacking +CPANPLUS::Hacking - developing CPANPLUS =head1 DESCRIPTION @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals.pm index 4756421a4ad..e9f97bfa2a1 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals.pm @@ -42,13 +42,13 @@ use vars qw[@ISA $VERSION]; CPANPLUS::Internals::Report ]; -$VERSION = "0.9103"; +$VERSION = "0.9121"; =pod =head1 NAME -CPANPLUS::Internals +CPANPLUS::Internals - CPANPLUS internals =head1 SYNOPSIS @@ -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; @@ -268,7 +268,7 @@ be flushed. ### File::Fetch's method fail list } elsif ( $what eq 'methods' ) { - ### still fucking p4 :( ### + ### still unbelievably p4 :( ### $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {}; ### blow away the m::l::c cache, so modules can be (re)loaded @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants.pm index 443d5a4ca8a..bd48a1db8c6 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants.pm +++ b/Master/tlpkg/tlperl/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,64 +318,65 @@ 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 PERL_WRAPPER => 'use strict; BEGIN { my $old = select STDERR; $|++; select $old; $|++; $0 = shift(@ARGV); my $rv = do($0); die $@ if $@; }'; use constant STORABLE_EXT => '.stored'; use constant GET_XS_FILES => sub { my $dir = $_[0] or return; require File::Find; my @files; - File::Find::find( + 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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants/Report.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants/Report.pm index abdb3c98dd0..294de692369 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants/Report.pm +++ b/Master/tlpkg/tlperl/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. . @@ -200,15 +200,32 @@ $buffer . }; +use constant REPORT_MESSAGE_PASS_HEADER + => sub { + my($stage, $buffer) = @_; + return << "."; + +Thank you for uploading your work to CPAN. Congratulations! +All tests were successful. + +TEST RESULTS: + +Below is the error stack from stage '$stage': + +$buffer + +. + }; + use constant REPORT_MISSING_PREREQS => sub { my ($author,$email,@missing) = @_; - $author = ($author && $email) - ? "$author ($email)" + $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 +259,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 +283,7 @@ Thanks! :-) . }; -use constant REPORT_LOADED_PREREQS +use constant REPORT_LOADED_PREREQS => sub { my $mod = shift; my $cb = $mod->parent; @@ -274,13 +291,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 +305,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 +365,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 +393,7 @@ use constant REPORT_TESTS_SKIPPED . }; - + use constant REPORT_MESSAGE_FOOTER => sub { return << "."; @@ -384,7 +401,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 +410,7 @@ it personally. We appreciate your patience. :) ********************************************************************** Additional comments: - + . }; diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm index f30911bab88..2f8b730ca54 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm @@ -19,21 +19,21 @@ local $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Internals::Extract +CPANPLUS::Internals::Extract - internals for archive extraction =head1 SYNOPSIS ### for source files ### $self->_gunzip( file => 'foo.gz', output => 'blah.txt' ); - + ### for modules/packages ### - $dir = $self->_extract( module => $modobj, + $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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm index 7dcb3c366bb..f8a232e1f8e 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm @@ -19,7 +19,7 @@ $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Internals::Fetch +CPANPLUS::Internals::Fetch - internals for fetching files =head1 SYNOPSIS @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm index 73a2d297e2d..6e3cd5641dc 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm @@ -20,7 +20,7 @@ require CPANPLUS::Internals; =head1 NAME -CPANPLUS::Internals::Report +CPANPLUS::Internals::Report - internals for sending test reports =head1 SYNOPSIS @@ -297,11 +297,12 @@ sub _send_report { ### check arguments ### my ($buffer, $failed, $mod, $verbose, $force, $address, $save, - $tests_skipped ); + $tests_skipped, $status ); my $tmpl = { module => { required => 1, store => \$mod, allow => IS_MODOBJ }, buffer => { required => 1, store => \$buffer }, failed => { required => 1, store => \$failed }, + status => { default => {}, store => \$status, strict_type => 1 }, address => { default => CPAN_TESTERS_EMAIL, store => \$address }, save => { default => 0, store => \$save }, verbose => { default => $conf->get_conf('verbose'), @@ -471,8 +472,9 @@ sub _send_report { return 1 if $cp_conf =~ /\bmaketest_only\b/i and ($stage !~ /\btest\b/); + my $capture = ( $status && defined $status->{capture} ? $status->{capture} : $buffer ); ### the bit where we inform what went wrong - $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer ); + $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $capture ); ### was it missing prereqs? ### if( my @missing = MISSING_PREREQS_LIST->($buffer) ) { @@ -507,8 +509,34 @@ sub _send_report { $message .= REPORT_TESTS_SKIPPED->(); } elsif( $grade eq GRADE_NA) { + my $capture = ( $status && defined $status->{capture} ? $status->{capture} : $buffer ); + + ### add the reason for the NA to the buffer + $capture = join $/, $capture, map { + '[' . $_->tag . '] [' . $_->when . '] ' . + $_->message } ( CPANPLUS::Error->stack )[-1]; + ### the bit where we inform what went wrong - $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer ); + $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $capture ); + + ### add a list of what modules have been loaded of your prereqs list + $message .= REPORT_LOADED_PREREQS->($mod); + + ### add a list of versions of toolchain modules + $message .= REPORT_TOOLCHAIN_VERSIONS->($mod); + + ### the footer + $message .= REPORT_MESSAGE_FOOTER->(); + + } elsif ( $grade eq GRADE_PASS and ( $status and defined $status->{capture} ) ) { + ### the bit where we inform what went right + $message .= REPORT_MESSAGE_PASS_HEADER->( $stage, $status->{capture} ); + + ### add a list of what modules have been loaded of your prereqs list + $message .= REPORT_LOADED_PREREQS->($mod); + + ### add a list of versions of toolchain modules + $message .= REPORT_TOOLCHAIN_VERSIONS->($mod); ### the footer $message .= REPORT_MESSAGE_FOOTER->(); diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Search.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Search.pm index a93626b618e..6a5a6cf9a48 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Search.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Search.pm @@ -19,7 +19,7 @@ $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Internals::Search +CPANPLUS::Internals::Search - internals for searching for modules =head1 SYNOPSIS @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm index 96370046255..1f75535fa65 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm +++ b/Master/tlpkg/tlperl/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 @@ -74,7 +74,7 @@ $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Internals::Source +CPANPLUS::Internals::Source - internals for updating source files =head1 SYNOPSIS @@ -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} ); @@ -549,6 +549,16 @@ sub __create_author_tree { ### don't need it anymore ### unlink $out; + my ($tot,$prce,$prc,$idx); + + $args->{verbose} + and local $|=1, + $tot = scalar(split /\n/, $cont), + ($prce, $prc, $idx) = (int $tot / 25, 0, 0); + + $args->{verbose} + and print "\t0%"; + for ( split /\n/, $cont ) { my($id, $name, $email) = m/^alias \s+ (\S+) \s+ @@ -561,8 +571,24 @@ sub __create_author_tree { cpanid => $id, #authors CPAN ID ) or error( loc("Could not add author '%1'", $name ) ); + $args->{verbose} + and ( + $idx++, + + ($idx==$prce + and ($prc+=4,$idx=0,print ".")), + + (($prc % 10) + or $idx + or print $prc,'%') + ); + } + $args->{verbose} + and print "\n"; + + return $self->_atree; } #__create_author_tree @@ -636,9 +662,17 @@ sub _create_mod_tree { ### don't need it anymore ### unlink $out; - my($past_header, $count); - for ( split /\n/, $content ) { + my($past_header, $count, $tot, $prce, $prc, $idx); + + $args->{verbose} + and local $|=1, + $tot = scalar(split /\n/, $content), + ($prce, $prc, $idx) = (int $tot / 25, 0, 0); + + $args->{verbose} + and print "\t0%"; + for ( split /\n/, $content ) { ### quick hack to read past the header of the file ### ### this is still rather evil... fix some time - Kane if( m|^\s*$| ) { @@ -647,11 +681,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 +695,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 +738,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 +747,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], @@ -730,8 +764,23 @@ sub _create_mod_tree { mtime => '', ) or error( loc( "Could not add module '%1'", $data[0] ) ); + $args->{verbose} + and ( + $idx++, + + ($idx==$prce + and ($prc+=4,$idx=0,print ".")), + + (($prc % 10) + or $idx + or print $prc,'%') + ); + } #for + $args->{verbose} + and print "\n"; + return $self->_mtree; } #_create_mod_tree @@ -822,9 +871,9 @@ sub __create_dslip_tree { ### use this regex to make sure dslips with ';' in them don't cause ### parser errors my ($ds_one, $ds_two) = ($in =~ m|.+}\s+ - (\$(?:CPAN::Modulelist::)?cols.*?) - (\$(?:CPAN::Modulelist::)?data.*) - |sx); + (\$(?:CPAN::Modulelist::)?cols.*?) + (\$(?:CPAN::Modulelist::)?data.*) + |sx); ### eval them into existence ### ### still not too fond of this solution - kane ### @@ -925,7 +974,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 +986,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 +1003,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 +1034,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 +1051,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 +1080,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 +1102,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 +1130,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 +1146,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 +1173,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 +1216,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 +1228,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 +1236,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,68 +1249,69 @@ 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; + + my $res = do { local $File::Fetch::WARN = 0; + local $File::Fetch::TIMEOUT = $conf->get_conf('timeout'); $ff->fetch( to => $dir ); - }; + }; ### couldn't get the file unless( $res ) { - + ### it's not a local scheme, so can't auto index unless( $ff->scheme eq 'file' ) { error(loc("Could not update sources from '%1': %2", $remote, $ff->error )); - return; - + 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 +1323,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 +1355,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 +1367,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 +1451,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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm index cb3fd4f1e76..d589bbd1d8b 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm +++ b/Master/tlpkg/tlperl/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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite.pm index 556be6456d5..47bdbebfd77 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite.pm +++ b/Master/tlpkg/tlperl/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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm index f908c9803e4..7208e00ee11 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm +++ b/Master/tlpkg/tlperl/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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm index 31abaffed4d..e9651ed45fd 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm @@ -10,6 +10,7 @@ use File::Copy; use Params::Check qw[check]; use Module::Load::Conditional qw[can_load]; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use version; local $Params::Check::VERBOSE = 1; @@ -17,7 +18,7 @@ local $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Internals::Utils +CPANPLUS::Internals::Utils - convenience functions for CPANPLUS =head1 SYNOPSIS @@ -59,7 +60,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 +163,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; } @@ -199,7 +200,11 @@ sub _version_to_number { check( $tmpl, \%hash ) or return; - return $version if $version =~ /^\.?\d/; + $version =~ s!_!!g; # *sigh* + return $version if $version =~ /^\d*(?:\.\d+)?$/; + if ( my ($vers) = $version =~ /^(v?\d+(?:\.\d+(?:\.\d+)?)?)/ ) { + return eval { version->parse($vers)->numify }; + } return '0.0'; } @@ -282,7 +287,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 +316,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 +350,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,8 +378,9 @@ 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; + + $x = $self->_version_to_number(version => $x); + $y = $self->_version_to_number(version => $y); return $x <=> $y; } @@ -399,7 +405,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 +415,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 +454,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 +475,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 +494,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 +527,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 +552,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 +652,7 @@ sub _update_timestamp { error( loc("Couldn't touch %1", $file) ); return; } - + return 1; } diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm index 8d237efc050..4d470c6a71c 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm @@ -27,7 +27,7 @@ $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Module +CPANPLUS::Module - CPAN module objects for CPANPLUS =head1 SYNOPSIS @@ -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,15 +669,18 @@ 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; $type = INSTALLER_MM if $found_makefile && !$found_build; + # Special case Module::Build to always use INSTALLER_MM + $type = INSTALLER_MM if $self->package =~ m{^Module-Build-\d}; + } ### ok, so it's a 'build' installer, but you don't /have/ module build @@ -685,22 +688,22 @@ sub get_installer_type { if( $type and $type eq INSTALLER_BUILD and ( not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD ) or not $cb->module_tree( INSTALLER_BUILD ) - ->is_uptodate( version => '0.24' ) + ->is_uptodate( version => '0.60' ) ) ) { - + ### XXX this is for recording purposes only. We *have* to install ### these before even creating a dist object, or we'll get an error ### saying 'no such dist type'; ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow? my $href = $self->status->configure_requires || {}; - my $deps = { INSTALLER_BUILD, '0.24', %$href }; - + my $deps = { INSTALLER_BUILD, '0.60', %$href }; + $self->status->configure_requires( $deps ); - + msg(loc("This module requires '%1' and '%2' to be installed first. ". "Adding these modules to your prerequisites list", 'Module::Build', INSTALLER_BUILD - ), $verbose ); + ), $verbose ); ### ok, actually we found neither ### @@ -747,7 +750,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 +764,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 +785,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 +837,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 +845,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 +926,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 +967,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 +981,7 @@ sub install { $self->name, $self->name, $info->{name}, $info->{author}, $info->{url} )); - + return; } @@ -1028,10 +1031,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 +1042,8 @@ sub install { force => $args->{force}, ) or error(loc("Failed to send test report for '%1'", $self->module ) ); - } - + } + return; } else { @@ -1065,8 +1068,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 +1108,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 +1117,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 +1191,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 +1210,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 +1278,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 @@ -1288,6 +1291,10 @@ Returns a boolean indicating if this module is uptodate or not. @_, ); + ### Don't trust modules which are the result of @INC hooks + ### FatPacker uses this trickery and it causes WTF moments + return $alt_rv if defined $href->{dir} && ref $href->{dir}; + return $href->{$key} || $alt_rv; } } @@ -1349,7 +1356,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 +1373,7 @@ sub contains { my $pkg = $self->package; my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] ); - + return @mods; } @@ -1491,10 +1498,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 +1626,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 +1648,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 +1660,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 +1701,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 +1717,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 +1776,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 +1805,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/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm index 0daac6716d7..9ce12ebfde2 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm @@ -13,7 +13,7 @@ local $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Module::Author +CPANPLUS::Module::Author - CPAN author object for CPANPLUS =head1 SYNOPSIS @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm index 3156c5c7abb..0c844714981 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm @@ -17,7 +17,7 @@ $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Module::Author::Fake +CPANPLUS::Module::Author::Fake - dummy author object for CPANPLUS =head1 SYNOPSIS @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm index 3f9561e2dfe..8dde1cc0554 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm @@ -19,7 +19,7 @@ $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Module::Checksums +CPANPLUS::Module::Checksums - checking the checksum of a distribution =head1 SYNOPSIS @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm index 84d0233cf83..b0db1dae109 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm @@ -17,7 +17,7 @@ $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Module::Fake +CPANPLUS::Module::Fake - fake module object for internal use =head1 SYNOPSIS @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm index 6f2015c504c..26d3dc81f5b 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm @@ -13,25 +13,25 @@ $Params::Check::VERBOSE = 1; =head1 NAME -CPANPLUS::Selfupdate +CPANPLUS::Selfupdate - self-updating for CPANPLUS =head1 SYNOPSIS $su = $cb->selfupdate_object; - + @feats = $su->list_features; @feats = $su->list_enabled_features; - + @mods = map { $su->modules_for_feature( $_ ) } @feats; @mods = $su->list_core_dependencies; @mods = $su->list_core_modules; - + for ( @mods ) { print $_->name " should be version " . $_->version_required; - print "Installed version is not uptodate!" + print "Installed version is not uptodate!" unless $_->is_installed_version_sufficient; } - + $ok = $su->selfupdate( update => 'all', latest => 0 ); =cut @@ -49,8 +49,8 @@ CPANPLUS::Selfupdate 'Module::Load' => '0.10', 'Module::Load::Conditional' => '0.38', # returns dir for loaded # modules - 'version' => '0.73', # needed for M::L::C - # addresses #24630 and + 'version' => '0.77', # needed for M::L::C + # 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' ) - ? ( 'CPANPLUS::Dist::Build' => '0.24' ) : () ), + ( check_install( module => 'CPANPLUS::Dist::Build' ) + ? ( 'CPANPLUS::Dist::Build' => '0.60' ) : () ), }, - + 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' }; + : { 'CPANPLUS::Dist::Build' => '0.60' }; }, 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/Master/tlpkg/tlperl/lib/CPANPLUS/Shell.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell.pm index e3eb181c6dc..04735275121 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell.pm @@ -20,7 +20,7 @@ $DEFAULT = SHELL_DEFAULT; =head1 NAME -CPANPLUS::Shell +CPANPLUS::Shell - base class for CPANPLUS shells =head1 SYNOPSIS @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Classic.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Classic.pm index 08c03bcf383..089d3de16bd 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Classic.pm +++ b/Master/tlpkg/tlperl/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/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm index 35c02aff2b7..56dce061ae3 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm +++ b/Master/tlpkg/tlperl/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.9121"; } load CPANPLUS::Shell; @@ -56,6 +56,7 @@ my $map = { 'u' => '_uninstall', '/' => '_meta', # undocumented for now 'c' => '_reports', + 'e' => '_reload_shell', }; ### free letters: e g j k n y ### @@ -73,7 +74,7 @@ my $Prompt = $Brand . '> '; =head1 NAME -CPANPLUS::Shell::Default +CPANPLUS::Shell::Default - the default CPANPLUS shell =head1 SYNOPSIS @@ -119,8 +120,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 @@ -141,9 +142,10 @@ CPANPLUS::Shell::Default cpanp> w # show last search results again cpanp> q # quit the shell + cpanp> e # exit the shell and reload cpanp> /plugins # list available plugins - cpanp> /? PLUGIN # list help test of <PLUGIN> + cpanp> /? PLUGIN # list help test of <PLUGIN> ### common options: cpanp> i ... --skiptest # skip tests @@ -250,11 +252,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 +282,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 +306,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 +345,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 +379,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 +504,7 @@ sub __display_results { } else { $self->__print( loc("No results to display"), "\n" ); } - + return 1; } @@ -514,7 +516,7 @@ sub _quit { if defined $rc->{'logout'}; $self->__print( loc("Exiting CPANPLUS shell"), "\n" ); - + return 1; } @@ -529,21 +531,22 @@ 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' ), loc(' q # exit' ), +loc(' e # exit and reload' ), loc(' v # version information' ), loc('[Search]' ), loc(' a AUTHOR ... # search by author(s)' ), @@ -584,7 +587,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 +595,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 +763,7 @@ sub _fetch { $self->__print( "\n" ); } $self->_pager_close; - + return 1 if $rv; return; } @@ -860,16 +863,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 +909,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 +933,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 +964,7 @@ sub _install { $self->__print( loc("Module '%1' %tense(%2,past) successfully\n", $mod->module, $action) - ); + ); } else { $flag++; $self->__print( @@ -981,8 +984,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 +1004,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 +1028,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 +1067,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 +1085,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 +1128,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 +1138,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 +1202,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 +1241,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 +1251,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 +1275,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 +1293,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 +1334,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 +1370,7 @@ sub _set_conf { my $format = { conf => '%-25s %s', program => '%-12s %s', - }->{ $type }; + }->{ $type }; unless( $key ) { my @list = grep { $_ ne 'hosts' } @@ -1386,7 +1389,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 +1405,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 +1494,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 +1553,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 +1620,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 +1644,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 +1707,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 +1779,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 +1788,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 +1798,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 +1859,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 +1870,38 @@ 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; } -} +} + +sub _reload_shell { + { exec ($^X, '-MCPANPLUS', '-e', 'shell') }; print STDERR "couldn't exec foo: $!"; +} 1; @@ -1912,10 +1919,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/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm index 7b546819075..b602a547ac3 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm +++ b/Master/tlpkg/tlperl/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 - add custom sources to CPANPLUS =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/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod index ca765f9e0ac..8000aac9884 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod +++ b/Master/tlpkg/tlperl/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/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm index d2b829abded..9d14a5976dc 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm +++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm @@ -9,7 +9,7 @@ use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; =head1 NAME -CPANPLUS::Shell::Default::Plugins::Remote +CPANPLUS::Shell::Default::Plugins::Remote - connect to a remote CPANPLUS =head1 SYNOPSIS @@ -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/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Source.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Source.pm index 889b3d3d9bd..74c3582ffb4 100644 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Source.pm +++ b/Master/tlpkg/tlperl/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 - read in CPANPLUS commands =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 |