[p5sagit/p5-mst-13.2.git] / ext / CPANPLUS / lib / CPANPLUS / Internals / Source / Memory.pm

package CPANPLUS::Internals::Source::Memory;

use base 'CPANPLUS::Internals::Source';

use strict;

use CPANPLUS::Error;
use CPANPLUS::Module;
use CPANPLUS::Module::Fake;
use CPANPLUS::Module::Author;
use CPANPLUS::Internals::Constants;

use File::Fetch;
use Archive::Extract;

use IPC::Cmd                    qw[can_run];
use File::Temp                  qw[tempdir];
use File::Basename              qw[dirname];
use Params::Check               qw[allow check];
use Module::Load::Conditional   qw[can_load];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

$Params::Check::VERBOSE = 1;

=head1 NAME 

CPANPLUS::Internals::Source::Memory - In memory implementation

=cut

### flag to show if init_trees got its' data from storable. This allows
### us to not write an existing stored file back to disk
{   my $from_storable;

    sub _init_trees {
        my $self = shift;
        my $conf = $self->configure_object;
        my %hash = @_;
    
        my($path,$uptodate,$verbose,$use_stored);
        my $tmpl = {
            path        => { default => $conf->get_conf('base'), store => \$path },
            verbose     => { default => $conf->get_conf('verbose'), store => \$verbose },
            uptodate    => { required => 1, store => \$uptodate },
            use_stored  => { default  => 1, store => \$use_stored },
        };
    
        check( $tmpl, \%hash ) or return;
    
        ### retrieve the stored source files ###
        my $stored      = $self->__memory_retrieve_source(
                                path        => $path,
                                uptodate    => $uptodate && $use_stored,
                                verbose     => $verbose,
                            ) || {};
    
        ### we got this from storable if $stored has keys..
        $from_storable = keys %$stored ? 1 : 0;
    
        ### set up the trees
        $self->_atree( $stored->{_atree} || {} );                    
        $self->_mtree( $stored->{_mtree} || {} );

        return 1;
    }

    sub _standard_trees_completed { return $from_storable }
    sub _custom_trees_completed   { return $from_storable }

    sub _finalize_trees {
        my $self = shift;
        my $conf = $self->configure_object;
        my %hash = @_;
    
        my($path,$uptodate,$verbose);
        my $tmpl = {
            path        => { default => $conf->get_conf('base'), store => \$path },
            verbose     => { default => $conf->get_conf('verbose'), store => \$verbose },
            uptodate    => { required => 1, store => \$uptodate },
        };

        {   local $Params::Check::ALLOW_UNKNOWN = 1;    
            check( $tmpl, \%hash ) or return;
        }
        
        ### write the stored files to disk, so we can keep using them
        ### from now on, till they become invalid
        ### write them if the original sources weren't uptodate, or
        ### we didn't just load storable files
        $self->__memory_save_source() if !$uptodate or not $from_storable;
    
        return 1;
    }
    
    ### saves current memory state
    sub _save_state {
        my $self = shift;
        return $self->_finalize_trees( @_, uptodate => 0 );
    }        
}

sub _add_author_object {
    my $self = shift;
    my %hash = @_;
    
    my $class;
    my $tmpl = {
        class   => { default => 'CPANPLUS::Module::Author', store => \$class },
        map { $_ => { required => 1 } } 
            qw[ author cpanid email ]
    };

    my $href = do {
        local $Params::Check::NO_DUPLICATES = 1;
        check( $tmpl, \%hash ) or return;
    };
    
    my $obj = $class->new( %$href, _id => $self->_id );
    
    $self->author_tree->{ $href->{'cpanid'} } = $obj or return;

    return $obj;
}

sub _add_module_object {
    my $self = shift;
    my %hash = @_;

    my $class;    
    my $tmpl = {
        class   => { default => 'CPANPLUS::Module', store => \$class },
        map { $_ => { required => 1 } } 
            qw[ module version path comment author package description dslip mtime ]
    };

    my $href = do {
        local $Params::Check::NO_DUPLICATES = 1;
        check( $tmpl, \%hash ) or return;
    };
    
    my $obj = $class->new( %$href, _id => $self->_id );
    
    ### Every module get's stored as a module object ###
    $self->module_tree->{ $href->{module} } = $obj or return;

    return $obj;    
}

{   my %map = (
        _source_search_module_tree  => [ module_tree => 'CPANPLUS::Module' ],
        _source_search_author_tree  => [ author_tree => 'CPANPLUS::Module::Author' ],
    );        

    while( my($sub, $aref) = each %map ) {
        no strict 'refs';
        
        my($meth, $class) = @$aref;
        
        *$sub = sub {
            my $self = shift;
            my $conf = $self->configure_object;
            my %hash = @_;
        
            my($authors,$list,$verbose,$type);
            my $tmpl = {
                data    => { default    => [],
                             strict_type=> 1, store     => \$authors },
                allow   => { required   => 1, default   => [ ], strict_type => 1,
                             store      => \$list },
                verbose => { default    => $conf->get_conf('verbose'),
                             store      => \$verbose },
                type    => { required   => 1, allow => [$class->accessors()],
                             store      => \$type },
            };
        
            my $args = check( $tmpl, \%hash ) or return;            
        
            my @rv;
            for my $obj ( values %{ $self->$meth } ) {
                #push @rv, $auth if check(
                #                        { $type => { allow => $list } },
                #                        { $type => $auth->$type }
                #                    );
                push @rv, $obj if allow( $obj->$type() => $list );
            }        
        
            return @rv;
        }
    }
}

=pod

=head2 $cb->__memory_retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL])

This method retrieves a I<storable>d tree identified by C<$name>.

It takes the following arguments:

=over 4

=item name

The internal name for the source file to retrieve.

=item uptodate

A flag indicating whether the file-cache is up-to-date or not.

=item path

The absolute path to the directory holding the source files.

=item verbose

A boolean flag indicating whether or not to be verbose.

=back

Will get information from the config file by default.

Returns a tree on success, false on failure.

=cut

sub __memory_retrieve_source {
    my $self = shift;
    my %hash = @_;
    my $conf = $self->configure_object;

    my $tmpl = {
        path     => { default => $conf->get_conf('base') },
        verbose  => { default => $conf->get_conf('verbose') },
        uptodate => { default => 0 },
    };

    my $args = check( $tmpl, \%hash ) or return;

    ### check if we can retrieve a frozen data structure with storable ###
    my $storable = can_load( modules => {'Storable' => '0.0'} )
                        if $conf->get_conf('storable');

    return unless $storable;

    ### $stored is the name of the frozen data structure ###
    my $stored = $self->__memory_storable_file( $args->{path} );

    if ($storable && -e $stored && -s _ && $args->{'uptodate'}) {
        msg( loc("Retrieving %1", $stored), $args->{'verbose'} );

        my $href = Storable::retrieve($stored);
        return $href;
    } else {
        return;
    }
}

=pod

=head2 $cb->__memory_save_source([verbose => BOOL, path => $path])

This method saves all the parsed trees in I<storable>d format if
C<Storable> is available.

It takes the following arguments:

=over 4

=item path

The absolute path to the directory holding the source files.

=item verbose

A boolean flag indicating whether or not to be verbose.

=back

Will get information from the config file by default.

Returns true on success, false on failure.

=cut

sub __memory_save_source {
    my $self = shift;
    my %hash = @_;
    my $conf = $self->configure_object;


    my $tmpl = {
        path     => { default => $conf->get_conf('base'), allow => DIR_EXISTS },
        verbose  => { default => $conf->get_conf('verbose') },
        force    => { default => 1 },
    };

    my $args = check( $tmpl, \%hash ) or return;

    my $aref = [qw[_mtree _atree]];

    ### check if we can retrieve a frozen data structure with storable ###
    my $storable;
    $storable = can_load( modules => {'Storable' => '0.0'} )
                    if $conf->get_conf('storable');
    return unless $storable;

    my $to_write = {};
    foreach my $key ( @$aref ) {
        next unless ref( $self->$key );
        $to_write->{$key} = $self->$key;
    }

    return unless keys %$to_write;

    ### $stored is the name of the frozen data structure ###
    my $stored = $self->__memory_storable_file( $args->{path} );

    if (-e $stored && not -w $stored) {
        msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} );
        return;
    }

    msg( loc("Writing compiled source information to disk. This might take a little while."),
	    $args->{'verbose'} );

    my $flag;
    unless( Storable::nstore( $to_write, $stored ) ) {
        error( loc("could not store %1!", $stored) );
        $flag++;
    }

    return $flag ? 0 : 1;
}

sub __memory_storable_file {
    my $self = shift;
    my $conf = $self->configure_object;
    my $path = shift or return;

    ### check if we can retrieve a frozen data structure with storable ###
    my $storable = $conf->get_conf('storable')
                        ? can_load( modules => {'Storable' => '0.0'} )
                        : 0;

    return unless $storable;
    
    ### $stored is the name of the frozen data structure ###
    ### changed to use File::Spec->catfile -jmb
    my $stored = File::Spec->rel2abs(
        File::Spec->catfile(
            $path,                          #base dir
            $conf->_get_source('stored')    #file
            . '.s' .
            $Storable::VERSION              #the version of storable 
            . '.c' .
            $self->VERSION                  #the version of CPANPLUS
            . STORABLE_EXT                  #append a suffix
        )
    );

    return $stored;
}


# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:

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