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