diff options
| author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
|---|---|---|
| committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
| commit | 316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch) | |
| tree | cb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/CPANPLUS | |
| parent | cd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff) | |
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS')
42 files changed, 0 insertions, 21134 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm deleted file mode 100755 index a599e5429eb..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm +++ /dev/null @@ -1,1330 +0,0 @@ -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/lib/CPANPLUS/Backend/RV.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Backend/RV.pm deleted file mode 100755 index 9edbe0452c9..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Backend/RV.pm +++ /dev/null @@ -1,144 +0,0 @@ -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/lib/CPANPLUS/Config.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Config.pm deleted file mode 100755 index 71d2b4fd03a..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Config.pm +++ /dev/null @@ -1,849 +0,0 @@ -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/lib/CPANPLUS/Configure.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm deleted file mode 100755 index baac91dc886..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm +++ /dev/null @@ -1,630 +0,0 @@ -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/lib/CPANPLUS/Configure/Setup.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm deleted file mode 100755 index 3bcf8f45090..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm +++ /dev/null @@ -1,1653 +0,0 @@ -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/lib/CPANPLUS/Dist.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm deleted file mode 100755 index 00c68c39806..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm +++ /dev/null @@ -1,688 +0,0 @@ -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/lib/CPANPLUS/Dist/Autobundle.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Autobundle.pm deleted file mode 100755 index 16638b258f8..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Autobundle.pm +++ /dev/null @@ -1,117 +0,0 @@ -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/lib/CPANPLUS/Dist/Base.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Base.pm deleted file mode 100755 index c7108ed1392..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Base.pm +++ /dev/null @@ -1,261 +0,0 @@ -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/lib/CPANPLUS/Dist/Build.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build.pm deleted file mode 100755 index 0f27639cda5..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build.pm +++ /dev/null @@ -1,836 +0,0 @@ -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/lib/CPANPLUS/Dist/Build/Constants.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build/Constants.pm deleted file mode 100755 index 1ac02108e44..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build/Constants.pm +++ /dev/null @@ -1,69 +0,0 @@ -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/lib/CPANPLUS/Dist/MM.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/MM.pm deleted file mode 100755 index be65cd43cc8..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/MM.pm +++ /dev/null @@ -1,1007 +0,0 @@ -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/lib/CPANPLUS/Dist/Sample.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Sample.pm deleted file mode 100755 index 0b0939208ff..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Sample.pm +++ /dev/null @@ -1,16 +0,0 @@ -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/lib/CPANPLUS/Error.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Error.pm deleted file mode 100755 index 38710a8a857..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Error.pm +++ /dev/null @@ -1,201 +0,0 @@ -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/lib/CPANPLUS/FAQ.pod b/Master/tlpkg/tlperl/lib/CPANPLUS/FAQ.pod deleted file mode 100755 index 82bb57aaf47..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/FAQ.pod +++ /dev/null @@ -1,30 +0,0 @@ -=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/lib/CPANPLUS/Hacking.pod b/Master/tlpkg/tlperl/lib/CPANPLUS/Hacking.pod deleted file mode 100755 index 1a28b9e5b05..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Hacking.pod +++ /dev/null @@ -1,135 +0,0 @@ -=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/lib/CPANPLUS/Internals.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals.pm deleted file mode 100755 index 1c21bbec0ee..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals.pm +++ /dev/null @@ -1,516 +0,0 @@ -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/lib/CPANPLUS/Internals/Constants.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants.pm deleted file mode 100755 index 1a38200dfb7..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants.pm +++ /dev/null @@ -1,375 +0,0 @@ -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/lib/CPANPLUS/Internals/Constants/Report.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants/Report.pm deleted file mode 100755 index 59a41a6083b..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants/Report.pm +++ /dev/null @@ -1,407 +0,0 @@ -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/lib/CPANPLUS/Internals/Extract.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm deleted file mode 100755 index 84a48a50dea..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm +++ /dev/null @@ -1,243 +0,0 @@ -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/lib/CPANPLUS/Internals/Fetch.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm deleted file mode 100755 index 395965bab60..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm +++ /dev/null @@ -1,473 +0,0 @@ -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/lib/CPANPLUS/Internals/Report.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm deleted file mode 100755 index 774c6b91a02..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm +++ /dev/null @@ -1,645 +0,0 @@ -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/lib/CPANPLUS/Internals/Search.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Search.pm deleted file mode 100755 index 63c4da64d92..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Search.pm +++ /dev/null @@ -1,363 +0,0 @@ -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/lib/CPANPLUS/Internals/Source.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm deleted file mode 100755 index 54e9d710cfd..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm +++ /dev/null @@ -1,1417 +0,0 @@ -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/lib/CPANPLUS/Internals/Source/Memory.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm deleted file mode 100755 index cb3fd4f1e76..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm +++ /dev/null @@ -1,374 +0,0 @@ -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/lib/CPANPLUS/Internals/Source/SQLite.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite.pm deleted file mode 100755 index a0ddf499bf6..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite.pm +++ /dev/null @@ -1,326 +0,0 @@ -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/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm deleted file mode 100755 index f908c9803e4..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm +++ /dev/null @@ -1,145 +0,0 @@ -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/lib/CPANPLUS/Internals/Utils.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm deleted file mode 100755 index 8475c362023..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm +++ /dev/null @@ -1,657 +0,0 @@ -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/lib/CPANPLUS/Internals/Utils/Autoflush.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils/Autoflush.pm deleted file mode 100755 index 56566436a14..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils/Autoflush.pm +++ /dev/null @@ -1,5 +0,0 @@ -package CPANPLUS::Internals::Utils::Autoflush; - -BEGIN { $|++ }; - -1; diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm deleted file mode 100755 index 2122c6d51f9..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm +++ /dev/null @@ -1,1816 +0,0 @@ -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/lib/CPANPLUS/Module/Author.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm deleted file mode 100755 index 92940fa51ff..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm +++ /dev/null @@ -1,232 +0,0 @@ -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/lib/CPANPLUS/Module/Author/Fake.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm deleted file mode 100755 index 3156c5c7abb..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm +++ /dev/null @@ -1,80 +0,0 @@ -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/lib/CPANPLUS/Module/Checksums.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm deleted file mode 100755 index e1a2bbdb6ad..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm +++ /dev/null @@ -1,251 +0,0 @@ -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/lib/CPANPLUS/Module/Fake.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm deleted file mode 100755 index 84d0233cf83..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm +++ /dev/null @@ -1,86 +0,0 @@ -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/lib/CPANPLUS/Module/Signature.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Signature.pm deleted file mode 100755 index cec6f2906b0..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Signature.pm +++ /dev/null @@ -1,65 +0,0 @@ -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/lib/CPANPLUS/Selfupdate.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm deleted file mode 100755 index 48f918ce82e..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm +++ /dev/null @@ -1,547 +0,0 @@ -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/lib/CPANPLUS/Shell.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell.pm deleted file mode 100755 index 854d46b16a4..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell.pm +++ /dev/null @@ -1,341 +0,0 @@ -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/lib/CPANPLUS/Shell/Classic.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Classic.pm deleted file mode 100755 index 08c03bcf383..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Classic.pm +++ /dev/null @@ -1,1236 +0,0 @@ -################################################## -### 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/lib/CPANPLUS/Shell/Default.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm deleted file mode 100755 index a441c87e794..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm +++ /dev/null @@ -1,1938 +0,0 @@ -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/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm deleted file mode 100755 index ad4701a488c..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm +++ /dev/null @@ -1,201 +0,0 @@ -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/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod deleted file mode 100755 index ca765f9e0ac..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod +++ /dev/null @@ -1,136 +0,0 @@ -=head1 NAME - -CPANPLUS::Shell::Default::Plugins::HOWTO -- documentation on how to write your own plugins - -=head1 SYNOPSIS - - package CPANPLUS::Shell::Default::Plugins::MyPlugin; - - ### return command => method mapping - sub plugins { ( myplugin1 => 'mp1', myplugin2 => 'mp2' ) } - - ### method called when the command '/myplugin1' is issued - sub mp1 { .... } - - ### method called when the command '/? myplugin1' is issued - sub mp1_help { return "Help Text" } - -=head1 DESCRIPTION - -This pod text explains how to write your own plugins for -C<CPANPLUS::Shell::Default>. - -=head1 HOWTO - -=head2 Registering Plugin Modules - -Plugins are detected by using C<Module::Pluggable>. Every module in -the C<CPANPLUS::Shell::Default::Plugins::*> namespace is considered a -plugin, and is attempted to be loaded. - -Therefor, any plugin must be declared in that namespace, in a corresponding -C<.pm> file. - -=head2 Registering Plugin Commands - -To register any plugin commands, a list of key value pairs must be returned -by a C<plugins> method in your package. The keys are the commands you wish -to register, the values are the methods in the plugin package you wish to have -called when the command is issued. - -For example, a simple 'Hello, World!' plugin: - - package CPANPLUS::Shell::Default::Plugins::HW; - - sub plugins { return ( helloworld => 'hw' ) }; - - sub hw { print "Hello, world!\n" } - -When the user in the default shell now issues the C</helloworld> command, -this command will be dispatched to the plugin, and its C<hw> method will -be called - -=head2 Registering Plugin Help - -To provide usage information for your plugin, the user of the default shell -can type C</? PLUGIN_COMMAND>. In that case, the function C<PLUGIN_COMMAND_help> -will be called in your plugin package. - -For example, extending the above example, when a user calls C</? helloworld>, -the function C<hw_help> will be called, which might look like this: - - sub hw_help { " /helloworld # prints "Hello, world!\n" } - -If you dont provide a corresponding _help function to your commands, the -default shell will handle it gracefully, but the user will be stuck without -usage information on your commands, so it's considered undesirable to omit -the help functions. - -=head2 Arguments to Plugin Commands - -Any plugin function will receive the following arguments when called, which -are all positional: - -=over 4 - -=item Classname -- The name of your plugin class - -=item Shell -- The CPANPLUS::Shell::Default object - -=item Backend -- The CPANPLUS::Backend object - -=item Command -- The command issued by the user - -=item Input -- The input string from the user - -=item Options -- A hashref of options provided by the user - -=back - -For example, the following command: - - /helloworld bob --nofoo --bar=2 joe - -Would yield the following arguments: - - sub hw { - my $class = shift; # CPANPLUS::Shell::Default::Plugins::HW - my $shell = shift; # CPANPLUS::Shell::Default object - my $cb = shift; # CPANPLUS::Backend object - my $cmd = shift; # 'helloworld' - my $input = shift; # 'bob joe' - my $opts = shift; # { foo => 0, bar => 2 } - - .... - } - - -=head1 BUG REPORTS - -Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. - -=head1 AUTHOR - -This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=head1 SEE ALSO - -L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell>, L<cpanp> - -=cut - -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# vim: expandtab shiftwidth=4: - diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm deleted file mode 100755 index d2b829abded..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm +++ /dev/null @@ -1,186 +0,0 @@ -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/lib/CPANPLUS/Shell/Default/Plugins/Source.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Source.pm deleted file mode 100755 index 889b3d3d9bd..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Source.pm +++ /dev/null @@ -1,107 +0,0 @@ -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: - |