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   118521 use base 'CPANPLUS::Internals::Source';
  14         81  
  14         8968  
4              
5 14     14   122 use strict;
  14         41  
  14         368  
6              
7 14     14   91 use CPANPLUS::Error;
  14         52  
  14         812  
8 14     14   110 use CPANPLUS::Module;
  14         42  
  14         285  
9 14     14   99 use CPANPLUS::Module::Fake;
  14         36  
  14         286  
10 14     14   95 use CPANPLUS::Module::Author;
  14         38  
  14         309  
11 14     14   99 use CPANPLUS::Internals::Constants;
  14         47  
  14         5271  
12              
13 14     14   128 use File::Fetch;
  14         39  
  14         361  
14 14     14   108 use Archive::Extract;
  14         34  
  14         385  
15              
16 14     14   91 use IPC::Cmd qw[can_run];
  14         43  
  14         686  
17 14     14   106 use File::Temp qw[tempdir];
  14         36  
  14         647  
18 14     14   107 use File::Basename qw[dirname];
  14         41  
  14         676  
19 14     14   102 use Params::Check qw[allow check];
  14         37  
  14         807  
20 14     14   110 use Module::Load::Conditional qw[can_load];
  14         42  
  14         730  
21 14     14   96 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  14         30  
  14         99  
22              
23 14     14   3879 use vars qw[$VERSION];
  14         39  
  14         10971  
24             $VERSION = "0.9910";
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   194 my $self = shift;
40 32         252 my $conf = $self->configure_object;
41 32         407 my %hash = @_;
42              
43 32         175 my($path,$uptodate,$verbose,$use_stored);
44 32         363 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       330 check( $tmpl, \%hash ) or return;
52              
53             ### retrieve the stored source files ###
54 32   100     6646 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       249 $from_storable = keys %$stored ? 1 : 0;
62              
63             ### set up the trees
64 32   100     831 $self->_atree( $stored->{_atree} || {} );
65 32   100     460 $self->_mtree( $stored->{_mtree} || {} );
66              
67 32         411 return 1;
68             }
69              
70 32     32   235 sub _standard_trees_completed { return $from_storable }
71 32     32   208 sub _custom_trees_completed { return $from_storable }
72              
73             sub _finalize_trees {
74 33     33   141 my $self = shift;
75 33         290 my $conf = $self->configure_object;
76 33         313 my %hash = @_;
77              
78 33         141 my($path,$uptodate,$verbose);
79 33         315 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         154 { local $Params::Check::ALLOW_UNKNOWN = 1;
  33         328  
86 33 50       263 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     5979 $self->__memory_save_source() if !$uptodate or not $from_storable;
94              
95 33         296 return 1;
96             }
97              
98             ### saves current memory state
99             sub _save_state {
100 1     1   10 my $self = shift;
101 1         5 return $self->_finalize_trees( @_, uptodate => 0 );
102             }
103             }
104              
105             sub _add_author_object {
106 124     124   350 my $self = shift;
107 124         1168 my %hash = @_;
108              
109 124         289 my $class;
110             my $tmpl = {
111             class => { default => 'CPANPLUS::Module::Author', store => \$class },
112 124         760 map { $_ => { required => 1 } }
  372         1620  
113             qw[ author cpanid email ]
114             };
115              
116 124         409 my $href = do {
117 124         530 local $Params::Check::NO_DUPLICATES = 1;
118 124 50       582 check( $tmpl, \%hash ) or return;
119             };
120              
121 124         19280 my $obj = $class->new( %$href, _id => $self->_id );
122              
123 124 50       1034 $self->author_tree->{ $href->{'cpanid'} } = $obj or return;
124              
125 124         920 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   722 my $self = shift;
138 310         3595 my %hash = @_;
139              
140 310         640 my $href = do {
141 310         760 local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
142 310 50       1236 check( $tmpl, \%hash ) or return;
143             };
144 310         79755 my $class = delete $href->{class};
145              
146 310         3216 my $obj = $class->new( %$href, _id => $self->_id );
147              
148             ### Every module get's stored as a module object ###
149 310 50       1831 $self->module_tree->{ $href->{module} } = $obj or return;
150              
151 310         2130 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   121 no strict 'refs';
  14         45  
  14         13188  
162              
163             my($meth, $class) = @$aref;
164              
165             *$sub = sub {
166 84     84   221 my $self = shift;
167 84         301 my $conf = $self->configure_object;
168 84         374 my %hash = @_;
169              
170 84         217 my($authors,$list,$verbose,$type);
171 84         1004 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       420 my $args = check( $tmpl, \%hash ) or return;
183              
184 84         16621 my @rv;
185 84         172 for my $obj ( values %{ $self->$meth } ) {
  84         506  
186             #push @rv, $auth if check(
187             # { $type => { allow => $list } },
188             # { $type => $auth->$type }
189             # );
190 822 100       15001 push @rv, $obj if allow( $obj->$type() => $list );
191             }
192              
193 84         2135 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   190 my $self = shift;
234 32         273 my %hash = @_;
235 32         222 my $conf = $self->configure_object;
236              
237 32         337 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       306 my $args = check( $tmpl, \%hash ) or return;
244              
245             ### check if we can retrieve a frozen data structure with storable ###
246 32 50       4090 my $storable = can_load( modules => {'Storable' => '0.0'} )
247             if $conf->get_conf('storable');
248              
249 32 50       237256 return unless $storable;
250              
251             ### $stored is the name of the frozen data structure ###
252 32         633 my $stored = $self->__memory_storable_file( $args->{path} );
253              
254 32 100 66     1921 if ($storable && -e $stored && -s _ && $args->{'uptodate'}) {
      66        
      100        
255 1         8 msg( loc("Retrieving %1", $stored), $args->{'verbose'} );
256              
257 1         20 my $href = Storable::retrieve($stored);
258 1         245 return $href;
259             } else {
260 31         607 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   143 my $self = shift;
293 32         149 my %hash = @_;
294 32         208 my $conf = $self->configure_object;
295              
296              
297 32         301 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       244 my $args = check( $tmpl, \%hash ) or return;
304              
305 32         2665 my $aref = [qw[_mtree _atree]];
306              
307             ### check if we can retrieve a frozen data structure with storable ###
308 32         117 my $storable;
309 32 50       276 $storable = can_load( modules => {'Storable' => '0.0'} )
310             if $conf->get_conf('storable');
311 32 50       6122 return unless $storable;
312              
313 32         131 my $to_write = {};
314 32         145 foreach my $key ( @$aref ) {
315 64 50       449 next unless ref( $self->$key );
316 64         241 $to_write->{$key} = $self->$key;
317             }
318              
319 32 50       203 return unless keys %$to_write;
320              
321             ### $stored is the name of the frozen data structure ###
322 32         381 my $stored = $self->__memory_storable_file( $args->{path} );
323              
324 32 50 66     1517 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         427 $args->{'verbose'} );
331              
332 32         403 my $flag;
333 32 50       596 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       14754 return $flag ? 0 : 1;
339             }
340              
341             sub __memory_storable_file {
342 64     64   298 my $self = shift;
343 64         366 my $conf = $self->configure_object;
344 64 50       430 my $path = shift or return;
345              
346             ### check if we can retrieve a frozen data structure with storable ###
347 64 50       878 my $storable = $conf->get_conf('storable')
348             ? can_load( modules => {'Storable' => '0.0'} )
349             : 0;
350              
351 64 50       8466 return unless $storable;
352              
353             ### $stored is the name of the frozen data structure ###
354             ### changed to use File::Spec->catfile -jmb
355 64         921 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         802 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;