cpan/CPANPLUS/lib/CPANPLUS/Internals/Source/Memory.pm

   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
 353             . '.s' .
 354             $Storable::VERSION              #the version of storable
 355             . '.c' .
 356             $self->VERSION                  #the version of CPANPLUS
 357             . STORABLE_EXT                  #append a suffix
 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;