This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
1f75535fa654060adc6c7589f80fb88f954d1c0b
[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     $args->{verbose}
555    and local $|=1,
556        $tot = scalar(split /\n/, $cont),
557        ($prce, $prc, $idx) = (int $tot / 25, 0, 0);
558
559     $args->{verbose}
560    and print "\t0%";
561
562     for ( split /\n/, $cont ) {
563         my($id, $name, $email) = m/^alias \s+
564                                     (\S+) \s+
565                                     "\s* ([^\"\<]+?) \s* <(.+)> \s*"
566                                 /x;
567
568         $self->_add_author_object(
569             author  => $name,           #authors name
570             email   => $email,          #authors email address
571             cpanid  => $id,             #authors CPAN ID
572         ) or error( loc("Could not add author '%1'", $name ) );
573
574    $args->{verbose}
575        and (
576           $idx++,
577
578           ($idx==$prce
579          and ($prc+=4,$idx=0,print ".")),
580
581               (($prc % 10)
582               or $idx
583               or print $prc,'%')
584       );
585
586     }
587
588     $args->{verbose}
589    and print "\n";
590
591
592     return $self->_atree;
593
594 } #__create_author_tree
595
596 =pod
597
598 =head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL])
599
600 This method opens a source files and parses its contents into a
601 searchable module-tree or restores a file-cached version of a
602 previous parse, if the sources are uptodate and the file-cache exists.
603
604 It takes the following arguments:
605
606 =over 4
607
608 =item uptodate
609
610 A flag indicating whether the file-cache is up-to-date or not.
611
612 =item path
613
614 The absolute path to the directory holding the source files.
615
616 =item verbose
617
618 A boolean flag indicating whether or not to be verbose.
619
620 =back
621
622 Will get information from the config file by default.
623
624 Returns a tree on success, false on failure.
625
626 =cut
627
628 ### this builds a hash reference with the structure of the cpan module tree ###
629 sub _create_mod_tree {
630     my $self = shift;
631     my %hash = @_;
632     my $conf = $self->configure_object;
633
634
635     my $tmpl = {
636         path     => { default => $conf->get_conf('base') },
637         verbose  => { default => $conf->get_conf('verbose') },
638         uptodate => { default => 0 },
639     };
640
641     my $args = check( $tmpl, \%hash ) or return undef;
642     my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod'));
643
644     msg(loc("Rebuilding module tree, this might take a while"),
645         $args->{verbose});
646
647
648     my $dslip_tree = $self->__create_dslip_tree( %$args );
649
650     ### extract the file ###
651     my $ae      = Archive::Extract->new( archive => $file ) or return;
652     my $out     = STRIP_GZ_SUFFIX->($file);
653
654     ### make sure to set the PREFER_BIN flag if desired ###
655     {   local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
656         $ae->extract( to => $out )                              or return;
657     }
658
659     my $content = $self->_get_file_contents( file => $out ) or return;
660     my $lines   = $content =~ tr/\n/\n/;
661
662     ### don't need it anymore ###
663     unlink $out;
664
665     my($past_header, $count, $tot, $prce, $prc, $idx);
666
667     $args->{verbose}
668    and local $|=1,
669        $tot = scalar(split /\n/, $content),
670        ($prce, $prc, $idx) = (int $tot / 25, 0, 0);
671
672     $args->{verbose}
673    and print "\t0%";
674
675     for ( split /\n/, $content ) {
676         ### quick hack to read past the header of the file ###
677         ### this is still rather evil... fix some time - Kane
678         if( m|^\s*$| ) {
679             unless( $count ) {
680                 error(loc("Could not determine line count from %1", $file));
681                 return;
682             }
683             $past_header = 1;
684         }
685
686         ### we're still in the header -- find the amount of lines we expect
687         unless( $past_header ) {
688
689             ### if the line count doesn't match what we expect, bail out
690             ### this should address: #45644: detect broken index
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             ### still in the header, keep moving
701             next;
702         }
703
704         ### skip empty lines ###
705         next unless /\S/;
706         chomp;
707
708         my @data = split /\s+/;
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 = $self->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         ### adding the dslip info
732         ### probably can use some optimization
733         my $dslip;
734         for my $item ( qw[ statd stats statl stati statp ] ) {
735             ### checking if there's an entry in the dslip info before
736             ### catting it on. appeasing warnings this way
737             $dslip .=   $dslip_tree->{ $data[0] }->{$item}
738                             ? $dslip_tree->{ $data[0] }->{$item}
739                             : ' ';
740         }
741
742         ### XXX this could be sped up if we used author names, not author
743         ### objects in creation, and then look them up in the author tree
744         ### when needed. This will need a fix to all the places that create
745         ### fake author/module objects as well.
746
747         ### callback to store the individual object
748         $self->_add_module_object(
749             module      => $data[0],            # full module name
750             version     => ($data[1] eq 'undef' # version number
751                                 ? '0.0'
752                                 : $data[1]),
753             path        => File::Spec::Unix->catfile(
754                                 $conf->_get_mirror('base'),
755                                 $data[2],
756                             ),          # extended path on the cpan mirror,
757                                         # like /A/AB/ABIGAIL
758             comment     => $data[3],    # comment on the module
759             author      => $aobj,
760             package     => $package,    # package name, like
761                                         # 'foo-bar-baz-1.03.tar.gz'
762             description => $dslip_tree->{ $data[0] }->{'description'},
763             dslip       => $dslip,
764             mtime       => '',
765         ) or error( loc( "Could not add module '%1'", $data[0] ) );
766
767    $args->{verbose}
768        and (
769           $idx++,
770
771           ($idx==$prce
772          and ($prc+=4,$idx=0,print ".")),
773
774               (($prc % 10)
775               or $idx
776               or print $prc,'%')
777       );
778
779     } #for
780
781     $args->{verbose}
782    and print "\n";
783
784     return $self->_mtree;
785
786 } #_create_mod_tree
787
788 =pod
789
790 =head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL])
791
792 This method opens a source files and parses its contents into a
793 searchable dslip-tree or restores a file-cached version of a
794 previous parse, if the sources are uptodate and the file-cache exists.
795
796 It takes the following arguments:
797
798 =over 4
799
800 =item uptodate
801
802 A flag indicating whether the file-cache is uptodate or not.
803
804 =item path
805
806 The absolute path to the directory holding the source files.
807
808 =item verbose
809
810 A boolean flag indicating whether or not to be verbose.
811
812 =back
813
814 Will get information from the config file by default.
815
816 Returns a tree on success, false on failure.
817
818 =cut
819
820 sub __create_dslip_tree {
821     my $self = shift;
822     my %hash = @_;
823     my $conf = $self->configure_object;
824
825     my $tmpl = {
826         path     => { default => $conf->get_conf('base') },
827         verbose  => { default => $conf->get_conf('verbose') },
828         uptodate => { default => 0 },
829     };
830
831     my $args = check( $tmpl, \%hash ) or return;
832
833     ### get the file name of the source ###
834     my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip'));
835
836     ### extract the file ###
837     my $ae      = Archive::Extract->new( archive => $file ) or return;
838     my $out     = STRIP_GZ_SUFFIX->($file);
839
840     ### make sure to set the PREFER_BIN flag if desired ###
841     {   local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
842         $ae->extract( to => $out )                              or return;
843     }
844
845     my $in      = $self->_get_file_contents( file => $out ) or return;
846
847     ### don't need it anymore ###
848     unlink $out;
849
850
851     ### get rid of the comments and the code ###
852     ### need a smarter parser, some people have this in their dslip info:
853     # [
854     # 'Statistics::LTU',
855     # 'R',
856     # 'd',
857     # 'p',
858     # 'O',
859     # '?',
860     # 'Implements Linear Threshold Units',
861     # ...skipping...
862     # "\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!",
863     # 'BENNIE',
864     # '11'
865     # ],
866     ### also, older versions say:
867     ### $cols = [....]
868     ### and newer versions say:
869     ### $CPANPLUS::Modulelist::cols = [...]
870     ### split '$cols' and '$data' into 2 variables ###
871     ### use this regex to make sure dslips with ';' in them don't cause
872     ### parser errors
873     my ($ds_one, $ds_two) = ($in =~ m|.+}\s+
874                               (\$(?:CPAN::Modulelist::)?cols.*?)
875                               (\$(?:CPAN::Modulelist::)?data.*)
876                            |sx);
877
878     ### eval them into existence ###
879     ### still not too fond of this solution - kane ###
880     my ($cols, $data);
881     {   #local $@; can't use this, it's buggy -kane
882
883         $cols = eval $ds_one;
884         error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
885
886         $data = eval $ds_two;
887         error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
888
889     }
890
891     my $tree = {};
892     my $primary = "modid";
893
894     ### this comes from CPAN::Modulelist
895     ### which is in 03modlist.data.gz
896     for (@$data){
897         my %hash;
898         @hash{@$cols} = @$_;
899         $tree->{$hash{$primary}} = \%hash;
900     }
901
902     return $tree;
903
904 } #__create_dslip_tree
905
906 =pod
907
908 =head2 $cb->_dslip_defs ()
909
910 This function returns the definition structure (ARRAYREF) of the
911 dslip tree.
912
913 =cut
914
915 ### these are the definitions used for dslip info
916 ### they shouldn't change over time.. so hardcoding them doesn't appear to
917 ### be a problem. if it is, we need to parse 03modlist.data better to filter
918 ### all this out.
919 ### right now, this is just used to look up dslip info from a module
920 sub _dslip_defs {
921     my $self = shift;
922
923     my $aref = [
924
925         # D
926         [ q|Development Stage|, {
927             i   => loc('Idea, listed to gain consensus or as a placeholder'),
928             c   => loc('under construction but pre-alpha (not yet released)'),
929             a   => loc('Alpha testing'),
930             b   => loc('Beta testing'),
931             R   => loc('Released'),
932             M   => loc('Mature (no rigorous definition)'),
933             S   => loc('Standard, supplied with Perl 5'),
934         }],
935
936         # S
937         [ q|Support Level|, {
938             m   => loc('Mailing-list'),
939             d   => loc('Developer'),
940             u   => loc('Usenet newsgroup comp.lang.perl.modules'),
941             n   => loc('None known, try comp.lang.perl.modules'),
942             a   => loc('Abandoned; volunteers welcome to take over maintenance'),
943         }],
944
945         # L
946         [ q|Language Used|, {
947             p   => loc('Perl-only, no compiler needed, should be platform independent'),
948             c   => loc('C and perl, a C compiler will be needed'),
949             h   => loc('Hybrid, written in perl with optional C code, no compiler needed'),
950             '+' => loc('C++ and perl, a C++ compiler will be needed'),
951             o   => loc('perl and another language other than C or C++'),
952         }],
953
954         # I
955         [ q|Interface Style|, {
956             f   => loc('plain Functions, no references used'),
957             h   => loc('hybrid, object and function interfaces available'),
958             n   => loc('no interface at all (huh?)'),
959             r   => loc('some use of unblessed References or ties'),
960             O   => loc('Object oriented using blessed references and/or inheritance'),
961         }],
962
963         # P
964         [ q|Public License|, {
965             p   => loc('Standard-Perl: user may choose between GPL and Artistic'),
966             g   => loc('GPL: GNU General Public License'),
967             l   => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'),
968             b   => loc('BSD: The BSD License'),
969             a   => loc('Artistic license alone'),
970             o   => loc('other (but distribution allowed without restrictions)'),
971         }],
972     ];
973
974     return $aref;
975 }
976
977 =head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] );
978
979 Adds a custom source index and updates it based on the provided URI.
980
981 Returns the full path to the index file on success or false on failure.
982
983 =cut
984
985 sub _add_custom_module_source {
986     my $self = shift;
987     my $conf = $self->configure_object;
988     my %hash = @_;
989
990     my($verbose,$uri);
991     my $tmpl = {
992         verbose => { default => $conf->get_conf('verbose'),
993                      store   => \$verbose },
994         uri     => { required => 1, store => \$uri }
995     };
996
997     check( $tmpl, \%hash ) or return;
998
999     ### what index file should we use on disk?
1000     my $index = $self->__custom_module_source_index_file( uri => $uri );
1001
1002     ### already have it.
1003     if( IS_FILE->( $index ) ) {
1004         msg(loc("Source '%1' already added", $uri));
1005         return 1;
1006     }
1007
1008     ### do we need to create the targe dir?
1009     {   my $dir = dirname( $index );
1010         unless( IS_DIR->( $dir ) ) {
1011             $self->_mkdir( dir => $dir ) or return
1012         }
1013     }
1014
1015     ### write the file
1016     my $fh = OPEN_FILE->( $index => '>' ) or do {
1017         error(loc("Could not open index file for '%1'", $uri));
1018         return;
1019     };
1020
1021     ### basically we 'touched' it. Check the return value, may be
1022     ### important on win32 and similar OS, where there's file length
1023     ### limits
1024     close $fh or do {
1025         error(loc("Could not write index file to disk for '%1'", $uri));
1026         return;
1027     };
1028
1029     $self->__update_custom_module_source(
1030                 remote  => $uri,
1031                 local   => $index,
1032                 verbose => $verbose,
1033             ) or do {
1034                 ### we faild to update it, we probably have an empty
1035                 ### possibly silly filename on disk now -- remove it
1036                 1 while unlink $index;
1037                 return;
1038             };
1039
1040     return $index;
1041 }
1042
1043 =head2 $index = $cb->__custom_module_source_index_file( uri => $uri );
1044
1045 Returns the full path to the encoded index file for C<$uri>, as used by
1046 all C<custom module source> routines.
1047
1048 =cut
1049
1050 sub __custom_module_source_index_file {
1051     my $self = shift;
1052     my $conf = $self->configure_object;
1053     my %hash = @_;
1054
1055     my($verbose,$uri);
1056     my $tmpl = {
1057         uri     => { required => 1, store => \$uri }
1058     };
1059
1060     check( $tmpl, \%hash ) or return;
1061
1062     my $index = File::Spec->catfile(
1063                     $conf->get_conf('base'),
1064                     $conf->_get_build('custom_sources'),
1065                     $self->_uri_encode( uri => $uri ),
1066                 );
1067
1068     return $index;
1069 }
1070
1071 =head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] );
1072
1073 Removes a custom index file based on the URI provided.
1074
1075 Returns the full path to the index file on success or false on failure.
1076
1077 =cut
1078
1079 sub _remove_custom_module_source {
1080     my $self = shift;
1081     my $conf = $self->configure_object;
1082     my %hash = @_;
1083
1084     my($verbose,$uri);
1085     my $tmpl = {
1086         verbose => { default => $conf->get_conf('verbose'),
1087                      store   => \$verbose },
1088         uri     => { required => 1, store => \$uri }
1089     };
1090
1091     check( $tmpl, \%hash ) or return;
1092
1093     ### use uri => local, instead of the other way around
1094     my %files = reverse $self->__list_custom_module_sources;
1095
1096     ### On VMS the case of key to %files can be either exact or lower case
1097     ### XXX abstract this lookup out? --kane
1098     my $file = $files{ $uri };
1099     $file    = $files{ lc $uri } if !defined($file) && ON_VMS;
1100
1101     unless (defined $file) {
1102         error(loc("No such custom source '%1'", $uri));
1103         return;
1104     };
1105
1106     1 while unlink $file;
1107
1108     if( IS_FILE->( $file ) ) {
1109         error(loc("Could not remove index file '%1' for custom source '%2'",
1110                     $file, $uri));
1111         return;
1112     }
1113
1114     msg(loc("Successfully removed index file for '%1'", $uri), $verbose);
1115
1116     return $file;
1117 }
1118
1119 =head2 %files = $cb->__list_custom_module_sources
1120
1121 This method scans the 'custom-sources' directory in your base directory
1122 for additional sources to include in your module tree.
1123
1124 Returns a list of key value pairs as follows:
1125
1126   /full/path/to/source/file%3Fencoded => http://decoded/mirror/path
1127
1128 =cut
1129
1130 sub __list_custom_module_sources {
1131     my $self = shift;
1132     my $conf = $self->configure_object;
1133
1134     my($verbose);
1135     my $tmpl = {
1136         verbose => { default => $conf->get_conf('verbose'),
1137                      store   => \$verbose },
1138     };
1139
1140     my $dir = File::Spec->catdir(
1141                     $conf->get_conf('base'),
1142                     $conf->_get_build('custom_sources'),
1143                 );
1144
1145     unless( IS_DIR->( $dir ) ) {
1146         msg(loc("No '%1' dir, skipping custom sources", $dir), $verbose);
1147         return;
1148     }
1149
1150     ### unencode the files
1151     ### skip ones starting with # though
1152     my %files = map {
1153         my $org = $_;
1154         my $dec = $self->_uri_decode( uri => $_ );
1155         File::Spec->catfile( $dir, $org ) => $dec
1156     } grep { $_ !~ /^#/ } READ_DIR->( $dir );
1157
1158     return %files;
1159 }
1160
1161 =head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] );
1162
1163 Attempts to update all the index files to your custom module sources.
1164
1165 If the index is missing, and it's a C<file://> uri, it will generate
1166 a new local index for you.
1167
1168 Return true on success, false on failure.
1169
1170 =cut
1171
1172 sub __update_custom_module_sources {
1173     my $self = shift;
1174     my $conf = $self->configure_object;
1175     my %hash = @_;
1176
1177     my $verbose;
1178     my $tmpl = {
1179         verbose => { default => $conf->get_conf('verbose'),
1180                      store   => \$verbose }
1181     };
1182
1183     check( $tmpl, \%hash ) or return;
1184
1185     my %files = $self->__list_custom_module_sources;
1186
1187     ### uptodate check has been done a few levels up.
1188     my $fail;
1189     while( my($local,$remote) = each %files ) {
1190
1191         $self->__update_custom_module_source(
1192                     remote  => $remote,
1193                     local   => $local,
1194                     verbose => $verbose,
1195                 ) or ( $fail++, next );
1196     }
1197
1198     error(loc("Failed updating one or more remote sources files")) if $fail;
1199
1200     return if $fail;
1201     return 1;
1202 }
1203
1204 =head2 $ok = $cb->__update_custom_module_source
1205
1206 Attempts to update all the index files to your custom module sources.
1207
1208 If the index is missing, and it's a C<file://> uri, it will generate
1209 a new local index for you.
1210
1211 Return true on success, false on failure.
1212
1213 =cut
1214
1215 sub __update_custom_module_source {
1216     my $self = shift;
1217     my $conf = $self->configure_object;
1218     my %hash = @_;
1219
1220     my($verbose,$local,$remote);
1221     my $tmpl = {
1222         verbose => { default  => $conf->get_conf('verbose'),
1223                      store    => \$verbose },
1224         local   => { store    => \$local, allow => FILE_EXISTS },
1225         remote  => { required => 1, store => \$remote },
1226     };
1227
1228     check( $tmpl, \%hash ) or return;
1229
1230     msg( loc("Updating sources from '%1'", $remote), $verbose);
1231
1232     ### if you didn't provide a local file, we'll look in your custom
1233     ### dir to find the local encoded version for you
1234     $local ||= do {
1235         ### find all files we know of
1236         my %files = reverse $self->__list_custom_module_sources or do {
1237             error(loc("No custom modules sources defined -- need '%1' argument",
1238                       'local'));
1239             return;
1240         };
1241
1242         ### On VMS the case of key to %files can be either exact or lower case
1243         ### XXX abstract this lookup out? --kane
1244         my $file = $files{ $remote };
1245         $file    = $files{ lc $remote } if !defined ($file) && ON_VMS;
1246
1247         ### return the local file we're supposed to use
1248         $file or do {
1249             error(loc("Remote source '%1' unknown -- needs '%2' argument",
1250                       $remote, 'local'));
1251             return;
1252         };
1253     };
1254
1255     my $uri =  join '/', $remote, $conf->_get_source('custom_index');
1256     my $ff  =  File::Fetch->new( uri => $uri );
1257
1258     ### tempdir doesn't clean up by default, as opposed to tempfile()
1259     ### so add it explicitly.
1260     my $dir =  tempdir( CLEANUP => 1 );
1261
1262     my $res =  do {
1263                     local $File::Fetch::WARN = 0;
1264                     local $File::Fetch::TIMEOUT = $conf->get_conf('timeout');
1265                     $ff->fetch( to => $dir );
1266                };
1267
1268     ### couldn't get the file
1269     unless( $res ) {
1270
1271         ### it's not a local scheme, so can't auto index
1272         unless( $ff->scheme eq 'file' ) {
1273             error(loc("Could not update sources from '%1': %2",
1274                       $remote, $ff->error ));
1275             return;
1276
1277         ### it's a local uri, we can index it ourselves
1278         } else {
1279             msg(loc("No index file found at '%1', generating one",
1280                     $ff->uri), $verbose );
1281
1282             ### ON VMS, if you are working with a UNIX file specification,
1283             ### you need currently use the UNIX variants of the File::Spec.
1284             my $ff_path = do {
1285                 my $file_class = 'File::Spec';
1286                 $file_class .= '::Unix' if ON_VMS;
1287                 $file_class->catdir( File::Spec::Unix->splitdir( $ff->path ) );
1288             };
1289
1290             $self->__write_custom_module_index(
1291                 path    => $ff_path,
1292                 to      => $local,
1293                 verbose => $verbose,
1294             ) or return;
1295
1296             ### XXX don't write that here, __write_custom_module_index
1297             ### already prints this out
1298             #msg(loc("Index file written to '%1'", $to), $verbose);
1299         }
1300
1301     ### copy it to the real spot and update its timestamp
1302     } else {
1303         $self->_move( file => $res, to => $local ) or return;
1304         $self->_update_timestamp( file => $local );
1305
1306         msg(loc("Index file saved to '%1'", $local), $verbose);
1307     }
1308
1309     return $local;
1310 }
1311
1312 =head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] )
1313
1314 Scans the C<path> you provided for packages and writes an index with all
1315 the available packages to C<$path/packages.txt>. If you'd like the index
1316 to be written to a different file, provide the C<to> argument.
1317
1318 Returns true on success and false on failure.
1319
1320 =cut
1321
1322 sub __write_custom_module_index {
1323     my $self = shift;
1324     my $conf = $self->configure_object;
1325     my %hash = @_;
1326
1327     my ($verbose, $path, $to);
1328     my $tmpl = {
1329         verbose => { default => $conf->get_conf('verbose'),
1330                      store   => \$verbose },
1331         path    => { required => 1, allow => DIR_EXISTS, store => \$path },
1332         to      => { store => \$to },
1333     };
1334
1335     check( $tmpl, \%hash ) or return;
1336
1337     ### no explicit to? then we'll use our default
1338     $to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') );
1339
1340     my @files;
1341     require File::Find;
1342     File::Find::find( sub {
1343         ### let's see if A::E can even parse it
1344         my $ae = do {
1345             local $Archive::Extract::WARN = 0;
1346             local $Archive::Extract::WARN = 0;
1347             Archive::Extract->new( archive => $File::Find::name )
1348         } or return;
1349
1350         ### it's a type A::E recognize, so we can add it
1351         $ae->type or return;
1352
1353         ### neither $_ nor $File::Find::name have the chunk of the path in
1354         ### it starting $path -- it's either only the filename, or the full
1355         ### path, so we have to strip it ourselves
1356         ### make sure to remove the leading slash as well.
1357         my $copy = $File::Find::name;
1358         my $re   = quotemeta($path);
1359         $copy    =~ s|^$re[\\/]?||i;
1360
1361         push @files, $copy;
1362
1363     }, $path );
1364
1365     ### does the dir exist? if not, create it.
1366     {   my $dir = dirname( $to );
1367         unless( IS_DIR->( $dir ) ) {
1368             $self->_mkdir( dir => $dir ) or return
1369         }
1370     }
1371
1372     ### create the index file
1373     my $fh = OPEN_FILE->( $to => '>' ) or return;
1374
1375     print $fh "$_\n" for @files;
1376     close $fh;
1377
1378     msg(loc("Successfully written index file to '%1'", $to), $verbose);
1379
1380     return $to;
1381 }
1382
1383
1384 =head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] )
1385
1386 Creates entries in the module tree based upon the files as returned
1387 by C<__list_custom_module_sources>.
1388
1389 Returns true on success, false on failure.
1390
1391 =cut
1392
1393 ### use $auth_obj as a persistent version, so we don't have to recreate
1394 ### modules all the time
1395 {   my $auth_obj;
1396
1397     sub __create_custom_module_entries {
1398         my $self    = shift;
1399         my $conf    = $self->configure_object;
1400         my %hash    = @_;
1401
1402         my $verbose;
1403         my $tmpl = {
1404             verbose     => { default => $conf->get_conf('verbose'), store => \$verbose },
1405         };
1406
1407         check( $tmpl, \%hash ) or return undef;
1408
1409         my %files = $self->__list_custom_module_sources;
1410
1411         while( my($file,$name) = each %files ) {
1412
1413             msg(loc("Adding packages from custom source '%1'", $name), $verbose);
1414
1415             my $fh = OPEN_FILE->( $file ) or next;
1416
1417             while( local $_ = <$fh> ) {
1418                 chomp;
1419                 next if /^#/;
1420                 next unless /\S+/;
1421
1422                 ### join on / -- it's a URI after all!
1423                 my $parse = join '/', $name, $_;
1424
1425                 ### try to make a module object out of it
1426                 my $mod = $self->parse_module( module => $parse ) or (
1427                     error(loc("Could not parse '%1'", $_)),
1428                     next
1429                 );
1430
1431                 ### mark this object with a custom author
1432                 $auth_obj ||= do {
1433                     my $id = CUSTOM_AUTHOR_ID;
1434
1435                     ### if the object is being created for the first time,
1436                     ### make sure there's an entry in the author tree as
1437                     ### well, so we can search on the CPAN ID
1438                     $self->author_tree->{ $id } =
1439                         CPANPLUS::Module::Author::Fake->new( cpanid => $id );
1440                 };
1441
1442                 $mod->author( $auth_obj );
1443
1444                 ### and now add it to the module tree -- this MAY
1445                 ### override things of course
1446                 if( my $old_mod = $self->module_tree( $mod->module ) ) {
1447
1448                     ### On VMS use the old module name to get the real case
1449                     $mod->module( $old_mod->module ) if ON_VMS;
1450
1451                     msg(loc("About to overwrite module tree entry for '%1' with '%2'",
1452                             $mod->module, $mod->package), $verbose);
1453                 }
1454
1455                 ### mark where it came from
1456                 $mod->description( loc("Custom source from '%1'",$name) );
1457
1458                 ### store it in the module tree
1459                 $self->module_tree->{ $mod->module } = $mod;
1460             }
1461         }
1462
1463         return 1;
1464     }
1465 }
1466
1467 1;