summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm346
1 files changed, 198 insertions, 148 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm
index 96370046255..1f75535fa65 100644
--- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm
@@ -21,22 +21,22 @@ use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
$Params::Check::VERBOSE = 1;
### list of methods the parent class must implement
-{ for my $sub ( qw[_init_trees _finalize_trees
+{ for my $sub ( qw[_init_trees _finalize_trees
_standard_trees_completed _custom_trees_completed
_add_module_object _add_author_object _save_state
- ]
+ ]
) {
no strict 'refs';
- *$sub = sub {
+ *$sub = sub {
my $self = shift;
my $class = ref $self || $self;
-
- require Carp;
- Carp::croak( loc( "Class %1 must implement method '%2'",
+
+ require Carp;
+ Carp::croak( loc( "Class %1 must implement method '%2'",
$class, $sub ) );
}
}
-}
+}
{
my $recurse; # flag to prevent recursive calls to *_tree functions
@@ -74,7 +74,7 @@ $Params::Check::VERBOSE = 1;
=head1 NAME
-CPANPLUS::Internals::Source
+CPANPLUS::Internals::Source - internals for updating source files
=head1 SYNOPSIS
@@ -98,14 +98,14 @@ The flow looks like this:
$cb->_check_trees
$cb->__check_uptodate
$cb->_update_source
- $cb->__update_custom_module_sources
+ $cb->__update_custom_module_sources
$cb->__update_custom_module_source
$cb->_build_trees
### engine methods
{ $cb->_init_trees;
$cb->_standard_trees_completed
$cb->_custom_trees_completed
- }
+ }
$cb->__create_author_tree
### engine methods
{ $cb->_add_author_object }
@@ -113,7 +113,7 @@ The flow looks like this:
$cb->__create_dslip_tree
### engine methods
{ $cb->_add_module_object }
- $cb->__create_custom_module_entries
+ $cb->__create_custom_module_entries
$cb->_dslip_defs
@@ -177,43 +177,43 @@ sub _build_trees {
) or do {
error( loc("Could not initialize trees" ) );
return;
- };
+ };
### return if we weren't able to build the trees ###
return unless $self->_mtree && $self->_atree;
-
+
### did we get everything from a stored state? if not,
### process them now.
if( not $self->_standard_trees_completed ) {
-
+
### first, prep the author tree
$self->__create_author_tree(
uptodate => $uptodate,
path => $path,
- verbose => $verbose,
+ verbose => $verbose,
) or return;
### and now the module tree
$self->_create_mod_tree(
uptodate => $uptodate,
path => $path,
- verbose => $verbose,
+ verbose => $verbose,
) or return;
}
-
+
### XXX unpleasant hack. since custom sources uses ->parse_module, we
- ### already have a special module object with extra meta data. that
+ ### already have a special module object with extra meta data. that
### doesn't gelwell with the sqlite storage engine. So, we check 'normal'
### trees from separate trees, so the engine can treat them differently.
### Effectively this means that with the SQLite engine, for now, custom
### sources are continuously reparsed =/ -kane
if( not $self->_custom_trees_completed ) {
-
+
### update them if the other sources are also deemed out of date
if( $conf->get_conf('enable_custom_sources') ) {
- $self->__update_custom_module_sources( verbose => $verbose )
+ $self->__update_custom_module_sources( verbose => $verbose )
or error(loc("Could not update custom module sources"));
- }
+ }
### add custom sources here if enabled
if( $conf->get_conf('enable_custom_sources') ) {
@@ -226,13 +226,13 @@ sub _build_trees {
$self->_finalize_trees(
path => $path,
uptodate => $uptodate,
- verbose => $verbose,
+ verbose => $verbose,
use_stored => $use_stored,
) or do {
error(loc( "Could not finalize trees" ));
return;
- };
-
+ };
+
### still necessary? can only run one instance now ###
### will probably stay that way --kane
# my $id = $self->_store_id( $self );
@@ -320,7 +320,7 @@ sub _check_trees {
### as well
### RT #47820: Don't try to update custom sources if they are disabled
### in the configuration.
- $self->__update_custom_module_sources( verbose => $verbose )
+ $self->__update_custom_module_sources( verbose => $verbose )
if $conf->get_conf('enable_custom_sources') and ( $update_source or !$uptodate );
return $uptodate;
@@ -389,7 +389,7 @@ sub __check_uptodate {
if ( $flag or $args->{'update_source'} ) {
if ( $self->_update_source( name => $args->{'name'} ) ) {
- return 0; # return 0 so 'uptodate' will be set to 0, meaning no
+ return 0; # return 0 so 'uptodate' will be set to 0, meaning no
# use of previously stored hashrefs!
} else {
msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} );
@@ -549,6 +549,16 @@ sub __create_author_tree {
### don't need it anymore ###
unlink $out;
+ my ($tot,$prce,$prc,$idx);
+
+ $args->{verbose}
+ and local $|=1,
+ $tot = scalar(split /\n/, $cont),
+ ($prce, $prc, $idx) = (int $tot / 25, 0, 0);
+
+ $args->{verbose}
+ and print "\t0%";
+
for ( split /\n/, $cont ) {
my($id, $name, $email) = m/^alias \s+
(\S+) \s+
@@ -561,8 +571,24 @@ sub __create_author_tree {
cpanid => $id, #authors CPAN ID
) or error( loc("Could not add author '%1'", $name ) );
+ $args->{verbose}
+ and (
+ $idx++,
+
+ ($idx==$prce
+ and ($prc+=4,$idx=0,print ".")),
+
+ (($prc % 10)
+ or $idx
+ or print $prc,'%')
+ );
+
}
+ $args->{verbose}
+ and print "\n";
+
+
return $self->_atree;
} #__create_author_tree
@@ -636,9 +662,17 @@ sub _create_mod_tree {
### don't need it anymore ###
unlink $out;
- my($past_header, $count);
- for ( split /\n/, $content ) {
+ my($past_header, $count, $tot, $prce, $prc, $idx);
+
+ $args->{verbose}
+ and local $|=1,
+ $tot = scalar(split /\n/, $content),
+ ($prce, $prc, $idx) = (int $tot / 25, 0, 0);
+
+ $args->{verbose}
+ and print "\t0%";
+ for ( split /\n/, $content ) {
### quick hack to read past the header of the file ###
### this is still rather evil... fix some time - Kane
if( m|^\s*$| ) {
@@ -647,11 +681,11 @@ sub _create_mod_tree {
return;
}
$past_header = 1;
- }
-
+ }
+
### we're still in the header -- find the amount of lines we expect
unless( $past_header ) {
-
+
### if the line count doesn't match what we expect, bail out
### this should address: #45644: detect broken index
$count = $1 if /^Line-Count:\s+(\d+)/;
@@ -661,12 +695,12 @@ sub _create_mod_tree {
"contains only %3 lines!",
$count, $file, $lines ));
return;
- }
+ }
}
### still in the header, keep moving
next;
}
-
+
### skip empty lines ###
next unless /\S/;
chomp;
@@ -704,7 +738,7 @@ sub _create_mod_tree {
? $dslip_tree->{ $data[0] }->{$item}
: ' ';
}
-
+
### XXX this could be sped up if we used author names, not author
### objects in creation, and then look them up in the author tree
### when needed. This will need a fix to all the places that create
@@ -713,9 +747,9 @@ sub _create_mod_tree {
### callback to store the individual object
$self->_add_module_object(
module => $data[0], # full module name
- version => ($data[1] eq 'undef' # version number
- ? '0.0'
- : $data[1]),
+ version => ($data[1] eq 'undef' # version number
+ ? '0.0'
+ : $data[1]),
path => File::Spec::Unix->catfile(
$conf->_get_mirror('base'),
$data[2],
@@ -730,8 +764,23 @@ sub _create_mod_tree {
mtime => '',
) or error( loc( "Could not add module '%1'", $data[0] ) );
+ $args->{verbose}
+ and (
+ $idx++,
+
+ ($idx==$prce
+ and ($prc+=4,$idx=0,print ".")),
+
+ (($prc % 10)
+ or $idx
+ or print $prc,'%')
+ );
+
} #for
+ $args->{verbose}
+ and print "\n";
+
return $self->_mtree;
} #_create_mod_tree
@@ -822,9 +871,9 @@ sub __create_dslip_tree {
### use this regex to make sure dslips with ';' in them don't cause
### parser errors
my ($ds_one, $ds_two) = ($in =~ m|.+}\s+
- (\$(?:CPAN::Modulelist::)?cols.*?)
- (\$(?:CPAN::Modulelist::)?data.*)
- |sx);
+ (\$(?:CPAN::Modulelist::)?cols.*?)
+ (\$(?:CPAN::Modulelist::)?data.*)
+ |sx);
### eval them into existence ###
### still not too fond of this solution - kane ###
@@ -925,7 +974,7 @@ sub _dslip_defs {
return $aref;
}
-=head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] );
+=head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] );
Adds a custom source index and updates it based on the provided URI.
@@ -937,16 +986,16 @@ sub _add_custom_module_source {
my $self = shift;
my $conf = $self->configure_object;
my %hash = @_;
-
+
my($verbose,$uri);
- my $tmpl = {
+ my $tmpl = {
verbose => { default => $conf->get_conf('verbose'),
store => \$verbose },
uri => { required => 1, store => \$uri }
};
-
+
check( $tmpl, \%hash ) or return;
-
+
### what index file should we use on disk?
my $index = $self->__custom_module_source_index_file( uri => $uri );
@@ -954,29 +1003,29 @@ sub _add_custom_module_source {
if( IS_FILE->( $index ) ) {
msg(loc("Source '%1' already added", $uri));
return 1;
- }
-
- ### do we need to create the targe dir?
+ }
+
+ ### do we need to create the targe dir?
{ my $dir = dirname( $index );
unless( IS_DIR->( $dir ) ) {
$self->_mkdir( dir => $dir ) or return
}
- }
-
+ }
+
### write the file
my $fh = OPEN_FILE->( $index => '>' ) or do {
error(loc("Could not open index file for '%1'", $uri));
return;
};
-
- ### basically we 'touched' it. Check the return value, may be
+
+ ### basically we 'touched' it. Check the return value, may be
### important on win32 and similar OS, where there's file length
### limits
close $fh or do {
error(loc("Could not write index file to disk for '%1'", $uri));
return;
- };
-
+ };
+
$self->__update_custom_module_source(
remote => $uri,
local => $index,
@@ -985,9 +1034,9 @@ sub _add_custom_module_source {
### we faild to update it, we probably have an empty
### possibly silly filename on disk now -- remove it
1 while unlink $index;
- return;
+ return;
};
-
+
return $index;
}
@@ -1002,24 +1051,24 @@ sub __custom_module_source_index_file {
my $self = shift;
my $conf = $self->configure_object;
my %hash = @_;
-
+
my($verbose,$uri);
- my $tmpl = {
+ my $tmpl = {
uri => { required => 1, store => \$uri }
};
-
+
check( $tmpl, \%hash ) or return;
-
+
my $index = File::Spec->catfile(
$conf->get_conf('base'),
- $conf->_get_build('custom_sources'),
+ $conf->_get_build('custom_sources'),
$self->_uri_encode( uri => $uri ),
- );
+ );
return $index;
}
-=head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] );
+=head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] );
Removes a custom index file based on the URI provided.
@@ -1031,19 +1080,19 @@ sub _remove_custom_module_source {
my $self = shift;
my $conf = $self->configure_object;
my %hash = @_;
-
+
my($verbose,$uri);
- my $tmpl = {
+ my $tmpl = {
verbose => { default => $conf->get_conf('verbose'),
store => \$verbose },
uri => { required => 1, store => \$uri }
};
-
+
check( $tmpl, \%hash ) or return;
### use uri => local, instead of the other way around
my %files = reverse $self->__list_custom_module_sources;
-
+
### On VMS the case of key to %files can be either exact or lower case
### XXX abstract this lookup out? --kane
my $file = $files{ $uri };
@@ -1053,15 +1102,15 @@ sub _remove_custom_module_source {
error(loc("No such custom source '%1'", $uri));
return;
};
-
+
1 while unlink $file;
-
+
if( IS_FILE->( $file ) ) {
error(loc("Could not remove index file '%1' for custom source '%2'",
$file, $uri));
return;
- }
-
+ }
+
msg(loc("Successfully removed index file for '%1'", $uri), $verbose);
return $file;
@@ -1081,12 +1130,12 @@ Returns a list of key value pairs as follows:
sub __list_custom_module_sources {
my $self = shift;
my $conf = $self->configure_object;
-
+
my($verbose);
- my $tmpl = {
+ my $tmpl = {
verbose => { default => $conf->get_conf('verbose'),
store => \$verbose },
- };
+ };
my $dir = File::Spec->catdir(
$conf->get_conf('base'),
@@ -1097,16 +1146,16 @@ sub __list_custom_module_sources {
msg(loc("No '%1' dir, skipping custom sources", $dir), $verbose);
return;
}
-
+
### unencode the files
### skip ones starting with # though
- my %files = map {
- my $org = $_;
- my $dec = $self->_uri_decode( uri => $_ );
+ my %files = map {
+ my $org = $_;
+ my $dec = $self->_uri_decode( uri => $_ );
File::Spec->catfile( $dir, $org ) => $dec
- } grep { $_ !~ /^#/ } READ_DIR->( $dir );
+ } grep { $_ !~ /^#/ } READ_DIR->( $dir );
- return %files;
+ return %files;
}
=head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] );
@@ -1124,35 +1173,35 @@ sub __update_custom_module_sources {
my $self = shift;
my $conf = $self->configure_object;
my %hash = @_;
-
+
my $verbose;
- my $tmpl = {
+ my $tmpl = {
verbose => { default => $conf->get_conf('verbose'),
store => \$verbose }
};
-
+
check( $tmpl, \%hash ) or return;
-
+
my %files = $self->__list_custom_module_sources;
-
- ### uptodate check has been done a few levels up.
+
+ ### uptodate check has been done a few levels up.
my $fail;
while( my($local,$remote) = each %files ) {
-
+
$self->__update_custom_module_source(
remote => $remote,
local => $local,
verbose => $verbose,
- ) or ( $fail++, next );
+ ) or ( $fail++, next );
}
-
+
error(loc("Failed updating one or more remote sources files")) if $fail;
-
+
return if $fail;
return 1;
}
-=head2 $ok = $cb->__update_custom_module_source
+=head2 $ok = $cb->__update_custom_module_source
Attempts to update all the index files to your custom module sources.
@@ -1167,9 +1216,9 @@ sub __update_custom_module_source {
my $self = shift;
my $conf = $self->configure_object;
my %hash = @_;
-
+
my($verbose,$local,$remote);
- my $tmpl = {
+ my $tmpl = {
verbose => { default => $conf->get_conf('verbose'),
store => \$verbose },
local => { store => \$local, allow => FILE_EXISTS },
@@ -1179,7 +1228,7 @@ sub __update_custom_module_source {
check( $tmpl, \%hash ) or return;
msg( loc("Updating sources from '%1'", $remote), $verbose);
-
+
### if you didn't provide a local file, we'll look in your custom
### dir to find the local encoded version for you
$local ||= do {
@@ -1187,7 +1236,7 @@ sub __update_custom_module_source {
my %files = reverse $self->__list_custom_module_sources or do {
error(loc("No custom modules sources defined -- need '%1' argument",
'local'));
- return;
+ return;
};
### On VMS the case of key to %files can be either exact or lower case
@@ -1200,68 +1249,69 @@ sub __update_custom_module_source {
error(loc("Remote source '%1' unknown -- needs '%2' argument",
$remote, 'local'));
return;
- };
+ };
};
-
+
my $uri = join '/', $remote, $conf->_get_source('custom_index');
- my $ff = File::Fetch->new( uri => $uri );
+ my $ff = File::Fetch->new( uri => $uri );
### tempdir doesn't clean up by default, as opposed to tempfile()
### so add it explicitly.
my $dir = tempdir( CLEANUP => 1 );
-
- my $res = do { local $File::Fetch::WARN = 0;
+
+ my $res = do {
local $File::Fetch::WARN = 0;
+ local $File::Fetch::TIMEOUT = $conf->get_conf('timeout');
$ff->fetch( to => $dir );
- };
+ };
### couldn't get the file
unless( $res ) {
-
+
### it's not a local scheme, so can't auto index
unless( $ff->scheme eq 'file' ) {
error(loc("Could not update sources from '%1': %2",
$remote, $ff->error ));
- return;
-
+ return;
+
### it's a local uri, we can index it ourselves
} else {
msg(loc("No index file found at '%1', generating one",
$ff->uri), $verbose );
-
+
### ON VMS, if you are working with a UNIX file specification,
### you need currently use the UNIX variants of the File::Spec.
my $ff_path = do {
my $file_class = 'File::Spec';
$file_class .= '::Unix' if ON_VMS;
$file_class->catdir( File::Spec::Unix->splitdir( $ff->path ) );
- };
+ };
$self->__write_custom_module_index(
path => $ff_path,
to => $local,
verbose => $verbose,
) or return;
-
+
### XXX don't write that here, __write_custom_module_index
### already prints this out
#msg(loc("Index file written to '%1'", $to), $verbose);
}
-
+
### copy it to the real spot and update its timestamp
- } else {
+ } else {
$self->_move( file => $res, to => $local ) or return;
$self->_update_timestamp( file => $local );
-
+
msg(loc("Index file saved to '%1'", $local), $verbose);
}
-
+
return $local;
}
=head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] )
-Scans the C<path> you provided for packages and writes an index with all
+Scans the C<path> you provided for packages and writes an index with all
the available packages to C<$path/packages.txt>. If you'd like the index
to be written to a different file, provide the C<to> argument.
@@ -1273,29 +1323,29 @@ sub __write_custom_module_index {
my $self = shift;
my $conf = $self->configure_object;
my %hash = @_;
-
+
my ($verbose, $path, $to);
- my $tmpl = {
+ my $tmpl = {
verbose => { default => $conf->get_conf('verbose'),
store => \$verbose },
path => { required => 1, allow => DIR_EXISTS, store => \$path },
to => { store => \$to },
};
-
- check( $tmpl, \%hash ) or return;
+
+ check( $tmpl, \%hash ) or return;
### no explicit to? then we'll use our default
$to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') );
my @files;
require File::Find;
- File::Find::find( sub {
+ File::Find::find( sub {
### let's see if A::E can even parse it
my $ae = do {
local $Archive::Extract::WARN = 0;
local $Archive::Extract::WARN = 0;
- Archive::Extract->new( archive => $File::Find::name )
- } or return;
+ Archive::Extract->new( archive => $File::Find::name )
+ } or return;
### it's a type A::E recognize, so we can add it
$ae->type or return;
@@ -1305,11 +1355,11 @@ sub __write_custom_module_index {
### path, so we have to strip it ourselves
### make sure to remove the leading slash as well.
my $copy = $File::Find::name;
- my $re = quotemeta($path);
+ my $re = quotemeta($path);
$copy =~ s|^$re[\\/]?||i;
-
+
push @files, $copy;
-
+
}, $path );
### does the dir exist? if not, create it.
@@ -1317,80 +1367,80 @@ sub __write_custom_module_index {
unless( IS_DIR->( $dir ) ) {
$self->_mkdir( dir => $dir ) or return
}
- }
+ }
### create the index file
my $fh = OPEN_FILE->( $to => '>' ) or return;
-
+
print $fh "$_\n" for @files;
close $fh;
-
+
msg(loc("Successfully written index file to '%1'", $to), $verbose);
-
+
return $to;
}
-=head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] )
+=head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] )
Creates entries in the module tree based upon the files as returned
by C<__list_custom_module_sources>.
Returns true on success, false on failure.
-=cut
+=cut
### use $auth_obj as a persistent version, so we don't have to recreate
### modules all the time
-{ my $auth_obj;
+{ my $auth_obj;
sub __create_custom_module_entries {
my $self = shift;
my $conf = $self->configure_object;
my %hash = @_;
-
+
my $verbose;
my $tmpl = {
verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
};
-
+
check( $tmpl, \%hash ) or return undef;
-
- my %files = $self->__list_custom_module_sources;
-
+
+ my %files = $self->__list_custom_module_sources;
+
while( my($file,$name) = each %files ) {
-
+
msg(loc("Adding packages from custom source '%1'", $name), $verbose);
-
+
my $fh = OPEN_FILE->( $file ) or next;
-
+
while( local $_ = <$fh> ) {
chomp;
next if /^#/;
next unless /\S+/;
-
+
### join on / -- it's a URI after all!
my $parse = join '/', $name, $_;
-
+
### try to make a module object out of it
my $mod = $self->parse_module( module => $parse ) or (
error(loc("Could not parse '%1'", $_)),
next
);
-
+
### mark this object with a custom author
$auth_obj ||= do {
my $id = CUSTOM_AUTHOR_ID;
-
+
### if the object is being created for the first time,
### make sure there's an entry in the author tree as
### well, so we can search on the CPAN ID
- $self->author_tree->{ $id } =
- CPANPLUS::Module::Author::Fake->new( cpanid => $id );
+ $self->author_tree->{ $id } =
+ CPANPLUS::Module::Author::Fake->new( cpanid => $id );
};
-
+
$mod->author( $auth_obj );
-
+
### and now add it to the module tree -- this MAY
### override things of course
if( my $old_mod = $self->module_tree( $mod->module ) ) {
@@ -1401,15 +1451,15 @@ Returns true on success, false on failure.
msg(loc("About to overwrite module tree entry for '%1' with '%2'",
$mod->module, $mod->package), $verbose);
}
-
+
### mark where it came from
$mod->description( loc("Custom source from '%1'",$name) );
-
+
### store it in the module tree
$self->module_tree->{ $mod->module } = $mod;
}
}
-
+
return 1;
}
}