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