1package CPANPLUS::Internals::Source::Memory;
2
3use base 'CPANPLUS::Internals::Source';
4
5use strict;
6
7use CPANPLUS::Error;
8use CPANPLUS::Module;
9use CPANPLUS::Module::Fake;
10use CPANPLUS::Module::Author;
11use CPANPLUS::Internals::Constants;
12
13use File::Fetch;
14use Archive::Extract;
15
16use IPC::Cmd                    qw[can_run];
17use File::Temp                  qw[tempdir];
18use File::Basename              qw[dirname];
19use Params::Check               qw[allow check];
20use Module::Load::Conditional   qw[can_load];
21use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
22
23use vars qw[$VERSION];
24$VERSION = "0.9912";
25
26$Params::Check::VERBOSE = 1;
27
28=head1 NAME
29
30CPANPLUS::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        my $self = shift;
40        my $conf = $self->configure_object;
41        my %hash = @_;
42
43        my($path,$uptodate,$verbose,$use_stored);
44        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        check( $tmpl, \%hash ) or return;
52
53        ### retrieve the stored source files ###
54        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        $from_storable = keys %$stored ? 1 : 0;
62
63        ### set up the trees
64        $self->_atree( $stored->{_atree} || {} );
65        $self->_mtree( $stored->{_mtree} || {} );
66
67        return 1;
68    }
69
70    sub _standard_trees_completed { return $from_storable }
71    sub _custom_trees_completed   { return $from_storable }
72
73    sub _finalize_trees {
74        my $self = shift;
75        my $conf = $self->configure_object;
76        my %hash = @_;
77
78        my($path,$uptodate,$verbose);
79        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        {   local $Params::Check::ALLOW_UNKNOWN = 1;
86            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        $self->__memory_save_source() if !$uptodate or not $from_storable;
94
95        return 1;
96    }
97
98    ### saves current memory state
99    sub _save_state {
100        my $self = shift;
101        return $self->_finalize_trees( @_, uptodate => 0 );
102    }
103}
104
105sub _add_author_object {
106    my $self = shift;
107    my %hash = @_;
108
109    my $class;
110    my $tmpl = {
111        class   => { default => 'CPANPLUS::Module::Author', store => \$class },
112        map { $_ => { required => 1 } }
113            qw[ author cpanid email ]
114    };
115
116    my $href = do {
117        local $Params::Check::NO_DUPLICATES = 1;
118        check( $tmpl, \%hash ) or return;
119    };
120
121    my $obj = $class->new( %$href, _id => $self->_id );
122
123    $self->author_tree->{ $href->{'cpanid'} } = $obj or return;
124
125    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        my $self = shift;
138        my %hash = @_;
139
140        my $href = do {
141            local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
142            check( $tmpl, \%hash ) or return;
143        };
144        my $class = delete $href->{class};
145
146        my $obj = $class->new( %$href, _id => $self->_id );
147
148        ### Every module get's stored as a module object ###
149        $self->module_tree->{ $href->{module} } = $obj or return;
150
151        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        no strict 'refs';
162
163        my($meth, $class) = @$aref;
164
165        *$sub = sub {
166            my $self = shift;
167            my $conf = $self->configure_object;
168            my %hash = @_;
169
170            my($authors,$list,$verbose,$type);
171            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            my $args = check( $tmpl, \%hash ) or return;
183
184            my @rv;
185            for my $obj ( values %{ $self->$meth } ) {
186                #push @rv, $auth if check(
187                #                        { $type => { allow => $list } },
188                #                        { $type => $auth->$type }
189                #                    );
190                push @rv, $obj if allow( $obj->$type() => $list );
191            }
192
193            return @rv;
194        }
195    }
196}
197
198=pod
199
200=head2 $cb->__memory_retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL])
201
202This method retrieves a I<storable>d tree identified by C<$name>.
203
204It takes the following arguments:
205
206=over 4
207
208=item name
209
210The internal name for the source file to retrieve.
211
212=item uptodate
213
214A flag indicating whether the file-cache is up-to-date or not.
215
216=item path
217
218The absolute path to the directory holding the source files.
219
220=item verbose
221
222A boolean flag indicating whether or not to be verbose.
223
224=back
225
226Will get information from the config file by default.
227
228Returns a tree on success, false on failure.
229
230=cut
231
232sub __memory_retrieve_source {
233    my $self = shift;
234    my %hash = @_;
235    my $conf = $self->configure_object;
236
237    my $tmpl = {
238        path     => { default => $conf->get_conf('base') },
239        verbose  => { default => $conf->get_conf('verbose') },
240        uptodate => { default => 0 },
241    };
242
243    my $args = check( $tmpl, \%hash ) or return;
244
245    ### check if we can retrieve a frozen data structure with storable ###
246    my $storable = can_load( modules => {'Storable' => '0.0'} )
247                        if $conf->get_conf('storable');
248
249    return unless $storable;
250
251    ### $stored is the name of the frozen data structure ###
252    my $stored = $self->__memory_storable_file( $args->{path} );
253
254    if ($storable && -e $stored && -s _ && $args->{'uptodate'}) {
255        msg( loc("Retrieving %1", $stored), $args->{'verbose'} );
256
257        my $href = Storable::retrieve($stored);
258        return $href;
259    } else {
260        return;
261    }
262}
263
264=pod
265
266=head2 $cb->__memory_save_source([verbose => BOOL, path => $path])
267
268This method saves all the parsed trees in I<storable>d format if
269C<Storable> is available.
270
271It takes the following arguments:
272
273=over 4
274
275=item path
276
277The absolute path to the directory holding the source files.
278
279=item verbose
280
281A boolean flag indicating whether or not to be verbose.
282
283=back
284
285Will get information from the config file by default.
286
287Returns true on success, false on failure.
288
289=cut
290
291sub __memory_save_source {
292    my $self = shift;
293    my %hash = @_;
294    my $conf = $self->configure_object;
295
296
297    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    my $args = check( $tmpl, \%hash ) or return;
304
305    my $aref = [qw[_mtree _atree]];
306
307    ### check if we can retrieve a frozen data structure with storable ###
308    my $storable;
309    $storable = can_load( modules => {'Storable' => '0.0'} )
310                    if $conf->get_conf('storable');
311    return unless $storable;
312
313    my $to_write = {};
314    foreach my $key ( @$aref ) {
315        next unless ref( $self->$key );
316        $to_write->{$key} = $self->$key;
317    }
318
319    return unless keys %$to_write;
320
321    ### $stored is the name of the frozen data structure ###
322    my $stored = $self->__memory_storable_file( $args->{path} );
323
324    if (-e $stored && not -w $stored) {
325        msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} );
326        return;
327    }
328
329    msg( loc("Writing compiled source information to disk. This might take a little while."),
330	    $args->{'verbose'} );
331
332    my $flag;
333    unless( Storable::nstore( $to_write, $stored ) ) {
334        error( loc("could not store %1!", $stored) );
335        $flag++;
336    }
337
338    return $flag ? 0 : 1;
339}
340
341sub __memory_storable_file {
342    my $self = shift;
343    my $conf = $self->configure_object;
344    my $path = shift or return;
345
346    ### check if we can retrieve a frozen data structure with storable ###
347    my $storable = $conf->get_conf('storable')
348                        ? can_load( modules => {'Storable' => '0.0'} )
349                        : 0;
350
351    return unless $storable;
352
353    ### $stored is the name of the frozen data structure ###
354    ### changed to use File::Spec->catfile -jmb
355    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    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
3801;
381