1 package CPANPLUS::Internals::Source;
7 use CPANPLUS::Module::Fake;
8 use CPANPLUS::Module::Author;
9 use CPANPLUS::Internals::Constants;
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';
21 $Params::Check::VERBOSE = 1;
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
32 my $class = ref $self || $self;
35 Carp::croak( loc( "Class %1 must implement method '%2'",
42 my $recurse; # flag to prevent recursive calls to *_tree functions
44 ### lazy loading of module tree
48 unless ($self->_mtree or $recurse++ > 0) {
49 my $uptodate = $self->_check_trees( @_[1..$#_] );
50 $self->_build_trees(uptodate => $uptodate);
57 ### lazy loading of author tree
61 unless ($self->_atree or $recurse++ > 0) {
62 my $uptodate = $self->_check_trees( @_[1..$#_] );
63 $self->_build_trees(uptodate => $uptodate);
77 CPANPLUS::Internals::Source
81 ### lazy load author/module trees ###
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
92 Functions exist to check if source files are still C<good to use> as
93 well as update them, and then parse them.
95 The flow looks like this:
97 $cb->_author_tree || $cb->_module_tree
101 $cb->__update_custom_module_sources
102 $cb->__update_custom_module_source
106 $cb->_standard_trees_completed
107 $cb->_custom_trees_completed
109 $cb->__create_author_tree
111 { $cb->_add_author_object }
112 $cb->__create_module_tree
113 $cb->__create_dslip_tree
115 { $cb->_add_module_object }
116 $cb->__create_custom_module_entries
126 =head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] )
128 This method rebuilds the author- and module-trees from source.
130 It takes the following arguments:
136 Indicates whether any on disk caches are still ok to use.
140 The absolute path to the directory holding the source files.
144 A boolean flag indicating whether or not to be verbose.
148 A boolean flag indicating whether or not it is ok to use previously
149 stored trees. Defaults to true.
153 Returns a boolean indicating success.
157 ### (re)build the trees ###
159 my ($self, %hash) = @_;
160 my $conf = $self->configure_object;
162 my($path,$uptodate,$use_stored,$verbose);
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 },
170 my $args = check( $tmpl, \%hash ) or return;
174 uptodate => $uptodate,
176 use_stored => $use_stored,
178 error( loc("Could not initialize trees" ) );
182 ### return if we weren't able to build the trees ###
183 return unless $self->_mtree && $self->_atree;
185 ### did we get everything from a stored state? if not,
186 ### process them now.
187 if( not $self->_standard_trees_completed ) {
189 ### first, prep the author tree
190 $self->__create_author_tree(
191 uptodate => $uptodate,
196 ### and now the module tree
197 $self->_create_mod_tree(
198 uptodate => $uptodate,
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 ) {
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"));
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"));
225 ### give the source engine a chance to wrap up creation
226 $self->_finalize_trees(
228 uptodate => $uptodate,
230 use_stored => $use_stored,
232 error(loc( "Could not finalize trees" ));
236 ### still necessary? can only run one instance now ###
237 ### will probably stay that way --kane
238 # my $id = $self->_store_id( $self );
240 # unless ( $id == $self->_id ) {
241 # error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) );
249 =head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] )
251 Retrieve source files and return a boolean indicating whether or not
252 the source files are up to date.
254 Takes several arguments:
260 A flag to force re-fetching of the source files, even
261 if they are still up to date.
265 The absolute path to the directory holding the source files.
269 A boolean flag indicating whether or not to be verbose.
273 Will get information from the config file by default.
277 ### retrieve source files, and returns a boolean indicating if it's up to date
279 my ($self, %hash) = @_;
280 my $conf = $self->configure_object;
287 path => { default => $conf->get_conf('base'),
290 verbose => { default => $conf->get_conf('verbose'),
293 update_source => { default => 0, store => \$update_source },
296 my $args = check( $tmpl, \%hash ) or return;
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;
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 );
305 my $uptodate = 1; # default return value
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 ),
312 update_source => $update_source,
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
321 $self->__update_custom_module_sources( verbose => $verbose )
322 if $update_source or !$uptodate;
329 =head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] )
331 C<__check_uptodate> checks if a given source file is still up-to-date
332 and if not, or when C<update_source> is true, will re-fetch the source
335 Takes the following arguments:
341 The source file to check.
345 The internal shortcut name for the source file (used for config
350 Flag to force updating of sourcefiles regardless.
354 Boolean to indicate whether to be verbose or not.
358 Returns a boolean value indicating whether the current files are up
363 ### this method checks whether or not the source files we are using are still up to date
364 sub __check_uptodate {
367 my $conf = $self->configure_object;
371 file => { required => 1 },
372 name => { required => 1 },
373 update_source => { default => 0 },
374 verbose => { default => $conf->get_conf('verbose') },
377 my $args = check( $tmpl, \%hash ) or return;
380 unless ( -e $args->{'file'} && (
381 ( stat $args->{'file'} )[9]
382 + $conf->_get_source('update') )
387 if ( $flag or $args->{'update_source'} ) {
389 if ( $self->_update_source( name => $args->{'name'} ) ) {
390 return 0; # return 0 so 'uptodate' will be set to 0, meaning no
391 # use of previously stored hashrefs!
393 msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} );
404 =head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] )
406 This method does the actual fetching of source files.
408 It takes the following arguments:
414 The internal shortcut name for the source file (used for config
419 The full path where to write the files.
423 Boolean to indicate whether to be verbose or not.
427 Returns a boolean to indicate success.
431 ### this sub fetches new source files ###
435 my $conf = $self->configure_object;
439 name => { required => 1 },
440 path => { default => $conf->get_conf('base') },
441 verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
444 my $args = check( $tmpl, \%hash ) or return;
447 my $path = $args->{path};
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;
453 msg( loc("Updating source file '%1'", $file), $verbose );
455 my $fake = CPANPLUS::Module::Fake->new(
456 module => $args->{'name'},
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(
472 error( loc("Couldn't fetch '%1'", $file) );
476 $self->_update_timestamp( file => File::Spec->catfile($path, $file) );
484 =head2 $cb->__create_author_tree([path => $path, uptodate => BOOL, verbose => BOOL])
486 This method opens a source files and parses its contents into a
487 searchable author-tree or restores a file-cached version of a
488 previous parse, if the sources are uptodate and the file-cache exists.
490 It takes the following arguments:
496 A flag indicating whether the file-cache is uptodate or not.
500 The absolute path to the directory holding the source files.
504 A boolean flag indicating whether or not to be verbose.
508 Will get information from the config file by default.
510 Returns a tree on success, false on failure.
514 sub __create_author_tree {
517 my $conf = $self->configure_object;
521 path => { default => $conf->get_conf('base') },
522 verbose => { default => $conf->get_conf('verbose') },
523 uptodate => { default => 0 },
526 my $args = check( $tmpl, \%hash ) or return;
528 my $file = File::Spec->catfile(
530 $conf->_get_source('auth')
533 msg(loc("Rebuilding author tree, this might take a while"),
536 ### extract the file ###
537 my $ae = Archive::Extract->new( archive => $file ) or return;
538 my $out = STRIP_GZ_SUFFIX->($file);
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;
545 my $cont = $self->_get_file_contents( file => $out ) or return;
547 ### don't need it anymore ###
550 for ( split /\n/, $cont ) {
551 my($id, $name, $email) = m/^alias \s+
553 "\s* ([^\"\<]+?) \s* <(.+)> \s*"
556 $self->_add_author_object(
557 author => $name, #authors name
558 email => $email, #authors email address
559 cpanid => $id, #authors CPAN ID
560 ) or error( loc("Could not add author '%1'", $name ) );
564 return $self->_atree;
566 } #__create_author_tree
570 =head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL])
572 This method opens a source files and parses its contents into a
573 searchable module-tree or restores a file-cached version of a
574 previous parse, if the sources are uptodate and the file-cache exists.
576 It takes the following arguments:
582 A flag indicating whether the file-cache is up-to-date or not.
586 The absolute path to the directory holding the source files.
590 A boolean flag indicating whether or not to be verbose.
594 Will get information from the config file by default.
596 Returns a tree on success, false on failure.
600 ### this builds a hash reference with the structure of the cpan module tree ###
601 sub _create_mod_tree {
604 my $conf = $self->configure_object;
608 path => { default => $conf->get_conf('base') },
609 verbose => { default => $conf->get_conf('verbose') },
610 uptodate => { default => 0 },
613 my $args = check( $tmpl, \%hash ) or return undef;
614 my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod'));
616 msg(loc("Rebuilding module tree, this might take a while"),
620 my $dslip_tree = $self->__create_dslip_tree( %$args );
622 ### extract the file ###
623 my $ae = Archive::Extract->new( archive => $file ) or return;
624 my $out = STRIP_GZ_SUFFIX->($file);
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;
631 my $content = $self->_get_file_contents( file => $out ) or return;
632 my $lines = $content =~ tr/\n/\n/;
634 ### don't need it anymore ###
637 my($past_header, $count);
638 for ( split /\n/, $content ) {
640 ### quick hack to read past the header of the file ###
641 ### this is still rather evil... fix some time - Kane
644 error(loc("Could not determine line count from %1", $file));
650 ### we're still in the header -- find the amount of lines we expect
651 unless( $past_header ) {
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+)/;
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 ));
664 ### still in the header, keep moving
668 ### skip empty lines ###
672 my @data = split /\s+/;
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] =~
680 ([A-Z\d-]+) (?:/[\S]+)?/
684 ### remove file name from the path
685 $data[2] =~ s|/[^/]+$||;
687 my $aobj = $self->author_tree($author);
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] ) );
695 ### adding the dslip info
696 ### probably can use some optimization
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}
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.
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
717 path => File::Spec::Unix->catfile(
718 $conf->_get_mirror('base'),
720 ), # extended path on the cpan mirror,
722 comment => $data[3], # comment on the module
724 package => $package, # package name, like
725 # 'foo-bar-baz-1.03.tar.gz'
726 description => $dslip_tree->{ $data[0] }->{'description'},
729 ) or error( loc( "Could not add module '%1'", $data[0] ) );
733 return $self->_mtree;
739 =head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL])
741 This method opens a source files and parses its contents into a
742 searchable dslip-tree or restores a file-cached version of a
743 previous parse, if the sources are uptodate and the file-cache exists.
745 It takes the following arguments:
751 A flag indicating whether the file-cache is uptodate or not.
755 The absolute path to the directory holding the source files.
759 A boolean flag indicating whether or not to be verbose.
763 Will get information from the config file by default.
765 Returns a tree on success, false on failure.
769 sub __create_dslip_tree {
772 my $conf = $self->configure_object;
775 path => { default => $conf->get_conf('base') },
776 verbose => { default => $conf->get_conf('verbose') },
777 uptodate => { default => 0 },
780 my $args = check( $tmpl, \%hash ) or return;
782 ### get the file name of the source ###
783 my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip'));
785 ### extract the file ###
786 my $ae = Archive::Extract->new( archive => $file ) or return;
787 my $out = STRIP_GZ_SUFFIX->($file);
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;
794 my $in = $self->_get_file_contents( file => $out ) or return;
796 ### don't need it anymore ###
800 ### get rid of the comments and the code ###
801 ### need a smarter parser, some people have this in their dslip info:
809 # 'Implements Linear Threshold Units',
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!",
815 ### also, older versions say:
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
822 my ($ds_one, $ds_two) = ($in =~ m|.+}\s+
823 (\$(?:CPAN::Modulelist::)?cols.*?)
824 (\$(?:CPAN::Modulelist::)?data.*)
827 ### eval them into existence ###
828 ### still not too fond of this solution - kane ###
830 { #local $@; can't use this, it's buggy -kane
832 $cols = eval $ds_one;
833 error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
835 $data = eval $ds_two;
836 error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
841 my $primary = "modid";
843 ### this comes from CPAN::Modulelist
844 ### which is in 03modlist.data.gz
848 $tree->{$hash{$primary}} = \%hash;
853 } #__create_dslip_tree
857 =head2 $cb->_dslip_defs ()
859 This function returns the definition structure (ARRAYREF) of the
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
868 ### right now, this is just used to look up dslip info from a module
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'),
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'),
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++'),
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'),
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)'),
926 =head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] );
928 Adds a custom source index and updates it based on the provided URI.
930 Returns the full path to the index file on success or false on failure.
934 sub _add_custom_module_source {
936 my $conf = $self->configure_object;
941 verbose => { default => $conf->get_conf('verbose'),
942 store => \$verbose },
943 uri => { required => 1, store => \$uri }
946 check( $tmpl, \%hash ) or return;
948 ### what index file should we use on disk?
949 my $index = $self->__custom_module_source_index_file( uri => $uri );
952 if( IS_FILE->( $index ) ) {
953 msg(loc("Source '%1' already added", $uri));
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
965 my $fh = OPEN_FILE->( $index => '>' ) or do {
966 error(loc("Could not open index file for '%1'", $uri));
970 ### basically we 'touched' it. Check the return value, may be
971 ### important on win32 and similar OS, where there's file length
974 error(loc("Could not write index file to disk for '%1'", $uri));
978 $self->__update_custom_module_source(
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;
992 =head2 $index = $cb->__custom_module_source_index_file( uri => $uri );
994 Returns the full path to the encoded index file for C<$uri>, as used by
995 all C<custom module source> routines.
999 sub __custom_module_source_index_file {
1001 my $conf = $self->configure_object;
1006 uri => { required => 1, store => \$uri }
1009 check( $tmpl, \%hash ) or return;
1011 my $index = File::Spec->catfile(
1012 $conf->get_conf('base'),
1013 $conf->_get_build('custom_sources'),
1014 $self->_uri_encode( uri => $uri ),
1020 =head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] );
1022 Removes a custom index file based on the URI provided.
1024 Returns the full path to the index file on success or false on failure.
1028 sub _remove_custom_module_source {
1030 my $conf = $self->configure_object;
1035 verbose => { default => $conf->get_conf('verbose'),
1036 store => \$verbose },
1037 uri => { required => 1, store => \$uri }
1040 check( $tmpl, \%hash ) or return;
1042 ### use uri => local, instead of the other way around
1043 my %files = reverse $self->__list_custom_module_sources;
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;
1050 unless (defined $file) {
1051 error(loc("No such custom source '%1'", $uri));
1055 1 while unlink $file;
1057 if( IS_FILE->( $file ) ) {
1058 error(loc("Could not remove index file '%1' for custom source '%2'",
1063 msg(loc("Successfully removed index file for '%1'", $uri), $verbose);
1068 =head2 %files = $cb->__list_custom_module_sources
1070 This method scans the 'custom-sources' directory in your base directory
1071 for additional sources to include in your module tree.
1073 Returns a list of key value pairs as follows:
1075 /full/path/to/source/file%3Fencoded => http://decoded/mirror/path
1079 sub __list_custom_module_sources {
1081 my $conf = $self->configure_object;
1085 verbose => { default => $conf->get_conf('verbose'),
1086 store => \$verbose },
1089 my $dir = File::Spec->catdir(
1090 $conf->get_conf('base'),
1091 $conf->_get_build('custom_sources'),
1094 unless( IS_DIR->( $dir ) ) {
1095 msg(loc("No '%1' dir, skipping custom sources", $dir), $verbose);
1099 ### unencode the files
1100 ### skip ones starting with # though
1103 my $dec = $self->_uri_decode( uri => $_ );
1104 File::Spec->catfile( $dir, $org ) => $dec
1105 } grep { $_ !~ /^#/ } READ_DIR->( $dir );
1110 =head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] );
1112 Attempts to update all the index files to your custom module sources.
1114 If the index is missing, and it's a C<file://> uri, it will generate
1115 a new local index for you.
1117 Return true on success, false on failure.
1121 sub __update_custom_module_sources {
1123 my $conf = $self->configure_object;
1128 verbose => { default => $conf->get_conf('verbose'),
1129 store => \$verbose }
1132 check( $tmpl, \%hash ) or return;
1134 my %files = $self->__list_custom_module_sources;
1136 ### uptodate check has been done a few levels up.
1138 while( my($local,$remote) = each %files ) {
1140 $self->__update_custom_module_source(
1143 verbose => $verbose,
1144 ) or ( $fail++, next );
1147 error(loc("Failed updating one or more remote sources files")) if $fail;
1153 =head2 $ok = $cb->__update_custom_module_source
1155 Attempts to update all the index files to your custom module sources.
1157 If the index is missing, and it's a C<file://> uri, it will generate
1158 a new local index for you.
1160 Return true on success, false on failure.
1164 sub __update_custom_module_source {
1166 my $conf = $self->configure_object;
1169 my($verbose,$local,$remote);
1171 verbose => { default => $conf->get_conf('verbose'),
1172 store => \$verbose },
1173 local => { store => \$local, allow => FILE_EXISTS },
1174 remote => { required => 1, store => \$remote },
1177 check( $tmpl, \%hash ) or return;
1179 msg( loc("Updating sources from '%1'", $remote), $verbose);
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
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",
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;
1196 ### return the local file we're supposed to use
1198 error(loc("Remote source '%1' unknown -- needs '%2' argument",
1204 my $uri = join '/', $remote, $conf->_get_source('custom_index');
1205 my $ff = File::Fetch->new( uri => $uri );
1207 ### tempdir doesn't clean up by default, as opposed to tempfile()
1208 ### so add it explicitly.
1209 my $dir = tempdir( CLEANUP => 1 );
1211 my $res = do { local $File::Fetch::WARN = 0;
1212 local $File::Fetch::WARN = 0;
1213 $ff->fetch( to => $dir );
1216 ### couldn't get the file
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 ));
1225 ### it's a local uri, we can index it ourselves
1227 msg(loc("No index file found at '%1', generating one",
1228 $ff->uri), $verbose );
1230 ### ON VMS, if you are working with a UNIX file specification,
1231 ### you need currently use the UNIX variants of the File::Spec.
1233 my $file_class = 'File::Spec';
1234 $file_class .= '::Unix' if ON_VMS;
1235 $file_class->catdir( File::Spec::Unix->splitdir( $ff->path ) );
1238 $self->__write_custom_module_index(
1241 verbose => $verbose,
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);
1249 ### copy it to the real spot and update its timestamp
1251 $self->_move( file => $res, to => $local ) or return;
1252 $self->_update_timestamp( file => $local );
1254 msg(loc("Index file saved to '%1'", $local), $verbose);
1260 =head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] )
1262 Scans the C<path> you provided for packages and writes an index with all
1263 the available packages to C<$path/packages.txt>. If you'd like the index
1264 to be written to a different file, provide the C<to> argument.
1266 Returns true on success and false on failure.
1270 sub __write_custom_module_index {
1272 my $conf = $self->configure_object;
1275 my ($verbose, $path, $to);
1277 verbose => { default => $conf->get_conf('verbose'),
1278 store => \$verbose },
1279 path => { required => 1, allow => DIR_EXISTS, store => \$path },
1280 to => { store => \$to },
1283 check( $tmpl, \%hash ) or return;
1285 ### no explicit to? then we'll use our default
1286 $to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') );
1290 File::Find::find( sub {
1291 ### let's see if A::E can even parse it
1293 local $Archive::Extract::WARN = 0;
1294 local $Archive::Extract::WARN = 0;
1295 Archive::Extract->new( archive => $File::Find::name )
1298 ### it's a type A::E recognize, so we can add it
1299 $ae->type or return;
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);
1307 $copy =~ s|^$re[\\/]?||i;
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
1320 ### create the index file
1321 my $fh = OPEN_FILE->( $to => '>' ) or return;
1323 print $fh "$_\n" for @files;
1326 msg(loc("Successfully written index file to '%1'", $to), $verbose);
1332 =head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] )
1334 Creates entries in the module tree based upon the files as returned
1335 by C<__list_custom_module_sources>.
1337 Returns true on success, false on failure.
1341 ### use $auth_obj as a persistant version, so we don't have to recreate
1342 ### modules all the time
1345 sub __create_custom_module_entries {
1347 my $conf = $self->configure_object;
1352 verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
1355 check( $tmpl, \%hash ) or return undef;
1357 my %files = $self->__list_custom_module_sources;
1359 while( my($file,$name) = each %files ) {
1361 msg(loc("Adding packages from custom source '%1'", $name), $verbose);
1363 my $fh = OPEN_FILE->( $file ) or next;
1365 while( local $_ = <$fh> ) {
1370 ### join on / -- it's a URI after all!
1371 my $parse = join '/', $name, $_;
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'", $_)),
1379 ### mark this object with a custom author
1381 my $id = CUSTOM_AUTHOR_ID;
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 );
1390 $mod->author( $auth_obj );
1392 ### and now add it to the modlue tree -- this MAY
1393 ### override things of course
1394 if( my $old_mod = $self->module_tree( $mod->module ) ) {
1396 ### On VMS use the old module name to get the real case
1397 $mod->module( $old_mod->module ) if ON_VMS;
1399 msg(loc("About to overwrite module tree entry for '%1' with '%2'",
1400 $mod->module, $mod->package), $verbose);
1403 ### mark where it came from
1404 $mod->description( loc("Custom source from '%1'",$name) );
1406 ### store it in the module tree
1407 $self->module_tree->{ $mod->module } = $mod;