1 package CPANPLUS::Internals::Source::Memory;
3 use base 'CPANPLUS::Internals::Source';
9 use CPANPLUS::Module::Fake;
10 use CPANPLUS::Module::Author;
11 use CPANPLUS::Internals::Constants;
16 use IPC::Cmd qw[can_run];
17 use File::Temp qw[tempdir];
18 use File::Basename qw[dirname];
19 use Params::Check qw[allow check];
20 use Module::Load::Conditional qw[can_load];
21 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
23 $Params::Check::VERBOSE = 1;
27 CPANPLUS::Internals::Source::Memory - In memory implementation
31 ### flag to show if init_trees got its' data from storable. This allows
32 ### us to not write an existing stored file back to disk
37 my $conf = $self->configure_object;
40 my($path,$uptodate,$verbose,$use_stored);
42 path => { default => $conf->get_conf('base'), store => \$path },
43 verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
44 uptodate => { required => 1, store => \$uptodate },
45 use_stored => { default => 1, store => \$use_stored },
48 check( $tmpl, \%hash ) or return;
50 ### retrieve the stored source files ###
51 my $stored = $self->__memory_retrieve_source(
53 uptodate => $uptodate && $use_stored,
57 ### we got this from storable if $stored has keys..
58 $from_storable = keys %$stored ? 1 : 0;
61 $self->_atree( $stored->{_atree} || {} );
62 $self->_mtree( $stored->{_mtree} || {} );
67 sub _standard_trees_completed { return $from_storable }
68 sub _custom_trees_completed { return $from_storable }
72 my $conf = $self->configure_object;
75 my($path,$uptodate,$verbose);
77 path => { default => $conf->get_conf('base'), store => \$path },
78 verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
79 uptodate => { required => 1, store => \$uptodate },
82 { local $Params::Check::ALLOW_UNKNOWN = 1;
83 check( $tmpl, \%hash ) or return;
86 ### write the stored files to disk, so we can keep using them
87 ### from now on, till they become invalid
88 ### write them if the original sources weren't uptodate, or
89 ### we didn't just load storable files
90 $self->__memory_save_source() if !$uptodate or not $from_storable;
95 ### saves current memory state
98 return $self->_finalize_trees( @_, uptodate => 0 );
102 sub _add_author_object {
108 class => { default => 'CPANPLUS::Module::Author', store => \$class },
109 map { $_ => { required => 1 } }
110 qw[ author cpanid email ]
114 local $Params::Check::NO_DUPLICATES = 1;
115 check( $tmpl, \%hash ) or return;
118 my $obj = $class->new( %$href, _id => $self->_id );
120 $self->author_tree->{ $href->{'cpanid'} } = $obj or return;
125 sub _add_module_object {
131 class => { default => 'CPANPLUS::Module', store => \$class },
132 map { $_ => { required => 1 } }
133 qw[ module version path comment author package description dslip mtime ]
137 local $Params::Check::NO_DUPLICATES = 1;
138 check( $tmpl, \%hash ) or return;
141 my $obj = $class->new( %$href, _id => $self->_id );
143 ### Every module get's stored as a module object ###
144 $self->module_tree->{ $href->{module} } = $obj or return;
150 _source_search_module_tree => [ module_tree => 'CPANPLUS::Module' ],
151 _source_search_author_tree => [ author_tree => 'CPANPLUS::Module::Author' ],
154 while( my($sub, $aref) = each %map ) {
157 my($meth, $class) = @$aref;
161 my $conf = $self->configure_object;
164 my($authors,$list,$verbose,$type);
166 data => { default => [],
167 strict_type=> 1, store => \$authors },
168 allow => { required => 1, default => [ ], strict_type => 1,
170 verbose => { default => $conf->get_conf('verbose'),
171 store => \$verbose },
172 type => { required => 1, allow => [$class->accessors()],
176 my $args = check( $tmpl, \%hash ) or return;
179 for my $obj ( values %{ $self->$meth } ) {
180 #push @rv, $auth if check(
181 # { $type => { allow => $list } },
182 # { $type => $auth->$type }
184 push @rv, $obj if allow( $obj->$type() => $list );
194 =head2 $cb->__memory_retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL])
196 This method retrieves a I<storable>d tree identified by C<$name>.
198 It takes the following arguments:
204 The internal name for the source file to retrieve.
208 A flag indicating whether the file-cache is up-to-date or not.
212 The absolute path to the directory holding the source files.
216 A boolean flag indicating whether or not to be verbose.
220 Will get information from the config file by default.
222 Returns a tree on success, false on failure.
226 sub __memory_retrieve_source {
229 my $conf = $self->configure_object;
232 path => { default => $conf->get_conf('base') },
233 verbose => { default => $conf->get_conf('verbose') },
234 uptodate => { default => 0 },
237 my $args = check( $tmpl, \%hash ) or return;
239 ### check if we can retrieve a frozen data structure with storable ###
240 my $storable = can_load( modules => {'Storable' => '0.0'} )
241 if $conf->get_conf('storable');
243 return unless $storable;
245 ### $stored is the name of the frozen data structure ###
246 my $stored = $self->__memory_storable_file( $args->{path} );
248 if ($storable && -e $stored && -s _ && $args->{'uptodate'}) {
249 msg( loc("Retrieving %1", $stored), $args->{'verbose'} );
251 my $href = Storable::retrieve($stored);
260 =head2 $cb->__memory_save_source([verbose => BOOL, path => $path])
262 This method saves all the parsed trees in I<storable>d format if
263 C<Storable> is available.
265 It takes the following arguments:
271 The absolute path to the directory holding the source files.
275 A boolean flag indicating whether or not to be verbose.
279 Will get information from the config file by default.
281 Returns true on success, false on failure.
285 sub __memory_save_source {
288 my $conf = $self->configure_object;
292 path => { default => $conf->get_conf('base'), allow => DIR_EXISTS },
293 verbose => { default => $conf->get_conf('verbose') },
294 force => { default => 1 },
297 my $args = check( $tmpl, \%hash ) or return;
299 my $aref = [qw[_mtree _atree]];
301 ### check if we can retrieve a frozen data structure with storable ###
303 $storable = can_load( modules => {'Storable' => '0.0'} )
304 if $conf->get_conf('storable');
305 return unless $storable;
308 foreach my $key ( @$aref ) {
309 next unless ref( $self->$key );
310 $to_write->{$key} = $self->$key;
313 return unless keys %$to_write;
315 ### $stored is the name of the frozen data structure ###
316 my $stored = $self->__memory_storable_file( $args->{path} );
318 if (-e $stored && not -w $stored) {
319 msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} );
323 msg( loc("Writing compiled source information to disk. This might take a little while."),
324 $args->{'verbose'} );
327 unless( Storable::nstore( $to_write, $stored ) ) {
328 error( loc("could not store %1!", $stored) );
332 return $flag ? 0 : 1;
335 sub __memory_storable_file {
337 my $conf = $self->configure_object;
338 my $path = shift or return;
340 ### check if we can retrieve a frozen data structure with storable ###
341 my $storable = $conf->get_conf('storable')
342 ? can_load( modules => {'Storable' => '0.0'} )
345 return unless $storable;
347 ### $stored is the name of the frozen data structure ###
348 ### changed to use File::Spec->catfile -jmb
349 my $stored = File::Spec->rel2abs(
352 $conf->_get_source('stored') #file
354 $Storable::VERSION #the version of storable
355 . '.stored' #append a suffix
366 # c-indentation-style: bsd
368 # indent-tabs-mode: nil
370 # vim: expandtab shiftwidth=4: