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