File Coverage

Bio/Root/Storable.pm
Criterion Covered Total %
statement 147 176 83.5
branch 41 72 56.9
condition 9 20 45.0
subroutine 23 23 100.0
pod 13 13 100.0
total 233 304 76.6


line stmt bran cond sub pod time code
1             package Bio::Root::Storable;
2 1     1   460 use strict;
  1         1  
  1         26  
3 1     1   301 use Bio::Root::IO;
  1         2  
  1         35  
4 1     1   6 use Data::Dumper qw( Dumper );
  1         2  
  1         50  
5 1     1   5 use File::Spec;
  1         1  
  1         18  
6 1     1   3 use base qw(Bio::Root::Root);
  1         1  
  1         72  
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 1     1   5 use vars qw( $BINARY );
  1         2  
  1         51  
48              
49             BEGIN{
50 1 50   1   59 if( eval "require Storable" ){
51 1         2370 Storable->import( 'freeze', 'thaw' );
52 1         1295 $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 4     4 1 148 my ($caller, @args) = @_;
73 4         17 my $self = $caller->SUPER::new(@args);
74 4         9 $self->_initialise_storable;
75 4         7 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 8     8   9 my $self = shift;
93 8         29 my( $workdir, $template, $suffix ) =
94             $self->_rearrange([qw(WORKDIR TEMPLATE SUFFIX)], @_ );
95 8 100       19 $workdir && $self->workdir ( $workdir );
96 8 100       16 $template && $self->template( $template );
97 8 50       11 $suffix && $self->suffix ( $suffix );
98 8         10 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 28     28 1 37 my $key = '_statefile';
120 28         32 my $self = shift;
121              
122 28 50       50 if( @_ ){ $self->{$key} = shift }
  0         0  
123              
124 28 100       43 if( ! $self->{$key} ){ # Create a new statefile
125 4         5 my $workdir = $self->workdir;
126 4         8 my $template = $self->template;
127 4         7 my $suffix = $self->suffix;
128              
129             # TODO: add cleanup and unlink methods. For now, we'll keep the
130             # statefile hanging around.
131 4         9 my @args = ( CLEANUP=>0, UNLINK=>0 );
132 4 50       9 if( $template ){ push( @args, 'TEMPLATE' => $template )};
  4         7  
133 4 50       7 if( $workdir ){ push( @args, 'DIR' => $workdir )};
  4         5  
134 4 100       7 if( $suffix ){ push( @args, 'SUFFIX' => $suffix )};
  2         3  
135 4         17 my( $fh, $file ) = Bio::Root::IO->new->tempfile( @args );
136             # If filehandle is not stored, don't leave it open
137 4         14 $fh->close;
138              
139 4         57 $self->{$key} = $file;
140             }
141              
142 28         1310 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 22     22 1 23 my $key = '_workdir';
160 22         21 my $self = shift;
161 22 100       35 if( @_ ){
162 2         9 my $caller = join( ', ', (caller(0))[1..2] );
163 2 50       39 $self->{$key} && $self->debug("Overwriting workdir: probably bad!");
164 2         4 $self->{$key} = shift
165             }
166             #$self->{$key} ||= $Bio::Root::IO::TEMPDIR;
167 22   66     88 $self->{$key} ||= File::Spec->tmpdir();
168 22         44 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 24     24 1 26 my $key = '_template';
186 24         24 my $self = shift;
187 24 100       32 if( @_ ){ $self->{$key} = shift }
  4         8  
188 24   100     40 $self->{$key} ||= 'XXXXXXXX';
189 24         63 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 22     22 1 26 my $key = '_suffix';
207 22         21 my $self = shift;
208 22 100       37 if( @_ ){ $self->{$key} = shift }
  2         2  
209 22         37 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 4     4 1 920 my $self = shift;
231 4         8 my @args = @_;
232              
233 4         9 $self->_initialise_storable( @args );
234              
235 4 50       7 if( $self->retrievable ){ return $self->clone } # Clone retrievable
  0         0  
236 4         16 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 30     30 1 943 my $self = shift;
260 30 100       45 if( @_ ){ $self->{_retrievable} = shift }
  18         25  
261 30         46 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 2     2 1 10 my $self = shift;
280 2         5 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 10     10 1 1471 my $self = shift;
302 10         15 my $statefile = $self->statefile;
303 10         19 my $store_obj = $self->serialise;
304 10         46 my $io = Bio::Root::IO->new( ">$statefile" );
305 10         28 $io->_print( $store_obj );
306 10         53 $self->debug( "STORING $self to $statefile\n" );
307             # If filehandle is not stored, don't leave it open
308 10         21 $io->close;
309 10         31 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 12     12 1 13 my $self = shift;
332              
333             # Create a new object of same class that is going to be serialised
334 12         29 my $store_obj = bless( {}, ref( $self ) );
335              
336 12         19 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 12         33 foreach my $key( keys( %$self ) ){
343 62 100       100 if( $key =~ /^__/ ){ next } # Ignore keys starting with '__'
  8         13  
344 54         58 my $value = $self->{$key};
345              
346             # Scalar value
347 54 100 33     86 if( ! ref( $value ) ){
    50          
    0          
    0          
348 52         73 $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 2         7 $store_obj->{$key} = $value->new_retrievable( %retargs );
355 2         6 next;
356             }
357              
358             # Arrayref value. Look for Bio::Root::Storable objs
359             elsif( ref( $value ) eq 'ARRAY' ){
360 0         0 my @ary;
361 0         0 foreach my $val( @$value ){
362 0 0 0     0 if( ref($val) =~ /^Bio::/ and $val->isa('Bio::Root::Storable') ){
363 0         0 push( @ary, $val->new_retrievable( %retargs ) );
364             }
365 0         0 else{ push( @ary, $val ) }
366             }
367 0         0 $store_obj->{$key} = \@ary;
368             }
369              
370             # Hashref value. Look for Bio::Root::Storable objs
371             elsif( ref( $value ) eq 'HASH' ){
372 0         0 my %hash;
373 0         0 foreach my $k2( keys %$value ){
374 0         0 my $val = $value->{$k2};
375 0 0 0     0 if( ref($val) =~ /^Bio::/ and $val->isa('Bio::Root::Storable') ){
376 0         0 $hash{$k2} = $val->new_retrievable( %retargs );
377             }
378 0         0 else{ $hash{$k2} = $val }
379             }
380 0         0 $store_obj->{$key} = \%hash;
381             }
382              
383             # Unknown, just add to the store object regardless
384 0         0 else{ $store_obj->{$key} = $value }
385             }
386 12         27 $store_obj->retrievable(0); # Once deserialised, obj not retrievable
387 12         21 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 6     6 1 10 my( $caller, $statefile ) = @_;
408              
409 6         9 my $self = {};
410 6   66     17 my $class = ref( $caller ) || $caller;
411              
412             # Is this a call on a retrievable object?
413 6 100 66     15 if ( ref( $caller )
414             and $caller->retrievable
415             ){
416 2         3 $self = $caller;
417 2         5 $statefile = $self->statefile;
418             }
419 6         7 bless( $self, $class );
420              
421             # Recover serialised object
422 6 50       62 if( ! -f $statefile ){
423 0         0 $self->throw( "Token $statefile is not found" );
424             }
425 6         29 my $io = Bio::Root::IO->new( $statefile );
426 6         20 local $/ = undef;
427 6         13 my $state_str = $io->_readline('-raw'=>1);
428             # If filehandle is not stored, don't leave it open
429 6         15 $io->close;
430              
431             # Dynamic-load modules required by stored object
432 6         8 my $stored_obj;
433             my $success;
434 6         15 for( my $i=0; $i<10; $i++ ){
435 6         9 eval{ $stored_obj = $self->_thaw( $state_str ) };
  6         13  
436 6 50       73 if( ! $@ ){
437 6         6 $success = 1;
438 6         8 last;
439             }
440 0         0 my $package;
441 0 0       0 if( $@ =~ /Cannot restore overloading(.*)/i ){
442 0         0 my $postmatch = $1; #'
443 0 0       0 if( $postmatch =~ /\(package +([\w\:]+)\)/ ) {
444 0         0 $package = $1;
445             }
446             }
447 0 0       0 if( $package ){
448 0         0 eval "require $package";
449 0 0       0 $self->throw($@) if $@;
450             }
451 0         0 else{ $self->throw($@) }
452             }
453 6 50       9 if( ! $success ){ $self->throw("maximum number of requires exceeded" ) }
  0         0  
454              
455 6 50       12 if( ! ref( $stored_obj ) ){
456 0         0 $self->throw( "Token $statefile returned no data" );
457             }
458 6         16 map{ $self->{$_} = $stored_obj->{$_} } keys %$stored_obj; # Copy hasheys
  36         52  
459 6         16 $self->retrievable(0);
460              
461             # Maintain class of stored obj
462 6         16 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 2     2 1 465 my $self = shift;
481 2         5 my $frozen = $self->_freeze( $self );
482 2         96 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 4     4 1 6 my $self = shift;
502 4 50       5 if( -e $self->statefile ){
503 4         8 unlink( $self->statefile );
504             }
505 4         21 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 14     14   15 my $self = shift;
525 14         15 my $data = shift;
526 14 100       18 if( $BINARY ){
527 7         17 return freeze( $data );
528             }
529             else{
530 7         9 $Data::Dumper::Purity = 1;
531 7         40 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 8     8   10 my $self = shift;
554 8         9 my $data = shift;
555 8 100       13 if( $BINARY ){
556 4         10 return thaw( $data )
557             }
558             else{
559 4         5 my $code;
560 4         281 $code = eval( $data ) ;
561 4 50       15 if($@) {
562 0         0 $self->throw( "eval: $@" );
563             }
564 4 50       10 ref( $code ) eq 'REF'
565             or $self->throw( "Serialised string was not a scalar ref" );
566 4         9 return $$code;
567             }
568             }
569              
570             1;