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