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 $cont = $self->_get_file_contents( file => $out ) or return;
633 ### don't need it anymore ###
638 for ( split /\n/, $cont ) {
640 ### quick hack to read past the header of the file ###
641 ### this is still rather evil... fix some time - Kane
642 $flag = 1 if m|^\s*$|;
645 ### skip empty lines ###
649 my @data = split /\s+/;
651 ### filter out the author and filename as well ###
652 ### authors can apparently have digits in their names,
653 ### and dirs can have dots... blah!
654 my ($author, $package) = $data[2] =~
657 ([A-Z\d-]+) (?:/[\S]+)?/
661 ### remove file name from the path
662 $data[2] =~ s|/[^/]+$||;
664 my $aobj = $self->author_tree($author);
666 error( loc( "No such author '%1' -- can't make module object " .
667 "'%2' that is supposed to belong to this author",
668 $author, $data[0] ) );
672 ### adding the dslip info
673 ### probably can use some optimization
675 for my $item ( qw[ statd stats statl stati statp ] ) {
676 ### checking if there's an entry in the dslip info before
677 ### catting it on. appeasing warnings this way
678 $dslip .= $dslip_tree->{ $data[0] }->{$item}
679 ? $dslip_tree->{ $data[0] }->{$item}
683 ### XXX this could be sped up if we used author names, not author
684 ### objects in creation, and then look them up in the author tree
685 ### when needed. This will need a fix to all the places that create
686 ### fake author/module objects as well.
688 ### callback to store the individual object
689 $self->_add_module_object(
690 module => $data[0], # full module name
691 version => ($data[1] eq 'undef' # version number
694 path => File::Spec::Unix->catfile(
695 $conf->_get_mirror('base'),
697 ), # extended path on the cpan mirror,
699 comment => $data[3], # comment on the module
701 package => $package, # package name, like
702 # 'foo-bar-baz-1.03.tar.gz'
703 description => $dslip_tree->{ $data[0] }->{'description'},
706 ) or error( loc( "Could not add module '%1'", $data[0] ) );
710 return $self->_mtree;
716 =head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL])
718 This method opens a source files and parses its contents into a
719 searchable dslip-tree or restores a file-cached version of a
720 previous parse, if the sources are uptodate and the file-cache exists.
722 It takes the following arguments:
728 A flag indicating whether the file-cache is uptodate or not.
732 The absolute path to the directory holding the source files.
736 A boolean flag indicating whether or not to be verbose.
740 Will get information from the config file by default.
742 Returns a tree on success, false on failure.
746 sub __create_dslip_tree {
749 my $conf = $self->configure_object;
752 path => { default => $conf->get_conf('base') },
753 verbose => { default => $conf->get_conf('verbose') },
754 uptodate => { default => 0 },
757 my $args = check( $tmpl, \%hash ) or return;
759 ### get the file name of the source ###
760 my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip'));
762 ### extract the file ###
763 my $ae = Archive::Extract->new( archive => $file ) or return;
764 my $out = STRIP_GZ_SUFFIX->($file);
766 ### make sure to set the PREFER_BIN flag if desired ###
767 { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
768 $ae->extract( to => $out ) or return;
771 my $in = $self->_get_file_contents( file => $out ) or return;
773 ### don't need it anymore ###
777 ### get rid of the comments and the code ###
778 ### need a smarter parser, some people have this in their dslip info:
786 # 'Implements Linear Threshold Units',
788 # "\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!",
792 ### also, older versions say:
794 ### and newer versions say:
795 ### $CPANPLUS::Modulelist::cols = [...]
796 ### split '$cols' and '$data' into 2 variables ###
797 ### use this regex to make sure dslips with ';' in them don't cause
799 my ($ds_one, $ds_two) = ($in =~ m|.+}\s+
800 (\$(?:CPAN::Modulelist::)?cols.*?)
801 (\$(?:CPAN::Modulelist::)?data.*)
804 ### eval them into existence ###
805 ### still not too fond of this solution - kane ###
807 { #local $@; can't use this, it's buggy -kane
809 $cols = eval $ds_one;
810 error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
812 $data = eval $ds_two;
813 error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
818 my $primary = "modid";
820 ### this comes from CPAN::Modulelist
821 ### which is in 03modlist.data.gz
825 $tree->{$hash{$primary}} = \%hash;
830 } #__create_dslip_tree
834 =head2 $cb->_dslip_defs ()
836 This function returns the definition structure (ARRAYREF) of the
841 ### these are the definitions used for dslip info
842 ### they shouldn't change over time.. so hardcoding them doesn't appear to
843 ### be a problem. if it is, we need to parse 03modlist.data better to filter
845 ### right now, this is just used to look up dslip info from a module
852 [ q|Development Stage|, {
853 i => loc('Idea, listed to gain consensus or as a placeholder'),
854 c => loc('under construction but pre-alpha (not yet released)'),
855 a => loc('Alpha testing'),
856 b => loc('Beta testing'),
857 R => loc('Released'),
858 M => loc('Mature (no rigorous definition)'),
859 S => loc('Standard, supplied with Perl 5'),
863 [ q|Support Level|, {
864 m => loc('Mailing-list'),
865 d => loc('Developer'),
866 u => loc('Usenet newsgroup comp.lang.perl.modules'),
867 n => loc('None known, try comp.lang.perl.modules'),
868 a => loc('Abandoned; volunteers welcome to take over maintainance'),
872 [ q|Language Used|, {
873 p => loc('Perl-only, no compiler needed, should be platform independent'),
874 c => loc('C and perl, a C compiler will be needed'),
875 h => loc('Hybrid, written in perl with optional C code, no compiler needed'),
876 '+' => loc('C++ and perl, a C++ compiler will be needed'),
877 o => loc('perl and another language other than C or C++'),
881 [ q|Interface Style|, {
882 f => loc('plain Functions, no references used'),
883 h => loc('hybrid, object and function interfaces available'),
884 n => loc('no interface at all (huh?)'),
885 r => loc('some use of unblessed References or ties'),
886 O => loc('Object oriented using blessed references and/or inheritance'),
890 [ q|Public License|, {
891 p => loc('Standard-Perl: user may choose between GPL and Artistic'),
892 g => loc('GPL: GNU General Public License'),
893 l => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'),
894 b => loc('BSD: The BSD License'),
895 a => loc('Artistic license alone'),
896 o => loc('other (but distribution allowed without restrictions)'),
903 =head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] );
905 Adds a custom source index and updates it based on the provided URI.
907 Returns the full path to the index file on success or false on failure.
911 sub _add_custom_module_source {
913 my $conf = $self->configure_object;
918 verbose => { default => $conf->get_conf('verbose'),
919 store => \$verbose },
920 uri => { required => 1, store => \$uri }
923 check( $tmpl, \%hash ) or return;
925 ### what index file should we use on disk?
926 my $index = $self->__custom_module_source_index_file( uri => $uri );
929 if( IS_FILE->( $index ) ) {
930 msg(loc("Source '%1' already added", $uri));
934 ### do we need to create the targe dir?
935 { my $dir = dirname( $index );
936 unless( IS_DIR->( $dir ) ) {
937 $self->_mkdir( dir => $dir ) or return
942 my $fh = OPEN_FILE->( $index => '>' ) or do {
943 error(loc("Could not open index file for '%1'", $uri));
947 ### basically we 'touched' it. Check the return value, may be
948 ### important on win32 and similar OS, where there's file length
951 error(loc("Could not write index file to disk for '%1'", $uri));
955 $self->__update_custom_module_source(
960 ### we faild to update it, we probably have an empty
961 ### possibly silly filename on disk now -- remove it
962 1 while unlink $index;
969 =head2 $index = $cb->__custom_module_source_index_file( uri => $uri );
971 Returns the full path to the encoded index file for C<$uri>, as used by
972 all C<custom module source> routines.
976 sub __custom_module_source_index_file {
978 my $conf = $self->configure_object;
983 uri => { required => 1, store => \$uri }
986 check( $tmpl, \%hash ) or return;
988 my $index = File::Spec->catfile(
989 $conf->get_conf('base'),
990 $conf->_get_build('custom_sources'),
991 $self->_uri_encode( uri => $uri ),
997 =head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] );
999 Removes a custom index file based on the URI provided.
1001 Returns the full path to the index file on success or false on failure.
1005 sub _remove_custom_module_source {
1007 my $conf = $self->configure_object;
1012 verbose => { default => $conf->get_conf('verbose'),
1013 store => \$verbose },
1014 uri => { required => 1, store => \$uri }
1017 check( $tmpl, \%hash ) or return;
1019 ### use uri => local, instead of the other way around
1020 my %files = reverse $self->__list_custom_module_sources;
1022 ### On VMS the case of key to %files can be either exact or lower case
1023 ### XXX abstract this lookup out? --kane
1024 my $file = $files{ $uri };
1025 $file = $files{ lc $uri } if !defined($file) && ON_VMS;
1027 unless (defined $file) {
1028 error(loc("No such custom source '%1'", $uri));
1032 1 while unlink $file;
1034 if( IS_FILE->( $file ) ) {
1035 error(loc("Could not remove index file '%1' for custom source '%2'",
1040 msg(loc("Successfully removed index file for '%1'", $uri), $verbose);
1045 =head2 %files = $cb->__list_custom_module_sources
1047 This method scans the 'custom-sources' directory in your base directory
1048 for additional sources to include in your module tree.
1050 Returns a list of key value pairs as follows:
1052 /full/path/to/source/file%3Fencoded => http://decoded/mirror/path
1056 sub __list_custom_module_sources {
1058 my $conf = $self->configure_object;
1062 verbose => { default => $conf->get_conf('verbose'),
1063 store => \$verbose },
1066 my $dir = File::Spec->catdir(
1067 $conf->get_conf('base'),
1068 $conf->_get_build('custom_sources'),
1071 unless( IS_DIR->( $dir ) ) {
1072 msg(loc("No '%1' dir, skipping custom sources", $dir), $verbose);
1076 ### unencode the files
1077 ### skip ones starting with # though
1080 my $dec = $self->_uri_decode( uri => $_ );
1081 File::Spec->catfile( $dir, $org ) => $dec
1082 } grep { $_ !~ /^#/ } READ_DIR->( $dir );
1087 =head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] );
1089 Attempts to update all the index files to your custom module sources.
1091 If the index is missing, and it's a C<file://> uri, it will generate
1092 a new local index for you.
1094 Return true on success, false on failure.
1098 sub __update_custom_module_sources {
1100 my $conf = $self->configure_object;
1105 verbose => { default => $conf->get_conf('verbose'),
1106 store => \$verbose }
1109 check( $tmpl, \%hash ) or return;
1111 my %files = $self->__list_custom_module_sources;
1113 ### uptodate check has been done a few levels up.
1115 while( my($local,$remote) = each %files ) {
1117 $self->__update_custom_module_source(
1120 verbose => $verbose,
1121 ) or ( $fail++, next );
1124 error(loc("Failed updating one or more remote sources files")) if $fail;
1130 =head2 $ok = $cb->__update_custom_module_source
1132 Attempts to update all the index files to your custom module sources.
1134 If the index is missing, and it's a C<file://> uri, it will generate
1135 a new local index for you.
1137 Return true on success, false on failure.
1141 sub __update_custom_module_source {
1143 my $conf = $self->configure_object;
1146 my($verbose,$local,$remote);
1148 verbose => { default => $conf->get_conf('verbose'),
1149 store => \$verbose },
1150 local => { store => \$local, allow => FILE_EXISTS },
1151 remote => { required => 1, store => \$remote },
1154 check( $tmpl, \%hash ) or return;
1156 msg( loc("Updating sources from '%1'", $remote), $verbose);
1158 ### if you didn't provide a local file, we'll look in your custom
1159 ### dir to find the local encoded version for you
1161 ### find all files we know of
1162 my %files = reverse $self->__list_custom_module_sources or do {
1163 error(loc("No custom modules sources defined -- need '%1' argument",
1168 ### On VMS the case of key to %files can be either exact or lower case
1169 ### XXX abstract this lookup out? --kane
1170 my $file = $files{ $remote };
1171 $file = $files{ lc $remote } if !defined ($file) && ON_VMS;
1173 ### return the local file we're supposed to use
1175 error(loc("Remote source '%1' unknown -- needs '%2' argument",
1181 my $uri = join '/', $remote, $conf->_get_source('custom_index');
1182 my $ff = File::Fetch->new( uri => $uri );
1184 ### tempdir doesn't clean up by default, as opposed to tempfile()
1185 ### so add it explicitly.
1186 my $dir = tempdir( CLEANUP => 1 );
1188 my $res = do { local $File::Fetch::WARN = 0;
1189 local $File::Fetch::WARN = 0;
1190 $ff->fetch( to => $dir );
1193 ### couldn't get the file
1196 ### it's not a local scheme, so can't auto index
1197 unless( $ff->scheme eq 'file' ) {
1198 error(loc("Could not update sources from '%1': %2",
1199 $remote, $ff->error ));
1202 ### it's a local uri, we can index it ourselves
1204 msg(loc("No index file found at '%1', generating one",
1205 $ff->uri), $verbose );
1207 ### ON VMS, if you are working with a UNIX file specification,
1208 ### you need currently use the UNIX variants of the File::Spec.
1210 my $file_class = 'File::Spec';
1211 $file_class .= '::Unix' if ON_VMS;
1212 $file_class->catdir( File::Spec::Unix->splitdir( $ff->path ) );
1215 $self->__write_custom_module_index(
1218 verbose => $verbose,
1221 ### XXX don't write that here, __write_custom_module_index
1222 ### already prints this out
1223 #msg(loc("Index file written to '%1'", $to), $verbose);
1226 ### copy it to the real spot and update its timestamp
1228 $self->_move( file => $res, to => $local ) or return;
1229 $self->_update_timestamp( file => $local );
1231 msg(loc("Index file saved to '%1'", $local), $verbose);
1237 =head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] )
1239 Scans the C<path> you provided for packages and writes an index with all
1240 the available packages to C<$path/packages.txt>. If you'd like the index
1241 to be written to a different file, provide the C<to> argument.
1243 Returns true on success and false on failure.
1247 sub __write_custom_module_index {
1249 my $conf = $self->configure_object;
1252 my ($verbose, $path, $to);
1254 verbose => { default => $conf->get_conf('verbose'),
1255 store => \$verbose },
1256 path => { required => 1, allow => DIR_EXISTS, store => \$path },
1257 to => { store => \$to },
1260 check( $tmpl, \%hash ) or return;
1262 ### no explicit to? then we'll use our default
1263 $to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') );
1267 File::Find::find( sub {
1268 ### let's see if A::E can even parse it
1270 local $Archive::Extract::WARN = 0;
1271 local $Archive::Extract::WARN = 0;
1272 Archive::Extract->new( archive => $File::Find::name )
1275 ### it's a type A::E recognize, so we can add it
1276 $ae->type or return;
1278 ### neither $_ nor $File::Find::name have the chunk of the path in
1279 ### it starting $path -- it's either only the filename, or the full
1280 ### path, so we have to strip it ourselves
1281 ### make sure to remove the leading slash as well.
1282 my $copy = $File::Find::name;
1283 my $re = quotemeta($path);
1284 $copy =~ s|^$re[\\/]?||i;
1290 ### does the dir exist? if not, create it.
1291 { my $dir = dirname( $to );
1292 unless( IS_DIR->( $dir ) ) {
1293 $self->_mkdir( dir => $dir ) or return
1297 ### create the index file
1298 my $fh = OPEN_FILE->( $to => '>' ) or return;
1300 print $fh "$_\n" for @files;
1303 msg(loc("Successfully written index file to '%1'", $to), $verbose);
1309 =head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] )
1311 Creates entries in the module tree based upon the files as returned
1312 by C<__list_custom_module_sources>.
1314 Returns true on success, false on failure.
1318 ### use $auth_obj as a persistant version, so we don't have to recreate
1319 ### modules all the time
1322 sub __create_custom_module_entries {
1324 my $conf = $self->configure_object;
1329 verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
1332 check( $tmpl, \%hash ) or return undef;
1334 my %files = $self->__list_custom_module_sources;
1336 while( my($file,$name) = each %files ) {
1338 msg(loc("Adding packages from custom source '%1'", $name), $verbose);
1340 my $fh = OPEN_FILE->( $file ) or next;
1342 while( local $_ = <$fh> ) {
1347 ### join on / -- it's a URI after all!
1348 my $parse = join '/', $name, $_;
1350 ### try to make a module object out of it
1351 my $mod = $self->parse_module( module => $parse ) or (
1352 error(loc("Could not parse '%1'", $_)),
1356 ### mark this object with a custom author
1358 my $id = CUSTOM_AUTHOR_ID;
1360 ### if the object is being created for the first time,
1361 ### make sure there's an entry in the author tree as
1362 ### well, so we can search on the CPAN ID
1363 $self->author_tree->{ $id } =
1364 CPANPLUS::Module::Author::Fake->new( cpanid => $id );
1367 $mod->author( $auth_obj );
1369 ### and now add it to the modlue tree -- this MAY
1370 ### override things of course
1371 if( my $old_mod = $self->module_tree( $mod->module ) ) {
1373 ### On VMS use the old module name to get the real case
1374 $mod->module( $old_mod->module ) if ON_VMS;
1376 msg(loc("About to overwrite module tree entry for '%1' with '%2'",
1377 $mod->module, $mod->package), $verbose);
1380 ### mark where it came from
1381 $mod->description( loc("Custom source from '%1'",$name) );
1383 ### store it in the module tree
1384 $self->module_tree->{ $mod->module } = $mod;