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;
27 CPANPLUS::Internals::Source
31 ### lazy load author/module trees ###
38 CPANPLUS::Internals::Source controls the updating of source files and
39 the parsing of them into usable module/author trees to be used by
42 Functions exist to check if source files are still C<good to use> as
43 well as update them, and then parse them.
45 The flow looks like this:
47 $cb->_author_tree || $cb->_module_tree
51 $cb->__update_custom_module_sources
52 $cb->__update_custom_module_source
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
60 $cb->__create_custom_module_entries
70 my $recurse; # flag to prevent recursive calls to *_tree functions
72 ### lazy loading of module tree
76 unless ($self->{_modtree} or $recurse++ > 0) {
77 my $uptodate = $self->_check_trees( @_[1..$#_] );
78 $self->_build_trees(uptodate => $uptodate);
82 return $self->{_modtree};
85 ### lazy loading of author tree
89 unless ($self->{_authortree} or $recurse++ > 0) {
90 my $uptodate = $self->_check_trees( @_[1..$#_] );
91 $self->_build_trees(uptodate => $uptodate);
95 return $self->{_authortree};
102 =head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] )
104 Retrieve source files and return a boolean indicating whether or not
105 the source files are up to date.
107 Takes several arguments:
113 A flag to force re-fetching of the source files, even
114 if they are still up to date.
118 The absolute path to the directory holding the source files.
122 A boolean flag indicating whether or not to be verbose.
126 Will get information from the config file by default.
130 ### retrieve source files, and returns a boolean indicating if it's up to date
132 my ($self, %hash) = @_;
133 my $conf = $self->configure_object;
140 path => { default => $conf->get_conf('base'),
143 verbose => { default => $conf->get_conf('verbose'),
146 update_source => { default => 0, store => \$update_source },
149 my $args = check( $tmpl, \%hash ) or return;
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;
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 );
158 my $uptodate = 1; # default return value
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 ),
165 update_source => $update_source,
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
174 $self->__update_custom_module_sources( verbose => $verbose )
175 if $update_source or !$uptodate;
182 =head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] )
184 C<__check_uptodate> checks if a given source file is still up-to-date
185 and if not, or when C<update_source> is true, will re-fetch the source
188 Takes the following arguments:
194 The source file to check.
198 The internal shortcut name for the source file (used for config
203 Flag to force updating of sourcefiles regardless.
207 Boolean to indicate whether to be verbose or not.
211 Returns a boolean value indicating whether the current files are up
216 ### this method checks whether or not the source files we are using are still up to date
217 sub __check_uptodate {
220 my $conf = $self->configure_object;
224 file => { required => 1 },
225 name => { required => 1 },
226 update_source => { default => 0 },
227 verbose => { default => $conf->get_conf('verbose') },
230 my $args = check( $tmpl, \%hash ) or return;
233 unless ( -e $args->{'file'} && (
234 ( stat $args->{'file'} )[9]
235 + $conf->_get_source('update') )
240 if ( $flag or $args->{'update_source'} ) {
242 if ( $self->_update_source( name => $args->{'name'} ) ) {
243 return 0; # return 0 so 'uptodate' will be set to 0, meaning no
244 # use of previously stored hashrefs!
246 msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} );
257 =head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] )
259 This method does the actual fetching of source files.
261 It takes the following arguments:
267 The internal shortcut name for the source file (used for config
272 The full path where to write the files.
276 Boolean to indicate whether to be verbose or not.
280 Returns a boolean to indicate success.
284 ### this sub fetches new source files ###
288 my $conf = $self->configure_object;
292 name => { required => 1 },
293 path => { default => $conf->get_conf('base') },
294 verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
297 my $args = check( $tmpl, \%hash ) or return;
300 my $path = $args->{path};
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;
306 msg( loc("Updating source file '%1'", $file), $verbose );
308 my $fake = CPANPLUS::Module::Fake->new(
309 module => $args->{'name'},
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(
325 error( loc("Couldn't fetch '%1'", $file) );
329 $self->_update_timestamp( file => File::Spec->catfile($path, $file) );
337 =head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] )
339 This method rebuilds the author- and module-trees from source.
341 It takes the following arguments:
347 Indicates whether any on disk caches are still ok to use.
351 The absolute path to the directory holding the source files.
355 A boolean flag indicating whether or not to be verbose.
359 A boolean flag indicating whether or not it is ok to use previously
360 stored trees. Defaults to true.
364 Returns a boolean indicating success.
368 ### (re)build the trees ###
370 my ($self, %hash) = @_;
371 my $conf = $self->configure_object;
373 my($path,$uptodate,$use_stored);
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 },
381 my $args = check( $tmpl, \%hash ) or return undef;
383 ### retrieve the stored source files ###
384 my $stored = $self->__retrieve_source(
386 uptodate => $uptodate && $use_stored,
387 verbose => $args->{'verbose'},
390 ### build the trees ###
391 $self->{_authortree} = $stored->{_authortree} ||
392 $self->__create_author_tree(
393 uptodate => $uptodate,
395 verbose => $args->{verbose},
397 $self->{_modtree} = $stored->{_modtree} ||
398 $self->_create_mod_tree(
399 uptodate => $uptodate,
401 verbose => $args->{verbose},
404 ### return if we weren't able to build the trees ###
405 return unless $self->{_modtree} && $self->{_authortree};
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"));
413 ### add custom sources here
414 $self->__create_custom_module_entries( verbose => $args->{verbose} )
415 or error(loc("Could not create custom module entries"));
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;
423 ### still necessary? can only run one instance now ###
424 ### will probably stay that way --kane
425 # my $id = $self->_store_id( $self );
427 # unless ( $id == $self->_id ) {
428 # error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) );
436 =head2 $cb->__retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL])
438 This method retrieves a I<storable>d tree identified by C<$name>.
440 It takes the following arguments:
446 The internal name for the source file to retrieve.
450 A flag indicating whether the file-cache is up-to-date or not.
454 The absolute path to the directory holding the source files.
458 A boolean flag indicating whether or not to be verbose.
462 Will get information from the config file by default.
464 Returns a tree on success, false on failure.
468 sub __retrieve_source {
471 my $conf = $self->configure_object;
474 path => { default => $conf->get_conf('base') },
475 verbose => { default => $conf->get_conf('verbose') },
476 uptodate => { default => 0 },
479 my $args = check( $tmpl, \%hash ) or return;
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');
485 return unless $storable;
487 ### $stored is the name of the frozen data structure ###
488 my $stored = $self->__storable_file( $args->{path} );
490 if ($storable && -e $stored && -s _ && $args->{'uptodate'}) {
491 msg( loc("Retrieving %1", $stored), $args->{'verbose'} );
493 my $href = Storable::retrieve($stored);
502 =head2 $cb->_save_source([verbose => BOOL, path => $path])
504 This method saves all the parsed trees in I<storable>d format if
505 C<Storable> is available.
507 It takes the following arguments:
513 The absolute path to the directory holding the source files.
517 A boolean flag indicating whether or not to be verbose.
521 Will get information from the config file by default.
523 Returns true on success, false on failure.
530 my $conf = $self->configure_object;
534 path => { default => $conf->get_conf('base'), allow => DIR_EXISTS },
535 verbose => { default => $conf->get_conf('verbose') },
536 force => { default => 1 },
539 my $args = check( $tmpl, \%hash ) or return;
541 my $aref = [qw[_modtree _authortree]];
543 ### check if we can retrieve a frozen data structure with storable ###
545 $storable = can_load( modules => {'Storable' => '0.0'} )
546 if $conf->get_conf('storable');
547 return unless $storable;
550 foreach my $key ( @$aref ) {
551 next unless ref( $self->{$key} );
552 $to_write->{$key} = $self->{$key};
555 return unless keys %$to_write;
557 ### $stored is the name of the frozen data structure ###
558 my $stored = $self->__storable_file( $args->{path} );
560 if (-e $stored && not -w $stored) {
561 msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} );
565 msg( loc("Writing compiled source information to disk. This might take a little while."),
566 $args->{'verbose'} );
569 unless( Storable::nstore( $to_write, $stored ) ) {
570 error( loc("could not store %1!", $stored) );
574 return $flag ? 0 : 1;
577 sub __storable_file {
579 my $conf = $self->configure_object;
580 my $path = shift or return;
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'} )
587 return unless $storable;
589 ### $stored is the name of the frozen data structure ###
590 ### changed to use File::Spec->catfile -jmb
591 my $stored = File::Spec->rel2abs(
594 $conf->_get_source('stored') #file
596 $Storable::VERSION #the version of storable
597 . '.stored' #append a suffix
606 =head2 $cb->__create_author_tree([path => $path, uptodate => BOOL, verbose => BOOL])
608 This method opens a source files and parses its contents into a
609 searchable author-tree or restores a file-cached version of a
610 previous parse, if the sources are uptodate and the file-cache exists.
612 It takes the following arguments:
618 A flag indicating whether the file-cache is uptodate or not.
622 The absolute path to the directory holding the source files.
626 A boolean flag indicating whether or not to be verbose.
630 Will get information from the config file by default.
632 Returns a tree on success, false on failure.
636 sub __create_author_tree {
639 my $conf = $self->configure_object;
643 path => { default => $conf->get_conf('base') },
644 verbose => { default => $conf->get_conf('verbose') },
645 uptodate => { default => 0 },
648 my $args = check( $tmpl, \%hash ) or return;
650 my $file = File::Spec->catfile(
652 $conf->_get_source('auth')
655 msg(loc("Rebuilding author tree, this might take a while"),
658 ### extract the file ###
659 my $ae = Archive::Extract->new( archive => $file ) or return;
660 my $out = STRIP_GZ_SUFFIX->($file);
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;
667 my $cont = $self->_get_file_contents( file => $out ) or return;
669 ### don't need it anymore ###
672 for ( split /\n/, $cont ) {
673 my($id, $name, $email) = m/^alias \s+
675 "\s* ([^\"\<]+?) \s* <(.+)> \s*"
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
688 } #__create_author_tree
692 =head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL])
694 This method opens a source files and parses its contents into a
695 searchable module-tree or restores a file-cached version of a
696 previous parse, if the sources are uptodate and the file-cache exists.
698 It takes the following arguments:
704 A flag indicating whether the file-cache is up-to-date or not.
708 The absolute path to the directory holding the source files.
712 A boolean flag indicating whether or not to be verbose.
716 Will get information from the config file by default.
718 Returns a tree on success, false on failure.
722 ### this builds a hash reference with the structure of the cpan module tree ###
723 sub _create_mod_tree {
726 my $conf = $self->configure_object;
730 path => { default => $conf->get_conf('base') },
731 verbose => { default => $conf->get_conf('verbose') },
732 uptodate => { default => 0 },
735 my $args = check( $tmpl, \%hash ) or return undef;
736 my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod'));
738 msg(loc("Rebuilding module tree, this might take a while"),
742 my $dslip_tree = $self->__create_dslip_tree( %$args );
744 ### extract the file ###
745 my $ae = Archive::Extract->new( archive => $file ) or return;
746 my $out = STRIP_GZ_SUFFIX->($file);
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;
753 my $cont = $self->_get_file_contents( file => $out ) or return;
755 ### don't need it anymore ###
761 for ( split /\n/, $cont ) {
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*$|;
768 ### skip empty lines ###
772 my @data = split /\s+/;
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] =~
780 ([A-Z\d-]+) (?:/[\S]+)?/
784 ### remove file name from the path
785 $data[2] =~ s|/[^/]+$||;
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] ) );
795 ### adding the dslip info
796 ### probably can use some optimization
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}
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
812 path => File::Spec::Unix->catfile(
813 $conf->_get_mirror('base'),
815 ), # extended path on the cpan mirror,
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'},
823 _id => $self->_id, # id of this internals object
834 =head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL])
836 This method opens a source files and parses its contents into a
837 searchable dslip-tree or restores a file-cached version of a
838 previous parse, if the sources are uptodate and the file-cache exists.
840 It takes the following arguments:
846 A flag indicating whether the file-cache is uptodate or not.
850 The absolute path to the directory holding the source files.
854 A boolean flag indicating whether or not to be verbose.
858 Will get information from the config file by default.
860 Returns a tree on success, false on failure.
864 sub __create_dslip_tree {
867 my $conf = $self->configure_object;
870 path => { default => $conf->get_conf('base') },
871 verbose => { default => $conf->get_conf('verbose') },
872 uptodate => { default => 0 },
875 my $args = check( $tmpl, \%hash ) or return;
877 ### get the file name of the source ###
878 my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip'));
880 ### extract the file ###
881 my $ae = Archive::Extract->new( archive => $file ) or return;
882 my $out = STRIP_GZ_SUFFIX->($file);
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;
889 my $in = $self->_get_file_contents( file => $out ) or return;
891 ### don't need it anymore ###
895 ### get rid of the comments and the code ###
896 ### need a smarter parser, some people have this in their dslip info:
904 # 'Implements Linear Threshold Units',
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!",
910 ### also, older versions say:
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
917 my ($ds_one, $ds_two) = ($in =~ m|.+}\s+
918 (\$(?:CPAN::Modulelist::)?cols.*?)
919 (\$(?:CPAN::Modulelist::)?data.*)
922 ### eval them into existence ###
923 ### still not too fond of this solution - kane ###
925 { #local $@; can't use this, it's buggy -kane
927 $cols = eval $ds_one;
928 error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
930 $data = eval $ds_two;
931 error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
936 my $primary = "modid";
938 ### this comes from CPAN::Modulelist
939 ### which is in 03modlist.data.gz
943 $tree->{$hash{$primary}} = \%hash;
948 } #__create_dslip_tree
952 =head2 $cb->_dslip_defs ()
954 This function returns the definition structure (ARRAYREF) of the
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
963 ### right now, this is just used to look up dslip info from a module
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'),
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'),
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++'),
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'),
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)'),
1021 =head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] );
1023 Adds a custom source index and updates it based on the provided URI.
1025 Returns the full path to the index file on success or false on failure.
1029 sub _add_custom_module_source {
1031 my $conf = $self->configure_object;
1036 verbose => { default => $conf->get_conf('verbose'),
1037 store => \$verbose },
1038 uri => { required => 1, store => \$uri }
1041 check( $tmpl, \%hash ) or return;
1043 my $index = File::Spec->catfile(
1044 $conf->get_conf('base'),
1045 $conf->_get_build('custom_sources'),
1046 $self->_uri_encode( uri => $uri ),
1049 ### already have it.
1050 if( IS_FILE->( $index ) ) {
1051 msg(loc("Source '%1' already added", $uri));
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
1063 my $fh = OPEN_FILE->( $index => '>' ) or do {
1064 error(loc("Could not write index file for '%1'", $uri));
1068 ### basically we 'touched' it.
1071 $self->__update_custom_module_source(
1074 verbose => $verbose,
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;
1085 =head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] );
1087 Removes a custom index file based on the URI provided.
1089 Returns the full path to the index file on success or false on failure.
1093 sub _remove_custom_module_source {
1095 my $conf = $self->configure_object;
1100 verbose => { default => $conf->get_conf('verbose'),
1101 store => \$verbose },
1102 uri => { required => 1, store => \$uri }
1105 check( $tmpl, \%hash ) or return;
1107 ### use uri => local, instead of the other way around
1108 my %files = reverse $self->__list_custom_module_sources;
1110 ### On VMS the case of key to %files can be either exact or lower case
1111 ### XXX abstract this lookup out? --kane
1112 my $file = $files{ $uri };
1113 $file = $files{ lc $uri } if !defined($file) && ON_VMS;
1115 unless (defined $file) {
1116 error(loc("No such custom source '%1'", $uri));
1120 1 while unlink $file;
1122 if( IS_FILE->( $file ) ) {
1123 error(loc("Could not remove index file '%1' for custom source '%2'",
1128 msg(loc("Successfully removed index file for '%1'", $uri), $verbose);
1133 =head2 %files = $cb->__list_custom_module_sources
1135 This method scans the 'custom-sources' directory in your base directory
1136 for additional sources to include in your module tree.
1138 Returns a list of key value pairs as follows:
1140 /full/path/to/source/file%3Fencoded => http://decoded/mirror/path
1144 sub __list_custom_module_sources {
1146 my $conf = $self->configure_object;
1148 my $dir = File::Spec->catdir(
1149 $conf->get_conf('base'),
1150 $conf->_get_build('custom_sources'),
1153 unless( IS_DIR->( $dir ) ) {
1154 msg(loc("No '%1' dir, skipping custom sources", $dir));
1158 ### unencode the files
1159 ### skip ones starting with # though
1162 my $dec = $self->_uri_decode( uri => $_ );
1163 File::Spec->catfile( $dir, $org ) => $dec
1164 } grep { $_ !~ /^#/ } READ_DIR->( $dir );
1169 =head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] );
1171 Attempts to update all the index files to your custom module sources.
1173 If the index is missing, and it's a C<file://> uri, it will generate
1174 a new local index for you.
1176 Return true on success, false on failure.
1180 sub __update_custom_module_sources {
1182 my $conf = $self->configure_object;
1187 verbose => { default => $conf->get_conf('verbose'),
1188 store => \$verbose }
1191 check( $tmpl, \%hash ) or return;
1193 my %files = $self->__list_custom_module_sources;
1195 ### uptodate check has been done a few levels up.
1197 while( my($local,$remote) = each %files ) {
1199 $self->__update_custom_module_source(
1202 verbose => $verbose,
1203 ) or ( $fail++, next );
1206 error(loc("Failed updating one or more remote sources files")) if $fail;
1212 =head2 $ok = $cb->__update_custom_module_source
1214 Attempts to update all the index files to your custom module sources.
1216 If the index is missing, and it's a C<file://> uri, it will generate
1217 a new local index for you.
1219 Return true on success, false on failure.
1223 sub __update_custom_module_source {
1225 my $conf = $self->configure_object;
1228 my($verbose,$local,$remote);
1230 verbose => { default => $conf->get_conf('verbose'),
1231 store => \$verbose },
1232 local => { store => \$local, allow => FILE_EXISTS },
1233 remote => { required => 1, store => \$remote },
1236 check( $tmpl, \%hash ) or return;
1238 msg( loc("Updating sources from '%1'", $remote), $verbose);
1240 ### if you didn't provide a local file, we'll look in your custom
1241 ### dir to find the local encoded version for you
1243 ### find all files we know of
1244 my %files = reverse $self->__list_custom_module_sources or do {
1245 error(loc("No custom modules sources defined -- need '%1' argument",
1250 ### On VMS the case of key to %files can be either exact or lower case
1251 ### XXX abstract this lookup out? --kane
1252 my $file = $files{ $remote };
1253 $file = $files{ lc $remote } if !defined ($file) && ON_VMS;
1255 ### return the local file we're supposed to use
1257 error(loc("Remote source '%1' unknown -- needs '%2' argument",
1263 my $uri = join '/', $remote, $conf->_get_source('custom_index');
1264 my $ff = File::Fetch->new( uri => $uri );
1266 ### tempdir doesn't clean up by default, as opposed to tempfile()
1267 ### so add it explicitly.
1268 my $dir = tempdir( CLEANUP => 1 );
1270 my $res = do { local $File::Fetch::WARN = 0;
1271 local $File::Fetch::WARN = 0;
1272 $ff->fetch( to => $dir );
1275 ### couldn't get the file
1278 ### it's not a local scheme, so can't auto index
1279 unless( $ff->scheme eq 'file' ) {
1280 error(loc("Could not update sources from '%1': %2",
1281 $remote, $ff->error ));
1284 ### it's a local uri, we can index it ourselves
1286 msg(loc("No index file found at '%1', generating one",
1287 $ff->uri), $verbose );
1289 ### ON VMS, if you are working with a UNIX file specification,
1290 ### you need currently use the UNIX variants of the File::Spec.
1292 my $file_class = 'File::Spec';
1293 $file_class .= '::Unix' if ON_VMS;
1294 $file_class->catdir( File::Spec::Unix->splitdir( $ff->path ) );
1297 $self->__write_custom_module_index(
1300 verbose => $verbose,
1303 ### XXX don't write that here, __write_custom_module_index
1304 ### already prints this out
1305 #msg(loc("Index file written to '%1'", $to), $verbose);
1308 ### copy it to the real spot and update it's timestamp
1310 $self->_move( file => $res, to => $local ) or return;
1311 $self->_update_timestamp( file => $local );
1313 msg(loc("Index file saved to '%1'", $local), $verbose);
1319 =head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] )
1321 Scans the C<path> you provided for packages and writes an index with all
1322 the available packages to C<$path/packages.txt>. If you'd like the index
1323 to be written to a different file, provide the C<to> argument.
1325 Returns true on success and false on failure.
1329 sub __write_custom_module_index {
1331 my $conf = $self->configure_object;
1334 my ($verbose, $path, $to);
1336 verbose => { default => $conf->get_conf('verbose'),
1337 store => \$verbose },
1338 path => { required => 1, allow => DIR_EXISTS, store => \$path },
1339 to => { store => \$to },
1342 check( $tmpl, \%hash ) or return;
1344 ### no explicit to? then we'll use our default
1345 $to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') );
1349 File::Find::find( sub {
1350 ### let's see if A::E can even parse it
1352 local $Archive::Extract::WARN = 0;
1353 local $Archive::Extract::WARN = 0;
1354 Archive::Extract->new( archive => $File::Find::name )
1357 ### it's a type A::E recognize, so we can add it
1358 $ae->type or return;
1360 ### neither $_ nor $File::Find::name have the chunk of the path in
1361 ### it starting $path -- it's either only the filename, or the full
1362 ### path, so we have to strip it ourselves
1363 ### make sure to remove the leading slash as well.
1364 my $copy = $File::Find::name;
1365 my $re = quotemeta($path);
1366 $copy =~ s|^$re[\\/]?||i;
1372 ### does the dir exist? if not, create it.
1373 { my $dir = dirname( $to );
1374 unless( IS_DIR->( $dir ) ) {
1375 $self->_mkdir( dir => $dir ) or return
1379 ### create the index file
1380 my $fh = OPEN_FILE->( $to => '>' ) or return;
1382 print $fh "$_\n" for @files;
1385 msg(loc("Successfully written index file to '%1'", $to), $verbose);
1391 =head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] )
1393 Creates entries in the module tree based upon the files as returned
1394 by C<__list_custom_module_sources>.
1396 Returns true on success, false on failure.
1400 ### use $auth_obj as a persistant version, so we don't have to recreate
1401 ### modules all the time
1404 sub __create_custom_module_entries {
1406 my $conf = $self->configure_object;
1411 verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
1414 check( $tmpl, \%hash ) or return undef;
1416 my %files = $self->__list_custom_module_sources;
1418 while( my($file,$name) = each %files ) {
1420 msg(loc("Adding packages from custom source '%1'", $name), $verbose);
1422 my $fh = OPEN_FILE->( $file ) or next;
1429 ### join on / -- it's a URI after all!
1430 my $parse = join '/', $name, $_;
1432 ### try to make a module object out of it
1433 my $mod = $self->parse_module( module => $parse ) or (
1434 error(loc("Could not parse '%1'", $_)),
1438 ### mark this object with a custom author
1440 my $id = CUSTOM_AUTHOR_ID;
1442 ### if the object is being created for the first time,
1443 ### make sure there's an entry in the author tree as
1444 ### well, so we can search on the CPAN ID
1445 $self->author_tree->{ $id } =
1446 CPANPLUS::Module::Author::Fake->new( cpanid => $id );
1449 $mod->author( $auth_obj );
1451 ### and now add it to the modlue tree -- this MAY
1452 ### override things of course
1453 if( my $old_mod = $self->module_tree( $mod->module ) ) {
1455 ### On VMS use the old module name to get the real case
1456 $mod->module( $old_mod->module ) if ON_VMS;
1458 msg(loc("About to overwrite module tree entry for '%1' with '%2'",
1459 $mod->module, $mod->package), $verbose);
1462 ### mark where it came from
1463 $mod->description( loc("Custom source from '%1'",$name) );
1465 ### store it in the module tree
1466 $self->module_tree->{ $mod->module } = $mod;
1476 # c-indentation-style: bsd
1478 # indent-tabs-mode: nil
1480 # vim: expandtab shiftwidth=4: