File Coverage

lib/CPANPLUS/Internals/Source/Memory.pm
Criterion Covered Total %
statement 147 151 97.3
branch 29 50 58.0
condition 18 21 85.7
subroutine 28 28 100.0
pod n/a
total 222 250 88.8


line stmt bran cond sub pod time code
1             package CPANPLUS::Internals::Source::Memory;
2              
3 14     14   120912 use base 'CPANPLUS::Internals::Source';
  14         67  
  14         8663  
4              
5 14     14   135 use strict;
  14         50  
  14         392  
6              
7 14     14   99 use CPANPLUS::Error;
  14         37  
  14         899  
8 14     14   95 use CPANPLUS::Module;
  14         58  
  14         359  
9 14     14   101 use CPANPLUS::Module::Fake;
  14         41  
  14         285  
10 14     14   83 use CPANPLUS::Module::Author;
  14         59  
  14         300  
11 14     14   83 use CPANPLUS::Internals::Constants;
  14         36  
  14         5496  
12              
13 14     14   139 use File::Fetch;
  14         40  
  14         341  
14 14     14   83 use Archive::Extract;
  14         51  
  14         475  
15              
16 14     14   97 use IPC::Cmd qw[can_run];
  14         35  
  14         747  
17 14     14   99 use File::Temp qw[tempdir];
  14         51  
  14         731  
18 14     14   123 use File::Basename qw[dirname];
  14         41  
  14         677  
19 14     14   110 use Params::Check qw[allow check];
  14         35  
  14         778  
20 14     14   101 use Module::Load::Conditional qw[can_load];
  14         54  
  14         795  
21 14     14   117 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  14         58  
  14         124  
22              
23 14     14   3910 use vars qw[$VERSION];
  14         47  
  14         11575  
24             $VERSION = "0.9914";
25              
26             $Params::Check::VERBOSE = 1;
27              
28             =head1 NAME
29              
30             CPANPLUS::Internals::Source::Memory - In memory implementation
31              
32             =cut
33              
34             ### flag to show if init_trees got its' data from storable. This allows
35             ### us to not write an existing stored file back to disk
36             { my $from_storable;
37              
38             sub _init_trees {
39 32     32   188 my $self = shift;
40 32         277 my $conf = $self->configure_object;
41 32         266 my %hash = @_;
42              
43 32         194 my($path,$uptodate,$verbose,$use_stored);
44 32         395 my $tmpl = {
45             path => { default => $conf->get_conf('base'), store => \$path },
46             verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
47             uptodate => { required => 1, store => \$uptodate },
48             use_stored => { default => 1, store => \$use_stored },
49             };
50              
51 32 50       397 check( $tmpl, \%hash ) or return;
52              
53             ### retrieve the stored source files ###
54 32   100     6937 my $stored = $self->__memory_retrieve_source(
55             path => $path,
56             uptodate => $uptodate && $use_stored,
57             verbose => $verbose,
58             ) || {};
59              
60             ### we got this from storable if $stored has keys..
61 32 100       214 $from_storable = keys %$stored ? 1 : 0;
62              
63             ### set up the trees
64 32   100     700 $self->_atree( $stored->{_atree} || {} );
65 32   100     380 $self->_mtree( $stored->{_mtree} || {} );
66              
67 32         290 return 1;
68             }
69              
70 32     32   196 sub _standard_trees_completed { return $from_storable }
71 32     32   194 sub _custom_trees_completed { return $from_storable }
72              
73             sub _finalize_trees {
74 33     33   145 my $self = shift;
75 33         299 my $conf = $self->configure_object;
76 33         292 my %hash = @_;
77              
78 33         137 my($path,$uptodate,$verbose);
79 33         280 my $tmpl = {
80             path => { default => $conf->get_conf('base'), store => \$path },
81             verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
82             uptodate => { required => 1, store => \$uptodate },
83             };
84              
85 33         163 { local $Params::Check::ALLOW_UNKNOWN = 1;
  33         316  
86 33 50       249 check( $tmpl, \%hash ) or return;
87             }
88              
89             ### write the stored files to disk, so we can keep using them
90             ### from now on, till they become invalid
91             ### write them if the original sources weren't uptodate, or
92             ### we didn't just load storable files
93 33 100 100     6019 $self->__memory_save_source() if !$uptodate or not $from_storable;
94              
95 33         277 return 1;
96             }
97              
98             ### saves current memory state
99             sub _save_state {
100 1     1   3 my $self = shift;
101 1         9 return $self->_finalize_trees( @_, uptodate => 0 );
102             }
103             }
104              
105             sub _add_author_object {
106 124     124   348 my $self = shift;
107 124         992 my %hash = @_;
108              
109 124         328 my $class;
110             my $tmpl = {
111             class => { default => 'CPANPLUS::Module::Author', store => \$class },
112 124         782 map { $_ => { required => 1 } }
  372         1687  
113             qw[ author cpanid email ]
114             };
115              
116 124         341 my $href = do {
117 124         600 local $Params::Check::NO_DUPLICATES = 1;
118 124 50       547 check( $tmpl, \%hash ) or return;
119             };
120              
121 124         19992 my $obj = $class->new( %$href, _id => $self->_id );
122              
123 124 50       985 $self->author_tree->{ $href->{'cpanid'} } = $obj or return;
124              
125 124         1060 return $obj;
126             }
127              
128             {
129             my $tmpl = {
130             class => { default => 'CPANPLUS::Module' },
131             map { $_ => { required => 1 } } qw[
132             module version path comment author package description dslip mtime
133             ],
134             };
135              
136             sub _add_module_object {
137 310     310   743 my $self = shift;
138 310         3275 my %hash = @_;
139              
140 310         633 my $href = do {
141 310         891 local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
142 310 50       1333 check( $tmpl, \%hash ) or return;
143             };
144 310         82606 my $class = delete $href->{class};
145              
146 310         3080 my $obj = $class->new( %$href, _id => $self->_id );
147              
148             ### Every module get's stored as a module object ###
149 310 50       1766 $self->module_tree->{ $href->{module} } = $obj or return;
150              
151 310         2427 return $obj;
152             }
153             }
154              
155             { my %map = (
156             _source_search_module_tree => [ module_tree => 'CPANPLUS::Module' ],
157             _source_search_author_tree => [ author_tree => 'CPANPLUS::Module::Author' ],
158             );
159              
160             while( my($sub, $aref) = each %map ) {
161 14     14   192 no strict 'refs';
  14         56  
  14         14010  
162              
163             my($meth, $class) = @$aref;
164              
165             *$sub = sub {
166 84     84   241 my $self = shift;
167 84         319 my $conf = $self->configure_object;
168 84         430 my %hash = @_;
169              
170 84         223 my($authors,$list,$verbose,$type);
171 84         1021 my $tmpl = {
172             data => { default => [],
173             strict_type=> 1, store => \$authors },
174             allow => { required => 1, default => [ ], strict_type => 1,
175             store => \$list },
176             verbose => { default => $conf->get_conf('verbose'),
177             store => \$verbose },
178             type => { required => 1, allow => [$class->accessors()],
179             store => \$type },
180             };
181              
182 84 50       519 my $args = check( $tmpl, \%hash ) or return;
183              
184 84         17565 my @rv;
185 84         200 for my $obj ( values %{ $self->$meth } ) {
  84         488  
186             #push @rv, $auth if check(
187             # { $type => { allow => $list } },
188             # { $type => $auth->$type }
189             # );
190 822 100       15834 push @rv, $obj if allow( $obj->$type() => $list );
191             }
192              
193 84         2232 return @rv;
194             }
195             }
196             }
197              
198             =pod
199              
200             =head2 $cb->__memory_retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL])
201              
202             This method retrieves a Id tree identified by C<$name>.
203              
204             It takes the following arguments:
205              
206             =over 4
207              
208             =item name
209              
210             The internal name for the source file to retrieve.
211              
212             =item uptodate
213              
214             A flag indicating whether the file-cache is up-to-date or not.
215              
216             =item path
217              
218             The absolute path to the directory holding the source files.
219              
220             =item verbose
221              
222             A boolean flag indicating whether or not to be verbose.
223              
224             =back
225              
226             Will get information from the config file by default.
227              
228             Returns a tree on success, false on failure.
229              
230             =cut
231              
232             sub __memory_retrieve_source {
233 32     32   157 my $self = shift;
234 32         209 my %hash = @_;
235 32         219 my $conf = $self->configure_object;
236              
237 32         322 my $tmpl = {
238             path => { default => $conf->get_conf('base') },
239             verbose => { default => $conf->get_conf('verbose') },
240             uptodate => { default => 0 },
241             };
242              
243 32 50       261 my $args = check( $tmpl, \%hash ) or return;
244              
245             ### check if we can retrieve a frozen data structure with storable ###
246 32 50       4227 my $storable = can_load( modules => {'Storable' => '0.0'} )
247             if $conf->get_conf('storable');
248              
249 32 50       246133 return unless $storable;
250              
251             ### $stored is the name of the frozen data structure ###
252 32         565 my $stored = $self->__memory_storable_file( $args->{path} );
253              
254 32 100 66     1696 if ($storable && -e $stored && -s _ && $args->{'uptodate'}) {
      66        
      100        
255 1         7 msg( loc("Retrieving %1", $stored), $args->{'verbose'} );
256              
257 1         19 my $href = Storable::retrieve($stored);
258 1         253 return $href;
259             } else {
260 31         558 return;
261             }
262             }
263              
264             =pod
265              
266             =head2 $cb->__memory_save_source([verbose => BOOL, path => $path])
267              
268             This method saves all the parsed trees in Id format if
269             C is available.
270              
271             It takes the following arguments:
272              
273             =over 4
274              
275             =item path
276              
277             The absolute path to the directory holding the source files.
278              
279             =item verbose
280              
281             A boolean flag indicating whether or not to be verbose.
282              
283             =back
284              
285             Will get information from the config file by default.
286              
287             Returns true on success, false on failure.
288              
289             =cut
290              
291             sub __memory_save_source {
292 32     32   121 my $self = shift;
293 32         139 my %hash = @_;
294 32         161 my $conf = $self->configure_object;
295              
296              
297 32         281 my $tmpl = {
298             path => { default => $conf->get_conf('base'), allow => DIR_EXISTS },
299             verbose => { default => $conf->get_conf('verbose') },
300             force => { default => 1 },
301             };
302              
303 32 50       264 my $args = check( $tmpl, \%hash ) or return;
304              
305 32         2738 my $aref = [qw[_mtree _atree]];
306              
307             ### check if we can retrieve a frozen data structure with storable ###
308 32         114 my $storable;
309 32 50       302 $storable = can_load( modules => {'Storable' => '0.0'} )
310             if $conf->get_conf('storable');
311 32 50       5912 return unless $storable;
312              
313 32         116 my $to_write = {};
314 32         139 foreach my $key ( @$aref ) {
315 64 50       376 next unless ref( $self->$key );
316 64         226 $to_write->{$key} = $self->$key;
317             }
318              
319 32 50       170 return unless keys %$to_write;
320              
321             ### $stored is the name of the frozen data structure ###
322 32         308 my $stored = $self->__memory_storable_file( $args->{path} );
323              
324 32 50 66     1308 if (-e $stored && not -w $stored) {
325 0         0 msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} );
326 0         0 return;
327             }
328              
329             msg( loc("Writing compiled source information to disk. This might take a little while."),
330 32         344 $args->{'verbose'} );
331              
332 32         411 my $flag;
333 32 50       497 unless( Storable::nstore( $to_write, $stored ) ) {
334 0         0 error( loc("could not store %1!", $stored) );
335 0         0 $flag++;
336             }
337              
338 32 50       15797 return $flag ? 0 : 1;
339             }
340              
341             sub __memory_storable_file {
342 64     64   279 my $self = shift;
343 64         311 my $conf = $self->configure_object;
344 64 50       351 my $path = shift or return;
345              
346             ### check if we can retrieve a frozen data structure with storable ###
347 64 50       817 my $storable = $conf->get_conf('storable')
348             ? can_load( modules => {'Storable' => '0.0'} )
349             : 0;
350              
351 64 50       8362 return unless $storable;
352              
353             ### $stored is the name of the frozen data structure ###
354             ### changed to use File::Spec->catfile -jmb
355 64         572 my $stored = File::Spec->rel2abs(
356             File::Spec->catfile(
357             $path, #base dir
358             $conf->_get_source('stored') #file
359             . '.s' .
360             $Storable::VERSION #the version of storable
361             . '.c' .
362             $self->VERSION #the version of CPANPLUS
363             . STORABLE_EXT #append a suffix
364             )
365             );
366              
367 64         703 return $stored;
368             }
369              
370              
371              
372              
373             # Local variables:
374             # c-indentation-style: bsd
375             # c-basic-offset: 4
376             # indent-tabs-mode: nil
377             # End:
378             # vim: expandtab shiftwidth=4:
379              
380             1;