Bio/Root/Storable.pm

   1 package Bio::Root::Storable;
   2 use strict;
   3 use Bio::Root::IO;
   4 use Data::Dumper qw( Dumper );
   5 use File::Spec;
   6 use base qw(Bio::Root::Root);
   7
   8 =head1 SYNOPSIS
   9
  10   my $storable = Bio::Root::Storable->new();
  11
  12   # Store/retrieve using class retriever
  13   my $token     = $storable->store();
  14   my $storable2 = Bio::Root::Storable->retrieve( $token );
  15
  16   # Store/retrieve using object retriever
  17   my $storable2 = $storable->new_retrievable();
  18   $storable2->retrieve();
  19
  20 =head1 DESCRIPTION
  21
  22 Generic module that allows objects to be safely stored/retrieved from
  23 disk.  Can be inhereted by any BioPerl object. As it will not usually
  24 be the first class in the inheretence list, _initialise_storable()
  25 should be called during object instantiation.
  26
  27 Object storage is recursive; If the object being stored contains other
  28 storable objects, these will be stored separately, and replaced by a
  29 skeleton object in the parent hierarchy. When the parent is later
  30 retrieved, its children remain in the skeleton state until explicitly
  31 retrieved by the parent. This lazy-retrieve approach has obvious
  32 memory efficiency benefits for certain applications.
  33
  34
  35 By default, objects are stored in binary format (using the Perl
  36 Storable module). Earlier versions of Perl5 do not include Storable as
  37 a core module. If this is the case, ASCII object storage (using the
  38 Perl Data::Dumper module) is used instead.
  39
  40 ASCII storage can be enabled by default by setting the value of
  41 $Bio::Root::Storable::BINARY to false.
  42
  43 =head1 AUTHOR Will Spooner
  44
  45 =cut
  46
  47 use vars qw( $BINARY );
  48
  49 BEGIN{
  50     if( eval "require Storable" ){
  51         Storable->import( 'freeze', 'thaw' );
  52         $BINARY = 1;
  53     }
  54 }
  55
  56 #----------------------------------------------------------------------
  57
  58 =head2 new
  59
  60   Arg [1]   : -workdir  => filesystem path,
  61               -template => tmpfile template,
  62               -suffix   => tmpfile suffix,
  63   Function  : Builds a new Bio::Root::Storable inhereting object
  64   Returntype: Bio::Root::Storable inhereting object
  65   Exceptions:
  66   Caller    :
  67   Example   : $storable = Bio::Root::Storable->new()
  68
  69 =cut
  70
  71 sub new {
  72     my ($caller, @args) = @_;
  73     my $self = $caller->SUPER::new(@args);
  74     $self->_initialise_storable;
  75     return $self;
  76 }
  77
  78 #----------------------------------------------------------------------
  79
  80 =head2 _initialise_storable
  81
  82   Arg [1]   : See 'new' method
  83   Function  : Initialises storable-specific attributes
  84   Returntype: boolean
  85   Exceptions:
  86   Caller    :
  87   Example   :
  88
  89 =cut
  90
  91 sub _initialise_storable {
  92     my $self = shift;
  93     my( $workdir, $template, $suffix ) =
  94         $self->_rearrange([qw(WORKDIR TEMPLATE SUFFIX)], @_ );
  95     $workdir  && $self->workdir ( $workdir );
  96     $template && $self->template( $template );
  97     $suffix   && $self->suffix  ( $suffix   );
  98     return 1;
  99 }
 100
 101
 102
 103 #----------------------------------------------------------------------
 104
 105 =head2 statefile
 106
 107   Arg [1]   : string (optional)
 108   Function  : Accessor for the file to write state into.
 109               Should not normally use as a setter - let Root::IO
 110               do this for you.
 111   Returntype: string
 112   Exceptions:
 113   Caller    : Bio::Root::Storable->store
 114   Example   : my $statefile = $obj->statefile();
 115
 116 =cut
 117
 118 sub statefile{
 119     my $key = '_statefile';
 120     my $self  = shift;
 121
 122     if( @_ ){ $self->{$key} = shift }
 123
 124     if( ! $self->{$key} ){ # Create a new statefile
 125         my $workdir  = $self->workdir;
 126         my $template = $self->template;
 127         my $suffix   = $self->suffix;
 128
 129         # TODO: add cleanup and unlink methods. For now, we'll keep the
 130         # statefile hanging around.
 131         my @args = ( CLEANUP=>0, UNLINK=>0 );
 132         if( $template ){ push( @args, 'TEMPLATE' => $template )};
 133         if( $workdir  ){ push( @args, 'DIR'      => $workdir  )};
 134         if( $suffix   ){ push( @args, 'SUFFIX'   => $suffix   )};
 135         my( $fh, $file ) = Bio::Root::IO->new->tempfile( @args );
 136         # If filehandle is not stored, don't leave it open
 137         $fh->close;
 138
 139         $self->{$key} = $file;
 140     }
 141
 142     return $self->{$key};
 143 }
 144
 145 #----------------------------------------------------------------------
 146
 147 =head2 workdir
 148
 149   Arg [1]   : string (optional) (TODO - convert to array for x-platform)
 150   Function  : Accessor for the statefile directory. Defaults to File::Spec->tmpdir
 151   Returntype: string
 152   Exceptions:
 153   Caller    :
 154   Example   : $obj->workdir('/tmp/foo');
 155
 156 =cut
 157
 158 sub workdir {
 159     my $key = '_workdir';
 160     my $self = shift;
 161     if( @_ ){
 162         my $caller = join( ', ', (caller(0))[1..2] );
 163         $self->{$key} && $self->debug("Overwriting workdir: probably bad!");
 164         $self->{$key} = shift
 165     }
 166     #$self->{$key} ||= $Bio::Root::IO::TEMPDIR;
 167     $self->{$key} ||= File::Spec->tmpdir();
 168     return $self->{$key};
 169 }
 170
 171 #----------------------------------------------------------------------
 172
 173 =head2 template
 174
 175   Arg [1]   : string (optional)
 176   Function  : Accessor for the statefile template. Defaults to XXXXXXXX
 177   Returntype: string
 178   Exceptions:
 179   Caller    :
 180   Example   : $obj->workdir('RES_XXXXXXXX');
 181
 182 =cut
 183
 184 sub template {
 185     my $key = '_template';
 186     my $self = shift;
 187     if( @_ ){ $self->{$key} = shift }
 188     $self->{$key} ||= 'XXXXXXXX';
 189     return $self->{$key};
 190 }
 191
 192 #----------------------------------------------------------------------
 193
 194 =head2 suffix
 195
 196   Arg [1]   : string (optional)
 197   Function  : Accessor for the statefile template.
 198   Returntype: string
 199   Exceptions:
 200   Caller    :
 201   Example   : $obj->suffix('.state');
 202
 203 =cut
 204
 205 sub suffix {
 206     my $key = '_suffix';
 207     my $self = shift;
 208     if( @_ ){ $self->{$key} = shift }
 209     return $self->{$key};
 210 }
 211
 212 #----------------------------------------------------------------------
 213
 214 =head2 new_retrievable
 215
 216   Arg [1]   : Same as for 'new'
 217   Function  : Similar to store, except returns a 'skeleton' of the calling
 218               object, rather than the statefile.
 219               The skeleton can be repopulated by calling 'retrieve'. This
 220               will be a clone of the original object.
 221   Returntype: Bio::Root::Storable inhereting object
 222   Exceptions:
 223   Caller    :
 224   Example   : my $skel = $obj->new_retrievable(); # skeleton
 225               $skel->retrieve();                  # clone
 226
 227 =cut
 228
 229 sub new_retrievable{
 230     my $self = shift;
 231     my @args = @_;
 232
 233     $self->_initialise_storable( @args );
 234
 235     if( $self->retrievable ){ return $self->clone } # Clone retrievable
 236     return bless( { _statefile   => $self->store(@args),
 237                     _workdir     => $self->workdir,
 238                     _suffix      => $self->suffix,
 239                     _template    => $self->template,
 240                     _retrievable => 1 },
 241                  ref( $self ) );
 242 }
 243
 244 #----------------------------------------------------------------------
 245
 246 =head2 retrievable
 247
 248   Arg [1]   : none
 249   Function  : Reports whether the object is in 'skeleton' state, and the
 250               'retrieve' method can be called.
 251   Returntype: boolean
 252   Exceptions:
 253   Caller    :
 254   Example   : if( $obj->retrievable ){ $obj->retrieve }
 255
 256 =cut
 257
 258 sub retrievable {
 259     my $self = shift;
 260     if( @_ ){ $self->{_retrievable} = shift }
 261     return $self->{_retrievable};
 262 }
 263
 264 #----------------------------------------------------------------------
 265
 266 =head2 token
 267
 268   Arg [1]   : None
 269   Function  : Accessor for token attribute
 270   Returntype: string. Whatever retrieve needs to retrieve.
 271               This base implementation returns the statefile
 272   Exceptions:
 273   Caller    :
 274   Example   : my $token = $obj->token();
 275
 276 =cut
 277
 278 sub token{
 279     my $self = shift;
 280     return $self->statefile;
 281 }
 282
 283
 284 #----------------------------------------------------------------------
 285
 286 =head2 store
 287
 288   Arg [1]   : none
 289   Function  : Saves a serialised representation of the object structure
 290               to disk. Returns the name of the file that the object was
 291               saved to.
 292   Returntype: string
 293
 294   Exceptions:
 295   Caller    :
 296   Example   : my $token = $obj->store();
 297
 298 =cut
 299
 300 sub store{
 301     my $self = shift;
 302     my $statefile = $self->statefile;
 303     my $store_obj = $self->serialise;
 304     my $io = Bio::Root::IO->new( ">$statefile" );
 305     $io->_print( $store_obj );
 306     $self->debug( "STORING $self to $statefile\n" );
 307     # If filehandle is not stored, don't leave it open
 308     $io->close;
 309     return $statefile;
 310 }
 311
 312 #----------------------------------------------------------------------
 313
 314 =head2 serialise
 315
 316   Arg [1]   : none
 317   Function  : Prepares the the serialised representation of the object.
 318               Object attribute names starting with '__' are skipped.
 319               This is useful for those that do not serialise too well
 320               (e.g. filehandles).
 321               Attributes are examined for other storable objects. If these
 322               are found they are serialised separately using 'new_retrievable'
 323   Returntype: string
 324   Exceptions:
 325   Caller    :
 326   Example   : my $serialised = $obj->serialise();
 327
 328 =cut
 329
 330 sub serialise{
 331     my $self = shift;
 332
 333     # Create a new object of same class that is going to be serialised
 334     my $store_obj = bless( {}, ref( $self ) );
 335
 336     my %retargs = ( -workdir =>$self->workdir,
 337                     -suffix  =>$self->suffix,
 338                     -template=>$self->template );
 339     # Assume that other storable bio objects held by this object are
 340     # only 1-deep.
 341
 342     foreach my $key( keys( %$self ) ){
 343         if( $key =~ /^__/ ){ next } # Ignore keys starting with '__'
 344         my $value = $self->{$key};
 345
 346         # Scalar value
 347         if( ! ref( $value ) ){
 348             $store_obj->{$key} = $value;
 349         }
 350
 351         # Bio::Root::Storable obj: save placeholder
 352         elsif( ref($value) =~ /^Bio::/ and $value->isa('Bio::Root::Storable') ){
 353             # Bio::Root::Storable
 354             $store_obj->{$key} = $value->new_retrievable( %retargs );
 355             next;
 356         }
 357
 358         # Arrayref value. Look for Bio::Root::Storable objs
 359         elsif( ref( $value ) eq 'ARRAY' ){
 360             my @ary;
 361             foreach my $val( @$value ){
 362                 if( ref($val) =~ /^Bio::/ and $val->isa('Bio::Root::Storable') ){
 363                     push(  @ary, $val->new_retrievable( %retargs ) );
 364                 }
 365                 else{ push(  @ary, $val ) }
 366             }
 367             $store_obj->{$key} = \@ary;
 368         }
 369
 370         # Hashref value. Look for Bio::Root::Storable objs
 371         elsif( ref( $value ) eq 'HASH' ){
 372             my %hash;
 373             foreach my $k2( keys %$value ){
 374                 my $val = $value->{$k2};
 375                 if( ref($val) =~ /^Bio::/ and $val->isa('Bio::Root::Storable') ){
 376                     $hash{$k2} = $val->new_retrievable( %retargs );
 377                 }
 378                 else{ $hash{$k2} = $val }
 379             }
 380             $store_obj->{$key} = \%hash;
 381         }
 382
 383         # Unknown, just add to the store object regardless
 384         else{ $store_obj->{$key} = $value }
 385     }
 386     $store_obj->retrievable(0); # Once deserialised, obj not retrievable
 387     return $self->_freeze( $store_obj );
 388 }
 389
 390
 391 #----------------------------------------------------------------------
 392
 393 =head2 retrieve
 394
 395   Arg [1]   : string; filesystem location of the state file to be retrieved
 396   Function  : Retrieves a stored object from disk.
 397               Note that the retrieved object will be blessed into its original
 398               class, and not the
 399   Returntype: Bio::Root::Storable inhereting object
 400   Exceptions:
 401   Caller    :
 402   Example   : my $obj = Bio::Root::Storable->retrieve( $token );
 403
 404 =cut
 405
 406 sub retrieve{
 407     my( $caller, $statefile ) = @_;
 408
 409     my $self = {};
 410     my $class = ref( $caller ) || $caller;
 411
 412     # Is this a call on a retrievable object?
 413     if (    ref( $caller )
 414         and $caller->retrievable
 415         ){
 416         $self = $caller;
 417         $statefile = $self->statefile;
 418     }
 419     bless( $self, $class );
 420
 421     # Recover serialised object
 422     if( ! -f $statefile ){
 423         $self->throw( "Token $statefile is not found" );
 424     }
 425     my $io = Bio::Root::IO->new( $statefile );
 426     local $/ = undef;
 427     my $state_str = $io->_readline('-raw'=>1);
 428     # If filehandle is not stored, don't leave it open
 429     $io->close;
 430
 431     # Dynamic-load modules required by stored object
 432     my $stored_obj;
 433     my $success;
 434     for( my $i=0; $i<10; $i++ ){
 435         eval{ $stored_obj = $self->_thaw( $state_str ) };
 436         if( ! $@ ){
 437             $success = 1;
 438             last;
 439         }
 440         my $package;
 441         if( $@ =~ /Cannot restore overloading(.*)/i ){
 442             my $postmatch = $1; #'
 443             if( $postmatch =~ /\(package +([\w\:]+)\)/ ) {
 444                 $package = $1;
 445             }
 446         }
 447         if( $package ){
 448             eval "require $package";
 449             $self->throw($@) if $@;
 450         }
 451         else{ $self->throw($@) }
 452     }
 453     if( ! $success ){ $self->throw("maximum number of requires exceeded" ) }
 454
 455     if( ! ref( $stored_obj ) ){
 456         $self->throw( "Token $statefile returned no data" );
 457     }
 458     map{ $self->{$_} = $stored_obj->{$_} } keys %$stored_obj; # Copy hasheys
 459     $self->retrievable(0);
 460
 461     # Maintain class of stored obj
 462     return $self;
 463 }
 464
 465 #----------------------------------------------------------------------
 466
 467
 468 =head2 clone
 469
 470   Arg [1]   : none
 471   Function  : Returns a clone of the calling object
 472   Returntype: Bio::Root::Storable inhereting object
 473   Exceptions:
 474   Caller    :
 475   Example   : my $clone = $obj->clone();
 476
 477 =cut
 478
 479 sub clone {
 480     my $self = shift;
 481     my $frozen = $self->_freeze( $self );
 482     return $self->_thaw( $frozen );
 483 }
 484
 485
 486
 487 #----------------------------------------------------------------------
 488
 489 =head2 remove
 490
 491   Arg [1]   : none
 492   Function  : Clears the stored object from disk
 493   Returntype: boolean
 494   Exceptions:
 495   Caller    :
 496   Example   : $obj->remove();
 497
 498 =cut
 499
 500 sub remove {
 501     my $self = shift;
 502     if( -e $self->statefile ){
 503         unlink( $self->statefile );
 504     }
 505     return 1;
 506 }
 507
 508 #----------------------------------------------------------------------
 509
 510 =head2 _freeze
 511
 512   Arg [1]   : variable
 513   Function  : Converts whatever is in the the arg into a string.
 514               Uses either Storable::freeze or Data::Dumper::Dump
 515               depending on the value of $Bio::Root::BINARY
 516   Returntype:
 517   Exceptions:
 518   Caller    :
 519   Example   :
 520
 521 =cut
 522
 523 sub _freeze {
 524     my $self = shift;
 525     my $data = shift;
 526     if( $BINARY ){
 527         return freeze( $data );
 528     }
 529     else{
 530         $Data::Dumper::Purity = 1;
 531         return Data::Dumper->Dump( [\$data],["*code"] );
 532     }
 533 }
 534
 535 #----------------------------------------------------------------------
 536
 537 =head2 _thaw
 538
 539   Arg [1]   : string
 540   Function  : Converts the string into a perl 'whatever'.
 541               Uses either Storable::thaw or eval depending on the
 542               value of $Bio::Root::BINARY.
 543               Note; the string arg should have been created with
 544               the _freeze method, or strange things may occur!
 545   Returntype: variable
 546   Exceptions:
 547   Caller    :
 548   Example   :
 549
 550 =cut
 551
 552 sub _thaw {
 553     my $self = shift;
 554     my $data = shift;
 555     if( $BINARY ){
 556         return thaw( $data )
 557     }
 558     else{
 559         my $code;
 560         $code = eval( $data ) ;
 561         if($@) {
 562             $self->throw( "eval: $@" );
 563         }
 564         ref( $code ) eq 'REF'
 565             or $self->throw( "Serialised string was not a scalar ref" );
 566         return $$code;
 567     }
 568 }
 569
 570 1;