File Coverage

lib/CPANPLUS/Internals/Source.pm
Criterion Covered Total %
statement 337 388 86.8
branch 99 172 57.5
condition 23 58 39.6
subroutine 36 38 94.7
pod n/a
total 495 656 75.4


line stmt bran cond sub pod time code
1             package CPANPLUS::Internals::Source;
2              
3 16     16   179 use strict;
  16         75  
  16         776  
4              
5 16     16   189 use CPANPLUS::Error;
  16         82  
  16         2390  
6 16     16   154 use CPANPLUS::Module;
  16         60  
  16         1107  
7 16     16   6903 use CPANPLUS::Module::Fake;
  16         62  
  16         697  
8 16     16   142 use CPANPLUS::Module::Author;
  16         49  
  16         499  
9 16     16   185 use CPANPLUS::Internals::Constants;
  16         41  
  16         10210  
10              
11 16     16   174 use File::Fetch;
  16         44  
  16         759  
12 16     16   120 use Archive::Extract;
  16         60  
  16         844  
13              
14 16     16   129 use IPC::Cmd qw[can_run];
  16         59  
  16         1496  
15 16     16   135 use File::Temp qw[tempdir];
  16         50  
  16         1290  
16 16     16   118 use File::Basename qw[dirname];
  16         41  
  16         1340  
17 16     16   142 use Params::Check qw[check];
  16         50  
  16         898  
18 16     16   158 use Module::Load::Conditional qw[can_load];
  16         45  
  16         1197  
19 16     16   127 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  16         47  
  16         330  
20              
21 16     16   6641 use vars qw[$VERSION];
  16         59  
  16         1529  
