diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm | 381 |
1 files changed, 0 insertions, 381 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm deleted file mode 100644 index a28532e02cd..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm +++ /dev/null @@ -1,381 +0,0 @@ -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 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; |