Bio/Root/Storable.pm

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