diff options
| author | Norbert Preining <preining@logic.at> | 2010-02-28 09:36:33 +0000 |
|---|---|---|
| committer | Norbert Preining <preining@logic.at> | 2010-02-28 09:36:33 +0000 |
| commit | 5589232e99f0fa13868111280c5b64ce9dc25730 (patch) | |
| tree | 28f2e6ff422108ac87934aff9c3fc5911963625c /Master/tlpkg/tlperl.straw/lib/CPANPLUS | |
| parent | a6f5de6eed80d66fbd23ceabda7edf22b8162236 (diff) | |
add a tlperl.straw directory for public inspection
git-svn-id: svn://tug.org/texlive/trunk@17235 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/CPANPLUS')
42 files changed, 21134 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Backend.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Backend.pm new file mode 100755 index 00000000000..a599e5429eb --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Backend.pm @@ -0,0 +1,1330 @@ +package CPANPLUS::Backend; + +use strict; + + +use CPANPLUS::Error; +use CPANPLUS::Configure; +use CPANPLUS::Internals; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Module; +use CPANPLUS::Module::Author; +use CPANPLUS::Backend::RV; + +use FileHandle; +use File::Spec (); +use File::Spec::Unix (); +use File::Basename (); +use Params::Check qw[check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +use vars qw[@ISA $VERSION]; + +@ISA = qw[CPANPLUS::Internals]; +$VERSION = $CPANPLUS::Internals::VERSION; + +### mark that we're running under CPANPLUS to spawned processes +$ENV{'PERL5_CPANPLUS_IS_RUNNING'} = $$; + +### XXX version.pm MAY format this version, if it's in use... :( +### so for consistency, just call ->VERSION ourselves as well. +$ENV{'PERL5_CPANPLUS_IS_VERSION'} = __PACKAGE__->VERSION; + +=pod + +=head1 NAME + +CPANPLUS::Backend + +=head1 SYNOPSIS + + my $cb = CPANPLUS::Backend->new; + my $conf = $cb->configure_object; + + my $author = $cb->author_tree('KANE'); + my $mod = $cb->module_tree('Some::Module'); + my $mod = $cb->parse_module( module => 'Some::Module' ); + + my @objs = $cb->search( type => TYPE, + allow => [...] ); + + $cb->flush('all'); + $cb->reload_indices; + $cb->local_mirror; + + +=head1 DESCRIPTION + +This module provides the programmer's interface to the C<CPANPLUS> +libraries. + +=head1 ENVIRONMENT + +When C<CPANPLUS::Backend> is loaded, which is necessary for just +about every <CPANPLUS> operation, the environment variable +C<PERL5_CPANPLUS_IS_RUNNING> is set to the current process id. + +Additionally, the environment variable C<PERL5_CPANPLUS_IS_VERSION> +will be set to the version of C<CPANPLUS::Backend>. + +This information might be useful somehow to spawned processes. + +=head1 METHODS + +=head2 $cb = CPANPLUS::Backend->new( [CONFIGURE_OBJ] ) + +This method returns a new C<CPANPLUS::Backend> object. +This also initialises the config corresponding to this object. +You have two choices in this: + +=over 4 + +=item Provide a valid C<CPANPLUS::Configure> object + +This will be used verbatim. + +=item No arguments + +Your default config will be loaded and used. + +=back + +New will return a C<CPANPLUS::Backend> object on success and die on +failure. + +=cut + +sub new { + my $class = shift; + my $conf; + + if( $_[0] && IS_CONFOBJ->( conf => $_[0] ) ) { + $conf = shift; + } else { + $conf = CPANPLUS::Configure->new() or return; + } + + my $self = $class->SUPER::_init( _conf => $conf ); + + return $self; +} + +=pod + +=head2 $href = $cb->module_tree( [@modules_names_list] ) + +Returns a reference to the CPANPLUS module tree. + +If you give it any arguments, they will be treated as module names +and C<module_tree> will try to look up these module names and +return the corresponding module objects instead. + +See L<CPANPLUS::Module> for the operations you can perform on a +module object. + +=cut + +sub module_tree { + my $self = shift; + my $modtree = $self->_module_tree; + + if( @_ ) { + my @rv; + for my $name ( grep { defined } @_) { + + ### From John Malmberg: This is failing on VMS + ### because ODS-2 does not retain the case of + ### filenames that are created. + ### The problem is the filename is being converted + ### to a module name and then looked up in the + ### %$modtree hash. + ### + ### As a fix, we do a search on VMS instead -- + ### more cpu cycles, but it gets around the case + ### problem --kane + my ($modobj) = do { + ON_VMS + ? $self->search( + type => 'module', + allow => [qr/^$name$/i], + ) + : $modtree->{$name} + }; + + push @rv, $modobj || ''; + } + return @rv == 1 ? $rv[0] : @rv; + } else { + return $modtree; + } +} + +=pod + +=head2 $href = $cb->author_tree( [@author_names_list] ) + +Returns a reference to the CPANPLUS author tree. + +If you give it any arguments, they will be treated as author names +and C<author_tree> will try to look up these author names and +return the corresponding author objects instead. + +See L<CPANPLUS::Module::Author> for the operations you can perform on +an author object. + +=cut + +sub author_tree { + my $self = shift; + my $authtree = $self->_author_tree; + + if( @_ ) { + my @rv; + for my $name (@_) { + push @rv, $authtree->{$name} || ''; + } + return @rv == 1 ? $rv[0] : @rv; + } else { + return $authtree; + } +} + +=pod + +=head2 $conf = $cb->configure_object; + +Returns a copy of the C<CPANPLUS::Configure> object. + +See L<CPANPLUS::Configure> for operations you can perform on a +configure object. + +=cut + +sub configure_object { return shift->_conf() }; + +=head2 $su = $cb->selfupdate_object; + +Returns a copy of the C<CPANPLUS::Selfupdate> object. + +See the L<CPANPLUS::Selfupdate> manpage for the operations +you can perform on the selfupdate object. + +=cut + +sub selfupdate_object { return shift->_selfupdate() }; + +=pod + +=head2 @mods = $cb->search( type => TYPE, allow => AREF, [data => AREF, verbose => BOOL] ) + +C<search> enables you to search for either module or author objects, +based on their data. The C<type> you can specify is any of the +accessors specified in C<CPANPLUS::Module::Author> or +C<CPANPLUS::Module>. C<search> will determine by the C<type> you +specified whether to search by author object or module object. + +You have to specify an array reference of regular expressions or +strings to match against. The rules used for this array ref are the +same as in C<Params::Check>, so read that manpage for details. + +The search is an C<or> search, meaning that if C<any> of the criteria +match, the search is considered to be successful. + +You can specify the result of a previous search as C<data> to limit +the new search to these module or author objects, rather than the +entire module or author tree. This is how you do C<and> searches. + +Returns a list of module or author objects on success and false +on failure. + +See L<CPANPLUS::Module> for the operations you can perform on a +module object. +See L<CPANPLUS::Module::Author> for the operations you can perform on +an author object. + +=cut + +sub search { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my ($type); + my $args = do { + local $Params::Check::NO_DUPLICATES = 0; + local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + type => { required => 1, allow => [CPANPLUS::Module->accessors(), + CPANPLUS::Module::Author->accessors()], store => \$type }, + allow => { required => 1, default => [ ], strict_type => 1 }, + }; + + check( $tmpl, \%hash ) + } or return; + + ### figure out whether it was an author or a module search + ### when ambiguous, it'll be an author search. + my $aref; + if( grep { $type eq $_ } CPANPLUS::Module::Author->accessors() ) { + $aref = $self->_search_author_tree( %$args ); + } else { + $aref = $self->_search_module_tree( %$args ); + } + + return @$aref if $aref; + return; +} + +=pod + +=head2 $backend_rv = $cb->fetch( modules => \@mods ) + +Fetches a list of modules. C<@mods> can be a list of distribution +names, module names or module objects--basically anything that +L<parse_module> can understand. + +See the equivalent method in C<CPANPLUS::Module> for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C<CPANPLUS::Backend::RV> object. Please consult +that module's documentation on how to interpret the return value. + +=head2 $backend_rv = $cb->extract( modules => \@mods ) + +Extracts a list of modules. C<@mods> can be a list of distribution +names, module names or module objects--basically anything that +L<parse_module> can understand. + +See the equivalent method in C<CPANPLUS::Module> for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C<CPANPLUS::Backend::RV> object. Please consult +that module's documentation on how to interpret the return value. + +=head2 $backend_rv = $cb->install( modules => \@mods ) + +Installs a list of modules. C<@mods> can be a list of distribution +names, module names or module objects--basically anything that +L<parse_module> can understand. + +See the equivalent method in C<CPANPLUS::Module> for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C<CPANPLUS::Backend::RV> object. Please consult +that module's documentation on how to interpret the return value. + +=head2 $backend_rv = $cb->readme( modules => \@mods ) + +Fetches the readme for a list of modules. C<@mods> can be a list of +distribution names, module names or module objects--basically +anything that L<parse_module> can understand. + +See the equivalent method in C<CPANPLUS::Module> for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C<CPANPLUS::Backend::RV> object. Please consult +that module's documentation on how to interpret the return value. + +=head2 $backend_rv = $cb->files( modules => \@mods ) + +Returns a list of files used by these modules if they are installed. +C<@mods> can be a list of distribution names, module names or module +objects--basically anything that L<parse_module> can understand. + +See the equivalent method in C<CPANPLUS::Module> for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C<CPANPLUS::Backend::RV> object. Please consult +that module's documentation on how to interpret the return value. + +=head2 $backend_rv = $cb->distributions( modules => \@mods ) + +Returns a list of module objects representing all releases for this +module on success. +C<@mods> can be a list of distribution names, module names or module +objects, basically anything that L<parse_module> can understand. + +See the equivalent method in C<CPANPLUS::Module> for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C<CPANPLUS::Backend::RV> object. Please consult +that module's documentation on how to interpret the return value. + +=cut + +### XXX add direcotry_tree, packlist etc? or maybe remove files? ### +for my $func (qw[fetch extract install readme files distributions]) { + no strict 'refs'; + + *$func = sub { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my ($mods); + my $args = do { + local $Params::Check::NO_DUPLICATES = 1; + local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { default => [], strict_type => 1, + required => 1, store => \$mods }, + }; + + check( $tmpl, \%hash ); + } or return; + + ### make them all into module objects ### + my %mods = map { $_ => $self->parse_module(module => $_) || '' } @$mods; + + my $flag; my $href; + while( my($name,$obj) = each %mods ) { + $href->{$name} = IS_MODOBJ->( mod => $obj ) + ? $obj->$func( %$args ) + : undef; + + $flag++ unless $href->{$name}; + } + + return CPANPLUS::Backend::RV->new( + function => $func, + ok => !$flag, + rv => $href, + args => \%hash, + ); + } +} + +=pod + +=head2 $mod_obj = $cb->parse_module( module => $modname|$distname|$modobj|URI|PATH ) + +C<parse_module> tries to find a C<CPANPLUS::Module> object that +matches your query. Here's a list of examples you could give to +C<parse_module>; + +=over 4 + +=item Text::Bastardize + +=item Text-Bastardize + +=item Text-Bastardize-1.06 + +=item AYRNIEU/Text-Bastardize + +=item AYRNIEU/Text-Bastardize-1.06 + +=item AYRNIEU/Text-Bastardize-1.06.tar.gz + +=item http://example.com/Text-Bastardize-1.06.tar.gz + +=item file:///tmp/Text-Bastardize-1.06.tar.gz + +=item /tmp/Text-Bastardize-1.06 + +=item ./Text-Bastardize-1.06 + +=item . + +=back + +These items would all come up with a C<CPANPLUS::Module> object for +C<Text::Bastardize>. The ones marked explicitly as being version 1.06 +would give back a C<CPANPLUS::Module> object of that version. +Even if the version on CPAN is currently higher. + +The last three are examples of PATH resolution. In the first, we supply +an absolute path to the unwrapped distribution. In the second the +distribution is relative to the current working directory. +In the third, we will use the current working directory. + +If C<parse_module> is unable to actually find the module you are looking +for in its module tree, but you supplied it with an author, module +and version part in a distribution name or URI, it will create a fake +C<CPANPLUS::Module> object for you, that you can use just like the +real thing. + +See L<CPANPLUS::Module> for the operations you can perform on a +module object. + +If even this fancy guessing doesn't enable C<parse_module> to create +a fake module object for you to use, it will warn about an error and +return false. + +=cut + +sub parse_module { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $mod; + my $tmpl = { + module => { required => 1, store => \$mod }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + return $mod if IS_MODOBJ->( module => $mod ); + + ### ok, so it's not a module object, but a ref nonetheless? + ### what are you smoking? + if( ref $mod ) { + error(loc("Can not parse module string from reference '%1'", $mod )); + return; + } + + ### check only for allowed characters in a module name + unless( $mod =~ /[^\w:]/ ) { + + ### perhaps we can find it in the module tree? + my $maybe = $self->module_tree($mod); + return $maybe if IS_MODOBJ->( module => $maybe ); + } + + ### Special case arbitary file paths such as '.' etc. + if ( $mod and -d File::Spec->rel2abs($mod) ) { + my $dir = File::Spec->rel2abs($mod); + my $parent = File::Spec->rel2abs( File::Spec->catdir( $dir, '..' ) ); + + ### fix paths on VMS + if (ON_VMS) { + $dir = VMS::Filespec::unixify($dir); + $parent = VMS::Filespec::unixify($parent); + } + + my $dist = $mod = File::Basename::basename($dir); + $dist .= '-0' unless $dist =~ /\-[0-9._]+$/; + $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/; + + my $modobj = CPANPLUS::Module::Fake->new( + module => $mod, + version => 0, + package => $dist, + path => $parent, + author => CPANPLUS::Module::Author::Fake->new + ); + + ### better guess for the version + $modobj->version( $modobj->package_version ) + if defined $modobj->package_version; + + ### better guess at module name, if possible + if ( my $pkgname = $modobj->package_name ) { + $pkgname =~ s/-/::/g; + + ### no sense replacing it unless we changed something + $modobj->module( $pkgname ) + if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/; + } + + $modobj->status->fetch( $parent ); + $modobj->status->extract( $dir ); + $modobj->get_installer_type; + return $modobj; + } + + ### ok, so it looks like a distribution then? + my @parts = split '/', $mod; + my $dist = pop @parts; + + ### ah, it's a URL + if( $mod =~ m|\w+://.+| ) { + my $modobj = CPANPLUS::Module::Fake->new( + module => $dist, + version => 0, + package => $dist, + path => File::Spec::Unix->catdir( + $conf->_get_mirror('base'), + UNKNOWN_DL_LOCATION ), + author => CPANPLUS::Module::Author::Fake->new + ); + + ### set the fetch_from accessor so we know to by pass the + ### usual mirrors + $modobj->status->_fetch_from( $mod ); + + ### better guess for the version + $modobj->version( $modobj->package_version ) + if defined $modobj->package_version; + + ### better guess at module name, if possible + if ( my $pkgname = $modobj->package_name ) { + $pkgname =~ s/-/::/g; + + ### no sense replacing it unless we changed something + $modobj->module( $pkgname ) + if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/; + } + + return $modobj; + } + + ### perhaps we can find it's a third party module? + { my $modobj = CPANPLUS::Module::Fake->new( + module => $mod, + version => 0, + package => $dist, + path => File::Spec::Unix->catdir( + $conf->_get_mirror('base'), + UNKNOWN_DL_LOCATION ), + author => CPANPLUS::Module::Author::Fake->new + ); + if( $modobj->is_third_party ) { + my $info = $modobj->third_party_information; + + $modobj->author->author( $info->{author} ); + $modobj->author->email( $info->{author_url} ); + $modobj->description( $info->{url} ); + + return $modobj; + } + } + + unless( $dist ) { + error( loc("%1 is not a proper distribution name!", $mod) ); + return; + } + + ### there's wonky uris out there, like this: + ### E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091 + ### compensate for that + my $author; + ### you probably have an A/AB/ABC/....../Dist.tgz type uri + if( (defined $parts[0] and length $parts[0] == 1) and + (defined $parts[1] and length $parts[1] == 2) and + $parts[2] =~ /^$parts[0]/i and $parts[2] =~ /^$parts[1]/i + ) { + splice @parts, 0, 2; # remove the first 2 entries from the list + $author = shift @parts; # this is the actual author name then + + ### we''ll assume a ABC/..../Dist.tgz + } else { + $author = shift @parts || ''; + } + + my($pkg, $version, $ext, $full) = + $self->_split_package_string( package => $dist ); + + ### translate a distribution into a module name ### + my $guess = $pkg; + $guess =~ s/-/::/g if $guess; + + my $maybe = $self->module_tree( $guess ); + if( IS_MODOBJ->( module => $maybe ) ) { + + ### maybe you asked for a package instead + if ( $maybe->package eq $mod ) { + return $maybe; + + ### perhaps an outdated version instead? + } elsif ( $version ) { + my $auth_obj; my $path; + + ### did you give us an author part? ### + if( $author ) { + $auth_obj = CPANPLUS::Module::Author::Fake->new( + _id => $maybe->_id, + cpanid => uc $author, + author => uc $author, + ); + $path = File::Spec::Unix->catdir( + $conf->_get_mirror('base'), + substr(uc $author, 0, 1), + substr(uc $author, 0, 2), + uc $author, + @parts, #possible sub dirs + ); + } else { + $auth_obj = $maybe->author; + $path = $maybe->path; + } + + if( $maybe->package_name eq $pkg ) { + + my $modobj = CPANPLUS::Module::Fake->new( + module => $maybe->module, + version => $version, + ### no extension? use the extension the original package + ### had instead + package => do { $ext + ? $full + : $full .'.'. $maybe->package_extension + }, + path => $path, + author => $auth_obj, + _id => $maybe->_id + ); + return $modobj; + + ### you asked for a specific version? + ### assume our $maybe is the one you wanted, + ### and fix up the version.. + } else { + + my $modobj = $maybe->clone; + $modobj->version( $version ); + $modobj->package( + $maybe->package_name .'-'. + $version .'.'. + $maybe->package_extension + ); + + ### you wanted a specific author, but it's not the one + ### from the module tree? we'll fix it up + if( $author and $author ne $modobj->author->cpanid ) { + $modobj->author( $auth_obj ); + $modobj->path( $path ); + } + + return $modobj; + } + + ### you didn't care about a version, so just return the object then + } elsif ( !$version ) { + return $maybe; + } + + ### ok, so we can't find it, and it's not an outdated dist either + ### perhaps we can fake one based on the author name and so on + } elsif ( $author and $version ) { + + ### be extra friendly and pad the .tar.gz suffix where needed + ### it's just a guess of course, but most dists are .tar.gz + $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/; + + ### XXX duplication from above for generating author obj + path... + my $modobj = CPANPLUS::Module::Fake->new( + module => $guess, + version => $version, + package => $dist, + author => CPANPLUS::Module::Author::Fake->new( + author => uc $author, + cpanid => uc $author, + _id => $self->_id, + ), + path => File::Spec::Unix->catdir( + $conf->_get_mirror('base'), + substr(uc $author, 0, 1), + substr(uc $author, 0, 2), + uc $author, + @parts, #possible subdirs + ), + _id => $self->_id, + ); + + return $modobj; + + ### face it, we have /no/ idea what he or she wants... + ### let's start putting the blame somewhere + } else { + + # Lets not give up too easily. There is one last chance + # http://perlmonks.org/?node_id=805957 + # This should catch edge-cases where the package name + # is unrelated to the modules it contains. + + my ($modobj) = grep { $_->package_name eq $mod } + $self->search( type => 'package', allow => [ qr/^\Q$mod\E/ ], ); + return $modobj if IS_MODOBJ->( module => $modobj ); + + unless( $author ) { + error( loc( "'%1' does not contain an author part", $mod ) ); + } + + error( loc( "Cannot find '%1' in the module tree", $mod ) ); + } + + return; +} + +=pod + +=head2 $bool = $cb->reload_indices( [update_source => BOOL, verbose => BOOL] ); + +This method reloads the source files. + +If C<update_source> is set to true, this will fetch new source files +from your CPAN mirror. Otherwise, C<reload_indices> will do its +usual cache checking and only update them if they are out of date. + +By default, C<update_source> will be false. + +The verbose setting defaults to what you have specified in your +config file. + +Returns true on success and false on failure. + +=cut + +sub reload_indices { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + my $tmpl = { + update_source => { default => 0, allow => [qr/^\d$/] }, + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### make a call to the internal _module_tree, so it triggers cache + ### file age + my $uptodate = $self->_check_trees( %$args ); + + + return 1 if $self->_build_trees( + uptodate => $uptodate, + use_stored => 0, + verbose => $conf->get_conf('verbose'), + ); + + error( loc( "Error rebuilding source trees!" ) ); + + return; +} + +=pod + +=head2 $bool = $cb->flush(CACHE_NAME) + +This method allows flushing of caches. +There are several things which can be flushed: + +=over 4 + +=item * C<methods> + +The return status of methods which have been attempted, such as +different ways of fetching files. It is recommended that automatic +flushing be used instead. + +=item * C<hosts> + +The return status of URIs which have been attempted, such as +different hosts of fetching files. It is recommended that automatic +flushing be used instead. + +=item * C<modules> + +Information about modules such as prerequisites and whether +installation succeeded, failed, or was not attempted. + +=item * C<lib> + +This resets PERL5LIB, which is changed to ensure that while installing +modules they are in our @INC. + +=item * C<load> + +This resets the cache of modules we've attempted to load, but failed. +This enables you to load them again after a failed load, if they +somehow have become available. + +=item * C<all> + +Flush all of the aforementioned caches. + +=back + +Returns true on success and false on failure. + +=cut + +sub flush { + my $self = shift; + my $type = shift or return; + + my $cache = { + methods => [ qw( methods load ) ], + hosts => [ qw( hosts ) ], + modules => [ qw( modules lib) ], + lib => [ qw( lib ) ], + load => [ qw( load ) ], + all => [ qw( hosts lib modules methods load ) ], + }; + + my $aref = $cache->{$type} + or ( + error( loc("No such cache '%1'", $type) ), + return + ); + + return $self->_flush( list => $aref ); +} + +=pod + +=head2 @mods = $cb->installed() + +Returns a list of module objects of all your installed modules. +If an error occurs, it will return false. + +See L<CPANPLUS::Module> for the operations you can perform on a +module object. + +=cut + +sub installed { + my $self = shift; + my $aref = $self->_all_installed; + + return @$aref if $aref; + return; +} + +=pod + +=head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] ) + +Creates a local mirror of CPAN, of only the most recent sources in a +location you specify. If you set this location equal to a custom host +in your C<CPANPLUS::Config> you can use your local mirror to install +from. + +It takes the following arguments: + +=over 4 + +=item path + +The location where to create the local mirror. + +=item index_files + +Enable/disable fetching of index files. You can disable fetching of the +index files if you don't plan to use the local mirror as your primary +site, or if you'd like up-to-date index files be fetched from elsewhere. + +Defaults to true. + +=item force + +Forces refetching of packages, even if they are there already. + +Defaults to whatever setting you have in your C<CPANPLUS::Config>. + +=item verbose + +Prints more messages about what its doing. + +Defaults to whatever setting you have in your C<CPANPLUS::Config>. + +=back + +Returns true on success and false on error. + +=cut + +sub local_mirror { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($path, $index, $force, $verbose); + my $tmpl = { + path => { default => $conf->get_conf('base'), + store => \$path }, + index_files => { default => 1, store => \$index }, + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + check( $tmpl, \%hash ) or return; + + unless( -d $path ) { + $self->_mkdir( dir => $path ) + or( error( loc( "Could not create '%1', giving up", $path ) ), + return + ); + } elsif ( ! -w _ ) { + error( loc( "Could not write to '%1', giving up", $path ) ); + return; + } + + my $flag; + AUTHOR: { + for my $auth ( sort { $a->cpanid cmp $b->cpanid } + values %{$self->author_tree} + ) { + + MODULE: { + my $i; + for my $mod ( $auth->modules ) { + my $fetchdir = File::Spec->catdir( $path, $mod->path ); + + my %opts = ( + verbose => $verbose, + force => $force, + fetchdir => $fetchdir, + ); + + ### only do this the for the first module ### + unless( $i++ ) { + $mod->_get_checksums_file( + %opts + ) or ( + error( loc( "Could not fetch %1 file, " . + "skipping author '%2'", + CHECKSUMS, $auth->cpanid ) ), + $flag++, next AUTHOR + ); + } + + $mod->fetch( %opts ) + or( error( loc( "Could not fetch '%1'", $mod->module ) ), + $flag++, next MODULE + ); + } } + } } + + if( $index ) { + for my $name (qw[auth dslip mod]) { + $self->_update_source( + name => $name, + verbose => $verbose, + path => $path, + ) or ( $flag++, next ); + } + } + + return !$flag; +} + +=pod + +=head2 $file = $cb->autobundle([path => OUTPUT_PATH, force => BOOL, verbose => BOOL]) + +Writes out a snapshot of your current installation in C<CPAN> bundle +style. This can then be used to install the same modules for a +different or on a different machine by issuing the following commands: + + ### using the default shell: + CPAN Terminal> i file://path/to/Snapshot_XXYY.pm + + ### using the API + $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' ); + $modobj->install; + +It will, by default, write to an 'autobundle' directory under your +cpanplus homedirectory, but you can override that by supplying a +C<path> argument. + +It will return the location of the output file on success and false on +failure. + +=cut + +sub autobundle { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($path,$force,$verbose); + my $tmpl = { + force => { default => $conf->get_conf('force'), store => \$force }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + path => { default => File::Spec->catdir( + $conf->get_conf('base'), + $self->_perl_version( perl => $^X ), + $conf->_get_build('distdir'), + $conf->_get_build('autobundle') ), + store => \$path }, + }; + + check($tmpl, \%hash) or return; + + unless( -d $path ) { + $self->_mkdir( dir => $path ) + or( error(loc("Could not create directory '%1'", $path ) ), + return + ); + } + + my $name; my $file; + { ### default filename for the bundle ### + my($year,$month,$day) = (localtime)[5,4,3]; + $year += 1900; $month++; + + my $ext = 0; + + my $prefix = $conf->_get_build('autobundle_prefix'); + my $format = "${prefix}_%04d_%02d_%02d_%02d"; + + BLOCK: { + $name = sprintf( $format, $year, $month, $day, $ext); + + $file = File::Spec->catfile( $path, $name . '.pm' ); + + -f $file ? ++$ext && redo BLOCK : last BLOCK; + } + } + my $fh; + unless( $fh = FileHandle->new( ">$file" ) ) { + error( loc( "Could not open '%1' for writing: %2", $file, $! ) ); + return; + } + + ### make sure we load the module tree *before* doing this, as it + ### starts to chdir all over the place + $self->module_tree; + + my $string = join "\n\n", + map { + join ' ', + $_->module, + ($_->installed_version(verbose => 0) || 'undef') + } sort { + $a->module cmp $b->module + } $self->installed; + + my $now = scalar localtime; + my $head = '=head1'; + my $pkg = __PACKAGE__; + my $version = $self->VERSION; + my $perl_v = join '', `$^X -V`; + + print $fh <<EOF; +package $name; + +\$VERSION = '0.01'; + +1; + +__END__ + +$head NAME + +$name - Snapshot of your installation at $now + +$head SYNOPSIS + +To install the modules from this snapshot, run: + + cpanp -i file://full/path/to/${name}.pm + +$head CONTENTS + +$string + +$head CONFIGURATION + +$perl_v + +$head AUTHOR + +This bundle has been generated autotomatically by + $pkg $version + +EOF + + close $fh; + + return $file; +} + +=head2 $bool = $cb->save_state + +Explicit command to save memory state to disk. This can be used to save +information to disk about where a module was extracted, the result of +C<make test>, etc. This will then be re-loaded into memory when a new +session starts. + +The capability of saving state to disk depends on the source engine +being used (See C<CPANPLUS::Config> for the option to choose your +source engine). The default storage engine supports this option. + +Most users will not need this command, but it can handy for automated +systems like setting up CPAN smoke testers. + +The method will return true if it managed to save the state to disk, +or false if it did not. + +=cut + +sub save_state { + my $self = shift; + return $self->_save_state( @_ ); +} + + +### XXX these wrappers are not individually tested! only the underlying +### code through source.t and indirectly trought he CustomSource plugin. +=pod + +=head1 CUSTOM MODULE SOURCES + +Besides the sources as provided by the general C<CPAN> mirrors, it's +possible to add your own sources list to your C<CPANPLUS> index. + +The methodology behind this works much like C<Debian's apt-sources>. + +The methods below show you how to make use of this functionality. Also +note that most of these methods are available through the default shell +plugin command C</cs>, making them available as shortcuts through the +shell and via the commandline. + +=head2 %files = $cb->list_custom_sources + +Returns a mapping of registered custom sources and their local indices +as follows: + + /full/path/to/local/index => http://remote/source + +Note that any file starting with an C<#> is being ignored. + +=cut + +sub list_custom_sources { + return shift->__list_custom_module_sources( @_ ); +} + +=head2 $local_index = $cb->add_custom_source( uri => URI, [verbose => BOOL] ); + +Adds an C<URI> to your own sources list and mirrors its index. See the +documentation on C<< $cb->update_custom_source >> on how this is done. + +Returns the full path to the local index on success, or false on failure. + +Note that when adding a new C<URI>, the change to the in-memory tree is +not saved until you rebuild or save the tree to disk again. You can do +this using the C<< $cb->reload_indices >> method. + +=cut + +sub add_custom_source { + return shift->_add_custom_module_source( @_ ); +} + +=head2 $local_index = $cb->remove_custom_source( uri => URI, [verbose => BOOL] ); + +Removes an C<URI> from your own sources list and removes its index. + +To find out what C<URI>s you have as part of your own sources list, use +the C<< $cb->list_custom_sources >> method. + +Returns the full path to the deleted local index file on success, or false +on failure. + +=cut + +### XXX do clever dispatching based on arg number? +sub remove_custom_source { + return shift->_remove_custom_module_source( @_ ); +} + +=head2 $bool = $cb->update_custom_source( [remote => URI] ); + +Updates the indexes for all your custom sources. It does this by fetching +a file called C<packages.txt> in the root of the custom sources's C<URI>. +If you provide the C<remote> argument, it will only update the index for +that specific C<URI>. + +Here's an example of how custom sources would resolve into index files: + + file:///path/to/sources => file:///path/to/sources/packages.txt + http://example.com/sources => http://example.com/sources/packages.txt + ftp://example.com/sources => ftp://example.com/sources/packages.txt + +The file C<packages.txt> simply holds a list of packages that can be found +under the root of the C<URI>. This file can be automatically generated for +you when the remote source is a C<file:// URI>. For C<http://>, C<ftp://>, +and similar, the administrator of that repository should run the method +C<< $cb->write_custom_source_index >> on the repository to allow remote +users to index it. + +For details, see the C<< $cb->write_custom_source_index >> method below. + +All packages that are added via this mechanism will be attributed to the +author with C<CPANID> C<LOCAL>. You can use this id to search for all +added packages. + +=cut + +sub update_custom_source { + my $self = shift; + + ### if it mentions /remote/, the request is to update a single uri, + ### not all the ones we have, so dispatch appropriately + my $rv = grep( /remote/i, @_) + ? $self->__update_custom_module_source( @_ ) + : $self->__update_custom_module_sources( @_ ); + + return $rv; +} + +=head2 $file = $cb->write_custom_source_index( path => /path/to/package/root, [to => /path/to/index/file, verbose => BOOL] ); + +Writes the index for a custom repository root. Most users will not have to +worry about this, but administrators of a repository will need to make sure +their indexes are up to date. + +The index will be written to a file called C<packages.txt> in your repository +root, which you can specify with the C<path> argument. You can override this +location by specifying the C<to> argument, but in normal operation, that should +not be required. + +Once the index file is written, users can then add the C<URI> pointing to +the repository to their custom list of sources and start using it right away. See the C<< $cb->add_custom_source >> method for user details. + +=cut + +sub write_custom_source_index { + return shift->__write_custom_module_index( @_ ); +} + +1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>, +L<CPANPLUS::Selfupdate> + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + +__END__ + +todo: +sub dist { # not sure about this one -- probably already done + enough in Module.pm +sub reports { # in Module.pm, wrapper here + + diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Backend/RV.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Backend/RV.pm new file mode 100755 index 00000000000..9edbe0452c9 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Backend/RV.pm @@ -0,0 +1,144 @@ +package CPANPLUS::Backend::RV; + +use strict; +use vars qw[$STRUCT]; + + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use IPC::Cmd qw[can_run run]; +use Params::Check qw[check]; + +use base 'Object::Accessor'; + +local $Params::Check::VERBOSE = 1; + + +=pod + +=head1 NAME + +CPANPLUS::Backend::RV + +=head1 SYNOPSIS + + ### create a CPANPLUS::Backend::RV object + $backend_rv = CPANPLUS::Backend::RV->new( + ok => $boolean, + args => $args, + rv => $return_value + function => $calling_function ); + + ### if you have a CPANPLUS::Backend::RV object + $passed_args = $backend_rv->args; # args passed to function + $ok = $backend_rv->ok; # boolean indication overall + # result of the call + $function = $backend_rv->fucntion # name of the calling + # function + $rv = $backend_rv->rv # the actual return value + # of the calling function + +=head1 DESCRIPTION + +This module provides return value objects for multi-module +calls to CPANPLUS::Backend. In boolean context, it returns the status +of the overall result (ie, the same as the C<ok> method would). + +=head1 METHODS + +=head2 new( ok => BOOL, args => DATA, rv => DATA, [function => $method_name] ) + +Creates a new CPANPLUS::Backend::RV object from the data provided. +This method should only be called by CPANPLUS::Backend functions. +The accessors may be used by users inspecting an RV object. + +All the argument names can be used as accessors later to retrieve the +data. + +Arguments: + +=over 4 + +=item ok + +Boolean indicating overall success + +=item args + +The arguments provided to the function that returned this rv object. +Useful to inspect later to see what was actually passed to the function +in case of an error. + +=item rv + +An arbitrary data structure that has the detailed return values of each +of your multi-module calls. + +=item function + +The name of the function that created this rv object. +Can be explicitly passed. If not, C<new()> will try to deduce the name +from C<caller()> information. + +=back + +=cut + +sub new { + my $class = shift; + my %hash = @_; + + my $tmpl = { + ok => { required => 1, allow => BOOLEANS }, + args => { required => 1 }, + rv => { required => 1 }, + function => { default => CALLING_FUNCTION->() }, + }; + + my $args = check( $tmpl, \%hash ) or return; + my $self = bless {}, $class; + +# $self->mk_accessors( qw[ok args function rv] ); + $self->mk_accessors( keys %$tmpl ); + + ### set the values passed in the struct ### + while( my($key,$val) = each %$args ) { + $self->$key( $val ); + } + + return $self; +} + +sub _ok { return shift->ok } +#sub _stringify { Carp::carp( "stringifying!" ); overload::StrVal( shift ) } + +### make it easier to check if($rv) { foo() } +### this allows people to not have to explicitly say +### if( $rv->ok ) { foo() } +### XXX add an explicit stringify, so it doesn't fall back to "bool"? :( +use overload bool => \&_ok, +# '""' => \&_stringify, + fallback => 1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Config.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Config.pm new file mode 100755 index 00000000000..71d2b4fd03a --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Config.pm @@ -0,0 +1,849 @@ +package CPANPLUS::Config; + +use strict; +use warnings; + +use base 'Object::Accessor'; + +use base 'CPANPLUS::Internals::Utils'; + +use Config; +use File::Spec; +use Module::Load; +use CPANPLUS; +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use File::Basename qw[dirname]; +use IPC::Cmd qw[can_run]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use Module::Load::Conditional qw[check_install]; + + +=pod + +=head1 NAME + +CPANPLUS::Config + +=head1 SYNOPSIS + + ### conf object via CPANPLUS::Backend; + $cb = CPANPLUS::Backend->new; + $conf = $cb->configure_object; + + ### or as a standalone object + $conf = CPANPLUS::Configure->new; + + ### values in 'conf' section + $verbose = $conf->get_conf( 'verbose' ); + $conf->set_conf( verbose => 1 ); + + ### values in 'program' section + $editor = $conf->get_program( 'editor' ); + $conf->set_program( editor => '/bin/vi' ); + +=head1 DESCRIPTION + +This module contains defaults and heuristics for configuration +information for CPANPLUS. To change any of these values, please +see the documentation in C<CPANPLUS::Configure>. + +Below you'll find a list of configuration types and keys, and +their meaning. + +=head1 CONFIGURATION + +=cut + +### BAH! you can't have POD interleaved with a hash +### declaration.. so declare every entry seperatedly :( +my $Conf = { + '_fetch' => { + 'blacklist' => [ 'ftp' ], + }, + + ### _source, _build and _mirror are supposed to be static + ### no changes should be needed unless pause/cpan changes + '_source' => { + 'hosts' => 'MIRRORED.BY', + 'auth' => '01mailrc.txt.gz', + 'stored' => 'sourcefiles', + 'dslip' => '03modlist.data.gz', + 'update' => '86400', + 'mod' => '02packages.details.txt.gz', + 'custom_index' => 'packages.txt', + }, + '_build' => { + 'plugins' => 'plugins', + 'moddir' => 'build', + 'startdir' => '', + 'distdir' => 'dist', + 'autobundle' => 'autobundle', + 'autobundle_prefix' => 'Snapshot', + 'autdir' => 'authors', + 'install_log_dir' => 'install-logs', + 'custom_sources' => 'custom-sources', + 'sanity_check' => 1, + }, + '_mirror' => { + 'base' => 'authors/id/', + 'auth' => 'authors/01mailrc.txt.gz', + 'dslip' => 'modules/03modlist.data.gz', + 'mod' => 'modules/02packages.details.txt.gz' + }, +}; + +=head2 Section 'conf' + +=over 4 + +=item hosts + +An array ref containing hosts entries to be queried for packages. + +An example entry would like this: + + { 'scheme' => 'ftp', + 'path' => '/pub/CPAN/', + 'host' => 'ftp.cpan.org' + }, + +=cut + + ### default host list + $Conf->{'conf'}->{'hosts'} = [ + { + 'scheme' => 'http', + 'path' => '/', + 'host' => 'cpan.strawberryperl.com' + }, + { + 'scheme' => 'ftp', + 'path' => '/pub/CPAN/', + 'host' => 'ftp.cpan.org' + }, + { + 'scheme' => 'http', + 'path' => '/', + 'host' => 'www.cpan.org' + }, + { + 'scheme' => 'ftp', + 'path' => '/pub/CPAN/', + 'host' => 'ftp.nl.uu.net' + }, + { + 'scheme' => 'ftp', + 'path' => '/pub/CPAN/', + 'host' => 'cpan.valueclick.com' + }, + { + 'scheme' => 'ftp', + 'path' => '/pub/languages/perl/CPAN/', + 'host' => 'ftp.funet.fi' + } + ]; + +# If we are on fake Hotel/Airport wireless, +# prefer a minicpan to the poisoned wireless. +if ( -d 'C:\strawberry\minicpan' ) { + eval { + require LWP::Online; + require URI::file; + 1; + }; + unless ( $@ ) { + my $path = URI::file->new('C:\strawberry\minicpan'); + + if ( LWP::Online::online() ) { + push @{$Conf->{'conf'}->{'hosts'}}, { + 'path' => $path->path(), + 'scheme' => 'file', + 'host' => '' + }; + } else { + unshift @{$Conf->{'conf'}->{'hosts'}}, { + 'path' => $path->path(), + 'scheme' => 'file', + 'host' => '' + }; + } + } +} + +if ( -d 'C:\minicpan' ) { + eval { + require LWP::Online; + require URI::file; + 1; + }; + unless ( $@ ) { + my $path = URI::file->new('C:\minicpan'); + + if ( LWP::Online::online() ) { + push @{$Conf->{'conf'}->{'hosts'}}, { + 'path' => $path->path(), + 'scheme' => 'file', + 'host' => '' + }; + } else { + unshift @{$Conf->{'conf'}->{'hosts'}}, { + 'path' => $path->path(), + 'scheme' => 'file', + 'host' => '' + }; + } + } +} + + +=item allow_build_interactivity + +Boolean flag to indicate whether 'perl Makefile.PL' and similar +are run interactively or not. Defaults to 'true'. + +=cut + + $Conf->{'conf'}->{'allow_build_interactivity'} = 1; + +=item base + +The directory CPANPLUS keeps all its build and state information in. +Defaults to ~/.cpanplus. + +=cut + + $Conf->{'conf'}->{'base'} = File::Spec->catdir('C:', 'cpanplus'); + +=item buildflags + +Any flags to be passed to 'perl Build.PL'. See C<perldoc Module::Build> +for details. Defaults to an empty string. + +=cut + + $Conf->{'conf'}->{'buildflags'} = '--uninst 1'; + +=item cpantest + +Boolean flag to indicate whether or not to mail test results of module +installations to C<http://testers.cpan.org>. Defaults to 'false'. + +=cut + + $Conf->{'conf'}->{'cpantest'} = 0; + +=item cpantest_mx + +String holding an explicit mailserver to use when sending out emails +for C<http://testers.cpan.org>. An empty string will use your system +settings. Defaults to an empty string. + +=cut + + $Conf->{'conf'}->{'cpantest_mx'} = ''; + +=item debug + +Boolean flag to enable or disable extensive debuggging information. +Defaults to 'false'. + +=cut + + $Conf->{'conf'}->{'debug'} = 0; + +=item dist_type + +Default distribution type to use when building packages. See C<cpan2dist> +or C<CPANPLUS::Dist> for details. An empty string will not use any +package building software. Defaults to an empty string. + +=cut + + $Conf->{'conf'}->{'dist_type'} = ''; + +=item email + +Email address to use for anonymous ftp access and as C<from> address +when sending emails. Defaults to an C<example.com> address. + +=cut + + $Conf->{'conf'}->{'email'} = DEFAULT_EMAIL; + +=item enable_custom_sources + +Boolean flag indicating whether custom sources should be enabled or +not. See the C<CUSTOM MODULE SOURCES> in C<CPANPLUS::Backend> for +details on how to use them. + +Defaults to C<true> + +=cut + ### csjewell@cpan.org: This is very slow, so turning off. + + ### this addresses #32248 which requests a possibillity to + ### turn off custom sources + $Conf->{'conf'}->{'enable_custom_sources'} = 0; + +=item extractdir + +String containing the directory where fetched archives should be +extracted. An empty string will use a directory under your C<base> +directory. Defaults to an empty string. + +=cut + + $Conf->{'conf'}->{'extractdir'} = ''; + +=item fetchdir + +String containing the directory where fetched archives should be +stored. An empty string will use a directory under your C<base> +directory. Defaults to an empty string. + +=cut + + $Conf->{'conf'}->{'fetchdir'} = ''; + +=item flush + +Boolean indicating whether build failures, cache dirs etc should +be flushed after every operation or not. Defaults to 'true'. + +=cut + + $Conf->{'conf'}->{'flush'} = 1; + +=item force + +Boolean indicating whether files should be forcefully overwritten +if they exist, modules should be installed when they fail tests, +etc. Defaults to 'false'. + +=cut + + $Conf->{'conf'}->{'force'} = 0; + +=item lib + +An array ref holding directories to be added to C<@INC> when CPANPLUS +starts up. Defaults to an empty array reference. + +=cut + + $Conf->{'conf'}->{'lib'} = []; + +=item makeflags + +A string holding flags that will be passed to the C<make> program +when invoked. Defaults to an empty string. + +=cut + + $Conf->{'conf'}->{'makeflags'} = 'UNINST=1'; + +=item makemakerflags + +A string holding flags that will be passed to C<perl Makefile.PL> +when invoked. Defaults to an empty string. + +=cut + + $Conf->{'conf'}->{'makemakerflags'} = ''; + +=item md5 + +A boolean indicating whether or not md5 checks should be done when +an archive is fetched. Defaults to 'true' if you have C<Digest::MD5> +installed, 'false' otherwise. + +=cut + + $Conf->{'conf'}->{'md5'} = ( + check_install( module => 'Digest::MD5' ) ? 1 : 0 ); + +=item no_update + +A boolean indicating whether or not C<CPANPLUS>' source files should be +updated or not. Defaults to 'false'. + +=cut + + $Conf->{'conf'}->{'no_update'} = 0; + +=item passive + +A boolean indicating whether or not to use passive ftp connections. +Defaults to 'true'. + +=cut + + $Conf->{'conf'}->{'passive'} = 1; + +=item prefer_bin + +A boolean indicating whether or not to prefer command line programs +over perl modules. Defaults to 'false' unless you do not have +C<Compress::Zlib> installed (as that would mean we could not extract +C<.tar.gz> files) + +=cut + ### if we dont have c::zlib, we'll need to use /bin/tar or we + ### can not extract any files. Good time to change the default + $Conf->{'conf'}->{'prefer_bin'} = + (eval {require Compress::Zlib; 1} ? 0 : 1 ); + +=item prefer_makefile + +A boolean indicating whether or not prefer a C<Makefile.PL> over a +C<Build.PL> file if both are present. Defaults to 'true'. + +=cut + + $Conf->{'conf'}->{'prefer_makefile'} = 0; + +=item prereqs + +A digit indicating what to do when a package you are installing has a +prerequisite. Options are: + + 0 Do not install + 1 Install + 2 Ask + 3 Ignore (dangerous, install will probably fail!) + +The default is to ask. + +=cut + + $Conf->{'conf'}->{'prereqs'} = PREREQ_INSTALL; + +=item shell + +A string holding the shell class you wish to start up when starting +C<CPANPLUS> in interactive mode. + +Defaults to C<CPANPLUS::Shell::Default>, the default CPANPLUS shell. + +=cut + + $Conf->{'conf'}->{'shell'} = 'CPANPLUS::Shell::Default'; + +=item show_startup_tip + +A boolean indicating whether or not to show start up tips in the +interactive shell. Defaults to 'true'. + +=cut + + $Conf->{'conf'}->{'show_startup_tip'} = 1; + +=item signature + +A boolean indicating whether or not check signatures if packages are +signed. Defaults to 'true' if you have C<gpg> or C<Crypt::OpenPGP> +installed, 'false' otherwise. + +=cut + + $Conf->{'conf'}->{'signature'} = do { + check_install( module => 'Module::Signature', version => '0.06' ) + and ( can_run('gpg') || + check_install(module => 'Crypt::OpenPGP') + ); + } ? 1 : 0; + +=item skiptest + +A boolean indicating whether or not to skip tests when installing modules. +Defaults to 'false'. + +=cut + + $Conf->{'conf'}->{'skiptest'} = 0; + +=item storable + +A boolean indicating whether or not to use C<Storable> to write compiled +source file information to disk. This makes for faster startup and look +up times, but takes extra diskspace. Defaults to 'true' if you have +C<Storable> installed and 'false' if you don't. + +=cut + + $Conf->{'conf'}->{'storable'} = + ( check_install( module => 'Storable' ) ? 1 : 0 ); + +=item timeout + +Digit indicating the time before a fetch request times out (in seconds). +Defaults to 300. + +=cut + + $Conf->{'conf'}->{'timeout'} = 300; + +=item verbose + +A boolean indicating whether or not C<CPANPLUS> runs in verbose mode. +Defaults to 'true' if you have the environment variable +C<PERL5_CPANPLUS_VERBOSE> set to true, 'false' otherwise. + +It is recommended you run with verbose enabled, but it is disabled +for historical reasons. + +=cut + + $Conf->{'conf'}->{'verbose'} = $ENV{PERL5_CPANPLUS_VERBOSE} || 0; + +=item write_install_log + +A boolean indicating whether or not to write install logs after installing +a module using the interactive shell. Defaults to 'true'. + + +=cut + + $Conf->{'conf'}->{'write_install_logs'} = 1; + +=item source_engine + +Class to use as the source engine, which is generally a subclass of +C<CPANPLUS::Internals::Source>. Default to C<CPANPLUS::Internals::Source::Memory>. + +=cut + + $Conf->{'conf'}->{'source_engine'} = 'CPANPLUS::Internals::Source::SQLite'; + +=item cpantest_reporter_args + +A hashref of key => value pairs that are passed to the constructor +of C<Test::Reporter>. If you'd want to enable TLS for example, you'd +set it to: + + { transport => 'Net::SMTP::TLS', + transport_args => [ User => 'Joe', Password => '123' ], + } + +=cut + + $Conf->{'conf'}->{'cpantest_reporter_args'} = {}; + +=back + +=head2 Section 'program' + +=cut + + ### Paths get stripped of whitespace on win32 in the constructor + ### sudo gets emptied if there's no need for it in the constructor + +=over 4 + +=item editor + +A string holding the path to your editor of choice. Defaults to your +$ENV{EDITOR}, $ENV{VISUAL}, 'vi' or 'pico' programs, in that order. + +=cut + + $Conf->{'program'}->{'editor'} = do { + $ENV{'EDITOR'} || $ENV{'VISUAL'} || + can_run('vi') || can_run('pico') + }; + +=item make + +A string holding the path to your C<make> binary. Looks for the C<make> +program used to build perl or failing that, a C<make> in your path. + +=cut + + $Conf->{'program'}->{'make'} = + can_run($Config{'make'}) || can_run('make'); + +=item pager + +A string holding the path to your pager of choice. Defaults to your +$ENV{PAGER}, 'less' or 'more' programs, in that order. + +=cut + + $Conf->{'program'}->{'pager'} = + $ENV{'PAGER'} || can_run('less') || can_run('more'); + + ### no one uses this feature anyway, and it's only working for EU::MM + ### and not for module::build + #'perl' => '', + +=item shell + +A string holding the path to your login shell of choice. Defaults to your +$ENV{SHELL} setting, or $ENV{COMSPEC} on Windows. + +=cut + + $Conf->{'program'}->{'shell'} = $^O eq 'MSWin32' + ? $ENV{COMSPEC} + : $ENV{SHELL}; + +=item sudo + +A string holding the path to your C<sudo> binary if your install path +requires super user permissions. Looks for C<sudo> in your path, or +remains empty if you do not require super user permissiosn to install. + +=cut + + $Conf->{'program'}->{'sudo'} = do { + ### let's assume you dont need sudo, + ### unless one of the below criteria tells us otherwise + my $sudo = undef; + + ### you're a normal user, you might need sudo + if( $> ) { + + ### check for all install dirs! + ### you have write permissions to the installdir, + ### you don't need sudo + if( -w $Config{'installsitelib'} && -w $Config{'installsitebin'} ) { + + ### installsiteman3dir is a 5.8'ism.. don't check + ### it on 5.6.x... + if( defined $Config{'installsiteman3dir'} ) { + $sudo = -w $Config{'installsiteman3dir'} + ? undef + : can_run('sudo'); + } else { + $sudo = undef; + } + + ### you have PERL_MM_OPT set to some alternate + ### install place. You probably have write permissions + ### to that + } elsif ( $ENV{'PERL_MM_OPT'} and + $ENV{'PERL_MM_OPT'} =~ /INSTALL|LIB|PREFIX/ + ) { + $sudo = undef; + + ### you probably don't have write permissions + } else { + $sudo = can_run('sudo'); + } + } + + ### and return the value + $sudo; + }; + +=item perlwrapper + +A string holding the path to the C<cpanp-run-perl> utility bundled +with CPANPLUS, which is used to enable autoflushing in spawned processes. + +=cut + + ### perlwrapper that allows us to turn on autoflushing + $Conf->{'program'}->{'perlwrapper'} = sub { + my $name = 'cpanp-run-perl'; + + my @bins = do{ + require Config; + my $ver = $Config::Config{version}; + + ### if we are running with 'versiononly' enabled, + ### all binaries will have the perlversion appended + ### ie, cpanp will become cpanp5.9.5 + ### so prefer the versioned binary in that case + $Config::Config{versiononly} + ? ($name.$ver, $name) + : ($name, $name.$ver); + }; + + ### patch from Steve Hay Fri 29 Jun 2007 14:26:02 GMT+02:00 + ### Msg-Id: <4684FA5A.7030506@uk.radan.com> + ### look for files with a ".bat" extension as well on Win32 + @bins = map { $_, "$_.bat" } @bins if $^O eq 'MSWin32'; + + my $path; + BIN: for my $bin (@bins) { + + ### parallel to your cpanp/cpanp-boxed + my $maybe = File::Spec->rel2abs( + File::Spec->catfile( dirname($0), $bin ) + ); + $path = $maybe and last BIN if -f $maybe; + + ### parallel to your CPANPLUS.pm: + ### $INC{cpanplus}/../bin/cpanp-run-perl + $maybe = File::Spec->rel2abs( + File::Spec->catfile( + dirname($INC{'CPANPLUS.pm'}), + '..', # lib dir + 'bin', # bin dir + $bin, # script + ) + ); + $path = $maybe and last BIN if -f $maybe; + + ### you installed CPANPLUS in a custom prefix, + ### so go paralel to /that/. PREFIX=/tmp/cp + ### would put cpanp-run-perl in /tmp/cp/bin and + ### CPANPLUS.pm in + ### /tmp/cp/lib/perl5/site_perl/5.8.8 + $maybe = File::Spec->rel2abs( + File::Spec->catfile( + dirname( $INC{'CPANPLUS.pm'} ), + '..', '..', '..', '..', # 4x updir + 'bin', # bin dir + $bin, # script + ) + ); + $path = $maybe and last BIN if -f $maybe; + + ### in your path -- take this one last, the + ### previous two assume extracted tarballs + ### or user installs + ### note that we don't use 'can_run' as it's + ### not an executable, just a wrapper... + ### prefer anything that's found in the path paralel to your $^X + for my $dir (File::Spec->rel2abs( dirname($^X) ), + split(/\Q$Config::Config{path_sep}\E/, $ENV{PATH}), + File::Spec->curdir, + ) { + + ### On VMS the path could be in UNIX format, and we + ### currently need it to be in VMS format + $dir = VMS::Filespec::vmspath($dir) if ON_VMS; + + $maybe = File::Spec->catfile( $dir, $bin ); + $path = $maybe and last BIN if -f $maybe; + } + } + + ### we should have a $path by now ideally, if so return it + return $path if defined $path; + + ### if not, warn about it and give sensible default. + ### XXX try to be a no-op instead then.. + ### cross your fingers... + ### pass '-P' to perl: "run program through C + ### preprocessor before compilation" + ### XXX using -P actually changes the way some Makefile.PLs + ### are executed, so don't do that... --kane + error(loc( + "Could not find the '%1' binary in your path". + "--this may be a problem.\n". + "Please locate this program and set ". + "your '%2' config entry to its path.\n". + "From the default shell, you can do this by typing:\n\n". + " %3\n". + " %4\n", + $name, 'perlwrapper', + 's program perlwrapper FULL_PATH_TO_CPANP_RUN_PERL', + 's save' + )); + return ''; + }->(); + +=back + +=cut + +sub new { + my $class = shift; + my $obj = $class->SUPER::new; + + $obj->mk_accessors( keys %$Conf ); + + for my $acc ( keys %$Conf ) { + my $subobj = Object::Accessor->new; + $subobj->mk_accessors( keys %{$Conf->{$acc}} ); + + ### read in all the settings from the sub accessors; + for my $subacc ( $subobj->ls_accessors ) { + $subobj->$subacc( $Conf->{$acc}->{$subacc} ); + } + + ### now store it in the parent object + $obj->$acc( $subobj ); + } + + $obj->_clean_up_paths; + + ### shut up IPC::Cmd warning about not findin IPC::Run on win32 + $IPC::Cmd::WARN = 0; + + return $obj; +} + +sub _clean_up_paths { + my $self = shift; + + ### clean up paths if we are on win32 + if( $^O eq 'MSWin32' ) { + for my $pgm ( $self->program->ls_accessors ) { + my $path = $self->program->$pgm; + + ### paths with whitespace needs to be shortened + ### for shell outs. + if ($path and $path =~ /\s+/) { + my($prog, $args); + + ### patch from Steve Hay, 13nd of June 2007 + ### msg-id: <467012A4.6060705@uk.radan.com> + ### windows directories are not allowed to end with + ### a space, so any occurrence of '\w\s+/\w+' means + ### we're dealing with arguments, not directory + ### names. + if ($path =~ /^(.*?)(\s+\/.*$)/) { + ($prog, $args) = ($1, $2); + + ### otherwise, there are no arguments + } else { + ($prog, $args) = ($path, ''); + } + + $prog = Win32::GetShortPathName( $prog ); + $self->program->$pgm( $prog . $args ); + } + } + } + + return 1; +} + +1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Configure> + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Configure.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Configure.pm new file mode 100755 index 00000000000..baac91dc886 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Configure.pm @@ -0,0 +1,630 @@ +package CPANPLUS::Configure; +use strict; + + +use CPANPLUS::Internals::Constants; +use CPANPLUS::Error; +use CPANPLUS::Config; + +use Log::Message; +use Module::Load qw[load]; +use Params::Check qw[check]; +use File::Basename qw[dirname]; +use Module::Loaded (); +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +use vars qw[$AUTOLOAD $VERSION $MIN_CONFIG_VERSION]; +use base qw[CPANPLUS::Internals::Utils]; + +local $Params::Check::VERBOSE = 1; + +### require, avoid circular use ### +require CPANPLUS::Internals; +$VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION; + +### can't use O::A as we're using our own AUTOLOAD to get to +### the config options. +for my $meth ( qw[conf _lib _perl5lib]) { + no strict 'refs'; + + *$meth = sub { + my $self = shift; + $self->{'_'.$meth} = $_[0] if @_; + return $self->{'_'.$meth}; + } +} + + +=pod + +=head1 NAME + +CPANPLUS::Configure + +=head1 SYNOPSIS + + $conf = CPANPLUS::Configure->new( ); + + $bool = $conf->can_save; + $bool = $conf->save( $where ); + + @opts = $conf->options( $type ); + + $make = $conf->get_program('make'); + $verbose = $conf->set_conf( verbose => 1 ); + +=head1 DESCRIPTION + +This module deals with all the configuration issues for CPANPLUS. +Users can use objects created by this module to alter the behaviour +of CPANPLUS. + +Please refer to the C<CPANPLUS::Backend> documentation on how to +obtain a C<CPANPLUS::Configure> object. + +=head1 METHODS + +=head2 $Configure = CPANPLUS::Configure->new( load_configs => BOOL ) + +This method returns a new object. Normal users will never need to +invoke the C<new> method, but instead retrieve the desired object via +a method call on a C<CPANPLUS::Backend> object. + +=item load_configs + +Controls whether or not additional user configurations are to be loaded +or not. Defaults to C<true>. + +=cut + +### store teh CPANPLUS::Config object in a closure, so we only +### initialize it once.. otherwise, on a 2nd ->new, settings +### from configs on top of this one will be reset +{ my $Config; + + sub new { + my $class = shift; + my %hash = @_; + + ### XXX pass on options to ->init() like rescan? + my ($load); + my $tmpl = { + load_configs => { default => 1, store => \$load }, + }; + + check( $tmpl, \%hash ) or ( + warn Params::Check->last_error, return + ); + + $Config ||= CPANPLUS::Config->new; + my $self = bless {}, $class; + $self->conf( $Config ); + + ### you want us to load other configs? + ### these can override things in the default config + $self->init if $load; + + ### after processing the config files, check what + ### @INC and PERL5LIB are set to. + $self->_lib( \@INC ); + $self->_perl5lib( $ENV{'PERL5LIB'} ); + + return $self; + } +} + +=head2 $bool = $Configure->init( [rescan => BOOL]) + +Initialize the configure with other config files than just +the default 'CPANPLUS::Config'. + +Called from C<new()> to load user/system configurations + +If the C<rescan> option is provided, your disk will be +examined again to see if there are new config files that +could be read. Defaults to C<false>. + +Returns true on success, false on failure. + +=cut + +### move the Module::Pluggable detection to runtime, rather +### than compile time, so that a simple 'require CPANPLUS' +### doesn't start running over your filesystem for no good +### reason. Make sure we only do the M::P call once though. +### we use $loaded to mark it +{ my $loaded; + my $warned; + sub init { + my $self = shift; + my $obj = $self->conf; + my %hash = @_; + + my ($rescan); + my $tmpl = { + rescan => { default => 0, store => \$rescan }, + }; + + check( $tmpl, \%hash ) or ( + warn Params::Check->last_error, return + ); + + ### if the base dir is changed, we have to rescan it + ### for any CPANPLUS::Config::* files as well, so keep + ### track of it + my $cur_base = $self->get_conf('base'); + + ### warn if we find an old style config specified + ### via environment variables + { my $env = ENV_CPANPLUS_CONFIG; + if( $ENV{$env} and not $warned ) { + $warned++; + error(loc("Specifying a config file in your environment " . + "using %1 is obsolete.\nPlease follow the ". + "directions outlined in %2 or use the '%3' command\n". + "in the default shell to use custom config files.", + $env, "CPANPLUS::Configure->save", 's save')); + } + } + + { ### make sure that the homedir is included now + local @INC = ( LIB_DIR->($cur_base), @INC ); + + ### only set it up once + if( !$loaded++ or $rescan ) { + ### find plugins & extra configs + ### check $home/.cpanplus/lib as well + require Module::Pluggable; + + Module::Pluggable->import( + search_path => ['CPANPLUS::Config'], + search_dirs => [ LIB_DIR->($cur_base) ], + except => qr/::SUPER$/, + sub_name => 'configs' + ); + } + + + ### do system config, user config, rest.. in that order + ### apparently, on a 2nd invocation of -->configs, a + ### ::ISA::CACHE package can appear.. that's bad... + my %confs = map { $_ => $_ } + grep { $_ !~ /::ISA::/ } __PACKAGE__->configs; + my @confs = grep { defined } + map { delete $confs{$_} } CONFIG_SYSTEM, CONFIG_USER; + push @confs, sort keys %confs; + + for my $plugin ( @confs ) { + msg(loc("Found config '%1'", $plugin),0); + + ### if we already did this the /last/ time around dont + ### run the setup agian. + if( my $loc = Module::Loaded::is_loaded( $plugin ) ) { + msg(loc(" Already loaded '%1' (%2)", $plugin, $loc), 0); + next; + } else { + msg(loc(" Loading config '%1'", $plugin),0); + + if( eval { load $plugin; 1 } ) { + msg(loc(" Loaded '%1' (%2)", + $plugin, Module::Loaded::is_loaded( $plugin ) ), 0); + } else { + error(loc(" Error loading '%1': %2", $plugin, $@)); + } + } + + if( $@ ) { + error(loc("Could not load '%1': %2", $plugin, $@)); + next; + } + + my $sub = $plugin->can('setup'); + $sub->( $self ) if $sub; + } + } + + ### did one of the plugins change the base dir? then we should + ### scan the dirs again + if( $cur_base ne $self->get_conf('base') ) { + msg(loc("Base dir changed from '%1' to '%2', rescanning", + $cur_base, $self->get_conf('base')), 0); + $self->init( @_, rescan => 1 ); + } + + ### clean up the paths once more, just in case + $obj->_clean_up_paths; + + ### XXX in case the 'lib' param got changed, we need to + ### add that now, or it's not propagating ;( + { my $lib = $self->get_conf('lib'); + my %inc = map { $_ => $_ } @INC; + for my $l ( @$lib ) { + push @INC, $l unless $inc{$l}; + } + $self->_lib( \@INC ); + } + + return 1; + } +} +=pod + +=head2 can_save( [$config_location] ) + +Check if we can save the configuration to the specified file. +If no file is provided, defaults to your personal config. + +Returns true if the file can be saved, false otherwise. + +=cut + +sub can_save { + my $self = shift; + my $file = shift || CONFIG_USER_FILE->(); + + return 1 unless -e $file; + + chmod 0644, $file; + return (-w $file); +} + +=pod + +=head2 $file = $conf->save( [$package_name] ) + +Saves the configuration to the package name you provided. +If this package is not C<CPANPLUS::Config::System>, it will +be saved in your C<.cpanplus> directory, otherwise it will +be attempted to be saved in the system wide directory. + +If no argument is provided, it will default to your personal +config. + +Returns the full path to the file if the config was saved, +false otherwise. + +=cut + +sub _config_pm_to_file { + my $self = shift; + my $pm = shift or return; + my $dir = shift || CONFIG_USER_LIB_DIR->(); + + ### only 3 types of files know: home, system and 'other' + ### so figure out where to save them based on their type + my $file; + if( $pm eq CONFIG_USER ) { + $file = CONFIG_USER_FILE->(); + + } elsif ( $pm eq CONFIG_SYSTEM ) { + $file = CONFIG_SYSTEM_FILE->(); + + ### third party file + } else { + my $cfg_pkg = CONFIG . '::'; + unless( $pm =~ /^$cfg_pkg/ ) { + error(loc( + "WARNING: Your config package '%1' is not in the '%2' ". + "namespace and will not be automatically detected by %3", + $pm, $cfg_pkg, 'CPANPLUS' + )); + } + + $file = File::Spec->catfile( + $dir, + split( '::', $pm ) + ) . '.pm'; + } + + return $file; +} + + +sub save { + my $self = shift; + my $pm = shift || CONFIG_USER; + my $savedir = shift || ''; + + my $file = $self->_config_pm_to_file( $pm, $savedir ) or return; + my $dir = dirname( $file ); + + unless( -d $dir ) { + $self->_mkdir( dir => $dir ) or ( + error(loc("Can not create directory '%1' to save config to",$dir)), + return + ) + } + return unless $self->can_save($file); + + ### find only accesors that are not private + my @acc = sort grep { $_ !~ /^_/ } $self->conf->ls_accessors; + + ### for dumping the values + use Data::Dumper; + + my @lines; + for my $acc ( @acc ) { + + push @lines, "### $acc section", $/; + + for my $key ( $self->conf->$acc->ls_accessors ) { + my $val = Dumper( $self->conf->$acc->$key ); + + $val =~ s/\$VAR1\s+=\s+//; + $val =~ s/;\n//; + + push @lines, '$'. "conf->set_${acc}( $key => $val );", $/; + } + push @lines, $/,$/; + + } + + my $str = join '', map { " $_" } @lines; + + ### use a variable to make sure the pod parser doesn't snag it + my $is = '='; + my $time = gmtime; + + + my $msg = <<_END_OF_CONFIG_; +############################################### +### +### Configuration structure for $pm +### +############################################### + +#last changed: $time GMT + +### minimal pod, so you can find it with perldoc -l, etc +${is}pod + +${is}head1 NAME + +$pm + +${is}head1 DESCRIPTION + +This is a CPANPLUS configuration file. Editing this +config changes the way CPANPLUS will behave + +${is}cut + +package $pm; + +use strict; + +sub setup { + my \$conf = shift; + +$str + + return 1; +} + +1; + +_END_OF_CONFIG_ + + $self->_move( file => $file, to => "$file~" ) if -f $file; + + my $fh = new FileHandle; + $fh->open(">$file") + or (error(loc("Could not open '%1' for writing: %2", $file, $!)), + return ); + + $fh->print($msg); + $fh->close; + + return $file; +} + +=pod + +=head2 options( type => TYPE ) + +Returns a list of all valid config options given a specific type +(like for example C<conf> of C<program>) or false if the type does +not exist + +=cut + +sub options { + my $self = shift; + my $conf = $self->conf; + my %hash = @_; + + my $type; + my $tmpl = { + type => { required => 1, default => '', + strict_type => 1, store => \$type }, + }; + + check($tmpl, \%hash) or return; + + my %seen; + return sort grep { !$seen{$_}++ } + map { $_->$type->ls_accessors if $_->can($type) } + $self->conf; + return; +} + +=pod + +=head1 ACCESSORS + +Accessors that start with a C<_> are marked private -- regular users +should never need to use these. + +See the C<CPANPLUS::Config> documentation for what items can be +set and retrieved. + +=head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] ); + +The C<get_*> style accessors merely retrieves one or more desired +config options. + +=head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] ); + +The C<set_*> style accessors set the current value for one +or more config options and will return true upon success, false on +failure. + +=head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] ); + +The C<add_*> style accessor adds a new key to a config key. + +Currently, the following accessors exist: + +=over 4 + +=item set|get_conf + +Simple configuration directives like verbosity and favourite shell. + +=item set|get_program + +Location of helper programs. + +=item _set|_get_build + +Locations of where to put what files for CPANPLUS. + +=item _set|_get_source + +Locations and names of source files locally. + +=item _set|_get_mirror + +Locations and names of source files remotely. + +=item _set|_get_fetch + +Special settings pertaining to the fetching of files. + +=back + +=cut + +sub AUTOLOAD { + my $self = shift; + my $conf = $self->conf; + + my $name = $AUTOLOAD; + $name =~ s/.+:://; + + my ($private, $action, $field) = + $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/; + + my $type = ''; + $type .= '_' if $private; + $type .= $field if $field; + + unless ( $conf->can($type) ) { + error( loc("Invalid method type: '%1'", $name) ); + return; + } + + unless( scalar @_ ) { + error( loc("No arguments provided!") ); + return; + } + + ### retrieve a current value for an existing key ### + if( $action eq 'get' ) { + for my $key (@_) { + my @list = (); + + ### get it from the user config first + if( $conf->can($type) and $conf->$type->can($key) ) { + push @list, $conf->$type->$key; + + ### XXX EU::AI compatibility hack to provide lookups like in + ### cpanplus 0.04x; we renamed ->_get_build('base') to + ### ->get_conf('base') + } elsif ( $type eq '_build' and $key eq 'base' ) { + return $self->get_conf($key); + + } else { + error( loc(q[No such key '%1' in field '%2'], $key, $type) ); + return; + } + + return wantarray ? @list : $list[0]; + } + + ### set an existing key to a new value ### + } elsif ( $action eq 'set' ) { + my %args = @_; + + while( my($key,$val) = each %args ) { + + if( $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; + } + } + + return 1; + + ### add a new key to the config ### + } elsif ( $action eq 'add' ) { + my %args = @_; + + while( my($key,$val) = each %args ) { + + if( $conf->$type->can($key) ) { + error( loc( q[Key '%1' already exists for field '%2'], + $key, $type)); + return; + } else { + $conf->$type->mk_accessors( $key ); + $conf->$type->$key( $val ); + } + } + return 1; + + } else { + + error( loc(q[Unknown action '%1'], $action) ); + return; + } +} + +sub DESTROY { 1 }; + +1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Config> + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Configure/Setup.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Configure/Setup.pm new file mode 100755 index 00000000000..3bcf8f45090 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Configure/Setup.pm @@ -0,0 +1,1653 @@ +package CPANPLUS::Configure::Setup; + +use strict; +use vars qw(@ISA); + +use base qw[CPANPLUS::Internals::Utils]; +use base qw[Object::Accessor]; + +use Config; +use Term::UI; +use Module::Load; +use Term::ReadLine; + + +use CPANPLUS::Internals::Utils; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Error; + +use IPC::Cmd qw[can_run]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +### silence Term::UI +$Term::UI::VERBOSE = 0; + +#Can't ioctl TIOCGETP: Unknown error +#Consider installing Term::ReadKey from CPAN site nearby +# at http://www.perl.com/CPAN +#Or use +# perl -MCPAN -e shell +#to reach CPAN. Falling back to 'stty'. +# If you do not want to see this warning, set PERL_READLINE_NOWARN +#in your environment. +#'stty' is not recognized as an internal or external command, +#operable program or batch file. +#Cannot call `stty': No such file or directory at C:/Perl/site/lib/Term/ReadLine/ + +### setting this var in the meantime to avoid this warning ### +$ENV{PERL_READLINE_NOWARN} = 1; + + +sub new { + my $class = shift; + my %hash = @_; + + my $tmpl = { + configure_object => { }, + term => { }, + backend => { }, + autoreply => { default => 0, }, + skip_mirrors => { default => 0, }, + use_previous => { default => 1, }, + config_type => { default => CONFIG_USER }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### initialize object + my $obj = $class->SUPER::new( keys %$tmpl ); + for my $acc ( $obj->ls_accessors ) { + $obj->$acc( $args->{$acc} ); + } + + ### otherwise there's a circular use ### + load CPANPLUS::Configure; + load CPANPLUS::Backend; + + $obj->configure_object( CPANPLUS::Configure->new() ) + unless $obj->configure_object; + + $obj->backend( CPANPLUS::Backend->new( $obj->configure_object ) ) + unless $obj->backend; + + ### use empty string in case user only has T::R::Stub -- it complains + $obj->term( Term::ReadLine->new('') ) + unless $obj->term; + + ### enable autoreply if that was passed ### + $Term::UI::AUTOREPLY = $obj->autoreply; + + return $obj; +} + +sub init { + my $self = shift; + my $term = $self->term; + + ### default setting, unless changed + $self->config_type( CONFIG_USER ) unless $self->config_type; + + my $save = loc('Save & exit'); + my $exit = loc('Quit without saving'); + my @map = ( + # key on the display # method to dispatch to + [ loc('Select Configuration file') => '_save_where' ], + [ loc('Setup CLI Programs') => '_setup_program' ], + [ loc('Setup CPANPLUS Home directory') => '_setup_base' ], + [ loc('Setup FTP/Email settings') => '_setup_ftp' ], + [ loc('Setup basic preferences') => '_setup_conf' ], + [ loc('Setup installer settings') => '_setup_installer' ], + [ loc('Select mirrors'), => '_setup_hosts' ], + [ loc('Edit configuration file') => '_edit' ], + [ $save => '_save' ], + [ $exit => 1 ], + ); + + my @keys = map { $_->[0] } @map; # sorted keys + my %map = map { @$_ } @map; # lookup hash + + PICK_SECTION: { + print loc(" +=================> MAIN MENU <================= + +Welcome to the CPANPLUS configuration. Please select which +parts you wish to configure + +Defaults are taken from your current configuration. +If you would save now, your settings would be written to: + + %1 + + ", $self->config_type ); + + my $choice = $term->get_reply( + prompt => "Section to configure:", + choices => \@keys, + default => $keys[0] + ); + + ### exit configuration? + if( $choice eq $exit ) { + print loc(" +Quitting setup, changes will not be saved. + "); + return 1; + } + + my $method = $map{$choice}; + + my $rv = $self->$method or print loc(" +There was an error setting up this section. You might want to try again + "); + + ### was it save & exit? + if( $choice eq $save and $rv ) { + print loc(" +Quitting setup, changes are saved to '%1' + ", $self->config_type + ); + return 1; + } + + ### otherwise, present choice again + redo PICK_SECTION; + } + + return 1; +} + + + +### sub that figures out what kind of config type the user wants +sub _save_where { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + + ASK_CONFIG_TYPE: { + + print loc( q[ +Where would you like to save your CPANPLUS Configuration file? + +If you want to configure CPANPLUS for this user only, +select the '%1' option. +The file will then be saved in your homedirectory. + +If you are the system administrator of this machine, +and would like to make this config available globally, +select the '%2' option. +The file will be then be saved in your CPANPLUS +installation directory. + + ], CONFIG_USER, CONFIG_SYSTEM ); + + + ### ask what config type we should save to + my $type = $term->get_reply( + prompt => loc("Type of configuration file"), + default => $self->config_type || CONFIG_USER, + choices => [CONFIG_USER, CONFIG_SYSTEM], + ); + + my $file = $conf->_config_pm_to_file( $type ); + + ### can we save to this file? + unless( $conf->can_save( $file ) ) { + error(loc( + "Can not save to file '%1'-- please check permissions " . + "and try again", $file + )); + + redo ASK_CONFIG_FILE; + } + + ### you already have the file -- are we allowed to overwrite + ### or should we try again? + if ( -e $file and -w _ ) { + print loc(q[ +I see you already have this file: + %1 + +The file will not be overwritten until you explicitly save it. + + ], $file ); + + redo ASK_CONFIG_TYPE + unless $term->ask_yn( + prompt => loc( "Do you wish to use this file?"), + default => 'n', + ); + } + + print $/, loc("Using '%1' as your configuration type", $type); + + return $self->config_type($type); + } +} + + +### setup the build & cache dirs +sub _setup_base { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + my $base = $conf->get_conf('base'); + my $home = File::Spec->catdir( $self->_home_dir, DOT_CPANPLUS ); + + print loc(" +CPANPLUS needs a directory of its own to cache important index +files and maybe keep a temporary mirror of CPAN files. +This may be a site-wide directory or a personal directory. + +For a single-user installation, we suggest using your home directory. + +"); + + my $where; + ASK_HOME_DIR: { + my $other = loc('Somewhere else'); + if( $base and ($base ne $home) ) { + print loc("You have several choices:"); + + $where = $term->get_reply( + prompt => loc('Please pick one'), + choices => [$home, $base, $other], + default => $home, + ); + } else { + $where = $base; + } + + if( $where and -d $where ) { + print loc(" +I see you already have a directory: + %1 + + "), $where; + + my $yn = $term->ask_yn( + prompt => loc('Should I use it?'), + default => 'y', + ); + $where = '' unless $yn; + } + + if( $where and ($where ne $other) and not -d $where ) { + if (!$self->_mkdir( dir => $where ) ) { + print "\n", loc("Unable to create directory '%1'", $where); + redo ASK_HOME_DIR; + } + + } elsif( not $where or ($where eq $other) ) { + print loc(" +First of all, I'd like to create this directory. + + "); + + NEW_HOME: { + $where = $term->get_reply( + prompt => loc('Where shall I create it?'), + default => $home, + ); + + my $again; + if( -d $where and not -w _ ) { + print "\n", loc("I can't seem to write in this directory"); + $again++; + } elsif (!$self->_mkdir( dir => $where ) ) { + print "\n", loc("Unable to create directory '%1'", $where); + $again++; + } + + if( $again ) { + print "\n", loc('Please select another directory'), "\n\n"; + redo NEW_HOME; + } + } + } + } + + ### tidy up the path and store it + $where = File::Spec->rel2abs($where); + $conf->set_conf( base => $where ); + + ### create subdirectories ### + my @dirs = + File::Spec->catdir( $where, $self->_perl_version(perl => $^X), + $conf->_get_build('moddir') ), + map { + File::Spec->catdir( $where, $conf->_get_build($_) ) + } qw[autdir distdir]; + + for my $dir ( @dirs ) { + unless( $self->_mkdir( dir => $dir ) ) { + warn loc("I wasn't able to create '%1'", $dir), "\n"; + } + } + + ### clear away old storable images before 0.031 + for my $src (qw[dslip mailrc packages]) { + 1 while unlink File::Spec->catfile( $where, $src ); + + } + + print loc(q[ +Your CPANPLUS build and cache directory has been set to: + %1 + + ], $where); + + return 1; +} + +sub _setup_ftp { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + ######################### + ## are you a pacifist? ## + ######################### + + print loc(" +If you are connecting through a firewall or proxy that doesn't handle +FTP all that well you can use passive FTP. + +"); + + my $yn = $term->ask_yn( + prompt => loc("Use passive FTP?"), + default => $conf->get_conf('passive'), + ); + + $conf->set_conf(passive => $yn); + + ### set the ENV var as well, else it won't get set till AFTER + ### the configuration is saved. but we fetch files BEFORE that. + $ENV{FTP_PASSIVE} = $yn; + + print "\n"; + print $yn + ? loc("I will use passive FTP.") + : loc("I won't use passive FTP."); + print "\n"; + + ############################# + ## should fetches timeout? ## + ############################# + + print loc(" +CPANPLUS can specify a network timeout for downloads (in whole seconds). +If none is desired (or to skip this question), enter '0'. + +"); + + my $timeout = 0 + $term->get_reply( + prompt => loc("Network timeout for downloads"), + default => $conf->get_conf('timeout') || 0, + allow => qr/(?!\D)/, ### whole numbers only + ); + + $conf->set_conf(timeout => $timeout); + + print "\n"; + print $timeout + ? loc("The network timeout for downloads is %1 seconds.", $timeout) + : loc("The network timeout for downloads is not set."); + print "\n"; + + ############################ + ## where can I reach you? ## + ############################ + + print loc(" +What email address should we send as our anonymous password when +fetching modules from CPAN servers? Some servers will NOT allow you to +connect without a valid email address, or at least something that looks +like one. +Also, if you choose to report test results at some point, a valid email +is required for the 'from' field, so choose wisely. + + "); + + my $other = 'Something else'; + my @choices = (DEFAULT_EMAIL, $Config{cf_email}, $other); + my $current = $conf->get_conf('email'); + + ### if your current address is not in the list, add it to the choices + unless (grep { $_ eq $current } @choices) { + unshift @choices, $current; + } + + my $email = $term->get_reply( + prompt => loc('Which email address shall I use?'), + default => $current || $choices[0], + choices => \@choices, + ); + + if( $email eq $other ) { + EMAIL: { + $email = $term->get_reply( + prompt => loc('Email address: '), + ); + + unless( $self->_valid_email($email) ) { + print loc(" +You did not enter a valid email address, please try again! + ") if length $email; + + redo EMAIL; + } + } + } + + print loc(" +Your 'email' is now: + %1 + + ", $email); + + $conf->set_conf( email => $email ); + + return 1; +} + + +### commandline programs +sub _setup_program { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + print loc(" +CPANPLUS can use command line utilities to do certain +tasks, rather than use perl modules. + +If you wish to use a certain command utility, just enter +the full path (or accept the default). If you do not wish +to use it, enter a single space. + +Note that the paths you provide should not contain spaces, which is +needed to make a distinction between program name and options to that +program. For Win32 machines, you can use the short name for a path, +like '%1'. +", 'c:\Progra~1\prog.exe' ); + + for my $prog ( sort $conf->options( type => 'program') ) { + PROGRAM: { + print "\n", loc("Where can I find your '%1' utility? ". + "(Enter a single space to disable)", $prog ), "\n"; + + my $loc = $term->get_reply( + prompt => "Path to your '$prog'", + default => $conf->get_program( $prog ), + ); + + ### empty line clears it + my $cmd = $loc =~ /^\s*$/ ? undef : $loc; + my ($bin) = $cmd =~ /^(\S+)/; + + ### did you provide a valid program ? + if( $bin and not can_run( $bin ) ) { + print "\n"; + print loc("Can not find the binary '%1' in your path!", $bin); + redo PROGRAM; + } + + ### make is special -- we /need/ it! + if( $prog eq 'make' and not $bin ) { + print loc( + "==> Without your '%1' utility, I can not function! <==", + 'make' + ); + print loc("Please provide one!"); + + ### show win32 where to download + if ( $^O eq 'MSWin32' ) { + print loc("You can get '%1' from:", NMAKE); + print "\t". NMAKE_URL ."\n"; + } + print "\n"; + redo PROGRAM; + } + + $conf->set_program( $prog => $cmd ); + print $cmd + ? loc( "Your '%1' utility has been set to '%2'.", + $prog, $cmd ) + : loc( "Your '%1' has been disabled.", $prog ); + print "\n"; + } + } + + return 1; +} + +sub _setup_installer { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + my $none = 'None'; + { + print loc(" +CPANPLUS uses binary programs as well as Perl modules to accomplish +various tasks. Normally, CPANPLUS will prefer the use of Perl modules +over binary programs. + +You can change this setting by making CPANPLUS prefer the use of +certain binary programs if they are available. + + "); + + ### default to using binaries if we don't have compress::zlib only + ### -- it'll get very noisy otherwise + my $type = 'prefer_bin'; + my $yn = $term->ask_yn( + prompt => loc("Should I prefer the use of binary programs?"), + default => $conf->get_conf( $type ), + ); + + print $yn + ? loc("Ok, I will prefer to use binary programs if possible.") + : loc("Ok, I will prefer to use Perl modules if possible."); + print "\n\n"; + + + $conf->set_conf( $type => $yn ); + } + + { + print loc(" +Makefile.PL is run by perl in a separate process, and accepts various +flags that controls the module's installation. For instance, if you +would like to install modules to your private user directory, set +'makemakerflags' to: + +LIB=~/perl/lib INSTALLMAN1DIR=~/perl/man/man1 INSTALLMAN3DIR=~/perl/man/man3 + +and be sure that you do NOT set UNINST=1 in 'makeflags' below. + +Enter a name=value list separated by whitespace, but quote any embedded +spaces that you want to preserve. (Enter a space to clear any existing +settings.) + +If you don't understand this question, just press ENTER. + + "); + + my $type = 'makemakerflags'; + my $flags = $term->get_reply( + prompt => 'Makefile.PL flags?', + default => $conf->get_conf($type), + ); + + $flags = '' if $flags eq $none || $flags !~ /\S/; + + print "\n", loc("Your '%1' have been set to:", 'Makefile.PL flags'), + "\n ", ( $flags ? $flags : loc('*nothing entered*')), + "\n\n"; + + $conf->set_conf( $type => $flags ); + } + + { + print loc(" +Like Makefile.PL, we run 'make' and 'make install' as separate processes. +If you have any parameters (e.g. '-j3' in dual processor systems) you want +to pass to the calls, please specify them here. + +In particular, 'UNINST=1' is recommended for root users, unless you have +fine-tuned ideas of where modules should be installed in the \@INC path. + +Enter a name=value list separated by whitespace, but quote any embedded +spaces that you want to preserve. (Enter a space to clear any existing +settings.) + +Again, if you don't understand this question, just press ENTER. + + "); + my $type = 'makeflags'; + my $flags = $term->get_reply( + prompt => 'make flags?', + default => $conf->get_conf($type), + ); + + $flags = '' if $flags eq $none || $flags !~ /\S/; + + print "\n", loc("Your '%1' have been set to:", $type), + "\n ", ( $flags ? $flags : loc('*nothing entered*')), + "\n\n"; + + $conf->set_conf( $type => $flags ); + } + + { + print loc(" +An alternative to ExtUtils::MakeMaker and Makefile.PL there's a module +called Module::Build which uses a Build.PL. + +If you would like to specify any flags to pass when executing the +Build.PL (and Build) script, please enter them below. + +For instance, if you would like to install modules to your private +user directory, you could enter: + + install_base=/my/private/path + +Or to uninstall old copies of modules before updating, you might +want to enter: + + uninst=1 + +Again, if you don't understand this question, just press ENTER. + + "); + + my $type = 'buildflags'; + my $flags = $term->get_reply( + prompt => 'Build.PL and Build flags?', + default => $conf->get_conf($type), + ); + + $flags = '' if $flags eq $none || $flags !~ /\S/; + + print "\n", loc("Your '%1' have been set to:", + 'Build.PL and Build flags'), + "\n ", ( $flags ? $flags : loc('*nothing entered*')), + "\n\n"; + + $conf->set_conf( $type => $flags ); + } + + ### use EU::MM or module::build? ### + { + print loc(" +Some modules provide both a Build.PL (Module::Build) and a Makefile.PL +(ExtUtils::MakeMaker). By default, CPANPLUS prefers Makefile.PL. + +Module::Build support is not bundled standard with CPANPLUS, but +requires you to install 'CPANPLUS::Dist::Build' from CPAN. + +Although Module::Build is a pure perl solution, which means you will +not need a 'make' binary, it does have some limitations. The most +important is that CPANPLUS is unable to uninstall any modules installed +by Module::Build. + +Again, if you don't understand this question, just press ENTER. + + "); + my $type = 'prefer_makefile'; + my $yn = $term->ask_yn( + prompt => loc("Prefer Makefile.PL over Build.PL?"), + default => $conf->get_conf($type), + ); + + $conf->set_conf( $type => $yn ); + } + + { + print loc(' +If you like, CPANPLUS can add extra directories to your @INC list during +startup. These will just be used by CPANPLUS and will not change your +external environment or perl interpreter. Enter a space separated list of +pathnames to be added to your @INC, quoting any with embedded whitespace. +(To clear the current value enter a single space.) + + '); + + my $type = 'lib'; + my $flags = $term->get_reply( + prompt => loc('Additional @INC directories to add?'), + default => (join " ", @{$conf->get_conf($type) || []} ), + ); + + my $lib; + unless( $flags =~ /\S/ ) { + $lib = []; + } else { + (@$lib) = $flags =~ m/\s*("[^"]+"|'[^']+'|[^\s]+)/g; + } + + print "\n", loc("Your additional libs are now:"), "\n"; + + print scalar @$lib + ? map { " $_\n" } @$lib + : " ", loc("*nothing entered*"), "\n"; + print "\n\n"; + + $conf->set_conf( $type => $lib ); + } + + return 1; +} + + +sub _setup_conf { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + my $none = 'None'; + { + ############ + ## noisy? ## + ############ + + print loc(" +In normal operation I can just give you basic information about what I +am doing, or I can be more verbose and give you every little detail. + + "); + + my $type = 'verbose'; + my $yn = $term->ask_yn( + prompt => loc("Should I be verbose?"), + default => $conf->get_conf( $type ), ); + + print "\n"; + print $yn + ? loc("You asked for it!") + : loc("I'll try to be quiet"); + + $conf->set_conf( $type => $yn ); + } + + { + ####################### + ## flush you animal! ## + ####################### + + print loc(" +In the interest of speed, we keep track of what modules were installed +successfully and which failed in the current session. We can flush this +data automatically, or you can explicitly issue a 'flush' when you want +to purge it. + + "); + + my $type = 'flush'; + my $yn = $term->ask_yn( + prompt => loc("Flush automatically?"), + default => $conf->get_conf( $type ), + ); + + print "\n"; + print $yn + ? loc("I'll flush after every full module install.") + : loc("I won't flush until you tell me to."); + + $conf->set_conf( $type => $yn ); + } + + { + ##################### + ## force installs? ## + ##################### + + print loc(" +Usually, when a test fails, I won't install the module, but if you +prefer, I can force the install anyway. + + "); + + my $type = 'force'; + my $yn = $term->ask_yn( + prompt => loc("Force installs?"), + default => $conf->get_conf( $type ), + ); + + print "\n"; + print $yn + ? loc("I will force installs.") + : loc("I won't force installs."); + + $conf->set_conf( $type => $yn ); + } + + { + ################### + ## about prereqs ## + ################### + + print loc(" +Sometimes a module will require other modules to be installed before it +will work. CPANPLUS can attempt to install these for you automatically +if you like, or you can do the deed yourself. + +If you would prefer that we NEVER try to install extra modules +automatically, select NO. (Usually you will want this set to YES.) + +If you would like to build modules to satisfy testing or prerequisites, +but not actually install them, select BUILD. + +NOTE: This feature requires you to flush the 'lib' cache for longer +running programs (refer to the CPANPLUS::Backend documentations for +more details). + +Otherwise, select ASK to have us ask your permission to install them. + + "); + + my $type = 'prereqs'; + + my @map = ( + [ PREREQ_IGNORE, # conf value + loc('No, do not install prerequisites'), # UI Value + loc("I won't install prerequisites") # diag message + ], + [ PREREQ_INSTALL, + loc('Yes, please install prerequisites'), + loc("I will install prerequisites") + ], + [ PREREQ_ASK, + loc('Ask me before installing a prerequisite'), + loc("I will ask permission to install") + ], + [ PREREQ_BUILD, + loc('Build prerequisites, but do not install them'), + loc( "I will only build, but not install prerequisites" ) + ], + ); + + my %reply = map { $_->[1] => $_->[0] } @map; # choice => value + my %diag = map { $_->[1] => $_->[2] } @map; # choice => diag message + my %conf = map { $_->[0] => $_->[1] } @map; # value => ui choice + + my $reply = $term->get_reply( + prompt => loc('Follow prerequisites?'), + default => $conf{ $conf->get_conf( $type ) }, + choices => [ @conf{ sort keys %conf } ], + ); + print "\n"; + + my $value = $reply{ $reply }; + my $diag = $diag{ $reply }; + + $conf->set_conf( $type => $value ); + print $diag, "\n"; + } + + { print loc(" +Modules in the CPAN archives are protected with md5 checksums. + +This requires the Perl module Digest::MD5 to be installed (which +CPANPLUS can do for you later); + + "); + my $type = 'md5'; + + my $yn = $term->ask_yn( + prompt => loc("Shall I use the MD5 checksums?"), + default => $conf->get_conf( $type ), + ); + + print $yn + ? loc("I will use the MD5 checksums if you have it") + : loc("I won't use the MD5 checksums"); + + $conf->set_conf( $type => $yn ); + + } + + + { ########################################### + ## sally sells seashells by the seashore ## + ########################################### + + print loc(" +By default CPANPLUS uses its own shell when invoked. If you would prefer +a different shell, such as one you have written or otherwise acquired, +please enter the full name for your shell module. + + "); + + my $type = 'shell'; + my $other = 'Other'; + my @choices = (qw| CPANPLUS::Shell::Default + CPANPLUS::Shell::Classic |, + $other ); + my $default = $conf->get_conf($type); + + unshift @choices, $default unless grep { $_ eq $default } @choices; + + my $reply = $term->get_reply( + prompt => loc('Which CPANPLUS shell do you want to use?'), + default => $default, + choices => \@choices, + ); + + if( $reply eq $other ) { + SHELL: { + $reply = $term->get_reply( + prompt => loc( 'Please enter the name of the shell '. + 'you wish to use: '), + ); + + unless( check_install( module => $reply ) ) { + print "\n", + loc("Could not find '$reply' in your path " . + "-- please try again"), + "\n"; + redo SHELL; + } + } + } + + print "\n", loc("Your shell is now: %1", $reply), "\n\n"; + + $conf->set_conf( $type => $reply ); + } + + { + ################### + ## use storable? ## + ################### + + print loc(" +To speed up the start time of CPANPLUS, and maintain a cache over +multiple runs, we can use Storable to freeze some information. +Would you like to do this? + +"); + my $type = 'storable'; + my $yn = $term->ask_yn( + prompt => loc("Use Storable?"), + default => $conf->get_conf( $type ) ? 1 : 0, + ); + print "\n"; + print $yn + ? loc("I will use Storable if you have it") + : loc("I will not use Storable"); + + $conf->set_conf( $type => $yn ); + } + + { + ################### + ## use sqlite ? ## + ################### + + print loc(" + +To limit the amount of RAM used by CPANPLUS, you can use the SQLite +source backend instead. Note that it is currently still experimental. +Would you like to do this? + +"); + my $type = 'source_engine'; + my $class = 'CPANPLUS::Internals::Source::SQLite'; + my $yn = $term->ask_yn( + prompt => loc("Use SQLite?"), + default => $conf->get_conf( $type ) eq $class ? 1 : 0, + ); + print "\n"; + print $yn + ? loc("I will use SQLite") + : loc("I will not use SQLite"); + + $conf->set_conf( $type => $class ); + } + + { + ################### + ## use cpantest? ## + ################### + + print loc(" +CPANPLUS has support for the Test::Reporter module, which can be utilized +to report success and failures of modules installed by CPANPLUS. Would +you like to do this? Note that you will still be prompted before +sending each report. + +If you don't have all the required modules installed yet, you should +consider installing '%1' + +This package bundles all the required modules to enable test reporting +and querying from CPANPLUS. +You can do so straight after this installation. + + ", 'Bundle::CPANPLUS::Test::Reporter'); + + my $type = 'cpantest'; + my $yn = $term->ask_yn( + prompt => loc('Report test results?'), + default => $conf->get_conf( $type ) ? 1 : 0, + ); + + print "\n"; + print $yn + ? loc("I will prompt you to report test results") + : loc("I won't prompt you to report test results"); + + $conf->set_conf( $type => $yn ); + } + + { + ################################### + ## use cryptographic signatures? ## + ################################### + + print loc(" +The Module::Signature extension allows CPAN authors to sign their +distributions using PGP signatures. Would you like to check for +module's cryptographic integrity before attempting to install them? +Note that this requires either the 'gpg' utility or Crypt::OpenPGP +to be installed. + + "); + my $type = 'signature'; + + my $yn = $term->ask_yn( + prompt => loc('Shall I check module signatures?'), + default => $conf->get_conf($type) ? 1 : 0, + ); + + print "\n"; + print $yn + ? loc("Ok, I will attempt to check module signatures.") + : loc("Ok, I won't attempt to check module signatures."); + + $conf->set_conf( $type => $yn ); + } + + return 1; +} + +sub _setup_hosts { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + + if( scalar @{ $conf->get_conf('hosts') } ) { + + my $hosts; + for my $href ( @{$conf->get_conf('hosts')} ) { + $hosts .= "\t$href->{scheme}://$href->{host}$href->{path}\n"; + } + + print loc(" +I see you already have some hosts selected: + +$hosts + +If you'd like to stick with your current settings, just select 'Yes'. +Otherwise, select 'No' and you can reconfigure your hosts + +"); + my $yn = $term->ask_yn( + prompt => loc("Would you like to keep your current hosts?"), + default => 'y', + ); + return 1 if $yn; + } + + my @hosts; + MAIN: { + + print loc(" +Now we need to know where your favorite CPAN sites are located. Make a +list of a few sites (just in case the first on the array won't work). + +If you are mirroring CPAN to your local workstation, specify a file: +URI by picking the CUSTOM option. + +Otherwise, let us fetch the official CPAN mirror list and you can pick +the mirror that suits you best from a list by using the MIRROR option; +First, pick a nearby continent and country. Then, you will be presented +with a list of URLs of CPAN mirrors in the country you selected. Select +one or more of those URLs. + +Note, the latter option requires a working net connection. + +You can select VIEW to see your current selection and QUIT when you +are done. + +"); + + my $reply = $term->get_reply( + prompt => loc('Please choose an option'), + choices => [qw|Mirror Custom View Quit|], + default => 'Mirror', + ); + + goto MIRROR if $reply eq 'Mirror'; + goto CUSTOM if $reply eq 'Custom'; + goto QUIT if $reply eq 'Quit'; + + $self->_view_hosts(@hosts) if $reply eq 'View'; + redo MAIN; + } + + my $mirror_file; + my $hosts; + MIRROR: { + $mirror_file ||= $self->_get_mirrored_by or return; + $hosts ||= $self->_parse_mirrored_by($mirror_file) or return; + + my ($continent, $country, $host) = $self->_guess_from_timezone( $hosts ); + + CONTINENT: { + my %seen; + my @choices = sort map { + $_->{'continent'} + } grep { + not $seen{$_->{'continent'}}++ + } values %$hosts; + push @choices, qw[Custom Up Quit]; + + my $reply = $term->get_reply( + prompt => loc('Pick a continent'), + default => $continent, + choices => \@choices, + ); + + goto MAIN if $reply eq 'Up'; + goto CUSTOM if $reply eq 'Custom'; + goto QUIT if $reply eq 'Quit'; + + $continent = $reply; + } + + COUNTRY: { + my %seen; + my @choices = sort map { + $_->{'country'} + } grep { + not $seen{$_->{'country'}}++ + } grep { + ($_->{'continent'} eq $continent) + } values %$hosts; + push @choices, qw[Custom Up Quit]; + + my $reply = $term->get_reply( + prompt => loc('Pick a country'), + default => $country, + choices => \@choices, + ); + + goto CONTINENT if $reply eq 'Up'; + goto CUSTOM if $reply eq 'Custom'; + goto QUIT if $reply eq 'Quit'; + + $country = $reply; + } + + HOST: { + my @list = grep { + $_->{'continent'} eq $continent and + $_->{'country'} eq $country + } values %$hosts; + + my %map; my $default; + for my $href (@list) { + for my $con ( @{$href->{'connections'}} ) { + next unless length $con->{'host'}; + + my $entry = $con->{'scheme'} . '://' . $con->{'host'}; + $default = $entry if $con->{'host'} eq $host; + + $map{$entry} = $con; + } + } + + CHOICE: { + + ### doesn't play nice with Term::UI :( + ### should make t::ui figure out pager opens + #$self->_pager_open; # host lists might be long + + print loc(" +You can enter multiple sites by seperating them by a space. +For example: + 1 4 2 5 + "); + + my @reply = $term->get_reply( + prompt => loc('Please pick a site: '), + choices => [sort(keys %map), + qw|Custom View Up Quit|], + default => $default, + multi => 1, + ); + #$self->_pager_close; + + + goto COUNTRY if grep { $_ eq 'Up' } @reply; + goto CUSTOM if grep { $_ eq 'Custom' } @reply; + goto QUIT if grep { $_ eq 'Quit' } @reply; + + ### add the host, but only if it's not on the stack already ### + unless( grep { $_ eq 'View' } @reply ) { + for my $reply (@reply) { + if( grep { $_ eq $map{$reply} } @hosts ) { + print loc("Host '%1' already selected", $reply); + print "\n\n"; + } else { + push @hosts, $map{$reply} + } + } + } + + $self->_view_hosts(@hosts); + + goto QUIT if $self->autoreply; + redo CHOICE; + } + } + } + + CUSTOM: { + print loc(" +If there are any additional URLs you would like to use, please add them +now. You may enter them separately or as a space delimited list. + +We provide a default fall-back URL, but you are welcome to override it +with e.g. 'http://www.cpan.org/' if LWP, wget or curl is installed. + +(Enter a single space when you are done, or to simply skip this step.) + +Note that if you want to use a local depository, you will have to enter +as follows: + +file://server/path/to/cpan + +if the file is on a server on your local network or as: + +file:///path/to/cpan + +if the file is on your local disk. Note the three /// after the file: bit + +"); + + CHOICE: { + my $reply = $term->get_reply( + prompt => loc("Additionals host(s) to add: "), + default => '', + ); + + last CHOICE unless $reply =~ /\S/; + + my $href = $self->_parse_host($reply); + + if( $href ) { + push @hosts, $href + unless grep { + $href->{'scheme'} eq $_->{'scheme'} and + $href->{'host'} eq $_->{'host'} and + $href->{'path'} eq $_->{'path'} + } @hosts; + + last CHOICE if $self->autoreply; + } else { + print loc("Invalid uri! Please try again!"); + } + + $self->_view_hosts(@hosts); + + redo CHOICE; + } + + DONE: { + + print loc(" +Where would you like to go now? + +Please pick one of the following options or Quit when you are done + +"); + my $answer = $term->get_reply( + prompt => loc("Where to now?"), + default => 'Quit', + choices => [qw|Mirror Custom View Quit|], + ); + + if( $answer eq 'View' ) { + $self->_view_hosts(@hosts); + redo DONE; + } + + goto MIRROR if $answer eq 'Mirror'; + goto CUSTOM if $answer eq 'Custom'; + goto QUIT if $answer eq 'Quit'; + } + } + + QUIT: { + $conf->set_conf( hosts => \@hosts ); + + print loc(" +Your host configuration has been saved + +"); + } + + return 1; +} + +sub _view_hosts { + my $self = shift; + my @hosts = @_; + + print "\n\n"; + + if( scalar @hosts ) { + my $i = 1; + for my $host (@hosts) { + + ### show full path on file uris, otherwise, just show host + my $path = join '', ( + $host->{'scheme'} eq 'file' + ? ( ($host->{'host'} || '[localhost]'), + $host->{path} ) + : $host->{'host'} + ); + + printf "%-40s %30s\n", + loc("Selected %1",$host->{'scheme'} . '://' . $path ), + loc("%quant(%2,host) selected thus far.", $i); + $i++; + } + } else { + print loc("No hosts selected so far."); + } + + print "\n\n"; + + return 1; +} + +sub _get_mirrored_by { + my $self = shift; + my $cpan = $self->backend; + my $conf = $self->configure_object; + + print loc(" +Now, we are going to fetch the mirror list for first-time configurations. +This may take a while... + +"); + + ### use the enew configuratoin ### + $cpan->configure_object( $conf ); + + load CPANPLUS::Module::Fake; + load CPANPLUS::Module::Author::Fake; + + my $mb = CPANPLUS::Module::Fake->new( + module => $conf->_get_source('hosts'), + path => '', + package => $conf->_get_source('hosts'), + author => CPANPLUS::Module::Author::Fake->new( + _id => $cpan->_id ), + _id => $cpan->_id, + ); + + my $file = $cpan->_fetch( fetchdir => $conf->get_conf('base'), + module => $mb ); + + return $file if $file; + return; +} + +sub _parse_mirrored_by { + my $self = shift; + my $file = shift; + + -s $file or return; + + my $fh = new FileHandle; + $fh->open("$file") + or ( + warn(loc('Could not open file "%1": %2', $file, $!)), + return + ); + + ### slurp the file in ### + { local $/; $file = <$fh> } + + ### remove comments ### + $file =~ s/#.*$//gm; + + $fh->close; + + ### sample host entry ### + # ftp.sun.ac.za: + # frequency = "daily" + # dst_ftp = "ftp://ftp.sun.ac.za/CPAN/CPAN/" + # dst_location = "Stellenbosch, South Africa, Africa (-26.1992 28.0564)" + # dst_organisation = "University of Stellenbosch" + # dst_timezone = "+2" + # dst_contact = "ftpadm@ftp.sun.ac.za" + # dst_src = "ftp.funet.fi" + # + # # dst_dst = "ftp://ftp.sun.ac.za/CPAN/CPAN/" + # # dst_contact = "mailto:ftpadm@ftp.sun.ac.za + # # dst_src = "ftp.funet.fi" + + ### host name as key, rest of the entry as value ### + my %hosts = $file =~ m/([a-zA-Z0-9\-\.]+):\s+((?:\w+\s+=\s+".*?"\s+)+)/gs; + + while (my($host,$data) = each %hosts) { + + my $href; + map { + s/^\s*//; + my @a = split /\s*=\s*/; + $a[1] =~ s/^"(.+?)"$/$1/g; + $href->{ pop @a } = pop @a; + } grep /\S/, split /\n/, $data; + + ($href->{city_area}, $href->{country}, $href->{continent}, + $href->{latitude}, $href->{longitude} ) = + $href->{dst_location} =~ + m/ + #Aizu-Wakamatsu, Tohoku-chiho, Fukushima + ^"?( + (?:[^,]+?)\s* # city + (?: + (?:,\s*[^,]+?)\s* # optional area + )*? # some have multiple areas listed + ) + + #Japan + ,\s*([^,]+?)\s* # country + + #Asia + ,\s*([^,]+?)\s* # continent + + # (37.4333 139.9821) + \((\S+)\s+(\S+?)\)"?$ # (latitude longitude) + /sx; + + ### parse the different hosts, store them in config format ### + my @list; + + for my $type (qw[dst_ftp dst_rsync dst_http]) { + my $path = $href->{$type}; + next unless $path =~ /\w/; + if ($type eq 'dst_rsync' && $path !~ /^rsync:/) { + $path =~ s{::}{/}; + $path = "rsync://$path/"; + } + my $parts = $self->_parse_host($path); + push @list, $parts; + } + + $href->{connections} = \@list; + $hosts{$host} = $href; + } + + return \%hosts; +} + +sub _parse_host { + my $self = shift; + my $host = shift; + + my @parts = $host =~ m|^(\w*)://([^/]*)(/.*)$|s; + + my $href; + for my $key (qw[scheme host path]) { + $href->{$key} = shift @parts; + } + + return if lc($href->{'scheme'}) ne 'file' and !$href->{'host'}; + return if !$href->{'path'}; + + return $href; +} + +## tries to figure out close hosts based on your timezone +## +## Currently can only report on unique items for each of zones, countries, and +## sites. In the future this will be combined with something else (perhaps a +## ping?) to narrow down multiple choices. +## +## Tries to return the best zone, country, and site for your location. Any non- +## unique items will be set to undef instead. +## +## (takes hashref, returns array) +## +sub _guess_from_timezone { + my $self = shift; + my $hosts = shift; + my (%zones, %countries, %sites); + + ### autrijus - build time zone table + my %freq_weight = ( + 'hourly' => 2400, + '4 times a day' => 400, + '4x daily' => 400, + 'daily' => 100, + 'twice daily' => 50, + 'weekly' => 15, + ); + + while (my ($site, $host) = each %{$hosts}) { + my ($zone, $continent, $country, $frequency) = + @{$host}{qw/dst_timezone continent country frequency/}; + + + # skip non-well-formed ones + next unless $continent and $country and $zone =~ /^[-+]?\d+(?::30)?/; + ### fix style + chomp $zone; + $zone =~ s/:30/.5/; + $zone =~ s/^\+//; + $zone =~ s/"//g; + + $zones{$zone}{$continent}++; + $countries{$zone}{$continent}{$country}++; + $sites{$zone}{$continent}{$country}{$site} = $freq_weight{$frequency}; + } + + use Time::Local; + my $offset = ((timegm(localtime) - timegm(gmtime)) / 3600); + + local $_; + + ## pick the entry with most country/site/frequency, one level each; + ## note it has to be sorted -- otherwise we're depending on the hash order. + ## also, the list context assignment (pick first one) is deliberate. + + my ($continent) = map { + (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_})) + } $zones{$offset}; + + my ($country) = map { + (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_})) + } $countries{$offset}{$continent}; + + my ($site) = map { + (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_})) + } $sites{$offset}{$continent}{$country}; + + return ($continent, $country, $site); +} # _guess_from_timezone + + +### big big regex, stolen to check if you enter a valid address +{ + my $RFC822PAT; # RFC pattern to match for valid email address + + sub _valid_email { + my $self = shift; + if (!$RFC822PAT) { + my $esc = '\\\\'; my $Period = '\.'; my $space = '\040'; + my $tab = '\t'; my $OpenBR = '\['; my $CloseBR = '\]'; + my $OpenParen = '\('; my $CloseParen = '\)'; my $NonASCII = '\x80-\xff'; + my $ctrl = '\000-\037'; my $CRlist = '\012\015'; + + my $qtext = qq/[^$esc$NonASCII$CRlist\"]/; + my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/; + my $quoted_pair = qq< $esc [^$NonASCII] >; # an escaped character + my $ctext = qq< [^$esc$NonASCII$CRlist()] >; + my $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >; + my $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >; + my $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >; + my $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/; + my $atom = qq< $atom_char+ (?!$atom_char) >; + my $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >; + my $word = qq< (?: $atom | $quoted_str ) >; + my $domain_ref = $atom; + my $domain_lit = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >; + my $sub_domain = qq< (?: $domain_ref | $domain_lit) $X >; + my $domain = qq< $sub_domain (?: $Period $X $sub_domain)* >; + my $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >; + my $local_part = qq< $word $X (?: $Period $X $word $X )* >; + my $addr_spec = qq< $local_part \@ $X $domain >; + my $route_addr = qq[ < $X (?: $route )? $addr_spec > ]; + my $phrase_ctrl = '\000-\010\012-\037'; # like ctrl, but without tab + my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/; + my $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >; + $RFC822PAT = qq< $X (?: $addr_spec | $phrase $route_addr) >; + } + + return scalar ($_[0] =~ /$RFC822PAT/ox); + } +} + + + + + + +1; + + +sub _edit { + my $self = shift; + my $conf = $self->configure_object; + my $file = shift || $conf->_config_pm_to_file( $self->config_type ); + my $editor = shift || $conf->get_program('editor'); + my $term = $self->term; + + unless( $editor ) { + print loc(" +I'm sorry, I can't find a suitable editor, so I can't offer you +post-configuration editing of the config file + +"); + return 1; + } + + ### save the thing first, so there's something to edit + $self->_save; + + return !system("$editor $file"); +} + +sub _save { + my $self = shift; + my $conf = $self->configure_object; + + return $conf->save( $self->config_type ); +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist.pm new file mode 100755 index 00000000000..00c68c39806 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist.pm @@ -0,0 +1,688 @@ +package CPANPLUS::Dist; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use Cwd (); +use Object::Accessor; +use Parse::CPAN::Meta; + +use IPC::Cmd qw[run]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +use base 'Object::Accessor'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Dist + +=head1 SYNOPSIS + + my $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new( + module => $modobj, + ); + +=head1 DESCRIPTION + +C<CPANPLUS::Dist> is a base class for C<CPANPLUS::Dist::MM> +and C<CPANPLUS::Dist::Build>. Developers of other C<CPANPLUS::Dist::*> +plugins should look at C<CPANPLUS::Dist::Base>. + +=head1 ACCESSORS + +=over 4 + +=item parent() + +Returns the C<CPANPLUS::Module> object that parented this object. + +=item status() + +Returns the C<Object::Accessor> object that keeps the status for +this module. + +=back + +=head1 STATUS ACCESSORS + +All accessors can be accessed as follows: + $deb->status->ACCESSOR + +=over 4 + +=item created() + +Boolean indicating whether the dist was created successfully. +Explicitly set to C<0> when failed, so a value of C<undef> may be +interpreted as C<not yet attempted>. + +=item installed() + +Boolean indicating whether the dist was installed successfully. +Explicitly set to C<0> when failed, so a value of C<undef> may be +interpreted as C<not yet attempted>. + +=item uninstalled() + +Boolean indicating whether the dist was uninstalled successfully. +Explicitly set to C<0> when failed, so a value of C<undef> may be +interpreted as C<not yet attempted>. + +=item dist() + +The location of the final distribution. This may be a file or +directory, depending on how your distribution plug in of choice +works. This will be set upon a successful create. + +=cut + +=back + +=head2 $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new( module => MODOBJ ); + +Create a new C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object based on the +provided C<MODOBJ>. + +*** DEPRECATED *** +The optional argument C<format> is used to indicate what type of dist +you would like to create (like C<CPANPLUS::Dist::MM> or +C<CPANPLUS::Dist::Build> and so on ). + +C<< CPANPLUS::Dist->new >> is exlusively meant as a method to be +inherited by C<CPANPLUS::Dist::MM|Build>. + +Returns a C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object on success +and false on failure. + +=cut + +sub new { + my $self = shift; + my $class = ref $self || $self; + my %hash = @_; + + ### first verify we got a module object ### + my( $mod, $format ); + my $tmpl = { + module => { required => 1, allow => IS_MODOBJ, store => \$mod }, + ### for backwards compatibility + format => { default => $class, store => \$format, + allow => [ __PACKAGE__->dist_types ], + }, + }; + check( $tmpl, \%hash ) or return; + + unless( can_load( modules => { $format => '0.0' }, verbose => 1 ) ) { + error(loc("'%1' not found -- you need '%2' version '%3' or higher ". + "to detect plugins", $format, 'Module::Pluggable','2.4')); + return; + } + + ### get an empty o::a object for this class + my $obj = $format->SUPER::new; + + $obj->mk_accessors( qw[parent status] ); + + ### set the parent + $obj->parent( $mod ); + + ### create a status object ### + { my $acc = Object::Accessor->new; + $obj->status($acc); + + ### add minimum supported accessors + $acc->mk_accessors( qw[prepared created installed uninstalled + distdir dist] ); + } + + ### get the conf object ### + my $conf = $mod->parent->configure_object(); + + ### check if the format is available in this environment ### + if( $conf->_get_build('sanity_check') and not $obj->format_available ) { + error( loc( "Format '%1' is not available", $format) ); + return; + } + + ### now initialize it or admit failure + unless( $obj->init ) { + error(loc("Dist initialization of '%1' failed for '%2'", + $format, $mod->module)); + return; + } + + ### return the object + return $obj; +} + +=head2 @dists = CPANPLUS::Dist->dist_types; + +Returns a list of the CPANPLUS::Dist::* classes available + +=cut + +### returns a list of dist_types we support +### will get overridden by Module::Pluggable if loaded +### XXX add support for 'plugin' dir in config as well +{ my $Loaded; + my @Dists = (INSTALLER_MM); + my @Ignore = (); + + ### backdoor method to add more dist types + sub _add_dist_types { my $self = shift; push @Dists, @_ }; + + ### backdoor method to exclude dist types + sub _ignore_dist_types { my $self = shift; push @Ignore, @_ }; + sub _reset_dist_ignore { @Ignore = () }; + + ### locally add the plugins dir to @INC, so we can find extra plugins + #local @INC = @INC, File::Spec->catdir( + # $conf->get_conf('base'), + # $conf->_get_build('plugins') ); + + ### load any possible plugins + sub dist_types { + + if ( !$Loaded++ and check_install( module => 'Module::Pluggable', + version => '2.4') + ) { + require Module::Pluggable; + + my $only_re = __PACKAGE__ . '::\w+$'; + my %except = map { $_ => 1 } + INSTALLER_SAMPLE, + INSTALLER_BASE; + + Module::Pluggable->import( + sub_name => '_dist_types', + search_path => __PACKAGE__, + only => qr/$only_re/, + require => 1, + except => [ keys %except ] + ); + my %ignore = map { $_ => $_ } @Ignore; + + push @Dists, grep { not $ignore{$_} and not $except{$_} } + __PACKAGE__->_dist_types; + } + + return @Dists; + } + +=head2 $bool = CPANPLUS::Dist->rescan_dist_types; + +Rescans C<@INC> for available dist types. Useful if you've installed new +C<CPANPLUS::Dist::*> classes and want to make them available to the +current process. + +=cut + + sub rescan_dist_types { + my $dist = shift; + $Loaded = 0; # reset the flag; + return $dist->dist_types; + } +} + +=head2 $bool = CPANPLUS::Dist->has_dist_type( $type ) + +Returns true if distribution type C<$type> is loaded/supported. + +=cut + +sub has_dist_type { + my $dist = shift; + my $type = shift or return; + + return scalar grep { $_ eq $type } CPANPLUS::Dist->dist_types; +} + +=head2 $bool = $dist->prereq_satisfied( modobj => $modobj, version => $version_spec ) + +Returns true if this prereq is satisfied. Returns false if it's not. +Also issues an error if it seems "unsatisfiable," i.e. if it can't be +found on CPAN or the latest CPAN version doesn't satisfy it. + +=cut + +sub prereq_satisfied { + my $dist = shift; + my $cb = $dist->parent->parent; + my %hash = @_; + + my($mod,$ver); + my $tmpl = { + version => { required => 1, store => \$ver }, + modobj => { required => 1, store => \$mod, allow => IS_MODOBJ }, + }; + + check( $tmpl, \%hash ) or return; + + return 1 if $mod->is_uptodate( version => $ver ); + + if ( $cb->_vcmp( $ver, $mod->version ) > 0 ) { + + error(loc( + "This distribution depends on %1, but the latest version". + " of %2 on CPAN (%3) doesn't satisfy the specific version". + " dependency (%4). You may have to resolve this dependency ". + "manually.", + $mod->module, $mod->module, $mod->version, $ver )); + + } + + return; +} + +=head2 $configure_requires = $dist->find_configure_requires( [file => /path/to/META.yml] ) + +Reads the configure_requires for this distribution from the META.yml +file in the root directory and returns a hashref with module names +and versions required. + +=cut + +sub find_configure_requires { + my $self = shift; + my $mod = $self->parent; + my $meth = 'configure_requires'; + + ### the prereqs as we have them now + my @args = ( + defaults => $mod->status->$meth || {}, + keys => [ $meth ], + ); + + ### the default file to use, which may be overriden + push @args, ( file => META_YML->( $mod->status->extract ) ) + if defined $mod->status->extract; + + my $href = $self->_prereqs_from_meta_file( @args, @_ ); + + ### and store it in the module + $mod->status->$meth( $href ); + + return { %$href }; +} + +sub find_mymeta_requires { + my $self = shift; + my $mod = $self->parent; + my $meth = 'prereqs'; + + ### the prereqs as we have them now + my @args = ( + defaults => $mod->status->$meth || {}, + keys => [qw|requires build_requires|], + ); + + ### the default file to use, which may be overriden + push @args, ( file => MYMETA_YML->( $mod->status->extract ) ) + if defined $mod->status->extract; + + my $href = $self->_prereqs_from_meta_file( @args, @_ ); + + ### and store it in the module + $mod->status->$meth( $href ); + + return { %$href }; +} + +sub _prereqs_from_meta_file { + my $self = shift; + my $mod = $self->parent; + my %hash = @_; + + my( $meta, $defaults, $keys ); + my $tmpl = { ### check if we have an extract path. if not, we + ### get 'undef value' warnings from file::spec + file => { default => do { defined $mod->status->extract + ? META_YML->( $mod->status->extract ) + : '' }, + store => \$meta, + }, + defaults => { required => 1, default => {}, strict_type => 1, + store => \$defaults }, + keys => { required => 1, default => [], strict_type => 1, + store => \$keys }, + }; + + check( $tmpl, \%hash ) or return; + + ### if there's a meta file, we read it; + if( -e $meta ) { + + ### Parse::CPAN::Meta uses exceptions for errors + ### hash returned in list context!!! + my ($doc) = eval { Parse::CPAN::Meta::LoadFile( $meta ) }; + + unless( $doc ) { + error(loc( "Could not read %1: '%2'", $meta, $@ )); + return $defaults; + } + + ### read the keys now, make sure not to throw + ### away anything that was already added + for my $key ( @$keys ) { + $defaults = { + %$defaults, + %{ $doc->{$key} }, + } if $doc->{ $key }; + } + } + + ### and return a copy + return \%{ $defaults }; +} + +=head2 $bool = $dist->_resolve_prereqs( ... ) + +Makes sure prerequisites are resolved + + format The dist class to use to make the prereqs + (ie. CPANPLUS::Dist::MM) + + prereqs Hash of the prerequisite modules and their versions + + target What to do with the prereqs. + create => Just build them + install => Install them + ignore => Ignore them + + prereq_build If true, always build the prereqs even if already + resolved + + verbose Be verbose + + force Force the prereq to be built, even if already resolved + +=cut + +sub _resolve_prereqs { + my $dist = shift; + my $self = $dist->parent; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my ($prereqs, $format, $verbose, $target, $force, $prereq_build); + my $tmpl = { + ### XXX perhaps this should not be required, since it may not be + ### packaged, just installed... + ### Let it be empty as well -- that means the $modobj->install + ### routine will figure it out, which is fine if we didn't have any + ### very specific wishes (it will even detect the favourite + ### dist_type). + format => { required => 1, store => \$format, + allow => ['',__PACKAGE__->dist_types], }, + prereqs => { required => 1, default => { }, + strict_type => 1, store => \$prereqs }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + force => { default => $conf->get_conf('force'), + store => \$force }, + ### make sure allow matches with $mod->install's list + target => { default => '', store => \$target, + allow => ['',qw[create ignore install]] }, + prereq_build => { default => 0, store => \$prereq_build }, + }; + + check( $tmpl, \%hash ) or return; + + ### so there are no prereqs? then don't even bother + return 1 unless keys %$prereqs; + + ### Make sure we wound up where we started. + my $original_wd = Cwd::cwd; + + ### so you didn't provide an explicit target. + ### maybe your config can tell us what to do. + $target ||= { + PREREQ_ASK, TARGET_INSTALL, # we'll bail out if the user says no + PREREQ_BUILD, TARGET_CREATE, + PREREQ_IGNORE, TARGET_IGNORE, + PREREQ_INSTALL, TARGET_INSTALL, + }->{ $conf->get_conf('prereqs') } || ''; + + ### XXX BIG NASTY HACK XXX FIXME at some point. + ### when installing Bundle::CPANPLUS::Dependencies, we want to + ### install all packages matching 'cpanplus' to be installed last, + ### as all CPANPLUS' prereqs are being installed as well, but are + ### being loaded for bootstrapping purposes. This means CPANPLUS + ### can find them, but for example cpanplus::dist::build won't, + ### which gets messy FAST. So, here we sort our prereqs only IF + ### the parent module is Bundle::CPANPLUS::Dependencies. + ### Really, we would wnat some sort of sorted prereq mechanism, + ### but Bundle:: doesn't support it, and we flatten everything + ### to a hash internally. A sorted hash *might* do the trick if + ### we got a transparent implementation.. that would mean we would + ### just have to remove the 'sort' here, and all will be well + my @sorted_prereqs; + + ### use regex, could either be a module name, or a package name + if( $self->module =~ /^Bundle(::|-)CPANPLUS(::|-)Dependencies/ ) { + my (@first, @last); + for my $mod ( sort keys %$prereqs ) { + $mod =~ /CPANPLUS/ + ? push @last, $mod + : push @first, $mod; + } + @sorted_prereqs = (@first, @last); + } else { + @sorted_prereqs = sort keys %$prereqs; + } + + ### first, transfer this key/value pairing into a + ### list of module objects + desired versions + my @install_me; + + for my $mod ( @sorted_prereqs ) { + my $version = $prereqs->{$mod}; + + ### 'perl' is a special case, there's no mod object for it + if( $mod eq PERL_CORE ) { + + ### run a CLI invocation to see if the perl you specified is + ### uptodate + my $ok = run( command => "$^X -M$version -e1", verbose => 0 ); + + unless( $ok ) { + error(loc( "Module '%1' needs perl version '%2', but you ". + "only have version '%3' -- can not proceed", + $self->module, $version, + $cb->_perl_version( perl => $^X ) ) ); + return; + } + + next; + } + + my $modobj = $cb->module_tree($mod); + + #### XXX we ignore the version, and just assume that the latest + #### version from cpan will meet your requirements... dodgy =/ + unless( $modobj ) { + # Check if it is a core module + my $sub = CPANPLUS::Module->can( + 'module_is_supplied_with_perl_core' ); + my $core = $sub->( $mod ); + unless ( $core ) { + error( loc( "No such module '%1' found on CPAN", $mod ) ); + next; + } + if ( $cb->_vcmp( $version, $core ) > 0 ) { + error(loc( "Version of core module '%1' ('%2') is too low for ". + "'%3' (needs '%4') -- carrying on but this may be a problem", + $mod, $core, + $self->module, $version )); + } + next; + } + + ### it's not uptodate, we need to install it + if( !$dist->prereq_satisfied(modobj => $modobj, version => $version)) { + msg(loc("Module '%1' requires '%2' version '%3' to be installed ", + $self->module, $modobj->module, $version), $verbose ); + + push @install_me, [$modobj, $version]; + + ### it's not an MM or Build format, that means it's a package + ### manager... we'll need to install it as well, via the PM + } elsif ( INSTALL_VIA_PACKAGE_MANAGER->($format) and + !$modobj->package_is_perl_core and + ($target ne TARGET_IGNORE) + ) { + msg(loc("Module '%1' depends on '%2', may need to build a '%3' ". + "package for it as well", $self->module, $modobj->module, + $format)); + push @install_me, [$modobj, $version]; + } + } + + + + ### so you just want to ignore prereqs? ### + if( $target eq TARGET_IGNORE ) { + + ### but you have modules you need to install + if( @install_me ) { + msg(loc("Ignoring prereqs, this may mean your install will fail"), + $verbose); + msg(loc("'%1' listed the following dependencies:", $self->module), + $verbose); + + for my $aref (@install_me) { + my ($mod,$version) = @$aref; + + my $str = sprintf "\t%-35s %8s\n", $mod->module, $version; + msg($str,$verbose); + } + + return; + + ### ok, no problem, you have all needed prereqs anyway + } else { + return 1; + } + } + + my $flag; + for my $aref (@install_me) { + my($modobj,$version) = @$aref; + + ### another prereq may have already installed this one... + ### so dont ask again if the module turns out to be uptodate + ### see bug [#11840] + ### if either force or prereq_build are given, the prereq + ### should be built anyway + next if (!$force and !$prereq_build) && + $dist->prereq_satisfied(modobj => $modobj, version => $version); + + ### either we're told to ignore the prereq, + ### or the user wants us to ask him + if( ( $conf->get_conf('prereqs') == PREREQ_ASK and not + $cb->_callbacks->install_prerequisite->($self, $modobj) + ) + ) { + msg(loc("Will not install prerequisite '%1' -- Note " . + "that the overall install may fail due to this", + $modobj->module), $verbose); + next; + } + + ### value set and false -- means failure ### + if( defined $modobj->status->installed + && !$modobj->status->installed + ) { + error( loc( "Prerequisite '%1' failed to install before in " . + "this session", $modobj->module ) ); + $flag++; + last; + } + + ### part of core? + if( $modobj->package_is_perl_core ) { + error(loc("Prerequisite '%1' is perl-core (%2) -- not ". + "installing that. Aborting install", + $modobj->module, $modobj->package ) ); + $flag++; + last; + } + + ### circular dependency code ### + my $pending = $cb->_status->pending_prereqs || {}; + + ### recursive dependency ### + if ( $pending->{ $modobj->module } ) { + error( loc( "Recursive dependency detected (%1) -- skipping", + $modobj->module ) ); + next; + } + + ### register this dependency as pending ### + $pending->{ $modobj->module } = $modobj; + $cb->_status->pending_prereqs( $pending ); + + ### call $modobj->install rather than doing + ### CPANPLUS::Dist->new and the like ourselves, + ### since ->install will take care of fetch && + ### extract as well + my $pa = $dist->status->_prepare_args || {}; + my $ca = $dist->status->_create_args || {}; + my $ia = $dist->status->_install_args || {}; + + unless( $modobj->install( %$pa, %$ca, %$ia, + force => $force, + verbose => $verbose, + format => $format, + target => $target ) + ) { + error(loc("Failed to install '%1' as prerequisite " . + "for '%2'", $modobj->module, $self->module ) ); + $flag++; + } + + ### unregister the pending dependency ### + $pending->{ $modobj->module } = 0; + $cb->_status->pending_prereqs( $pending ); + + last if $flag; + + ### don't want us to install? ### + if( $target ne TARGET_INSTALL ) { + my $dir = $modobj->status->extract + or error(loc("No extraction dir for '%1' found ". + "-- weird", $modobj->module)); + + $modobj->add_to_includepath(); + + next; + } + } + + ### reset the $prereqs iterator, in case we bailed out early ### + keys %$prereqs; + + ### chdir back to where we started + $cb->_chdir( dir => $original_wd ); + + return 1 unless $flag; + return; +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Autobundle.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Autobundle.pm new file mode 100755 index 00000000000..16638b258f8 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Autobundle.pm @@ -0,0 +1,117 @@ +package CPANPLUS::Dist::Autobundle; + +use strict; +use warnings; +use CPANPLUS::Error qw[error msg]; +use Params::Check qw[check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +use base qw[CPANPLUS::Dist::Base]; + +=head1 NAME + +CPANPLUS::Dist::Autobundle + +=head1 SYNOPSIS + + $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' ); + $modobj->install; + +=head1 DESCRIPTION + +C<CPANPLUS::Dist::Autobundle> is a distribution class for installing installation +snapshots as created by C<CPANPLUS>' C<autobundle> command. + +All modules as mentioned in the snapshot will be installed on your system. + +=cut + +sub init { + my $dist = shift; + my $status = $dist->status; + + $status->mk_accessors( + qw[prepared created installed _prepare_args _create_args _install_args] + ); + + return 1; +} + +sub prepare { + my $dist = shift; + my %args = @_; + + ### store the arguments, so ->install can use them in recursive loops ### + $dist->status->_prepare_args( \%args ); + + return $dist->status->prepared( 1 ); +} + +sub create { + my $dist = shift; + my $self = $dist->parent; + + ### we're also the cpan_dist, since we don't need to have anything + ### prepared + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my( $force, $verbose, $prereq_target, $prereq_format, $prereq_build); + + my $args = do { + local $Params::Check::ALLOW_UNKNOWN = 1; + my $tmpl = { + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + prereq_target => { default => '', store => \$prereq_target }, + + ### don't set the default prereq format to 'makemaker' -- wrong! + prereq_format => { #default => $self->status->installer_type, + default => '', + store => \$prereq_format }, + prereq_build => { default => 0, store => \$prereq_build }, + }; + + check( $tmpl, \%hash ) or return; + }; + + ### maybe we already ran a create on this object? ### + return 1 if $dist->status->created && !$force; + + ### store the arguments, so ->install can use them in recursive loops ### + $dist->status->_create_args( \%hash ); + + msg(loc("Resolving prerequisites mentioned in the bundle"), $verbose); + + ### this will set the directory back to the start + ### dir, so we must chdir /again/ + my $ok = $dist->_resolve_prereqs( + format => $prereq_format, + verbose => $verbose, + prereqs => $self->status->prereqs, + target => $prereq_target, + force => $force, + prereq_build => $prereq_build, + ); + + ### if all went well, mark it & return + return $dist->status->created( $ok ? 1 : 0); +} + +sub install { + my $dist = shift; + my %args = @_; + + ### store the arguments, so ->install can use them in recursive loops ### + $dist->status->_install_args( \%args ); + + return $dist->status->installed( 1 ); +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Base.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Base.pm new file mode 100755 index 00000000000..c7108ed1392 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Base.pm @@ -0,0 +1,261 @@ +package CPANPLUS::Dist::Base; + +use strict; + +use base qw[CPANPLUS::Dist]; +use vars qw[$VERSION]; +$VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION; + + +=head1 NAME + +CPANPLUS::Dist::Base - Base class for custom distribution classes + +=head1 SYNOPSIS + + package CPANPLUS::Dist::MY_IMPLEMENTATION + + use base 'CPANPLUS::Dist::Base'; + + sub prepare { + my $dist = shift; + + ### do the 'standard' things + $dist->SUPER::prepare( @_ ) or return; + + ### do MY_IMPLEMENTATION specific things + ... + + ### don't forget to set the status! + return $dist->status->prepared( $SUCCESS ? 1 : 0 ); + } + + +=head1 DESCRIPTION + +CPANPLUS::Dist::Base functions as a base class for all custom +distribution implementations. It does all the mundane work +CPANPLUS would have done without a custom distribution, so you +can override just the parts you need to make your own implementation +work. + +=head1 FLOW + +Below is a brief outline when and in which order methods in this +class are called: + + $Class->format_available; # can we use this class on this system? + + $dist->init; # set up custom accessors, etc + $dist->prepare; # find/write meta information + $dist->create; # write the distribution file + $dist->install; # install the distribution file + + $dist->uninstall; # remove the distribution (OPTIONAL) + +=head1 METHODS + +=cut + +=head2 @subs = $Class->methods + +Returns a list of methods that this class implements that you can +override. + +=cut + +sub methods { + return qw[format_available init prepare create install uninstall] +} + +=head2 $bool = $Class->format_available + +This method is called when someone requests a module to be installed +via the superclass. This gives you the opportunity to check if all +the needed requirements to build and install this distribution have +been met. + +For example, you might need a command line program, or a certain perl +module installed to do your job. Now is the time to check. + +Simply return true if the request can proceed and false if it can not. + +The C<CPANPLUS::Dist::Base> implementation always returns true. + +=cut + +sub format_available { return 1 } + + +=head2 $bool = $dist->init + +This method is called just after the new dist object is set up and +before the C<prepare> method is called. This is the time to set up +the object so it can be used with your class. + +For example, you might want to add extra accessors to the C<status> +object, which you might do as follows: + + $dist->status->mk_accessors( qw[my_implementation_accessor] ); + +The C<status> object is implemented as an instance of the +C<Object::Accessor> class. Please refer to its documentation for +details. + +Return true if the initialization was successul, and false if it was +not. + +The C<CPANPLUS::Dist::Base> implementation does not alter your object +and always returns true. + +=cut + +sub init { return 1; } + +=head2 $bool = $dist->prepare + +This runs the preparation step of your distribution. This step is meant +to set up the environment so the C<create> step can create the actual +distribution(file). +A C<prepare> call in the standard C<ExtUtils::MakeMaker> distribution +would, for example, run C<perl Makefile.PL> to find the dependencies +for a distribution. For a C<debian> distribution, this is where you +would write all the metafiles required for the C<dpkg-*> tools. + +The C<CPANPLUS::Dist::Base> implementation simply calls the underlying +distribution class (Typically C<CPANPLUS::Dist::MM> or +C<CPANPLUS::Dist::Build>). + +Sets C<< $dist->status->prepared >> to the return value of this function. +If you override this method, you should make sure to set this value. + +=cut + +sub prepare { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + my $dist_cpan = $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + + $dist->status->prepared( $dist_cpan->prepare( @_ ) ); +} + +=head2 $bool = $dist->create + +This runs the creation step of your distribution. This step is meant +to follow up on the C<prepare> call, that set up your environment so +the C<create> step can create the actual distribution(file). +A C<create> call in the standard C<ExtUtils::MakeMaker> distribution +would, for example, run C<make> and C<make test> to build and test +a distribution. For a C<debian> distribution, this is where you +would create the actual C<.deb> file using C<dpkg>. + +The C<CPANPLUS::Dist::Base> implementation simply calls the underlying +distribution class (Typically C<CPANPLUS::Dist::MM> or +C<CPANPLUS::Dist::Build>). + +Sets C<< $dist->status->dist >> to the location of the created +distribution. +If you override this method, you should make sure to set this value. + +Sets C<< $dist->status->created >> to the return value of this function. +If you override this method, you should make sure to set this value. + +=cut + +sub create { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + my $dist_cpan = $self->status->dist_cpan; + $dist = $self->status->dist if $self->status->dist; + $self->status->dist( $dist ) unless $self->status->dist; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my $format = ref $dist; + + ### make sure to set this variable, if the caller hasn't yet + ### just so we have some clue where the dist left off. + $dist->status->dist( $dist_cpan->status->distdir ) + unless defined $dist->status->dist; + + $dist->status->created( $dist_cpan->create(prereq_format => $format, @_) ); +} + +=head2 $bool = $dist->install + +This runs the install step of your distribution. This step is meant +to follow up on the C<create> call, which prepared a distribution(file) +to install. +A C<create> call in the standard C<ExtUtils::MakeMaker> distribution +would, for example, run C<make install> to copy the distribution files +to their final destination. For a C<debian> distribution, this is where +you would run C<dpkg --install> on the created C<.deb> file. + +The C<CPANPLUS::Dist::Base> implementation simply calls the underlying +distribution class (Typically C<CPANPLUS::Dist::MM> or +C<CPANPLUS::Dist::Build>). + +Sets C<< $dist->status->installed >> to the return value of this function. +If you override this method, you should make sure to set this value. + +=cut + +sub install { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + my $dist_cpan = $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + + $dist->status->installed( $dist_cpan->install( @_ ) ); +} + +=head2 $bool = $dist->uninstall + +This runs the uninstall step of your distribution. This step is meant +to remove the distribution from the file system. +A C<uninstall> call in the standard C<ExtUtils::MakeMaker> distribution +would, for example, run C<make uninstall> to remove the distribution +files the file system. For a C<debian> distribution, this is where you +would run C<dpkg --uninstall PACKAGE>. + +The C<CPANPLUS::Dist::Base> implementation simply calls the underlying +distribution class (Typically C<CPANPLUS::Dist::MM> or +C<CPANPLUS::Dist::Build>). + +Sets C<< $dist->status->uninstalled >> to the return value of this function. +If you override this method, you should make sure to set this value. + +=cut + +sub uninstall { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + my $dist_cpan = $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + + $dist->status->uninstalled( $dist_cpan->uninstall( @_ ) ); +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Build.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Build.pm new file mode 100755 index 00000000000..0f27639cda5 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Build.pm @@ -0,0 +1,836 @@ +package CPANPLUS::Dist::Build; + +use strict; +use warnings; +use vars qw[@ISA $STATUS $VERSION]; +@ISA = qw[CPANPLUS::Dist]; + +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 { + require CPANPLUS::Dist::Build::Constants; + CPANPLUS::Dist::Build::Constants->import() + if not __PACKAGE__->can('BUILD') && __PACKAGE__->can('BUILD_DIR'); +} + +use CPANPLUS::Error; + +use Config; +use FileHandle; +use Cwd; +use version; + +use IPC::Cmd qw[run]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; + +$VERSION = '0.46'; + +=pod + +=head1 NAME + +CPANPLUS::Dist::Build - CPANPLUS plugin to install packages that use Build.PL + +=head1 SYNOPSIS + + my $build = CPANPLUS::Dist->new( + format => 'CPANPLUS::Dist::Build', + module => $modobj, + ); + + $build->prepare; # runs Build.PL + $build->create; # runs build && build test + $build->install; # runs build install + + +=head1 DESCRIPTION + +C<CPANPLUS::Dist::Build> is a distribution class for C<Module::Build> +related modules. +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 +just C<Do The Right Thing> when it's loaded. + +=head1 ACCESSORS + +=over 4 + +=item C<parent()> + +Returns the C<CPANPLUS::Module> object that parented this object. + +=item C<status()> + +Returns the C<Object::Accessor> object that keeps the status for +this module. + +=back + +=head1 STATUS ACCESSORS + +All accessors can be accessed as follows: + $build->status->ACCESSOR + +=over 4 + +=item C<build_pl ()> + +Location of the Build file. +Set to 0 explicitly if something went wrong. + +=item C<build ()> + +BOOL indicating if the C<Build> command was successful. + +=item C<test ()> + +BOOL indicating if the C<Build test> command was successful. + +=item C<prepared ()> + +BOOL indicating if the C<prepare> call exited succesfully +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>. + +=item C<created ()> + +BOOL indicating if the C<create> call exited succesfully. This gets +set after C<Build> and C<Build test>. + +=item C<installed ()> + +BOOL indicating if the module was installed. This gets set after +C<Build install> exits successfully. + +=item uninstalled () + +BOOL indicating if the module was uninstalled properly. + +=item C<_create_args ()> + +Storage of the arguments passed to C<create> for this object. Used +for recursive calls when satisfying prerequisites. + +=item C<_install_args ()> + +Storage of the arguments passed to C<install> for this object. Used +for recursive calls when satisfying prerequisites. + +=back + +=cut + +=head1 METHODS + +=head2 $bool = CPANPLUS::Dist::Build->format_available(); + +Returns a boolean indicating whether or not you can use this package +to create and install modules in your environment. + +=cut + +### check if the format is available ### +sub format_available { + my $mod = "Module::Build"; + unless( can_load( modules => { $mod => '0.2611' } ) ) { + error( loc( "You do not have '%1' -- '%2' not available", + $mod, __PACKAGE__ ) ); + return; + } + + return 1; +} + + +=head2 $bool = $dist->init(); + +Sets up the C<CPANPLUS::Dist::Build> object for use. +Effectively creates all the needed status accessors. + +Called automatically whenever you create a new C<CPANPLUS::Dist> object. + +=cut + +sub init { + my $dist = shift; + my $status = $dist->status; + + $status->mk_accessors(qw[build_pl build test created installed uninstalled + _create_args _install_args _prepare_args + _mb_object _buildflags + ]); + + ### just in case 'format_available' didn't get called + require Module::Build; + + return 1; +} + +=pod + +=head2 $bool = $dist->prepare([perl => '/path/to/perl', buildflags => 'EXTRA=FLAGS', force => BOOL, verbose => BOOL]) + +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 +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. + +After a succcesfull C<prepare> you may call C<create> to create the +distribution, followed by C<install> to actually install it. + +Returns true on success and false on failure. + +=cut + +sub prepare { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + + ### we're also the cpan_dist, since we don't need to have anything + ### prepared from another installer + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc( "No dir found to operate on!" ) ); + return; + } + + my $args; + my( $force, $verbose, $buildflags, $perl, $prereq_target, $prereq_format, + $prereq_build ); + { local $Params::Check::ALLOW_UNKNOWN = 1; + my $tmpl = { + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + perl => { default => $^X, store => \$perl }, + buildflags => { default => $conf->get_conf('buildflags'), + store => \$buildflags }, + prereq_target => { default => '', store => \$prereq_target }, + prereq_format => { default => '', + store => \$prereq_format }, + prereq_build => { default => 0, store => \$prereq_build }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + return 1 if $dist->status->prepared && !$force; + + $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; + } + + ### by now we've loaded module::build, and we're using the API, so + ### it's safe to remove CPANPLUS::inc from our inc path, especially + ### because it can trip up tests run under taint (just like EU::MM). + ### turn off our PERL5OPT so no modules from CPANPLUS::inc get + ### included in make test -- it should build without. + ### also, modules that run in taint mode break if we leave + ### our code ref in perl5opt + ### XXX 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{PERL5LIB} = CPANPLUS::inc->original_perl5lib; + #local @INC = CPANPLUS::inc->original_inc; + + ### this will generate warnings under anything lower than M::B 0.2606 + my @buildflags = $dist->_buildflags_as_list( $buildflags ); + $dist->status->_buildflags( $buildflags ); + + my $fail; + RUN: { + # 0.85_01 + ### we resolve 'configure requires' here, so we can run the 'perl + ### Makefile.PL' command + ### XXX for tests: mock f_c_r to something that *can* resolve and + ### something that *doesnt* resolve. Check the error log for ok + ### on this step or failure + ### XXX make a seperate tarball to test for this scenario: simply + ### 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 $ok = $dist->_resolve_prereqs( + format => $prereq_format, + verbose => $verbose, + prereqs => $configure_requires, + target => $prereq_target, + force => $force, + prereq_build => $prereq_build, + ); + + unless( $ok ) { + + #### use $dist->flush to reset the cache ### + error( loc( "Unable to satisfy '%1' for '%2' " . + "-- aborting install", + 'configure_requires', $self->module ) ); + $dist->status->prepared(0); + $fail++; + last RUN; + } + ### end of prereq resolving ### + } + + # Wrap the exception that may be thrown here (should likely be + # done at a much higher level). + my $prep_output; + + 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]; + + unless ( scalar run( command => $cmd, + buffer => \$prep_output, + verbose => $verbose ) + ) { + error( loc( "Build.PL failed: %1", $prep_output ) ); + $fail++; last RUN; + } + + msg( $prep_output, 0 ); + + my $prereqs = $self->status->prereqs; + + $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( + module => $self, + failed => $fail, + buffer => CPANPLUS::Error->stack_as_string, + verbose => $verbose, + force => $force, + ) or error(loc("Failed to send test report for '%1'", + $self->module ) ); + } + + 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 ); +} + +sub _find_prereqs { + my $dist = shift; + my $self = $dist->parent; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my ($verbose, $dir, $buildflags, $perl); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + dir => { default => $self->status->extract, store => \$dir }, + perl => { default => $^X, store => \$perl }, + buildflags => { default => $conf->get_conf('buildflags'), + store => \$buildflags }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $prereqs = {}; + + $prereqs = $dist->find_mymeta_requires() + if $dist->can('find_mymeta_requires'); + + if ( keys %$prereqs ) { + # Ugly hack + } + else { + my $safe_ver = version->new('0.31_03'); + my $content; + PREREQS: { + if ( version->new( $Module::Build::VERSION ) >= $safe_ver and IPC::Cmd->can_capture_buffer ) { + my @buildflags = $dist->_buildflags_as_list( $buildflags ); + + # Use the new Build action 'prereq_data' + my $run_perl = $conf->get_program('perlwrapper'); + + unless ( scalar run( command => [$perl, $run_perl, BUILD->($dir), 'prereq_data', @buildflags], + buffer => \$content, + verbose => 0 ) + ) { + error( loc( "Build 'prereq_data' failed: %1 %2", $!, $content ) ); + #return; + } + else { + last PREREQS; + } + + } + + my $file = File::Spec->catfile( $dir, '_build', 'prereqs' ); + return unless -f $file; + + my $fh = FileHandle->new(); + + unless( $fh->open( $file ) ) { + error( loc( "Cannot open '%1': %2", $file, $! ) ); + return; + } + + $content = do { local $/; <$fh> }; + + } + + return unless $content; + my $bphash = eval $content; + return unless $bphash and ref $bphash eq 'HASH'; + foreach my $type ('requires', 'build_requires') { + next unless $bphash->{$type} and ref $bphash->{$type} eq 'HASH'; + $prereqs->{$_} = $bphash->{$type}->{$_} for keys %{ $bphash->{$type} }; + } + } + # Temporary fix + delete $prereqs->{'perl'}; + + ### allows for a user defined callback to filter the prerequisite + ### list as they see fit, to remove (or add) any prereqs they see + ### fit. The default installed callback will return the hashref in + ### an unmodified form + ### this callback got added after cpanplus 0.0562, so use a 'can' + ### to find out if it's supported. For older versions, we'll just + ### return the hashref as is ourselves. + my $href = $cb->_callbacks->can('filter_prereqs') + ? $cb->_callbacks->filter_prereqs->( $cb, $prereqs ) + : $prereqs; + + $self->status->prereqs( $href ); + + ### make sure it's not the same ref + return { %$href }; +} + +=pod + +=head2 $dist->create([perl => '/path/to/perl', buildflags => 'EXTRA=FLAGS', prereq_target => TARGET, force => BOOL, verbose => BOOL, skiptest => BOOL]) + +C<create> preps a distribution for installation. This means it will +run C<Build> and C<Build test>. +This will also satisfy any prerequisites the module may have. + +If you set C<skiptest> to true, it will skip the C<Build test> stage. +If you set C<force> to true, it will go over all the stages of the +C<Build> process again, ignoring any previously cached results. It +will also ignore a bad return value from C<Build test> and still allow +the operation to return true. + +Returns true on success and false on failure. + +You may then call C<< $dist->install >> on the object to actually +install it. + +=cut + +sub create { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + + ### we're also the cpan_dist, since we don't need to have anything + ### prepared from another installer + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc( "No dir found to operate on!" ) ); + return; + } + + my $args; + my( $force, $verbose, $buildflags, $skiptest, $prereq_target, + $perl, $prereq_format, $prereq_build); + { local $Params::Check::ALLOW_UNKNOWN = 1; + my $tmpl = { + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + perl => { default => $^X, store => \$perl }, + buildflags => { default => $conf->get_conf('buildflags'), + store => \$buildflags }, + skiptest => { default => $conf->get_conf('skiptest'), + store => \$skiptest }, + prereq_target => { default => '', store => \$prereq_target }, + ### don't set the default format to 'build' -- that is wrong! + prereq_format => { #default => $self->status->installer_type, + default => '', + store => \$prereq_format }, + prereq_build => { default => 0, store => \$prereq_build }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + # restore the state as we have created this already. + if ( $dist->status->created && !$force ) { + ### add this directory to your lib ### + $self->add_to_includepath(); + return 1; + } + + $dist->status->_create_args( $args ); + + ### is this dist prepared? + 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; + } + + ### by now we've loaded module::build, and we're using the API, so + ### it's safe to remove CPANPLUS::inc from our inc path, especially + ### because it can trip up tests run under taint (just like EU::MM). + ### turn off our PERL5OPT so no modules from CPANPLUS::inc get + ### included in make test -- it should build without. + ### also, modules that run in taint mode break if we leave + ### our code ref in perl5opt + ### XXX 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{PERL5LIB} = CPANPLUS::inc->original_perl5lib; + #local @INC = CPANPLUS::inc->original_inc; + + ### but do it *before* the new_from_context, as M::B seems + ### to be actually running the file... + ### an unshift in the block seems to be ignored.. somehow... + #{ my $lib = $self->best_path_to_module_build; + # unshift @INC, $lib if $lib; + #} + unshift @INC, $self->best_path_to_module_build + if $self->best_path_to_module_build; + + ### this will generate warnings under anything lower than M::B 0.2606 + my @buildflags = $dist->_buildflags_as_list( $buildflags ); + $dist->status->_buildflags( $buildflags ); + + my $fail; my $prereq_fail; my $test_fail; + RUN: { + + my $run_perl = $conf->get_program('perlwrapper'); + + ### this will set the directory back to the start + ### dir, so we must chdir /again/ + my $ok = $dist->_resolve_prereqs( + force => $force, + format => $prereq_format, + verbose => $verbose, + prereqs => $self->status->prereqs, + target => $prereq_target, + prereq_build => $prereq_build, + ); + + unless( $cb->_chdir( dir => $dir ) ) { + error( loc( "Could not chdir to build directory '%1'", $dir ) ); + return; + } + + unless( $ok ) { + #### use $dist->flush to reset the cache ### + error( loc( "Unable to satisfy prerequisites for '%1' " . + "-- aborting install", $self->module ) ); + $dist->status->build(0); + $fail++; $prereq_fail++; + last RUN; + } + + my ($captured, $cmd); + if ( ON_VMS ) { + $cmd = [$perl, BUILD->($dir), @buildflags]; + } + else { + $cmd = [$perl, $run_perl, BUILD->($dir), @buildflags]; + } + + unless ( scalar run( command => $cmd, + buffer => \$captured, + verbose => $verbose ) + ) { + error( loc( "MAKE failed:\n%1", $captured ) ); + $dist->status->build(0); + $fail++; last RUN; + } + + msg( $captured, 0 ); + + $dist->status->build(1); + + ### 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 + ### against 0.2607 on 26/1/2005 + unless( $skiptest ) { + my $test_output; + if ( ON_VMS ) { + $cmd = [$perl, BUILD->($dir), "test", @buildflags]; + } + else { + $cmd = [$perl, $run_perl, BUILD->($dir), "test", @buildflags]; + } + unless ( scalar run( command => $cmd, + buffer => \$test_output, + verbose => $verbose ) + ) { + error( loc( "MAKE TEST failed:\n%1 ", $test_output ) ); + + ### mark specifically *test* failure.. so we dont + ### send success on force... + $test_fail++; + + if( !$force and !$cb->_callbacks->proceed_on_test_failure->( + $self, $@ ) + ) { + $dist->status->test(0); + $fail++; last RUN; + } + + } + else { + msg( loc( "MAKE TEST passed:\n%1", $test_output ), 0 ); + #msg( $test_output, 0 ); + $dist->status->test(1); + } + } + else { + msg(loc("Tests skipped"), $verbose); + } + } + + unless( $cb->_chdir( dir => $orig ) ) { + error( loc( "Could not chdir back to start dir '%1'", $orig ) ); + } + + ### send out test report? ### + if( $conf->get_conf('cpantest') and not $prereq_fail ) { + $cb->_send_report( + module => $self, + failed => $test_fail || $fail, + buffer => CPANPLUS::Error->stack_as_string, + verbose => $verbose, + force => $force, + tests_skipped => $skiptest, + ) or error(loc("Failed to send test report for '%1'", + $self->module ) ); + } + + return $dist->status->created( $fail ? 0 : 1 ); +} + +=head2 $dist->install([verbose => BOOL, perl => /path/to/perl]) + +Actually installs the created dist. + +Returns true on success and false on failure. + +=cut + +sub install { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + + ### we're also the cpan_dist, since we don't need to have anything + ### prepared from another installer + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + + my $verbose; my $perl; my $force; my $buildflags; + { local $Params::Check::ALLOW_UNKNOWN = 1; + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + force => { default => $conf->get_conf('force'), + store => \$force }, + buildflags => { default => $conf->get_conf('buildflags'), + store => \$buildflags }, + perl => { default => $^X, store => \$perl }, + }; + + my $args = check( $tmpl, \%hash ) or return; + $dist->status->_install_args( $args ); + } + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc( "No dir found to operate on!" ) ); + return; + } + + my $orig = cwd(); + + unless( $cb->_chdir( dir => $dir ) ) { + error( loc( "Could not chdir to build directory '%1'", $dir ) ); + return; + } + + ### value set and false -- means failure ### + if( defined $self->status->installed && + !$self->status->installed && !$force + ) { + error( loc( "Module '%1' has failed to install before this session " . + "-- aborting install", $self->module ) ); + return; + } + + my $fail; + my @buildflags = $dist->_buildflags_as_list( $buildflags ); + my $run_perl = $conf->get_program('perlwrapper'); + + ### hmm, how is this going to deal with sudo? + ### for now, check effective uid, if it's not root, + ### shell out, otherwise use the method + if( $> ) { + + ### don't worry about loading the right version of M::B anymore + ### the 'new_from_context' already added the 'right' path to + ### M::B at the top of the build.pl + my $cmd; + if ( ON_VMS ) { + $cmd = [$perl, BUILD->($dir), "install", @buildflags]; + } + else { + $cmd = [$perl, $run_perl, BUILD->($dir), "install", @buildflags]; + } + my $sudo = $conf->get_program('sudo'); + unshift @$cmd, $sudo if $sudo; + + + my $buffer; + unless( scalar run( command => $cmd, + buffer => \$buffer, + verbose => $verbose ) + ) { + error(loc("Could not run '%1': %2", 'Build install', $buffer)); + $fail++; + } + } else { + my ($install_output, $cmd); + if ( ON_VMS ) { + $cmd = [$perl, BUILD->($dir), "install", @buildflags]; + } + else { + $cmd = [$perl, $run_perl, BUILD->($dir), "install", @buildflags]; + } + unless( scalar run( command => $cmd, + buffer => \$install_output, + verbose => $verbose ) + ) { + error(loc("Could not run '%1': %2", 'Build install', $install_output)); + $fail++; + } + else { + msg( $install_output, 0 ); + } + } + + + unless( $cb->_chdir( dir => $orig ) ) { + error( loc( "Could not chdir back to start dir '%1'", $orig ) ); + } + + return $dist->status->installed( $fail ? 0 : 1 ); +} + +### returns the string 'foo=bar --zot quux' +### as the list 'foo=bar', '--zot', 'qux' +sub _buildflags_as_list { + my $self = shift; + my $flags = shift or return; + + return Module::Build->split_like_shell($flags); +} + +=head1 AUTHOR + +Originally by Jos Boumans E<lt>kane@cpan.orgE<gt>. Brought to working +condition by Ken Williams E<lt>kwilliams@cpan.orgE<gt>. + +Other hackery and currently maintained by Chris C<BinGOs> Williams ( no relation ). E<lt>bingos@cpan.orgE<gt>. + +=head1 LICENSE + +The CPAN++ interface (of which this module is a part of) is +copyright (c) 2001, 2002, 2003, 2004, 2005 Jos Boumans E<lt>kane@cpan.orgE<gt>. +All rights reserved. + +This library is free software; +you may redistribute and/or modify it under the same +terms as Perl itself. + +=cut + +qq[Putting the Module::Build into CPANPLUS]; + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Build/Constants.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Build/Constants.pm new file mode 100755 index 00000000000..1ac02108e44 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Build/Constants.pm @@ -0,0 +1,69 @@ +package CPANPLUS::Dist::Build::Constants; + +use strict; +use warnings; +use File::Spec; + +BEGIN { + + require Exporter; + use vars qw[$VERSION @ISA @EXPORT]; + + $VERSION = '0.46'; + @ISA = qw[Exporter]; + @EXPORT = qw[ BUILD_DIR BUILD ]; +} + + +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'; + + return $file; + }; + +1; + +=head1 NAME + +CPANPLUS::Dist::Build::Constants - Constants for CPANPLUS::Dist::Build + +=head1 SYNOPSIS + + use CPANPLUS::Dist::Build::Constants; + +=head1 DESCRIPTION + +CPANPLUS::Dist::Build::Constants provides some constants required by L<CPANPLUS::Dist::Build>. + +=head1 AUTHOR + +Originally by Jos Boumans E<lt>kane@cpan.orgE<gt>. Brought to working +condition and currently maintained by Ken Williams E<lt>kwilliams@cpan.orgE<gt>. + +=head1 LICENSE + +The CPAN++ interface (of which this module is a part of) is +copyright (c) 2001, 2002, 2003, 2004, 2005 Jos Boumans E<lt>kane@cpan.orgE<gt>. +All rights reserved. + +This library is free software; +you may redistribute and/or modify it under the same +terms as Perl itself. + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/MM.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/MM.pm new file mode 100755 index 00000000000..be65cd43cc8 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/MM.pm @@ -0,0 +1,1007 @@ +package CPANPLUS::Dist::MM; + +use warnings; +use strict; +use vars qw[@ISA $STATUS]; +use base 'CPANPLUS::Dist::Base'; + +use CPANPLUS::Internals::Constants; +use CPANPLUS::Internals::Constants::Report; +use CPANPLUS::Error; +use FileHandle; +use Cwd; + +use IPC::Cmd qw[run]; +use Params::Check qw[check]; +use File::Basename qw[dirname]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Dist::MM + +=head1 SYNOPSIS + + $mm = CPANPLUS::Dist::MM->new( module => $modobj ); + + $mm->create; # runs make && make test + $mm->install; # runs make install + + +=head1 DESCRIPTION + +C<CPANPLUS::Dist::MM> is a distribution class for MakeMaker related +modules. +Using this package, you can create, install and uninstall perl +modules. It inherits from C<CPANPLUS::Dist>. + +=head1 ACCESSORS + +=over 4 + +=item parent() + +Returns the C<CPANPLUS::Module> object that parented this object. + +=item status() + +Returns the C<Object::Accessor> object that keeps the status for +this module. + +=back + +=head1 STATUS ACCESSORS + +All accessors can be accessed as follows: + $mm->status->ACCESSOR + +=over 4 + +=item makefile () + +Location of the Makefile (or Build file). +Set to 0 explicitly if something went wrong. + +=item make () + +BOOL indicating if the C<make> (or C<Build>) command was successful. + +=item test () + +BOOL indicating if the C<make test> (or C<Build test>) command was +successful. + +=item prepared () + +BOOL indicating if the C<prepare> call exited succesfully +This gets set after C<perl Makefile.PL> + +=item distdir () + +Full path to the directory in which the C<prepare> call took place, +set after a call to C<prepare>. + +=item created () + +BOOL indicating if the C<create> call exited succesfully. This gets +set after C<make> and C<make test>. + +=item installed () + +BOOL indicating if the module was installed. This gets set after +C<make install> (or C<Build install>) exits successfully. + +=item uninstalled () + +BOOL indicating if the module was uninstalled properly. + +=item _create_args () + +Storage of the arguments passed to C<create> for this object. Used +for recursive calls when satisfying prerequisites. + +=item _install_args () + +Storage of the arguments passed to C<install> for this object. Used +for recursive calls when satisfying prerequisites. + +=back + +=cut + +=head1 METHODS + +=head2 $bool = $dist->format_available(); + +Returns a boolean indicating whether or not you can use this package +to create and install modules in your environment. + +=cut + +### check if the format is available ### +sub format_available { + my $dist = shift; + + ### we might be called as $class->format_available =/ + require CPANPLUS::Internals; + my $cb = CPANPLUS::Internals->_retrieve_id( + CPANPLUS::Internals->_last_id ); + my $conf = $cb->configure_object; + + my $mod = "ExtUtils::MakeMaker"; + unless( can_load( modules => { $mod => 0.0 } ) ) { + error( loc( "You do not have '%1' -- '%2' not available", + $mod, __PACKAGE__ ) ); + return; + } + + for my $pgm ( qw[make] ) { + unless( $conf->get_program( $pgm ) ) { + error(loc( + "You do not have '%1' in your path -- '%2' not available\n" . + "Please check your config entry for '%1'", + $pgm, __PACKAGE__ , $pgm + )); + return; + } + } + + return 1; +} + +=pod $bool = $dist->init(); + +Sets up the C<CPANPLUS::Dist::MM> object for use. +Effectively creates all the needed status accessors. + +Called automatically whenever you create a new C<CPANPLUS::Dist> object. + +=cut + +sub init { + my $dist = shift; + my $status = $dist->status; + + $status->mk_accessors(qw[makefile make test created installed uninstalled + bin_make _prepare_args _create_args _install_args] + ); + + return 1; +} + +=pod $bool = $dist->prepare([perl => '/path/to/perl', makemakerflags => 'EXTRA=FLAGS', force => BOOL, verbose => BOOL]) + +C<prepare> preps a distribution for installation. This means it will +run C<perl Makefile.PL> and determine what prerequisites this distribution +declared. + +If you set C<force> to true, it will go over all the stages of the +C<prepare> process again, ignoring any previously cached results. + +When running C<perl Makefile.PL>, the environment variable +C<PERL5_CPANPLUS_IS_EXECUTING> will be set to the full path of the +C<Makefile.PL> that is being executed. This enables any code inside +the C<Makefile.PL> to know that it is being installed via CPANPLUS. + +Returns true on success and false on failure. + +You may then call C<< $dist->create >> on the object to create the +installable files. + +=cut + +sub prepare { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + + ### we're also the cpan_dist, since we don't need to have anything + ### prepared + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc( "No dir found to operate on!" ) ); + return; + } + + my $args; + my( $force, $verbose, $perl, @mmflags, $prereq_target, $prereq_format, + $prereq_build ); + { local $Params::Check::ALLOW_UNKNOWN = 1; + my $tmpl = { + perl => { default => $^X, store => \$perl }, + makemakerflags => { default => + $conf->get_conf('makemakerflags') || '', + store => \$mmflags[0] }, + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + prereq_target => { default => '', store => \$prereq_target }, + prereq_format => { default => '', + store => \$prereq_format }, + prereq_build => { default => 0, store => \$prereq_build }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + + ### maybe we already ran a create on this object? ### + return 1 if $dist->status->prepared && !$force; + + ### store the arguments, so ->install can use them in recursive loops ### + $dist->status->_prepare_args( $args ); + + ### chdir to work directory ### + my $orig = cwd(); + unless( $cb->_chdir( dir => $dir ) ) { + error( loc( "Could not chdir to build directory '%1'", $dir ) ); + return; + } + + my $fail; + RUN: { + + ### we resolve 'configure requires' here, so we can run the 'perl + ### Makefile.PL' command + ### XXX for tests: mock f_c_r to something that *can* resolve and + ### something that *doesnt* resolve. Check the error log for ok + ### on this step or failure + ### XXX make a seperate tarball to test for this scenario: simply + ### containing a makefile.pl/build.pl for test purposes? + { my $configure_requires = $dist->find_configure_requires; + my $ok = $dist->_resolve_prereqs( + format => $prereq_format, + verbose => $verbose, + prereqs => $configure_requires, + target => $prereq_target, + force => $force, + prereq_build => $prereq_build, + ); + + unless( $ok ) { + + #### use $dist->flush to reset the cache ### + error( loc( "Unable to satisfy '%1' for '%2' " . + "-- aborting install", + 'configure_requires', $self->module ) ); + $dist->status->prepared(0); + $fail++; + last RUN; + } + ### end of prereq resolving ### + } + + + + ### don't run 'perl makefile.pl' again if there's a makefile already + if( -e MAKEFILE->() && (-M MAKEFILE->() < -M $dir) && !$force ) { + msg(loc("'%1' already exists, not running '%2 %3' again ". + " unless you force", + MAKEFILE->(), $perl, MAKEFILE_PL->() ), $verbose ); + + } else { + unless( -e MAKEFILE_PL->() ) { + msg(loc("No '%1' found - attempting to generate one", + MAKEFILE_PL->() ), $verbose ); + + $dist->write_makefile_pl( + verbose => $verbose, + force => $force + ); + + ### bail out if there's no makefile.pl ### + unless( -e MAKEFILE_PL->() ) { + error( loc( "Could not find '%1' - cannot continue", + MAKEFILE_PL->() ) ); + + ### mark that we screwed up ### + $dist->status->makefile(0); + $fail++; last RUN; + } + } + + ### you can turn off running this verbose by changing + ### the config setting below, although it is really not + ### recommended + my $run_verbose = $verbose || + $conf->get_conf('allow_build_interactivity') || + 0; + + ### this makes MakeMaker use defaults if possible, according + ### to schwern. See ticket 8047 for details. + local $ENV{PERL_MM_USE_DEFAULT} = 1 unless $run_verbose; + + ### turn off our PERL5OPT so no modules from CPANPLUS::inc get + ### included in the makefile.pl -- it should build without + ### also, modules that run in taint mode break if we leave + ### our code ref in perl5opt + ### XXX we've removed the ENV settings from cp::inc, so only need + ### to reset the @INC + #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt || ''; + + ### make sure it's a string, so that mmflags that have more than + ### one key value pair are passed as is, rather than as: + ### perl Makefile.PL "key=val key=>val" + + + #### XXX this needs to be the absolute path to the Makefile.PL + ### since cpanp-run-perl uses 'do' to execute the file, and do() + ### checks your @INC.. so, if there's _another_ makefile.pl in + ### your @INC, it will execute that one... + my $makefile_pl = MAKEFILE_PL->( $cb->_safe_path( path => $dir ) ); + + ### setting autoflush to true fixes issue from rt #8047 + ### XXX this means that we need to keep the path to CPANPLUS + ### in @INC, stopping us from resolving dependencies on CPANPLUS + ### at bootstrap time properly. + + ### 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]; + + ### set ENV var to tell underlying code this is what we're + ### executing. + my $captured; + my $rv = do { + my $env = ENV_CPANPLUS_IS_EXECUTING; + local $ENV{$env} = $makefile_pl; + scalar run( command => $cmd, + buffer => \$captured, + verbose => $run_verbose, # may be interactive + ); + }; + + unless( $rv ) { + error( loc( "Could not run '%1 %2': %3 -- cannot continue", + $perl, MAKEFILE_PL->(), $captured ) ); + + $dist->status->makefile(0); + $fail++; last RUN; + } + + ### put the output on the stack, don't print it + msg( $captured, 0 ); + } + + ### so, nasty feature in Module::Build, that when a Makefile.PL + ### is a disguised Build.PL, it generates a Build file, not a + ### Makefile. this breaks everything :( see rt bug #19741 + if( not -e MAKEFILE->( $dir ) and -e BUILD_PL->( $dir ) ) { + error(loc( + "We just ran '%1' without errors, but no '%2' is ". + "present. However, there is a '%3' file, so this may ". + "be related to bug #19741 in %4, which describes a ". + "fake '%5' which generates a '%6' file instead of a '%7'. ". + "You could try to work around this issue by setting '%8' ". + "to false and trying again. This will attempt to use the ". + "'%9' instead.", + "$^X ".MAKEFILE_PL->(), MAKEFILE->(), BUILD_PL->(), + 'Module::Build', MAKEFILE_PL->(), 'Build', MAKEFILE->(), + 'prefer_makefile', BUILD_PL->() + )); + + $fail++, last RUN; + } + + ### if we got here, we managed to make a 'makefile' ### + $dist->status->makefile( MAKEFILE->($dir) ); + + ### start resolving prereqs ### + my $prereqs = $self->status->prereqs; + + ### a hashref of prereqs on success, undef on failure ### + $prereqs ||= $dist->_find_prereqs( + verbose => $verbose, + file => $dist->status->makefile + ); + + unless( $prereqs ) { + error( loc( "Unable to scan '%1' for prereqs", + $dist->status->makefile ) ); + + $fail++; last RUN; + } + } + + unless( $cb->_chdir( dir => $orig ) ) { + error( loc( "Could not chdir back to start dir '%1'", $orig ) ); + } + + ### save where we wrote this stuff -- same as extract dir in normal + ### installer circumstances + $dist->status->distdir( $self->status->extract ); + + return $dist->status->prepared( $fail ? 0 : 1); +} + +=pod + +=head2 $href = $dist->_find_prereqs( file => '/path/to/Makefile', [verbose => BOOL]) + +Parses a C<Makefile> for C<PREREQ_PM> entries and distills from that +any prerequisites mentioned in the C<Makefile> + +Returns a hash with module-version pairs on success and false on +failure. + +=cut + +sub _find_prereqs { + my $dist = shift; + my $self = $dist->parent; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my ($verbose, $file); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + file => { required => 1, allow => FILE_READABLE, store => \$file }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### see if we got prereqs from MYMETA + my $prereqs = $dist->find_mymeta_requires(); + + ### we found some prereqs, we'll trust MYMETA + ### but we do need to run it through the callback + return $cb->_callbacks->filter_prereqs->( $cb, $prereqs ) if keys %$prereqs; + + my $fh = FileHandle->new(); + unless( $fh->open( $file ) ) { + error( loc( "Cannot open '%1': %2", $file, $! ) ); + return; + } + + my %p; + while( local $_ = <$fh> ) { + my ($found) = m|^[\#]\s+PREREQ_PM\s+=>\s+(.+)|; + + next unless $found; + + while( $found =~ m/(?:\s)([\w\:]+)=>(?:q\[(.*?)\],?|undef)/g ) { + if( defined $p{$1} ) { + my $ver = $cb->_version_to_number(version => $2); + $p{$1} = $ver + if $cb->_vcmp( $ver, $p{$1} ) > 0; + } + else { + $p{$1} = $cb->_version_to_number(version => $2); + } + } + last; + } + + my $href = $cb->_callbacks->filter_prereqs->( $cb, \%p ); + + $self->status->prereqs( $href ); + + ### just to make sure it's not the same reference ### + return { %$href }; +} + +=pod + +=head2 $bool = $dist->create([perl => '/path/to/perl', make => '/path/to/make', makeflags => 'EXTRA=FLAGS', prereq_target => TARGET, skiptest => BOOL, force => BOOL, verbose => BOOL]) + +C<create> creates the files necessary for installation. This means +it will run C<make> and C<make test>. This will also scan for and +attempt to satisfy any prerequisites the module may have. + +If you set C<skiptest> to true, it will skip the C<make test> stage. +If you set C<force> to true, it will go over all the stages of the +C<make> process again, ignoring any previously cached results. It +will also ignore a bad return value from C<make test> and still allow +the operation to return true. + +Returns true on success and false on failure. + +You may then call C<< $dist->install >> on the object to actually +install it. + +=cut + +sub create { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + + ### we're also the cpan_dist, since we don't need to have anything + ### prepared + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc( "No dir found to operate on!" ) ); + return; + } + + my $args; + my( $force, $verbose, $make, $makeflags, $skiptest, $prereq_target, $perl, + @mmflags, $prereq_format, $prereq_build); + { local $Params::Check::ALLOW_UNKNOWN = 1; + my $tmpl = { + perl => { default => $^X, store => \$perl }, + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + make => { default => $conf->get_program('make'), + store => \$make }, + makeflags => { default => $conf->get_conf('makeflags'), + store => \$makeflags }, + skiptest => { default => $conf->get_conf('skiptest'), + store => \$skiptest }, + prereq_target => { default => '', store => \$prereq_target }, + ### don't set the default prereq format to 'makemaker' -- wrong! + prereq_format => { #default => $self->status->installer_type, + default => '', + store => \$prereq_format }, + prereq_build => { default => 0, store => \$prereq_build }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + ### maybe we already ran a create on this object? + ### make sure we add to include path again, just in case we came from + ### ->save_state, at which point we need to restore @INC/$PERL5LIB + if( $dist->status->created && !$force ) { + $self->add_to_includepath; + return 1; + } + + ### store the arguments, so ->install can use them in recursive loops ### + $dist->status->_create_args( $args ); + + unless( $dist->status->prepared ) { + error( loc( "You have not successfully prepared a '%2' distribution ". + "yet -- cannot create yet", __PACKAGE__ ) ); + return; + } + + + ### chdir to work directory ### + my $orig = cwd(); + unless( $cb->_chdir( dir => $dir ) ) { + error( loc( "Could not chdir to build directory '%1'", $dir ) ); + return; + } + + my $fail; my $prereq_fail; my $test_fail; + RUN: { + ### this will set the directory back to the start + ### dir, so we must chdir /again/ + my $ok = $dist->_resolve_prereqs( + format => $prereq_format, + verbose => $verbose, + prereqs => $self->status->prereqs, + target => $prereq_target, + force => $force, + prereq_build => $prereq_build, + ); + + unless( $cb->_chdir( dir => $dir ) ) { + error( loc( "Could not chdir to build directory '%1'", $dir ) ); + return; + } + + unless( $ok ) { + + #### use $dist->flush to reset the cache ### + error( loc( "Unable to satisfy prerequisites for '%1' " . + "-- aborting install", $self->module ) ); + $dist->status->make(0); + $fail++; $prereq_fail++; + last RUN; + } + ### end of prereq resolving ### + + my $captured; + + ### 'make' section ### + if( -d BLIB->($dir) && (-M BLIB->($dir) < -M $dir) && !$force ) { + msg(loc("Already ran '%1' for this module [%2] -- " . + "not running again unless you force", + $make, $self->module ), $verbose ); + } else { + unless(scalar run( command => [$make, $makeflags], + buffer => \$captured, + verbose => $verbose ) + ) { + error( loc( "MAKE failed: %1 %2", $!, $captured ) ); + $dist->status->make(0); + $fail++; last RUN; + } + + ### put the output on the stack, don't print it + msg( $captured, 0 ); + + $dist->status->make(1); + + ### add this directory to your lib ### + $self->add_to_includepath(); + + ### dont bail out here, there's a conditional later on + #last RUN if $skiptest; + } + + ### 'make test' section ### + unless( $skiptest ) { + + ### turn off our PERL5OPT so no modules from CPANPLUS::inc get + ### included in make test -- it should build without + ### also, modules that run in taint mode break if we leave + ### our code ref in perl5opt + ### XXX CPANPLUS::inc functionality is now obsolete. + #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt || ''; + + ### you can turn off running this verbose by changing + ### the config setting below, although it is really not + ### recommended + my $run_verbose = + $verbose || + $conf->get_conf('allow_build_interactivity') || + 0; + + ### XXX need to add makeflags here too? + ### yes, but they should really be split out -- see bug #4143 + if( scalar run( + command => [$make, 'test', $makeflags], + buffer => \$captured, + verbose => $run_verbose, + ) ) { + ### tests might pass because it doesn't have any tests defined + ### log this occasion non-verbosely, so our test reporter can + ### pick up on this + if ( NO_TESTS_DEFINED->( $captured ) ) { + msg( NO_TESTS_DEFINED->( $captured ), 0 ) + } else { + msg( loc( "MAKE TEST passed: %1", $captured ), 0 ); + } + + $dist->status->test(1); + } else { + error( loc( "MAKE TEST failed: %1 %2", $!, $captured ) ); + + ### send out error report here? or do so at a higher level? + ### --higher level --kane. + $dist->status->test(0); + + ### mark specifically *test* failure.. so we dont + ### send success on force... + $test_fail++; + + if( !$force and !$cb->_callbacks->proceed_on_test_failure->( + $self, $captured ) + ) { + $fail++; last RUN; + } + } + } + } #</RUN> + + unless( $cb->_chdir( dir => $orig ) ) { + error( loc( "Could not chdir back to start dir '%1'", $orig ) ); + } + + ### send out test report? + ### only do so if the failure is this module, not its prereq + if( $conf->get_conf('cpantest') and not $prereq_fail) { + $cb->_send_report( + module => $self, + failed => $test_fail || $fail, + buffer => CPANPLUS::Error->stack_as_string, + verbose => $verbose, + force => $force, + ) or error(loc("Failed to send test report for '%1'", + $self->module ) ); + } + + return $dist->status->created( $fail ? 0 : 1); +} + +=pod + +=head2 $bool = $dist->install([make => '/path/to/make', makemakerflags => 'EXTRA=FLAGS', force => BOOL, verbose => BOOL]) + +C<install> runs the following command: + make install + +Returns true on success, false on failure. + +=cut + +sub install { + + ### just in case you did the create with ANOTHER dist object linked + ### to the same module object + my $dist = shift(); + my $self = $dist->parent; + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + + unless( $dist->status->created ) { + error(loc("You have not successfully created a '%2' distribution yet " . + "-- cannot install yet", __PACKAGE__ )); + return; + } + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc( "No dir found to operate on!" ) ); + return; + } + + my $args; + my($force,$verbose,$make,$makeflags); + { local $Params::Check::ALLOW_UNKNOWN = 1; + my $tmpl = { + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + make => { default => $conf->get_program('make'), + store => \$make }, + makeflags => { default => $conf->get_conf('makeflags'), + store => \$makeflags }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + ### value set and false -- means failure ### + if( defined $self->status->installed && + !$self->status->installed && !$force + ) { + error( loc( "Module '%1' has failed to install before this session " . + "-- aborting install", $self->module ) ); + return; + } + + + $dist->status->_install_args( $args ); + + my $orig = cwd(); + unless( $cb->_chdir( dir => $dir ) ) { + error( loc( "Could not chdir to build directory '%1'", $dir ) ); + return; + } + + my $fail; my $captured; + + ### 'make install' section ### + ### XXX need makeflags here too? + ### yes, but they should really be split out.. see bug #4143 + my $cmd = [$make, 'install', $makeflags]; + my $sudo = $conf->get_program('sudo'); + unshift @$cmd, $sudo if $sudo and $>; + + $cb->flush('lib'); + unless(scalar run( command => $cmd, + verbose => $verbose, + buffer => \$captured, + ) ) { + error( loc( "MAKE INSTALL failed: %1 %2", $!, $captured ) ); + $fail++; + } + + ### put the output on the stack, don't print it + msg( $captured, 0 ); + + unless( $cb->_chdir( dir => $orig ) ) { + error( loc( "Could not chdir back to start dir '%1'", $orig ) ); + } + + return $dist->status->installed( $fail ? 0 : 1 ); + +} + +=pod + +=head2 $bool = $dist->write_makefile_pl([force => BOOL, verbose => BOOL]) + +This routine can write a C<Makefile.PL> from the information in a +module object. It is used to write a C<Makefile.PL> when the original +author forgot it (!!). + +Returns 1 on success and false on failure. + +The file gets written to the directory the module's been extracted +to. + +=cut + +sub write_makefile_pl { + ### just in case you already did a call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc( "No dir found to operate on!" ) ); + return; + } + + my ($force, $verbose); + my $tmpl = { + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $file = MAKEFILE_PL->($dir); + if( -s $file && !$force ) { + msg(loc("Already created '%1' - not doing so again without force", + $file ), $verbose ); + return 1; + } + + ### due to a bug with AS perl 5.8.4 built 810 (and maybe others) + ### opening files with content in them already does nasty things; + ### seek to pos 0 and then print, but not truncating the file + ### bug reported to activestate on 19 sep 2004: + ### http://bugs.activestate.com/show_bug.cgi?id=34051 + unlink $file if $force; + + my $fh = new FileHandle; + unless( $fh->open( ">$file" ) ) { + error( loc( "Could not create file '%1': %2", $file, $! ) ); + return; + } + + my $mf = MAKEFILE_PL->(); + my $name = $self->module; + my $version = $self->version; + my $author = $self->author->author; + my $href = $self->status->prereqs; + my $prereqs = join ",\n", map { + (' ' x 25) . "'$_'\t=> '$href->{$_}'" + } keys %$href; + $prereqs ||= ''; # just in case there are none; + + print $fh qq| + ### Auto-generated $mf by CPANPLUS ### + + use ExtUtils::MakeMaker; + + WriteMakefile( + NAME => '$name', + VERSION => '$version', + AUTHOR => '$author', + PREREQ_PM => { +$prereqs + }, + ); + \n|; + + $fh->close; + return 1; +} + +sub dist_dir { + ### just in case you already did a call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $make; my $verbose; + { local $Params::Check::ALLOW_UNKNOWN = 1; + my $tmpl = { + make => { default => $conf->get_program('make'), + store => \$make }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + check( $tmpl, \%hash ) or return; + } + + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc( "No dir found to operate on!" ) ); + return; + } + + ### chdir to work directory ### + my $orig = cwd(); + unless( $cb->_chdir( dir => $dir ) ) { + error( loc( "Could not chdir to build directory '%1'", $dir ) ); + return; + } + + my $fail; my $distdir; + TRY: { + $dist->prepare( @_ ) or (++$fail, last TRY); + + + my $captured; + unless(scalar run( command => [$make, 'distdir'], + buffer => \$captured, + verbose => $verbose ) + ) { + error( loc( "MAKE DISTDIR failed: %1 %2", $!, $captured ) ); + ++$fail, last TRY; + } + + ### /path/to/Foo-Bar-1.2/Foo-Bar-1.2 + $distdir = File::Spec->catdir( $dir, $self->package_name . '-' . + $self->package_version ); + + unless( -d $distdir ) { + error(loc("Do not know where '%1' got created", 'distdir')); + ++$fail, last TRY; + } + } + + unless( $cb->_chdir( dir => $orig ) ) { + error( loc( "Could not chdir to start directory '%1'", $orig ) ); + return; + } + + return if $fail; + return $distdir; +} + + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Sample.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Sample.pm new file mode 100755 index 00000000000..0b0939208ff --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Dist/Sample.pm @@ -0,0 +1,16 @@ +package CPANPLUS::Dist::Sample; + +=pod + +=head1 NAME + +CPANPLUS::Dist::Sample -- Sample code to create your own Dist::* plugin + +=head1 Description. + +This document is B<Obsolete>. Please read the documentation and code +in C<CPANPLUS::Dist::Base>. + +=cut + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Error.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Error.pm new file mode 100755 index 00000000000..38710a8a857 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Error.pm @@ -0,0 +1,201 @@ +package CPANPLUS::Error; + +use strict; + +use Log::Message private => 0;; + +=pod + +=head1 NAME + +CPANPLUS::Error + +=head1 SYNOPSIS + + use CPANPLUS::Error qw[cp_msg cp_error]; + +=head1 DESCRIPTION + +This module provides the error handling code for the CPANPLUS +libraries, and is mainly intended for internal use. + +=head1 FUNCTIONS + +=head2 cp_msg("message string" [,VERBOSE]) + +Records a message on the stack, and prints it to C<STDOUT> (or actually +C<$MSG_FH>, see the C<GLOBAL VARIABLES> section below), if the +C<VERBOSE> option is true. +The C<VERBOSE> option defaults to false. + +=head2 msg() + +An alias for C<cp_msg>. + +=head2 cp_error("error string" [,VERBOSE]) + +Records an error on the stack, and prints it to C<STDERR> (or actually +C<$ERROR_FH>, see the C<GLOBAL VARIABLES> sections below), if the +C<VERBOSE> option is true. +The C<VERBOSE> options defaults to true. + +=head2 error() + +An alias for C<cp_error>. + +=head1 CLASS METHODS + +=head2 CPANPLUS::Error->stack() + +Retrieves all the items on the stack. Since C<CPANPLUS::Error> is +implemented using C<Log::Message>, consult its manpage for the +function C<retrieve> to see what is returned and how to use the items. + +=head2 CPANPLUS::Error->stack_as_string([TRACE]) + +Returns the whole stack as a printable string. If the C<TRACE> option is +true all items are returned with C<Carp::longmess> output, rather than +just the message. +C<TRACE> defaults to false. + +=head2 CPANPLUS::Error->flush() + +Removes all the items from the stack and returns them. Since +C<CPANPLUS::Error> is implemented using C<Log::Message>, consult its +manpage for the function C<retrieve> to see what is returned and how +to use the items. + +=cut + +BEGIN { + use Exporter; + use Params::Check qw[check]; + use vars qw[@EXPORT @ISA $ERROR_FH $MSG_FH]; + + @ISA = 'Exporter'; + @EXPORT = qw[cp_error cp_msg error msg]; + + my $log = new Log::Message; + + for my $func ( @EXPORT ) { + no strict 'refs'; + + my $prefix = 'cp_'; + my $name = $func; + $name =~ s/^$prefix//g; + + *$func = sub { + my $msg = shift; + + ### no point storing non-messages + return unless defined $msg; + + $log->store( + message => $msg, + tag => uc $name, + level => $prefix . $name, + extra => [@_] + ); + }; + } + + sub flush { + return reverse $log->flush; + } + + sub stack { + return $log->retrieve( chrono => 1 ); + } + + sub stack_as_string { + my $class = shift; + my $trace = shift() ? 1 : 0; + + return join $/, map { + '[' . $_->tag . '] [' . $_->when . '] ' . + ($trace ? $_->message . ' ' . $_->longmess + : $_->message); + } __PACKAGE__->stack; + } +} + +=head1 GLOBAL VARIABLES + +=over 4 + +=item $ERROR_FH + +This is the filehandle all the messages sent to C<error()> are being +printed. This defaults to C<*STDERR>. + +=item $MSG_FH + +This is the filehandle all the messages sent to C<msg()> are being +printed. This default to C<*STDOUT>. + +=cut +local $| = 1; +$ERROR_FH = \*STDERR; +$MSG_FH = \*STDOUT; + +package Log::Message::Handlers; +use Carp (); + +{ + + sub cp_msg { + my $self = shift; + my $verbose = shift; + + ### so you don't want us to print the msg? ### + return if defined $verbose && $verbose == 0; + + my $old_fh = select $CPANPLUS::Error::MSG_FH; + + print '['. $self->tag . '] ' . $self->message . "\n"; + select $old_fh; + + return; + } + + sub cp_error { + my $self = shift; + my $verbose = shift; + + ### so you don't want us to print the error? ### + return if defined $verbose && $verbose == 0; + + my $old_fh = select $CPANPLUS::Error::ERROR_FH; + + ### is only going to be 1 for now anyway ### + ### C::I may not be loaded, so do a can() check first + my $cb = CPANPLUS::Internals->can('_return_all_objects') + ? (CPANPLUS::Internals->_return_all_objects)[0] + : undef; + + ### maybe we didn't initialize an internals object (yet) ### + my $debug = $cb ? $cb->configure_object->get_conf('debug') : 0; + my $msg = '['. $self->tag . '] ' . $self->message . "\n"; + + ### i'm getting this warning in the test suite: + ### Ambiguous call resolved as CORE::warn(), qualify as such or + ### use & at CPANPLUS/Error.pm line 57. + ### no idea where it's coming from, since there's no 'sub warn' + ### anywhere to be found, but i'll mark it explicitly nonetheless + ### --kane + print $debug ? Carp::shortmess($msg) : $msg . "\n"; + + select $old_fh; + + return; + } +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/FAQ.pod b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/FAQ.pod new file mode 100755 index 00000000000..82bb57aaf47 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/FAQ.pod @@ -0,0 +1,30 @@ +=pod + +=head1 NAME + +CPANPLUS::FAQ + +=head1 DESCRIPTION + +This document attempts to provide answers to commonly asked questions. + + XXX Work in progress + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Hacking.pod b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Hacking.pod new file mode 100755 index 00000000000..1a28b9e5b05 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Hacking.pod @@ -0,0 +1,135 @@ +=pod + +=head1 NAME + +CPANPLUS::Hacking + +=head1 DESCRIPTION + +This document attempts to describe how to develop with the +CPANPLUS environment most easily, how certain things work and why. + +This is basically a quick-start guide to people who want to add +features or patches to CPANPLUS. + +=head1 OBTAINING CPANPLUS + +Checkout CPANPLUS from its Subversion repository at +L<http://oss.dwim.org/cpanplus-devel> . + +=head1 INSTALLING CPANPLUS + +CPANPLUS follows the standard perl module installation process: + + perl Makefile.PL + make + make test + make install + +=head1 CONFIGURING CPANPLUS + +When running C<perl Makefile.PL> you will be prompted to configure. +If you have already done so, and merely wish to update the C<Makefile>, +simply run: + + perl Makefile.PL JFDI=1 + +This will keep your configuration intact. Note however, if there are +changes to the default configuration file C<Config.pm-orig>, you should +either delete your current config file and reconfigure, or patch your +config file from the new entries in C<Config.pm-orig>. + +=head1 RUNNING CPANPLUS FROM DEVELOPMENT ENVIRONMENT + +If you'd rather not install the development version to your +C<site_perl> directory, that's no problem. You can set your C<PERL5LIB> +environment variable to CPANPLUS' C<lib> directory, and you can run it +from there. + +=head1 RUNNING CPANPLUS TESTS + +Tests are what tells us if CPANPLUS is working. If a test is not working, +try to run it explicilty like this: + + perl -I/path/to/cpanplus/lib t/XX_name_of_test.t 1 + +The extra '1' makes sure that all the messages and errors (they might +be errors we're testing for!) are being printed rather than kept quiet. +This is a great way to find out the context of any failures that may +occur. + +If you believe this test failure proves a bug in CPANPLUS, the long +output of the test file is something we'd like to see alongside your +bug report. + +=head1 FINDING BUGS + +Sometimes you might find bugs in CPANPLUS' behaviour. If you encounter +these in a development snapshot, we'd appreciate a complete patch (as +described below in the L<SENDING PATCHES> section. + +If it's way over your head, then of course reporting the bug is always +better than not reporting it at all. Before you do so though, make +sure you have the B<latest> development snapshot, and the bug still +persists there. If so, report the bug to this address: + + cpanplus-devel@lists.sourceforge.net + +A good C<patch> would have the following characteristics: + +=over 4 + +=item Problem description + +Describe clearly what the bug is you found, and what it should have +done instead. + +=item Program demonstrating the bug + +Show us how to reproduce the bug, in a simple of a program as possible + +=item [OPTIONAL] A patch to the test suite to test for the bug + +Amend our test suite by making sure this bug will be found in this, and +future versions of CPANPLUS (see L<SUPPLYING PATCHES>) + +=item [OPTIONAL] A patch to the code + tests + documentation + +Fix the bug, update the docs & tests. That way your bug will be gone +forever :) + +=back + +=head1 SUPPLYING PATCHES + +Patches are a good thing, and they are welcome. Especially if they fix +bugs you've found along the way, or that others have reported. + +We prefer patches in the following format: + +=over 4 + +=item * In C<diff -u> or C<diff -c> format + +=item * From the root of the snapshot + +=item * Including patches for code + tests + docs + +=item * Sent per mail to cpanplus-devel@lists.sourceforge.net + +=item * With subject containing C<[PATCH]> + description of the patch + +=back + +You will always be informed if a patch is applied or rejected, and in +case of rejection why that is (perhaps you can tweak the patch to have +it accepted after all). + +=cut + +__END__ + +* perl5lib +* perl t/foo 1 +* patches to cpanplus-devel +* snap/devel.tgz diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals.pm new file mode 100755 index 00000000000..1c21bbec0ee --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals.pm @@ -0,0 +1,516 @@ +package CPANPLUS::Internals; + +### we /need/ perl5.6.1 or higher -- we use coderefs in @INC, +### and 5.6.0 is just too buggy +use 5.006001; + +use strict; +use Config; + + +use CPANPLUS::Error; + +use CPANPLUS::Selfupdate; + +use CPANPLUS::Internals::Extract; +use CPANPLUS::Internals::Fetch; +use CPANPLUS::Internals::Utils; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Internals::Search; +use CPANPLUS::Internals::Report; + + +require base; +use Cwd qw[cwd]; +use Module::Load qw[load]; +use Params::Check qw[check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use Module::Load::Conditional qw[can_load]; + +use Object::Accessor; + + +local $Params::Check::VERBOSE = 1; + +use vars qw[@ISA $VERSION]; + +@ISA = qw[ + CPANPLUS::Internals::Extract + CPANPLUS::Internals::Fetch + CPANPLUS::Internals::Utils + CPANPLUS::Internals::Search + CPANPLUS::Internals::Report + ]; + +$VERSION = "0.9001"; + +=pod + +=head1 NAME + +CPANPLUS::Internals + +=head1 SYNOPSIS + + my $internals = CPANPLUS::Internals->_init( _conf => $conf ); + my $backend = CPANPLUS::Internals->_retrieve_id( $ID ); + +=head1 DESCRIPTION + +This module is the guts of CPANPLUS -- it inherits from all other +modules in the CPANPLUS::Internals::* namespace, thus defying normal +rules of OO programming -- but if you're reading this, you already +know what's going on ;) + +Please read the C<CPANPLUS::Backend> documentation for the normal API. + +=head1 ACCESSORS + +=over 4 + +=item _conf + +Get/set the configure object + +=item _id + +Get/set the id + +=cut + +### autogenerate accessors ### +for my $key ( qw[_conf _id _modules _hosts _methods _status + _callbacks _selfupdate _mtree _atree] +) { + no strict 'refs'; + *{__PACKAGE__."::$key"} = sub { + $_[0]->{$key} = $_[1] if @_ > 1; + return $_[0]->{$key}; + } +} + +=pod + +=back + +=head1 METHODS + +=head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ ) + +C<_init> creates a new CPANPLUS::Internals object. + +You have to pass it a valid C<CPANPLUS::Configure> object. + +Returns the object on success, or dies on failure. + +=cut +{ ### NOTE: + ### if extra callbacks are added, don't forget to update the + ### 02-internals.t test script with them! + my $callback_map = { + ### name default value + install_prerequisite => 1, # install prereqs when 'ask' is set? + edit_test_report => 0, # edit the prepared test report? + send_test_report => 1, # send the test report? + # munge the test report + munge_test_report => sub { return $_[1] }, + # filter out unwanted prereqs + filter_prereqs => sub { return $_[1] }, + # continue if 'make test' fails? + proceed_on_test_failure => sub { return 0 }, + munge_dist_metafile => sub { return $_[1] }, + }; + + my $status = Object::Accessor->new; + $status->mk_accessors(qw[pending_prereqs]); + + my $callback = Object::Accessor->new; + $callback->mk_accessors(keys %$callback_map); + + my $conf; + my $Tmpl = { + _conf => { required => 1, store => \$conf, + allow => IS_CONFOBJ }, + _id => { default => '', no_override => 1 }, + _authortree => { default => '', no_override => 1 }, + _modtree => { default => '', no_override => 1 }, + _hosts => { default => {}, no_override => 1 }, + _methods => { default => {}, no_override => 1 }, + _status => { default => '<empty>', no_override => 1 }, + _callbacks => { default => '<empty>', no_override => 1 }, + }; + + sub _init { + my $class = shift; + my %hash = @_; + + ### temporary warning until we fix the storing of multiple id's + ### and their serialization: + ### probably not going to happen --kane + if( my $id = $class->_last_id ) { + # make it a singleton. + warn loc(q[%1 currently only supports one %2 object per ] . + qq[running program\n], 'CPANPLUS', $class); + + return $class->_retrieve_id( $id ); + } + + my $args = check($Tmpl, \%hash) + or die loc(qq[Could not initialize '%1' object], $class); + + bless $args, $class; + + $args->{'_id'} = $args->_inc_id; + $args->{'_status'} = $status; + $args->{'_callbacks'} = $callback; + + ### initialize callbacks to default state ### + for my $name ( $callback->ls_accessors ) { + my $rv = ref $callback_map->{$name} ? 'sub return value' : + $callback_map->{$name} ? 'true' : 'false'; + + $args->_callbacks->$name( + sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'", + $name, $rv), $args->_conf->get_conf('debug')); + return ref $callback_map->{$name} + ? $callback_map->{$name}->( @_ ) + : $callback_map->{$name}; + } + ); + } + + ### create a selfupdate object + $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) ); + + ### initalize it as an empty hashref ### + $args->_status->pending_prereqs( {} ); + + $conf->_set_build( startdir => cwd() ), + or error( loc("couldn't locate current dir!") ); + + $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive'); + + my $id = $args->_store_id( $args ); + + unless ( $id == $args->_id ) { + error( loc("IDs do not match: %1 != %2. Storage failed!", + $id, $args->_id) ); + } + + ### different source engines available now, so set them here + { my $store = $conf->get_conf( 'source_engine' ) + || DEFAULT_SOURCE_ENGINE; + + unless( can_load( modules => { $store => '0.0' }, verbose => 1 ) ) { + error( loc( "Could not load source engine '%1'", $store ) ); + + if( $store ne DEFAULT_SOURCE_ENGINE ) { + msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 ); + + load DEFAULT_SOURCE_ENGINE; + + base->import( DEFAULT_SOURCE_ENGINE ); + } else { + return; + } + } else { + base->import( $store ); + } + } + + return $args; + } + +=pod + +=head2 $bool = $internals->_flush( list => \@caches ) + +Flushes the designated caches from the C<CPANPLUS> object. + +Returns true on success, false if one or more caches could not be +be flushed. + +=cut + + sub _flush { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $aref; + my $tmpl = { + list => { required => 1, default => [], + strict_type => 1, store => \$aref }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $flag = 0; + for my $what (@$aref) { + my $cache = '_' . $what; + + ### set the include paths back to their original ### + if( $what eq 'lib' ) { + $ENV{PERL5LIB} = $conf->_perl5lib || ''; + @INC = @{$conf->_lib}; + + ### give all modules a new status object -- this is slightly + ### costly, but the best way to make sure all statusses are + ### forgotten --kane + } elsif ( $what eq 'modules' ) { + for my $modobj ( values %{$self->module_tree} ) { + + $modobj->_flush; + } + + ### blow away the methods cache... currently, that's only + ### File::Fetch's method fail list + } elsif ( $what eq 'methods' ) { + + ### still fucking p4 :( ### + $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {}; + + ### blow away the m::l::c cache, so modules can be (re)loaded + ### again if they become available + } elsif ( $what eq 'load' ) { + undef $Module::Load::Conditional::CACHE; + + } else { + unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) { + error( loc( "No such cache: '%1'", $what ) ); + $flag++; + next; + } else { + $self->$cache( {} ); + } + } + } + return !$flag; + } + +### NOTE: +### if extra callbacks are added, don't forget to update the +### 02-internals.t test script with them! + +=pod + +=head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF ); + +Registers a callback for later use by the internal libraries. + +Here is a list of the currently used callbacks: + +=over 4 + +=item install_prerequisite + +Is called when the user wants to be C<asked> about what to do with +prerequisites. Should return a boolean indicating true to install +the prerequisite and false to skip it. + +=item send_test_report + +Is called when the user should be prompted if he wishes to send the +test report. Should return a boolean indicating true to send the +test report and false to skip it. + +=item munge_test_report + +Is called when the test report message has been composed, giving +the user a chance to programatically alter it. Should return the +(munged) message to be sent. + +=item edit_test_report + +Is called when the user should be prompted to edit test reports +about to be sent out by Test::Reporter. Should return a boolean +indicating true to edit the test report in an editor and false +to skip it. + +=item proceed_on_test_failure + +Is called when 'make test' or 'Build test' fails. Should return +a boolean indicating whether the install should continue even if +the test failed. + +=item munge_dist_metafile + +Is called when the C<CPANPLUS::Dist::*> metafile is created, like +C<control> for C<CPANPLUS::Dist::Deb>, giving the user a chance to +programatically alter it. Should return the (munged) text to be +written to the metafile. + +=back + +=cut + + sub _register_callback { + my $self = shift or return; + my %hash = @_; + + my ($name,$code); + my $tmpl = { + name => { required => 1, store => \$name, + allow => [$callback->ls_accessors] }, + code => { required => 1, allow => IS_CODEREF, + store => \$code }, + }; + + check( $tmpl, \%hash ) or return; + + $self->_callbacks->$name( $code ) or return; + + return 1; + } + +# =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF ); +# +# Adds a new callback to be used from anywhere in the system. If the callback +# is already known, an error is raised and false is returned. If the callback +# is not yet known, it is added, and the corresponding coderef is registered +# using the +# +# =cut +# +# sub _add_callback { +# my $self = shift or return; +# my %hash = @_; +# +# my ($name,$code); +# my $tmpl = { +# name => { required => 1, store => \$name, }, +# code => { required => 1, allow => IS_CODEREF, +# store => \$code }, +# }; +# +# check( $tmpl, \%hash ) or return; +# +# if( $callback->can( $name ) ) { +# error(loc("Callback '%1' is already registered")); +# return; +# } +# +# $callback->mk_accessor( $name ); +# +# $self->_register_callback( name => $name, code => $code ) or return; +# +# return 1; +# } + +} + +=pod + +=head2 $bool = $internals->_add_to_includepath( directories => \@dirs ) + +Adds a list of directories to the include path. +This means they get added to C<@INC> as well as C<$ENV{PERL5LIB}>. + +Returns true on success, false on failure. + +=cut + +sub _add_to_includepath { + my $self = shift; + my %hash = @_; + + my $dirs; + my $tmpl = { + directories => { required => 1, default => [], store => \$dirs, + strict_type => 1 }, + }; + + check( $tmpl, \%hash ) or return; + + my $s = $Config{'path_sep'}; + + ### only add if it's not added yet + for my $lib (@$dirs) { + push @INC, $lib unless grep { $_ eq $lib } @INC; + # + ### it will be complaining if $ENV{PERL5LIB] is not defined (yet). + local $^W; + $ENV{'PERL5LIB'} .= $s . $lib + unless $ENV{'PERL5LIB'} =~ qr|\Q$s$lib\E|; + } + + return 1; +} + +=pod + +=head2 $id = CPANPLUS::Internals->_last_id + +Return the id of the last object stored. + +=head2 $id = CPANPLUS::Internals->_store_id( $internals ) + +Store this object; return its id. + +=head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID ) + +Retrieve an object based on its ID -- return false on error. + +=head2 CPANPLUS::Internals->_remove_id( $ID ) + +Remove the object marked by $ID from storage. + +=head2 @objs = CPANPLUS::Internals->_return_all_objects + +Return all stored objects. + +=cut + + +### code for storing multiple objects +### -- although we only support one right now +### XXX when support for multiple objects comes, saving source will have +### to change +{ + my $idref = {}; + my $count = 0; + + sub _inc_id { return ++$count; } + + sub _last_id { $count } + + sub _store_id { + my $self = shift; + my $obj = shift or return; + + unless( IS_INTERNALS_OBJ->($obj) ) { + error( loc("The object you passed has the wrong ref type: '%1'", + ref $obj) ); + return; + } + + $idref->{ $obj->_id } = $obj; + return $obj->_id; + } + + sub _retrieve_id { + my $self = shift; + my $id = shift or return; + + my $obj = $idref->{$id}; + return $obj; + } + + sub _remove_id { + my $self = shift; + my $id = shift or return; + + return delete $idref->{$id}; + } + + sub _return_all_objects { return values %$idref } +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Constants.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Constants.pm new file mode 100755 index 00000000000..1a38200dfb7 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Constants.pm @@ -0,0 +1,375 @@ +package CPANPLUS::Internals::Constants; + +use strict; + +use CPANPLUS::Error; + +use Config; +use File::Spec; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +require Exporter; +use vars qw[$VERSION @ISA @EXPORT]; + +use Package::Constants; + +@ISA = qw[Exporter]; +@EXPORT = Package::Constants->list( __PACKAGE__ ); + + +sub constants { @EXPORT }; + +use constant INSTALLER_BUILD + => 'CPANPLUS::Dist::Build'; +use constant INSTALLER_MM => 'CPANPLUS::Dist::MM'; +use constant INSTALLER_SAMPLE + => 'CPANPLUS::Dist::Sample'; +use constant INSTALLER_BASE => 'CPANPLUS::Dist::Base'; +use constant INSTALLER_AUTOBUNDLE + => 'CPANPLUS::Dist::Autobundle'; + +use constant SHELL_DEFAULT => 'CPANPLUS::Shell::Default'; +use constant SHELL_CLASSIC => 'CPANPLUS::Shell::Classic'; + +use constant CONFIG => 'CPANPLUS::Config'; +use constant CONFIG_USER => 'CPANPLUS::Config::User'; +use constant CONFIG_SYSTEM => 'CPANPLUS::Config::System'; +use constant CONFIG_BOXED => 'CPANPLUS::Config::Boxed'; + +use constant DEFAULT_SOURCE_ENGINE + => 'CPANPLUS::Internals::Source::Memory'; + +use constant TARGET_INIT => 'init'; +use constant TARGET_CREATE => 'create'; +use constant TARGET_PREPARE => 'prepare'; +use constant TARGET_INSTALL => 'install'; +use constant TARGET_IGNORE => 'ignore'; + +use constant ON_WIN32 => $^O eq 'MSWin32'; +use constant ON_NETWARE => $^O eq 'NetWare'; +use constant ON_CYGWIN => $^O eq 'cygwin'; +use constant ON_VMS => $^O eq 'VMS'; + +use constant DOT_CPANPLUS => ON_VMS ? '_cpanplus' : '.cpanplus'; + +use constant OPT_AUTOFLUSH => '-MCPANPLUS::Internals::Utils::Autoflush'; + +use constant UNKNOWN_DL_LOCATION + => 'UNKNOWN-ORIGIN'; + +use constant NMAKE => 'nmake.exe'; +use constant NMAKE_URL => + 'ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe'; + +use constant INSTALL_VIA_PACKAGE_MANAGER + => sub { my $fmt = $_[0] or return; + return 1 if $fmt ne INSTALLER_BUILD and + $fmt ne INSTALLER_MM; + }; + +use constant IS_CODEREF => sub { ref $_[-1] eq 'CODE' }; +use constant IS_MODOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Module') }; +use constant IS_FAKE_MODOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Module::Fake') }; +use constant IS_AUTHOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Module::Author') }; +use constant IS_FAKE_AUTHOBJ + => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Module::Author::Fake') }; + +use constant IS_CONFOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Configure') }; + +use constant IS_RVOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Backend::RV') }; + +use constant IS_INTERNALS_OBJ + => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Internals') }; + +use constant IS_FILE => sub { return 1 if -e $_[-1] }; + +use constant FILE_EXISTS => sub { + my $file = $_[-1]; + return 1 if IS_FILE->($file); + local $Carp::CarpLevel = + $Carp::CarpLevel+2; + error(loc( q[File '%1' does not exist], + $file)); + return; + }; + +use constant FILE_READABLE => sub { + my $file = $_[-1]; + return 1 if -e $file && -r _; + local $Carp::CarpLevel = + $Carp::CarpLevel+2; + error( loc( q[File '%1' is not readable ]. + q[or does not exist], $file)); + return; + }; +use constant IS_DIR => sub { return 1 if -d $_[-1] }; + +use constant DIR_EXISTS => sub { + my $dir = $_[-1]; + return 1 if IS_DIR->($dir); + local $Carp::CarpLevel = + $Carp::CarpLevel+2; + error(loc(q[Dir '%1' does not exist], + $dir)); + return; + }; + + ### On VMS, if the $Config{make} is either MMK + ### or MMS, then the makefile is 'DESCRIP.MMS'. +use constant MAKEFILE => sub { my $file = + (ON_VMS and + $Config::Config{make} =~ /MM[S|K]/i) + ? 'DESCRIP.MMS' + : 'Makefile'; + + return @_ + ? File::Spec->catfile( @_, $file ) + : $file; + }; +use constant MAKEFILE_PL => sub { return @_ + ? File::Spec->catfile( @_, + 'Makefile.PL' ) + : 'Makefile.PL'; + }; +use constant BUILD_PL => sub { return @_ + ? File::Spec->catfile( @_, + 'Build.PL' ) + : 'Build.PL'; + }; + +use constant META_YML => sub { return @_ + ? File::Spec->catfile( @_, 'META.yml' ) + : 'META.yml'; + }; + +use constant MYMETA_YML => sub { return @_ + ? File::Spec->catfile( @_, 'MYMETA.yml' ) + : 'MYMETA.yml'; + }; + +use constant BLIB => sub { return @_ + ? File::Spec->catfile(@_, 'blib') + : 'blib'; + }; + +use constant LIB => 'lib'; +use constant LIB_DIR => sub { return @_ + ? File::Spec->catdir(@_, LIB) + : LIB; + }; +use constant AUTO => 'auto'; +use constant LIB_AUTO_DIR => sub { return @_ + ? File::Spec->catdir(@_, LIB, AUTO) + : File::Spec->catdir(LIB, AUTO) + }; +use constant ARCH => 'arch'; +use constant ARCH_DIR => sub { return @_ + ? File::Spec->catdir(@_, ARCH) + : ARCH; + }; +use constant ARCH_AUTO_DIR => sub { return @_ + ? File::Spec->catdir(@_,ARCH,AUTO) + : File::Spec->catdir(ARCH,AUTO) + }; + +use constant BLIB_LIBDIR => sub { return @_ + ? File::Spec->catdir( + @_, BLIB->(), LIB ) + : File::Spec->catdir( BLIB->(), LIB ); + }; + +use constant CONFIG_USER_LIB_DIR => sub { + require CPANPLUS::Internals::Utils; + LIB_DIR->( + CPANPLUS::Internals::Utils->_home_dir, + DOT_CPANPLUS + ); + }; +use constant CONFIG_USER_FILE => sub { + File::Spec->catfile( + CONFIG_USER_LIB_DIR->(), + split('::', CONFIG_USER), + ) . '.pm'; + }; +use constant CONFIG_SYSTEM_FILE => sub { + require CPANPLUS::Internals; + require File::Basename; + my $dir = File::Basename::dirname( + $INC{'CPANPLUS/Internals.pm'} + ); + + ### XXX use constants + File::Spec->catfile( + $dir, qw[Config System.pm] + ); + }; + +use constant README => sub { my $obj = $_[0]; + my $pkg = $obj->package_name; + $pkg .= '-' . $obj->package_version . + '.readme'; + return $pkg; + }; +use constant META_EXT => 'meta'; + +use constant META => sub { my $obj = $_[0]; + my $pkg = $obj->package_name; + $pkg .= '-' . $obj->package_version . + '.' . META_EXT; + return $pkg; + }; + +use constant OPEN_FILE => sub { + my($file, $mode) = (@_, ''); + my $fh; + open $fh, "$mode" . $file + or error(loc( + "Could not open file '%1': %2", + $file, $!)); + return $fh if $fh; + return; + }; + +use constant OPEN_DIR => sub { + my $dir = shift; + my $dh; + opendir $dh, $dir or error(loc( + "Could not open dir '%1': %2", $dir, $! + )); + + return $dh if $dh; + return; + }; + +use constant READ_DIR => sub { + my $dir = shift; + my $dh = OPEN_DIR->( $dir ) or return; + + ### exclude . and .. + my @files = grep { $_ !~ /^\.{1,2}/ } + readdir($dh); + + ### Remove trailing dot on VMS when + ### using VMS syntax. + if( ON_VMS ) { + s/(?<!\^)\.$// for @files; + } + + return @files; + }; + +use constant STRIP_GZ_SUFFIX + => sub { + my $file = $_[0] or return; + $file =~ s/.gz$//i; + return $file; + }; + +use constant CHECKSUMS => 'CHECKSUMS'; +use constant PGP_HEADER => '-----BEGIN PGP SIGNED MESSAGE-----'; +use constant ENV_CPANPLUS_CONFIG + => 'PERL5_CPANPLUS_CONFIG'; +use constant ENV_CPANPLUS_IS_EXECUTING + => 'PERL5_CPANPLUS_IS_EXECUTING'; +use constant DEFAULT_EMAIL => 'cpanplus@example.com'; +use constant CPANPLUS_UA => sub { ### for the version number ### + require CPANPLUS::Internals; + "CPANPLUS/$CPANPLUS::Internals::VERSION" + }; +use constant TESTERS_URL => sub { + 'http://cpantesters.org/distro/'. + uc(substr($_[0],0,1)) .'/'. $_[0] . '.yaml'; + }; +use constant TESTERS_DETAILS_URL + => sub { + 'http://cpantesters.org/distro/'. + uc(substr($_[0],0,1)) .'/'. $_[0]; + }; + +use constant CREATE_FILE_URI + => sub { + my $dir = $_[0] or return; + return $dir =~ m|^/| + ? 'file://' . $dir + : 'file:///' . $dir; + }; + +use constant EMPTY_DSLIP => ' '; + +use constant CUSTOM_AUTHOR_ID + => 'LOCAL'; + +use constant DOT_SHELL_DEFAULT_RC + => '.shell-default.rc'; + +use constant SOURCE_SQLITE_DB + => 'db.sql'; + +use constant PREREQ_IGNORE => 0; +use constant PREREQ_INSTALL => 1; +use constant PREREQ_ASK => 2; +use constant PREREQ_BUILD => 3; +use constant BOOLEANS => [0,1]; +use constant CALLING_FUNCTION + => sub { my $lvl = $_[0] || 0; + return join '::', (caller(2+$lvl))[3] + }; +use constant PERL_CORE => 'perl'; +use constant STORABLE_EXT => '.stored'; + +use constant GET_XS_FILES => sub { my $dir = $_[0] or return; + require File::Find; + my @files; + File::Find::find( + sub { push @files, $File::Find::name + if $File::Find::name =~ /\.xs$/i + }, $dir ); + + return @files; + }; + +use constant INSTALL_LOG_FILE + => sub { my $obj = shift or return; + my $name = $obj->name; $name =~ s/::/-/g; + $name .= '-'. $obj->version; + $name .= '-'. scalar(time) . '.log'; + return $name; + }; + +use constant ON_OLD_CYGWIN => do { ON_CYGWIN and $] < 5.008 + ? loc( + "Your perl version for %1 is too low; ". + "Require %2 or higher for this function", + $^O, '5.8.0' ) + : ''; + }; + +### XXX these 2 are probably obsolete -- check & remove; +use constant DOT_EXISTS => '.exists'; + +use constant QUOTE_PERL_ONE_LINER + => sub { my $line = shift or return; + + ### use double quotes on these systems + return qq["$line"] + if ON_WIN32 || ON_NETWARE || ON_VMS; + + ### single quotes on the rest + return qq['$line']; + }; + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Constants/Report.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Constants/Report.pm new file mode 100755 index 00000000000..59a41a6083b --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Constants/Report.pm @@ -0,0 +1,407 @@ +package CPANPLUS::Internals::Constants::Report; + +use strict; +use CPANPLUS::Error; + +use File::Spec; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +require Exporter; +use vars qw[$VERSION @ISA @EXPORT]; + +use Package::Constants; + +### for the version +require CPANPLUS::Internals; + +$VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION; +@ISA = qw[Exporter]; +@EXPORT = Package::Constants->list( __PACKAGE__ ); + + +### OS to regex map ### +my %OS = ( + Amiga => 'amigaos', + Atari => 'mint', + BSD => 'bsdos|darwin|freebsd|openbsd|netbsd', + Be => 'beos', + BeOS => 'beos', + Cygwin => 'cygwin', + Darwin => 'darwin', + EBCDIC => 'os390|os400|posix-bc|vmesa', + HPUX => 'hpux', + Linux => 'linux', + MSDOS => 'dos|os2|MSWin32|cygwin', + 'bin\\d*Mac'=> 'MacOS|darwin', # binMac, bin56Mac, bin58Mac... + Mac => 'MacOS|darwin', + MacPerl => 'MacOS', + MacOS => 'MacOS|darwin', + MacOSX => 'darwin', + MPE => 'mpeix', + MPEiX => 'mpeix', + OS2 => 'os2', + Plan9 => 'plan9', + RISCOS => 'riscos', + SGI => 'irix', + Solaris => 'solaris', + Unix => 'aix|bsdos|darwin|dgux|dynixptx|freebsd|'. + 'linux|hpux|machten|netbsd|next|openbsd|dec_osf|'. + 'svr4|sco_sv|unicos|unicosmk|solaris|sunos', + VMS => 'VMS', + VOS => 'VOS', + Win32 => 'MSWin32|cygwin', + Win32API => 'MSWin32|cygwin', +); + +use constant GRADE_FAIL => 'fail'; +use constant GRADE_PASS => 'pass'; +use constant GRADE_NA => 'na'; +use constant GRADE_UNKNOWN => 'unknown'; + +use constant MAX_REPORT_SEND + => 2; + +use constant CPAN_TESTERS_EMAIL + => 'cpan-testers@perl.org'; + +### the cpan mail account for this user ### +use constant CPAN_MAIL_ACCOUNT + => sub { + my $username = shift or return; + return $username . '@cpan.org'; + }; + +### check if this module is platform specific and if we're on that +### specific platform. Alternately, the module is not platform specific +### and we're always OK to send out test results. +use constant RELEVANT_TEST_RESULT + => sub { + my $mod = shift or return; + my $name = $mod->module; + my $specific; + for my $platform (keys %OS) { + if( $name =~ /\b$platform\b/i ) { + # beware the Mac != MAC + next if($platform eq 'Mac' && + $name !~ /\b$platform\b/); + $specific++; + return 1 if + $^O =~ /^(?:$OS{$platform})$/ + } + }; + return $specific ? 0 : 1; + }; + +use constant UNSUPPORTED_OS + => sub { + my $buffer = shift or return; + if( $buffer =~ + /No support for OS|OS unsupported/im ) { + return 1; + } + return 0; + }; + +use constant PERL_VERSION_TOO_LOW + => sub { + my $buffer = shift or return; + # ExtUtils::MakeMaker format + if( $buffer =~ + /Perl .*? required--this is only .*?/m ) { + return 1; + } + # Module::Build format + if( $buffer =~ + /ERROR:( perl:)? Version .*?( of perl)? is installed, but we need version >= .*?/m ) { + return 1; + } + return 0; + }; + +use constant NO_TESTS_DEFINED + => sub { + my $buffer = shift or return; + if( $buffer =~ + /(No tests defined( for [\w:]+ extension)?\.)/ + and $buffer !~ /\*\.t/m and + $buffer !~ /test\.pl/m + ) { + return $1 + } + + return; + }; + +### what stage did the test fail? ### +use constant TEST_FAIL_STAGE + => sub { + my $buffer = shift or return; + return $buffer =~ /(MAKE [A-Z]+).*/ + ? lc $1 : + 'fetch'; + }; + + +use constant MISSING_PREREQS_LIST + => sub { + my $buffer = shift; + my $last = ( split /\[ERROR\] .+? MAKE TEST/, $buffer )[-1]; + my @list = map { s/.pm$//; s|/|::|g; $_ } + ($last =~ + m/\bCan\'t locate (\S+) in \@INC/g); + + ### make sure every missing prereq is only + ### listed once + { my %seen; + @list = grep { !$seen{$_}++ } @list + } + + return @list; + }; + +use constant MISSING_EXTLIBS_LIST + => sub { + my $buffer = shift; + my @list = + ($buffer =~ + m/No library found for -l([-\w]+)/g); + + return @list; + }; + +use constant REPORT_MESSAGE_HEADER + => sub { + my ($version, $author) = @_; + return << "."; + +Dear $author, + +This is a computer-generated error report created automatically by +CPANPLUS, version $version. Testers personal comments may appear +at the end of this report. + +. + }; + +use constant REPORT_MESSAGE_FAIL_HEADER + => sub { + my($stage, $buffer) = @_; + return << "."; + +Thank you for uploading your work to CPAN. However, it appears that +there were some problems testing your distribution. + +TEST RESULTS: + +Below is the error stack from stage '$stage': + +$buffer + +. + }; + +use constant REPORT_MISSING_PREREQS + => sub { + my ($author,$email,@missing) = @_; + $author = ($author && $email) + ? "$author ($email)" + : 'Your Name Here'; + + my $modules = join "\n", @missing; + my $prereqs = join "\n", + map {"\t'$_'\t=> '0',". + " # or a minimum working version"} + @missing; + + return << "."; + +MISSING PREREQUISITES: + +It was observed that the test suite seem to fail without these modules: + +$modules + +As such, adding the prerequisite module(s) to 'PREREQ_PM' in your +Makefile.PL should solve this problem. For example: + +WriteMakefile( + AUTHOR => '$author', + ... # other information + PREREQ_PM => { +$prereqs + } +); + +Thanks! :-) + +. + }; + +use constant REPORT_MISSING_TESTS + => sub { + return << "."; +RECOMMENDATIONS: + +It would be very helpful if you could include even a simple test +script in the next release, so people can verify which platforms +can successfully install them, as well as avoid regression bugs? + +A simple 't/use.t' that says: + +#!/usr/bin/env perl -w +use strict; +use Test; +BEGIN { plan tests => 1 } + +use Your::Module::Here; ok(1); +exit; +__END__ + +would be appreciated. If you are interested in making a more robust +test suite, please see the Test::Simple, Test::More and Test::Tutorial +documentation at <http://search.cpan.org/dist/Test-Simple/>. + +Thanks! :-) + +. + }; + +use constant REPORT_LOADED_PREREQS + => sub { + my $mod = shift; + my $cb = $mod->parent; + my $prq = $mod->status->prereqs || {}; + + ### not every prereq may be coming from CPAN + ### so maybe we wont find it in our module + ### tree at all... + ### skip ones that cant be found in teh list + ### as reported in #12723 + my @prq = grep { defined } + map { $cb->module_tree($_) } + sort keys %$prq; + + ### no prereqs? + return '' unless @prq; + + ### some apparently, list what we loaded + my $str = << "."; +PREREQUISITES: + +Here is a list of prerequisites you specified and versions we +managed to load: + +. + $str .= join '', + map { sprintf "\t%s %-30s %8s %8s\n", + @$_ + + } [' ', 'Module Name', 'Have', 'Want'], + map { my $want = $prq->{$_->name}; + [ do { $_->is_uptodate( + version => $want + ) ? ' ' : '!' + }, + $_->name, + $_->installed_version, + $want + ], + ### might be empty entries in there + } grep { $_ } @prq; + + return $str; + }; + +use constant REPORT_TOOLCHAIN_VERSIONS + => sub { + my $mod = shift; + my $cb = $mod->parent; + #die unless $cb->isa('CPANPLUS::Backend'); + + my @toolchain_modules= qw( + CPANPLUS + CPANPLUS::Dist::Build + Cwd + ExtUtils::CBuilder + ExtUtils::Command + ExtUtils::Install + ExtUtils::MakeMaker + ExtUtils::Manifest + ExtUtils::ParseXS + File::Spec + Module::Build + Test::Harness + Test::More + version + ); + + my @toolchain = + grep { $_ } #module_tree returns '' when module is not found + map { $cb->module_tree($_) } + sort @toolchain_modules; + + ### no prereqs? + return '' unless @toolchain; + + ### toolchain modules + my $str = << "."; + +Perl module toolchain versions installed: +. + $str .= join '', + map { sprintf "\t%-30s %8s\n", + @$_ + + } ['Module Name', 'Have'], + map { + [ $_->name, + $_->installed_version, + ], + ### might be empty entries in there + } @toolchain; + + return $str; + }; + + +use constant REPORT_TESTS_SKIPPED + => sub { + return << "."; + +******************************** NOTE ******************************** +*** *** +*** The tests for this module were skipped during this build *** +*** *** +********************************************************************** + +. + }; + +use constant REPORT_MESSAGE_FOOTER + => sub { + return << "."; + +******************************** NOTE ******************************** +The comments above are created mechanically, possibly without manual +checking by the sender. As there are many people performing automatic +tests on each upload to CPAN, it is likely that you will receive +identical messages about the same problem. + +If you believe that the message is mistaken, please reply to the first +one with correction and/or additional informations, and do not take +it personally. We appreciate your patience. :) +********************************************************************** + +Additional comments: + +. + }; + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Extract.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Extract.pm new file mode 100755 index 00000000000..84a48a50dea --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Extract.pm @@ -0,0 +1,243 @@ +package CPANPLUS::Internals::Extract; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use File::Spec (); +use File::Basename (); +use Archive::Extract; +use IPC::Cmd qw[run]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Extract + +=head1 SYNOPSIS + + ### for source files ### + $self->_gunzip( file => 'foo.gz', output => 'blah.txt' ); + + ### for modules/packages ### + $dir = $self->_extract( module => $modobj, + extractdir => '/some/where' ); + +=head1 DESCRIPTION + +CPANPLUS::Internals::Extract extracts compressed files for CPANPLUS. +It can do this by either a pure perl solution (preferred) with the +use of C<Archive::Tar> and C<Compress::Zlib>, or with binaries, like +C<gzip> and C<tar>. + +The flow looks like this: + + $cb->_extract + Delegate to Archive::Extract + +=head1 METHODS + +=head2 $dir = _extract( module => $modobj, [perl => '/path/to/perl', extractdir => '/path/to/extract/to', prefer_bin => BOOL, verbose => BOOL, force => BOOL] ) + +C<_extract> will take a module object and extract it to C<extractdir> +if provided, or the default location which is obtained from your +config. + +The file name is obtained by looking at C<< $modobj->status->fetch >> +and will be parsed to see if it's a tar or zip archive. + +If it's a zip archive, C<__unzip> will be called, otherwise C<__untar> +will be called. In the unlikely event the file is of neither format, +an error will be thrown. + +C<_extract> takes the following options: + +=over 4 + +=item module + +A C<CPANPLUS::Module> object. This is required. + +=item extractdir + +The directory to extract the archive to. By default this looks +something like: + /CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME + +=item prefer_bin + +A flag indicating whether you prefer a pure perl solution, ie +C<Archive::Tar> or C<Archive::Zip> respectively, or a binary solution +like C<unzip> and C<tar>. + +=item perl + +The path to the perl executable to use for any perl calls. Also used +to determine the build version directory for extraction. + +=item verbose + +Specifies whether to be verbose or not. Defaults to your corresponding +config entry. + +=item force + +Specifies whether to force the extraction or not. Defaults to your +corresponding config entry. + +=back + +All other options are passed on verbatim to C<__unzip> or C<__untar>. + +Returns the directory the file was extracted to on success and false +on failure. + +=cut + +sub _extract { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + local $Params::Check::ALLOW_UNKNOWN = 1; + + my( $mod, $verbose, $force ); + my $tmpl = { + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + prefer_bin => { default => $conf->get_conf('prefer_bin') }, + extractdir => { default => $conf->get_conf('extractdir') }, + module => { required => 1, allow => IS_MODOBJ, store => \$mod }, + perl => { default => $^X }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### did we already extract it ? ### + my $loc = $mod->status->extract(); + + if( $loc && !$force ) { + msg(loc("Already extracted '%1' to '%2'. ". + "Won't extract again without force", + $mod->module, $loc), $verbose); + return $loc; + } + + ### did we already fetch the file? ### + my $file = $mod->status->fetch(); + unless( -s $file ) { + error( loc( "File '%1' has zero size: cannot extract", $file ) ); + return; + } + + ### the dir to extract to ### + my $to = $args->{'extractdir'} || + File::Spec->catdir( + $conf->get_conf('base'), + $self->_perl_version( perl => $args->{'perl'} ), + $conf->_get_build('moddir'), + ); + + ### delegate to Archive::Extract ### + ### set up some flags for archive::extract ### + local $Archive::Extract::PREFER_BIN = $args->{'prefer_bin'}; + local $Archive::Extract::DEBUG = $conf->get_conf('debug'); + local $Archive::Extract::WARN = $verbose; + + my $ae = Archive::Extract->new( archive => $file ); + + unless( $ae->extract( to => $to ) ) { + error( loc( "Unable to extract '%1' to '%2': %3", + $file, $to, $ae->error ) ); + return; + } + + ### if ->files is not filled, we dont know what the hell was + ### extracted.. try to offer a suggestion and bail :( + unless ( $ae->files ) { + error( loc( "'%1' was not able to determine extracted ". + "files from the archive. Instal '%2' and ensure ". + "it works properly and try again", + $ae->is_zip ? 'Archive::Zip' : 'Archive::Tar' ) ); + return; + } + + + ### print out what files we extracted ### + msg(loc("Extracted '%1'",$_),$verbose) for @{$ae->files}; + + ### set them all to be +w for the owner, so we don't get permission + ### denied for overwriting files that are just +r + + ### this is to rigurous -- just change to +w for the owner [cpan #13358] + #chmod 0755, map { File::Spec->rel2abs( File::Spec->catdir($to, $_) ) } + # @{$ae->files}; + + for my $file ( @{$ae->files} ) { + my $path = File::Spec->rel2abs( File::Spec->catfile($to, $file) ); + + $self->_mode_plus_w( file => $path ); + } + + ### check the return value for the extracted path ### + ### Make an educated guess if we didn't get an extract_path + ### back + ### XXX apparently some people make their own dists and they + ### pack up '.' which means the leading directory is '.' + ### and only the second directory is the actual module directory + ### so, we'll have to check if our educated guess exists first, + ### then see if the extract path works.. and if nothing works... + ### well, then we really don't know. + + my $dir; + for my $try ( + File::Spec->rel2abs( + ### _safe_path must be called before catdir because catdir on + ### VMS currently will not handle the extra dots in the directories. + File::Spec->catdir( $self->_safe_path( path => $to ) , + $self->_safe_path( path => + $mod->package_name .'-'. + $mod->package_version + ) ) ) , + File::Spec->rel2abs( $ae->extract_path ), + ) { + ($dir = $try) && last if -d $try; + } + + ### test if the dir exists ### + unless( $dir && -d $dir ) { + error(loc("Unable to determine extract dir for '%1'",$mod->module)); + return; + + } else { + msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose); + + ### register where we extracted the files to, + ### also store what files were extracted + $mod->status->extract( $dir ); + $mod->status->files( $ae->files ); + } + + ### also, figure out what kind of install we're dealing with ### + $mod->get_installer_type(); + + return $mod->status->extract(); +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Fetch.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Fetch.pm new file mode 100755 index 00000000000..395965bab60 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Fetch.pm @@ -0,0 +1,473 @@ +package CPANPLUS::Internals::Fetch; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use File::Fetch; +use File::Spec; +use Cwd qw[cwd]; +use IPC::Cmd qw[run]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Fetch + +=head1 SYNOPSIS + + my $output = $cb->_fetch( + module => $modobj, + fetchdir => '/path/to/save/to', + verbose => BOOL, + force => BOOL, + ); + + $cb->_add_fail_host( host => 'foo.com' ); + $cb->_host_ok( host => 'foo.com' ); + + +=head1 DESCRIPTION + +CPANPLUS::Internals::Fetch fetches files from either ftp, http, file +or rsync mirrors. + +This is the rough flow: + + $cb->_fetch + Delegate to File::Fetch; + + +=head1 METHODS + +=cut + +=head1 $path = _fetch( module => $modobj, [fetchdir => '/path/to/save/to', fetch_from => 'scheme://path/to/fetch/from', verbose => BOOL, force => BOOL, prefer_bin => BOOL, ttl => $seconds] ) + +C<_fetch> will fetch files based on the information in a module +object. You always need a module object. If you want a fake module +object for a one-off fetch, look at C<CPANPLUS::Module::Fake>. + +C<fetchdir> is the place to save the file to. Usually this +information comes from your configuration, but you can override it +expressly if needed. + +C<fetch_from> lets you specify an URI to get this file from. If you +do not specify one, your list of configured hosts will be probed to +download the file from. + +C<force> forces a new download, even if the file already exists. + +C<verbose> simply indicates whether or not to print extra messages. + +C<prefer_bin> indicates whether you prefer the use of commandline +programs over perl modules. Defaults to your corresponding config +setting. + +C<ttl> (in seconds) indicates how long a cached copy is valid for. If +the fetch time of the local copy is within the ttl, the cached copy is +returned. Otherwise, the file is refetched. + +C<_fetch> figures out, based on the host list, what scheme to use and +from there, delegates to C<File::Fetch> do the actual fetching. + +Returns the path of the output file on success, false on failure. + +Note that you can set a C<blacklist> on certain methods in the config. +Simply add the identifying name of the method (ie, C<lwp>) to: + $conf->_set_fetch( blacklist => ['lwp'] ); + +And the C<LWP> function will be skipped by C<File::Fetch>. + +=cut + +sub _fetch { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + local $Params::Check::NO_DUPLICATES = 0; + + my ($modobj, $verbose, $force, $fetch_from, $ttl); + my $tmpl = { + module => { required => 1, allow => IS_MODOBJ, store => \$modobj }, + fetchdir => { default => $conf->get_conf('fetchdir') }, + fetch_from => { default => '', store => \$fetch_from }, + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + prefer_bin => { default => $conf->get_conf('prefer_bin') }, + ttl => { default => 0, store => \$ttl }, + }; + + + my $args = check( $tmpl, \%hash ) or return; + + ### check if we already downloaded the thing ### + if( (my $where = $modobj->status->fetch()) and not $force and not $ttl ) { + + msg(loc("Already fetched '%1' to '%2', " . + "won't fetch again without force", + $modobj->module, $where ), $verbose ); + return $where; + } + + my ($remote_file, $local_file, $local_path); + + ### build the local path to downlaod to ### + { + $local_path = $args->{fetchdir} || + File::Spec->catdir( + $conf->get_conf('base'), + $modobj->path, + ); + + ### create the path if it doesn't exist ### + unless( -d $local_path ) { + unless( $self->_mkdir( dir => $local_path ) ) { + msg( loc("Could not create path '%1'", $local_path), $verbose); + return; + } + } + + $local_file = File::Spec->rel2abs( + File::Spec->catfile( + $local_path, + $modobj->package, + ) + ); + + ### do we already have the file? if so, can we use the cached version, + ### or do we need to refetch? + if( -e $local_file ) { + + my $unlink = 0; + my $use_cached = 0; + + ### if force is in effect, we have to refetch + if( $force ) { + $unlink++ + + ### if you provided a ttl, and it was exceeded, we'll refetch, + } elsif( $ttl and ([stat $local_file]->[9] + $ttl > time) ) { + msg(loc("Using cached file '%1' on disk; ". + "ttl (%2s) is not exceeded", + $local_file, $ttl), $verbose ); + + $use_cached++; + + ### if you provided a ttl, and the above conditional didn't match, + ### we exceeded the ttl, so we refetch + } elsif ( $ttl ) { + $unlink++; + + ### otherwise we can use the cached version + } else { + $use_cached++; + } + + if( $unlink ) { + ### some fetches will fail if the files exist already, so let's + ### delete them first + 1 while unlink $local_file; + + msg(loc("Could not delete %1, some methods may " . + "fail to force a download", $local_file), $verbose) + if -e $local_file; + + } else { + + ### store where we fetched it ### + $modobj->status->fetch( $local_file ); + + return $local_file; + } + } + } + + + ### we got a custom URI + if ( $fetch_from ) { + my $abs = $self->__file_fetch( from => $fetch_from, + to => $local_path, + verbose => $verbose ); + + unless( $abs ) { + error(loc("Unable to download '%1'", $fetch_from)); + return; + } + + ### store where we fetched it ### + $modobj->status->fetch( $abs ); + + return $abs; + + ### we will get it from one of our mirrors + } else { + ### build the remote path to download from ### + { $remote_file = File::Spec::Unix->catfile( + $modobj->path, + $modobj->package, + ); + unless( $remote_file ) { + error( loc('No remote file given for download') ); + return; + } + } + + ### see if we even have a host or a method to use to download with ### + my $found_host; + my @maybe_bad_host; + + HOST: { + ### F*CKING PIECE OF F*CKING p4 SHIT makes + ### '$File :: Fetch::SOME_VAR' + ### into a meta variable and starts substituting the file name... + ### GRAAAAAAAAAAAAAAAAAAAAAAH! + ### use ' to combat it! + + ### set up some flags for File::Fetch ### + local $File'Fetch::BLACKLIST = $conf->_get_fetch('blacklist'); + local $File'Fetch::TIMEOUT = $conf->get_conf('timeout'); + local $File'Fetch::DEBUG = $conf->get_conf('debug'); + local $File'Fetch::FTP_PASSIVE = $conf->get_conf('passive'); + local $File'Fetch::FROM_EMAIL = $conf->get_conf('email'); + local $File'Fetch::PREFER_BIN = $conf->get_conf('prefer_bin'); + local $File'Fetch::WARN = $verbose; + + + ### loop over all hosts we have ### + for my $host ( @{$conf->get_conf('hosts')} ) { + $found_host++; + + my $where; + + ### file:// uris are special and need parsing + if( $host->{'scheme'} eq 'file' ) { + + ### the full path in the native format of the OS + my $host_spec = + File::Spec->file_name_is_absolute( $host->{'path'} ) + ? $host->{'path'} + : File::Spec->rel2abs( $host->{'path'} ); + + ### there might be volumes involved on vms/win32 + if( ON_WIN32 or ON_VMS ) { + + ### now extract the volume in order to be Win32 and + ### VMS friendly. + ### 'no_file' indicates that there's no file part + ### of this path, so we only get 2 bits returned. + my ($vol, $host_path) = File::Spec->splitpath( + $host_spec, 'no_file' + ); + + ### and split up the directories + my @host_dirs = File::Spec->splitdir( $host_path ); + + ### if we got a volume we pretend its a directory for + ### the sake of the file:// url + if( defined $vol and $vol ) { + + ### D:\foo\bar needs to be encoded as D|\foo\bar + ### For details, see the following link: + ### http://en.wikipedia.org/wiki/File:// + ### The RFC doesnt seem to address Windows volume + ### descriptors but it does address VMS volume + ### descriptors, however wikipedia covers a bit of + ### history regarding win32 + $vol =~ s/:$/|/ if ON_WIN32; + + $vol =~ s/:// if ON_VMS; + + ### XXX i'm not sure what cases this is addressing. + ### this comes straight from dmq's file:// patches + ### for win32. --kane + ### According to dmq, the best summary is: + ### "if file:// urls dont look right on VMS reuse + ### the win32 logic and see if that fixes things" + + ### first element not empty? Might happen on VMS. + ### prepend the volume in that case. + if( $host_dirs[0] ) { + unshift @host_dirs, $vol; + + ### element empty? reuse it to store the volume + ### encoded as a directory name. (Win32/VMS) + } else { + $host_dirs[0] = $vol; + } + } + + ### now it's in UNIX format, which is the same format + ### as used for URIs + $host_spec = File::Spec::Unix->catdir( @host_dirs ); + } + + ### now create the file:// uri from the components + $where = CREATE_FILE_URI->( + File::Spec::Unix->catfile( + $host->{'host'} || '', + $host_spec, + $remote_file, + ) + ); + + ### its components will be in unix format, for a http://, + ### ftp:// or any other style of URI + } else { + my $mirror_path = File::Spec::Unix->catfile( + $host->{'path'}, $remote_file + ); + + my %args = ( scheme => $host->{scheme}, + host => $host->{host}, + path => $mirror_path, + ); + + $where = $self->_host_to_uri( %args ); + } + + my $abs = $self->__file_fetch( from => $where, + to => $local_path, + verbose => $verbose ); + + ### we got a path back? + if( $abs ) { + ### store where we fetched it ### + $modobj->status->fetch( $abs ); + + ### this host is good, the previous ones are apparently + ### not, so mark them as such. + $self->_add_fail_host( host => $_ ) for @maybe_bad_host; + + return $abs; + } + + ### so we tried to get the file but didn't actually fetch it -- + ### there's a chance this host is bad. mark it as such and + ### actually flag it back if we manage to get the file + ### somewhere else + push @maybe_bad_host, $host; + } + } + + $found_host + ? error(loc("Fetch failed: host list exhausted " . + "-- are you connected today?")) + : error(loc("No hosts found to download from " . + "-- check your config")); + } + + return; +} + +sub __file_fetch { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my ($where, $local_path, $verbose); + my $tmpl = { + from => { required => 1, store => \$where }, + to => { required => 1, store => \$local_path }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + check( $tmpl, \%hash ) or return; + + msg(loc("Trying to get '%1'", $where ), $verbose ); + + ### build the object ### + my $ff = File::Fetch->new( uri => $where ); + + ### sanity check ### + error(loc("Bad uri '%1'",$where)), return unless $ff; + + if( my $file = $ff->fetch( to => $local_path ) ) { + unless( -e $file && -s _ ) { + msg(loc("'%1' said it fetched '%2', but it was not created", + 'File::Fetch', $file), $verbose); + + } else { + my $abs = File::Spec->rel2abs( $file ); + + ### so TTLs will work + $self->_update_timestamp( file => $abs ); + + return $abs; + } + + } else { + error(loc("Fetching of '%1' failed: %2", $where, $ff->error)); + } + + return; +} + +=pod + +=head2 _add_fail_host( host => $host_hashref ) + +Mark a particular host as bad. This makes C<CPANPLUS::Internals::Fetch> +skip it in fetches until this cache is flushed. + +=head2 _host_ok( host => $host_hashref ) + +Query the cache to see if this host is ok, or if it has been flagged +as bad. + +Returns true if the host is ok, false otherwise. + +=cut + +{ ### caching functions ### + + sub _add_fail_host { + my $self = shift; + my %hash = @_; + + my $host; + my $tmpl = { + host => { required => 1, default => {}, + strict_type => 1, store => \$host }, + }; + + check( $tmpl, \%hash ) or return; + + return $self->_hosts->{$host} = 1; + } + + sub _host_ok { + my $self = shift; + my %hash = @_; + + my $host; + my $tmpl = { + host => { required => 1, store => \$host }, + }; + + check( $tmpl, \%hash ) or return; + + return $self->_hosts->{$host} ? 0 : 1; + } +} + + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Report.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Report.pm new file mode 100755 index 00000000000..774c6b91a02 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Report.pm @@ -0,0 +1,645 @@ +package CPANPLUS::Internals::Report; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Internals::Constants::Report; + +use Data::Dumper; + +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +### for the version ### +require CPANPLUS::Internals; + +=head1 NAME + +CPANPLUS::Internals::Report + +=head1 SYNOPSIS + + ### enable test reporting + $cb->configure_object->set_conf( cpantest => 1 ); + + ### set custom mx host, shouldn't normally be needed + $cb->configure_object->set_conf( cpantest_mx => 'smtp.example.com' ); + +=head1 DESCRIPTION + +This module provides all the functionality to send test reports to +C<http://testers.cpan.org> using the C<Test::Reporter> module. + +All methods will be called automatically if you have C<CPANPLUS> +configured to enable test reporting (see the C<SYNOPSIS>). + +=head1 METHODS + +=head2 $bool = $cb->_have_query_report_modules + +This function checks if all the required modules are here for querying +reports. It returns true and loads them if they are, or returns false +otherwise. + +=head2 $bool = $cb->_have_send_report_modules + +This function checks if all the required modules are here for sending +reports. It returns true and loads them if they are, or returns false +otherwise. + +=cut + +### XXX remove this list and move it into selfupdate, somehow.. +### this is dual administration +{ my $query_list = { + 'File::Fetch' => '0.13_02', + 'Parse::CPAN::Meta' => '0.0', + 'File::Temp' => '0.0', + }; + + my $send_list = { + %$query_list, + 'Test::Reporter' => '1.34', + }; + + sub _have_query_report_modules { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $tmpl = { + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + return can_load( modules => $query_list, verbose => $args->{verbose} ) + ? 1 + : 0; + } + + sub _have_send_report_modules { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $tmpl = { + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + return can_load( modules => $send_list, verbose => $args->{verbose} ) + ? 1 + : 0; + } +} + +=head2 @list = $cb->_query_report( module => $modobj, [all_versions => BOOL, verbose => BOOL] ) + +This function queries the CPAN testers database at +I<http://testers.cpan.org/> for test results of specified module objects, +module names or distributions. + +The optional argument C<all_versions> controls whether all versions of +a given distribution should be grabbed. It defaults to false +(fetching only reports for the current version). + +Returns the a list with the following data structures (for CPANPLUS +version 0.042) on success, or false on failure. The contents of the +data structure depends on what I<http://testers.cpan.org> returns, +but generally looks like this: + + { + 'grade' => 'PASS', + 'dist' => 'CPANPLUS-0.042', + 'platform' => 'i686-pld-linux-thread-multi' + 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/98316' + ... + }, + { + 'grade' => 'PASS', + 'dist' => 'CPANPLUS-0.042', + 'platform' => 'i686-linux-thread-multi' + 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99416' + ... + }, + { + 'grade' => 'FAIL', + 'dist' => 'CPANPLUS-0.042', + 'platform' => 'cygwin-multi-64int', + 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99371' + ... + }, + { + 'grade' => 'FAIL', + 'dist' => 'CPANPLUS-0.042', + 'platform' => 'i586-linux', + 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99396' + ... + }, + +The status of the test can be one of the following: +UNKNOWN, PASS, FAIL or NA (not applicable). + +=cut + +sub _query_report { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($mod, $verbose, $all); + my $tmpl = { + module => { required => 1, allow => IS_MODOBJ, + store => \$mod }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + all_versions => { default => 0, store => \$all }, + }; + + check( $tmpl, \%hash ) or return; + + ### check if we have the modules we need for querying + return unless $self->_have_query_report_modules( verbose => 1 ); + + + ### XXX no longer use LWP here. However, that means we don't + ### automagically set proxies anymore!!! + # my $ua = LWP::UserAgent->new; + # $ua->agent( CPANPLUS_UA->() ); + # + ### set proxies if we have them ### + # $ua->env_proxy(); + + my $url = TESTERS_URL->($mod->package_name); + my $ff = File::Fetch->new( uri => $url ); + + msg( loc("Fetching: '%1'", $url), $verbose ); + + my $res = do { + my $tempdir = File::Temp::tempdir(); + my $where = $ff->fetch( to => $tempdir ); + + unless( $where ) { + error( loc( "Fetching report for '%1' failed: %2", + $url, $ff->error ) ); + return; + } + + my $fh = OPEN_FILE->( $where ); + + do { local $/; <$fh> }; + }; + + my ($aref) = eval { Parse::CPAN::Meta::Load( $res ) }; + + if( $@ ) { + error(loc("Error reading result: %1", $@)); + return; + }; + + my $dist = $mod->package_name .'-'. $mod->package_version; + my $details = TESTERS_DETAILS_URL->($mod->package_name); + + my @rv; + for my $href ( @$aref ) { + next unless $all or defined $href->{'distversion'} && + $href->{'distversion'} eq $dist; + + $href->{'details'} = $details; + + ### backwards compatibility :( + $href->{'dist'} ||= $href->{'distversion'}; + $href->{'grade'} ||= $href->{'action'} || $href->{'status'}; + + push @rv, $href; + } + + return @rv if @rv; + return; +} + +=pod + +=head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, verbose => BOOL, force => BOOL]); + +This function sends a testers report to C<cpan-testers@perl.org> for a +particular distribution. +It returns true on success, and false on failure. + +It takes the following options: + +=over 4 + +=item module + +The module object of this particular distribution + +=item buffer + +The output buffer from the 'make/make test' process + +=item failed + +Boolean indicating if the 'make/make test' went wrong + +=item save + +Boolean indicating if the report should be saved locally instead of +mailed out. If provided, this function will return the location the +report was saved to, rather than a simple boolean 'TRUE'. + +Defaults to false. + +=item address + +The email address to mail the report for. You should never need to +override this, but it might be useful for debugging purposes. + +Defaults to C<cpan-testers@perl.org>. + +=item verbose + +Boolean indicating on whether or not to be verbose. + +Defaults to your configuration settings + +=item force + +Boolean indicating whether to force the sending, even if the max +amount of reports for fails have already been reached, or if you +may already have sent it before. + +Defaults to your configuration settings + +=back + +=cut + +sub _send_report { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + ### do you even /have/ test::reporter? ### + unless( $self->_have_send_report_modules(verbose => 1) ) { + error( loc( "You don't have '%1' (or modules required by '%2') ". + "installed, you cannot report test results.", + 'Test::Reporter', 'Test::Reporter' ) ); + return; + } + + ### check arguments ### + my ($buffer, $failed, $mod, $verbose, $force, $address, $save, + $tests_skipped ); + my $tmpl = { + module => { required => 1, store => \$mod, allow => IS_MODOBJ }, + buffer => { required => 1, store => \$buffer }, + failed => { required => 1, store => \$failed }, + address => { default => CPAN_TESTERS_EMAIL, store => \$address }, + save => { default => 0, store => \$save }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + force => { default => $conf->get_conf('force'), + store => \$force }, + tests_skipped + => { default => 0, store => \$tests_skipped }, + }; + + check( $tmpl, \%hash ) or return; + + ### get the data to fill the email with ### + my $name = $mod->module; + my $dist = $mod->package_name . '-' . $mod->package_version; + my $author = $mod->author->author; + my $email = $mod->author->email || CPAN_MAIL_ACCOUNT->( $author ); + my $cp_conf = $conf->get_conf('cpantest') || ''; + my $int_ver = $CPANPLUS::Internals::VERSION; + my $cb = $mod->parent; + + + ### will be 'fetch', 'make', 'test', 'install', etc ### + my $stage = TEST_FAIL_STAGE->($buffer); + + ### determine the grade now ### + + my $grade; + ### check if this is a platform specific module ### + ### if we failed the test, there may be reasons why + ### an 'NA' might have to be insted + GRADE: { if ( $failed ) { + + + ### XXX duplicated logic between this block + ### and REPORTED_LOADED_PREREQS :( + + ### figure out if the prereqs are on CPAN at all + ### -- if not, send NA grade + ### Also, if our version of prereqs is too low, + ### -- send NA grade. + ### This is to address bug: #25327: do not count + ### as FAIL modules where prereqs are not filled + { my $prq = $mod->status->prereqs || {}; + + while( my($prq_name,$prq_ver) = each %$prq ) { + my $obj = $cb->module_tree( $prq_name ); + my $sub = CPANPLUS::Module->can( + 'module_is_supplied_with_perl_core' ); + + ### if we can't find the module and it's not supplied with core. + ### this addresses: #32064: NA reports generated for failing + ### tests where core prereqs are specified + ### Note that due to a bug in Module::CoreList, in some released + ### version of perl (5.8.6+ and 5.9.2-4 at the time of writing) + ### 'Config' is not recognized as a core module. See this bug: + ### http://rt.cpan.org/Ticket/Display.html?id=32155 + if( !$obj and !$sub->( $prq_name ) ) { + msg(loc( "Prerequisite '%1' for '%2' could not be obtained". + " from CPAN -- sending N/A grade", + $prq_name, $name ), $verbose ); + + $grade = GRADE_NA; + last GRADE; + } + + if ( !$obj ) { + my $vcore = $sub->( $prq_name ); + if ( $cb->_vcmp( $prq_ver, $vcore ) > 0 ) { + msg(loc( "Version of core module '%1' ('%2') is too low for ". + "'%3' (needs '%4') -- sending N/A grade", + $prq_name, $vcore, + $name, $prq_ver ), $verbose ); + + $grade = GRADE_NA; + last GRADE; + } + } + + if( $obj and $cb->_vcmp( $prq_ver, $obj->installed_version ) > 0 ) { + msg(loc( "Installed version of '%1' ('%2') is too low for ". + "'%3' (needs '%4') -- sending N/A grade", + $prq_name, $obj->installed_version, + $name, $prq_ver ), $verbose ); + + $grade = GRADE_NA; + last GRADE; + } + } + } + + unless( RELEVANT_TEST_RESULT->($mod) ) { + msg(loc( + "'%1' is a platform specific module, and the test results on". + " your platform are not relevant --sending N/A grade.", + $name), $verbose); + + $grade = GRADE_NA; + + } elsif ( UNSUPPORTED_OS->( $buffer ) ) { + msg(loc( + "'%1' is a platform specific module, and the test results on". + " your platform are not relevant --sending N/A grade.", + $name), $verbose); + + $grade = GRADE_NA; + + ### you dont have a high enough perl version? + } elsif ( PERL_VERSION_TOO_LOW->( $buffer ) ) { + msg(loc("'%1' requires a higher version of perl than your current ". + "version -- sending N/A grade.", $name), $verbose); + + $grade = GRADE_NA; + + ### perhaps where were no tests... + ### see if the thing even had tests ### + } elsif ( NO_TESTS_DEFINED->( $buffer ) ) { + $grade = GRADE_UNKNOWN; + ### failures in PL or make/build stage are now considered UNKNOWN + } elsif ( $stage !~ /\btest\b/ ) { + + $grade = GRADE_UNKNOWN + + } else { + + $grade = GRADE_FAIL; + } + + ### if we got here, it didn't fail and tests were present.. so a PASS + ### is in order + } else { + $grade = GRADE_PASS; + } } + + ### so an error occurred, let's see what stage it went wrong in ### + + ### the header -- always include so the CPANPLUS version is apparent + my $message = REPORT_MESSAGE_HEADER->( $int_ver, $author ); + + if( $grade eq GRADE_FAIL or $grade eq GRADE_UNKNOWN) { + + ### return if one or more missing external libraries + if( my @missing = MISSING_EXTLIBS_LIST->($buffer) ) { + msg(loc("Not sending test report - " . + "external libraries not pre-installed")); + return 1; + } + + ### return if we're only supposed to report make_test failures ### + return 1 if $cp_conf =~ /\bmaketest_only\b/i + and ($stage !~ /\btest\b/); + + ### the bit where we inform what went wrong + $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer ); + + ### was it missing prereqs? ### + if( my @missing = MISSING_PREREQS_LIST->($buffer) ) { + if(!$self->_verify_missing_prereqs( + module => $mod, + missing => \@missing + )) { + msg(loc("Not sending test report - " . + "bogus missing prerequisites report")); + return 1; + } + $message .= REPORT_MISSING_PREREQS->($author,$email,@missing); + } + + ### was it missing test files? ### + if( NO_TESTS_DEFINED->($buffer) ) { + $message .= REPORT_MISSING_TESTS->(); + } + + ### add a list of what modules have been loaded of your prereqs list + $message .= REPORT_LOADED_PREREQS->($mod); + + ### add a list of versions of toolchain modules + $message .= REPORT_TOOLCHAIN_VERSIONS->($mod); + + ### the footer + $message .= REPORT_MESSAGE_FOOTER->(); + + ### it may be another grade than fail/unknown.. may be worth noting + ### that tests got skipped, since the buffer is not added in + } elsif ( $tests_skipped ) { + $message .= REPORT_TESTS_SKIPPED->(); + } elsif( $grade eq GRADE_NA) { + + ### the bit where we inform what went wrong + $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer ); + + ### the footer + $message .= REPORT_MESSAGE_FOOTER->(); + + } + + msg( loc("Sending test report for '%1'", $dist), $verbose); + + ### reporter object ### + my $reporter = do { + my $args = $conf->get_conf('cpantest_reporter_args') || {}; + + unless( UNIVERSAL::isa( $args, 'HASH' ) ) { + error(loc("'%1' must be a hashref, ignoring...", + 'cpantest_reporter_args')); + $args = {}; + } + + Test::Reporter->new( + grade => $grade, + distribution => $dist, + via => "CPANPLUS $int_ver", + timeout => $conf->get_conf('timeout') || 60, + debug => $conf->get_conf('debug'), + %$args, + ); + }; + + ### set a custom mx, if requested + $reporter->mx( [ $conf->get_conf('cpantest_mx') ] ) + if $conf->get_conf('cpantest_mx'); + + ### set the from address ### + $reporter->from( $conf->get_conf('email') ) + if $conf->get_conf('email') !~ /\@example\.\w+$/i; + + ### give the user a chance to programattically alter the message + $message = $self->_callbacks->munge_test_report->($mod, $message, $grade); + + ### add the body if we have any ### + $reporter->comments( $message ) if defined $message && length $message; + + ### do a callback to ask if we should send the report + unless ($self->_callbacks->send_test_report->($mod, $grade)) { + msg(loc("Ok, not sending test report")); + return 1; + } + + ### do a callback to ask if we should edit the report + if ($self->_callbacks->edit_test_report->($mod, $grade)) { + ### test::reporter 1.20 and lower don't have a way to set + ### the preferred editor with a method call, but it does + ### respect your env variable, so let's set that. + local $ENV{VISUAL} = $conf->get_program('editor') + if $conf->get_program('editor'); + + $reporter->edit_comments; + } + + ### allow to be overridden, but default to the normal address ### + $reporter->address( $address ); + + ### should we save it locally? ### + if( $save ) { + if( my $file = $reporter->write() ) { + msg(loc("Successfully wrote report for '%1' to '%2'", + $dist, $file), $verbose); + return $file; + + } else { + error(loc("Failed to write report for '%1'", $dist)); + return; + } + + ### XXX should we do an 'already sent' check? ### + ### something broke :( ### + } + else { + my $status; + eval { + $status = $reporter->send(); + }; + if ( $@ ) { + error(loc("Could not send '%1' report for '%2': %3", + $grade, $dist, $@)); + return; + } + if ( $status ) { + msg(loc("Successfully sent '%1' report for '%2'", $grade, $dist), + $verbose); + return 1; + } + error(loc("Could not send '%1' report for '%2': %3", + $grade, $dist, $reporter->errstr)); + return; + } +} + +sub _verify_missing_prereqs { + my $self = shift; + my %hash = @_; + + ### check arguments ### + my ($mod, $missing); + my $tmpl = { + module => { required => 1, store => \$mod }, + missing => { required => 1, store => \$missing }, + }; + + check( $tmpl, \%hash ) or return; + + + my %missing = map {$_ => 1} @$missing; + my $conf = $self->configure_object; + my $extract = $mod->status->extract; + + ### Read pre-requisites from Makefile.PL or Build.PL (if there is one), + ### of the form: + ### 'PREREQ_PM' => { + ### 'Compress::Zlib' => '1.20', + ### 'Test::More' => 0, + ### }, + ### Build.PL uses 'requires' instead of 'PREREQ_PM'. + + my @search; + push @search, ($extract ? MAKEFILE_PL->( $extract ) : MAKEFILE_PL->()); + push @search, ($extract ? BUILD_PL->( $extract ) : BUILD_PL->()); + + for my $file ( @search ) { + if(-e $file and -r $file) { + my $slurp = $self->_get_file_contents(file => $file); + my ($prereq) = + ($slurp =~ /'?(?:PREREQ_PM|requires)'?\s*=>\s*{(.*?)}/s); + my @prereq = + ($prereq =~ /'?([\w\:]+)'?\s*=>\s*'?\d[\d\.\-\_]*'?/sg); + delete $missing{$_} for(@prereq); + } + } + + return 1 if(keys %missing); # There ARE missing prerequisites + return; # All prerequisites accounted for +} + +1; + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Search.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Search.pm new file mode 100755 index 00000000000..63c4da64d92 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Search.pm @@ -0,0 +1,363 @@ +package CPANPLUS::Internals::Search; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Module; +use CPANPLUS::Module::Author; + +use File::Find; +use File::Spec; + +use Params::Check qw[check allow]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Search + +=head1 SYNOPSIS + + my $aref = $cpan->_search_module_tree( + type => 'package', + allow => [qr/DBI/], + ); + + my $aref = $cpan->_search_author_tree( + type => 'cpanid', + data => \@old_results, + verbose => 1, + allow => [qw|KANE AUTRIJUS|], + ); + + my $aref = $cpan->_all_installed( ); + +=head1 DESCRIPTION + +The functions in this module are designed to find module(objects) +based on certain criteria and return them. + +=head1 METHODS + +=head2 _search_module_tree( type => TYPE, allow => \@regexes, [data => \@previous_results ] ) + +Searches the moduletree for module objects matching the criteria you +specify. Returns an array ref of module objects on success, and false +on failure. + +It takes the following arguments: + +=over 4 + +=item type + +This can be any of the accessors for the C<CPANPLUS::Module> objects. +This is a required argument. + +=item allow + +A set of rules, or more precisely, a list of regexes (via C<qr//> or +plain strings), that the C<type> must adhere too. You can specify as +many as you like, and it will be treated as an C<OR> search. +For an C<AND> search, see the C<data> argument. + +This is a required argument. + +=item data + +An arrayref of previous search results. This is the way to do an C<AND> +search -- C<_search_module_tree> will only search the module objects +specified in C<data> if provided, rather than the moduletree itself. + +=back + +=cut + +# Although the Params::Check solution is more graceful, it is WAY too slow. +# +# This sample script: +# +# use CPANPLUS::Backend; +# my $cb = new CPANPLUS::Backend; +# $cb->module_tree; +# my @list = $cb->search( type => 'module', allow => [qr/^Acme/] ); +# print $_->module, $/ for @list; +# +# Produced the following output using Dprof WITH params::check code +# +# Total Elapsed Time = 3.670024 Seconds +# User+System Time = 3.390373 Seconds +# Exclusive Times +# %Time ExclSec CumulS #Calls sec/call Csec/c Name +# 88.7 3.008 4.463 20610 0.0001 0.0002 Params::Check::check +# 47.4 1.610 1.610 1 1.6100 1.6100 Storable::net_pstore +# 25.6 0.869 0.737 20491 0.0000 0.0000 Locale::Maketext::Simple::_default +# _gettext +# 23.2 0.789 0.524 40976 0.0000 0.0000 Params::Check::_who_was_it +# 23.2 0.789 0.677 20610 0.0000 0.0000 Params::Check::_sanity_check +# 19.7 0.670 0.670 1 0.6700 0.6700 Storable::pretrieve +# 14.1 0.480 0.211 41350 0.0000 0.0000 Params::Check::_convert_case +# 11.5 0.390 0.256 20610 0.0000 0.0000 Params::Check::_hashdefs +# 11.5 0.390 0.255 20697 0.0000 0.0000 Params::Check::_listreqs +# 11.4 0.389 0.177 20653 0.0000 0.0000 Params::Check::_canon_key +# 10.9 0.370 0.356 20697 0.0000 0.0000 Params::Check::_hasreq +# 8.02 0.272 4.750 1 0.2723 4.7501 CPANPLUS::Internals::Search::_sear +# ch_module_tree +# 6.49 0.220 0.086 20653 0.0000 0.0000 Params::Check::_iskey +# 6.19 0.210 0.077 20488 0.0000 0.0000 Params::Check::_store_error +# 5.01 0.170 0.036 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__ +# +# and this output /without/ +# +# Total Elapsed Time = 2.803426 Seconds +# User+System Time = 2.493426 Seconds +# Exclusive Times +# %Time ExclSec CumulS #Calls sec/call Csec/c Name +# 56.9 1.420 1.420 1 1.4200 1.4200 Storable::net_pstore +# 25.6 0.640 0.640 1 0.6400 0.6400 Storable::pretrieve +# 9.22 0.230 0.096 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__ +# 7.06 0.176 0.272 1 0.1762 0.2719 CPANPLUS::Internals::Search::_sear +# ch_module_tree +# 3.21 0.080 0.098 10 0.0080 0.0098 IPC::Cmd::BEGIN +# 1.60 0.040 0.205 13 0.0031 0.0158 CPANPLUS::Internals::BEGIN +# 1.20 0.030 0.030 29 0.0010 0.0010 vars::BEGIN +# 1.20 0.030 0.117 10 0.0030 0.0117 Log::Message::BEGIN +# 1.20 0.030 0.029 9 0.0033 0.0033 CPANPLUS::Internals::Search::BEGIN +# 0.80 0.020 0.020 5 0.0040 0.0040 DynaLoader::dl_load_file +# 0.80 0.020 0.127 10 0.0020 0.0127 CPANPLUS::Module::BEGIN +# 0.80 0.020 0.389 2 0.0099 0.1944 main::BEGIN +# 0.80 0.020 0.359 12 0.0017 0.0299 CPANPLUS::Backend::BEGIN +# 0.40 0.010 0.010 30 0.0003 0.0003 Config::FETCH +# 0.40 0.010 0.010 18 0.0006 0.0005 Locale::Maketext::Simple::load_loc +# + +sub _search_module_tree { + + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($mods,$list,$verbose,$type); + my $tmpl = { + data => { default => [], + strict_type=> 1, store => \$mods }, + allow => { required => 1, default => [ ], strict_type => 1, + store => \$list }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + type => { required => 1, allow => [CPANPLUS::Module->accessors()], + store => \$type }, + }; + + my $args = do { + ### don't check the template for sanity + ### -- we know it's good and saves a lot of performance + local $Params::Check::SANITY_CHECK_TEMPLATE = 0; + + check( $tmpl, \%hash ); + } or return; + + ### a list of module objects was supplied + if( @$mods ) { + local $Params::Check::VERBOSE = 0; + + my @rv; + for my $mod (@$mods) { + #push @rv, $mod if check( + # { $type => { allow => $list } }, + # { $type => $mod->$type() } + # ); + push @rv, $mod if allow( $mod->$type() => $list ); + + } + return \@rv; + + } else { + my @rv = $self->_source_search_module_tree( + allow => $list, + type => $type, + ); + return \@rv; + } +} + +=pod + +=head2 _search_author_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] ) + +Searches the authortree for author objects matching the criteria you +specify. Returns an array ref of author objects on success, and false +on failure. + +It takes the following arguments: + +=over 4 + +=item type + +This can be any of the accessors for the C<CPANPLUS::Module::Author> +objects. This is a required argument. + +=item allow + + +A set of rules, or more precisely, a list of regexes (via C<qr//> or +plain strings), that the C<type> must adhere too. You can specify as +many as you like, and it will be treated as an C<OR> search. +For an C<AND> search, see the C<data> argument. + +This is a required argument. + +=item data + +An arrayref of previous search results. This is the way to do an C<and> +search -- C<_search_author_tree> will only search the author objects +specified in C<data> if provided, rather than the authortree itself. + +=back + +=cut + +sub _search_author_tree { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($authors,$list,$verbose,$type); + my $tmpl = { + data => { default => [], + strict_type=> 1, store => \$authors }, + allow => { required => 1, default => [ ], strict_type => 1, + store => \$list }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + type => { required => 1, allow => [CPANPLUS::Module::Author->accessors()], + store => \$type }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + if( @$authors ) { + local $Params::Check::VERBOSE = 0; + + my @rv; + for my $auth (@$authors) { + #push @rv, $auth if check( + # { $type => { allow => $list } }, + # { $type => $auth->$type } + # ); + push @rv, $auth if allow( $auth->$type() => $list ); + } + return \@rv; + } else { + my @rv = $self->_source_search_author_tree( + allow => $list, + type => $type, + ); + return \@rv; + } +} + +=pod + +=head2 _all_installed() + +This function returns an array ref of module objects of modules that +are installed on this system. + +=cut + +sub _all_installed { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + ### File::Find uses follow_skip => 1 by default, which doesn't die + ### on duplicates, unless they are directories or symlinks. + ### Ticket #29796 shows this code dying on Alien::WxWidgets, + ### which uses symlinks. + ### File::Find doc says to use follow_skip => 2 to ignore duplicates + ### so this will stop it from dying. + my %find_args = ( follow_skip => 2 ); + + ### File::Find uses lstat, which quietly becomes stat on win32 + ### it then uses -l _ which is not allowed by the statbuffer because + ### you did a stat, not an lstat (duh!). so don't tell win32 to + ### follow symlinks, as that will break badly + $find_args{'follow_fast'} = 1 unless ON_WIN32; + + ### never use the @INC hooks to find installed versions of + ### modules -- they're just there in case they're not on the + ### perl install, but the user shouldn't trust them for *other* + ### modules! + ### XXX CPANPLUS::inc is now obsolete, remove the calls + #local @INC = CPANPLUS::inc->original_inc; + + my %seen; my @rv; + for my $dir (@INC ) { + next if $dir eq '.'; + + ### not a directory after all + ### may be coderef or some such + next unless -d $dir; + + ### make sure to clean up the directories just in case, + ### as we're making assumptions about the length + ### This solves rt.cpan issue #19738 + + ### John M. notes: On VMS cannonpath can not currently handle + ### the $dir values that are in UNIX format. + $dir = File::Spec->canonpath( $dir ) unless ON_VMS; + + ### have to use F::S::Unix on VMS, or things will break + my $file_spec = ON_VMS ? 'File::Spec::Unix' : 'File::Spec'; + + ### XXX in some cases File::Find can actually die! + ### so be safe and wrap it in an eval. + eval { File::Find::find( + { %find_args, + wanted => sub { + + return unless /\.pm$/i; + my $mod = $File::Find::name; + + ### make sure it's in Unix format, as it + ### may be in VMS format on VMS; + $mod = VMS::Filespec::unixify( $mod ) if ON_VMS; + + $mod = substr($mod, length($dir) + 1, -3); + $mod = join '::', $file_spec->splitdir($mod); + + return if $seen{$mod}++; + + my $modobj = $self->module_tree($mod); + + ### seperate return, a list context return with one '' + ### in it, is also true! + return unless $modobj; + + push @rv, $modobj; + }, + }, $dir + ) }; + + ### report the error if file::find died + error(loc("Error finding installed files in '%1': %2", $dir, $@)) if $@; + } + + return \@rv; +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source.pm new file mode 100755 index 00000000000..54e9d710cfd --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source.pm @@ -0,0 +1,1417 @@ +package CPANPLUS::Internals::Source; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Module; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author; +use CPANPLUS::Internals::Constants; + +use File::Fetch; +use Archive::Extract; + +use IPC::Cmd qw[can_run]; +use File::Temp qw[tempdir]; +use File::Basename qw[dirname]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +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 + _standard_trees_completed _custom_trees_completed + _add_module_object _add_author_object _save_state + ] + ) { + no strict 'refs'; + *$sub = sub { + my $self = shift; + my $class = ref $self || $self; + + require Carp; + Carp::croak( loc( "Class %1 must implement method '%2'", + $class, $sub ) ); + } + } +} + +{ + my $recurse; # flag to prevent recursive calls to *_tree functions + + ### lazy loading of module tree + sub _module_tree { + my $self = $_[0]; + + unless ($self->_mtree or $recurse++ > 0) { + my $uptodate = $self->_check_trees( @_[1..$#_] ); + $self->_build_trees(uptodate => $uptodate); + } + + $recurse--; + return $self->_mtree; + } + + ### lazy loading of author tree + sub _author_tree { + my $self = $_[0]; + + unless ($self->_atree or $recurse++ > 0) { + my $uptodate = $self->_check_trees( @_[1..$#_] ); + $self->_build_trees(uptodate => $uptodate); + } + + $recurse--; + return $self->_atree; + } + +} + + +=pod + +=head1 NAME + +CPANPLUS::Internals::Source + +=head1 SYNOPSIS + + ### lazy load author/module trees ### + + $cb->_author_tree; + $cb->_module_tree; + +=head1 DESCRIPTION + +CPANPLUS::Internals::Source controls the updating of source files and +the parsing of them into usable module/author trees to be used by +C<CPANPLUS>. + +Functions exist to check if source files are still C<good to use> as +well as update them, and then parse them. + +The flow looks like this: + + $cb->_author_tree || $cb->_module_tree + $cb->_check_trees + $cb->__check_uptodate + $cb->_update_source + $cb->__update_custom_module_sources + $cb->__update_custom_module_source + $cb->_build_trees + ### engine methods + { $cb->_init_trees; + $cb->_standard_trees_completed + $cb->_custom_trees_completed + } + $cb->__create_author_tree + ### engine methods + { $cb->_add_author_object } + $cb->__create_module_tree + $cb->__create_dslip_tree + ### engine methods + { $cb->_add_module_object } + $cb->__create_custom_module_entries + + $cb->_dslip_defs + +=head1 METHODS + +=cut + +=pod + +=head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] ) + +This method rebuilds the author- and module-trees from source. + +It takes the following arguments: + +=over 4 + +=item uptodate + +Indicates whether any on disk caches are still ok to use. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=item use_stored + +A boolean flag indicating whether or not it is ok to use previously +stored trees. Defaults to true. + +=back + +Returns a boolean indicating success. + +=cut + +### (re)build the trees ### +sub _build_trees { + my ($self, %hash) = @_; + my $conf = $self->configure_object; + + my($path,$uptodate,$use_stored,$verbose); + my $tmpl = { + path => { default => $conf->get_conf('base'), store => \$path }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + uptodate => { required => 1, store => \$uptodate }, + use_stored => { default => 1, store => \$use_stored }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + $self->_init_trees( + path => $path, + uptodate => $uptodate, + verbose => $verbose, + use_stored => $use_stored, + ) or do { + error( loc("Could not initialize trees" ) ); + return; + }; + + ### return if we weren't able to build the trees ### + return unless $self->_mtree && $self->_atree; + + ### did we get everything from a stored state? if not, + ### process them now. + if( not $self->_standard_trees_completed ) { + + ### first, prep the author tree + $self->__create_author_tree( + uptodate => $uptodate, + path => $path, + verbose => $verbose, + ) or return; + + ### and now the module tree + $self->_create_mod_tree( + uptodate => $uptodate, + path => $path, + verbose => $verbose, + ) or return; + } + + ### XXX unpleasant hack. since custom sources uses ->parse_module, we + ### already have a special module object with extra meta data. that + ### doesn't gelwell with the sqlite storage engine. So, we check 'normal' + ### trees from seperate trees, so the engine can treat them differently. + ### Effectively this means that with the SQLite engine, for now, custom + ### sources are continuously reparsed =/ -kane + if( not $self->_custom_trees_completed ) { + + ### update them if the other sources are also deemed out of date + if( $conf->get_conf('enable_custom_sources') ) { + $self->__update_custom_module_sources( verbose => $verbose ) + or error(loc("Could not update custom module sources")); + } + + ### add custom sources here if enabled + if( $conf->get_conf('enable_custom_sources') ) { + $self->__create_custom_module_entries( verbose => $verbose ) + or error(loc("Could not create custom module entries")); + } + } + + ### give the source engine a chance to wrap up creation + $self->_finalize_trees( + path => $path, + uptodate => $uptodate, + verbose => $verbose, + use_stored => $use_stored, + ) or do { + error(loc( "Could not finalize trees" )); + return; + }; + + ### still necessary? can only run one instance now ### + ### will probably stay that way --kane +# my $id = $self->_store_id( $self ); +# +# unless ( $id == $self->_id ) { +# error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) ); +# } + + return 1; +} + +=pod + +=head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] ) + +Retrieve source files and return a boolean indicating whether or not +the source files are up to date. + +Takes several arguments: + +=over 4 + +=item update_source + +A flag to force re-fetching of the source files, even +if they are still up to date. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +=cut + +### retrieve source files, and returns a boolean indicating if it's up to date +sub _check_trees { + my ($self, %hash) = @_; + my $conf = $self->configure_object; + + my $update_source; + my $verbose; + my $path; + + my $tmpl = { + path => { default => $conf->get_conf('base'), + store => \$path + }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose + }, + update_source => { default => 0, store => \$update_source }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### if the user never wants to update their source without explicitly + ### telling us, shortcircuit here + return 1 if $conf->get_conf('no_update') && !$update_source; + + ### a check to see if our source files are still up to date ### + msg( loc("Checking if source files are up to date"), $verbose ); + + my $uptodate = 1; # default return value + + for my $name (qw[auth dslip mod]) { + for my $file ( $conf->_get_source( $name ) ) { + $self->__check_uptodate( + file => File::Spec->catfile( $path, $file ), + name => $name, + update_source => $update_source, + verbose => $verbose, + ) or $uptodate = 0; + } + } + + ### if we're explicitly asked to update the sources, or if the + ### standard source files are out of date, update the custom sources + ### as well + ### RT #47820: Don't try to update custom sources if they are disabled + ### in the configuration. + $self->__update_custom_module_sources( verbose => $verbose ) + if $conf->get_conf('enable_custom_sources') and ( $update_source or !$uptodate ); + + return $uptodate; +} + +=pod + +=head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] ) + +C<__check_uptodate> checks if a given source file is still up-to-date +and if not, or when C<update_source> is true, will re-fetch the source +file. + +Takes the following arguments: + +=over 4 + +=item file + +The source file to check. + +=item name + +The internal shortcut name for the source file (used for config +lookups). + +=item update_source + +Flag to force updating of sourcefiles regardless. + +=item verbose + +Boolean to indicate whether to be verbose or not. + +=back + +Returns a boolean value indicating whether the current files are up +to date or not. + +=cut + +### this method checks whether or not the source files we are using are still up to date +sub __check_uptodate { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + file => { required => 1 }, + name => { required => 1 }, + update_source => { default => 0 }, + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $flag; + unless ( -e $args->{'file'} && ( + ( stat $args->{'file'} )[9] + + $conf->_get_source('update') ) + > time ) { + $flag = 1; + } + + if ( $flag or $args->{'update_source'} ) { + + if ( $self->_update_source( name => $args->{'name'} ) ) { + return 0; # return 0 so 'uptodate' will be set to 0, meaning no + # use of previously stored hashrefs! + } else { + msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} ); + return 1; + } + + } else { + return 1; + } +} + +=pod + +=head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] ) + +This method does the actual fetching of source files. + +It takes the following arguments: + +=over 4 + +=item name + +The internal shortcut name for the source file (used for config +lookups). + +=item path + +The full path where to write the files. + +=item verbose + +Boolean to indicate whether to be verbose or not. + +=back + +Returns a boolean to indicate success. + +=cut + +### this sub fetches new source files ### +sub _update_source { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + my $verbose; + my $tmpl = { + name => { required => 1 }, + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + + my $path = $args->{path}; + { ### this could use a clean up - Kane + ### no worries about the / -> we get it from the _ftp configuration, so + ### it's not platform dependant. -kane + my ($dir, $file) = $conf->_get_mirror( $args->{'name'} ) =~ m|(.+/)(.+)$|sg; + + msg( loc("Updating source file '%1'", $file), $verbose ); + + my $fake = CPANPLUS::Module::Fake->new( + module => $args->{'name'}, + path => $dir, + package => $file, + _id => $self->_id, + ); + + ### can't use $fake->fetch here, since ->parent won't work -- + ### the sources haven't been saved yet + my $rv = $self->_fetch( + module => $fake, + fetchdir => $path, + force => 1, + ); + + + unless ($rv) { + error( loc("Couldn't fetch '%1'", $file) ); + return; + } + + $self->_update_timestamp( file => File::Spec->catfile($path, $file) ); + } + + return 1; +} + +=pod + +=head2 $cb->__create_author_tree([path => $path, uptodate => BOOL, verbose => BOOL]) + +This method opens a source files and parses its contents into a +searchable author-tree or restores a file-cached version of a +previous parse, if the sources are uptodate and the file-cache exists. + +It takes the following arguments: + +=over 4 + +=item uptodate + +A flag indicating whether the file-cache is uptodate or not. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns a tree on success, false on failure. + +=cut + +sub __create_author_tree { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $file = File::Spec->catfile( + $args->{path}, + $conf->_get_source('auth') + ); + + msg(loc("Rebuilding author tree, this might take a while"), + $args->{verbose}); + + ### extract the file ### + my $ae = Archive::Extract->new( archive => $file ) or return; + my $out = STRIP_GZ_SUFFIX->($file); + + ### make sure to set the PREFER_BIN flag if desired ### + { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); + $ae->extract( to => $out ) or return; + } + + my $cont = $self->_get_file_contents( file => $out ) or return; + + ### don't need it anymore ### + unlink $out; + + for ( split /\n/, $cont ) { + my($id, $name, $email) = m/^alias \s+ + (\S+) \s+ + "\s* ([^\"\<]+?) \s* <(.+)> \s*" + /x; + + $self->_add_author_object( + author => $name, #authors name + email => $email, #authors email address + cpanid => $id, #authors CPAN ID + ) or error( loc("Could not add author '%1'", $name ) ); + + } + + return $self->_atree; + +} #__create_author_tree + +=pod + +=head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL]) + +This method opens a source files and parses its contents into a +searchable module-tree or restores a file-cached version of a +previous parse, if the sources are uptodate and the file-cache exists. + +It takes the following arguments: + +=over 4 + +=item uptodate + +A flag indicating whether the file-cache is up-to-date or not. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns a tree on success, false on failure. + +=cut + +### this builds a hash reference with the structure of the cpan module tree ### +sub _create_mod_tree { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return undef; + my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod')); + + msg(loc("Rebuilding module tree, this might take a while"), + $args->{verbose}); + + + my $dslip_tree = $self->__create_dslip_tree( %$args ); + + ### extract the file ### + my $ae = Archive::Extract->new( archive => $file ) or return; + my $out = STRIP_GZ_SUFFIX->($file); + + ### make sure to set the PREFER_BIN flag if desired ### + { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); + $ae->extract( to => $out ) or return; + } + + my $content = $self->_get_file_contents( file => $out ) or return; + my $lines = $content =~ tr/\n/\n/; + + ### don't need it anymore ### + unlink $out; + + my($past_header, $count); + 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*$| ) { + unless( $count ) { + error(loc("Could not determine line count from %1", $file)); + 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+)/; + if( $count ) { + if( $lines < $count ) { + error(loc("Expected to read at least %1 lines, but %2 ". + "contains only %3 lines!", + $count, $file, $lines )); + return; + } + } + ### still in the header, keep moving + next; + } + + ### skip empty lines ### + next unless /\S/; + chomp; + + my @data = split /\s+/; + + ### filter out the author and filename as well ### + ### authors can apparently have digits in their names, + ### and dirs can have dots... blah! + my ($author, $package) = $data[2] =~ + m| (?:[A-Z\d-]/)? + (?:[A-Z\d-]{2}/)? + ([A-Z\d-]+) (?:/[\S]+)?/ + ([^/]+)$ + |xsg; + + ### remove file name from the path + $data[2] =~ s|/[^/]+$||; + + my $aobj = $self->author_tree($author); + unless( $aobj ) { + error( loc( "No such author '%1' -- can't make module object " . + "'%2' that is supposed to belong to this author", + $author, $data[0] ) ); + next; + } + + ### adding the dslip info + ### probably can use some optimization + my $dslip; + for my $item ( qw[ statd stats statl stati statp ] ) { + ### checking if there's an entry in the dslip info before + ### catting it on. appeasing warnings this way + $dslip .= $dslip_tree->{ $data[0] }->{$item} + ? $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 + ### fake author/module objects as well. + + ### callback to store the individual object + $self->_add_module_object( + module => $data[0], # full module name + version => ($data[1] eq 'undef' # version number + ? '0.0' + : $data[1]), + path => File::Spec::Unix->catfile( + $conf->_get_mirror('base'), + $data[2], + ), # extended path on the cpan mirror, + # like /A/AB/ABIGAIL + comment => $data[3], # comment on the module + author => $aobj, + package => $package, # package name, like + # 'foo-bar-baz-1.03.tar.gz' + description => $dslip_tree->{ $data[0] }->{'description'}, + dslip => $dslip, + mtime => '', + ) or error( loc( "Could not add module '%1'", $data[0] ) ); + + } #for + + return $self->_mtree; + +} #_create_mod_tree + +=pod + +=head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL]) + +This method opens a source files and parses its contents into a +searchable dslip-tree or restores a file-cached version of a +previous parse, if the sources are uptodate and the file-cache exists. + +It takes the following arguments: + +=over 4 + +=item uptodate + +A flag indicating whether the file-cache is uptodate or not. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns a tree on success, false on failure. + +=cut + +sub __create_dslip_tree { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + my $tmpl = { + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### get the file name of the source ### + my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip')); + + ### extract the file ### + my $ae = Archive::Extract->new( archive => $file ) or return; + my $out = STRIP_GZ_SUFFIX->($file); + + ### make sure to set the PREFER_BIN flag if desired ### + { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); + $ae->extract( to => $out ) or return; + } + + my $in = $self->_get_file_contents( file => $out ) or return; + + ### don't need it anymore ### + unlink $out; + + + ### get rid of the comments and the code ### + ### need a smarter parser, some people have this in their dslip info: + # [ + # 'Statistics::LTU', + # 'R', + # 'd', + # 'p', + # 'O', + # '?', + # 'Implements Linear Threshold Units', + # ...skipping... + # "\x{c4}dd \x{fc}ml\x{e4}\x{fc}ts t\x{f6} \x{eb}v\x{eb}r\x{ff}th\x{ef}ng!", + # 'BENNIE', + # '11' + # ], + ### also, older versions say: + ### $cols = [....] + ### and newer versions say: + ### $CPANPLUS::Modulelist::cols = [...] + ### split '$cols' and '$data' into 2 variables ### + ### use this regex to make sure dslips with ';' in them don't cause + ### parser errors + my ($ds_one, $ds_two) = ($in =~ m|.+}\s+ + (\$(?:CPAN::Modulelist::)?cols.*?) + (\$(?:CPAN::Modulelist::)?data.*) + |sx); + + ### eval them into existence ### + ### still not too fond of this solution - kane ### + my ($cols, $data); + { #local $@; can't use this, it's buggy -kane + + $cols = eval $ds_one; + error( loc("Error in eval of dslip source files: %1", $@) ) if $@; + + $data = eval $ds_two; + error( loc("Error in eval of dslip source files: %1", $@) ) if $@; + + } + + my $tree = {}; + my $primary = "modid"; + + ### this comes from CPAN::Modulelist + ### which is in 03modlist.data.gz + for (@$data){ + my %hash; + @hash{@$cols} = @$_; + $tree->{$hash{$primary}} = \%hash; + } + + return $tree; + +} #__create_dslip_tree + +=pod + +=head2 $cb->_dslip_defs () + +This function returns the definition structure (ARRAYREF) of the +dslip tree. + +=cut + +### these are the definitions used for dslip info +### they shouldn't change over time.. so hardcoding them doesn't appear to +### be a problem. if it is, we need to parse 03modlist.data better to filter +### all this out. +### right now, this is just used to look up dslip info from a module +sub _dslip_defs { + my $self = shift; + + my $aref = [ + + # D + [ q|Development Stage|, { + i => loc('Idea, listed to gain consensus or as a placeholder'), + c => loc('under construction but pre-alpha (not yet released)'), + a => loc('Alpha testing'), + b => loc('Beta testing'), + R => loc('Released'), + M => loc('Mature (no rigorous definition)'), + S => loc('Standard, supplied with Perl 5'), + }], + + # S + [ q|Support Level|, { + m => loc('Mailing-list'), + d => loc('Developer'), + u => loc('Usenet newsgroup comp.lang.perl.modules'), + n => loc('None known, try comp.lang.perl.modules'), + a => loc('Abandoned; volunteers welcome to take over maintainance'), + }], + + # L + [ q|Language Used|, { + p => loc('Perl-only, no compiler needed, should be platform independent'), + c => loc('C and perl, a C compiler will be needed'), + h => loc('Hybrid, written in perl with optional C code, no compiler needed'), + '+' => loc('C++ and perl, a C++ compiler will be needed'), + o => loc('perl and another language other than C or C++'), + }], + + # I + [ q|Interface Style|, { + f => loc('plain Functions, no references used'), + h => loc('hybrid, object and function interfaces available'), + n => loc('no interface at all (huh?)'), + r => loc('some use of unblessed References or ties'), + O => loc('Object oriented using blessed references and/or inheritance'), + }], + + # P + [ q|Public License|, { + p => loc('Standard-Perl: user may choose between GPL and Artistic'), + g => loc('GPL: GNU General Public License'), + l => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'), + b => loc('BSD: The BSD License'), + a => loc('Artistic license alone'), + o => loc('other (but distribution allowed without restrictions)'), + }], + ]; + + return $aref; +} + +=head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] ); + +Adds a custom source index and updates it based on the provided URI. + +Returns the full path to the index file on success or false on failure. + +=cut + +sub _add_custom_module_source { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($verbose,$uri); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + uri => { required => 1, store => \$uri } + }; + + check( $tmpl, \%hash ) or return; + + ### what index file should we use on disk? + my $index = $self->__custom_module_source_index_file( uri => $uri ); + + ### already have it. + if( IS_FILE->( $index ) ) { + msg(loc("Source '%1' already added", $uri)); + return 1; + } + + ### do we need to create the targe dir? + { my $dir = dirname( $index ); + unless( IS_DIR->( $dir ) ) { + $self->_mkdir( dir => $dir ) or return + } + } + + ### write the file + my $fh = OPEN_FILE->( $index => '>' ) or do { + error(loc("Could not open index file for '%1'", $uri)); + return; + }; + + ### basically we 'touched' it. Check the return value, may be + ### important on win32 and similar OS, where there's file length + ### limits + close $fh or do { + error(loc("Could not write index file to disk for '%1'", $uri)); + return; + }; + + $self->__update_custom_module_source( + remote => $uri, + local => $index, + verbose => $verbose, + ) or do { + ### we faild to update it, we probably have an empty + ### possibly silly filename on disk now -- remove it + 1 while unlink $index; + return; + }; + + return $index; +} + +=head2 $index = $cb->__custom_module_source_index_file( uri => $uri ); + +Returns the full path to the encoded index file for C<$uri>, as used by +all C<custom module source> routines. + +=cut + +sub __custom_module_source_index_file { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($verbose,$uri); + my $tmpl = { + uri => { required => 1, store => \$uri } + }; + + check( $tmpl, \%hash ) or return; + + my $index = File::Spec->catfile( + $conf->get_conf('base'), + $conf->_get_build('custom_sources'), + $self->_uri_encode( uri => $uri ), + ); + + return $index; +} + +=head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] ); + +Removes a custom index file based on the URI provided. + +Returns the full path to the index file on success or false on failure. + +=cut + +sub _remove_custom_module_source { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($verbose,$uri); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + uri => { required => 1, store => \$uri } + }; + + check( $tmpl, \%hash ) or return; + + ### use uri => local, instead of the other way around + my %files = reverse $self->__list_custom_module_sources; + + ### On VMS the case of key to %files can be either exact or lower case + ### XXX abstract this lookup out? --kane + my $file = $files{ $uri }; + $file = $files{ lc $uri } if !defined($file) && ON_VMS; + + unless (defined $file) { + error(loc("No such custom source '%1'", $uri)); + return; + }; + + 1 while unlink $file; + + if( IS_FILE->( $file ) ) { + error(loc("Could not remove index file '%1' for custom source '%2'", + $file, $uri)); + return; + } + + msg(loc("Successfully removed index file for '%1'", $uri), $verbose); + + return $file; +} + +=head2 %files = $cb->__list_custom_module_sources + +This method scans the 'custom-sources' directory in your base directory +for additional sources to include in your module tree. + +Returns a list of key value pairs as follows: + + /full/path/to/source/file%3Fencoded => http://decoded/mirror/path + +=cut + +sub __list_custom_module_sources { + my $self = shift; + my $conf = $self->configure_object; + + my($verbose); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + my $dir = File::Spec->catdir( + $conf->get_conf('base'), + $conf->_get_build('custom_sources'), + ); + + unless( IS_DIR->( $dir ) ) { + msg(loc("No '%1' dir, skipping custom sources", $dir), $verbose); + return; + } + + ### unencode the files + ### skip ones starting with # though + my %files = map { + my $org = $_; + my $dec = $self->_uri_decode( uri => $_ ); + File::Spec->catfile( $dir, $org ) => $dec + } grep { $_ !~ /^#/ } READ_DIR->( $dir ); + + return %files; +} + +=head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] ); + +Attempts to update all the index files to your custom module sources. + +If the index is missing, and it's a C<file://> uri, it will generate +a new local index for you. + +Return true on success, false on failure. + +=cut + +sub __update_custom_module_sources { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $verbose; + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose } + }; + + check( $tmpl, \%hash ) or return; + + my %files = $self->__list_custom_module_sources; + + ### uptodate check has been done a few levels up. + my $fail; + while( my($local,$remote) = each %files ) { + + $self->__update_custom_module_source( + remote => $remote, + local => $local, + verbose => $verbose, + ) or ( $fail++, next ); + } + + error(loc("Failed updating one or more remote sources files")) if $fail; + + return if $fail; + return 1; +} + +=head2 $ok = $cb->__update_custom_module_source + +Attempts to update all the index files to your custom module sources. + +If the index is missing, and it's a C<file://> uri, it will generate +a new local index for you. + +Return true on success, false on failure. + +=cut + +sub __update_custom_module_source { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($verbose,$local,$remote); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + local => { store => \$local, allow => FILE_EXISTS }, + remote => { required => 1, store => \$remote }, + }; + + check( $tmpl, \%hash ) or return; + + msg( loc("Updating sources from '%1'", $remote), $verbose); + + ### if you didn't provide a local file, we'll look in your custom + ### dir to find the local encoded version for you + $local ||= do { + ### find all files we know of + my %files = reverse $self->__list_custom_module_sources or do { + error(loc("No custom modules sources defined -- need '%1' argument", + 'local')); + return; + }; + + ### On VMS the case of key to %files can be either exact or lower case + ### XXX abstract this lookup out? --kane + my $file = $files{ $remote }; + $file = $files{ lc $remote } if !defined ($file) && ON_VMS; + + ### return the local file we're supposed to use + $file or do { + error(loc("Remote source '%1' unknown -- needs '%2' argument", + $remote, 'local')); + return; + }; + }; + + my $uri = join '/', $remote, $conf->_get_source('custom_index'); + my $ff = File::Fetch->new( uri => $uri ); + + ### tempdir doesn't clean up by default, as opposed to tempfile() + ### so add it explicitly. + my $dir = tempdir( CLEANUP => 1 ); + + my $res = do { local $File::Fetch::WARN = 0; + local $File::Fetch::WARN = 0; + $ff->fetch( to => $dir ); + }; + + ### couldn't get the file + unless( $res ) { + + ### it's not a local scheme, so can't auto index + unless( $ff->scheme eq 'file' ) { + error(loc("Could not update sources from '%1': %2", + $remote, $ff->error )); + return; + + ### it's a local uri, we can index it ourselves + } else { + msg(loc("No index file found at '%1', generating one", + $ff->uri), $verbose ); + + ### ON VMS, if you are working with a UNIX file specification, + ### you need currently use the UNIX variants of the File::Spec. + my $ff_path = do { + my $file_class = 'File::Spec'; + $file_class .= '::Unix' if ON_VMS; + $file_class->catdir( File::Spec::Unix->splitdir( $ff->path ) ); + }; + + $self->__write_custom_module_index( + path => $ff_path, + to => $local, + verbose => $verbose, + ) or return; + + ### XXX don't write that here, __write_custom_module_index + ### already prints this out + #msg(loc("Index file written to '%1'", $to), $verbose); + } + + ### copy it to the real spot and update its timestamp + } else { + $self->_move( file => $res, to => $local ) or return; + $self->_update_timestamp( file => $local ); + + msg(loc("Index file saved to '%1'", $local), $verbose); + } + + return $local; +} + +=head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] ) + +Scans the C<path> you provided for packages and writes an index with all +the available packages to C<$path/packages.txt>. If you'd like the index +to be written to a different file, provide the C<to> argument. + +Returns true on success and false on failure. + +=cut + +sub __write_custom_module_index { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my ($verbose, $path, $to); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + path => { required => 1, allow => DIR_EXISTS, store => \$path }, + to => { store => \$to }, + }; + + check( $tmpl, \%hash ) or return; + + ### no explicit to? then we'll use our default + $to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') ); + + my @files; + require File::Find; + File::Find::find( sub { + ### let's see if A::E can even parse it + my $ae = do { + local $Archive::Extract::WARN = 0; + local $Archive::Extract::WARN = 0; + Archive::Extract->new( archive => $File::Find::name ) + } or return; + + ### it's a type A::E recognize, so we can add it + $ae->type or return; + + ### neither $_ nor $File::Find::name have the chunk of the path in + ### it starting $path -- it's either only the filename, or the full + ### path, so we have to strip it ourselves + ### make sure to remove the leading slash as well. + my $copy = $File::Find::name; + my $re = quotemeta($path); + $copy =~ s|^$re[\\/]?||i; + + push @files, $copy; + + }, $path ); + + ### does the dir exist? if not, create it. + { my $dir = dirname( $to ); + unless( IS_DIR->( $dir ) ) { + $self->_mkdir( dir => $dir ) or return + } + } + + ### create the index file + my $fh = OPEN_FILE->( $to => '>' ) or return; + + print $fh "$_\n" for @files; + close $fh; + + msg(loc("Successfully written index file to '%1'", $to), $verbose); + + return $to; +} + + +=head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] ) + +Creates entries in the module tree based upon the files as returned +by C<__list_custom_module_sources>. + +Returns true on success, false on failure. + +=cut + +### use $auth_obj as a persistant version, so we don't have to recreate +### modules all the time +{ my $auth_obj; + + sub __create_custom_module_entries { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $verbose; + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + }; + + check( $tmpl, \%hash ) or return undef; + + my %files = $self->__list_custom_module_sources; + + while( my($file,$name) = each %files ) { + + msg(loc("Adding packages from custom source '%1'", $name), $verbose); + + my $fh = OPEN_FILE->( $file ) or next; + + while( local $_ = <$fh> ) { + chomp; + next if /^#/; + next unless /\S+/; + + ### join on / -- it's a URI after all! + my $parse = join '/', $name, $_; + + ### try to make a module object out of it + my $mod = $self->parse_module( module => $parse ) or ( + error(loc("Could not parse '%1'", $_)), + next + ); + + ### mark this object with a custom author + $auth_obj ||= do { + my $id = CUSTOM_AUTHOR_ID; + + ### if the object is being created for the first time, + ### make sure there's an entry in the author tree as + ### well, so we can search on the CPAN ID + $self->author_tree->{ $id } = + CPANPLUS::Module::Author::Fake->new( cpanid => $id ); + }; + + $mod->author( $auth_obj ); + + ### and now add it to the modlue tree -- this MAY + ### override things of course + if( my $old_mod = $self->module_tree( $mod->module ) ) { + + ### On VMS use the old module name to get the real case + $mod->module( $old_mod->module ) if ON_VMS; + + msg(loc("About to overwrite module tree entry for '%1' with '%2'", + $mod->module, $mod->package), $verbose); + } + + ### mark where it came from + $mod->description( loc("Custom source from '%1'",$name) ); + + ### store it in the module tree + $self->module_tree->{ $mod->module } = $mod; + } + } + + return 1; + } +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/Memory.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/Memory.pm new file mode 100755 index 00000000000..cb3fd4f1e76 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/Memory.pm @@ -0,0 +1,374 @@ +package CPANPLUS::Internals::Source::Memory; + +use base 'CPANPLUS::Internals::Source'; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Module; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author; +use CPANPLUS::Internals::Constants; + +use File::Fetch; +use Archive::Extract; + +use IPC::Cmd qw[can_run]; +use File::Temp qw[tempdir]; +use File::Basename qw[dirname]; +use Params::Check qw[allow check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +=head1 NAME + +CPANPLUS::Internals::Source::Memory - In memory implementation + +=cut + +### flag to show if init_trees got its' data from storable. This allows +### us to not write an existing stored file back to disk +{ my $from_storable; + + sub _init_trees { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($path,$uptodate,$verbose,$use_stored); + my $tmpl = { + path => { default => $conf->get_conf('base'), store => \$path }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + uptodate => { required => 1, store => \$uptodate }, + use_stored => { default => 1, store => \$use_stored }, + }; + + check( $tmpl, \%hash ) or return; + + ### retrieve the stored source files ### + my $stored = $self->__memory_retrieve_source( + path => $path, + uptodate => $uptodate && $use_stored, + verbose => $verbose, + ) || {}; + + ### we got this from storable if $stored has keys.. + $from_storable = keys %$stored ? 1 : 0; + + ### set up the trees + $self->_atree( $stored->{_atree} || {} ); + $self->_mtree( $stored->{_mtree} || {} ); + + return 1; + } + + sub _standard_trees_completed { return $from_storable } + sub _custom_trees_completed { return $from_storable } + + sub _finalize_trees { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($path,$uptodate,$verbose); + my $tmpl = { + path => { default => $conf->get_conf('base'), store => \$path }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + uptodate => { required => 1, store => \$uptodate }, + }; + + { local $Params::Check::ALLOW_UNKNOWN = 1; + check( $tmpl, \%hash ) or return; + } + + ### write the stored files to disk, so we can keep using them + ### from now on, till they become invalid + ### write them if the original sources weren't uptodate, or + ### we didn't just load storable files + $self->__memory_save_source() if !$uptodate or not $from_storable; + + return 1; + } + + ### saves current memory state + sub _save_state { + my $self = shift; + return $self->_finalize_trees( @_, uptodate => 0 ); + } +} + +sub _add_author_object { + my $self = shift; + my %hash = @_; + + my $class; + my $tmpl = { + class => { default => 'CPANPLUS::Module::Author', store => \$class }, + map { $_ => { required => 1 } } + qw[ author cpanid email ] + }; + + my $href = do { + local $Params::Check::NO_DUPLICATES = 1; + check( $tmpl, \%hash ) or return; + }; + + my $obj = $class->new( %$href, _id => $self->_id ); + + $self->author_tree->{ $href->{'cpanid'} } = $obj or return; + + return $obj; +} + +sub _add_module_object { + my $self = shift; + my %hash = @_; + + my $class; + my $tmpl = { + class => { default => 'CPANPLUS::Module', store => \$class }, + map { $_ => { required => 1 } } + qw[ module version path comment author package description dslip mtime ] + }; + + my $href = do { + 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; +} + +{ my %map = ( + _source_search_module_tree => [ module_tree => 'CPANPLUS::Module' ], + _source_search_author_tree => [ author_tree => 'CPANPLUS::Module::Author' ], + ); + + while( my($sub, $aref) = each %map ) { + no strict 'refs'; + + my($meth, $class) = @$aref; + + *$sub = sub { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($authors,$list,$verbose,$type); + my $tmpl = { + data => { default => [], + strict_type=> 1, store => \$authors }, + allow => { required => 1, default => [ ], strict_type => 1, + store => \$list }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + type => { required => 1, allow => [$class->accessors()], + store => \$type }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my @rv; + for my $obj ( values %{ $self->$meth } ) { + #push @rv, $auth if check( + # { $type => { allow => $list } }, + # { $type => $auth->$type } + # ); + push @rv, $obj if allow( $obj->$type() => $list ); + } + + return @rv; + } + } +} + +=pod + +=head2 $cb->__memory_retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL]) + +This method retrieves a I<storable>d tree identified by C<$name>. + +It takes the following arguments: + +=over 4 + +=item name + +The internal name for the source file to retrieve. + +=item uptodate + +A flag indicating whether the file-cache is up-to-date or not. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns a tree on success, false on failure. + +=cut + +sub __memory_retrieve_source { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + my $tmpl = { + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### check if we can retrieve a frozen data structure with storable ### + my $storable = can_load( modules => {'Storable' => '0.0'} ) + if $conf->get_conf('storable'); + + return unless $storable; + + ### $stored is the name of the frozen data structure ### + my $stored = $self->__memory_storable_file( $args->{path} ); + + if ($storable && -e $stored && -s _ && $args->{'uptodate'}) { + msg( loc("Retrieving %1", $stored), $args->{'verbose'} ); + + my $href = Storable::retrieve($stored); + return $href; + } else { + return; + } +} + +=pod + +=head2 $cb->__memory_save_source([verbose => BOOL, path => $path]) + +This method saves all the parsed trees in I<storable>d format if +C<Storable> is available. + +It takes the following arguments: + +=over 4 + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns true on success, false on failure. + +=cut + +sub __memory_save_source { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + path => { default => $conf->get_conf('base'), allow => DIR_EXISTS }, + verbose => { default => $conf->get_conf('verbose') }, + force => { default => 1 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $aref = [qw[_mtree _atree]]; + + ### check if we can retrieve a frozen data structure with storable ### + my $storable; + $storable = can_load( modules => {'Storable' => '0.0'} ) + if $conf->get_conf('storable'); + return unless $storable; + + my $to_write = {}; + foreach my $key ( @$aref ) { + next unless ref( $self->$key ); + $to_write->{$key} = $self->$key; + } + + return unless keys %$to_write; + + ### $stored is the name of the frozen data structure ### + my $stored = $self->__memory_storable_file( $args->{path} ); + + if (-e $stored && not -w $stored) { + msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} ); + return; + } + + msg( loc("Writing compiled source information to disk. This might take a little while."), + $args->{'verbose'} ); + + my $flag; + unless( Storable::nstore( $to_write, $stored ) ) { + error( loc("could not store %1!", $stored) ); + $flag++; + } + + return $flag ? 0 : 1; +} + +sub __memory_storable_file { + my $self = shift; + my $conf = $self->configure_object; + my $path = shift or return; + + ### check if we can retrieve a frozen data structure with storable ### + my $storable = $conf->get_conf('storable') + ? can_load( modules => {'Storable' => '0.0'} ) + : 0; + + return unless $storable; + + ### $stored is the name of the frozen data structure ### + ### changed to use File::Spec->catfile -jmb + my $stored = File::Spec->rel2abs( + File::Spec->catfile( + $path, #base dir + $conf->_get_source('stored') #file + . '.s' . + $Storable::VERSION #the version of storable + . '.c' . + $self->VERSION #the version of CPANPLUS + . STORABLE_EXT #append a suffix + ) + ); + + return $stored; +} + + + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/SQLite.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/SQLite.pm new file mode 100755 index 00000000000..a0ddf499bf6 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/SQLite.pm @@ -0,0 +1,326 @@ +package CPANPLUS::Internals::Source::SQLite; + +use strict; +use warnings; + +use base 'CPANPLUS::Internals::Source'; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Internals::Source::SQLite::Tie; + +use Data::Dumper; +use DBIx::Simple; +use DBD::SQLite; + +use Params::Check qw[allow check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +use constant TXN_COMMIT => 1000; + +=head1 NAME + +CPANPLUS::Internals::Source::SQLite - SQLite implementation + +=cut + +{ my $Dbh; + my $DbFile; + + sub __sqlite_file { + return $DbFile if $DbFile; + + my $self = shift; + my $conf = $self->configure_object; + + $DbFile = File::Spec->catdir( + $conf->get_conf('base'), + SOURCE_SQLITE_DB + ); + + return $DbFile; + }; + + sub __sqlite_dbh { + return $Dbh if $Dbh; + + my $self = shift; + $Dbh = DBIx::Simple->connect( + "dbi:SQLite:dbname=" . $self->__sqlite_file, + '', '', + { AutoCommit => 1 } + ); + #$Dbh->dbh->trace(1); + + return $Dbh; + }; +} + +{ my $used_old_copy = 0; + + sub _init_trees { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($path,$uptodate,$verbose,$use_stored); + my $tmpl = { + path => { default => $conf->get_conf('base'), store => \$path }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + uptodate => { required => 1, store => \$uptodate }, + use_stored => { default => 1, store => \$use_stored }, + }; + + check( $tmpl, \%hash ) or return; + + ### if it's not uptodate, or the file doesn't exist, we need to create + ### a new sqlite db + if( not $uptodate or not -e $self->__sqlite_file ) { + $used_old_copy = 0; + + ### chuck the file + 1 while unlink $self->__sqlite_file; + + ### and create a new one + $self->__sqlite_create_db or do { + error(loc("Could not create new SQLite DB")); + return; + } + } else { + $used_old_copy = 1; + } + + ### set up the author tree + { my %at; + tie %at, 'CPANPLUS::Internals::Source::SQLite::Tie', + dbh => $self->__sqlite_dbh, table => 'author', + key => 'cpanid', cb => $self; + + $self->_atree( \%at ); + } + + ### set up the author tree + { my %mt; + tie %mt, 'CPANPLUS::Internals::Source::SQLite::Tie', + dbh => $self->__sqlite_dbh, table => 'module', + key => 'module', cb => $self; + + $self->_mtree( \%mt ); + } + + ### start a transaction + $self->__sqlite_dbh->query('BEGIN'); + + return 1; + + } + + sub _standard_trees_completed { return $used_old_copy } + sub _custom_trees_completed { return } + ### finish transaction + sub _finalize_trees { $_[0]->__sqlite_dbh->query('COMMIT'); return 1 } + + ### saves current memory state, but not implemented in sqlite + sub _save_state { + error(loc("%1 has not implemented writing state to disk", __PACKAGE__)); + return; + } +} + +{ my $txn_count = 0; + + ### XXX move this outside the sub, so we only compute it once + my $class; + my @keys = qw[ author cpanid email ]; + my $tmpl = { + class => { default => 'CPANPLUS::Module::Author', store => \$class }, + map { $_ => { required => 1 } } @keys + }; + + ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually + my $ph = join ',', map { '?' } @keys; + + + sub _add_author_object { + my $self = shift; + my %hash = @_; + my $dbh = $self->__sqlite_dbh; + + my $href = do { + local $Params::Check::NO_DUPLICATES = 1; + local $Params::Check::SANITY_CHECK_TEMPLATE = 0; + check( $tmpl, \%hash ) or return; + }; + + ### keep counting how many we inserted + unless( ++$txn_count % TXN_COMMIT ) { + #warn "Committing transaction $txn_count"; + $dbh->query('COMMIT') or error( $dbh->error ); # commit previous transaction + $dbh->query('BEGIN') or error( $dbh->error ); # and start a new one + } + + $dbh->query( + "INSERT INTO author (". join(',',keys(%$href)) .") VALUES ($ph)", + values %$href + ) or do { + error( $dbh->error ); + return; + }; + + return 1; + } +} + +{ my $txn_count = 0; + + ### XXX move this outside the sub, so we only compute it once + my $class; + my @keys = qw[ module version path comment author package description dslip mtime ]; + my $tmpl = { + class => { default => 'CPANPLUS::Module', store => \$class }, + map { $_ => { required => 1 } } @keys + }; + + ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually + my $ph = join ',', map { '?' } @keys; + + sub _add_module_object { + my $self = shift; + my %hash = @_; + my $dbh = $self->__sqlite_dbh; + + my $href = do { + local $Params::Check::NO_DUPLICATES = 1; + local $Params::Check::SANITY_CHECK_TEMPLATE = 0; + check( $tmpl, \%hash ) or return; + }; + + ### fix up author to be 'plain' string + $href->{'author'} = $href->{'author'}->cpanid; + + ### keep counting how many we inserted + unless( ++$txn_count % TXN_COMMIT ) { + #warn "Committing transaction $txn_count"; + $dbh->query('COMMIT') or error( $dbh->error ); # commit previous transaction + $dbh->query('BEGIN') or error( $dbh->error ); # and start a new one + } + + $dbh->query( + "INSERT INTO module (". join(',',keys(%$href)) .") VALUES ($ph)", + values %$href + ) or do { + error( $dbh->error ); + return; + }; + + return 1; + } +} + +{ my %map = ( + _source_search_module_tree + => [ module => module => 'CPANPLUS::Module' ], + _source_search_author_tree + => [ author => cpanid => 'CPANPLUS::Module::Author' ], + ); + + while( my($sub, $aref) = each %map ) { + no strict 'refs'; + + my($table, $key, $class) = @$aref; + *$sub = sub { + my $self = shift; + my %hash = @_; + my $dbh = $self->__sqlite_dbh; + + my($list,$type); + my $tmpl = { + allow => { required => 1, default => [ ], strict_type => 1, + store => \$list }, + type => { required => 1, allow => [$class->accessors()], + store => \$type }, + }; + + check( $tmpl, \%hash ) or return; + + + ### we aliased 'module' to 'name', so change that here too + $type = 'module' if $type eq 'name'; + + my $res = $dbh->query( "SELECT * from $table" ); + + my $meth = $table .'_tree'; + my @rv = map { $self->$meth( $_->{$key} ) } + grep { allow( $_->{$type} => $list ) } $res->hashes; + + return @rv; + } + } +} + + + +sub __sqlite_create_db { + my $self = shift; + my $dbh = $self->__sqlite_dbh; + + ### we can ignore the result/error; not all sqlite implemantation + ### support this + $dbh->query( qq[ + DROP TABLE IF EXISTS author; + \n] + ) or do { + msg( $dbh->error ); + }; + $dbh->query( qq[ + DROP TABLE IF EXISTS module; + \n] + ) or do { + msg( $dbh->error ); + }; + + + + $dbh->query( qq[ + /* the author information */ + CREATE TABLE author ( + id INTEGER PRIMARY KEY AUTOINCREMENT, + + author varchar(255), + email varchar(255), + cpanid varchar(255) + ); + \n] + + ) or do { + error( $dbh->error ); + return; + }; + + $dbh->query( qq[ + /* the module information */ + CREATE TABLE module ( + id INTEGER PRIMARY KEY AUTOINCREMENT, + + module varchar(255), + version varchar(255), + path varchar(255), + comment varchar(255), + author varchar(255), + package varchar(255), + description varchar(255), + dslip varchar(255), + mtime varchar(255) + ); + + \n] + + ) or do { + error( $dbh->error ); + return; + }; + + return 1; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm new file mode 100755 index 00000000000..f908c9803e4 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm @@ -0,0 +1,145 @@ +package CPANPLUS::Internals::Source::SQLite::Tie; + +use strict; +use warnings; + +use CPANPLUS::Error; +use CPANPLUS::Module; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author::Fake; +use CPANPLUS::Internals::Constants; + + +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + + +use Data::Dumper; +$Data::Dumper::Indent = 1; + +require Tie::Hash; +use vars qw[@ISA]; +push @ISA, 'Tie::StdHash'; + + +sub TIEHASH { + my $class = shift; + my %hash = @_; + + my $tmpl = { + dbh => { required => 1 }, + table => { required => 1 }, + key => { required => 1 }, + cb => { required => 1 }, + offset => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + my $obj = bless { %$args, store => {} } , $class; + + return $obj; +} + +sub FETCH { + my $self = shift; + my $key = shift or return; + my $dbh = $self->{dbh}; + my $cb = $self->{cb}; + my $table = $self->{table}; + + + ### did we look this one up before? + if( my $obj = $self->{store}->{$key} ) { + return $obj; + } + + my $res = $dbh->query( + "SELECT * from $table where $self->{key} = ?", $key + ) or do { + error( $dbh->error ); + return; + }; + + my $href = $res->hash; + + ### get rid of the primary key + delete $href->{'id'}; + + ### no results? + return unless keys %$href; + + ### expand author if needed + ### XXX no longer generic :( + if( $table eq 'module' ) { + $href->{author} = $cb->author_tree( $href->{author } ) or return; + } + + my $class = { + module => 'CPANPLUS::Module', + author => 'CPANPLUS::Module::Author', + }->{ $table }; + + my $obj = $self->{store}->{$key} = $class->new( %$href, _id => $cb->_id ); + + return $obj; +} + +sub STORE { + my $self = shift; + my $key = shift; + my $val = shift; + + $self->{store}->{$key} = $val; +} + +1; + +sub FIRSTKEY { + my $self = shift; + my $dbh = $self->{'dbh'}; + + my $res = $dbh->query( + "select $self->{key} from $self->{table} order by $self->{key} limit 1" + ); + + $self->{offset} = 0; + + my $key = $res->flat->[0]; + + return $key; +} + +sub NEXTKEY { + my $self = shift; + my $dbh = $self->{'dbh'}; + + my $res = $dbh->query( + "select $self->{key} from $self->{table} ". + "order by $self->{key} limit 1 offset $self->{offset}" + ); + + $self->{offset} +=1; + + my $key = $res->flat->[0]; + my $val = $self->FETCH( $key ); + + ### use each() semantics + return wantarray ? ( $key, $val ) : $key; +} + +sub EXISTS { !!$_[0]->FETCH( $_[1] ) } + +sub SCALAR { + my $self = shift; + my $dbh = $self->{'dbh'}; + + my $res = $dbh->query( "select count(*) from $self->{table}" ); + + return $res->flat; +} + +### intentionally left blank +sub DELETE { } +sub CLEAR { } + diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Utils.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Utils.pm new file mode 100755 index 00000000000..8475c362023 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Utils.pm @@ -0,0 +1,657 @@ +package CPANPLUS::Internals::Utils; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use Cwd qw[chdir cwd]; +use File::Copy; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Utils + +=head1 SYNOPSIS + + my $bool = $cb->_mkdir( dir => 'blah' ); + my $bool = $cb->_chdir( dir => 'blah' ); + my $bool = $cb->_rmdir( dir => 'blah' ); + + my $bool = $cb->_move( from => '/some/file', to => '/other/file' ); + my $bool = $cb->_move( from => '/some/dir', to => '/other/dir' ); + + my $cont = $cb->_get_file_contents( file => '/path/to/file' ); + + + my $version = $cb->_perl_version( perl => $^X ); + +=head1 DESCRIPTION + +C<CPANPLUS::Internals::Utils> holds a few convenience functions for +CPANPLUS libraries. + +=head1 METHODS + +=head2 $cb->_mkdir( dir => '/some/dir' ) + +C<_mkdir> creates a full path to a directory. + +Returns true on success, false on failure. + +=cut + +sub _mkdir { + my $self = shift; + + my %hash = @_; + + my $tmpl = { + dir => { required => 1 }, + }; + + my $args = check( $tmpl, \%hash ) or ( + error(loc( Params::Check->last_error ) ), return + ); + + unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { + error( loc("Could not use File::Path! This module should be core!") ); + return; + } + + eval { File::Path::mkpath($args->{dir}) }; + + if($@) { + chomp($@); + error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ )); + return; + } + + return 1; +} + +=pod + +=head2 $cb->_chdir( dir => '/some/dir' ) + +C<_chdir> changes directory to a dir. + +Returns true on success, false on failure. + +=cut + +sub _chdir { + my $self = shift; + my %hash = @_; + + my $tmpl = { + dir => { required => 1, allow => DIR_EXISTS }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + unless( chdir $args->{dir} ) { + error( loc(q[Could not chdir into '%1'], $args->{dir}) ); + return; + } + + return 1; +} + +=pod + +=head2 $cb->_rmdir( dir => '/some/dir' ); + +Removes a directory completely, even if it is non-empty. + +Returns true on success, false on failure. + +=cut + +sub _rmdir { + my $self = shift; + my %hash = @_; + + my $tmpl = { + dir => { required => 1, allow => IS_DIR }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { + error( loc("Could not use File::Path! This module should be core!") ); + return; + } + + eval { File::Path::rmtree($args->{dir}) }; + + if($@) { + chomp($@); + error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ )); + return; + } + + return 1; +} + +=pod + +=head2 $cb->_perl_version ( perl => 'some/perl/binary' ); + +C<_perl_version> returns the version of a certain perl binary. +It does this by actually running a command. + +Returns the perl version on success and false on failure. + +=cut + +sub _perl_version { + my $self = shift; + my %hash = @_; + + my $perl; + my $tmpl = { + perl => { required => 1, store => \$perl }, + }; + + check( $tmpl, \%hash ) or return; + + my $perl_version; + ### special perl, or the one we are running under? + if( $perl eq $^X ) { + ### just load the config + require Config; + $perl_version = $Config::Config{version}; + + } else { + my $cmd = $perl . + ' -MConfig -eprint+Config::config_vars+version'; + ($perl_version) = (`$cmd` =~ /version='(.*)'/); + } + + return $perl_version if defined $perl_version; + return; +} + +=pod + +=head2 $cb->_version_to_number( version => $version ); + +Returns a proper module version, or '0.0' if none was available. + +=cut + +sub _version_to_number { + my $self = shift; + my %hash = @_; + + my $version; + my $tmpl = { + version => { default => '0.0', store => \$version }, + }; + + check( $tmpl, \%hash ) or return; + + return $version if $version =~ /^\.?\d/; + return '0.0'; +} + +=pod + +=head2 $cb->_whoami + +Returns the name of the subroutine you're currently in. + +=cut + +sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name } + +=pod + +=head2 _get_file_contents( file => $file ); + +Returns the contents of a file + +=cut + +sub _get_file_contents { + my $self = shift; + my %hash = @_; + + my $file; + my $tmpl = { + file => { required => 1, store => \$file } + }; + + check( $tmpl, \%hash ) or return; + + my $fh = OPEN_FILE->($file) or return; + my $contents = do { local $/; <$fh> }; + + return $contents; +} + +=pod $cb->_move( from => $file|$dir, to => $target ); + +Moves a file or directory to the target. + +Returns true on success, false on failure. + +=cut + +sub _move { + my $self = shift; + my %hash = @_; + + my $from; my $to; + my $tmpl = { + file => { required => 1, allow => [IS_FILE,IS_DIR], + store => \$from }, + to => { required => 1, store => \$to } + }; + + check( $tmpl, \%hash ) or return; + + if( File::Copy::move( $from, $to ) ) { + return 1; + } else { + error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!)); + return; + } +} + +=pod $cb->_copy( from => $file|$dir, to => $target ); + +Moves a file or directory to the target. + +Returns true on success, false on failure. + +=cut + +sub _copy { + my $self = shift; + my %hash = @_; + + my($from,$to); + my $tmpl = { + file =>{ required => 1, allow => [IS_FILE,IS_DIR], + store => \$from }, + to => { required => 1, store => \$to } + }; + + check( $tmpl, \%hash ) or return; + + if( File::Copy::copy( $from, $to ) ) { + return 1; + } else { + error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!)); + return; + } +} + +=head2 $cb->_mode_plus_w( file => '/path/to/file' ); + +Sets the +w bit for the file. + +Returns true on success, false on failure. + +=cut + +sub _mode_plus_w { + my $self = shift; + my %hash = @_; + + require File::stat; + + my $file; + my $tmpl = { + file => { required => 1, allow => IS_FILE, store => \$file }, + }; + + check( $tmpl, \%hash ) or return; + + ### set the mode to +w for a file and +wx for a dir + my $x = File::stat::stat( $file ); + my $mask = -d $file ? 0100 : 0200; + + if( $x and chmod( $x->mode|$mask, $file ) ) { + return 1; + + } else { + error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!)); + return; + } +} + +=head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH ); + +Turns a CPANPLUS::Config style C<host> entry into an URI string. + +Returns the uri on success, and false on failure + +=cut + +sub _host_to_uri { + my $self = shift; + my %hash = @_; + + my($scheme, $host, $path); + my $tmpl = { + scheme => { required => 1, store => \$scheme }, + host => { default => 'localhost', store => \$host }, + path => { default => '', store => \$path }, + }; + + check( $tmpl, \%hash ) or return; + + ### it's an URI, so unixify the path. + ### VMS has a special method for just that + $path = ON_VMS + ? VMS::Filespec::unixify($path) + : File::Spec::Unix->catdir( File::Spec->splitdir( $path ) ); + + return "$scheme://" . File::Spec::Unix->catdir( $host, $path ); +} + +=head2 $cb->_vcmp( VERSION, VERSION ); + +Normalizes the versions passed and does a '<=>' on them, returning the result. + +=cut + +sub _vcmp { + my $self = shift; + my ($x, $y) = @_; + + s/_//g foreach $x, $y; + + return $x <=> $y; +} + +=head2 $cb->_home_dir + +Returns the user's homedir, or C<cwd> if it could not be found + +=cut + +sub _home_dir { + my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN ); + + for my $env ( @os_home_envs ) { + next unless exists $ENV{ $env }; + next unless defined $ENV{ $env } && length $ENV{ $env }; + return $ENV{ $env } if -d $ENV{ $env }; + } + + return cwd(); +} + +=head2 $path = $cb->_safe_path( path => $path ); + +Returns a path that's safe to us on Win32 and VMS. + +Only cleans up the path on Win32 if the path exists. + +On VMS, it encodes dots to _ using C<VMS::Filespec::vmsify> + +=cut + +sub _safe_path { + my $self = shift; + + my %hash = @_; + + my $path; + my $tmpl = { + path => { required => 1, store => \$path }, + }; + + check( $tmpl, \%hash ) or return; + + if( ON_WIN32 ) { + ### only need to fix it up if there's spaces in the path + return $path unless $path =~ /\s+/; + + ### clean up paths if we are on win32 + return Win32::GetShortPathName( $path ) || $path; + + } elsif ( ON_VMS ) { + ### XXX According to John Malmberg, there's an VMS issue: + ### catdir on VMS can not currently deal with directory components + ### with dots in them. + ### Fixing this is a a three step procedure, which will work for + ### VMS in its traditional ODS-2 mode, and it will also work if + ### VMS is in the ODS-5 mode that is being implemented. + ### If the path is already in VMS syntax, assume that we are done. + + ### VMS format is a path with a trailing ']' or ':' + return $path if $path =~ /\:|\]$/; + + ### 1. Make sure that the value to be converted, $path is + ### in UNIX directory syntax by appending a '/' to it. + $path .= '/' unless $path =~ m|/$|; + + ### 2. Use VMS::Filespec::vmsify($path . '/') to convert the dots to + ### underscores if needed. The trailing '/' is needed as so that + ### C<vmsify> knows that it should use directory translation instead of + ### filename translation, as filename translation leaves one dot. + $path = VMS::Filespec::vmsify( $path ); + + ### 3. Use $path = File::Spec->splitdir( VMS::Filespec::vmsify( + ### $path . '/') to remove the directory delimiters. + + ### From John Malmberg: + ### File::Spec->catdir will put the path back together. + ### The '/' trick only works if the string is a directory name + ### with UNIX style directory delimiters or no directory delimiters. + ### It is to force vmsify to treat the input specification as UNIX. + ### + ### There is a VMS::Filespec::unixpath() to do the appending of the '/' + ### to the specification, which will do a VMS::Filespec::vmsify() + ### if needed. + ### However it is not a good idea to call vmsify() on a pathname + ### returned by unixify(), and it is not a good idea to call unixify() + ### on a pathname returned by vmsify(). Because of the nature of the + ### conversion, not all file specifications can make the round trip. + ### + ### I think that directory specifications can safely make the round + ### trip, but not ones containing filenames. + $path = File::Spec->catdir( File::Spec->splitdir( $path ) ) + } + + return $path; +} + + +=head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING ); + +Splits the name of a CPAN package string up into its package, version +and extension parts. + +For example, C<Foo-Bar-1.2.tar.gz> would return the following parts: + + Package: Foo-Bar + Version: 1.2 + Extension: tar.gz + +=cut + +{ my $del_re = qr/[-_\+]/i; # delimiter between elements + my $pkg_re = qr/[a-z] # any letters followed by + [a-z\d]* # any letters, numbers + (?i:\.pm)? # followed by '.pm'--authors do this :( + (?: # optionally repeating: + $del_re # followed by a delimiter + [a-z] # any letters followed by + [a-z\d]* # any letters, numbers + (?i:\.pm)? # followed by '.pm'--authors do this :( + )* + /xi; + + my $ver_re = qr/[a-z]*\d*?[a-z]* # contains a digit and possibly letters + (?: # however, some start with a . only :( + [-._] # followed by a delimiter + [a-z\d]+ # and more digits and or letters + )*? + /xi; + + my $ext_re = qr/[a-z] # a letter, followed by + [a-z\d]* # letters and or digits, optionally + (?: + \. # followed by a dot and letters + [a-z\d]+ # and or digits (like .tar.bz2) + )? # optionally + /xi; + + my $ver_ext_re = qr/ + ($ver_re+) # version, optional + (?: + \. # a literal . + ($ext_re) # extension, + )? # optional, but requires version + /xi; + + ### composed regex for CPAN packages + my $full_re = qr/ + ^ + ( # the whole thing + ($pkg_re+) # package + (?: + $del_re # delimiter + $ver_ext_re # version + extension + )? + ) + $ + /xi; + + ### composed regex for perl packages + my $perl = PERL_CORE; + my $perl_re = qr/ + ^ + ( # the whole thing + ($perl) # package name for 'perl' + (?: + $ver_ext_re # version + extension + )? + ) + $ + /xi; + + +sub _split_package_string { + my $self = shift; + my %hash = @_; + + my $str; + my $tmpl = { package => { required => 1, store => \$str } }; + check( $tmpl, \%hash ) or return; + + + ### 2 different regexes, one for the 'perl' package, + ### one for ordinary CPAN packages.. try them both, + ### first match wins. + for my $re ( $full_re, $perl_re ) { + + ### try the next if the match fails + $str =~ $re or next; + + my $full = $1 || ''; + my $pkg = $2 || ''; + my $ver = $3 || ''; + my $ext = $4 || ''; + + ### this regex resets the capture markers! + ### strip the trailing delimiter + $pkg =~ s/$del_re$//; + + ### strip the .pm package suffix some authors insist on adding + $pkg =~ s/\.pm$//i; + + return ($pkg, $ver, $ext, $full ); + } + + return; + } +} + +{ my %escapes = map { + chr($_) => sprintf("%%%02X", $_) + } 0 .. 255; + + sub _uri_encode { + my $self = shift; + my %hash = @_; + + my $str; + my $tmpl = { + uri => { store => \$str, required => 1 } + }; + + check( $tmpl, \%hash ) or return; + + ### XXX taken straight from URI::Encode + ### Default unsafe characters. RFC 2732 ^(uric - reserved) + $str =~ s|([^A-Za-z0-9\-_.!~*'()])|$escapes{$1}|g; + + return $str; + } + + + sub _uri_decode { + my $self = shift; + my %hash = @_; + + my $str; + my $tmpl = { + uri => { store => \$str, required => 1 } + }; + + check( $tmpl, \%hash ) or return; + + ### XXX use unencode routine in utils? + $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + + return $str; + } +} + +sub _update_timestamp { + my $self = shift; + my %hash = @_; + + my $file; + my $tmpl = { + file => { required => 1, store => \$file, allow => FILE_EXISTS } + }; + + check( $tmpl, \%hash ) or return; + + ### `touch` the file, so windoze knows it's new -jmb + ### works on *nix too, good fix -Kane + ### make sure it is writable first, otherwise the `touch` will fail + + my $now = time; + unless( chmod( 0644, $file) && utime ($now, $now, $file) ) { + error( loc("Couldn't touch %1", $file) ); + return; + } + + return 1; +} + + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Utils/Autoflush.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Utils/Autoflush.pm new file mode 100755 index 00000000000..56566436a14 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Internals/Utils/Autoflush.pm @@ -0,0 +1,5 @@ +package CPANPLUS::Internals::Utils::Autoflush; + +BEGIN { $|++ }; + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module.pm new file mode 100755 index 00000000000..2122c6d51f9 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module.pm @@ -0,0 +1,1816 @@ +package CPANPLUS::Module; + +use strict; +use vars qw[@ISA]; + + +use CPANPLUS::Dist; +use CPANPLUS::Error; +use CPANPLUS::Module::Signature; +use CPANPLUS::Module::Checksums; +use CPANPLUS::Internals::Constants; + +use FileHandle; + +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use IPC::Cmd qw[can_run run]; +use File::Find qw[find]; +use Params::Check qw[check]; +use File::Basename qw[dirname]; +use Module::Load::Conditional qw[can_load check_install]; + +$Params::Check::VERBOSE = 1; + +@ISA = qw[ CPANPLUS::Module::Signature CPANPLUS::Module::Checksums]; + +=pod + +=head1 NAME + +CPANPLUS::Module + +=head1 SYNOPSIS + + ### get a module object from the CPANPLUS::Backend object + my $mod = $cb->module_tree('Some::Module'); + + ### accessors + $mod->version; + $mod->package; + + ### methods + $mod->fetch; + $mod->extract; + $mod->install; + + +=head1 DESCRIPTION + +C<CPANPLUS::Module> creates objects from the information in the +source files. These can then be used to query and perform actions +on, like fetching or installing. + +These objects should only be created internally. For C<fake> objects, +there's the C<CPANPLUS::Module::Fake> class. To obtain a module object +consult the C<CPANPLUS::Backend> documentation. + +=cut + +my $tmpl = { + module => { default => '', required => 1 }, # full module name + version => { default => '0.0' }, # version number + path => { default => '', required => 1 }, # extended path on the + # cpan mirror, like + # /author/id/K/KA/KANE + comment => { default => ''}, # comment on module + package => { default => '', required => 1 }, # package name, like + # 'bar-baz-1.03.tgz' + description => { default => '' }, # description of the + # module + dslip => { default => EMPTY_DSLIP }, # dslip information + _id => { required => 1 }, # id of the Internals + # parent object + _status => { no_override => 1 }, # stores status object + author => { default => '', required => 1, + allow => IS_AUTHOBJ }, # module author + mtime => { default => '' }, +}; + +### some of these will be resolved by wrapper functions that +### do Clever Things to find the actual value, so don't create +### an autogenerated sub for that just here, take an alternate +### name to allow for a wrapper +{ my %rename = ( + dslip => '_dslip' + ); + + ### autogenerate accessors ### + for my $key ( keys %$tmpl ) { + no strict 'refs'; + + my $sub = $rename{$key} || $key; + + *{__PACKAGE__."::$sub"} = sub { + $_[0]->{$key} = $_[1] if @_ > 1; + return $_[0]->{$key}; + } + } +} + + +=pod + +=head1 CLASS METHODS + +=head2 accessors () + +Returns a list of all accessor methods to the object + +=cut + +### *name is an alias, include it explicitly +sub accessors { return ('name', keys %$tmpl) }; + +=head1 ACCESSORS + +An objects of this class has the following accessors: + +=over 4 + +=item name + +Name of the module. + +=item module + +Name of the module. + +=item version + +Version of the module. Defaults to '0.0' if none was provided. + +=item path + +Extended path on the mirror. + +=item comment + +Any comment about the module -- largely unused. + +=item package + +The name of the package. + +=item description + +Description of the module -- only registered modules have this. + +=item dslip + +The five character dslip string, that represents meta-data of the +module -- again, only registered modules have this. + +=cut + +sub dslip { + my $self = shift; + + ### if this module has relevant dslip info, return it + return $self->_dslip if $self->_dslip ne EMPTY_DSLIP; + + ### if not, look at other modules in the same package, + ### see if *they* have any dslip info + for my $mod ( $self->contains ) { + return $mod->_dslip if $mod->_dslip ne EMPTY_DSLIP; + } + + ### ok, really no dslip info found, return the default + return EMPTY_DSLIP; +} + + +=pod + +=item status + +The C<CPANPLUS::Module::Status> object associated with this object. +(see below). + +=item author + +The C<CPANPLUS::Module::Author> object associated with this object. + +=item parent + +The C<CPANPLUS::Internals> object that spawned this module object. + +=back + +=cut + +### Alias ->name to ->module, for human beings. +*name = *module; + +sub parent { + my $self = shift; + my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id ); + + return $obj; +} + +=head1 STATUS ACCESSORS + +C<CPANPLUS> caches a lot of results from method calls and saves data +it collected along the road for later reuse. + +C<CPANPLUS> uses this internally, but it is also available for the end +user. You can get a status object by calling: + + $modobj->status + +You can then query the object as follows: + +=over 4 + +=item installer_type + +The installer type used for this distribution. Will be one of +'makemaker' or 'build'. This determines whether C<CPANPLUS::Dist::MM> +or C<CPANPLUS::Dist::Build> will be used to build this distribution. + +=item dist_cpan + +The dist object used to do the CPAN-side of the installation. Either +a C<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build> object. + +=item dist + +The custom dist object used to do the operating specific side of the +installation, if you've chosen to use this. For example, if you've +chosen to install using the C<ports> format, this may be a +C<CPANPLUS::Dist::Ports> object. + +Undefined if you didn't specify a separate format to install through. + +=item prereqs | requires + +A hashref of prereqs this distribution was found to have. Will look +something like this: + + { Carp => 0.01, strict => 0 } + +Might be undefined if the distribution didn't have any prerequisites. + +=item configure_requires + +Like prereqs, but these are necessary to be installed before the +build process can even begin. + +=item signature + +Flag indicating, if a signature check was done, whether it was OK or +not. + +=item extract + +The directory this distribution was extracted to. + +=item fetch + +The location this distribution was fetched to. + +=item readme + +The text of this distributions README file. + +=item uninstall + +Flag indicating if an uninstall call was done successfully. + +=item created + +Flag indicating if the C<create> call to your dist object was done +successfully. + +=item installed + +Flag indicating if the C<install> call to your dist object was done +successfully. + +=item checksums + +The location of this distributions CHECKSUMS file. + +=item checksum_ok + +Flag indicating if the checksums check was done successfully. + +=item checksum_value + +The checksum value this distribution is expected to have + +=back + +=head1 METHODS + +=head2 $self = CPANPLUS::Module->new( OPTIONS ) + +This method returns a C<CPANPLUS::Module> object. Normal users +should never call this method directly, but instead use the +C<CPANPLUS::Backend> to obtain module objects. + +This example illustrates a C<new()> call with all required arguments: + + CPANPLUS::Module->new( + module => 'Foo', + path => 'authors/id/A/AA/AAA', + package => 'Foo-1.0.tgz', + author => $author_object, + _id => INTERNALS_OBJECT_ID, + ); + +Every accessor is also a valid option to pass to C<new>. + +Returns a module object on success and false on failure. + +=cut + + +sub new { + my($class, %hash) = @_; + + ### don't check the template for sanity + ### -- we know it's good and saves a lot of performance + local $Params::Check::SANITY_CHECK_TEMPLATE = 0; + + my $object = check( $tmpl, \%hash ) or return; + + bless $object, $class; + + return $object; +} + +### only create status objects when they're actually asked for +sub status { + my $self = shift; + return $self->_status if $self->_status; + + my $acc = Object::Accessor->new; + $acc->mk_accessors( qw[ installer_type dist_cpan dist prereqs + signature extract fetch readme uninstall + created installed prepared checksums files + checksum_ok checksum_value _fetch_from + configure_requires + ] ); + + ### create an alias from 'requires' to 'prereqs', so it's more in + ### line with 'configure_requires'; + $acc->mk_aliases( requires => 'prereqs' ); + + $self->_status( $acc ); + + return $self->_status; +} + + +### flush the cache of this object ### +sub _flush { + my $self = shift; + $self->status->mk_flush; + return 1; +} + +=head2 $mod->package_name( [$package_string] ) + +Returns the name of the package a module is in. For C<Acme::Bleach> +that might be C<Acme-Bleach>. + +=head2 $mod->package_version( [$package_string] ) + +Returns the version of the package a module is in. For a module +in the package C<Acme-Bleach-1.1.tar.gz> this would be C<1.1>. + +=head2 $mod->package_extension( [$package_string] ) + +Returns the suffix added by the compression method of a package a +certain module is in. For a module in C<Acme-Bleach-1.1.tar.gz>, this +would be C<tar.gz>. + +=head2 $mod->package_is_perl_core + +Returns a boolean indicating of the package a particular module is in, +is actually a core perl distribution. + +=head2 $mod->module_is_supplied_with_perl_core( [version => $]] ) + +Returns a boolean indicating whether C<ANY VERSION> of this module +was supplied with the current running perl's core package. + +=head2 $mod->is_bundle + +Returns a boolean indicating if the module you are looking at, is +actually a bundle. Bundles are identified as modules whose name starts +with C<Bundle::>. + +=head2 $mod->is_autobundle; + +Returns a boolean indicating if the module you are looking at, is +actually an autobundle as generated by C<< $cb->autobundle >>. + +=head2 $mod->is_third_party + +Returns a boolean indicating whether the package is a known third-party +module (i.e. it's not provided by the standard Perl distribution and +is not available on the CPAN, but on a third party software provider). +See L<Module::ThirdParty> for more details. + +=head2 $mod->third_party_information + +Returns a reference to a hash with more information about a third-party +module. See the documentation about C<module_information()> in +L<Module::ThirdParty> for more details. + +=cut + +{ ### fetches the test reports for a certain module ### + my %map = ( + name => 0, + version => 1, + extension => 2, + ); + + while ( my($type, $index) = each %map ) { + my $name = 'package_' . $type; + + no strict 'refs'; + *$name = sub { + my $self = shift; + my $val = shift || $self->package; + my @res = $self->parent->_split_package_string( package => $val ); + + ### return the corresponding index from the result + return $res[$index] if @res; + return; + }; + } + + sub package_is_perl_core { + my $self = shift; + my $cb = $self->parent; + + ### check if the package looks like a perl core package + return 1 if $self->package_name eq PERL_CORE; + + ### address #44562: ::Module->package_is_perl_code : problem comparing + ### version strings -- use $cb->_vcmp to avoid warnings when version + ### have _ in them + + my $core = $self->module_is_supplied_with_perl_core; + ### ok, so it's found in the core, BUT it could be dual-lifed + if ($core) { + ### if the package is newer than installed, then it's dual-lifed + return if $cb->_vcmp($self->version, $self->installed_version) > 0; + + ### if the package is newer or equal to the corelist, + ### then it's dual-lifed + return if $cb->_vcmp( $self->version, $core ) >= 0; + + ### otherwise, it's older than corelist, thus unsuitable. + return 1; + } + + ### not in corelist, not a perl core package. + return; + } + + sub module_is_supplied_with_perl_core { + my $self = shift; + my $ver = shift || $]; + + ### allow it to be called as a package function as well like: + ### CPANPLUS::Module::module_is_supplied_with_perl_core('Config') + ### so that we can check the status of modules that aren't released + ### to CPAN, but are part of the core. + my $name = ref $self ? $self->module : $self; + + ### check Module::CoreList to see if it's a core package + require Module::CoreList; + + ### Address #41157: Module::module_is_supplied_with_perl_core() + ### broken for perl 5.10: Module::CoreList's version key for the + ### hash has a different number of trailing zero than $] aka + ### $PERL_VERSION. + my $core = $Module::CoreList::version{ 0+$ver }->{ $name }; + + return $core; + } + + ### make sure Bundle-Foo also gets flagged as bundle + sub is_bundle { + my $self = shift; + + ### cpan'd bundle + return 1 if $self->module =~ /^bundle(?:-|::)/i; + + ### autobundle + return 1 if $self->is_autobundle; + + ### neither + return; + } + + ### full path to a generated autobundle + sub is_autobundle { + my $self = shift; + my $conf = $self->parent->configure_object; + my $prefix = $conf->_get_build('autobundle_prefix'); + + return 1 if $self->module eq $prefix; + return; + } + + sub is_third_party { + my $self = shift; + + return unless can_load( modules => { 'Module::ThirdParty' => 0 } ); + + return Module::ThirdParty::is_3rd_party( $self->name ); + } + + sub third_party_information { + my $self = shift; + + return unless $self->is_third_party; + + return Module::ThirdParty::module_information( $self->name ); + } +} + +=pod + +=head2 $clone = $self->clone + +Clones the current module object for tinkering with. +It will have a clean C<CPANPLUS::Module::Status> object, as well as +a fake C<CPANPLUS::Module::Author> object. + +=cut + +{ ### accessors dont change during run time, so only compute once + my @acc = grep !/status/, __PACKAGE__->accessors(); + + sub clone { + my $self = shift; + + ### clone the object ### + my %data = map { $_ => $self->$_ } @acc; + + my $obj = CPANPLUS::Module::Fake->new( %data ); + + return $obj; + } +} + +=pod + +=head2 $where = $self->fetch + +Fetches the module from a CPAN mirror. +Look at L<CPANPLUS::Internals::Fetch::_fetch()> for details on the +options you can pass. + +=cut + +sub fetch { + my $self = shift; + my $cb = $self->parent; + + ### custom args + my %args = ( module => $self ); + + ### if a custom fetch location got specified before, add that here + $args{fetch_from} = $self->status->_fetch_from + if $self->status->_fetch_from; + + my $where = $cb->_fetch( @_, %args ) or return; + + ### do an md5 check ### + if( !$self->status->_fetch_from and + $cb->configure_object->get_conf('md5') and + $self->package ne CHECKSUMS + ) { + unless( $self->_validate_checksum ) { + error( loc( "Checksum error for '%1' -- will not trust package", + $self->package) ); + return; + } + } + + return $where; +} + +=pod + +=head2 $path = $self->extract + +Extracts the fetched module. +Look at L<CPANPLUS::Internals::Extract::_extract()> for details on +the options you can pass. + +=cut + +sub extract { + my $self = shift; + my $cb = $self->parent; + + unless( $self->status->fetch ) { + error( loc( "You have not fetched '%1' yet -- cannot extract", + $self->module) ); + return; + } + + ### can't extract these, so just use the basedir for the file + if( $self->is_autobundle ) { + + ### this is expected to be set after an extract call + $self->get_installer_type; + + return $self->status->extract( dirname( $self->status->fetch ) ); + } + + return $cb->_extract( @_, module => $self ); +} + +=head2 $type = $self->get_installer_type([prefer_makefile => BOOL]) + +Gets the installer type for this module. This may either be C<build> or +C<makemaker>. If C<Module::Build> is unavailable or no installer type +is available, it will fall back to C<makemaker>. If both are available, +it will pick the one indicated by your config, or by the +C<prefer_makefile> option you can pass to this function. + +Returns the installer type on success, and false on error. + +=cut + +sub get_installer_type { + my $self = shift; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my ($prefer_makefile,$verbose); + my $tmpl = { + prefer_makefile => { default => $conf->get_conf('prefer_makefile'), + store => \$prefer_makefile, allow => BOOLEANS }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + check( $tmpl, \%hash ) or return; + + my $type; + + ### autobundles use their own installer, so return that + if( $self->is_autobundle ) { + $type = INSTALLER_AUTOBUNDLE; + + } else { + my $extract = $self->status->extract(); + unless( $extract ) { + error(loc( + "Cannot determine installer type of unextracted module '%1'", + $self->module + )); + return; + } + + ### check if it's a makemaker or a module::build type dist ### + my $found_build = -e BUILD_PL->( $extract ); + my $found_makefile = -e MAKEFILE_PL->( $extract ); + + $type = INSTALLER_BUILD if !$prefer_makefile && $found_build; + $type = INSTALLER_BUILD if $found_build && !$found_makefile; + $type = INSTALLER_MM if $prefer_makefile && $found_makefile; + $type = INSTALLER_MM if $found_makefile && !$found_build; + } + + ### ok, so it's a 'build' installer, but you don't /have/ module build + ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow? + if( $type and $type eq INSTALLER_BUILD and ( + not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD ) + or not $cb->module_tree( INSTALLER_BUILD ) + ->is_uptodate( version => '0.24' ) + ) ) { + + ### XXX this is for recording purposes only. We *have* to install + ### these before even creating a dist object, or we'll get an error + ### saying 'no such dist type'; + ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow? + my $href = $self->status->configure_requires || {}; + my $deps = { INSTALLER_BUILD, '0.24', %$href }; + + $self->status->configure_requires( $deps ); + + msg(loc("This module requires '%1' and '%2' to be installed first. ". + "Adding these modules to your prerequisites list", + 'Module::Build', INSTALLER_BUILD + ), $verbose ); + + + ### ok, actually we found neither ### + } elsif ( !$type ) { + error( loc( "Unable to find '%1' or '%2' for '%3'; ". + "Will default to '%4' but might be unable ". + "to install!", BUILD_PL->(), MAKEFILE_PL->(), + $self->module, INSTALLER_MM ) ); + $type = INSTALLER_MM; + } + + return $self->status->installer_type( $type ) if $type; + return; +} + +=pod + +=head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]); + +Create a distribution object, ready to be installed. +Distribution type defaults to your config settings + +The optional C<args> hashref is passed on to the specific distribution +types' C<create> method after being dereferenced. + +Returns a distribution object on success, false on failure. + +See C<CPANPLUS::Dist> for details. + +=cut + +sub dist { + my $self = shift; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + ### have you determined your installer type yet? if not, do it here, + ### we need the info + $self->get_installer_type unless $self->status->installer_type; + + my($type,$args,$target); + my $tmpl = { + format => { default => $conf->get_conf('dist_type') || + $self->status->installer_type, + store => \$type }, + target => { default => TARGET_CREATE, store => \$target }, + args => { default => {}, store => \$args }, + }; + + check( $tmpl, \%hash ) or return; + + ### ok, check for $type. Do we have it? + unless( CPANPLUS::Dist->has_dist_type( $type ) ) { + + ### ok, we don't have it. Is it C::D::Build? if so we can install the + ### whole thing now + ### XXX we _could_ do this for any type we dont have actually... + if( $type eq INSTALLER_BUILD ) { + msg(loc("Bootstrapping installer '%1'", $type)); + + ### don't propagate the format, it's the one we're trying to + ### bootstrap, so it'll be an infinite loop if we do + + $cb->module_tree( $type )->install( target => $target, %$args ) or + do { + error(loc("Could not bootstrap installer '%1' -- ". + "can not continue", $type)); + return; + }; + + ### re-scan for available modules now + CPANPLUS::Dist->rescan_dist_types; + + unless( CPANPLUS::Dist->has_dist_type( $type ) ) { + error(loc("Newly installed installer type '%1' should be ". + "available, but is not! -- aborting", $type)); + return; + } else { + msg(loc("Installer '%1' succesfully bootstrapped", $type)); + } + + ### some other plugin you dont have. Abort + } else { + error(loc("Installer type '%1' not found. Please verify your ". + "installation -- aborting", $type )); + return; + } + } + + ### make sure we don't overwrite it, just in case we came + ### back from a ->save_state. This allows restoration to + ### work correctly + my( $dist, $dist_cpan ); + + unless( $dist = $self->status->dist ) { + $dist = $type->new( module => $self ) or return; + $self->status->dist( $dist ); + } + + unless( $dist_cpan = $self->status->dist_cpan ) { + + $dist_cpan = $type eq $self->status->installer_type + ? $self->status->dist + : $self->status->installer_type->new( module => $self ); + + + $self->status->dist_cpan( $dist_cpan ); + } + + + DIST: { + ### just wanted the $dist object? + last DIST if $target eq TARGET_INIT; + + ### first prepare the dist + $dist->prepare( %$args ) or return; + $self->status->prepared(1); + + ### you just wanted us to prepare? + last DIST if $target eq TARGET_PREPARE; + + $dist->create( %$args ) or return; + $self->status->created(1); + } + + return $dist; +} + +=pod + +=head2 $bool = $mod->prepare( ) + +Convenience method around C<install()> that prepares a module +without actually building it. This is equivalent to invoking C<install> +with C<target> set to C<prepare> + +Returns true on success, false on failure. + +=cut + +sub prepare { + my $self = shift; + return $self->install( @_, target => TARGET_PREPARE ); +} + +=head2 $bool = $mod->create( ) + +Convenience method around C<install()> that creates a module. +This is equivalent to invoking C<install> with C<target> set to +C<create> + +Returns true on success, false on failure. + +=cut + +sub create { + my $self = shift; + return $self->install( @_, target => TARGET_CREATE ); +} + +=head2 $bool = $mod->test( ) + +Convenience wrapper around C<install()> that tests a module, without +installing it. +It's the equivalent to invoking C<install()> with C<target> set to +C<create> and C<skiptest> set to C<0>. + +Returns true on success, false on failure. + +=cut + +sub test { + my $self = shift; + return $self->install( @_, target => TARGET_CREATE, skiptest => 0 ); +} + +=pod + +=head2 $bool = $self->install([ target => 'init|prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]); + +Installs the current module. This includes fetching it and extracting +it, if this hasn't been done yet, as well as creating a distribution +object for it. + +This means you can pass it more arguments than described above, which +will be passed on to the relevant methods as they are called. + +See C<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and +C<CPANPLUS::Dist> for details. + +Returns true on success, false on failure. + +=cut + +sub install { + my $self = shift; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $args; my $target; my $format; + { ### so we can use the rest of the args to the create calls etc ### + local $Params::Check::NO_DUPLICATES = 1; + local $Params::Check::ALLOW_UNKNOWN = 1; + + ### targets 'dist' and 'test' are now completely ignored ### + my $tmpl = { + ### match this allow list with Dist->_resolve_prereqs + target => { default => TARGET_INSTALL, store => \$target, + allow => [TARGET_PREPARE, TARGET_CREATE, + TARGET_INSTALL, TARGET_INIT ] }, + force => { default => $conf->get_conf('force'), }, + verbose => { default => $conf->get_conf('verbose'), }, + format => { default => $conf->get_conf('dist_type'), + store => \$format }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + + ### if this target isn't 'install', we will need to at least 'create' + ### every prereq, so it can build + ### XXX prereq_target of 'prepare' will do weird things here, and is + ### not supported. + $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL; + + ### check if it's already upto date ### + if( $target eq TARGET_INSTALL and !$args->{'force'} and + !$self->package_is_perl_core() and # separate rules apply + ( $self->status->installed() or $self->is_uptodate ) and + !INSTALL_VIA_PACKAGE_MANAGER->($format) + ) { + msg(loc("Module '%1' already up to date, won't install without force", + $self->module), $args->{'verbose'} ); + return $self->status->installed(1); + } + + # if it's a non-installable core package, abort the install. + if( $self->package_is_perl_core() ) { + # if the installed is newer, say so. + if( $self->installed_version > $self->version ) { + error(loc("The core Perl %1 module '%2' (%3) is more ". + "recent than the latest release on CPAN (%4). ". + "Aborting install.", + $], $self->module, $self->installed_version, + $self->version ) ); + # if the installed matches, say so. + } elsif( $self->installed_version == $self->version ) { + error(loc("The core Perl %1 module '%2' (%3) can only ". + "be installed by Perl itself. ". + "Aborting install.", + $], $self->module, $self->installed_version ) ); + # otherwise, the installed is older; say so. + } else { + error(loc("The core Perl %1 module '%2' can only be ". + "upgraded from %3 to %4 by Perl itself (%5). ". + "Aborting install.", + $], $self->module, $self->installed_version, + $self->version, $self->package ) ); + } + return; + + ### it might be a known 3rd party module + } elsif ( $self->is_third_party ) { + my $info = $self->third_party_information; + error(loc( + "%1 is a known third-party module.\n\n". + "As it isn't available on the CPAN, CPANPLUS can't install " . + "it automatically. Therefore you need to install it manually " . + "before proceeding.\n\n". + "%2 is part of %3, published by %4, and should be available ". + "for download at the following address:\n\t%5", + $self->name, $self->name, $info->{name}, $info->{author}, + $info->{url} + )); + + return; + } + + ### fetch it if need be ### + unless( $self->status->fetch ) { + my $params; + for (qw[prefer_bin fetchdir]) { + $params->{$_} = $args->{$_} if exists $args->{$_}; + } + for (qw[force verbose]) { + $params->{$_} = $args->{$_} if defined $args->{$_}; + } + $self->fetch( %$params ) or return; + } + + ### extract it if need be ### + unless( $self->status->extract ) { + my $params; + for (qw[prefer_bin extractdir]) { + $params->{$_} = $args->{$_} if exists $args->{$_}; + } + for (qw[force verbose]) { + $params->{$_} = $args->{$_} if defined $args->{$_}; + } + $self->extract( %$params ) or return; + } + + $args->{'prereq_format'} = $format if $format; + $format ||= $self->status->installer_type; + + unless( $format ) { + error( loc( "Don't know what installer to use; " . + "Couldn't find either '%1' or '%2' in the extraction " . + "directory '%3' -- will be unable to install", + BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) ); + + $self->status->installed(0); + return; + } + + + ### do SIGNATURE checks? ### + ### XXX check status and not recheck EVERY time? + if( $conf->get_conf('signature') ) { + unless( $self->check_signature( verbose => $args->{verbose} ) ) { + error( loc( "Signature check failed for module '%1' ". + "-- Not trusting this module, aborting install", + $self->module ) ); + $self->status->signature(0); + + ### send out test report on broken sig + if( $conf->get_conf('cpantest') ) { + $cb->_send_report( + module => $self, + failed => 1, + buffer => CPANPLUS::Error->stack_as_string, + verbose => $args->{verbose}, + force => $args->{force}, + ) or error(loc("Failed to send test report for '%1'", + $self->module ) ); + } + + return; + + } else { + ### signature OK ### + $self->status->signature(1); + } + } + + ### a target of 'create' basically means not to run make test ### + ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1. + #$args->{'skiptest'} = 1 if $target eq 'create'; + + ### bundle rules apply ### + if( $self->is_bundle ) { + ### check what we need to install ### + my @prereqs = $self->bundle_modules(); + unless( @prereqs ) { + error( loc( "Bundle '%1' does not specify any modules to install", + $self->module ) ); + + ### XXX mark an error here? ### + } + } + + my $dist = $self->dist( format => $format, + target => $target, + args => $args ); + unless( $dist ) { + error( loc( "Unable to create a new distribution object for '%1' " . + "-- cannot continue", $self->module ) ); + return; + } + + return 1 if $target ne TARGET_INSTALL; + + my $ok = $dist->install( %$args ) ? 1 : 0; + + $self->status->installed($ok); + + return 1 if $ok; + return; +} + +=pod @list = $self->bundle_modules() + +Returns a list of module objects the Bundle specifies. + +This requires you to have extracted the bundle already, using the +C<extract()> method. + +Returns false on error. + +=cut + +sub bundle_modules { + my $self = shift; + my $cb = $self->parent; + + unless( $self->is_bundle ) { + error( loc("'%1' is not a bundle", $self->module ) ); + return; + } + + my @files; + + ### autobundles are special files generated by CPANPLUS. If we can + ### read the file, we can determine the prereqs + if( $self->is_autobundle ) { + my $where; + unless( $where = $self->status->fetch ) { + error(loc("Don't know where '%1' was fetched to", $self->package)); + return; + } + + push @files, $where + + ### regular bundle::* upload + } else { + my $dir; + unless( $dir = $self->status->extract ) { + error(loc("Don't know where '%1' was extracted to", $self->module)); + return; + } + + find( { + wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i }, + no_chdir => 1, + }, $dir ); + } + + my $prereqs = {}; my @list; my $seen = {}; + for my $file ( @files ) { + my $fh = FileHandle->new($file) + or( error(loc("Could not open '%1' for reading: %2", + $file,$!)), next ); + + my $flag; + while( local $_ = <$fh> ) { + ### quick hack to read past the header of the file ### + last if $flag && m|^=head|i; + + ### from perldoc cpan: + ### =head1 CONTENTS + ### In this pod section each line obeys the format + ### Module_Name [Version_String] [- optional text] + $flag = 1 if m|^=head1 CONTENTS|i; + + if ($flag && /^(?!=)(\S+)\s*(\S+)?/) { + my $module = $1; + my $version = $cb->_version_to_number( version => $2 ); + + my $obj = $cb->module_tree($module); + + unless( $obj ) { + error(loc("Cannot find bundled module '%1'", $module), + loc("-- it does not seem to exist") ); + next; + } + + ### make sure we list no duplicates ### + unless( $seen->{ $obj->module }++ ) { + push @list, $obj; + $prereqs->{ $module } = + $cb->_version_to_number( version => $version ); + } + } + } + } + + ### store the prereqs we just found ### + $self->status->prereqs( $prereqs ); + + return @list; +} + +=pod + +=head2 $text = $self->readme + +Fetches the readme belonging to this module and stores it under +C<< $obj->status->readme >>. Returns the readme as a string on +success and returns false on failure. + +=cut + +sub readme { + my $self = shift; + my $conf = $self->parent->configure_object; + + ### did we already dl the readme once? ### + return $self->status->readme() if $self->status->readme(); + + ### this should be core ### + return unless can_load( modules => { FileHandle => '0.0' }, + verbose => 1, + ); + + ### get a clone of the current object, with a fresh status ### + my $obj = $self->clone or return; + + ### munge the package name + my $pkg = README->( $obj ); + $obj->package($pkg); + + my $file; + { ### disable checksum fetches on readme downloads + + my $tmp = $conf->get_conf( 'md5' ); + $conf->set_conf( md5 => 0 ); + + $file = $obj->fetch; + + $conf->set_conf( md5 => $tmp ); + + return unless $file; + } + + ### read the file into a scalar, to store in the original object ### + my $fh = new FileHandle; + unless( $fh->open($file) ) { + error( loc( "Could not open file '%1': %2", $file, $! ) ); + return; + } + + my $in = do{ local $/; <$fh> }; + $fh->close; + + return $self->status->readme( $in ); +} + +=pod + +=head2 $version = $self->installed_version() + +Returns the currently installed version of this module, if any. + +=head2 $where = $self->installed_file() + +Returns the location of the currently installed file of this module, +if any. + +=head2 $dir = $self->installed_dir() + +Returns the directory (or more accurately, the C<@INC> handle) from +which this module was loaded, if any. + +=head2 $bool = $self->is_uptodate([version => VERSION_NUMBER]) + +Returns a boolean indicating if this module is uptodate or not. + +=cut + +### uptodate/installed functions +{ my $map = { # hashkey, alternate rv + installed_version => ['version', 0 ], + installed_file => ['file', ''], + installed_dir => ['dir', ''], + is_uptodate => ['uptodate', 0 ], + }; + + while( my($method, $aref) = each %$map ) { + my($key,$alt_rv) = @$aref; + + no strict 'refs'; + *$method = sub { + ### never use the @INC hooks to find installed versions of + ### modules -- they're just there in case they're not on the + ### perl install, but the user shouldn't trust them for *other* + ### modules! + ### XXX CPANPLUS::inc is now obsolete, so this should not + ### be needed anymore + #local @INC = CPANPLUS::inc->original_inc; + + my $self = shift; + + ### make sure check_install is not looking in %INC, as + ### that may contain some of our sneakily loaded modules + ### that aren't installed as such. -- kane + local $Module::Load::Conditional::CHECK_INC_HASH = 0; + ### this should all that is required for deprecated core modules + local $Module::Load::Conditional::DEPRECATED = 1; + my $href = check_install( + module => $self->module, + version => $self->version, + @_, + ); + + return $href->{$key} || $alt_rv; + } + } +} + + + +=pod + +=head2 $href = $self->details() + +Returns a hashref with key/value pairs offering more information about +a particular module. For example, for C<Time::HiRes> it might look like +this: + + Author Jarkko Hietaniemi (jhi@iki.fi) + Description High resolution time, sleep, and alarm + Development Stage Released + Installed File /usr/local/perl/lib/Time/Hires.pm + Interface Style plain Functions, no references used + Language Used C and perl, a C compiler will be needed + Package Time-HiRes-1.65.tar.gz + Public License Unknown + Support Level Developer + Version Installed 1.52 + Version on CPAN 1.65 + +=cut + +sub details { + my $self = shift; + my $conf = $self->parent->configure_object(); + my $cb = $self->parent; + my %hash = @_; + + my $res = { + Author => loc("%1 (%2)", $self->author->author(), + $self->author->email() ), + Package => $self->package, + Description => $self->description || loc('None given'), + 'Version on CPAN' => $self->version, + }; + + ### check if we have the module installed + ### if so, add version have and version on cpan + $res->{'Version Installed'} = $self->installed_version + if $self->installed_version; + $res->{'Installed File'} = $self->installed_file if $self->installed_file; + + my $i = 0; + for my $item( split '', $self->dslip ) { + $res->{ $cb->_dslip_defs->[$i]->[0] } = + $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown'); + $i++; + } + + return $res; +} + +=head2 @list = $self->contains() + +Returns a list of module objects that represent the modules also +present in the package of this module. + +For example, for C<Archive::Tar> this might return: + + Archive::Tar + Archive::Tar::Constant + Archive::Tar::File + +=cut + +sub contains { + my $self = shift; + my $cb = $self->parent; + my $pkg = $self->package; + + my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] ); + + return @mods; +} + +=pod + +=head2 @list_of_hrefs = $self->fetch_report() + +This function queries the CPAN testers database at +I<http://testers.cpan.org/> for test results of specified module +objects, module names or distributions. + +Look at L<CPANPLUS::Internals::Report::_query_report()> for details on +the options you can pass and the return value to expect. + +=cut + +sub fetch_report { + my $self = shift; + my $cb = $self->parent; + + return $cb->_query_report( @_, module => $self ); +} + +=pod + +=head2 $bool = $self->uninstall([type => [all|man|prog]) + +This function uninstalls the specified module object. + +You can install 2 types of files, either C<man> pages or C<prog>ram +files. Alternately you can specify C<all> to uninstall both (which +is the default). + +Returns true on success and false on failure. + +Do note that this does an uninstall via the so-called C<.packlist>, +so if you used a module installer like say, C<ports> or C<apt>, you +should not use this, but use your package manager instead. + +=cut + +sub uninstall { + my $self = shift; + my $conf = $self->parent->configure_object(); + my %hash = @_; + + my ($type,$verbose); + my $tmpl = { + type => { default => 'all', allow => [qw|man prog all|], + store => \$type }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + force => { default => $conf->get_conf('force') }, + }; + + ### XXX add a warning here if your default install dist isn't + ### makefile or build -- that means you are using a package manager + ### and this will not do what you think! + + my $args = check( $tmpl, \%hash ) or return; + + if( $conf->get_conf('dist_type') and ( + ($conf->get_conf('dist_type') ne INSTALLER_BUILD) or + ($conf->get_conf('dist_type') ne INSTALLER_MM)) + ) { + msg(loc("You have a default installer type set (%1) ". + "-- you should probably use that package manager to " . + "uninstall modules", $conf->get_conf('dist_type')), $verbose); + } + + ### check if we even have the module installed -- no point in continuing + ### otherwise + unless( $self->installed_version ) { + error( loc( "Module '%1' is not installed, so cannot uninstall", + $self->module ) ); + return; + } + + ### nothing to uninstall ### + my $files = $self->files( type => $type ) or return; + my $dirs = $self->directory_tree( type => $type ) or return; + my $sudo = $conf->get_program('sudo'); + + ### just in case there's no file; M::B doensn't provide .packlists yet ### + my $pack = $self->packlist; + $pack = $pack->[0]->packlist_file() if $pack; + + ### first remove the files, then the dirs if they are empty ### + my $flag = 0; + for my $file( @$files, $pack ) { + next unless defined $file && -f $file; + + msg(loc("Unlinking '%1'", $file), $verbose); + + my @cmd = ($^X, "-eunlink+q[$file]"); + unshift @cmd, $sudo if $sudo; + + my $buffer; + unless ( run( command => \@cmd, + verbose => $verbose, + buffer => \$buffer ) + ) { + error(loc("Failed to unlink '%1': '%2'",$file, $buffer)); + $flag++; + } + } + + for my $dir ( sort @$dirs ) { + local *DIR; + opendir DIR, $dir or next; + my @count = readdir(DIR); + close DIR; + + next unless @count == 2; # . and .. + + msg(loc("Removing '%1'", $dir), $verbose); + + ### this fails on my win2k machines.. it indeed leaves the + ### dir, but it's not a critical error, since the files have + ### been removed. --kane + #unless( rmdir $dir ) { + # error( loc( "Could not remove '%1': %2", $dir, $! ) ) + # unless $^O eq 'MSWin32'; + #} + + my @cmd = ($^X, "-e", "rmdir q[$dir]"); + unshift @cmd, $sudo if $sudo; + + my $buffer; + unless ( run( command => \@cmd, + verbose => $verbose, + buffer => \$buffer ) + ) { + error(loc("Failed to rmdir '%1': %2",$dir,$buffer)); + $flag++; + } + } + + $self->status->uninstall(!$flag); + $self->status->installed( $flag ? 1 : undef); + + return !$flag; +} + +=pod + +=head2 @modobj = $self->distributions() + +Returns a list of module objects representing all releases for this +module on success, false on failure. + +=cut + +sub distributions { + my $self = shift; + my %hash = @_; + + my @list = $self->author->distributions( %hash, module => $self ) or return; + + ### it's another release then by the same author ### + return grep { $_->package_name eq $self->package_name } @list; +} + +=pod + +=head2 @list = $self->files () + +Returns a list of files used by this module, if it is installed. + +=head2 @list = $self->directory_tree () + +Returns a list of directories used by this module. + +=head2 @list = $self->packlist () + +Returns the C<ExtUtils::Packlist> object for this module. + +=head2 @list = $self->validate () + +Returns a list of files that are missing for this modules, but +are present in the .packlist file. + +=cut + +for my $sub (qw[files directory_tree packlist validate]) { + no strict 'refs'; + *$sub = sub { + return shift->_extutils_installed( @_, method => $sub ); + } +} + +### generic method to call an ExtUtils::Installed method ### +sub _extutils_installed { + my $self = shift; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my $home = $cb->_home_dir; # may be needed to fix up prefixes + my %hash = @_; + + my ($verbose,$type,$method); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose, }, + type => { default => 'all', + allow => [qw|prog man all|], + store => \$type, }, + method => { required => 1, + store => \$method, + allow => [qw|files directory_tree packlist + validate|], + }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### old versions of cygwin + perl < 5.8 are buggy here. bail out if we + ### find we're being used by them + { my $err = ON_OLD_CYGWIN; + if($err) { error($err); return }; + } + + return unless can_load( + modules => { 'ExtUtils::Installed' => '0.0' }, + verbose => $verbose, + ); + + my @config_names = ( + ### lib + { lib => 'privlib', # perl-only + arch => 'archlib', # compiled code + prefix => 'prefix', # prefix to both + }, + ### site + { lib => 'sitelib', + arch => 'sitearch', + prefix => 'siteprefix', + }, + ### vendor + { lib => 'vendorlib', + arch => 'vendorarch', + prefix => 'vendorprefix', + }, + ); + + ### search in your regular @INC, and anything you added to your config. + ### this lets EU::Installed find .packlists that are *not* in the standard + ### compiled in @INC path. Requires EU::I 1.42 or up. this addresses #33438 + ### make sure the archname path is also added, as that's where the .packlist + ### files are written + my @libs; + for my $lib ( @{ $conf->get_conf('lib') } ) { + require Config; + + ### and just the standard dir + push @libs, $lib; + + ### figure out what an MM prefix expands to. Basically, it's the + ### site install target from %Config, ie: /opt/lib/perl5/site_perl/5.8.8 + ### minus the site wide prefix, ie: /opt + ### this lets users add the dir they have set as their EU::MM PREFIX + ### to our 'lib' config and it Just Works + ### the arch specific dir, ie: + ### /opt/lib/perl5/site_perl/5.8.8/darwin-2level + ### XXX is this the right thing to do? + + ### we add all 6 dir combos for prefixes: + ### /foo/lib + ### /foo/lib/arch + ### /foo/site/lib + ### /foo/site/lib/arch + ### /foo/vendor/lib + ### /foo/vendor/lib/arch + for my $href ( @config_names ) { + for my $key ( qw[lib arch] ) { + + ### look up the config value -- use EXP for the EXPANDED + ### version, so no ~ etc are found in there + my $dir = $Config::Config{ $href->{ $key } .'exp' } or next; + my $prefix = $Config::Config{ $href->{prefix} }; + + ### prefix may be relative to home, and contain a ~ + ### if so, fix it up. + $prefix =~ s/^~/$home/; + + ### remove the prefix from it, so we can append to our $lib + $dir =~ s/^\Q$prefix\E//; + + ### do the appending + push @libs, File::Spec->catdir( $lib, $dir ); + + } + } + } + + my $inst; + unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) { + error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) ); + + ### in case it's being used directly... ### + return; + } + + + { ### EU::Installed can die =/ + my @files; + eval { @files = $inst->$method( $self->module, $type ) }; + + if( $@ ) { + chomp $@; + error( loc("Could not get '%1' for '%2': %3", + $method, $self->module, $@ ) ); + return; + } + + return wantarray ? @files : \@files; + } +} + +=head2 $bool = $self->add_to_includepath; + +Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows +you to add the module from its build dir to your path. + +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), + File::Spec->catdir(BLIB->($dir), ARCH), + BLIB->($dir), + ] + ) or return; + + } else { + error(loc( "No extract dir registered for '%1' -- can not add ". + "add builddir to search path!", $self->module )); + return; + } + + return 1; + +} + +=pod + +=head2 $path = $self->best_path_to_module_build(); + +B<OBSOLETE> + +If a newer version of Module::Build is found in your path, it will +return this C<special> path. If the newest version of C<Module::Build> +is found in your regular C<@INC>, the method will return false. This +indicates you do not need to add a special directory to your C<@INC>. + +Note that this is only relevant if you're building your own +C<CPANPLUS::Dist::*> plugin -- the built-in dist types already have +this taken care of. + +=cut + +### make sure we're always running 'perl Build.PL' and friends +### against the highest version of module::build available +sub best_path_to_module_build { + my $self = shift; + + ### Since M::B will actually shell out and run the Build.PL, we must + ### make sure it refinds the proper version of M::B in the path. + ### that may be either in our cp::inc or in site_perl, or even a + ### new M::B being installed. + ### don't add anything else here, as that might screw up prereq checks + + ### XXX this might be needed for Dist::MM too, if a makefile.pl is + ### masquerading as a Build.PL + + ### did we find the most recent module::build in our installer path? + + ### XXX can't do changes to @INC, they're being ignored by + ### new_from_context when writing a Build script. see ticket: + ### #8826 Module::Build ignores changes to @INC when writing Build + ### from new_from_context + ### XXX applied schwern's patches (as seen on CPANPLUS::Devel 10/12/04) + ### and upped the version to 0.26061 of the bundled version, and things + ### work again + + ### this functionality is now obsolete -- prereqs should be installed + ### and we no longer use the CPANPLUS::inc magic.. so comment this out. +# require Module::Build; +# if( CPANPLUS::inc->path_to('Module::Build') and ( +# CPANPLUS::inc->path_to('Module::Build') eq +# CPANPLUS::inc->installer_path ) +# ) { +# +# ### if the module being installed is *not* Module::Build +# ### itself -- as that would undoubtedly be newer -- add +# ### the path to the installers to @INC +# ### if it IS module::build itself, add 'lib' to its path, +# ### as the Build.PL would do as well, but the API doesn't. +# ### this makes self updates possible +# return $self->module eq 'Module::Build' +# ? 'lib' +# : CPANPLUS::inc->installer_path; +# } + + ### otherwise, the path was found through a 'normal' way of + ### scanning @INC. + return; +} + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + +1; + +__END__ + +todo: +reports(); diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Author.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Author.pm new file mode 100755 index 00000000000..92940fa51ff --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Author.pm @@ -0,0 +1,232 @@ +package CPANPLUS::Module::Author; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; +use Params::Check qw[check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Module::Author + +=head1 SYNOPSIS + + my $author = CPANPLUS::Module::Author->new( + author => 'Jack Ashton', + cpanid => 'JACKASH', + _id => INTERNALS_OBJECT_ID, + ); + + $author->cpanid; + $author->author; + $author->email; + + @dists = $author->distributions; + @mods = $author->modules; + + @accessors = CPANPLUS::Module::Author->accessors; + +=head1 DESCRIPTION + +C<CPANPLUS::Module::Author> creates objects from the information in the +source files. These can then be used to query on. + +These objects should only be created internally. For C<fake> objects, +there's the C<CPANPLUS::Module::Author::Fake> class. + +=head1 ACCESSORS + +An objects of this class has the following accessors: + +=over 4 + +=item author + +Name of the author. + +=item cpanid + +The CPAN id of the author. + +=item email + +The email address of the author, which defaults to '' if not provided. + +=item parent + +The C<CPANPLUS::Internals::Object> that spawned this module object. + +=back + +=cut + +my $tmpl = { + author => { required => 1 }, # full name of the author + cpanid => { required => 1 }, # cpan id + email => { default => '' }, # email address of the author + _id => { required => 1 }, # id of the Internals object that spawned us +}; + +### autogenerate accessors ### +for my $key ( keys %$tmpl ) { + no strict 'refs'; + *{__PACKAGE__."::$key"} = sub { + my $self = shift; + $self->{$key} = $_[0] if @_; + return $self->{$key}; + } +} + +sub parent { + my $self = shift; + my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id ); + + return $obj; +} + +=pod + +=head1 METHODS + +=head2 $auth = CPANPLUS::Module::Author->new( author => AUTHOR_NAME, cpanid => CPAN_ID, _id => INTERNALS_ID [, email => AUTHOR_EMAIL] ) + +This method returns a C<CPANPLUS::Module::Author> object, based on the given +parameters. + +Returns false on failure. + +=cut + +sub new { + my $class = shift; + my %hash = @_; + + ### don't check the template for sanity + ### -- we know it's good and saves a lot of performance + local $Params::Check::SANITY_CHECK_TEMPLATE = 0; + + my $object = check( $tmpl, \%hash ) or return; + + return bless $object, $class; +} + +=pod + +=head2 @mod_objs = $auth->modules() + +Return a list of module objects this author has released. + +=cut + +sub modules { + my $self = shift; + my $cb = $self->parent; + + my $aref = $cb->_search_module_tree( + type => 'author', + ### XXX, depending on backend, this is either an object + ### or the cpanid string. Dont know an elegant way to + ### solve this right now, so passing both + allow => [$self, $self->cpanid], + ); + return @$aref if $aref; + return; +} + +=pod + +=head2 @dists = $auth->distributions() + +Returns a list of module objects representing all the distributions +this author has released. + +=cut + +sub distributions { + my $self = shift; + my %hash = @_; + + local $Params::Check::ALLOW_UNKNOWN = 1; + local $Params::Check::NO_DUPLICATES = 1; + + my $mod; + my $tmpl = { + module => { default => '', store => \$mod }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### if we didn't get a module object passed, we'll find one ourselves ### + unless( $mod ) { + my @list = $self->modules; + if( @list ) { + $mod = $list[0]; + } else { + error( loc( "This author has released no modules" ) ); + return; + } + } + + my $file = $mod->checksums( %hash ); + my $href = $mod->_parse_checksums_file( file => $file ) or return; + + my @rv; + for my $name ( keys %$href ) { + + ### shortcut asap, so we avoid extra ops. On big checksums files + ### the call to clone() takes up a lot of time. + ### .meta files are now also in the checksums file, + ### which means we have to filter out things that dont + ### match our regex + next if $mod->package_extension( $name ) eq META_EXT; + + ### used to do this wiht ->clone. However, that calls ->dslip, + ### (which is wrong anyway, as we're doing a different module), + ### which in turn calls ->contains, which scans the entire + ### module tree using _search_module_tree, which uses P::C + ### and is therefor VERY VERY slow. + ### so let's do this the direct way for speed ups. + my $dist = CPANPLUS::Module::Fake->new( + module => do { my $m = $mod->package_name( $name ); + $m =~ s/-/::/g; $m; + }, + version => $mod->package_version( $name ), + package => $name, + path => $mod->path, # same author after all + author => $mod->author, # same author after all + mtime => $href->{$name}->{'mtime'}, # release date + ); + + push @rv, $dist; + } + + return @rv; +} + + +=pod + +=head1 CLASS METHODS + +=head2 accessors () + +Returns a list of all accessor methods to the object + +=cut + +sub accessors { return keys %$tmpl }; + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Author/Fake.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Author/Fake.pm new file mode 100755 index 00000000000..3156c5c7abb --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Author/Fake.pm @@ -0,0 +1,80 @@ +package CPANPLUS::Module::Author::Fake; + + +use CPANPLUS::Module::Author; +use CPANPLUS::Internals; +use CPANPLUS::Error; + +use strict; +use vars qw[@ISA]; +use Params::Check qw[check]; + +@ISA = qw[CPANPLUS::Module::Author]; + +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Module::Author::Fake + +=head1 SYNOPSIS + + my $auth = CPANPLUS::Module::Author::Fake->new( + author => 'Foo Bar', + email => 'luser@foo.com', + cpanid => 'FOO', + _id => $cpan->id, + ); + +=head1 DESCRIPTION + +A class for creating fake author objects, for shortcut use internally +by CPANPLUS. + +Inherits from C<CPANPLUS::Module::Author>. + +=head1 METHODS + +=head2 new( _id => DIGIT ) + +Creates a dummy author object. It can take the same options as +C<< CPANPLUS::Module::Author->new >>, but will fill in default ones +if none are provided. Only the _id key is required. + +=cut + +sub new { + my $class = shift; + my %hash = @_; + + my $tmpl = { + author => { default => 'CPANPLUS Internals' }, + email => { default => 'cpanplus-info@lists.sf.net' }, + cpanid => { default => 'CPANPLUS' }, + _id => { default => CPANPLUS::Internals->_last_id }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $obj = CPANPLUS::Module::Author->new( %$args ) or return; + + unless( $obj->_id ) { + error(loc("No '%1' specified -- No CPANPLUS object associated!",'_id')); + return; + } + + ### rebless object ### + return bless $obj, $class; +} + +1; + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Checksums.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Checksums.pm new file mode 100755 index 00000000000..e1a2bbdb6ad --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Checksums.pm @@ -0,0 +1,251 @@ +package CPANPLUS::Module::Checksums; + +use strict; +use vars qw[@ISA]; + + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use FileHandle; + +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; + +$Params::Check::VERBOSE = 1; + +@ISA = qw[ CPANPLUS::Module::Signature ]; + +=head1 NAME + +CPANPLUS::Module::Checksums + +=head1 SYNOPSIS + + $file = $modobj->checksums; + $bool = $mobobj->_validate_checksum; + +=head1 DESCRIPTION + +This is a class that provides functions for checking the checksum +of a distribution. Should not be loaded directly, but used via the +interface provided via C<CPANPLUS::Module>. + +=head1 METHODS + +=head2 $mod->checksums + +Fetches the checksums file for this module object. +For the options it can take, see C<CPANPLUS::Module::fetch()>. + +Returns the location of the checksums file on success and false +on error. + +The location of the checksums file is also stored as + + $mod->status->checksums + +=cut + +sub checksums { + my $mod = shift or return; + + my $file = $mod->_get_checksums_file( @_ ); + + return $mod->status->checksums( $file ) if $file; + + return; +} + +### checks if the package checksum matches the one +### from the checksums file +sub _validate_checksum { + my $self = shift; #must be isa CPANPLUS::Module + my $conf = $self->parent->configure_object; + my %hash = @_; + + my $verbose; + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + check( $tmpl, \%hash ) or return; + + ### if we can't check it, we must assume it's ok ### + return $self->status->checksum_ok(1) + unless can_load( modules => { 'Digest::MD5' => '0.0' } ); + #class CPANPLUS::Module::Status is runtime-generated + + my $file = $self->_get_checksums_file( verbose => $verbose ) or ( + error(loc(q[Could not fetch '%1' file], CHECKSUMS)), return ); + + $self->_check_signature_for_checksum_file( file => $file ) or ( + error(loc(q[Could not verify '%1' file], CHECKSUMS)), return ); + #for whole CHECKSUMS file + + my $href = $self->_parse_checksums_file( file => $file ) or ( + error(loc(q[Could not parse '%1' file], CHECKSUMS)), return ); + + my $size = $href->{ $self->package }->{'size'}; + + ### the checksums file tells us the size of the archive + ### but the downloaded file is of different size + if( defined $size ) { + if( not (-s $self->status->fetch == $size) ) { + error(loc( "Archive size does not match for '%1': " . + "size is '%2' but should be '%3'", + $self->package, -s $self->status->fetch, $size)); + return $self->status->checksum_ok(0); + } + } else { + msg(loc("Archive size is not known for '%1'",$self->package),$verbose); + } + + my $md5 = $href->{ $self->package }->{'md5'}; + + unless( defined $md5 ) { + msg(loc("No 'md5' checksum known for '%1'",$self->package),$verbose); + + return $self->status->checksum_ok(1); + } + + $self->status->checksum_value($md5); + + + my $fh = FileHandle->new( $self->status->fetch ) or return; + binmode $fh; + + my $ctx = Digest::MD5->new; + $ctx->addfile( $fh ); + + my $flag = $ctx->hexdigest eq $md5; + $flag + ? msg(loc("Checksum matches for '%1'", $self->package),$verbose) + : error(loc("Checksum does not match for '%1': " . + "MD5 is '%2' but should be '%3'", + $self->package, $ctx->hexdigest, $md5),$verbose); + + + return $self->status->checksum_ok(1) if $flag; + return $self->status->checksum_ok(0); +} + + +### fetches the module objects checksum file ### +sub _get_checksums_file { + my $self = shift; + my %hash = @_; + + my $clone = $self->clone; + $clone->package( CHECKSUMS ); + + my $file = $clone->fetch( ttl => 3600, %hash ) or return; + + return $file; +} + +sub _parse_checksums_file { + my $self = shift; + my %hash = @_; + + my $file; + my $tmpl = { + file => { required => 1, allow => FILE_READABLE, store => \$file }, + }; + my $args = check( $tmpl, \%hash ); + + my $fh = OPEN_FILE->( $file ) or return; + + ### loop over the header, there might be a pgp signature ### + my $signed; + while (local $_ = <$fh>) { + last if /^\$cksum = \{\s*$/; # skip till this line + my $header = PGP_HEADER; # but be tolerant of whitespace + $signed = 1 if /^${header}\s*$/;# due to crossplatform linebreaks + } + + ### read the filehandle, parse it rather than eval it, even though it + ### *should* be valid perl code + my $dist; + my $cksum = {}; + while (local $_ = <$fh>) { + + if (/^\s*'([^']+)' => \{\s*$/) { + $dist = $1; + + } elsif (/^\s*'([^']+)' => '?([^'\n]+)'?,?\s*$/ and defined $dist) { + $cksum->{$dist}{$1} = $2; + + } elsif (/^\s*}[,;]?\s*$/) { + undef $dist; + + } elsif (/^__END__\s*$/) { + last; + + } else { + error( loc("Malformed %1 line: %2", CHECKSUMS, $_) ); + } + } + + return $cksum; +} + +sub _check_signature_for_checksum_file { + my $self = shift; + + my $conf = $self->parent->configure_object; + my %hash = @_; + + ### you don't want to check signatures, + ### so let's just return true; + return 1 unless $conf->get_conf('signature'); + + my($force,$file,$verbose); + my $tmpl = { + file => { required => 1, allow => FILE_READABLE, store => \$file }, + force => { default => $conf->get_conf('force'), store => \$force }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $fh = OPEN_FILE->($file) or return; + + my $signed; + while (local $_ = <$fh>) { + my $header = PGP_HEADER; + $signed = 1 if /^$header$/; + } + + if ( !$signed ) { + msg(loc("No signature found in %1 file '%2'", + CHECKSUMS, $file), $verbose); + + return 1 unless $force; + + error( loc( "%1 file '%2' is not signed -- aborting", + CHECKSUMS, $file ) ); + return; + + } + + if( can_load( modules => { 'Module::Signature' => '0.06' } ) ) { + # local $Module::Signature::SIGNATURE = $file; + # ... check signatures ... + } + + return 1; +} + + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Fake.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Fake.pm new file mode 100755 index 00000000000..84d0233cf83 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Fake.pm @@ -0,0 +1,86 @@ +package CPANPLUS::Module::Fake; + + +use CPANPLUS::Error; +use CPANPLUS::Module; +use CPANPLUS::Module::Author::Fake; +use CPANPLUS::Internals; + +use strict; +use vars qw[@ISA]; +use Params::Check qw[check]; + +@ISA = qw[CPANPLUS::Module]; +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Module::Fake + +=head1 SYNOPSIS + + my $obj = CPANPLUS::Module::Fake->new( + module => 'Foo', + path => 'ftp/path/to/foo', + author => CPANPLUS::Module::Author::Fake->new, + package => 'fake-1.1.tgz', + _id => $cpan->_id, + ); + +=head1 DESCRIPTION + +A class for creating fake module objects, for shortcut use internally +by CPANPLUS. + +Inherits from C<CPANPLUS::Module>. + +=head1 METHODS + +=head2 new( module => $mod, path => $path, package => $pkg, [_id => DIGIT] ) + +Creates a dummy module object from the above parameters. It can +take more options (same as C<< CPANPLUS::Module->new >> but the above +are required. + +=cut + +sub new { + my $class = shift; + my %hash = @_; + + local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + module => { required => 1 }, + path => { required => 1 }, + package => { required => 1 }, + _id => { default => CPANPLUS::Internals->_last_id }, + author => { default => '' }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + $args->{author} ||= CPANPLUS::Module::Author::Fake->new( + _id => $args->{_id} ); + + my $obj = CPANPLUS::Module->new( %$args ) or return; + + unless( $obj->_id ) { + error(loc("No '%1' specified -- No CPANPLUS object associated!",'_id')); + return; + } + + ### rebless object ### + return bless $obj, $class; +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Signature.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Signature.pm new file mode 100755 index 00000000000..cec6f2906b0 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Module/Signature.pm @@ -0,0 +1,65 @@ +package CPANPLUS::Module::Signature; + +use strict; + + +use Cwd; +use CPANPLUS::Error; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; + + +### detached sig, not actually used afaik --kane ### +#sub get_signature { +# my $self = shift; +# +# my $clone = $self->clone; +# $clone->package( $self->package . '.sig' ); +# +# return $clone->fetch; +#} + +sub check_signature { + my $self = shift; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $verbose; + my $tmpl = { + verbose => {default => $conf->get_conf('verbose'), store => \$verbose}, + }; + + check( $tmpl, \%hash ) or return; + + my $dir = $self->status->extract or ( + error( loc( "Do not know what dir '%1' was extracted to; ". + "Cannot check signature", $self->module ) ), + return ); + + my $cwd = cwd(); + unless( $cb->_chdir( dir => $dir ) ) { + error(loc( "Could not chdir to '%1', cannot verify distribution '%2'", + $dir, $self->module )); + return; + } + + + ### check prerequisites + my $flag; + my $use_list = { 'Module::Signature' => '0.06' }; + if( can_load( modules => $use_list, verbose => 1 ) ) { + my $rv = Module::Signature::verify(); + + unless ($rv eq Module::Signature::SIGNATURE_OK() or + $rv eq Module::Signature::SIGNATURE_MISSING() + ) { + $flag++; # whoops, bad sig + } + } + + $cb->_chdir( dir => $cwd ); + return $flag ? 0 : 1; +} + +1; diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Selfupdate.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Selfupdate.pm new file mode 100755 index 00000000000..48f918ce82e --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Selfupdate.pm @@ -0,0 +1,547 @@ +package CPANPLUS::Selfupdate; + +use strict; +use Params::Check qw[check]; +use IPC::Cmd qw[can_run]; +use CPANPLUS::Error qw[error msg]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +use CPANPLUS::Internals::Constants; + +$Params::Check::VERBOSE = 1; + +=head1 NAME + +CPANPLUS::Selfupdate + +=head1 SYNOPSIS + + $su = $cb->selfupdate_object; + + @feats = $su->list_features; + @feats = $su->list_enabled_features; + + @mods = map { $su->modules_for_feature( $_ ) } @feats; + @mods = $su->list_core_dependencies; + @mods = $su->list_core_modules; + + for ( @mods ) { + print $_->name " should be version " . $_->version_required; + print "Installed version is not uptodate!" + unless $_->is_installed_version_sufficient; + } + + $ok = $su->selfupdate( update => 'all', latest => 0 ); + +=cut + +### a config has describing our deps etc +{ + + my $Modules = { + dependencies => { + 'File::Fetch' => '0.15_02', # lynx & 404 handling + 'File::Spec' => '0.82', + 'IPC::Cmd' => '0.36', # 5.6.2 compat: 2-arg open + 'Locale::Maketext::Simple' => '0.01', + 'Log::Message' => '0.01', + 'Module::Load' => '0.10', + 'Module::Load::Conditional' => '0.31_01', # returns dir for loaded + # modules + 'version' => '0.73', # needed for M::L::C + # addresses #24630 and + # #24675 + # Address ~0 overflow issue + 'Params::Check' => '0.22', + 'Package::Constants' => '0.01', + 'Term::UI' => '0.18', # option parsing + 'Test::Harness' => '2.62', # due to bug #19505 + # only 2.58 and 2.60 are bad + 'Test::More' => '0.47', # to run our tests + 'Archive::Extract' => '0.16', # ./Dir bug fix + 'Archive::Tar' => '1.23', + 'IO::Zlib' => '1.04', # needed for Archive::Tar + 'Object::Accessor' => '0.34', # mk_aliases support + 'Module::CoreList' => '2.22', # deprecated core modules + 'Module::Pluggable' => '2.4', + 'Module::Loaded' => '0.01', + 'Parse::CPAN::Meta' => '0.02', # config_requires support + 'ExtUtils::Install' => '1.42', # uninstall outside @INC + }, + + features => { + # config_key_name => [ + # sub { } to list module key/value pairs + # sub { } to check if feature is enabled + # ] + prefer_makefile => [ + sub { + my $cb = shift; + $cb->configure_object->get_conf('prefer_makefile') + ? { } + : { 'CPANPLUS::Dist::Build' => '0.24' }; + }, + sub { return 1 }, # always enabled + ], + cpantest => [ + { 'Test::Reporter' => '1.34', + 'Parse::CPAN::Meta' => '0.0' + }, + sub { + my $cb = shift; + return $cb->configure_object->get_conf('cpantest'); + }, + ], + dist_type => [ + sub { + my $cb = shift; + my $dist = $cb->configure_object->get_conf('dist_type'); + return { $dist => '0.0' } if $dist; + return; + }, + sub { + my $cb = shift; + return $cb->configure_object->get_conf('dist_type'); + }, + ], + + md5 => [ + { + 'Digest::MD5' => '0.0', + }, + sub { + my $cb = shift; + return $cb->configure_object->get_conf('md5'); + }, + ], + shell => [ + sub { + my $cb = shift; + my $dist = $cb->configure_object->get_conf('shell'); + + ### we bundle these shells, so don't bother having a dep + ### on them... If we don't do this, CPAN.pm actually detects + ### a recursive dependency and breaks (see #26077). + ### This is not an issue for CPANPLUS itself, it handles + ### it smartly. + return if $dist eq SHELL_DEFAULT or $dist eq SHELL_CLASSIC; + return { $dist => '0.0' } if $dist; + return; + }, + sub { return 1 }, + ], + signature => [ + sub { + my $cb = shift; + return { + 'Module::Signature' => '0.06', + } if can_run('gpg'); + ### leave this out -- Crypt::OpenPGP is fairly + ### painful to install, and broken on some platforms + ### so we'll just always fall back to gpg. It may + ### issue a warning or 2, but that's about it. + ### this change due to this ticket: #26914 + # and $cb->configure_object->get_conf('prefer_bin'); + + return { + 'Crypt::OpenPGP' => '0.0', + 'Module::Signature' => '0.06', + }; + }, + sub { + my $cb = shift; + return $cb->configure_object->get_conf('signature'); + }, + ], + storable => [ + { 'Storable' => '0.0' }, + sub { + my $cb = shift; + return $cb->configure_object->get_conf('storable'); + }, + ], + sqlite_backend => [ + { 'DBIx::Simple' => '0.0', + 'DBD::SQLite' => '0.0', + }, + sub { + my $cb = shift; + my $conf = $cb->configure_object; + return $conf->get_conf('source_engine') + eq 'CPANPLUS::Internals::Source::SQLite' + }, + ], + }, + core => { + 'CPANPLUS' => '0.0', + }, + }; + + sub _get_config { return $Modules } +} + +=head1 METHODS + +=head2 $self = CPANPLUS::Selfupdate->new( $backend_object ); + +Sets up a new selfupdate object. Called automatically when +a new backend object is created. + +=cut + +sub new { + my $class = shift; + my $cb = shift or return; + return bless sub { $cb }, $class; +} + + +{ ### cache to find the relevant modules + my $cache = { + core + => sub { my $self = shift; + core => [ $self->list_core_modules ] }, + + dependencies + => sub { my $self = shift; + dependencies => [ $self->list_core_dependencies ] }, + + enabled_features + => sub { my $self = shift; + map { $_ => [ $self->modules_for_feature( $_ ) ] } + $self->list_enabled_features + }, + features + => sub { my $self = shift; + map { $_ => [ $self->modules_for_feature( $_ ) ] } + $self->list_features + }, + ### make sure to do 'core' first, in case + ### we are out of date ourselves + all => [ qw|core dependencies enabled_features| ], + }; + + +=head2 @cat = $self->list_categories + +Returns a list of categories that the C<selfupdate> method accepts. + +See C<selfupdate> for details. + +=cut + + sub list_categories { return sort keys %$cache } + +=head2 %list = $self->list_modules_to_update( update => "core|dependencies|enabled_features|features|all", [latest => BOOL] ) + +List which modules C<selfupdate> would upgrade. You can update either +the core (CPANPLUS itself), the core dependencies, all features you have +currently turned on, or all features available, or everything. + +The C<latest> option determines whether it should update to the latest +version on CPAN, or if the minimal required version for CPANPLUS is +good enough. + +Returns a hash of feature names and lists of module objects to be +upgraded based on the category you provided. For example: + + %list = $self->list_modules_to_update( update => 'core' ); + +Would return: + + ( core => [ $module_object_for_cpanplus ] ); + +=cut + + sub list_modules_to_update { + my $self = shift; + my $cb = $self->(); + my $conf = $cb->configure_object; + my %hash = @_; + + my($type, $latest); + my $tmpl = { + update => { required => 1, store => \$type, + allow => [ keys %$cache ], }, + latest => { default => 0, store => \$latest, allow => BOOLEANS }, + }; + + { local $Params::Check::ALLOW_UNKNOWN = 1; + check( $tmpl, \%hash ) or return; + } + + my $ref = $cache->{$type}; + + ### a list of ( feature1 => \@mods, feature2 => \@mods, etc ) + my %list = UNIVERSAL::isa( $ref, 'ARRAY' ) + ? map { $cache->{$_}->( $self ) } @$ref + : $ref->( $self ); + + ### filter based on whether we need the latest ones or not + for my $aref ( values %list ) { + $aref = [ $latest + ? grep { !$_->is_uptodate } @$aref + : grep { !$_->is_installed_version_sufficient } @$aref + ]; + } + + return %list; + } + +=head2 $bool = $self->selfupdate( update => "core|dependencies|enabled_features|features|all", [latest => BOOL, force => BOOL] ) + +Selfupdate CPANPLUS. You can update either the core (CPANPLUS itself), +the core dependencies, all features you have currently turned on, or +all features available, or everything. + +The C<latest> option determines whether it should update to the latest +version on CPAN, or if the minimal required version for CPANPLUS is +good enough. + +Returns true on success, false on error. + +=cut + + sub selfupdate { + my $self = shift; + my $cb = $self->(); + my $conf = $cb->configure_object; + my %hash = @_; + + my $force; + my $tmpl = { + force => { default => $conf->get_conf('force'), store => \$force }, + }; + + { local $Params::Check::ALLOW_UNKNOWN = 1; + check( $tmpl, \%hash ) or return; + } + + my %list = $self->list_modules_to_update( %hash ) or return; + + ### just the modules please + my @mods = map { @$_ } values %list; + + my $flag; + for my $mod ( @mods ) { + unless( $mod->install( force => $force ) ) { + $flag++; + error(loc("Failed to update module '%1'", $mod->name)); + } + } + + return if $flag; + return 1; + } + +} + +=head2 @features = $self->list_features + +Returns a list of features that are supported by CPANPLUS. + +=cut + +sub list_features { + my $self = shift; + return keys %{ $self->_get_config->{'features'} }; +} + +=head2 @features = $self->list_enabled_features + +Returns a list of features that are enabled in your current +CPANPLUS installation. + +=cut + +sub list_enabled_features { + my $self = shift; + my $cb = $self->(); + + my @enabled; + for my $feat ( $self->list_features ) { + my $ref = $self->_get_config->{'features'}->{$feat}->[1]; + push @enabled, $feat if $ref->($cb); + } + + return @enabled; +} + +=head2 @mods = $self->modules_for_feature( FEATURE [,AS_HASH] ) + +Returns a list of C<CPANPLUS::Selfupdate::Module> objects which +represent the modules required to support this feature. + +For a list of features, call the C<list_features> method. + +If the C<AS_HASH> argument is provided, no module objects are +returned, but a hashref where the keys are names of the modules, +and values are their minimum versions. + +=cut + +sub modules_for_feature { + my $self = shift; + my $feature = shift or return; + my $as_hash = shift || 0; + my $cb = $self->(); + + unless( exists $self->_get_config->{'features'}->{$feature} ) { + error(loc("Unknown feature '%1'", $feature)); + return; + } + + my $ref = $self->_get_config->{'features'}->{$feature}->[0]; + + ### it's either a list of modules/versions or a subroutine that + ### returns a list of modules/versions + my $href = UNIVERSAL::isa( $ref, 'HASH' ) ? $ref : $ref->( $cb ); + + return unless $href; # nothing needed for the feature? + + return $href if $as_hash; + return $self->_hashref_to_module( $href ); +} + + +=head2 @mods = $self->list_core_dependencies( [AS_HASH] ) + +Returns a list of C<CPANPLUS::Selfupdate::Module> objects which +represent the modules that comprise the core dependencies of CPANPLUS. + +If the C<AS_HASH> argument is provided, no module objects are +returned, but a hashref where the keys are names of the modules, +and values are their minimum versions. + +=cut + +sub list_core_dependencies { + my $self = shift; + my $as_hash = shift || 0; + my $cb = $self->(); + my $href = $self->_get_config->{'dependencies'}; + + return $href if $as_hash; + return $self->_hashref_to_module( $href ); +} + +=head2 @mods = $self->list_core_modules( [AS_HASH] ) + +Returns a list of C<CPANPLUS::Selfupdate::Module> objects which +represent the modules that comprise the core of CPANPLUS. + +If the C<AS_HASH> argument is provided, no module objects are +returned, but a hashref where the keys are names of the modules, +and values are their minimum versions. + +=cut + +sub list_core_modules { + my $self = shift; + my $as_hash = shift || 0; + my $cb = $self->(); + my $href = $self->_get_config->{'core'}; + + return $href if $as_hash; + return $self->_hashref_to_module( $href ); +} + +sub _hashref_to_module { + my $self = shift; + my $cb = $self->(); + my $href = shift or return; + + return map { + CPANPLUS::Selfupdate::Module->new( + $cb->module_tree($_) => $href->{$_} + ) + } keys %$href; +} + + +=head1 CPANPLUS::Selfupdate::Module + +C<CPANPLUS::Selfupdate::Module> extends C<CPANPLUS::Module> objects +by providing accessors to aid in selfupdating CPANPLUS. + +These objects are returned by all methods of C<CPANPLUS::Selfupdate> +that return module objects. + +=cut + +{ package CPANPLUS::Selfupdate::Module; + use base 'CPANPLUS::Module'; + + ### stores module name -> cpanplus required version + ### XXX only can deal with 1 pair! + my %Cache = (); + my $Acc = 'version_required'; + + sub new { + my $class = shift; + my $mod = shift or return; + my $ver = shift; return unless defined $ver; + + my $obj = $mod->clone; # clone the module object + bless $obj, $class; # rebless it to our class + + $obj->$Acc( $ver ); + + return $obj; + } + +=head2 $version = $mod->version_required + +Returns the version of this module required for CPANPLUS. + +=cut + + sub version_required { + my $self = shift; + $Cache{ $self->name } = shift() if @_; + return $Cache{ $self->name }; + } + +=head2 $bool = $mod->is_installed_version_sufficient + +Returns true if the installed version of this module is sufficient +for CPANPLUS, or false if it is not. + +=cut + + + sub is_installed_version_sufficient { + my $self = shift; + return $self->is_uptodate( version => $self->$Acc ); + } + +} + +1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell.pm new file mode 100755 index 00000000000..854d46b16a4 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell.pm @@ -0,0 +1,341 @@ +package CPANPLUS::Shell; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Configure; +use CPANPLUS::Internals::Constants; + +use Module::Load qw[load]; +use Params::Check qw[check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +use vars qw[@ISA $SHELL $DEFAULT]; + +$DEFAULT = SHELL_DEFAULT; + +=pod + +=head1 NAME + +CPANPLUS::Shell + +=head1 SYNOPSIS + + use CPANPLUS::Shell; # load the shell indicated by your + # config -- defaults to + # CPANPLUS::Shell::Default + + use CPANPLUS::Shell qw[Classic] # load CPANPLUS::Shell::Classic; + + my $ui = CPANPLUS::Shell->new(); + my $name = $ui->which; # Find out what shell you loaded + + $ui->shell; # run the ui shell + + +=head1 DESCRIPTION + +This module is the generic loading (and base class) for all C<CPANPLUS> +shells. Through this module you can load any installed C<CPANPLUS> +shell. + +Just about all the functionality is provided by the shell that you have +loaded, and not by this class (which merely functions as a generic +loading class), so please consult the documentation of your shell of +choice. + +=cut + +sub import { + my $class = shift; + my $option = shift; + + ### find out what shell we're supposed to load ### + $SHELL = $option + ? $class . '::' . $option + : do { ### XXX this should offer to reconfigure + ### CPANPLUS, somehow. --rs + ### XXX load Configure only if we really have to + ### as that means any $Conf passed later on will + ### be ignored in favour of the one that was + ### retrieved via ->new --kane + my $conf = CPANPLUS::Configure->new() or + die loc("No configuration available -- aborting") . $/; + $conf->get_conf('shell') || $DEFAULT; + }; + + ### load the shell, fall back to the default if required + ### and die if even that doesn't work + EVAL: { + eval { load $SHELL }; + + if( $@ ) { + my $err = $@; + + die loc("Your default shell '%1' is not available: %2", + $DEFAULT, $err) . + loc("Check your installation!") . "\n" + if $SHELL eq $DEFAULT; + + warn loc("Failed to use '%1': %2", $SHELL, $err), + loc("Switching back to the default shell '%1'", $DEFAULT), + "\n"; + + $SHELL = $DEFAULT; + redo EVAL; + } + } + @ISA = ($SHELL); +} + +sub which { return $SHELL } + +1; + +########################################################################### +### abstracted out subroutines available to programmers of other shells ### +########################################################################### + +package CPANPLUS::Shell::_Base::ReadLine; + +use strict; +use vars qw($AUTOLOAD $TMPL); + +use FileHandle; +use CPANPLUS::Error; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + + +$TMPL = { + brand => { default => '', strict_type => 1 }, + prompt => { default => '> ', strict_type => 1 }, + pager => { default => '' }, + backend => { default => '' }, + term => { default => '' }, + format => { default => '' }, + dist_format => { default => '' }, + remote => { default => undef }, + noninteractive => { default => '' }, + cache => { default => [ ] }, + settings => { default => { install_all_prereqs => undef }, + no_override => 1 }, + _old_sigpipe => { default => '', no_override => 1 }, + _old_outfh => { default => '', no_override => 1 }, + _signals => { default => { INT => { } }, no_override => 1 }, +}; + +### autogenerate accessors ### +for my $key ( keys %$TMPL ) { + no strict 'refs'; + *{__PACKAGE__."::$key"} = sub { + my $self = shift; + $self->{$key} = $_[0] if @_; + return $self->{$key}; + } +} + +sub _init { + my $class = shift; + my %hash = @_; + + my $self = check( $TMPL, \%hash ) or return; + + bless $self, $class; + + ### signal handler ### + $SIG{INT} = $self->_signals->{INT}->{handler} = + sub { + unless ( $self->_signals->{INT}->{count}++ ) { + warn loc("Caught SIGINT"), "\n"; + } else { + warn loc("Got another SIGINT"), "\n"; die; + } + }; + ### end sig handler ### + + return $self; +} + +### display shell's banner, takes the Backend object as argument +sub _show_banner { + my $self = shift; + my $cpan = $self->backend; + my $term = $self->term; + + ### Tries to probe for our ReadLine support status + # a) under an interactive shell? + my $rl_avail = (!$term->isa('CPANPLUS::Shell::_Faked')) + # b) do we have a tty terminal? + ? (-t STDIN) + # c) should we enable the term? + ? (!$self->__is_bad_terminal($term)) + # d) external modules available? + ? ($term->ReadLine ne "Term::ReadLine::Stub") + # a+b+c+d => "Smart" terminal + ? loc("enabled") + # a+b+c => "Stub" terminal + : loc("available (try 'i Term::ReadLine::Perl')") + # a+b => "Bad" terminal + : loc("disabled") + # a => "Dumb" terminal + : loc("suppressed") + # none => "Faked" terminal + : loc("suppressed in batch mode"); + + $rl_avail = loc("ReadLine support %1.", $rl_avail); + $rl_avail = "\n*** $rl_avail" if (length($rl_avail) > 45); + + $self->__print( + loc("%1 -- CPAN exploration and module installation (v%2)", + $self->which, $self->which->VERSION()), "\n", + loc("*** Please report bugs to <bug-cpanplus\@rt.cpan.org>."), "\n", + loc("*** Using CPANPLUS::Backend v%1. %2", + $cpan->VERSION, $rl_avail), "\n\n" + ); +} + +### checks whether the Term::ReadLine is broken and needs to fallback to Stub +sub __is_bad_terminal { + my $self = shift; + my $term = $self->term; + + return unless $^O eq 'MSWin32'; + + ### replace the term with the default (stub) one + return $self->term(Term::ReadLine::Stub->new( $self->brand ) ); +} + +### open a pager handle +sub _pager_open { + my $self = shift; + my $cpan = $self->backend; + my $cmd = $cpan->configure_object->get_program('pager') or return; + + $self->_old_sigpipe( $SIG{PIPE} ); + $SIG{PIPE} = 'IGNORE'; + + my $fh = new FileHandle; + unless ( $fh->open("| $cmd") ) { + error(loc("could not pipe to %1: %2\n", $cmd, $!) ); + return; + } + + $fh->autoflush(1); + + $self->pager( $fh ); + $self->_old_outfh( select $fh ); + + return $fh; +} + +### print to the current pager handle, or STDOUT if it's not opened +sub _pager_close { + my $self = shift; + my $pager = $self->pager or return; + + $pager->close if (ref($pager) and $pager->can('close')); + + $self->pager( undef ); + + select $self->_old_outfh; + $SIG{PIPE} = $self->_old_sigpipe; + + return 1; +} + + + +{ + my $win32_console; + + ### determines row count of current terminal; defaults to 25. + ### used by the pager functions + sub _term_rowcount { + my $self = shift; + my $cpan = $self->backend; + my %hash = @_; + + my $default; + my $tmpl = { + default => { default => 25, allow => qr/^\d$/, + store => \$default } + }; + + check( $tmpl, \%hash ) or return; + + if ( $^O eq 'MSWin32' ) { + if ( can_load( modules => { 'Win32::Console' => '0.0' } ) ) { + $win32_console ||= Win32::Console->new(); + my $rows = ($win32_console->Info)[-1]; + return $rows; + } + + } else { + local $Module::Load::Conditional::VERBOSE = 0; + if ( can_load(modules => {'Term::Size' => '0.0'}) ) { + my ($cols, $rows) = Term::Size::chars(); + return $rows; + } + } + return $default; + } +} + +### Custom print routines, mainly to be able to catch output +### in test cases, or redirect it if need be +{ sub __print { + my $self = shift; + print @_; + } + + sub __printf { + my $self = shift; + my $fmt = shift; + + ### MUST specify $fmt as a seperate param, and not as part + ### of @_, as it will then miss the $fmt and return the + ### number of elements in the list... =/ --kane + $self->__print( sprintf( $fmt, @_ ) ); + } +} + +1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell::Classic>, L<cpanp> + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Classic.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Classic.pm new file mode 100755 index 00000000000..08c03bcf383 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Classic.pm @@ -0,0 +1,1236 @@ +################################################## +### CPANPLUS/Shell/Classic.pm ### +### Backwards compatible shell for CPAN++ ### +### Written 08-04-2002 by Jos Boumans ### +################################################## + +package CPANPLUS::Shell::Classic; + +use strict; + + +use CPANPLUS::Error; +use CPANPLUS::Backend; +use CPANPLUS::Configure::Setup; +use CPANPLUS::Internals::Constants; + +use Cwd; +use IPC::Cmd; +use Term::UI; +use Data::Dumper; +use Term::ReadLine; + +use Module::Load qw[load]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; + +$Params::Check::VERBOSE = 1; +$Params::Check::ALLOW_UNKNOWN = 1; + +BEGIN { + use vars qw[ $VERSION @ISA ]; + @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; + $VERSION = '0.0562'; +} + +load CPANPLUS::Shell; + + +### our command set ### +my $map = { + a => '_author', + b => '_bundle', + d => '_distribution', + 'm' => '_module', + i => '_find_all', + r => '_uptodate', + u => '_not_supported', + ls => '_ls', + get => '_fetch', + make => '_install', + test => '_install', + install => '_install', + clean => '_not_supported', + look => '_shell', + readme => '_readme', + h => '_help', + '?' => '_help', + o => '_set_conf', + reload => '_reload', + autobundle => '_autobundle', + '!' => '_bang', + #'q' => '_quit', # done it the loop itself +}; + +### the shell object, scoped to the file ### +my $Shell; +my $Brand = 'cpan'; +my $Prompt = $Brand . '> '; + +sub new { + my $class = shift; + + my $cb = new CPANPLUS::Backend; + my $self = $class->SUPER::_init( + brand => $Brand, + term => Term::ReadLine->new( $Brand ), + prompt => $Prompt, + backend => $cb, + format => "%5s %-50s %8s %-10s\n", + ); + ### make it available package wide ### + $Shell = $self; + + ### enable verbose, it's the cpan.pm way + $cb->configure_object->set_conf( verbose => 1 ); + + + ### register install callback ### + $cb->_register_callback( + name => 'install_prerequisite', + code => \&__ask_about_install, + ); + + ### register test report callback ### + $cb->_register_callback( + name => 'edit_test_report', + code => \&__ask_about_test_report, + ); + + return $self; +} + +sub shell { + my $self = shift; + my $term = $self->term; + + $self->_show_banner; + $self->_input_loop && print "\n"; + $self->_quit; +} + +sub _input_loop { + my $self = shift; + my $term = $self->term; + my $cb = $self->backend; + + my $normal_quit = 0; + while ( + defined (my $input = eval { $term->readline($self->prompt) } ) + or $self->_signals->{INT}{count} == 1 + ) { + ### re-initiate all signal handlers + while (my ($sig, $entry) = each %{$self->_signals} ) { + $SIG{$sig} = $entry->{handler} if exists($entry->{handler}); + } + + last if $self->_dispatch_on_input( input => $input ); + + ### flush the lib cache ### + $cb->_flush( list => [qw|lib load|] ); + + } continue { + $self->_signals->{INT}{count}-- + if $self->_signals->{INT}{count}; # clear the sigint count + } + + return 1; +} + +sub _dispatch_on_input { + my $self = shift; + my $conf = $self->backend->configure_object(); + my $term = $self->term; + my %hash = @_; + + my $string; + my $tmpl = { + input => { required => 1, store => \$string } + }; + + check( $tmpl, \%hash ) or return; + + ### the original force setting; + my $force_store = $conf->get_conf( 'force' ); + + ### parse the input: the first part before the space + ### is the command, followed by arguments. + ### see the usage below + my $key; + PARSE_INPUT: { + $string =~ s|^\s*([\w\?\!]+)\s*||; + chomp $string; + $key = lc($1); + } + + ### you prefixed the input with 'force' + ### that means we set the force flag, and + ### reparse the input... + ### YAY goto block :) + if( $key eq 'force' ) { + $conf->set_conf( force => 1 ); + goto PARSE_INPUT; + } + + ### you want to quit + return 1 if $key =~ /^q/; + + my $method = $map->{$key}; + unless( $self->can( $method ) ) { + print "Unknown command '$key'. Type ? for help.\n"; + return; + } + + ### dispatch the method call + eval { $self->$method( + command => $key, + result => [ split /\s+/, $string ], + input => $string ); + }; + warn $@ if $@; + + return; +} + +### displays quit message +sub _quit { + + ### well, that's what CPAN.pm says... + print "Lockfile removed\n"; +} + +sub _not_supported { + my $self = shift; + my %hash = @_; + + my $cmd; + my $tmpl = { + command => { required => 1, store => \$cmd } + }; + + check( $tmpl, \%hash ) or return; + + print "Sorry, the command '$cmd' is not supported\n"; + + return; +} + +sub _fetch { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $input); + my $tmpl = { + result => { store => \$aref, default => [] }, + input => { default => 'all', store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + for my $mod (@$aref) { + my $obj; + + unless( $obj = $cb->module_tree($mod) ) { + print "Warning: Cannot get $input, don't know what it is\n"; + print "Try the command\n\n"; + print "\ti /$mod/\n\n"; + print "to find objects with matching identifiers.\n"; + + next; + } + + $obj->fetch && $obj->extract; + } + + return $aref; +} + +sub _install { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my $mapping = { + make => { target => TARGET_CREATE, skiptest => 1 }, + test => { target => TARGET_CREATE }, + install => { target => TARGET_INSTALL }, + }; + + my($aref,$cmd); + my $tmpl = { + result => { store => \$aref, default => [] }, + command => { required => 1, store => \$cmd, allow => [keys %$mapping] }, + }; + + check( $tmpl, \%hash ) or return; + + for my $mod (@$aref) { + my $obj = $cb->module_tree( $mod ); + + unless( $obj ) { + print "No such module '$mod'\n"; + next; + } + + my $opts = $mapping->{$cmd}; + $obj->install( %$opts ); + } + + return $aref; +} + +sub _shell { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my($aref, $cmd); + my $tmpl = { + result => { store => \$aref, default => [] }, + command => { required => 1, store => \$cmd }, + + }; + + check( $tmpl, \%hash ) or return; + + + my $shell = $conf->get_program('shell'); + unless( $shell ) { + print "Your configuration does not define a value for subshells.\n". + qq[Please define it with "o conf shell <your shell>"\n]; + return; + } + + my $cwd = Cwd::cwd(); + + for my $mod (@$aref) { + print "Running $cmd for $mod\n"; + + my $obj = $cb->module_tree( $mod ) or next; + $obj->fetch or next; + $obj->extract or next; + + $cb->_chdir( dir => $obj->status->extract ) or next; + + #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt; + if( system($shell) and $! ) { + print "Error executing your subshell '$shell': $!\n"; + next; + } + } + $cb->_chdir( dir => $cwd ); + + return $aref; +} + +sub _readme { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my($aref, $cmd); + my $tmpl = { + result => { store => \$aref, default => [] }, + command => { required => 1, store => \$cmd }, + + }; + + check( $tmpl, \%hash ) or return; + + for my $mod (@$aref) { + my $obj = $cb->module_tree( $mod ) or next; + + if( my $readme = $obj->readme ) { + + $self->_pager_open; + print $readme; + $self->_pager_close; + } + } + + return 1; +} + +sub _reload { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my($input, $cmd); + my $tmpl = { + input => { default => 'all', store => \$input }, + command => { required => 1, store => \$cmd }, + + }; + + check( $tmpl, \%hash ) or return; + + if ( $input =~ /cpan/i ) { + print qq[You want to reload the CPAN code\n]; + print qq[Just type 'q' and then restart... ] . + qq[Trust me, it is MUCH safer\n]; + + } elsif ( $input =~ /index/i ) { + $cb->reload_indices(update_source => 1); + + } else { + print qq[cpan re-evals the CPANPLUS.pm file\n]; + print qq[index re-reads the index files\n]; + } + + return 1; +} + +sub _autobundle { + my $self = shift; + my $cb = $self->backend; + + print qq[Writing bundle file... This may take a while\n]; + + my $where = $cb->autobundle(); + + print $where + ? qq[\nWrote autobundle to $where\n] + : qq[\nCould not create autobundle\n]; + + return 1; +} + +sub _set_conf { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my($aref, $input); + my $tmpl = { + result => { store => \$aref, default => [] }, + input => { default => 'all', store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + my $type = shift @$aref; + + if( $type eq 'debug' ) { + print qq[Sorry you cannot set debug options through ] . + qq[this shell in CPANPLUS\n]; + return; + + } elsif ( $type eq 'conf' ) { + + ### from CPAN.pm :o) + # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf' + # should have been called set and 'o debug' maybe 'set debug' + + # commit Commit changes to disk + # defaults Reload defaults from disk + # init Interactive setting of all options + + my $name = shift @$aref; + my $value = "@$aref"; + + if( $name eq 'init' ) { + my $setup = CPANPLUS::Configure::Setup->new( + conf => $cb->configure_object, + term => $self->term, + backend => $cb, + ); + return $setup->init; + + } elsif ($name eq 'commit' ) {; + $cb->configure_object->save; + print "Your CPAN++ configuration info has been saved!\n\n"; + return; + + } elsif ($name eq 'defaults' ) { + print qq[Sorry, CPANPLUS cannot restore default for you.\n] . + qq[Perhaps you should run the interactive setup again.\n] . + qq[\ttry running 'o conf init'\n]; + return; + + ### we're just supplying things in the 'conf' section now, + ### not the program section.. it's a bit of a hassle to make that + ### work cleanly with the original CPAN.pm interface, so we'll fix + ### it when people start complaining, which is hopefully never. + } else { + unless( $name ) { + my @list = grep { $_ ne 'hosts' } + $conf->options( type => $type ); + + my $method = 'get_' . $type; + + local $Data::Dumper::Indent = 0; + for my $name ( @list ) { + my $val = $conf->$method($name); + ($val) = ref($val) + ? (Data::Dumper::Dumper($val) =~ /= (.*);$/) + : "'$val'"; + printf " %-25s %s\n", $name, $val; + } + + } elsif ( $name eq 'hosts' ) { + print "Setting hosts is not trivial.\n" . + "It is suggested you edit the " . + "configuration file manually"; + + } else { + my $method = 'set_' . $type; + if( $conf->$method($name => defined $value ? $value : '') ) { + my $set_to = defined $value ? $value : 'EMPTY STRING'; + print "Key '$name' was set to '$set_to'\n"; + } + } + } + } else { + print qq[Known options:\n] . + qq[ conf set or get configuration variables\n] . + qq[ debug set or get debugging options\n]; + } + + return; +} + +######################## +### search functions ### +######################## + +sub _author { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $short, $input, $class); + my $tmpl = { + result => { store => \$aref, default => ['/./'] }, + short => { default => 0, store => \$short }, + input => { default => 'all', store => \$input }, + class => { default => 'Author', no_override => 1, + store => \$class }, + }; + + check( $tmpl, \%hash ) or return; + + my @regexes = map { m|/(.+)/| ? qr/$1/ : $_ } @$aref; + + + my @rv; + for my $type (qw[author cpanid]) { + push @rv, $cb->search( type => $type, allow => \@regexes ); + } + + unless( @rv ) { + print "No object of type $class found for argument $input\n" + unless $short; + return; + } + + return $self->_pp_author( + result => \@rv, + class => $class, + short => $short, + input => $input ); + +} + +### find all modules matching a query ### +sub _module { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $short, $input, $class); + my $tmpl = { + result => { store => \$aref, default => ['/./'] }, + short => { default => 0, store => \$short }, + input => { default => 'all', store => \$input }, + class => { default => 'Module', no_override => 1, + store => \$class }, + }; + + check( $tmpl, \%hash ) or return; + + my @rv; + for my $module (@$aref) { + if( $module =~ m|/(.+)/| ) { + push @rv, $cb->search( type => 'module', + allow => [qr/$1/i] ); + } else { + my $obj = $cb->module_tree( $module ) or next; + push @rv, $obj; + } + } + + return $self->_pp_module( + result => \@rv, + class => $class, + short => $short, + input => $input ); +} + +### find all bundles matching a query ### +sub _bundle { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $short, $input, $class); + my $tmpl = { + result => { store => \$aref, default => ['/./'] }, + short => { default => 0, store => \$short }, + input => { default => 'all', store => \$input }, + class => { default => 'Bundle', no_override => 1, + store => \$class }, + }; + + check( $tmpl, \%hash ) or return; + + my @rv; + for my $bundle (@$aref) { + if( $bundle =~ m|/(.+)/| ) { + push @rv, $cb->search( type => 'module', + allow => [qr/Bundle::.*?$1/i] ); + } else { + my $obj = $cb->module_tree( "Bundle::${bundle}" ) or next; + push @rv, $obj; + } + } + + return $self->_pp_module( + result => \@rv, + class => $class, + short => $short, + input => $input ); +} + +sub _distribution { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $short, $input, $class); + my $tmpl = { + result => { store => \$aref, default => ['/./'] }, + short => { default => 0, store => \$short }, + input => { default => 'all', store => \$input }, + class => { default => 'Distribution', no_override => 1, + store => \$class }, + }; + + check( $tmpl, \%hash ) or return; + + my @rv; + for my $module (@$aref) { + ### if it's a regex... ### + if ( my ($match) = $module =~ m|^/(.+)/$|) { + + ### something like /FOO/Bar.tar.gz/ was entered + if (my ($path,$package) = $match =~ m|^/?(.+)/(.+)$|) { + my $seen; + + my @data = $cb->search( type => 'package', + allow => [qr/$package/i] ); + + my @list = $cb->search( type => 'path', + allow => [qr/$path/i], + data => \@data ); + + ### make sure we dont list the same dist twice + for my $val ( @list ) { + next if $seen->{$val->package}++; + + push @rv, $val; + } + + ### something like /FOO/ or /Bar.tgz/ was entered + ### so we look both in the path, as well as in the package name + } else { + my $seen; + { my @list = $cb->search( type => 'package', + allow => [qr/$match/i] ); + + ### make sure we dont list the same dist twice + for my $val ( @list ) { + next if $seen->{$val->package}++; + + push @rv, $val; + } + } + + { my @list = $cb->search( type => 'path', + allow => [qr/$match/i] ); + + ### make sure we dont list the same dist twice + for my $val ( @list ) { + next if $seen->{$val->package}++; + + push @rv, $val; + } + + } + } + + } else { + + ### user entered a full dist, like: R/RC/RCAPUTO/POE-0.19.tar.gz + if (my ($path,$package) = $module =~ m|^/?(.+)/(.+)$|) { + my @data = $cb->search( type => 'package', + allow => [qr/^$package$/] ); + my @list = $cb->search( type => 'path', + allow => [qr/$path$/i], + data => \@data); + + ### make sure we dont list the same dist twice + my $seen; + for my $val ( @list ) { + next if $seen->{$val->package}++; + + push @rv, $val; + } + } + } + } + + return $self->_pp_distribution( + result => \@rv, + class => $class, + short => $short, + input => $input ); +} + +sub _find_all { + my $self = shift; + + my @rv; + for my $method (qw[_author _bundle _module _distribution]) { + my $aref = $self->$method( @_, short => 1 ); + + push @rv, @$aref if $aref; + } + + print scalar(@rv). " items found\n" +} + +sub _uptodate { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $short, $input, $class); + my $tmpl = { + result => { store => \$aref, default => ['/./'] }, + short => { default => 0, store => \$short }, + input => { default => 'all', store => \$input }, + class => { default => 'Uptodate', no_override => 1, + store => \$class }, + }; + + check( $tmpl, \%hash ) or return; + + + my @rv; + if( @$aref) { + for my $module (@$aref) { + if( $module =~ m|/(.+)/| ) { + my @list = $cb->search( type => 'module', + allow => [qr/$1/i] ); + + ### only add those that are installed and not core + push @rv, grep { not $_->package_is_perl_core } + grep { $_->installed_file } + @list; + + } else { + my $obj = $cb->module_tree( $module ) or next; + push @rv, $obj; + } + } + } else { + @rv = @{$cb->_all_installed}; + } + + return $self->_pp_uptodate( + result => \@rv, + class => $class, + short => $short, + input => $input ); +} + +sub _ls { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $short, $input, $class); + my $tmpl = { + result => { store => \$aref, default => [] }, + short => { default => 0, store => \$short }, + input => { default => 'all', store => \$input }, + class => { default => 'Uptodate', no_override => 1, + store => \$class }, + }; + + check( $tmpl, \%hash ) or return; + + my @rv; + for my $name (@$aref) { + my $auth = $cb->author_tree( uc $name ); + + unless( $auth ) { + print qq[ls command rejects argument $name: not an author\n]; + next; + } + + push @rv, $auth->distributions; + } + + return $self->_pp_ls( + result => \@rv, + class => $class, + short => $short, + input => $input ); +} + +############################ +### pretty printing subs ### +############################ + + +sub _pp_author { + my $self = shift; + my %hash = @_; + + my( $aref, $short, $class, $input ); + my $tmpl = { + result => { required => 1, default => [], strict_type => 1, + store => \$aref }, + short => { default => 0, store => \$short }, + class => { required => 1, store => \$class }, + input => { required => 1, store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + ### no results + if( !@$aref ) { + print "No objects of type $class found for argument $input\n" + unless $short; + + ### one result, long output desired; + } elsif( @$aref == 1 and !$short ) { + + ### should look like this: + #cpan> a KANE + #Author id = KANE + # EMAIL boumans@frg.eur.nl + # FULLNAME Jos Boumans + + my $obj = shift @$aref; + + print "$class id = ", $obj->cpanid(), "\n"; + printf " %-12s %s\n", 'EMAIL', $obj->email(); + printf " %-12s %s%s\n", 'FULLNAME', $obj->author(); + + } else { + + ### should look like this: + #Author KANE (Jos Boumans) + #Author LBROCARD (Leon Brocard) + #2 items found + + for my $obj ( @$aref ) { + printf qq[%-15s %s ("%s" (%s))\n], + $class, $obj->cpanid, $obj->author, $obj->email; + } + print scalar(@$aref)." items found\n" unless $short; + } + + return $aref; +} + +sub _pp_module { + my $self = shift; + my %hash = @_; + + my( $aref, $short, $class, $input ); + my $tmpl = { + result => { required => 1, default => [], strict_type => 1, + store => \$aref }, + short => { default => 0, store => \$short }, + class => { required => 1, store => \$class }, + input => { required => 1, store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + + ### no results + if( !@$aref ) { + print "No objects of type $class found for argument $input\n" + unless $short; + + ### one result, long output desired; + } elsif( @$aref == 1 and !$short ) { + + + ### should look like this: + #Module id = LWP + # DESCRIPTION Libwww-perl + # CPAN_USERID GAAS (Gisle Aas <gisle@ActiveState.com>) + # CPAN_VERSION 5.64 + # CPAN_FILE G/GA/GAAS/libwww-perl-5.64.tar.gz + # DSLI_STATUS RmpO (released,mailing-list,perl,object-oriented) + # MANPAGE LWP - The World-Wide Web library for Perl + # INST_FILE C:\Perl\site\lib\LWP.pm + # INST_VERSION 5.62 + + my $obj = shift @$aref; + my $aut_obj = $obj->author; + my $format = " %-12s %s%s\n"; + + print "$class id = ", $obj->module(), "\n"; + printf $format, 'DESCRIPTION', $obj->description() + if $obj->description(); + + printf $format, 'CPAN_USERID', $aut_obj->cpanid() . " (" . + $aut_obj->author() . " <" . $aut_obj->email() . ">)"; + + printf $format, 'CPAN_VERSION', $obj->version(); + printf $format, 'CPAN_FILE', $obj->path() . '/' . $obj->package(); + + printf $format, 'DSLI_STATUS', $self->_pp_dslip($obj->dslip) + if $obj->dslip() =~ /\w/; + + #printf $format, 'MANPAGE', $obj->foo(); + ### this is for bundles... CPAN.pm downloads them, + #printf $format, 'CONATAINS, + # parses and goes from there... + + printf $format, 'INST_FILE', $obj->installed_file || + '(not installed)'; + printf $format, 'INST_VERSION', $obj->installed_version; + + + + } else { + + ### should look like this: + #Module LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz) + #Module POE (R/RC/RCAPUTO/POE-0.19.tar.gz) + #2 items found + + for my $obj ( @$aref ) { + printf "%-15s %-15s (%s)\n", $class, $obj->module(), + $obj->path() .'/'. $obj->package(); + } + print scalar(@$aref). " items found\n" unless $short; + } + + return $aref; +} + +sub _pp_dslip { + my $self = shift; + my $dslip = shift or return; + + my (%_statusD, %_statusS, %_statusL, %_statusI); + + @_statusD{qw(? i c a b R M S)} = + qw(unknown idea pre-alpha alpha beta released mature standard); + + @_statusS{qw(? m d u n)} = + qw(unknown mailing-list developer comp.lang.perl.* none); + + @_statusL{qw(? p c + o h)} = qw(unknown perl C C++ other hybrid); + @_statusI{qw(? f r O h)} = + qw(unknown functions references+ties object-oriented hybrid); + + my @status = split("", $dslip); + + my $results = sprintf( "%s (%s,%s,%s,%s)", + $dslip, + $_statusD{$status[0]}, + $_statusS{$status[1]}, + $_statusL{$status[2]}, + $_statusI{$status[3]} + ); + + return $results; +} + +sub _pp_distribution { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my( $aref, $short, $class, $input ); + my $tmpl = { + result => { required => 1, default => [], strict_type => 1, + store => \$aref }, + short => { default => 0, store => \$short }, + class => { required => 1, store => \$class }, + input => { required => 1, store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + + ### no results + if( !@$aref ) { + print "No objects of type $class found for argument $input\n" + unless $short; + + ### one result, long output desired; + } elsif( @$aref == 1 and !$short ) { + + + ### should look like this: + #Distribution id = S/SA/SABECK/POE-Component-Client-POP3-0.02.tar.gz + # CPAN_USERID SABECK (Scott Beck <scott@gossamer-threads.com>) + # CONTAINSMODS POE::Component::Client::POP3 + + my $obj = shift @$aref; + my $aut_obj = $obj->author; + my $pkg = $obj->package; + my $format = " %-12s %s\n"; + + my @list = $cb->search( type => 'package', + allow => [qr/^$pkg$/] ); + + + print "$class id = ", $obj->path(), '/', $obj->package(), "\n"; + printf $format, 'CPAN_USERID', + $aut_obj->cpanid .' ('. $aut_obj->author . + ' '. $aut_obj->email .')'; + + ### yes i know it's ugly, but it's what cpan.pm does + printf $format, 'CONTAINSMODS', join (' ', map { $_->module } @list); + + } else { + + ### should look like this: + #Distribution LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz) + #Distribution POE (R/RC/RCAPUTO/POE-0.19.tar.gz) + #2 items found + + for my $obj ( @$aref ) { + printf "%-15s %s\n", $class, $obj->path() .'/'. $obj->package(); + } + + print scalar(@$aref). " items found\n" unless $short; + } + + return $aref; +} + +sub _pp_uptodate { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my( $aref, $short, $class, $input ); + my $tmpl = { + result => { required => 1, default => [], strict_type => 1, + store => \$aref }, + short => { default => 0, store => \$short }, + class => { required => 1, store => \$class }, + input => { required => 1, store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + my $format = "%-25s %9s %9s %s\n"; + + my @not_uptodate; + my $no_version; + + my %seen; + for my $mod (@$aref) { + next if $mod->package_is_perl_core; + next if $seen{ $mod->package }++; + + + if( $mod->installed_file and not $mod->installed_version ) { + $no_version++; + next; + } + + push @not_uptodate, $mod unless $mod->is_uptodate; + } + + unless( @not_uptodate ) { + my $string = $input + ? "for $input" + : ''; + print "All modules are up to date $string\n"; + return; + + } else { + printf $format, ( 'Package namespace', + 'installed', + 'latest', + 'in CPAN file' + ); + } + + for my $mod ( sort { $a->module cmp $b->module } @not_uptodate ) { + printf $format, ( $mod->module, + $mod->installed_version, + $mod->version, + $mod->path .'/'. $mod->package, + ); + } + + print "$no_version installed modules have no (parsable) version number\n" + if $no_version; + + return \@not_uptodate; +} + +sub _pp_ls { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my( $aref, $short, $class, $input ); + my $tmpl = { + result => { required => 1, default => [], strict_type => 1, + store => \$aref }, + short => { default => 0, store => \$short }, + class => { required => 1, store => \$class }, + input => { required => 1, store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + ### should look something like this: + #6272 2002-05-12 KANE/Acme-Comment-1.00.tar.gz + #8171 2002-08-13 KANE/Acme-Comment-1.01.zip + #7110 2002-09-04 KANE/Acme-Comment-1.02.tar.gz + #7571 2002-09-08 KANE/Acme-Intraweb-1.01.tar.gz + #6625 2001-08-23 KANE/Acme-POE-Knee-1.10.zip + #3058 2003-10-05 KANE/Acme-Test-0.02.tar.gz + + ### don't know size or mtime + #my $format = "%8d %10s %s/%s\n"; + + for my $mod ( sort { $a->package cmp $b->package } @$aref ) { + print "\t" . $mod->package . "\n"; + } + + return $aref; +} + + +############################# +### end pretty print subs ### +############################# + + +sub _bang { + my $self = shift; + my %hash = @_; + + my( $input ); + my $tmpl = { + input => { required => 1, store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + eval $input; + warn $@ if $@; + + print "\n"; + + return; +} + +sub _help { + print qq[ +Display Information + a authors + b string display bundles + d or info distributions + m /regex/ about modules + i or anything of above + r none reinstall recommendations + u uninstalled distributions + +Download, Test, Make, Install... + get download + make make (implies get) + test modules, make test (implies make) + install dists, bundles make install (implies test) + clean make clean + look open subshell in these dists' directories + readme display these dists' README files + +Other + h,? display this menu ! perl-code eval a perl command + o conf [opt] set and query options q quit the cpan shell + reload cpan load CPAN.pm again reload index load newer indices + autobundle Snapshot force cmd unconditionally do cmd +]; + +} + + + +1; +__END__ + +=pod + +=head1 NAME + +CPANPLUS::Shell::Classic - CPAN.pm emulation for CPANPLUS + +=head1 DESCRIPTION + +The Classic shell is designed to provide the feel of the CPAN.pm shell +using CPANPLUS underneath. + +For detailed documentation, refer to L<CPAN>. + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author> + +=cut + + +=head1 SEE ALSO + +L<CPAN> + +=cut + + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default.pm new file mode 100755 index 00000000000..a441c87e794 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default.pm @@ -0,0 +1,1938 @@ +package CPANPLUS::Shell::Default; + +use strict; + + +use CPANPLUS::Error; +use CPANPLUS::Backend; +use CPANPLUS::Configure::Setup; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Internals::Constants::Report qw[GRADE_FAIL]; + +use Cwd; +use IPC::Cmd; +use Term::UI; +use Data::Dumper; +use Term::ReadLine; + +use Module::Load qw[load]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; +local $Data::Dumper::Indent = 1; # for dumpering from ! + +BEGIN { + use vars qw[ $VERSION @ISA ]; + @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; + $VERSION = "0.9001"; +} + +load CPANPLUS::Shell; + + +my $map = { + 'm' => '_search_module', + 'a' => '_search_author', + '!' => '_bang', + '?' => '_help', + 'h' => '_help', + 'q' => '_quit', + 'r' => '_readme', + 'v' => '_show_banner', + 'w' => '__display_results', + 'd' => '_fetch', + 'z' => '_shell', + 'f' => '_distributions', + 'x' => '_reload_indices', + 'i' => '_install', + 't' => '_install', + 'l' => '_details', + 'p' => '_print', + 's' => '_set_conf', + 'o' => '_uptodate', + 'b' => '_autobundle', + 'u' => '_uninstall', + '/' => '_meta', # undocumented for now + 'c' => '_reports', +}; +### free letters: e g j k n y ### + + +### will be filled if you have a .default-shell.rc and +### Config::Auto installed +my $rc = {}; + +### the shell object, scoped to the file ### +my $Shell; +my $Brand = loc('CPAN Terminal'); +my $Prompt = $Brand . '> '; + +=pod + +=head1 NAME + +CPANPLUS::Shell::Default + +=head1 SYNOPSIS + + ### loading the shell: + $ cpanp # run 'cpanp' from the command line + $ perl -MCPANPLUS -eshell # load the shell from the command line + + + use CPANPLUS::Shell qw[Default]; # load this shell via the API + # always done via CPANPLUS::Shell + + my $ui = CPANPLUS::Shell->new; + $ui->shell; # run the shell + $ui->dispatch_on_input( input => 'x'); # update the source using the + # dispatch method + + ### when in the shell: + ### Note that all commands can also take options. + ### Look at their underlying CPANPLUS::Backend methods to see + ### what options those are. + cpanp> h # show help messages + cpanp> ? # show help messages + + cpanp> m Acme # find acme modules, allows regexes + cpanp> a KANE # find modules by kane, allows regexes + cpanp> f Acme::Foo # get a list of all releases of Acme::Foo + + cpanp> i Acme::Foo # install Acme::Foo + cpanp> i Acme-Foo-1.3 # install version 1.3 of Acme::Foo + cpanp> i <URI> # install from URI, like ftp://foo.com/X.tgz + cpanp> i <DIR> # install from an absolute or relative directory + cpanp> i 1 3..5 # install search results 1, 3, 4 and 5 + cpanp> i * # install all search results + cpanp> a KANE; i *; # find modules by kane, install all results + cpanp> t Acme::Foo # test Acme::Foo, without installing it + cpanp> u Acme::Foo # uninstall Acme::Foo + cpanp> d Acme::Foo # download Acme::Foo + cpanp> z Acme::Foo # download & extract Acme::Foo, then open a + # shell in the extraction directory + + cpanp> c Acme::Foo # get a list of test results for Acme::Foo + cpanp> l Acme::Foo # view details about the Acme::Foo package + cpanp> r Acme::Foo # view Acme::Foo's README file + cpanp> o # get a list of all installed modules that + # are out of date + cpanp> o 1..3 # list uptodateness from a previous search + + cpanp> s conf # show config settings + cpanp> s conf md5 1 # enable md5 checks + cpanp> s program # show program settings + cpanp> s edit # edit config file + cpanp> s reconfigure # go through initial configuration again + cpanp> s selfupdate # update your CPANPLUS install + cpanp> s save # save config to disk + cpanp> s mirrors # show currently selected mirrors + + cpanp> ! [PERL CODE] # execute the following perl code + + cpanp> b # create an autobundle for this computers + # perl installation + cpanp> x # reload index files (purges cache) + cpanp> x --update_source # reload index files, get fresh source files + cpanp> p [FILE] # print error stack (to a file) + cpanp> v # show the banner + cpanp> w # show last search results again + + cpanp> q # quit the shell + + cpanp> /plugins # list avialable plugins + cpanp> /? PLUGIN # list help test of <PLUGIN> + + ### common options: + cpanp> i ... --skiptest # skip tests + cpanp> i ... --force # force all operations + cpanp> i ... --verbose # run in verbose mode + +=head1 DESCRIPTION + +This module provides the default user interface to C<CPANPLUS>. You +can start it via the C<cpanp> binary, or as detailed in the L<SYNOPSIS>. + +=cut + +sub new { + my $class = shift; + + my $cb = CPANPLUS::Backend->new( @_ ); + my $self = $class->SUPER::_init( + brand => $Brand, + term => Term::ReadLine->new( $Brand ), + prompt => $Prompt, + backend => $cb, + format => "%4s %-55s %8s %-10s\n", + dist_format => "%4s %-42s %-12s %8s %-10s\n", + ); + ### make it available package wide ### + $Shell = $self; + + my $rc_file = File::Spec->catfile( + $cb->configure_object->get_conf('base'), + DOT_SHELL_DEFAULT_RC, + ); + + + if( -e $rc_file && -r _ ) { + $rc = $self->_read_configuration_from_rc( $rc_file ); + } + + ### register install callback ### + $cb->_register_callback( + name => 'install_prerequisite', + code => \&__ask_about_install, + ); + + ### execute any login commands specified ### + $self->dispatch_on_input( input => $rc->{'login'} ) + if defined $rc->{'login'}; + + ### register test report callbacks ### + $cb->_register_callback( + name => 'edit_test_report', + code => \&__ask_about_edit_test_report, + ); + + $cb->_register_callback( + name => 'send_test_report', + code => \&__ask_about_send_test_report, + ); + + $cb->_register_callback( + name => 'proceed_on_test_failure', + code => \&__ask_about_test_failure, + ); + + ### load all the plugins + $self->_plugins_init; + + return $self; +} + +sub shell { + my $self = shift; + my $term = $self->term; + my $conf = $self->backend->configure_object; + + $self->_show_banner; + $self->__print( "*** Type 'p' now to show start up log\n" ); # XXX add to banner? + $self->_show_random_tip if $conf->get_conf('show_startup_tip'); + $self->_input_loop && $self->__print( "\n" ); + $self->_quit; +} + +sub _input_loop { + my $self = shift; + my $term = $self->term; + my $cb = $self->backend; + + my $normal_quit = 0; + while ( + defined (my $input = eval { $term->readline($self->prompt) } ) + or $self->_signals->{INT}{count} == 1 + ) { + ### re-initiate all signal handlers + while (my ($sig, $entry) = each %{$self->_signals} ) { + $SIG{$sig} = $entry->{handler} if exists($entry->{handler}); + } + + $self->__print( "\n" ); + last if $self->dispatch_on_input( input => $input ); + + ### flush the lib cache ### + $cb->_flush( list => [qw|lib load|] ); + + } continue { + ### clear the sigint count + $self->_signals->{INT}{count}-- + if $self->_signals->{INT}{count}; + + ### reset the 'install prereq?' cached answer + $self->settings->{'install_all_prereqs'} = undef; + + } + + return 1; +} + +### return 1 to quit ### +sub dispatch_on_input { + my $self = shift; + my $conf = $self->backend->configure_object(); + my $term = $self->term; + my %hash = @_; + + my($string, $noninteractive); + my $tmpl = { + input => { required => 1, store => \$string }, + noninteractive => { required => 0, store => \$noninteractive }, + }; + + check( $tmpl, \%hash ) or return; + + ### indicates whether or not the user will receive a shell + ### prompt after the command has finished. + $self->noninteractive($noninteractive) if defined $noninteractive; + + my $rv = 1; + + my @cmds = split ';', $string; + while( my $input = shift @cmds ) { + + ### to send over the socket ### + my $org_input = $input; + + my $key; my $options; + { ### make whitespace not count when using special chars + { $input =~ s|^\s*([!?/])|$1 |; } + + ### get the first letter of the input + $input =~ s|^\s*([\w\?\!/])\w*||; + + chomp $input; + $key = lc($1); + + ### we figured out what the command was... + ### if we have more input, that DOES NOT start with a white + ### space char, we misparsed.. like 'Test::Foo::Bar', which + ### would turn into 't', '::Foo::Bar'... + if( $input and $input !~ s/^\s+// ) { + $self->__print( loc("Could not understand command: %1\n". + "Possibly missing command before argument(s)?\n", + $org_input) ); + return; + } + + ### allow overrides from the config file ### + if( defined $rc->{$key} ) { + $input = $rc->{$key} . $input; + } + + ### grab command line options like --no-force and --verbose ### + ($options,$input) = $term->parse_options($input) + unless $key eq '!'; + } + + ### emtpy line? ### + return unless $key; + + ### time to quit ### + return 1 if $key eq 'q'; + + my $method = $map->{$key}; + + ### dispatch meta locally at all times ### + if( $key eq '/' ) { + ### keep track of failures + $rv *= length $self->$method(input => $input, options => $options); + next; + } + + ### flush unless we're trying to print the stack + CPANPLUS::Error->flush unless $key eq 'p'; + + ### connected over a socket? ### + if( $self->remote ) { + + ### unsupported commands ### + if( $key eq 'z' or + ($key eq 's' and $input =~ /^\s*edit/) + ) { + $self->__print( "\n", + loc( "Command '%1' not supported over remote connection", + join ' ', $key, $input + ), "\n\n" ); + + } else { + my($status,$buff) = $self->__send_remote_command($org_input); + + $self->__print( "\n", loc("Command failed!"), "\n\n" ) + unless $status; + + ### keep track of failures + $rv *= length $status; + + $self->_pager_open if $buff =~ tr/\n// > $self->_term_rowcount; + $self->__print( $buff ); + $self->_pager_close; + } + + ### or just a plain local shell? ### + } else { + + unless( $self->can($method) ) { + $self->__print(loc("Unknown command '%1'. Usage:", $key), "\n"); + $self->_help; + + } else { + + ### some methods don't need modules ### + my @mods; + @mods = $self->_select_modules($input) + unless grep {$key eq $_} qw[! m a v w x p s b / ? h]; + + ### keep track of failures + $rv *= defined eval { $self->$method( + modules => \@mods, + options => $options, + input => $input, + choice => $key ) + }; + error( $@ ) if $@; + } + } + } + + ### outside the shell loop, we can return the actual return value; + return $rv if $self->noninteractive; + + return; +} + +sub _select_modules { + my $self = shift; + my $input = shift or return; + my $cache = $self->cache; + my $cb = $self->backend; + + ### expand .. in $input + $input =~ s{\b(\d+)\s*\.\.\s*(\d+)\b} + {join(' ', ($1 < 1 ? 1 : $1) .. ($2 > $#{$cache} ? $#{$cache} : $2))}eg; + + $input = join(' ', 1 .. $#{$cache}) if $input eq '*'; + $input =~ s/'/::/g; # perl 4 convention + + my @rv; + for my $mod (split /\s+/, $input) { + + ### it's a cache look up ### + if( $mod =~ /^\d+/ and $mod > 0 ) { + unless( scalar @$cache ) { + $self->__print( loc("No search was done yet!"), "\n" ); + + } elsif ( my $obj = $cache->[$mod] ) { + push @rv, $obj; + + } else { + $self->__print( loc("No such module: %1", $mod), "\n" ); + } + + } else { + my $obj = $cb->parse_module( module => $mod ); + + unless( $obj ) { + $self->__print( loc("No such module: %1", $mod), "\n" ); + + } else { + push @rv, $obj; + } + } + } + + unless( scalar @rv ) { + $self->__print( loc("No modules found to operate on!\n") ); + return; + } else { + return @rv; + } +} + +sub _format_version { + my $self = shift; + my $version = shift || 0; + + ### fudge $version into the 'optimal' format + $version = 0 if $version eq 'undef'; + $version =~ s/_//g; # everything after gets stripped off otherwise + + ### allow 6 digits after the dot, as that's how perl stringifies + ### x.y.z numbers. + $version = sprintf('%3.6f', $version); + $version = '' if $version == '0.00'; + $version =~ s/(00{0,3})$/' ' x (length $1)/e; + + return $version; +} + +sub __display_results { + my $self = shift; + my $cache = $self->cache; + + my @rv = @$cache; + + if( scalar @rv ) { + + $self->_pager_open if $#{$cache} >= $self->_term_rowcount; + + my $i = 1; + for my $mod (@rv) { + next unless $mod; # first one is undef + # humans start counting at 1 + + ### for dists only -- we have checksum info + if( $mod->mtime ) { + $self->__printf( + $self->dist_format, + $i, + $mod->module, + $mod->mtime, + $self->_format_version( $mod->version ), + $mod->author->cpanid + ); + + } else { + $self->__printf( + $self->format, + $i, + $mod->module, + $self->_format_version( $mod->version ), + $mod->author->cpanid + ); + } + $i++; + } + + $self->_pager_close; + + } else { + $self->__print( loc("No results to display"), "\n" ); + } + + return 1; +} + + +sub _quit { + my $self = shift; + + $self->dispatch_on_input( input => $rc->{'logout'} ) + if defined $rc->{'logout'}; + + $self->__print( loc("Exiting CPANPLUS shell"), "\n" ); + + return 1; +} + +########################### +### actual command subs ### +########################### + + +### print out the help message ### +### perhaps, '?' should be a slightly different version ### +{ my @help; + sub _help { + my $self = shift; + my %hash = @_; + + my $input; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + input => { required => 0, store => \$input } + }; + + my $args = check( $tmpl, \%hash ) or return; + } + + @help = ( +loc('[General]' ), +loc(' h | ? # display help' ), +loc(' q # exit' ), +loc(' v # version information' ), +loc('[Search]' ), +loc(' a AUTHOR ... # search by author(s)' ), +loc(' m MODULE ... # search by module(s)' ), +loc(' f MODULE ... # list all releases of a module' ), +loc(" o [ MODULE ... ] # list installed module(s) that aren't up to date" ), +loc(' w # display the result of your last search again' ), +loc('[Operations]' ), +loc(' i MODULE | NUMBER ... # install module(s), by name or by search number' ), +loc(' i URI | ... # install module(s), by URI (ie http://foo.com/X.tgz)' ), +loc(' i DIR | ... # install module(s), by path (ie ./Module-1.0)' ), +loc(' t MODULE | NUMBER ... # test module(s), by name or by search number' ), +loc(' u MODULE | NUMBER ... # uninstall module(s), by name or by search number' ), +loc(' d MODULE | NUMBER ... # download module(s)' ), +loc(' l MODULE | NUMBER ... # display detailed information about module(s)' ), +loc(' r MODULE | NUMBER ... # display README files of module(s)' ), +loc(' c MODULE | NUMBER ... # check for module report(s) from cpan-testers' ), +loc(' z MODULE | NUMBER ... # extract module(s) and open command prompt in it' ), +loc('[Local Administration]' ), +loc(' b # write a bundle file for your configuration' ), +loc(' s program [OPT VALUE] # set program locations for this session' ), +loc(' s conf [OPT VALUE] # set config options for this session' ), +loc(' s mirrors # show currently selected mirrors' ), +loc(' s reconfigure # reconfigure settings ' ), +loc(' s selfupdate # update your CPANPLUS install '), +loc(' s save [user|system] # save settings for this user or systemwide' ), +loc(' s edit [user|system] # open configuration file in editor and reload' ), +loc(' ! EXPR # evaluate a perl statement' ), +loc(' p [FILE] # print the error stack (optionally to a file)' ), +loc(' x # reload CPAN indices (purges cache)' ), +loc(' x --update_source # reload CPAN indices, get fresh source files' ), +loc('[Common Options]' ), +loc(' i ... --skiptest # skip tests' ), +loc(' i ... --force # force all operations' ), +loc(' i ... --verbose # run in verbose mode' ), +loc('[Plugins]' ), +loc(' /plugins # list available plugins' ), +loc(' /? [PLUGIN NAME] # show usage for (a particular) plugin(s)' ), + + ) unless @help; + + $self->_pager_open if (@help >= $self->_term_rowcount); + ### XXX: functional placeholder for actual 'detailed' help. + $self->__print( "Detailed help for the command '$input' is " . + "not available.\n\n" ) if length $input; + $self->__print( map {"$_\n"} @help ); + $self->__print( $/ ); + $self->_pager_close; + + return 1; + } +} + +### eval some code ### +sub _bang { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + + my $input; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + input => { required => 1, store => \$input } + }; + + my $args = check( $tmpl, \%hash ) or return; + } + + local $Data::Dumper::Indent = 1; # for dumpering from ! + eval $input; + error( $@ ) if $@; + $self->__print( "\n" ); + + return if $@; + return 1; +} + +sub _search_module { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my $args; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + input => { required => 1, }, + options => { default => { } }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'}; + + ### XXX this is rather slow, because (probably) + ### of the many method calls + ### XXX need to profile to speed it up =/ + + ### find the modules ### + my @rv = sort { $a->module cmp $b->module } + $cb->search( + %{$args->{'options'}}, + type => 'module', + allow => \@regexes, + ); + + ### store the result in the cache ### + $self->cache([undef,@rv]); + + $self->__display_results; + + return 1; +} + +sub _search_author { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my $args; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + input => { required => 1, }, + options => { default => { } }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'}; + + my @rv; + for my $type (qw[author cpanid]) { + push @rv, $cb->search( + %{$args->{'options'}}, + type => $type, + allow => \@regexes, + ); + } + + my %seen; + my @list = sort { $a->module cmp $b->module } + grep { defined } + map { $_->modules } + grep { not $seen{$_}++ } @rv; + + $self->cache([undef,@list]); + + $self->__display_results; + return 1; +} + +sub _readme { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my $args; my $mods; my $opts; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { required => 1, store => \$mods }, + options => { default => { }, store => \$opts }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + return unless scalar @$mods; + + $self->_pager_open; + for my $mod ( @$mods ) { + $self->__print( $mod->readme( %$opts ) ); + } + + $self->_pager_close; + + return 1; +} + +sub _fetch { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my $args; my $mods; my $opts; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { required => 1, store => \$mods }, + options => { default => { }, store => \$opts }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + $self->_pager_open if @$mods >= $self->_term_rowcount; + my $rv = 1; + for my $mod (@$mods) { + my $where = $mod->fetch( %$opts ); + + $rv *= length $where; + + $self->__print( + $where + ? loc("Successfully fetched '%1' to '%2'", + $mod->module, $where ) + : loc("Failed to fetch '%1'", $mod->module) + ); + $self->__print( "\n" ); + } + $self->_pager_close; + + return 1 if $rv; + return; +} + +sub _shell { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my $shell = $conf->get_program('shell'); + unless( $shell ) { + $self->__print( + loc("Your config does not specify a subshell!"), "\n", + loc("Perhaps you need to re-run your setup?"), "\n" + ); + return; + } + + my $args; my $mods; my $opts; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { required => 1, store => \$mods }, + options => { default => { }, store => \$opts }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my $cwd = Cwd::cwd(); + for my $mod (@$mods) { + $mod->fetch( %$opts ) or next; + $mod->extract( %$opts ) or next; + + $cb->_chdir( dir => $mod->status->extract() ) or next; + + #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt; + + if( system($shell) and $! ) { + $self->__print( + loc("Error executing your subshell '%1': %2", + $shell, $!),"\n" + ); + next; + } + } + $cb->_chdir( dir => $cwd ); + + return 1; +} + +sub _distributions { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my $args; my $mods; my $opts; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { required => 1, store => \$mods }, + options => { default => { }, store => \$opts }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my @list; + for my $mod (@$mods) { + push @list, sort { $a->version <=> $b->version } + grep { defined } $mod->distributions( %$opts ); + } + + my @rv = sort { $a->module cmp $b->module } @list; + + $self->cache([undef,@rv]); + $self->__display_results; + + return 1; +} + +sub _reload_indices { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my $args; my $opts; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my $rv = $cb->reload_indices( %$opts ); + + ### so the update failed, but you didnt give it any options either + if( !$rv and !(keys %$opts) ) { + $self->__print( + "\nFailure may be due to corrupt source files\n" . + "Try this:\n\tx --update_source\n\n" ); + } + + return $rv; + +} + +sub _install { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my $args; my $mods; my $opts; my $choice; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { required => 1, store => \$mods }, + options => { default => { }, store => \$opts }, + choice => { required => 1, store => \$choice, + allow => [qw|i t|] }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + unless( scalar @$mods ) { + $self->__print( loc("Nothing done\n") ); + return; + } + + my $target = $choice eq 'i' ? TARGET_INSTALL : TARGET_CREATE; + my $prompt = $choice eq 'i' ? loc('Installing ') : loc('Testing '); + my $action = $choice eq 'i' ? 'install' : 'test'; + + my $status = {}; + ### first loop over the mods to install them ### + for my $mod (@$mods) { + $self->__print( $prompt, $mod->module, " (".$mod->version.")", "\n" ); + + my $log_length = length CPANPLUS::Error->stack_as_string; + + ### store the status for look up when we're done with all + ### install calls + $status->{$mod} = $mod->install( %$opts, target => $target ); + + ### would you like a log file of what happened? + if( $conf->get_conf('write_install_logs') ) { + + if ( ON_WIN32 and !check_install( + module => 'IPC::Run', version => 0.55 ) + ) { + error(loc("IPC::Run version '%1' is required on MSWin32" + . " in order to capture buffers." + . " The logfile generated may not contain" + . " any useful data, until it is installed", 0.55)); + } + + my $dir = File::Spec->catdir( + $conf->get_conf('base'), + $conf->_get_build('install_log_dir'), + ); + ### create the dir if it doesn't exit yet + $cb->_mkdir( dir => $dir ) unless -d $dir; + + my $file = File::Spec->catfile( + $dir, + INSTALL_LOG_FILE->( $mod ) + ); + if ( open my $fh, ">$file" ) { + my $stack = CPANPLUS::Error->stack_as_string; + ### remove everything in the log that was there *before* + ### we started this install + substr( $stack, 0, $log_length, '' ); + + print $fh $stack; + close $fh; + + $self->__print( + loc("*** Install log written to:\n %1\n\n", $file) + ); + } else { + warn "Could not open '$file': $!\n"; + next; + } + } + } + + my $flag; + ### then report whether all this went ok or not ### + for my $mod (@$mods) { + # if( $mod->status->installed ) { + if( $status->{$mod} ) { + $self->__print( + loc("Module '%1' %tense(%2,past) successfully\n", + $mod->module, $action) + ); + } else { + $flag++; + $self->__print( + loc("Error %tense(%1,present) '%2'\n", $action, $mod->module) + ); + } + } + + + + if( !$flag ) { + $self->__print( + loc("No errors %tense(%1,present) all modules", $action), "\n" + ); + } else { + $self->__print( + loc("Problem %tense(%1,present) one or more modules", $action) + ); + $self->__print( "\n" ); + + $self->__print( + loc("*** You can view the complete error buffer by pressing ". + "'%1' ***\n", 'p') + ) unless $conf->get_conf('verbose') || $self->noninteractive; + } + $self->__print( "\n" ); + + return !$flag; +} + +sub __ask_about_install { + my $mod = shift or return; + my $prereq = shift or return; + my $term = $Shell->term; + + $Shell->__print( "\n" ); + $Shell->__print( loc("Module '%1' requires '%2' to be installed", + $mod->module, $prereq->module ) ); + $Shell->__print( "\n\n" ); + + ### previously cached answer? + return $Shell->settings->{'install_all_prereqs'} + if defined $Shell->settings->{'install_all_prereqs'}; + + + $Shell->__print( + loc( "If you don't wish to see this question anymore\n". + "you can disable it by entering the following ". + "commands on the prompt:\n '%1'", + 's conf prereqs 1; s save' ) ); + $Shell->__print("\n\n"); + + my $yes = loc("Yes"); + my $no = loc("No"); + my $all = loc("Yes to all (for this module)"); + my $none = loc("No to all (for this module)"); + + my $reply = $term->get_reply( + prompt => loc("Should I install this module?"), + choices => [ $yes, $no, $all, $none ], + default => $yes, + ); + + ### if 'all' or 'none', save this, so we can apply it to + ### other prereqs in this chain. + $Shell->settings->{'install_all_prereqs'} = + $reply eq $all ? 1 : + $reply eq $none ? 0 : + undef; + + ### if 'yes' or 'all', the user wants it installed + return $reply eq $all ? 1 : + $reply eq $yes ? 1 : + 0; +} + +sub __ask_about_send_test_report { + my($mod, $grade) = @_; + return 1 unless $grade eq GRADE_FAIL; + + my $term = $Shell->term; + + $Shell->__print( "\n" ); + $Shell->__print( + loc("Test report prepared for module '%1'.\n Would you like to ". + "send it? (You can edit it if you like)", $mod->module ) ); + $Shell->__print( "\n\n" ); + my $bool = $term->ask_yn( + prompt => loc("Would you like to send the test report?"), + default => 'n' + ); + + return $bool; +} + +sub __ask_about_edit_test_report { + my($mod, $grade) = @_; + return 0 unless $grade eq GRADE_FAIL; + + my $term = $Shell->term; + + $Shell->__print( "\n" ); + $Shell->__print( + loc("Test report prepared for module '%1'. You can edit this ". + "report if you would like", $mod->module ) ); + $Shell->__print("\n\n"); + my $bool = $term->ask_yn( + prompt => loc("Would you like to edit the test report?"), + default => 'y' + ); + + return $bool; +} + +sub __ask_about_test_failure { + my $mod = shift; + my $captured = shift || ''; + my $term = $Shell->term; + + $Shell->__print( "\n" ); + $Shell->__print( + loc( "The tests for '%1' failed. Would you like me to proceed ". + "anyway or should we abort?", $mod->module ) ); + $Shell->__print( "\n\n" ); + + my $bool = $term->ask_yn( + prompt => loc("Proceed anyway?"), + default => 'n', + ); + + return $bool; +} + + +sub _details { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my $args; my $mods; my $opts; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { required => 1, store => \$mods }, + options => { default => { }, store => \$opts }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + ### every module has about 10 lines of details + ### maybe more later with Module::CPANTS etc + $self->_pager_open if scalar @$mods * 10 > $self->_term_rowcount; + + + my $format = "%-24s %-45s\n"; + my $cformat = "%-24s %-45s %-10s\n"; + for my $mod (@$mods) { + my $href = $mod->details( %$opts ); + my @list = sort { $a->module cmp $b->module } $mod->contains; + + unless( $href ) { + $self->__print( + loc("No details for %1 - it might be outdated.", + $mod->module), "\n" ); + next; + + } else { + $self->__print( loc( "Details for '%1'\n", $mod->module ) ); + for my $item ( sort keys %$href ) { + $self->__printf( $format, $item, $href->{$item} ); + } + + my $showed; + for my $item ( @list ) { + $self->__printf( + $cformat, ($showed ? '' : 'Contains:'), + $item->module, $item->version + ); + $showed++; + } + $self->__print( "\n" ); + } + } + $self->_pager_close; + $self->__print( "\n" ); + + return 1; +} + +sub _print { + my $self = shift; + my %hash = @_; + + my $args; my $opts; my $file; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + input => { default => '', store => \$file }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my $old; my $fh; + if( $file ) { + $fh = FileHandle->new( ">$file" ) + or( warn loc("Could not open '%1': '%2'", $file, $!), + return + ); + $old = select $fh; + } + + + $self->_pager_open if !$file; + + $self->__print( CPANPLUS::Error->stack_as_string ); + + $self->_pager_close; + + select $old if $old; + $self->__print( "\n" ); + + return 1; +} + +sub _set_conf { + my $self = shift; + my %hash = @_; + my $cb = $self->backend; + my $conf = $cb->configure_object; + + ### possible options + ### XXX hard coded, not optimal :( + my %types = ( + reconfigure => '', + save => q([user | system | boxed]), + edit => '', + program => q([key => val]), + conf => q([key => val]), + mirrors => '', + selfupdate => '', # XXX add all opts here? + ); + + + my $args; my $opts; my $input; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + input => { default => '', store => \$input }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my ($type,$key,$value) = $input =~ m/(\w+)\s*(\w*)\s*(.*?)$/; + $value =~ s/\s+$//g if $value; + $type = lc $type; + + if( $type eq 'reconfigure' ) { + my $setup = CPANPLUS::Configure::Setup->new( + configure_object => $conf, + term => $self->term, + backend => $cb, + ); + return $setup->init; + + } elsif ( $type eq 'save' ) { + my $where = { + user => CONFIG_USER, + system => CONFIG_SYSTEM, + boxed => CONFIG_BOXED, + }->{ $key } || CONFIG_USER; + + ### boxed is special, so let's get its value from %INC + ### so we can tell it where to save + ### XXX perhaps this logic should be generic for all + ### types, and put in the ->save() routine + my $dir; + if( $where eq CONFIG_BOXED ) { + my $file = join( '/', split( '::', CONFIG_BOXED ) ) . '.pm'; + my $file_re = quotemeta($file); + + my $path = $INC{$file} || ''; + $path =~ s/$file_re$//; + $dir = $path; + } + + my $rv = $cb->configure_object->save( $where => $dir ); + + $self->__print( + $rv + ? loc("Configuration successfully saved to %1\n (%2)\n", + $where, $rv) + : loc("Failed to save configuration\n" ) + ); + return $rv; + + } elsif ( $type eq 'edit' ) { + + my $editor = $conf->get_program('editor') + or( print(loc("No editor specified")), return ); + + my $where = { + user => CONFIG_USER, + system => CONFIG_SYSTEM, + }->{ $key } || CONFIG_USER; + + my $file = $conf->_config_pm_to_file( $where ); + system($editor,$file); + + ### now reload it + ### disable warnings for this + { require Module::Loaded; + Module::Loaded::mark_as_unloaded( $where ); + + ### reinitialize the config + local $^W; + $conf->init; + } + + return 1; + + } elsif ( $type eq 'mirrors' ) { + + $self->__print( + loc("Readonly list of mirrors (in order of preference):\n\n" ) ); + + my $i; + for my $host ( @{$conf->get_conf('hosts')} ) { + my $uri = $cb->_host_to_uri( %$host ); + + $i++; + $self->__print( "\t[$i] $uri\n" ); + } + + $self->__print( + loc("\nTo edit this list, please type: '%1'\n", 's edit') ); + + } elsif ( $type eq 'selfupdate' ) { + my %valid = map { $_ => $_ } + $cb->selfupdate_object->list_categories; + + unless( $valid{$key} ) { + $self->__print( + loc( "To update your current CPANPLUS installation, ". + "choose one of the these options:\n%1", + ( join $/, map { + sprintf "\ts selfupdate %-17s " . + "[--latest=0] [--dryrun]", $_ + } sort keys %valid ) + ) + ); + } else { + my %update_args = ( + update => $key, + latest => 1, + %$opts + ); + + + my %list = $cb->selfupdate_object + ->list_modules_to_update( %update_args ); + + $self->__print(loc("The following updates will take place:"),$/.$/); + + for my $feature ( sort keys %list ) { + my $aref = $list{$feature}; + + ### is it a 'feature' or a built in? + $self->__print( + $valid{$feature} + ? " " . ucfirst($feature) . ":\n" + : " Modules for '$feature' support:\n" + ); + + ### show what modules would be installed + $self->__print( + scalar @$aref + ? map { sprintf " %-42s %-6s -> %-6s \n", + $_->name, $_->installed_version, $_->version + } @$aref + : " No upgrades required\n" + ); + $self->__print( $/ ); + } + + + unless( $opts->{'dryrun'} ) { + $self->__print( loc("Updating your CPANPLUS installation\n") ); + $cb->selfupdate_object->selfupdate( %update_args ); + } + } + + } else { + + if ( $type eq 'program' or $type eq 'conf' ) { + + my $format = { + conf => '%-25s %s', + program => '%-12s %s', + }->{ $type }; + + unless( $key ) { + my @list = grep { $_ ne 'hosts' } + $conf->options( type => $type ); + + my $method = 'get_' . $type; + + local $Data::Dumper::Indent = 0; + for my $name ( @list ) { + my $val = $conf->$method($name) || ''; + ($val) = ref($val) + ? (Data::Dumper::Dumper($val) =~ /= (.*);$/) + : "'$val'"; + + $self->__printf( " $format\n", $name, $val ); + } + + } elsif ( $key eq 'hosts' or $key eq 'lib' ) { + $self->__print( + loc( "Setting %1 is not trivial.\n" . + "It is suggested you use '%2' and edit the " . + "configuration file manually", $key, 's edit') + ); + } else { + my $method = 'set_' . $type; + $conf->$method( $key => defined $value ? $value : '' ) + and $self->__print( loc("Key '%1' was set to '%2'", $key, + defined $value ? $value : 'EMPTY STRING') ); + } + + } else { + $self->__print( loc("Unknown type '%1'",$type || 'EMPTY' ) ); + $self->__print( $/ ); + $self->__print( loc("Try one of the following:") ); + $self->__print( $/, join $/, + map { sprintf "\t%-11s %s", $_, $types{$_} } + sort keys %types ); + } + } + $self->__print( "\n" ); + return 1; +} + +sub _uptodate { + my $self = shift; + my %hash = @_; + my $cb = $self->backend; + my $conf = $cb->configure_object; + + my $opts; my $mods; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + modules => { required => 1, store => \$mods }, + }; + + check( $tmpl, \%hash ) or return; + } + + ### long listing? short is default ### + my $long = $opts->{'long'} ? 1 : 0; + + my @list = scalar @$mods ? @$mods : @{$cb->_all_installed}; + + my @rv; my %seen; + for my $mod (@list) { + ### skip this mod if it's up to date ### + next if $mod->is_uptodate; + ### skip this mod if it's core ### + next if $mod->package_is_perl_core; + + if( $long or !$seen{$mod->package}++ ) { + push @rv, $mod; + } + } + + @rv = sort { $a->module cmp $b->module } @rv; + + $self->cache([undef,@rv]); + + $self->_pager_open if scalar @rv >= $self->_term_rowcount; + + my $format = "%5s %12s %12s %-36s %-10s\n"; + + my $i = 1; + for my $mod ( @rv ) { + $self->__printf( + $format, + $i, + $self->_format_version($mod->installed_version) || 'Unparsable', + $self->_format_version( $mod->version ), + $mod->module, + $mod->author->cpanid + ); + $i++; + } + $self->_pager_close; + + return 1; +} + +sub _autobundle { + my $self = shift; + my %hash = @_; + my $cb = $self->backend; + my $conf = $cb->configure_object; + + my $opts; my $input; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + input => { default => '', store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + } + + $opts->{'path'} = $input if $input; + + my $where = $cb->autobundle( %$opts ); + + $self->__print( + $where + ? loc("Wrote autobundle to '%1'", $where) + : loc("Could not create autobundle" ) + ); + $self->__print( "\n" ); + + return $where ? 1 : 0; +} + +sub _uninstall { + my $self = shift; + my %hash = @_; + my $cb = $self->backend; + my $term = $self->term; + my $conf = $cb->configure_object; + + my $opts; my $mods; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + modules => { default => [], store => \$mods }, + }; + + check( $tmpl, \%hash ) or return; + } + + my $force = $opts->{'force'} || $conf->get_conf('force'); + + unless( $force ) { + my $list = join "\n", map { ' ' . $_->module } @$mods; + + $self->__print( loc(" +This will uninstall the following modules: +%1 + +Note that if you installed them via a package manager, you probably +should use the same package manager to uninstall them + +", $list) ); + + return unless $term->ask_yn( + prompt => loc("Are you sure you want to continue?"), + default => 'n', + ); + } + + ### first loop over all the modules to uninstall them ### + for my $mod (@$mods) { + $self->__print( loc("Uninstalling '%1'", $mod->module), "\n" ); + + $mod->uninstall( %$opts ); + } + + my $flag; + ### then report whether all this went ok or not ### + for my $mod (@$mods) { + if( $mod->status->uninstall ) { + $self->__print( + loc("Module '%1' %tense(uninstall,past) successfully\n", + $mod->module ) ); + } else { + $flag++; + $self->__print( + loc("Error %tense(uninstall,present) '%1'\n", $mod->module) ); + } + } + + if( !$flag ) { + $self->__print( + loc("All modules %tense(uninstall,past) successfully"), "\n" ); + } else { + $self->__print( + loc("Problem %tense(uninstall,present) one or more modules" ), + "\n" ); + + $self->__print( + loc("*** You can view the complete error buffer by pressing '%1'". + "***\n", 'p') ) unless $conf->get_conf('verbose'); + } + $self->__print( "\n" ); + + return !$flag; +} + +sub _reports { + my $self = shift; + my %hash = @_; + my $cb = $self->backend; + my $term = $self->term; + my $conf = $cb->configure_object; + + my $opts; my $mods; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + modules => { default => '', store => \$mods }, + }; + + check( $tmpl, \%hash ) or return; + } + + ### XXX might need to be conditional ### + $self->_pager_open; + + for my $mod (@$mods) { + my @list = $mod->fetch_report( %$opts ) + or( print(loc("No reports available for this distribution.")), + next + ); + + @list = reverse + map { $_->[0] } + sort { $a->[1] cmp $b->[1] } + map { [$_, $_->{'dist'}.':'.$_->{'platform'}] } @list; + + + + ### XXX this may need to be sorted better somehow ### + my $url; + my $format = "%8s %s %s\n"; + + my %seen; + for my $href (@list ) { + $self->__print( + "[" . $mod->author->cpanid .'/'. $href->{'dist'} . "]\n" + ) unless $seen{ $href->{'dist'} }++; + + $self->__printf( + $format, + $href->{'grade'}, + $href->{'platform'}, + ($href->{'details'} ? '(*)' : '') + ); + + $url ||= $href->{'details'}; + } + + $self->__print( "\n==> $url\n" ) if $url; + $self->__print( "\n" ); + } + $self->_pager_close; + + return 1; +} + +### Load plugins +{ my @PluginModules; + my %Dispatch = ( + showtip => [ __PACKAGE__, '_show_random_tip'], + plugins => [ __PACKAGE__, '_list_plugins' ], + '?' => [ __PACKAGE__, '_plugins_usage' ], + ); + + sub plugin_modules { return @PluginModules } + sub plugin_table { return %Dispatch } + + my $init_done; + sub _plugins_init { + + ### only initialize once + return if $init_done++; + + ### find all plugins first + if( check_install( module => 'Module::Pluggable', version => '2.4') ) { + require Module::Pluggable; + + my $only_re = __PACKAGE__ . '::Plugins::\w+$'; + + Module::Pluggable->import( + sub_name => '_plugins', + search_path => __PACKAGE__, + only => qr/$only_re/, + #except => [ INSTALLER_MM, INSTALLER_SAMPLE ] + ); + + push @PluginModules, __PACKAGE__->_plugins; + } + + ### now try to load them + for my $p ( __PACKAGE__->plugin_modules ) { + my %map = eval { load $p; $p->import; $p->plugins }; + error(loc("Could not load plugin '$p': $@")), next if $@; + + ### register each plugin + while( my($name, $func) = each %map ) { + + if( not length $name or not length $func ) { + error(loc("Empty plugin name or dispatch function detected")); + next; + } + + if( exists( $Dispatch{$name} ) ) { + error(loc("'%1' is already registered by '%2'", + $name, $Dispatch{$name}->[0])); + next; + } + + ### register name, package and function + $Dispatch{$name} = [ $p, $func ]; + } + } + } + + ### dispatch a plugin command to its function + sub _meta { + my $self = shift; + my %hash = @_; + my $cb = $self->backend; + my $term = $self->term; + my $conf = $cb->configure_object; + + my $opts; my $input; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + input => { default => '', store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + } + + $input =~ s/\s*(\S+)\s*//; + my $cmd = $1; + + ### look up the command, or go to the default + my $aref = $Dispatch{ $cmd } || [ __PACKAGE__, '_plugin_default' ]; + + my($pkg,$func) = @$aref; + + my $rv = eval { $pkg->$func( $self, $cb, $cmd, $input, $opts ) }; + + error( $@ ) if $@; + + ### return $rv instead, so input loop can be terminated? + return 1; + } + + sub _plugin_default { error(loc("No such plugin command")) } +} + +### plugin commands +{ my $help_format = " /%-21s # %s\n"; + + sub _list_plugins { + my $self = shift; + + $self->__print( loc("Available plugins:\n") ); + $self->__print( loc(" List usage by using: /? PLUGIN_NAME\n" ) ); + $self->__print( $/ ); + + my %table = __PACKAGE__->plugin_table; + for my $name( sort keys %table ) { + my $pkg = $table{$name}->[0]; + my $this = __PACKAGE__; + + my $who = $pkg eq $this + ? "Standard Plugin" + : do { my $v = $self->_format_version($pkg->VERSION) || ''; + $pkg =~ s/^$this/../; + sprintf "Provided by: %-30s %-10s", $pkg, $v; + }; + + $self->__printf( $help_format, $name, $who ); + } + + $self->__print( $/.$/ ); + + $self->__print( + " Write your own plugins? Read the documentation of:\n" . + " CPANPLUS::Shell::Default::Plugins::HOWTO\n" ); + + $self->__print( $/ ); + } + + sub _list_plugins_help { + return sprintf $help_format, 'plugins', loc("lists available plugins"); + } + + ### registered as a plugin too + sub _show_random_tip_help { + return sprintf $help_format, 'showtip', loc("show usage tips" ); + } + + sub _plugins_usage { + my $self = shift; + my $shell = shift; + my $cb = shift; + my $cmd = shift; + my $input = shift; + my %table = $self->plugin_table; + + my @list = length $input ? split /\s+/, $input : sort keys %table; + + for my $name( @list ) { + + ### no such plugin? skip + error(loc("No such plugin '$name'")), next unless $table{$name}; + + my $pkg = $table{$name}->[0]; + my $func = $table{$name}->[1] . '_help'; + + if ( my $sub = $pkg->can( $func ) ) { + eval { $self->__print( $sub->() ) }; + error( $@ ) if $@; + + } else { + $self->__print(" No usage for '$name' -- try perldoc $pkg"); + } + + $self->__print( $/ ); + } + + $self->__print( $/.$/ ); + } + + sub _plugins_usage_help { + return sprintf $help_format, '? [NAME ...]', + loc("show usage for plugins"); + } +} + +### send a command to a remote host, retrieve the answer; +sub __send_remote_command { + my $self = shift; + my $cmd = shift; + my $remote = $self->remote or return; + my $user = $remote->{'username'}; + my $pass = $remote->{'password'}; + my $conn = $remote->{'connection'}; + my $end = "\015\012"; + my $answer; + + my $send = join "\0", $user, $pass, $cmd; + + print $conn $send . $end; + + ### XXX why doesn't something like this just work? + #1 while recv($conn, $answer, 1024, 0); + while(1) { + my $buff; + $conn->recv( $buff, 1024, 0 ); + $answer .= $buff; + last if $buff =~ /$end$/; + } + + my($status,$buffer) = split "\0", $answer; + + return ($status, $buffer); +} + + +sub _read_configuration_from_rc { + my $self = shift; + my $rc_file = shift; + + my $href; + if( can_load( modules => { 'Config::Auto' => '0.0' } ) ) { + $Config::Auto::DisablePerl = 1; + + eval { $href = Config::Auto::parse( $rc_file, format => 'space' ) }; + + $self->__print( + loc( "Unable to read in config file '%1': %2", $rc_file, $@ ) + ) if $@; + } + + return $href || {}; +} + +{ my @tips = ( + loc( "You can update CPANPLUS by running: '%1'", 's selfupdate' ), + loc( "You can install modules by URL using '%1'", 'i URL' ), + loc( "You can turn off these tips using '%1'", + 's conf show_startup_tip 0' ), + loc( "You can use wildcards like '%1' and '%2' on search results", + '*', '2..5' ) , + loc( "You can use plugins. Type '%1' to list available plugins", + '/plugins' ), + loc( "You can show all your out of date modules using '%1'", 'o' ), + loc( "Many operations take options, like '%1', '%2' or '%3'", + '--verbose', '--force', '--skiptest' ), + loc( "The documentation in %1 and %2 is very useful", + "CPANPLUS::Module", "CPANPLUS::Backend" ), + loc( "You can type '%1' for help and '%2' to exit", 'h', 'q' ), + loc( "You can run an interactive setup using '%1'", 's reconfigure' ), + loc( "You can add custom sources to your index. See '%1' for details", + '/cs --help' ), + loc( "CPANPLUS now has an experimental SQLite backend. You can enable ". + "it via: '%1'. Update dependencies via '%2'", + 's conf source_engine CPANPLUS::Internals::Source::SQLite; s save', + 's selfupdate enabled_features ' ), + ); + + sub _show_random_tip { + my $self = shift; + $self->__print( $/, "Did you know...\n ", + $tips[ int rand scalar @tips ], $/ ); + return 1; + } +} + +1; + +__END__ + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Shell::Classic>, L<CPANPLUS::Shell>, L<cpanp> + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + +__END__ + +TODO: + e => "_expand_inc", # scratch it, imho -- not used enough + +### free letters: g j k n y ### diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm new file mode 100755 index 00000000000..ad4701a488c --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm @@ -0,0 +1,201 @@ +package CPANPLUS::Shell::Default::Plugins::CustomSource; + +use strict; +use CPANPLUS::Error qw[error msg]; +use CPANPLUS::Internals::Constants; + +use Data::Dumper; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +=head1 NAME + +CPANPLUS::Shell::Default::Plugins::CustomSource + +=head1 SYNOPSIS + + ### elaborate help text + CPAN Terminal> /? cs + + ### add a new custom source + CPAN Terminal> /cs --add file:///path/to/releases + + ### list all your custom sources by + CPAN Terminal> /cs --list + + ### display the contents of a custom source by URI or ID + CPAN Terminal> /cs --contents file:///path/to/releases + CPAN Terminal> /cs --contents 1 + + ### Update a custom source by URI or ID + CPAN Terminal> /cs --update file:///path/to/releases + CPAN Terminal> /cs --update 1 + + ### Remove a custom source by URI or ID + CPAN Terminal> /cs --remove file:///path/to/releases + CPAN Terminal> /cs --remove 1 + + ### Write an index file for a custom source, to share + ### with 3rd parties or remote users + CPAN Terminal> /cs --write file:///path/to/releases + + ### Make sure to save your sources when adding/removing + ### sources, so your changes are reflected in the cache: + CPAN Terminal> x + +=head1 DESCRIPTION + +This is a C<CPANPLUS::Shell::Default> plugin that can add +custom sources to your CPANPLUS installation. This is a +wrapper around the C<custom module sources> code as outlined +in L<CPANPLUS::Backend/CUSTOM MODULE SOURCES>. + +This allows you to extend your index of available modules +beyond what's available on C<CPAN> with your own local +distributions, or ones offered by third parties. + +=cut + + +sub plugins { + return ( cs => 'custom_source' ) +} + +my $Cb; +my $Shell; +my @Index = (); + +sub _uri_from_cache { + my $self = shift; + my $input = shift or return; + + ### you gave us a search number + my $uri = $input =~ /^\d+$/ + ? $Index[ $input - 1 ] # remember, off by 1! + : $input; + + my %files = reverse $Cb->list_custom_sources; + + ### it's an URI we know + ### VMS can lower case all files, so make sure we check that too + my $local = $files{ $uri }; + $local = $files{ lc $uri } if !$local && ON_VMS; + + if( $local ) { + return wantarray + ? ($uri, $local) + : $uri; + } + + ### couldn't resolve the input + error(loc("Unknown URI/index: '%1'", $input)); + return; +} + +sub _list_custom_sources { + my $class = shift; + + my %files = $Cb->list_custom_sources; + + $Shell->__print( loc("Your remote sources:"), $/ ) if keys %files; + + my $i = 0; + while(my($local,$remote) = each %files) { + $Shell->__printf( " [%2d] %s\n", ++$i, $remote ); + + ### remember, off by 1! + push @Index, $remote; + } + + $Shell->__print( $/ ); +} + +sub _list_contents { + my $class = shift; + my $input = shift; + + my ($uri,$local) = $class->_uri_from_cache( $input ); + unless( $uri ) { + error(loc("--contents needs URI parameter")); + return; + } + + my $fh = OPEN_FILE->( $local ) or return; + + $Shell->__printf( " %s", $_ ) for sort <$fh>; + $Shell->__print( $/ ); +} + +sub custom_source { + my $class = shift; + my $shell = shift; $Shell = $shell; # available to all methods now + my $cb = shift; $Cb = $cb; # available to all methods now + my $cmd = shift; + my $input = shift || ''; + my $opts = shift || {}; + + ### show a list + if( $opts->{'list'} ) { + $class->_list_custom_sources; + + } elsif ( $opts->{'contents'} ) { + $class->_list_contents( $input ); + + } elsif ( $opts->{'add'} ) { + unless( $input ) { + error(loc("--add needs URI parameter")); + return; + } + + $cb->add_custom_source( uri => $input ) + and $shell->__print(loc("Added remote source '%1'", $input), $/); + + $Shell->__print($/, loc("Remote source contains:"), $/, $/); + $class->_list_contents( $input ); + + } elsif ( $opts->{'remove'} ) { + my($uri,$local) = $class->_uri_from_cache( $input ); + unless( $uri ) { + error(loc("--remove needs URI parameter")); + return; + } + + 1 while unlink $local; + + $shell->__print( loc("Removed remote source '%1'", $uri), $/ ); + + } elsif ( $opts->{'update'} ) { + ### did we get input? if so, it's a remote part + my $uri = $class->_uri_from_cache( $input ); + + $cb->update_custom_source( $uri ? ( remote => $uri ) : () ) + and do { $shell->__print( loc("Updated remote sources"), $/ ) }; + + } elsif ( $opts->{'write'} ) { + $cb->write_custom_source_index( path => $input ) and + $shell->__print( loc("Wrote remote source index for '%1'", $input), $/); + + } else { + error(loc("Unrecognized command, see '%1' for help", '/? cs')); + } + + return; +} + +sub custom_source_help { + return loc( + $/ . + ' # Plugin to manage custom sources from the default shell' . $/ . + " # See the 'CUSTOM MODULE SOURCES' section in the " . $/ . + ' # CPANPLUS::Backend documentation for details.' . $/ . + ' /cs --list # list available sources' . $/ . + ' /cs --add URI # add source' . $/ . + ' /cs --remove URI | INDEX # remove source' . $/ . + ' /cs --contents URI | INDEX # show packages from source'. $/ . + ' /cs --update [URI | INDEX] # update source index' . $/ . + ' /cs --write PATH # write source index' . $/ + ); + +} + +1; + diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod new file mode 100755 index 00000000000..ca765f9e0ac --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod @@ -0,0 +1,136 @@ +=head1 NAME + +CPANPLUS::Shell::Default::Plugins::HOWTO -- documentation on how to write your own plugins + +=head1 SYNOPSIS + + package CPANPLUS::Shell::Default::Plugins::MyPlugin; + + ### return command => method mapping + sub plugins { ( myplugin1 => 'mp1', myplugin2 => 'mp2' ) } + + ### method called when the command '/myplugin1' is issued + sub mp1 { .... } + + ### method called when the command '/? myplugin1' is issued + sub mp1_help { return "Help Text" } + +=head1 DESCRIPTION + +This pod text explains how to write your own plugins for +C<CPANPLUS::Shell::Default>. + +=head1 HOWTO + +=head2 Registering Plugin Modules + +Plugins are detected by using C<Module::Pluggable>. Every module in +the C<CPANPLUS::Shell::Default::Plugins::*> namespace is considered a +plugin, and is attempted to be loaded. + +Therefor, any plugin must be declared in that namespace, in a corresponding +C<.pm> file. + +=head2 Registering Plugin Commands + +To register any plugin commands, a list of key value pairs must be returned +by a C<plugins> method in your package. The keys are the commands you wish +to register, the values are the methods in the plugin package you wish to have +called when the command is issued. + +For example, a simple 'Hello, World!' plugin: + + package CPANPLUS::Shell::Default::Plugins::HW; + + sub plugins { return ( helloworld => 'hw' ) }; + + sub hw { print "Hello, world!\n" } + +When the user in the default shell now issues the C</helloworld> command, +this command will be dispatched to the plugin, and its C<hw> method will +be called + +=head2 Registering Plugin Help + +To provide usage information for your plugin, the user of the default shell +can type C</? PLUGIN_COMMAND>. In that case, the function C<PLUGIN_COMMAND_help> +will be called in your plugin package. + +For example, extending the above example, when a user calls C</? helloworld>, +the function C<hw_help> will be called, which might look like this: + + sub hw_help { " /helloworld # prints "Hello, world!\n" } + +If you dont provide a corresponding _help function to your commands, the +default shell will handle it gracefully, but the user will be stuck without +usage information on your commands, so it's considered undesirable to omit +the help functions. + +=head2 Arguments to Plugin Commands + +Any plugin function will receive the following arguments when called, which +are all positional: + +=over 4 + +=item Classname -- The name of your plugin class + +=item Shell -- The CPANPLUS::Shell::Default object + +=item Backend -- The CPANPLUS::Backend object + +=item Command -- The command issued by the user + +=item Input -- The input string from the user + +=item Options -- A hashref of options provided by the user + +=back + +For example, the following command: + + /helloworld bob --nofoo --bar=2 joe + +Would yield the following arguments: + + sub hw { + my $class = shift; # CPANPLUS::Shell::Default::Plugins::HW + my $shell = shift; # CPANPLUS::Shell::Default object + my $cb = shift; # CPANPLUS::Backend object + my $cmd = shift; # 'helloworld' + my $input = shift; # 'bob joe' + my $opts = shift; # { foo => 0, bar => 2 } + + .... + } + + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell>, L<cpanp> + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm new file mode 100755 index 00000000000..d2b829abded --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm @@ -0,0 +1,186 @@ +package CPANPLUS::Shell::Default::Plugins::Remote; + +use strict; + +use Module::Load; +use Params::Check qw[check]; +use CPANPLUS::Error qw[error msg]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +=head1 NAME + +CPANPLUS::Shell::Default::Plugins::Remote + +=head1 SYNOPSIS + + CPAN Terminal> /connect localhost 1337 --user=foo --pass=bar + ... + CPAN Terminal@localhost> /disconnect + +=head1 DESCRIPTION + +This is a C<CPANPLUS::Shell::Default> plugin that allows you to connect +to a machine running an instance of C<CPANPLUS::Daemon>, allowing remote +usage of the C<CPANPLUS Shell>. + +A sample session, updating all modules on a remote machine, might look +like this: + + CPAN Terminal> /connect --user=my_user --pass=secret localhost 1337 + + Connection accepted + + Successfully connected to 'localhost' on port '11337' + + Note that no output will appear until a command has completed + -- this may take a while + + + CPAN Terminal@localhost> o; i * + + [....] + + CPAN Terminal@localhost> /disconnect + + CPAN Terminal> + +=cut + +### store the original prompt here, so we can restore it on disconnect +my $Saved_Prompt; + +sub plugins { ( connect => 'connect', disconnect => 'disconnect' ) } + +sub connect { + my $class = shift; + my $shell = shift; + my $cb = shift; + my $cmd = shift; + my $input = shift || ''; + my $opts = shift || {}; + my $conf = $cb->configure_object; + + my $user; my $pass; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + user => { default => 'cpanpd', store => \$user }, + pass => { required => 1, store => \$pass }, + }; + + check( $tmpl, $opts ) or return; + } + + my @parts = split /\s+/, $input; + my $host = shift @parts || 'localhost'; + my $port = shift @parts || '1337'; + + load IO::Socket; + + my $remote = IO::Socket::INET->new( + Proto => "tcp", + PeerAddr => $host, + PeerPort => $port, + ) or ( + error( loc( "Cannot connect to port '%1' ". + "on host '%2'", $port, $host ) ), + return + ); + + my $con = { + connection => $remote, + username => $user, + password => $pass, + }; + + ### store the connection + $shell->remote( $con ); + + my($status,$buffer) = $shell->__send_remote_command( + "VERSION=$CPANPLUS::Shell::Default::VERSION"); + + if( $status ) { + print "\n$buffer\n\n"; + + print loc( "Successfully connected to '%1' on port '%2'", + $host, $port ); + print "\n\n"; + print loc( "Note that no output will appear until a command ". + "has completed\n-- this may take a while" ); + print "\n\n"; + + ### save the original prompt + $Saved_Prompt = $shell->prompt; + + $shell->prompt( $shell->brand .'@'. $host .':'. $port .'> ' ); + + } else { + print "\n$buffer\n\n"; + + print loc( "Failed to connect to '%1' on port '%2'", + $host, $port ); + print "\n\n"; + + $shell->remote( undef ); + } +} + +sub disconnect { + my $class = shift; + my $shell = shift; + + print "\n", ( $shell->remote + ? loc( "Disconnecting from remote host" ) + : loc( "Not connected to remote host" ) + ), "\n\n"; + + $shell->remote( undef ); + $shell->prompt( $Saved_Prompt ); +} + +sub connect_help { + return loc( + " /connect [HOST PORT] # Connect to the remote machine,\n" . + " # defaults taken from your config\n" . + " --user=USER # Optional username\n" . + " --pass=PASS # Optional password" ); +} + +sub disconnect_help { + return loc( + " /disconnect # Disconnect from the remote server" ); +} + +1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell>, L<cpanp> + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default/Plugins/Source.pm b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default/Plugins/Source.pm new file mode 100755 index 00000000000..889b3d3d9bd --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPANPLUS/Shell/Default/Plugins/Source.pm @@ -0,0 +1,107 @@ +package CPANPLUS::Shell::Default::Plugins::Source; + +use strict; +use CPANPLUS::Error qw[error msg]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +=head1 NAME + +CPANPLUS::Shell::Default::Plugins::Source + +=head1 SYNOPSIS + + CPAN Terminal> /source /tmp/list_of_commands /tmp/more_commands + +=head1 DESCRIPTION + +This is a C<CPANPLUS::Shell::Default> plugin that works just like +your unix shells source(1) command; it reads in a file that has +commands in it to execute, and then executes them. + +A sample file might look like this: + + # first, update all the source files + x --update_source + + # find all of my modules that are on the CPAN + # test them, and store the error log + a ^KANE$' + t * + p /home/kane/cpan-autotest/log + + # and inform us we're good to go + ! print "Autotest complete, log stored; please enter your commands!" + +Note how empty lines, and lines starting with a '#' are being skipped +in the execution. + +=cut + + +sub plugins { return ( source => 'source' ) } + +sub source { + my $class = shift; + my $shell = shift; + my $cb = shift; + my $cmd = shift; + my $input = shift || ''; + my $opts = shift || {}; + my $verbose = $cb->configure_object->get_conf('verbose'); + + for my $file ( split /\s+/, $input ) { + my $fh = FileHandle->new("$file") or( + error(loc("Could not open file '%1': %2", $file, $!)), + next + ); + + while( my $line = <$fh> ) { + chomp $line; + + next if $line !~ /\S+/; # skip empty/whitespace only lines + next if $line =~ /^#/; # skip comments + + msg(loc("Dispatching '%1'", $line), $verbose); + return 1 if $shell->dispatch_on_input( input => $line ); + } + } +} + +sub source_help { + return loc(' /source FILE [FILE ..] '. + '# read in commands from the specified file' ), +} + +1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell>, L<cpanp> + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + |