package CPANPLUS::Internals::Source::Memory; use deprecate; 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'; use vars qw[$VERSION]; $VERSION = "0.9135"; $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; } { my $tmpl = { class => { default => 'CPANPLUS::Module' }, map { $_ => { required => 1 } } qw[ module version path comment author package description dslip mtime ], }; sub _add_module_object { my $self = shift; my %hash = @_; my $href = do { local $Params::Check::SANITY_CHECK_TEMPLATE = 0; check( $tmpl, \%hash ) or return; }; my $class = delete $href->{class}; 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 Id 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 Id format if C 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;