File Coverage

lib/CPANPLUS/Internals/Source.pm
Criterion Covered Total %
statement 215 227 94.7
branch 60 100 60.0
condition 27 44 61.4
subroutine 24 24 100.0
pod n/a
total 326 395 82.5


line stmt bran cond sub pod time code
1             package CPANPLUS::Internals::Source;
2              
3 15     15   236 use strict;
  15         232  
  15         256  
4              
5 15     15   1066 use CPANPLUS::Error;
  15         216  
  15         242  
6 15     15   671 use CPANPLUS::Module;
  15         189  
  15         510  
7 15     15   599 use CPANPLUS::Module::Fake;
  15         942  
  15         509  
8 15     15   296 use CPANPLUS::Module::Author;
  15         185  
  15         269  
9 15     15   273 use CPANPLUS::Internals::Constants;
  15         138  
  15         347  
10              
11 15     15   654 use Archive::Extract;
  15         228  
  15         522  
12              
13 15     15   280 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  15         141  
  15         499  
14 15     15   250 use Params::Check qw[check];
  15         141  
  15         527  
15 15     15   240 use IPC::Cmd qw[can_run];
  15         140  
  15         409  
16 15     15   266 use Module::Load::Conditional qw[can_load];
  15         136  
  15         278  
17              
18             $Params::Check::VERBOSE = 1;
19              
20             =pod
21            
22             =head1 NAME
23            
24             CPANPLUS::Internals::Source
25            
26             =head1 SYNOPSIS
27            
28             ### lazy load author/module trees ###
29            
30             $cb->_author_tree;
31             $cb->_module_tree;
32            
33             =head1 DESCRIPTION
34            
35             CPANPLUS::Internals::Source controls the updating of source files and
36             the parsing of them into usable module/author trees to be used by
37             C<CPANPLUS>.
38            
39             Functions exist to check if source files are still C<good to use> as
40             well as update them, and then parse them.
41            
42             The flow looks like this:
43            
44             $cb->_author_tree || $cb->_module_tree
45             $cb->__check_trees
46             $cb->__check_uptodate
47             $cb->_update_source
48             $cb->_build_trees
49             $cb->__create_author_tree
50             $cb->__retrieve_source
51             $cb->__create_module_tree
52             $cb->__retrieve_source
53             $cb->__create_dslip_tree
54             $cb->__retrieve_source
55             $cb->_save_source
56            
57             $cb->_dslip_defs
58            
59             =head1 METHODS
60            
61             =cut
62              
63             {
64                 my $recurse; # flag to prevent recursive calls to *_tree functions
65              
66             ### lazy loading of module tree
67                 sub _module_tree {
68 16503     16503   207384         my $self = $_[0];
69              
70 16503 100 66     264925         unless ($self->{_modtree} or $recurse++ > 0) {
71 6         606             my $uptodate = $self->_check_trees( @_[1..$#_] );
72 6         728             $self->_build_trees(uptodate => $uptodate);
73                     }
74              
75 16503         196430         $recurse--;
76 16503         277943         return $self->{_modtree};
77                 }
78              
79             ### lazy loading of author tree
80                 sub _author_tree {
81 370     370   5686         my $self = $_[0];
82              
83 370 50 33     5783         unless ($self->{_authortree} or $recurse++ > 0) {
84 0         0             my $uptodate = $self->_check_trees( @_[1..$#_] );
85 0         0             $self->_build_trees(uptodate => $uptodate);
86                     }
87              
88 370         4216         $recurse--;
89 370         6731         return $self->{_authortree};
90                 }
91              
92             }
93              
94             =pod
95            
96             =head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] )
97            
98             Retrieve source files and return a boolean indicating whether or not
99             the source files are up to date.
100            
101             Takes several arguments:
102            
103             =over 4
104            
105             =item update_source
106            
107             A flag to force re-fetching of the source files, even
108             if they are still up to date.
109            
110             =item path
111            
112             The absolute path to the directory holding the source files.
113            
114             =item verbose
115            
116             A boolean flag indicating whether or not to be verbose.
117            
118             =back
119            
120             Will get information from the config file by default.
121            
122             =cut
123              
124             ### retrieve source files, and returns a boolean indicating if it's up to date
125             sub _check_trees {
126 25     25   659     my ($self, %hash) = @_;
127 25         2967     my $conf = $self->configure_object;
128              
129 25         287     my $update_source;
130 25         232     my $verbose;
131 25         337     my $path;
132              
133 25         568     my $tmpl = {
134                     path => { default => $conf->get_conf('base'),
135                                          store => \$path
136                                     },
137                     verbose => { default => $conf->get_conf('verbose'),
138                                          store => \$verbose
139                                     },
140                     update_source => { default => 0, store => \$update_source },
141                 };
142              
143 25 50       958     my $args = check( $tmpl, \%hash ) or return;
144              
145             ### if the user never wants to update their source without explicitly
146             ### telling us, shortcircuit here
147 25 50 33     492     return 1 if $conf->get_conf('no_update') && !$update_source;
148              
149             ### a check to see if our source files are still up to date ###
150 25         1257     msg( loc("Checking if source files are up to date"), $verbose );
151              
152 25         818     my $uptodate = 1; # default return value
153              
154 25         1073     for my $name (qw[auth dslip mod]) {
155 75         2804         for my $file ( $conf->_get_source( $name ) ) {
156 75 100       3784             $self->__check_uptodate(
157                             file => File::Spec->catfile( $args->{path}, $file ),
158                             name => $name,
159                             update_source => $update_source,
160                             verbose => $verbose,
161                         ) or $uptodate = 0;
162                     }
163                 }
164              
165 25         2722     return $uptodate;
166             }
167              
168             =pod
169            
170             =head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] )
171            
172             C<__check_uptodate> checks if a given source file is still up-to-date
173             and if not, or when C<update_source> is true, will re-fetch the source
174             file.
175            
176             Takes the following arguments:
177            
178             =over 4
179            
180             =item file
181            
182             The source file to check.
183            
184             =item name
185            
186             The internal shortcut name for the source file (used for config
187             lookups).
188            
189             =item update_source
190            
191             Flag to force updating of sourcefiles regardless.
192            
193             =item verbose
194            
195             Boolean to indicate whether to be verbose or not.
196            
197             =back
198            
199             Returns a boolean value indicating whether the current files are up
200             to date or not.
201            
202             =cut
203              
204             ### this method checks whether or not the source files we are using are still up to date
205             sub __check_uptodate {
206 75     75   695     my $self = shift;
207 75         1729     my %hash = @_;
208 75         1277     my $conf = $self->configure_object;
209              
210              
211 75         1785     my $tmpl = {
212                     file => { required => 1 },
213                     name => { required => 1 },
214                     update_source => { default => 0 },
215                     verbose => { default => $conf->get_conf('verbose') },
216                 };
217              
218 75 50       1483     my $args = check( $tmpl, \%hash ) or return;
219              
220 75         684     my $flag;
221 75 100 66     6330     unless ( -e $args->{'file'} && (
222                         ( stat $args->{'file'} )[9]
223                         + $conf->_get_source('update') )
224                         > time ) {
225 3         26         $flag = 1;
226                 }
227              
228 75 100 100     2523     if ( $flag or $args->{'update_source'} ) {
229              
230 6 50       181          if ( $self->_update_source( name => $args->{'name'} ) ) {
231 6         1071               return 0; # return 0 so 'uptodate' will be set to 0, meaning no use
232             # of previously stored hashrefs!
233                      } else {
234 0         0               msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} );
235 0         0               return 1;
236                      }
237              
238                 } else {
239 69         1840         return 1;
240                 }
241             }
242              
243             =pod
244            
245             =head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] )
246            
247             This method does the actual fetching of source files.
248            
249             It takes the following arguments:
250            
251             =over 4
252            
253             =item name
254            
255             The internal shortcut name for the source file (used for config
256             lookups).
257            
258             =item path
259            
260             The full path where to write the files.
261            
262             =item verbose
263            
264             Boolean to indicate whether to be verbose or not.
265            
266             =back
267            
268             Returns a boolean to indicate success.
269            
270             =cut
271              
272             ### this sub fetches new source files ###
273             sub _update_source {
274 9     9   204     my $self = shift;
275 9         195     my %hash = @_;
276 9         316     my $conf = $self->configure_object;
277              
278              
279 9         394     my $tmpl = {
280                     name => { required => 1 },
281                     path => { default => $conf->get_conf('base') },
282                     verbose => { default => $conf->get_conf('verbose') },
283                 };
284              
285 9 50       350     my $args = check( $tmpl, \%hash ) or return;
286              
287              
288 9         215     my $path = $args->{path};
289 9         213     my $now = time;
290              
291                 { ### this could use a clean up - Kane
292             ### no worries about the / -> we get it from the _ftp configuration, so
293             ### it's not platform dependant. -kane
294 9         77         my ($dir, $file) = $conf->_get_mirror( $args->{'name'} ) =~ m|(.+/)(.+)$|sg;
  9         282  
295              
296 9         608         msg( loc("Updating source file '%1'", $file), $args->{'verbose'} );
297              
298 9         618         my $fake = CPANPLUS::Module::Fake->new(
299                                     module => $args->{'name'},
300                                     path => $dir,
301                                     package => $file,
302                                     _id => $self->_id,
303                                 );
304              
305             ### can't use $fake->fetch here, since ->parent won't work --
306             ### the sources haven't been saved yet
307 9         753         my $rv = $self->_fetch(
308                                 module => $fake,
309                                 fetchdir => $path,
310                                 force => 1,
311                             );
312              
313              
314 9 50       352         unless ($rv) {
315 0         0             error( loc("Couldn't fetch '%1'", $file) );
316 0         0             return;
317                     }
318              
319             ### `touch` the file, so windoze knows it's new -jmb
320             ### works on *nix too, good fix -Kane
321 9 50       238         utime ( $now, $now, File::Spec->catfile($path, $file) ) or
322                         error( loc("Couldn't touch %1", $file) );
323              
324                 }
325 9         6637     return 1;
326             }
327              
328             =pod
329            
330             =head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] )
331            
332             This method rebuilds the author- and module-trees from source.
333            
334             It takes the following arguments:
335            
336             =over 4
337            
338             =item uptodate
339            
340             Indicates whether any on disk caches are still ok to use.
341            
342             =item path
343            
344             The absolute path to the directory holding the source files.
345            
346             =item verbose
347            
348             A boolean flag indicating whether or not to be verbose.
349            
350             =item use_stored
351            
352             A boolean flag indicating whether or not it is ok to use previously
353             stored trees. Defaults to true.
354            
355             =back
356            
357             Returns a boolean indicating success.
358            
359             =cut
360              
361             ### (re)build the trees ###
362             sub _build_trees {
363 25     25   1033     my ($self, %hash) = @_;
364 25         603     my $conf = $self->configure_object;
365              
366 25         280     my($path,$uptodate,$use_stored);
367 25         627     my $tmpl = {
368                     path => { default => $conf->get_conf('base'), store => \$path },
369                     verbose => { default => $