Bio/Root/Storable.pm

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