/
Root.pm
456 lines (350 loc) · 13.3 KB
/
Root.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
package Bio::Root::Root;
use strict;
# $Id$
=head1 NAME
Bio::Root::Root - Hash-based implementation of Bio::Root::RootI
=head1 SYNOPSIS
# Any Bioperl-compliant object is a RootI compliant object
# Here's how to throw and catch an exception using the eval-based syntax.
$obj->throw("This is an exception");
eval {
$obj->throw("This is catching an exception");
};
if( $@ ) {
print "Caught exception";
} else {
print "no exception";
}
# Alternatively, using the new typed exception syntax in the throw() call:
$obj->throw( -class => 'Bio::Root::BadParameter',
-text => "Can not open file $file",
-value => $file );
# Want to see debug() outputs for this object
my $obj = Bio::Object->new(-verbose=>1);
my $obj = Bio::Object->new(%args);
$obj->verbose(2);
# Print debug messages which honour current verbosity setting
$obj->debug("Boring output only to be seen if verbose > 0\n");
=head1 DESCRIPTION
This is a hashref-based implementation of the Bio::Root::RootI
interface. Most Bioperl objects should inherit from this.
See the documentation for L<Bio::Root::RootI> for most of the methods
implemented by this module. Only overridden methods are described
here.
=head2 Throwing Exceptions
One of the functionalities that L<Bio::Root::RootI> provides is the
ability to L<throw>() exceptions with pretty stack traces. Bio::Root::Root
enhances this with the ability to use L<Error> (available from CPAN)
if it has also been installed.
If L<Error> has been installed, L<throw>() will use it. This causes an
Error.pm-derived object to be thrown. This can be caught within a
C<catch{}> block, from wich you can extract useful bits of
information. If L<Error> is not installed, it will use the
L<Bio::Root::RootI>-based exception throwing facilty.
=head2 Typed Exception Syntax
The typed exception syntax of L<throw>() has the advantage of plainly
indicating the nature of the trouble, since the name of the class
is included in the title of the exception output.
To take advantage of this capability, you must specify arguments
as named parameters in the L<throw>() call. Here are the parameters:
=over 4
=item -class
name of the class of the exception.
This should be one of the classes defined in L<Bio::Root::Exception>,
or a custom error of yours that extends one of the exceptions
defined in L<Bio::Root::Exception>.
=item -text
a sensible message for the exception
=item -value
the value causing the exception or $!, if appropriate.
=back
Note that Bio::Root::Exception does not need to be imported into
your module (or script) namespace in order to throw exceptions
via Bio::Root::Root::throw(), since Bio::Root::Root imports it.
=head2 Try-Catch-Finally Support
In addition to using an eval{} block to handle exceptions, you can
also use a try-catch-finally block structure if L<Error> has been
installed in your system (available from CPAN). See the documentation
for Error for more details.
Here's an example. See the L<Bio::Root::Exception> module for
other pre-defined exception types:
try {
open( IN, $file) || $obj->throw( -class => 'Bio::Root::FileOpenException',
-text => "Cannot open file $file for reading",
-value => $!);
}
catch Bio::Root::BadParameter with {
my $err = shift; # get the Error object
# Perform specific exception handling code for the FileOpenException
}
catch Bio::Root::Exception with {
my $err = shift; # get the Error object
# Perform general exception handling code for any Bioperl exception.
}
otherwise {
# A catch-all for any other type of exception
}
finally {
# Any code that you want to execute regardless of whether or not
# an exception occurred.
};
# the ending semicolon is essential!
=head1 FEEDBACK
=head2 Mailing Lists
User feedback is an integral part of the evolution of this
and other Bioperl modules. Send your comments and suggestions preferably
to one of the Bioperl mailing lists.
Your participation is much appreciated.
bioperl-l@bioperl.org - General discussion
http://bioperl.org/wiki/Mailing_lists - About the mailing lists
=head2 Support
Please direct usage questions or support issues to the mailing list:
I<bioperl-l@bioperl.org>
rather than to the module maintainer directly. Many experienced and
reponsive experts will be able look at the problem and quickly
address it. Please include a thorough description of the problem
with code and data examples if at all possible.
=head2 Reporting Bugs
Report bugs to the Bioperl bug tracking system to help us keep track
the bugs and their resolution. Bug reports can be submitted via the
web:
http://bugzilla.open-bio.org/
=head1 AUTHOR
Functions originally from Steve Chervitz.
Refactored by Ewan Birney.
Re-refactored by Lincoln Stein.
=head1 APPENDIX
The rest of the documentation details each of the object
methods. Internal methods are usually preceded with a _
=cut
#'
use vars qw($DEBUG $ID $VERBOSITY $ERRORLOADED);
use strict;
use Bio::Root::IO;
use base qw(Bio::Root::RootI);
BEGIN {
$ID = 'Bio::Root::Root';
$DEBUG = 0;
$VERBOSITY = 0;
$ERRORLOADED = 0;
# Check whether or not Error.pm is available.
# $main::DONT_USE_ERROR is intended for testing purposes and also
# when you don't want to use the Error module, even if it is installed.
# Just put a INIT { $DONT_USE_ERROR = 1; } at the top of your script.
if( not $main::DONT_USE_ERROR ) {
if ( eval "require Error" ) {
import Error qw(:try);
require Bio::Root::Exception;
$ERRORLOADED = 1;
$Error::Debug = 1; # enable verbose stack trace
}
}
if( !$ERRORLOADED ) {
require Carp; import Carp qw( confess );
}
$main::DONT_USE_ERROR; # so that perl -w won't warn "used only once"
}
=head2 new
Purpose : generic instantiation function can be overridden if
special needs of a module cannot be done in _initialize
=cut
sub new {
# my ($class, %param) = @_;
my $class = shift;
my $self = {};
bless $self, ref($class) || $class;
if(@_ > 1) {
# if the number of arguments is odd but at least 3, we'll give
# it a try to find -verbose
shift if @_ % 2;
my %param = @_;
## See "Comments" above regarding use of _rearrange().
$self->verbose($param{'-VERBOSE'} || $param{'-verbose'});
}
return $self;
}
=head2 verbose
Title : verbose
Usage : $self->verbose(1)
Function: Sets verbose level for how ->warn behaves
-1 = no warning
0 = standard, small warning
1 = warning with stack trace
2 = warning becomes throw
Returns : The current verbosity setting (integer between -1 to 2)
Args : -1,0,1 or 2
=cut
sub verbose {
my ($self,$value) = @_;
# allow one to set global verbosity flag
return $DEBUG if $DEBUG;
return $VERBOSITY unless ref $self;
if (defined $value || ! defined $self->{'_root_verbose'}) {
$self->{'_root_verbose'} = $value || 0;
}
return $self->{'_root_verbose'};
}
sub _register_for_cleanup {
my ($self,$method) = @_;
if($method) {
if(! exists($self->{'_root_cleanup_methods'})) {
$self->{'_root_cleanup_methods'} = [];
}
push(@{$self->{'_root_cleanup_methods'}},$method);
}
}
sub _unregister_for_cleanup {
my ($self,$method) = @_;
my @methods = grep {$_ ne $method} $self->_cleanup_methods;
$self->{'_root_cleanup_methods'} = \@methods;
}
sub _cleanup_methods {
my $self = shift;
return unless ref $self && $self->isa('HASH');
my $methods = $self->{'_root_cleanup_methods'} or return;
@$methods;
}
=head2 throw
Title : throw
Usage : $obj->throw("throwing exception message");
or
$obj->throw( -class => 'Bio::Root::Exception',
-text => "throwing exception message",
-value => $bad_value );
Function: Throws an exception, which, if not caught with an eval or
a try block will provide a nice stack trace to STDERR
with the message.
If Error.pm is installed, and if a -class parameter is
provided, Error::throw will be used, throwing an error
of the type specified by -class.
If Error.pm is installed and no -class parameter is provided
(i.e., a simple string is given), A Bio::Root::Exception
is thrown.
Returns : n/a
Args : A string giving a descriptive error message, optional
Named parameters:
'-class' a string for the name of a class that derives
from Error.pm, such as any of the exceptions
defined in Bio::Root::Exception.
Default class: Bio::Root::Exception
'-text' a string giving a descriptive error message
'-value' the value causing the exception, or $! (optional)
Thus, if only a string argument is given, and Error.pm is available,
this is equivalent to the arguments:
-text => "message",
-class => Bio::Root::Exception
Comments : If Error.pm is installed, and you don't want to use it
for some reason, you can block the use of Error.pm by
Bio::Root::Root::throw() by defining a scalar named
$main::DONT_USE_ERROR (define it in your main script
and you don't need the main:: part) and setting it to
a true value; you must do this within a BEGIN subroutine.
=cut
sub throw {
my ($self, @args) = @_;
my ($text, $class, $value) = $self->_rearrange( [qw(TEXT
CLASS
VALUE)], @args);
$text ||= $args[0] if @args == 1;
if ($ERRORLOADED) {
# Enable re-throwing of Error objects.
# If the error is not derived from Bio::Root::Exception,
# we can't guarantee that the Error's value was set properly
# and, ipso facto, that it will be catchable from an eval{}.
# But chances are, if you're re-throwing non-Bio::Root::Exceptions,
# you're probably using Error::try(), not eval{}.
# TODO: Fix the MSG: line of the re-thrown error. Has an extra line
# containing the '----- EXCEPTION -----' banner.
if (ref($args[0])) {
if( $args[0]->isa('Error')) {
my $class = ref $args[0];
$class->throw( @args );
}
else {
my $text .= "\nWARNING: Attempt to throw a non-Error.pm object: " . ref$args[0];
my $class = "Bio::Root::Exception";
$class->throw( '-text' => $text, '-value' => $args[0] );
}
}
else {
$class ||= "Bio::Root::Exception";
my %args;
if( @args % 2 == 0 && $args[0] =~ /^-/ ) {
%args = @args;
$args{-text} = $text;
$args{-object} = $self;
}
$class->throw( scalar keys %args > 0 ? %args : @args ); # (%args || @args) puts %args in scalar context!
}
}
else {
$class ||= '';
$class = ' '.$class if $class;
my $std = $self->stack_trace_dump();
my $title = "------------- EXCEPTION$class -------------";
my $footer = ('-' x CORE::length($title))."\n";
$text ||= '';
die "\n$title\n", "MSG: $text\n", $std, $footer, "\n";
}
}
=head2 debug
Title : debug
Usage : $obj->debug("This is debugging output");
Function: Prints a debugging message when verbose is > 0
Returns : none
Args : message string(s) to print to STDERR
=cut
sub debug {
my ($self, @msgs) = @_;
# using CORE::warn doesn't give correct backtrace information; we want the
# line from the previous call in the call stack, not this call (similar to
# cluck). For now, just add a stack trace dump and simple comment under the
# correct conditions.
if (defined $self->verbose && $self->verbose > 0) {
if (!@msgs || $msgs[-1] !~ /\n$/) {
push @msgs, "Debugging comment:" if !@msgs;
push @msgs, sprintf("%s %s:%s", @{($self->stack_trace)[2]}[3,1,2])."\n";
}
CORE::warn @msgs;
}
}
=head2 _load_module
Title : _load_module
Usage : $self->_load_module("Bio::SeqIO::genbank");
Function: Loads up (like use) the specified module at run time on demand.
Example :
Returns : TRUE on success. Throws an exception upon failure.
Args : The module to load (_without_ the trailing .pm).
=cut
sub _load_module {
my ($self, $name) = @_;
my ($module, $load, $m);
$module = "_<$name.pm";
return 1 if $main::{$module};
# untaint operation for safe web-based running (modified after
# a fix by Lincoln) HL
if ($name !~ /^([\w:]+)$/) {
$self->throw("$name is an illegal perl package name");
} else {
$name = $1;
}
$load = "$name.pm";
my $io = Bio::Root::IO->new();
# catfile comes from IO
$load = $io->catfile((split(/::/,$load)));
eval {
require $load;
};
if ( $@ ) {
$self->throw("Failed to load module $name. ".$@);
}
return 1;
}
sub DESTROY {
my $self = shift;
my @cleanup_methods = $self->_cleanup_methods or return;
for my $method (@cleanup_methods) {
$method->($self);
}
}
1;