diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm | 346 |
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; } } |