File Coverage

Bio/Root/Root.pm
Criterion Covered Total %
statement 105 152 69.0
branch 38 72 52.7
condition 18 39 46.1
subroutine 16 17 94.1
pod 5 5 100.0
total 182 285 63.8


line stmt bran cond sub pod time code
1             package Bio::Root::Root;
2 276     276   2065 use strict;
  276         594  
  276         6159  
3 276     276   87683 use Bio::Root::IO;
  276         418  
  276         6971  
4 276     276   67092 use Bio::Root::Version;
  276         413  
  276         1206  
5 276     276   8554 use Scalar::Util qw(blessed reftype);
  276         342  
  276         12561  
6 276     276   975 use base qw(Bio::Root::RootI);
  276         280  
  276         93338  
7              
8             our $VERSION = eval "$VERSION";
9              
10             =head1 SYNOPSIS
11              
12             # Any Bioperl-compliant object is a RootI compliant object
13              
14             # Here's how to throw and catch an exception using the eval-based syntax.
15              
16             $obj->throw("This is an exception");
17              
18             eval {
19             $obj->throw("This is catching an exception");
20             };
21              
22             if( $@ ) {
23             print "Caught exception";
24             } else {
25             print "no exception";
26             }
27              
28             # Alternatively, using the new typed exception syntax in the throw() call:
29              
30             $obj->throw( -class => 'Bio::Root::BadParameter',
31             -text => "Can not open file $file",
32             -value => $file );
33              
34             # Want to see debug() outputs for this object
35              
36             my $obj = Bio::Object->new(-verbose=>1);
37              
38             my $obj = Bio::Object->new(%args);
39             $obj->verbose(2);
40              
41             # Print debug messages which honour current verbosity setting
42              
43             $obj->debug("Boring output only to be seen if verbose > 0\n");
44              
45             # Deep-object copy
46              
47             my $clone = $obj->clone;
48              
49             =head1 DESCRIPTION
50              
51             This is a hashref-based implementation of the Bio::Root::RootI
52             interface. Most Bioperl objects should inherit from this.
53              
54             See the documentation for L for most of the methods
55             implemented by this module. Only overridden methods are described
56             here.
57              
58             =head2 Throwing Exceptions
59              
60             One of the functionalities that L provides is the
61             ability to L() exceptions with pretty stack traces. Bio::Root::Root
62             enhances this with the ability to use L (available from CPAN)
63             if it has also been installed.
64              
65             If L has been installed, L() will use it. This causes an
66             Error.pm-derived object to be thrown. This can be caught within a
67             C block, from wich you can extract useful bits of
68             information. If L is not installed, it will use the
69             L-based exception throwing facilty.
70              
71             =head2 Typed Exception Syntax
72              
73             The typed exception syntax of L() has the advantage of plainly
74             indicating the nature of the trouble, since the name of the class
75             is included in the title of the exception output.
76              
77             To take advantage of this capability, you must specify arguments
78             as named parameters in the L() call. Here are the parameters:
79              
80             =over 4
81              
82             =item -class
83              
84             name of the class of the exception.
85             This should be one of the classes defined in L,
86             or a custom error of yours that extends one of the exceptions
87             defined in L.
88              
89             =item -text
90              
91             a sensible message for the exception
92              
93             =item -value
94              
95             the value causing the exception or $!, if appropriate.
96              
97             =back
98              
99             Note that Bio::Root::Exception does not need to be imported into
100             your module (or script) namespace in order to throw exceptions
101             via Bio::Root::Root::throw(), since Bio::Root::Root imports it.
102              
103             =head2 Try-Catch-Finally Support
104              
105             In addition to using an eval{} block to handle exceptions, you can
106             also use a try-catch-finally block structure if L has been
107             installed in your system (available from CPAN). See the documentation
108             for Error for more details.
109              
110             Here's an example. See the L module for
111             other pre-defined exception types:
112              
113             my $IN;
114             try {
115             open $IN, '<', $file or $obj->throw( -class => 'Bio::Root::FileOpenException',
116             -text => "Cannot read file '$file'",
117             -value => $!);
118             }
119             catch Bio::Root::BadParameter with {
120             my $err = shift; # get the Error object
121             # Perform specific exception handling code for the FileOpenException
122             }
123             catch Bio::Root::Exception with {
124             my $err = shift; # get the Error object
125             # Perform general exception handling code for any Bioperl exception.
126             }
127             otherwise {
128             # A catch-all for any other type of exception
129             }
130             finally {
131             # Any code that you want to execute regardless of whether or not
132             # an exception occurred.
133             };
134             # the ending semicolon is essential!
135              
136             =head1 AUTHOR Steve Chervitz
137              
138             Ewan Birney, Lincoln Stein
139              
140             =cut
141              
142             our ($DEBUG, $ID, $VERBOSITY, $ERRORLOADED, $CLONE_CLASS);
143              
144             BEGIN {
145 276     276   564 $ID = 'Bio::Root::Root';
146 276         466 $DEBUG = 0;
147 276         328 $VERBOSITY = 0;
148 276         441 $ERRORLOADED = 0;
149              
150             # Check whether or not Error.pm is available.
151              
152             # $main::DONT_USE_ERROR is intended for testing purposes and also
153             # when you don't want to use the Error module, even if it is installed.
154             # Just put a INIT { $DONT_USE_ERROR = 1; } at the top of your script.
155 276 50       957 if( not $main::DONT_USE_ERROR ) {
156 276 50       11554 if ( eval "require Error; 1;" ) {
157 276         1048 import Error qw(:try);
158 276         110480 require Bio::Root::Exception;
159 276         630 $ERRORLOADED = 1;
160 276         517 $Error::Debug = 1; # enable verbose stack trace
161             }
162             }
163 276 50       1518 if( !$ERRORLOADED ) {
164 0         0 require Carp; import Carp qw( confess );
  0         0  
165             }
166              
167             # set up _dclone()
168 276         775 for my $class (qw(Clone Storable)) {
169 276         11410 eval "require $class; 1;";
170 276 50       1815 if (!$@) {
171 276         420 $CLONE_CLASS = $class;
172 276 50       942 if ($class eq 'Clone') {
173 276     11886   2214 *Bio::Root::Root::_dclone = sub {shift; return Clone::clone(shift)};
  11886         8374  
  11886         679795  
174             } else {
175             *Bio::Root::Root::_dclone = sub {
176 0         0 shift;
177 0         0 local $Storable::Deparse = 1;
178 0         0 local $Storable::Eval = 1;
179 0         0 return Storable::dclone(shift);
180 0         0 };
181             }
182 276         561 last;
183             }
184             }
185 276 50       807 if (!defined $CLONE_CLASS) {
186             *Bio::Root::Root::_dclone = sub {
187 0         0 my ($self, $orig, $level) = @_;
188 0   0     0 my $class = Scalar::Util::blessed($orig) || '';
189 0   0     0 my $reftype = Scalar::Util::reftype($orig) || '';
190 0         0 my $data;
191 0 0       0 if (!$reftype) {
    0          
    0          
    0          
192 0         0 $data = $orig
193             } elsif ($reftype eq "ARRAY") {
194 0         0 $data = [map $self->_dclone($_), @$orig];
195             } elsif ($reftype eq "HASH") {
196 0         0 $data = { map { $_ => $self->_dclone($orig->{$_}) } keys %$orig };
  0         0  
197             } elsif ($reftype eq 'CODE') { # nothing, maybe shallow copy?
198 0         0 $self->throw("Code reference cloning not supported; install Clone or Storable from CPAN");
199 0         0 } else { $self->throw("What type is $_?")}
200 0 0       0 if ($class) {
201 0         0 bless $data, $class;
202             }
203 0         0 $data;
204             }
205 0         0 }
206              
207 276         376018 $main::DONT_USE_ERROR; # so that perl -w won't warn "used only once"
208             }
209              
210             =head2 new
211              
212             Purpose : generic instantiation function can be overridden if
213             special needs of a module cannot be done in _initialize
214              
215             =cut
216              
217             sub new {
218             # my ($class, %param) = @_;
219 205127     205127 1 171430 my $class = shift;
220 205127         183991 my $self = {};
221 205127   66     538521 bless $self, ref($class) || $class;
222              
223 205127 100       298835 if(@_ > 1) {
224             # if the number of arguments is odd but at least 3, we'll give
225             # it a try to find -verbose
226 152832 50       233537 shift if @_ % 2;
227 152832         329849 my %param = @_;
228             ## See "Comments" above regarding use of _rearrange().
229 152832   33     386952 $self->verbose($param{'-VERBOSE'} || $param{'-verbose'});
230             }
231 205127         252177 return $self;
232             }
233              
234              
235             =head2 clone
236              
237             Title : clone
238             Usage : my $clone = $obj->clone();
239             or
240             my $clone = $obj->clone( -start => 110 );
241             Function: Deep recursion copying of any object via Storable dclone()
242             Returns : A cloned object.
243             Args : Any named parameters provided will be set on the new object.
244             Unnamed parameters are ignored.
245             Comments: Where possible, faster clone methods are used, in order:
246             Clone::Fast::clone(), Clone::clone(), Storable::dclone. If neither
247             is present, a pure perl fallback (not very well tested) is used
248             instead. Storable dclone() cannot clone CODE references. Therefore,
249             any CODE reference in your original object will remain, but will not
250             exist in the cloned object. This should not be used for anything
251             other than cloning of simple objects. Developers of subclasses are
252             encouraged to override this method with one of their own.
253              
254             =cut
255              
256             sub clone {
257 11886     11886 1 12502 my ($orig, %named_params) = @_;
258              
259 11886 50 33     42024 __PACKAGE__->throw("Can't call clone() as a class method") unless
260             ref $orig && $orig->isa('Bio::Root::Root');
261              
262             # Can't dclone CODE references...
263             # Should we shallow copy these? Should be harmless for these specific
264             # methods...
265              
266             my %put_these_back = (
267 11886         17949 _root_cleanup_methods => $orig->{'_root_cleanup_methods'},
268             );
269 11886         10255 delete $orig->{_root_cleanup_methods};
270              
271             # call the proper clone method, set lazily above
272 11886         19144 my $clone = __PACKAGE__->_dclone($orig);
273              
274 11886         24605 $orig->{_root_cleanup_methods} = $put_these_back{_root_cleanup_methods};
275              
276 11886         19881 foreach my $key (grep { /^-/ } keys %named_params) {
  3         12  
277 3         3 my $method = $key;
278 3         9 $method =~ s/^-//;
279 3 50       14 if ($clone->can($method)) {
280 3         22 $clone->$method($named_params{$key})
281             } else {
282 0         0 $orig->warn("Parameter $method is not a method for ".ref($clone));
283             }
284             }
285 11886         22076 return $clone;
286             }
287              
288             =head2 _dclone
289              
290             Title : clone
291             Usage : my $clone = $obj->_dclone($ref);
292             or
293             my $clone = $obj->_dclone($ref);
294             Function: Returns a copy of the object passed to it (a deep clone)
295             Returns : clone of passed argument
296             Args : Anything
297             NOTE : This differs from clone significantly in that it does not clone
298             self, but the data passed to it. This code may need to be optimized
299             or overridden as needed.
300             Comments: This is set in the BEGIN block to take advantage of optimized
301             cloning methods if Clone or Storable is present, falling back to a
302             pure perl kludge. May be moved into a set of modules if the need
303             arises. At the moment, code ref cloning is not supported.
304              
305             =cut
306              
307             =head2 verbose
308              
309             Title : verbose
310             Usage : $self->verbose(1)
311             Function: Sets verbose level for how ->warn behaves
312             -1 = no warning
313             0 = standard, small warning
314             1 = warning with stack trace
315             2 = warning becomes throw
316             Returns : The current verbosity setting (integer between -1 to 2)
317             Args : -1,0,1 or 2
318              
319              
320             =cut
321              
322             sub verbose {
323 510538     510538 1 409148 my ($self,$value) = @_;
324             # allow one to set global verbosity flag
325 510538 100       647709 return $DEBUG if $DEBUG;
326 510522 100       668400 return $VERBOSITY unless ref $self;
327              
328 510494 100 100     1340913 if (defined $value || ! defined $self->{'_root_verbose'}) {
329 217355   100     587349 $self->{'_root_verbose'} = $value || 0;
330             }
331 510494         1015232 return $self->{'_root_verbose'};
332             }
333              
334             =head2 _register_for_cleanup
335              
336             =cut
337              
338             sub _register_for_cleanup {
339 72021     72021   61952 my ($self,$method) = @_;
340 72021 50       109277 if ($method) {
341 72021 100       111850 if(! exists($self->{'_root_cleanup_methods'})) {
342 67570         97100 $self->{'_root_cleanup_methods'} = [];
343             }
344 72021         56296 push(@{$self->{'_root_cleanup_methods'}},$method);
  72021         128779  
345             }
346             }
347              
348             =head2 _unregister_for_cleanup
349              
350             =cut
351              
352             sub _unregister_for_cleanup {
353 0     0   0 my ($self,$method) = @_;
354 0         0 my @methods = grep {$_ ne $method} $self->_cleanup_methods;
  0         0  
355 0         0 $self->{'_root_cleanup_methods'} = \@methods;
356             }
357              
358             =head2 _cleanup_methods
359              
360             =cut
361              
362             sub _cleanup_methods {
363 305105     305105   195448 my $self = shift;
364 305105 100 66     955436 return unless ref $self && $self->isa('HASH');
365 304998 100       1363055 my $methods = $self->{'_root_cleanup_methods'} or return;
366 58620         110458 @$methods;
367             }
368              
369             =head2 throw
370              
371             Title : throw
372             Usage : $obj->throw("throwing exception message");
373             or
374             $obj->throw( -class => 'Bio::Root::Exception',
375             -text => "throwing exception message",
376             -value => $bad_value );
377             Function: Throws an exception, which, if not caught with an eval or
378             a try block will provide a nice stack trace to STDERR
379             with the message.
380             If Error.pm is installed, and if a -class parameter is
381             provided, Error::throw will be used, throwing an error
382             of the type specified by -class.
383             If Error.pm is installed and no -class parameter is provided
384             (i.e., a simple string is given), A Bio::Root::Exception
385             is thrown.
386             Returns : n/a
387             Args : A string giving a descriptive error message, optional
388             Named parameters:
389             '-class' a string for the name of a class that derives
390             from Error.pm, such as any of the exceptions
391             defined in Bio::Root::Exception.
392             Default class: Bio::Root::Exception
393             '-text' a string giving a descriptive error message
394             '-value' the value causing the exception, or $! (optional)
395              
396             Thus, if only a string argument is given, and Error.pm is available,
397             this is equivalent to the arguments:
398             -text => "message",
399             -class => Bio::Root::Exception
400             Comments : If Error.pm is installed, and you don't want to use it
401             for some reason, you can block the use of Error.pm by
402             Bio::Root::Root::throw() by defining a scalar named
403             $main::DONT_USE_ERROR (define it in your main script
404             and you don't need the main:: part) and setting it to
405             a true value; you must do this within a BEGIN subroutine.
406              
407             =cut
408              
409             sub throw {
410 142     142 1 1224 my ($self, @args) = @_;
411              
412 142         587 my ($text, $class, $value) = $self->_rearrange( [qw(TEXT
413             CLASS
414             VALUE)], @args);
415 142 100 33     496 $text ||= $args[0] if @args == 1;
416              
417 142 50       303 if ($ERRORLOADED) {
418             # Enable re-throwing of Error objects.
419             # If the error is not derived from Bio::Root::Exception,
420             # we can't guarantee that the Error's value was set properly
421             # and, ipso facto, that it will be catchable from an eval{}.
422             # But chances are, if you're re-throwing non-Bio::Root::Exceptions,
423             # you're probably using Error::try(), not eval{}.
424             # TODO: Fix the MSG: line of the re-thrown error. Has an extra line
425             # containing the '----- EXCEPTION -----' banner.
426 142 50       280 if (ref($args[0])) {
427 0 0       0 if( $args[0]->isa('Error')) {
428 0         0 my $class = ref $args[0];
429 0         0 $class->throw( @args );
430             }
431             else {
432 0         0 my $text .= "\nWARNING: Attempt to throw a non-Error.pm object: " . ref$args[0];
433 0         0 my $class = "Bio::Root::Exception";
434 0         0 $class->throw( '-text' => $text, '-value' => $args[0] );
435             }
436             }
437             else {
438 142   100     453 $class ||= "Bio::Root::Exception";
439              
440 142         139 my %args;
441 142 100 66     463 if( @args % 2 == 0 && $args[0] =~ /^-/ ) {
442 11         31 %args = @args;
443 11         20 $args{-text} = $text;
444 11         20 $args{-object} = $self;
445             }
446              
447 142 100       1175 $class->throw( scalar keys %args > 0 ? %args : @args ); # (%args || @args) puts %args in scalar context!
448             }
449             }
450             else {
451 0   0     0 $class ||= '';
452 0 0       0 $class = ': '.$class if $class;
453 0         0 my $std = $self->stack_trace_dump();
454 0         0 my $title = "------------- EXCEPTION$class -------------";
455 0         0 my $footer = ('-' x CORE::length($title))."\n";
456 0   0     0 $text ||= '';
457              
458 0         0 die "\n$title\n", "MSG: $text\n", $std, $footer, "\n";
459             }
460             }
461              
462             =head2 debug
463              
464             Title : debug
465             Usage : $obj->debug("This is debugging output");
466             Function: Prints a debugging message when verbose is > 0
467             Returns : none
468             Args : message string(s) to print to STDERR
469              
470             =cut
471              
472             sub debug {
473 76642     76642 1 76520 my ($self, @msgs) = @_;
474              
475             # using CORE::warn doesn't give correct backtrace information; we want the
476             # line from the previous call in the call stack, not this call (similar to
477             # cluck). For now, just add a stack trace dump and simple comment under the
478             # correct conditions.
479 76642 50 66     84999 if (defined $self->verbose && $self->verbose > 0) {
480 0 0 0     0 if (!@msgs || $msgs[-1] !~ /\n$/) {
481 0 0       0 push @msgs, "Debugging comment:" if !@msgs;
482 0         0 push @msgs, sprintf("%s %s:%s", @{($self->stack_trace)[2]}[3,1,2])."\n";
  0         0  
483             }
484 0         0 CORE::warn @msgs;
485             }
486             }
487              
488             =head2 _load_module
489              
490             Title : _load_module
491             Usage : $self->_load_module("Bio::SeqIO::genbank");
492             Function: Loads up (like use) the specified module at run time on demand.
493             Example :
494             Returns : TRUE on success. Throws an exception upon failure.
495             Args : The module to load (_without_ the trailing .pm).
496              
497             =cut
498              
499             sub _load_module {
500 8940     8940   10032 my ($self, $name) = @_;
501 8940         7114 my ($module, $load, $m);
502 8940         12660 $module = "_<$name.pm";
503 8940 50       16792 return 1 if $main::{$module};
504              
505             # untaint operation for safe web-based running (modified after
506             # a fix by Lincoln) HL
507 8940 50       29537 if ($name !~ /^([\w:]+)$/) {
508 0         0 $self->throw("$name is an illegal perl package name");
509             } else {
510 8940         17585 $name = $1;
511             }
512              
513 8940         9145 $load = "$name.pm";
514 8940         22530 my $io = Bio::Root::IO->new();
515             # catfile comes from IO
516 8940         28790 $load = $io->catfile((split(/::/,$load)));
517 8940         13094 eval {
518 8940         220704 require $load;
519             };
520 8940 50       15299 if ( $@ ) {
521 0         0 $self->throw("Failed to load module $name. ".$@);
522             }
523 8940         16713 return 1;
524             }
525              
526             =head2 DESTROY
527              
528             =cut
529              
530             sub DESTROY {
531 305105     305105   566502 my $self = shift;
532 305105 100       338164 my @cleanup_methods = $self->_cleanup_methods or return;
533 58620         62465 for my $method (@cleanup_methods) {
534 63061         80256 $method->($self);
535             }
536             }
537              
538             1;