22             $VERSION = "0.9914";
23              
24             $Params::Check::VERBOSE = 1;
25              
26             ### list of methods the parent class must implement
27             { for my $sub ( qw[_init_trees _finalize_trees
28             _standard_trees_completed _custom_trees_completed
29             _add_module_object _add_author_object _save_state
30             ]
31             ) {
32 16     16   122 no strict 'refs';
  16         50  
  16         27735  
33             *$sub = sub {
34 0     0   0 my $self = shift;
35 0   0     0 my $class = ref $self || $self;
36              
37 0         0 require Carp;
38 0         0 Carp::croak( loc( "Class %1 must implement method '%2'",
39             $class, $sub ) );
40             }
41             }
42             }
43              
44             {
45             my $recurse; # flag to prevent recursive calls to *_tree functions
46              
47             ### lazy loading of module tree
48             sub _module_tree {
49 3397     3397   9980 my $self = $_[0];
50              
51 3397 100 66     9891 unless ($self->_mtree or $recurse++ > 0) {
52 9         108 my $uptodate = $self->_check_trees( @_[1..$#_] );
53 9         827 $self->_build_trees(uptodate => $uptodate);
54             }
55              
56 3397         5967 $recurse--;
57 3397         7437 return $self->_mtree;
58             }
59              
60             ### lazy loading of author tree
61             sub _author_tree {
62 165     165   608 my $self = $_[0];
63              
64 165 50 33     889 unless ($self->_atree or $recurse++ > 0) {
65 0         0 my $uptodate = $self->_check_trees( @_[1..$#_] );
66 0         0 $self->_build_trees(uptodate => $uptodate);
67             }
68              
69 165         481 $recurse--;
70 165         544 return $self->_atree;
71             }
72              
73             }
74              
75              
76             =pod
77              
78             =head1 NAME
79              
80             CPANPLUS::Internals::Source - internals for updating source files
81              
82             =head1 SYNOPSIS
83              
84             ### lazy load author/module trees ###
85              
86             $cb->_author_tree;
87             $cb->_module_tree;
88              
89             =head1 DESCRIPTION
90              
91             CPANPLUS::Internals::Source controls the updating of source files and
92             the parsing of them into usable module/author trees to be used by
93             C.
94              
95             Functions exist to check if source files are still C as
96             well as update them, and then parse them.
97              
98             The flow looks like this:
99              
100             $cb->_author_tree || $cb->_module_tree
101             $cb->_check_trees
102             $cb->__check_uptodate
103             $cb->_update_source
104             $cb->__update_custom_module_sources
105             $cb->__update_custom_module_source
106             $cb->_build_trees
107             ### engine methods
108             { $cb->_init_trees;
109             $cb->_standard_trees_completed
110             $cb->_custom_trees_completed
111             }
112             $cb->__create_author_tree
113             ### engine methods
114             { $cb->_add_author_object }
115             $cb->__create_module_tree
116             $cb->__create_dslip_tree
117             ### engine methods
118             { $cb->_add_module_object }
119             $cb->__create_custom_module_entries
120              
121             $cb->_dslip_defs
122              
123             =head1 METHODS
124              
125             =cut
126              
127             =pod
128              
129             =head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] )
130              
131             This method rebuilds the author- and module-trees from source.
132              
133             It takes the following arguments:
134              
135             =over 4
136              
137             =item uptodate
138              
139             Indicates whether any on disk caches are still ok to use.
140              
141             =item path
142              
143             The absolute path to the directory holding the source files.
144              
145             =item verbose
146              
147             A boolean flag indicating whether or not to be verbose.
148              
149             =item use_stored
150              
151             A boolean flag indicating whether or not it is ok to use previously
152             stored trees. Defaults to true.
153              
154             =back
155              
156             Returns a boolean indicating success.
157              
158             =cut
159              
160             ### (re)build the trees ###
161             sub _build_trees {
162 32     32   1000871 my ($self, %hash) = @_;
163 32         464 my $conf = $self->configure_object;
164              
165 32         201 my($path,$uptodate,$use_stored,$verbose);
166 32         409 my $tmpl = {
167             path => { default => $conf->get_conf('base'), store => \$path },
168             verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
169             uptodate => { required => 1, store => \$uptodate },
170             use_stored => { default => 1, store => \$use_stored },
171             };
172              
173 32 50       314 my $args = check( $tmpl, \%hash ) or return;
174              
175             $self->_init_trees(
176             path => $path,
177             uptodate => $uptodate,
178             verbose => $verbose,
179             use_stored => $use_stored,
180 32 50       6203 ) or do {
181 0         0 error( loc("Could not initialize trees" ) );
182 0         0 return;
183             };
184              
185             ### return if we weren't able to build the trees ###
186 32 50 33     165 return unless $self->_mtree && $self->_atree;
187              
188             ### did we get everything from a stored state? if not,
189             ### process them now.
190 32 100       305 if( not $self->_standard_trees_completed ) {
191              
192             ### first, prep the author tree
193 31 50       366 $self->__create_author_tree(
194             uptodate => $uptodate,
195             path => $path,
196             verbose => $verbose,
197             ) or return;
198              
199             ### and now the module tree
200 31 50       608 $self->_create_mod_tree(
201             uptodate => $uptodate,
202             path => $path,
203             verbose => $verbose,
204             ) or return;
205             }
206              
207             ### XXX unpleasant hack. since custom sources uses ->parse_module, we
208             ### already have a special module object with extra meta data. That
209             ### doesn't go well with the sqlite storage engine. So, we check 'normal'
210             ### trees from separate trees, so the engine can treat them differently.
211             ### Effectively this means that with the SQLite engine, for now, custom
212             ### sources are continuously reparsed =/ -kane
213 32 100       532 if( not $self->_custom_trees_completed ) {
214              
215             ### update them if the other sources are also deemed out of date
216 31 100       962 if( $conf->get_conf('enable_custom_sources') ) {
217 2 50       33 $self->__update_custom_module_sources( verbose => $verbose )
218             or error(loc("Could not update custom module sources"));
219             }
220              
221             ### add custom sources here if enabled
222 31 100       278 if( $conf->get_conf('enable_custom_sources') ) {
223 2 50       40 $self->__create_custom_module_entries( verbose => $verbose )
224             or error(loc("Could not create custom module entries"));
225             }
226             }
227              
228             ### give the source engine a chance to wrap up creation
229             $self->_finalize_trees(
230             path => $path,
231             uptodate => $uptodate,
232             verbose => $verbose,
233             use_stored => $use_stored,
234 32 50       407 ) or do {
235 0         0 error(loc( "Could not finalize trees" ));
236 0         0 return;
237             };
238              
239             ### still necessary? can only run one instance now ###
240             ### will probably stay that way --kane
241             # my $id = $self->_store_id( $self );
242             #
243             # unless ( $id == $self->_id ) {
244             # error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) );
245             # }
246              
247 32         1921 return 1;
248             }
249              
250             =pod
251              
252             =head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] )
253              
254             Retrieve source files and return a boolean indicating whether or not
255             the source files are up to date.
256              
257             Takes several arguments:
258              
259             =over 4
260              
261             =item update_source
262              
263             A flag to force re-fetching of the source files, even
264             if they are still up to date.
265              
266             =item path
267              
268             The absolute path to the directory holding the source files.
269              
270             =item verbose
271              
272             A boolean flag indicating whether or not to be verbose.
273              
274             =back
275              
276             Will get information from the config file by default.
277              
278             =cut
279              
280             ### retrieve source files, and returns a boolean indicating if it's up to date
281             sub _check_trees {
282 30     30   157 my ($self, %hash) = @_;
283 30         140 my $conf = $self->configure_object;
284              
285 30         123 my $update_source;
286             my $verbose;
287 30         0 my $path;
288              
289 30         244 my $tmpl = {
290             path => { default => $conf->get_conf('base'),
291             store => \$path
292             },
293             verbose => { default => $conf->get_conf('verbose'),
294             store => \$verbose
295             },
296             update_source => { default => 0, store => \$update_source },
297             };
298              
299 30 50       205 my $args = check( $tmpl, \%hash ) or return;
300              
301             ### if the user never wants to update their source without explicitly
302             ### telling us, shortcircuit here
303 30 50 33     3835 return 1 if $conf->get_conf('no_update') && !$update_source;
304              
305             ### a check to see if our source files are still up to date ###
306 30         173 msg( loc("Checking if source files are up to date"), $verbose );
307              
308 30         308 my $uptodate = 1; # default return value
309              
310 30         194 for my $name (qw[auth mod]) {
311 60         772 for my $file ( $conf->_get_source( $name ) ) {
312 60 100       1115 $self->__check_uptodate(
313             file => File::Spec->catfile( $path, $file ),
314             name => $name,
315             update_source => $update_source,
316             verbose => $verbose,
317             ) or $uptodate = 0;
318             }
319             }
320              
321             ### if we're explicitly asked to update the sources, or if the
322             ### standard source files are out of date, update the custom sources
323             ### as well
324             ### RT #47820: Don't try to update custom sources if they are disabled
325             ### in the configuration.
326 30 50 33     753 $self->__update_custom_module_sources( verbose => $verbose )
      66        
327             if $conf->get_conf('enable_custom_sources') and ( $update_source or !$uptodate );
328              
329 30         528 return $uptodate;
330             }
331              
332             =pod
333              
334             =head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] )
335              
336             C<__check_uptodate> checks if a given source file is still up-to-date
337             and if not, or when C is true, will re-fetch the source
338             file.
339              
340             Takes the following arguments:
341              
342             =over 4
343              
344             =item file
345              
346             The source file to check.
347              
348             =item name
349              
350             The internal shortcut name for the source file (used for config
351             lookups).
352              
353             =item update_source
354              
355             Flag to force updating of sourcefiles regardless.
356              
357             =item verbose
358              
359             Boolean to indicate whether to be verbose or not.
360              
361             =back
362              
363             Returns a boolean value indicating whether the current files are up
364             to date or not.
365              
366             =cut
367              
368             ### this method checks whether or not the source files we are using are still up to date
369             sub __check_uptodate {
370 60     60   202 my $self = shift;
371 60         395 my %hash = @_;
372 60         451 my $conf = $self->configure_object;
373              
374              
375 60         608 my $tmpl = {
376             file => { required => 1 },
377             name => { required => 1 },
378             update_source => { default => 0 },
379             verbose => { default => $conf->get_conf('verbose') },
380             };
381              
382 60 50       300 my $args = check( $tmpl, \%hash ) or return;
383              
384 60         8835 my $flag;
385 60 100 66     2503 unless ( -e $args->{'file'} && (
386             ( stat $args->{'file'} )[9]
387             + $conf->_get_source('update') )
388             > time ) {
389 24         94 $flag = 1;
390             }
391              
392 60 100 100     481 if ( $flag or $args->{'update_source'} ) {
393              
394 26 50       319 if ( $self->_update_source( name => $args->{'name'} ) ) {
395 26         1086 return 0; # return 0 so 'uptodate' will be set to 0, meaning no
396             # use of previously stored hashrefs!
397             } else {
398 0         0 msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} );
399 0         0 return 1;
400             }
401              
402             } else {
403 34         381 return 1;
404             }
405             }
406              
407             =pod
408              
409             =head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] )
410              
411             This method does the actual fetching of source files.
412              
413             It takes the following arguments:
414              
415             =over 4
416              
417             =item name
418              
419             The internal shortcut name for the source file (used for config
420             lookups).
421              
422             =item path
423              
424             The full path where to write the files.
425              
426             =item verbose
427              
428             Boolean to indicate whether to be verbose or not.
429              
430             =back
431              
432             Returns a boolean to indicate success.
433              
434             =cut
435              
436             ### this sub fetches new source files ###
437             sub _update_source {
438 29     29   446 my $self = shift;
439 29         164 my %hash = @_;
440 29         173 my $conf = $self->configure_object;
441              
442 29         68 my $verbose;
443 29         337 my $tmpl = {
444             name => { required => 1 },
445             path => { default => $conf->get_conf('base') },
446             verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
447             };
448              
449 29 50       260 my $args = check( $tmpl, \%hash ) or return;
450              
451              
452 29         3135 my $path = $args->{path};
453             { ### this could use a clean up - Kane
454             ### no worries about the / -> we get it from the _ftp configuration, so
455             ### it's not platform dependant. -kane
456 29         69 my ($dir, $file) = $conf->_get_mirror( $args->{'name'} ) =~ m|(.+/)(.+)$|sg;
  29         245  
457              
458 29         242 msg( loc("Updating source file '%1'", $file), $verbose );
459              
460             my $fake = CPANPLUS::Module::Fake->new(
461 29         615 module => $args->{'name'},
462             path => $dir,
463             package => $file,
464             _id => $self->_id,
465             );
466              
467             ### can't use $fake->fetch here, since ->parent won't work --
468             ### the sources haven't been saved yet
469 29         382 my $rv = $self->_fetch(
470             module => $fake,
471             fetchdir => $path,
472             force => 1,
473             );
474              
475              
476 29 50       243 unless ($rv) {
477 0         0 error( loc("Couldn't fetch '%1'", $file) );
478 0         0 return;
479             }
480              
481 29         706 $self->_update_timestamp( file => File::Spec->catfile($path, $file) );
482             }
483              
484 29         4598 return 1;
485             }
486              
487             =pod
488              
489             =head2 $cb->__create_author_tree([path => $path, uptodate => BOOL, verbose => BOOL])
490              
491             This method opens a source files and parses its contents into a
492             searchable author-tree or restores a file-cached version of a
493             previous parse, if the sources are uptodate and the file-cache exists.
494              
495             It takes the following arguments:
496              
497             =over 4
498              
499             =item uptodate
500              
501             A flag indicating whether the file-cache is uptodate or not.
502              
503             =item path
504              
505             The absolute path to the directory holding the source files.
506              
507             =item verbose
508              
509             A boolean flag indicating whether or not to be verbose.
510              
511             =back
512              
513             Will get information from the config file by default.
514              
515             Returns a tree on success, false on failure.
516              
517             =cut
518              
519             sub __create_author_tree {
520 31     31   126 my $self = shift;
521 31         210 my %hash = @_;
522 31         207 my $conf = $self->configure_object;
523              
524              
525 31         291 my $tmpl = {
526             path => { default => $conf->get_conf('base') },
527             verbose => { default => $conf->get_conf('verbose') },
528             uptodate => { default => 0 },
529             };
530              
531 31 50       189 my $args = check( $tmpl, \%hash ) or return;
532              
533             my $file = File::Spec->catfile(
534             $args->{path},
535 31         3851 $conf->_get_source('auth')
536             );
537              
538             msg(loc("Rebuilding author tree, this might take a while"),
539 31         263 $args->{verbose});
540              
541             ### extract the file ###
542 31 50       899 my $ae = Archive::Extract->new( archive => $file ) or return;
543 31         10960 my $out = STRIP_GZ_SUFFIX->($file);
544              
545             ### make sure to set the PREFER_BIN flag if desired ###
546 31         87 { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
  31         322  
547 31 50       378 $ae->extract( to => $out ) or return;
548             }
549              
550 31 50       875735 my $cont = $self->_get_file_contents( file => $out ) or return;
551              
552             ### don't need it anymore ###
553 31         2632 unlink $out;
554              
555 31         304 my ($tot,$prce,$prc,$idx);
556              
557 31 50 50     466 if ( $args->{verbose} and local $|=1 ) {
558 16     16   178 no warnings;
  16         58  
  16         10023  
559 0         0 $tot = scalar(split /\n/, $cont);
560 0         0 ($prce, $prc, $idx) = (int $tot / 25, 0, 0);
561 0         0 print "\t0%";
562             }
563              
564 31         387 for ( split /\n/, $cont ) {
565 124         2229 my($id, $name, $email) = m/^alias \s+
566             (\S+) \s+
567             "\s* ([^\"\<]+?) \s* <(.+)> \s*"
568             /x;
569              
570 124 50       1535 $self->_add_author_object(
571             author => $name, #authors name
572             email => $email, #authors email address
573             cpanid => $id, #authors CPAN ID
574             ) or error( loc("Could not add author '%1'", $name ) );
575              
576             $args->{verbose}
577             and (
578 124 50 0     601 $idx++,
      0        
579              
580             ($idx==$prce
581             and ($prc+=4,$idx=0,print ".")),
582              
583             (($prc % 10)
584             or $idx
585             or print $prc,'%')
586             );
587              
588             }
589              
590             $args->{verbose}
591 31 50       213 and print "\n";
592              
593              
594 31         197 return $self->_atree;
595              
596             } #__create_author_tree
597              
598             =pod
599              
600             =head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL])
601              
602             This method opens a source files and parses its contents into a
603             searchable module-tree or restores a file-cached version of a
604             previous parse, if the sources are uptodate and the file-cache exists.
605              
606             It takes the following arguments:
607              
608             =over 4
609              
610             =item uptodate
611              
612             A flag indicating whether the file-cache is up-to-date or not.
613              
614             =item path
615              
616             The absolute path to the directory holding the source files.
617              
618             =item verbose
619              
620             A boolean flag indicating whether or not to be verbose.
621              
622             =back
623              
624             Will get information from the config file by default.
625              
626             Returns a tree on success, false on failure.
627              
628             =cut
629              
630             ### this builds a hash reference with the structure of the cpan module tree ###
631             sub _create_mod_tree {
632 31     31   131 my $self = shift;
633 31         332 my %hash = @_;
634 31         340 my $conf = $self->configure_object;
635 31         1223 my $base = $conf->_get_mirror('base');
636              
637 31         321 my $tmpl = {
638             path => { default => $conf->get_conf('base') },
639             verbose => { default => $conf->get_conf('verbose') },
640             uptodate => { default => 0 },
641             };
642              
643 31 50       190 my $args = check( $tmpl, \%hash ) or return undef;
644 31         4554 my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod'));
645              
646             msg(loc("Rebuilding module tree, this might take a while"),
647 31         361 $args->{verbose});
648              
649              
650 31         741 my $dslip_tree = $self->__create_dslip_tree( %$args );
651              
652 31         190 my $author_tree = $self->author_tree;
653              
654             ### extract the file ###
655 31 50       611 my $ae = Archive::Extract->new( archive => $file ) or return;
656 31         11142 my $out = STRIP_GZ_SUFFIX->($file);
657              
658             ### make sure to set the PREFER_BIN flag if desired ###
659 31         128 { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
  31         381  
660 31 50       215 $ae->extract( to => $out ) or return;
661             }
662              
663 31 50       584650 my $content = $self->_get_file_contents( file => $out ) or return;
664 31         309 my $lines = $content =~ tr/\n/\n/;
665              
666             ### don't need it anymore ###
667 31         2342 unlink $out;
668              
669 31         275 my($past_header, $count, $tot, $prce, $prc, $idx);
670              
671 31 50 50     363 if ( $args->{verbose} and local $|=1 ) {
672 16     16   163 no warnings;
  16         48  
  16         52995  
673 0         0 $tot = scalar(split /\n/, $content);
674 0         0 ($prce, $prc, $idx) = (int $tot / 25, 0, 0);
675 0         0 print "\t0%";
676             }
677              
678 31         713 for ( split /\n/, $content ) {
679              
680             ### we're still in the header -- find the amount of lines we expect
681 589 100       1399 unless( $past_header ) {
682              
683             ### header has ended -- did we get the line count?
684 279 100       1429 if( m|^\s*$| ) {
685 31 50       237 unless( $count ) {
686 0         0 error(loc("Could not determine line count from %1", $file));
687 0         0 return;
688             }
689 31         132 $past_header = 1;
690              
691             ### if the line count doesn't match what we expect, bail out
692             ### this should address: #45644: detect broken index
693             } else {
694 248 100       1387 $count = $1 if /^Line-Count:\s+(\d+)/;
695 248 100       646 if( $count ) {
696 62 50       335 if( $lines < $count ) {
697 0         0 error(loc("Expected to read at least %1 lines, but %2 ".
698             "contains only %3 lines!",
699             $count, $file, $lines ));
700 0         0 return;
701             }
702             }
703             }
704              
705             ### still in the header, keep moving
706 279         551 next;
707             }
708              
709 310         2519 my @data = split /\s+/;
710             ### three fields expected on each line
711 310 50       991 next unless @data == 3;
712              
713             ### filter out the author and filename as well ###
714             ### authors can apparently have digits in their names,
715             ### and dirs can have dots... blah!
716 310         3162 my ($author, $package) = $data[2] =~
717             m| (?:[A-Z\d-]/)?
718             (?:[A-Z\d-]{2}/)?
719             ([A-Z\d-]+) (?:/[\S]+)?/
720             ([^/]+)$
721             |xsg;
722              
723             ### remove file name from the path
724 310         1698 $data[2] =~ s|/[^/]+$||;
725              
726 310         924 my $aobj = $author_tree->{$author};
727 310 50       903 unless( $aobj ) {
728 0         0 error( loc( "No such author '%1' -- can't make module object " .
729             "'%2' that is supposed to belong to this author",
730             $author, $data[0] ) );
731 0         0 next;
732             }
733              
734 310         713 my $dslip_mod = $dslip_tree->{ $data[0] };
735              
736             ### adding the dslip info
737 310         498 my $dslip;
738 310         825 for my $item ( qw[ statd stats statl stati statp ] ) {
739             ### checking if there's an entry in the dslip info before
740             ### catting it on. appeasing warnings this way
741 1550   50     5113 $dslip .= $dslip_mod->{$item} || ' ';
742             }
743              
744             ### XXX this could be sped up if we used author names, not author
745             ### objects in creation, and then look them up in the author tree
746             ### when needed. This will need a fix to all the places that create
747             ### fake author/module objects as well.
748              
749             ### callback to store the individual object
750             $self->_add_module_object(
751             module => $data[0], # full module name
752             version => ($data[1] eq 'undef' # version number
753             ? '0.0'
754             : $data[1]),
755             path => File::Spec::Unix->catfile(
756             $base,
757             $data[2],
758             ), # extended path on the cpan mirror,
759             # like /A/AB/ABIGAIL
760             comment => $data[3], # comment on the module
761             author => $aobj,
762             package => $package, # package name, like
763             # 'foo-bar-baz-1.03.tar.gz'
764 310 50       5773 description => $dslip_mod->{'description'},
    50          
765             dslip => $dslip,
766             mtime => '',
767             ) or error( loc( "Could not add module '%1'", $data[0] ) );
768              
769             $args->{verbose}
770             and (
771 310 50 0     1679 $idx++,
      0        
772              
773             ($idx==$prce
774             and ($prc+=4,$idx=0,print ".")),
775              
776             (($prc % 10)
777             or $idx
778             or print $prc,'%')
779             );
780              
781             } #for
782              
783             $args->{verbose}
784 31 50       228 and print "\n";
785              
786 31         170 return $self->_mtree;
787              
788             } #_create_mod_tree
789              
790             =pod
791              
792             =head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL])
793              
794             This method opens a source files and parses its contents into a
795             searchable dslip-tree or restores a file-cached version of a
796             previous parse, if the sources are uptodate and the file-cache exists.
797              
798             It takes the following arguments:
799              
800             =over 4
801              
802             =item uptodate
803              
804             A flag indicating whether the file-cache is uptodate or not.
805              
806             =item path
807              
808             The absolute path to the directory holding the source files.
809              
810             =item verbose
811              
812             A boolean flag indicating whether or not to be verbose.
813              
814             =back
815              
816             Will get information from the config file by default.
817              
818             Returns a tree on success, false on failure.
819              
820             =cut
821              
822             sub __create_dslip_tree {
823 31     31   112 my $self = shift;
824 31         176 my %hash = @_;
825 31         152 my $conf = $self->configure_object;
826              
827 31         189 return {}; # Quick hack
828             } #__create_dslip_tree
829              
830             =pod
831              
832             =head2 $cb->_dslip_defs ()
833              
834             This function returns the definition structure (ARRAYREF) of the
835             dslip tree.
836              
837             =cut
838              
839             ### these are the definitions used for dslip info
840             ### they shouldn't change over time.. so hardcoding them doesn't appear to
841             ### be a problem. if it is, we need to parse 03modlist.data better to filter
842             ### all this out.
843             ### right now, this is just used to look up dslip info from a module
844             sub _dslip_defs {
845 0     0   0 my $self = shift;
846              
847 0         0 my $aref = [
848              
849             # D
850             [ q|Development Stage|, {
851             i => loc('Idea, listed to gain consensus or as a placeholder'),
852             c => loc('under construction but pre-alpha (not yet released)'),
853             a => loc('Alpha testing'),
854             b => loc('Beta testing'),
855             R => loc('Released'),
856             M => loc('Mature (no rigorous definition)'),
857             S => loc('Standard, supplied with Perl 5'),
858             }],
859              
860             # S
861             [ q|Support Level|, {
862             m => loc('Mailing-list'),
863             d => loc('Developer'),
864             u => loc('Usenet newsgroup comp.lang.perl.modules'),
865             n => loc('None known, try comp.lang.perl.modules'),
866             a => loc('Abandoned; volunteers welcome to take over maintenance'),
867             }],
868              
869             # L
870             [ q|Language Used|, {
871             p => loc('Perl-only, no compiler needed, should be platform independent'),
872             c => loc('C and perl, a C compiler will be needed'),
873             h => loc('Hybrid, written in perl with optional C code, no compiler needed'),
874             '+' => loc('C++ and perl, a C++ compiler will be needed'),
875             o => loc('perl and another language other than C or C++'),
876             }],
877              
878             # I
879             [ q|Interface Style|, {
880             f => loc('plain Functions, no references used'),
881             h => loc('hybrid, object and function interfaces available'),
882             n => loc('no interface at all (huh?)'),
883             r => loc('some use of unblessed References or ties'),
884             O => loc('Object oriented using blessed references and/or inheritance'),
885             }],
886              
887             # P
888             [ q|Public License|, {
889             p => loc('Standard-Perl: user may choose between GPL and Artistic'),
890             g => loc('GPL: GNU General Public License'),
891             l => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'),
892             b => loc('BSD: The BSD License'),
893             a => loc('Artistic license alone'),
894             o => loc('other (but distribution allowed without restrictions)'),
895             }],
896             ];
897              
898 0         0 return $aref;
899             }
900              
901             =head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] );
902              
903             Adds a custom source index and updates it based on the provided URI.
904              
905             Returns the full path to the index file on success or false on failure.
906              
907             =cut
908              
909             sub _add_custom_module_source {
910 1     1   373 my $self = shift;
911 1         10 my $conf = $self->configure_object;
912 1         4 my %hash = @_;
913              
914 1         3 my($verbose,$uri);
915 1         7 my $tmpl = {
916             verbose => { default => $conf->get_conf('verbose'),
917             store => \$verbose },
918             uri => { required => 1, store => \$uri }
919             };
920              
921 1 50       10 check( $tmpl, \%hash ) or return;
922              
923             ### what index file should we use on disk?
924 1         103 my $index = $self->__custom_module_source_index_file( uri => $uri );
925              
926             ### already have it.
927 1 50       16 if( IS_FILE->( $index ) ) {
928 0         0 msg(loc("Source '%1' already added", $uri));
929 0         0 return 1;
930             }
931              
932             ### do we need to create the targe dir?
933 1         4 { my $dir = dirname( $index );
  1         42  
934 1 50       8 unless( IS_DIR->( $dir ) ) {
935 1 50       25 $self->_mkdir( dir => $dir ) or return
936             }
937             }
938              
939             ### write the file
940 1 50       8 my $fh = OPEN_FILE->( $index => '>' ) or do {
941 0         0 error(loc("Could not open index file for '%1'", $uri));
942 0         0 return;
943             };
944              
945             ### basically we 'touched' it. Check the return value, may be
946             ### important on win32 and similar OS, where there's file length
947             ### limits
948 1 50       16 close $fh or do {
949 0         0 error(loc("Could not write index file to disk for '%1'", $uri));
950 0         0 return;
951             };
952              
953             $self->__update_custom_module_source(
954             remote => $uri,
955             local => $index,
956             verbose => $verbose,
957 1 50       27 ) or do {
958             ### we failed to update it, we probably have an empty
959             ### possibly silly filename on disk now -- remove it
960 0         0 1 while unlink $index;
961 0         0 return;
962             };
963              
964 1         31 return $index;
965             }
966              
967             =head2 $index = $cb->__custom_module_source_index_file( uri => $uri );
968              
969             Returns the full path to the encoded index file for C<$uri>, as used by
970             all C routines.
971              
972             =cut
973              
974             sub __custom_module_source_index_file {
975 2     2   32 my $self = shift;
976 2         9 my $conf = $self->configure_object;
977 2         17 my %hash = @_;
978              
979 2         5 my($verbose,$uri);
980 2         8 my $tmpl = {
981             uri => { required => 1, store => \$uri }
982             };
983              
984 2 50       8 check( $tmpl, \%hash ) or return;
985              
986 2         143 my $index = File::Spec->catfile(
987             $conf->get_conf('base'),
988             $conf->_get_build('custom_sources'),
989             $self->_uri_encode( uri => $uri ),
990             );
991              
992 2         11 return $index;
993             }
994              
995             =head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] );
996              
997             Removes a custom index file based on the URI provided.
998              
999             Returns the full path to the index file on success or false on failure.
1000              
1001             =cut
1002              
1003             sub _remove_custom_module_source {
1004 1     1   1266 my $self = shift;
1005 1         14 my $conf = $self->configure_object;
1006 1         12 my %hash = @_;
1007              
1008 1         10 my($verbose,$uri);
1009 1         18 my $tmpl = {
1010             verbose => { default => $conf->get_conf('verbose'),
1011             store => \$verbose },
1012             uri => { required => 1, store => \$uri }
1013             };
1014              
1015 1 50       18 check( $tmpl, \%hash ) or return;
1016              
1017             ### use uri => local, instead of the other way around
1018 1         118 my %files = reverse $self->__list_custom_module_sources;
1019              
1020             ### On VMS the case of key to %files can be either exact or lower case
1021             ### XXX abstract this lookup out? --kane
1022 1         14 my $file = $files{ $uri };
1023 1 50 50     12 $file = $files{ lc $uri } if !defined($file) && ON_VMS;
1024              
1025 1 50       10 unless (defined $file) {
1026 0         0 error(loc("No such custom source '%1'", $uri));
1027 0         0 return;
1028             };
1029              
1030 1         116 1 while unlink $file;
1031              
1032 1 50       20 if( IS_FILE->( $file ) ) {
1033 0         0 error(loc("Could not remove index file '%1' for custom source '%2'",
1034             $file, $uri));
1035 0         0 return;
1036             }
1037              
1038 1         10 msg(loc("Successfully removed index file for '%1'", $uri), $verbose);
1039              
1040 1         18 return $file;
1041             }
1042              
1043             =head2 %files = $cb->__list_custom_module_sources
1044              
1045             This method scans the 'custom-sources' directory in your base directory
1046             for additional sources to include in your module tree.
1047              
1048             Returns a list of key value pairs as follows:
1049              
1050             /full/path/to/source/file%3Fencoded => http://decoded/mirror/path
1051              
1052             =cut
1053              
1054             sub __list_custom_module_sources {
1055 10     10   2200 my $self = shift;
1056 10         44 my $conf = $self->configure_object;
1057              
1058 10         33 my($verbose);
1059 10         82 my $tmpl = {
1060             verbose => { default => $conf->get_conf('verbose'),
1061             store => \$verbose },
1062             };
1063              
1064 10         86 my $dir = File::Spec->catdir(
1065             $conf->get_conf('base'),
1066             $conf->_get_build('custom_sources'),
1067             );
1068              
1069 10 100       89 unless( IS_DIR->( $dir ) ) {
1070 3         15 msg(loc("No '%1' dir, skipping custom sources", $dir), $verbose);
1071 3         36 return;
1072             }
1073              
1074             ### unencode the files
1075             ### skip ones starting with # though
1076             my %files = map {
1077 7         54 my $org = $_;
1078 7         99 my $dec = $self->_uri_decode( uri => $_ );
1079 7         124 File::Spec->catfile( $dir, $org ) => $dec
1080 7         50 } grep { $_ !~ /^#/ } READ_DIR->( $dir );
  7         55  
1081              
1082 7         64 return %files;
1083             }
1084              
1085             =head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] );
1086              
1087             Attempts to update all the index files to your custom module sources.
1088              
1089             If the index is missing, and it's a C uri, it will generate
1090             a new local index for you.
1091              
1092             Return true on success, false on failure.
1093              
1094             =cut
1095              
1096             sub __update_custom_module_sources {
1097 4     4   1001331 my $self = shift;
1098 4         53 my $conf = $self->configure_object;
1099 4         23 my %hash = @_;
1100              
1101 4         24 my $verbose;
1102 4         61 my $tmpl = {
1103             verbose => { default => $conf->get_conf('verbose'),
1104             store => \$verbose }
1105             };
1106              
1107 4 50       40 check( $tmpl, \%hash ) or return;
1108              
1109 4         369 my %files = $self->__list_custom_module_sources;
1110              
1111             ### uptodate check has been done a few levels up.
1112 4         14 my $fail;
1113 4         35 while( my($local,$remote) = each %files ) {
1114              
1115 2 50       19 $self->__update_custom_module_source(
1116             remote => $remote,
1117             local => $local,
1118             verbose => $verbose,
1119             ) or ( $fail++, next );
1120             }
1121              
1122 4 50       49 error(loc("Failed updating one or more remote sources files")) if $fail;
1123              
1124 4 50       21 return if $fail;
1125 4         39 return 1;
1126             }
1127              
1128             =head2 $ok = $cb->__update_custom_module_source
1129              
1130             Attempts to update all the index files to your custom module sources.
1131              
1132             If the index is missing, and it's a C uri, it will generate
1133             a new local index for you.
1134              
1135             Return true on success, false on failure.
1136              
1137             =cut
1138              
1139             sub __update_custom_module_source {
1140 4     4   1002344 my $self = shift;
1141 4         34 my $conf = $self->configure_object;
1142 4         35 my %hash = @_;
1143              
1144 4         470 my($verbose,$local,$remote);
1145 4         54 my $tmpl = {
1146             verbose => { default => $conf->get_conf('verbose'),
1147             store => \$verbose },
1148             local => { store => \$local, allow => FILE_EXISTS },
1149             remote => { required => 1, store => \$remote },
1150             };
1151              
1152 4 50       36 check( $tmpl, \%hash ) or return;
1153              
1154 4         537 msg( loc("Updating sources from '%1'", $remote), $verbose);
1155              
1156             ### if you didn't provide a local file, we'll look in your custom
1157             ### dir to find the local encoded version for you
1158 4   66     64 $local ||= do {
1159             ### find all files we know of
1160 1 50       36 my %files = reverse $self->__list_custom_module_sources or do {
1161 0         0 error(loc("No custom modules sources defined -- need '%1' argument",
1162             'local'));
1163 0         0 return;
1164             };
1165              
1166             ### On VMS the case of key to %files can be either exact or lower case
1167             ### XXX abstract this lookup out? --kane
1168 1         12 my $file = $files{ $remote };
1169 1 50 50     16 $file = $files{ lc $remote } if !defined ($file) && ON_VMS;
1170              
1171             ### return the local file we're supposed to use
1172 1 50       21 $file or do {
1173 0         0 error(loc("Remote source '%1' unknown -- needs '%2' argument",
1174             $remote, 'local'));
1175 0         0 return;
1176             };
1177             };
1178              
1179 4         35 my $uri = join '/', $remote, $conf->_get_source('custom_index');
1180 4         100 my $ff = File::Fetch->new( uri => $uri );
1181              
1182             ### tempdir doesn't clean up by default, as opposed to tempfile()
1183             ### so add it explicitly.
1184 4         23606 my $dir = tempdir( CLEANUP => 1 );
1185              
1186 4         5257 my $res = do {
1187 4         22 local $File::Fetch::WARN = 0;
1188 4         134 local $File::Fetch::TIMEOUT = $conf->get_conf('timeout');
1189 4         63 $ff->fetch( to => $dir );
1190             };
1191              
1192             ### couldn't get the file
1193 4 50       24237 unless( $res ) {
1194              
1195             ### it's not a local scheme, so can't auto index
1196 4 50       29 unless( $ff->scheme eq 'file' ) {
1197 0         0 error(loc("Could not update sources from '%1': %2",
1198             $remote, $ff->error ));
1199 0         0 return;
1200              
1201             ### it's a local uri, we can index it ourselves
1202             } else {
1203 4         75 msg(loc("No index file found at '%1', generating one",
1204             $ff->uri), $verbose );
1205              
1206             ### ON VMS, if you are working with a UNIX file specification,
1207             ### you need currently use the UNIX variants of the File::Spec.
1208 4         57 my $ff_path = do {
1209 4         44 my $file_class = 'File::Spec';
1210 4         18 $file_class .= '::Unix' if ON_VMS;
1211 4         25 $file_class->catdir( File::Spec::Unix->splitdir( $ff->path ) );
1212             };
1213              
1214 4 50       266 $self->__write_custom_module_index(
1215             path => $ff_path,
1216             to => $local,
1217             verbose => $verbose,
1218             ) or return;
1219              
1220             ### XXX don't write that here, __write_custom_module_index
1221             ### already prints this out
1222             #msg(loc("Index file written to '%1'", $to), $verbose);
1223             }
1224              
1225             ### copy it to the real spot and update its timestamp
1226             } else {
1227 0 0       0 $self->_move( file => $res, to => $local ) or return;
1228 0         0 $self->_update_timestamp( file => $local );
1229              
1230 0         0 msg(loc("Index file saved to '%1'", $local), $verbose);
1231             }
1232              
1233 4         213 return $local;
1234             }
1235              
1236             =head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] )
1237              
1238             Scans the C you provided for packages and writes an index with all
1239             the available packages to C<$path/packages.txt>. If you'd like the index
1240             to be written to a different file, provide the C argument.
1241              
1242             Returns true on success and false on failure.
1243              
1244             =cut
1245              
1246             sub __write_custom_module_index {
1247 5     5   1684 my $self = shift;
1248 5         81 my $conf = $self->configure_object;
1249 5         76 my %hash = @_;
1250              
1251 5         24 my ($verbose, $path, $to);
1252 5         173 my $tmpl = {
1253             verbose => { default => $conf->get_conf('verbose'),
1254             store => \$verbose },
1255             path => { required => 1, allow => DIR_EXISTS, store => \$path },
1256             to => { store => \$to },
1257             };
1258              
1259 5 50       28 check( $tmpl, \%hash ) or return;
1260              
1261             ### no explicit to? then we'll use our default
1262 5   33     316 $to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') );
1263              
1264 5         12 my @files;
1265 5         87 require File::Find;
1266             File::Find::find( sub {
1267             ### let's see if A::E can even parse it
1268 45 100   45   18679 my $ae = do {
1269 45         105 local $Archive::Extract::WARN = 0;
1270 45         71 local $Archive::Extract::WARN = 0;
1271 45         276 Archive::Extract->new( archive => $File::Find::name )
1272             } or return;
1273              
1274             ### it's a type A::E recognize, so we can add it
1275 25 50       4777 $ae->type or return;
1276              
1277             ### neither $_ nor $File::Find::name have the chunk of the path in
1278             ### it starting $path -- it's either only the filename, or the full
1279             ### path, so we have to strip it ourselves
1280             ### make sure to remove the leading slash as well.
1281 25         522 my $copy = $File::Find::name;
1282 25         63 my $re = quotemeta($path);
1283 25         200 $copy =~ s|^$re[\\/]?||i;
1284              
1285 25         343 push @files, $copy;
1286              
1287 5         917 }, $path );
1288              
1289             ### does the dir exist? if not, create it.
1290 5         41 { my $dir = dirname( $to );
  5         508  
1291 5 50       33 unless( IS_DIR->( $dir ) ) {
1292 0 0       0 $self->_mkdir( dir => $dir ) or return
1293             }
1294             }
1295              
1296             ### create the index file
1297 5 50       72 my $fh = OPEN_FILE->( $to => '>' ) or return;
1298              
1299 5         99 print $fh "$_\n" for @files;
1300 5         592 close $fh;
1301              
1302 5         42 msg(loc("Successfully written index file to '%1'", $to), $verbose);
1303              
1304 5         78 return $to;
1305             }
1306              
1307              
1308             =head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] )
1309              
1310             Creates entries in the module tree based upon the files as returned
1311             by C<__list_custom_module_sources>.
1312              
1313             Returns true on success, false on failure.
1314              
1315             =cut
1316              
1317             ### use $auth_obj as a persistent version, so we don't have to recreate
1318             ### modules all the time
1319             { my $auth_obj;
1320              
1321             sub __create_custom_module_entries {
1322 3     3   1022 my $self = shift;
1323 3         52 my $conf = $self->configure_object;
1324 3         31 my %hash = @_;
1325              
1326 3         9 my $verbose;
1327 3         34 my $tmpl = {
1328             verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
1329             };
1330              
1331 3 50       30 check( $tmpl, \%hash ) or return undef;
1332              
1333 3         211 my %files = $self->__list_custom_module_sources;
1334              
1335 3         29 while( my($file,$name) = each %files ) {
1336              
1337 2         11 msg(loc("Adding packages from custom source '%1'", $name), $verbose);
1338              
1339 2 50       22 my $fh = OPEN_FILE->( $file ) or next;
1340              
1341 2         78 while( local $_ = <$fh> ) {
1342 10         28 chomp;
1343 10 50       30 next if /^#/;
1344 10 50       59 next unless /\S+/;
1345              
1346             ### join on / -- it's a URI after all!
1347 10         50 my $parse = join '/', $name, $_;
1348              
1349             ### try to make a module object out of it
1350 10 50       60 my $mod = $self->parse_module( module => $parse ) or (
1351             error(loc("Could not parse '%1'", $_)),
1352             next
1353             );
1354              
1355             ### mark this object with a custom author
1356 10   66     33 $auth_obj ||= do {
1357 1         7 my $id = CUSTOM_AUTHOR_ID;
1358              
1359             ### if the object is being created for the first time,
1360             ### make sure there's an entry in the author tree as
1361             ### well, so we can search on the CPAN ID
1362 1         6 $self->author_tree->{ $id } =
1363             CPANPLUS::Module::Author::Fake->new( cpanid => $id );
1364             };
1365              
1366 10         80 $mod->author( $auth_obj );
1367              
1368             ### and now add it to the module tree -- this MAY
1369             ### override things of course
1370 10 100       27 if( my $old_mod = $self->module_tree( $mod->module ) ) {
1371              
1372             ### On VMS use the old module name to get the real case
1373 8         11 $mod->module( $old_mod->module ) if ON_VMS;
1374              
1375 8         23 msg(loc("About to overwrite module tree entry for '%1' with '%2'",
1376             $mod->module, $mod->package), $verbose);
1377             }
1378              
1379             ### mark where it came from
1380 10         105 $mod->description( loc("Custom source from '%1'",$name) );
1381              
1382             ### store it in the module tree
1383 10         32 $self->module_tree->{ $mod->module } = $mod;
1384             }
1385             }
1386              
1387 3         31 return 1;
1388             }
1389             }
1390              
1391             1;