|
0
|
1 package Bio::Root::Root;
|
|
|
2 use strict;
|
|
|
3
|
|
|
4 # $Id: Root.pm,v 1.30 2002/12/16 09:44:28 birney Exp $
|
|
|
5
|
|
|
6 =head1 NAME
|
|
|
7
|
|
|
8 Bio::Root::Root - Hash-based implementation of Bio::Root::RootI
|
|
|
9
|
|
|
10 =head1 SYNOPSIS
|
|
|
11
|
|
|
12 # any bioperl or bioperl compliant object is a RootI
|
|
|
13 # compliant object
|
|
|
14
|
|
|
15 # Here's how to throw and catch an exception using the eval-based syntax.
|
|
|
16
|
|
|
17 $obj->throw("This is an exception");
|
|
|
18
|
|
|
19 eval {
|
|
|
20 $obj->throw("This is catching an exception");
|
|
|
21 };
|
|
|
22
|
|
|
23 if( $@ ) {
|
|
|
24 print "Caught exception";
|
|
|
25 } else {
|
|
|
26 print "no exception";
|
|
|
27 }
|
|
|
28
|
|
|
29 # Alternatively, using the new typed exception syntax in the throw() call:
|
|
|
30
|
|
|
31 $obj->throw( -class => 'Bio::Root::BadParameter',
|
|
|
32 -text => "Can't open file $file",
|
|
|
33 -value => $file);
|
|
|
34
|
|
|
35 # Exceptions can be used in an eval{} block as shown above or within
|
|
|
36 # a try{} block if you have installed the Error.pm module.
|
|
|
37 # Here's a brief example. For more, see Bio::Root::Exception
|
|
|
38
|
|
|
39 use Error qw(:try);
|
|
|
40
|
|
|
41 try {
|
|
|
42 $obj->throw( # arguments as above );
|
|
|
43 }
|
|
|
44 catch Bio::Root::FileOpenException with {
|
|
|
45 my $err = shift;
|
|
|
46 print "Handling exception $err\n";
|
|
|
47 };
|
|
|
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 Bio::Root::RootI 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 Bio::Root::RootI provides is the
|
|
|
61 ability to throw() exceptions with pretty stack traces. Bio::Root::Root
|
|
|
62 enhances this with the ability to use B<Error.pm> (available from CPAN)
|
|
|
63 if it has also been installed.
|
|
|
64
|
|
|
65 If Error.pm has been installed, throw() will use it. This causes an
|
|
|
66 Error.pm-derived object to be thrown. This can be caught within a
|
|
|
67 C<catch{}> block, from wich you can extract useful bits of
|
|
|
68 information. If Error.pm is not installed, it will use the
|
|
|
69 Bio::Root::RootI-based exception throwing facilty.
|
|
|
70
|
|
|
71 =head2 Typed Exception Syntax
|
|
|
72
|
|
|
73 The typed exception syntax of throw() 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 throw() 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 B<Bio::Root::Exception>,
|
|
|
86 or a custom error of yours that extends one of the exceptions
|
|
|
87 defined in B<Bio::Root::Exception>.
|
|
|
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 B<Error.pm> 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 B<Bio::Root::Exception> module for
|
|
|
111 other pre-defined exception types:
|
|
|
112
|
|
|
113 try {
|
|
|
114 open( IN, $file) || $obj->throw( -class => 'Bio::Root::FileOpenException',
|
|
|
115 -text => "Cannot open file $file for reading",
|
|
|
116 -value => $!);
|
|
|
117 }
|
|
|
118 catch Bio::Root::BadParameter with {
|
|
|
119 my $err = shift; # get the Error object
|
|
|
120 # Perform specific exception handling code for the FileOpenException
|
|
|
121 }
|
|
|
122 catch Bio::Root::Exception with {
|
|
|
123 my $err = shift; # get the Error object
|
|
|
124 # Perform general exception handling code for any Bioperl exception.
|
|
|
125 }
|
|
|
126 otherwise {
|
|
|
127 # A catch-all for any other type of exception
|
|
|
128 }
|
|
|
129 finally {
|
|
|
130 # Any code that you want to execute regardless of whether or not
|
|
|
131 # an exception occurred.
|
|
|
132 };
|
|
|
133 # the ending semicolon is essential!
|
|
|
134
|
|
|
135
|
|
|
136 =head1 CONTACT
|
|
|
137
|
|
|
138 Functions originally from Steve Chervitz. Refactored by Ewan Birney.
|
|
|
139 Re-refactored by Lincoln Stein.
|
|
|
140
|
|
|
141 =head1 APPENDIX
|
|
|
142
|
|
|
143 The rest of the documentation details each of the object
|
|
|
144 methods. Internal methods are usually preceded with a _
|
|
|
145
|
|
|
146 =cut
|
|
|
147
|
|
|
148 #'
|
|
|
149
|
|
|
150 use vars qw(@ISA $DEBUG $ID $Revision $VERSION $VERBOSITY $ERRORLOADED);
|
|
|
151 use strict;
|
|
|
152 use Bio::Root::RootI;
|
|
|
153 use Bio::Root::IO;
|
|
|
154
|
|
|
155 @ISA = 'Bio::Root::RootI';
|
|
|
156
|
|
|
157 BEGIN {
|
|
|
158
|
|
|
159 $ID = 'Bio::Root::Root';
|
|
|
160 $VERSION = 1.0;
|
|
|
161 $Revision = '$Id: Root.pm,v 1.30 2002/12/16 09:44:28 birney Exp $ ';
|
|
|
162 $DEBUG = 0;
|
|
|
163 $VERBOSITY = 0;
|
|
|
164 $ERRORLOADED = 0;
|
|
|
165
|
|
|
166 # Check whether or not Error.pm is available.
|
|
|
167
|
|
|
168 # $main::DONT_USE_ERROR is intended for testing purposes and also
|
|
|
169 # when you don't want to use the Error module, even if it is installed.
|
|
|
170 # Just put a INIT { $DONT_USE_ERROR = 1; } at the top of your script.
|
|
|
171 if( not $main::DONT_USE_ERROR ) {
|
|
|
172 if ( eval "require Error" ) {
|
|
|
173 import Error qw(:try);
|
|
|
174 require Bio::Root::Exception;
|
|
|
175 $ERRORLOADED = 1;
|
|
|
176 $Error::Debug = 1; # enable verbose stack trace
|
|
|
177 }
|
|
|
178 }
|
|
|
179 if( !$ERRORLOADED ) {
|
|
|
180 require Carp; import Carp qw( confess );
|
|
|
181 }
|
|
|
182 $main::DONT_USE_ERROR; # so that perl -w won't warn "used only once"
|
|
|
183
|
|
|
184 }
|
|
|
185
|
|
|
186
|
|
|
187
|
|
|
188 =head2 new
|
|
|
189
|
|
|
190 Purpose : generic instantiation function can be overridden if
|
|
|
191 special needs of a module cannot be done in _initialize
|
|
|
192
|
|
|
193 =cut
|
|
|
194
|
|
|
195 sub new {
|
|
|
196 # my ($class, %param) = @_;
|
|
|
197 my $class = shift;
|
|
|
198 my $self = {};
|
|
|
199 bless $self, ref($class) || $class;
|
|
|
200
|
|
|
201 if(@_ > 1) {
|
|
|
202 # if the number of arguments is odd but at least 3, we'll give
|
|
|
203 # it a try to find -verbose
|
|
|
204 shift if @_ % 2;
|
|
|
205 my %param = @_;
|
|
|
206 ## See "Comments" above regarding use of _rearrange().
|
|
|
207 $self->verbose($param{'-VERBOSE'} || $param{'-verbose'});
|
|
|
208 }
|
|
|
209 return $self;
|
|
|
210 }
|
|
|
211
|
|
|
212
|
|
|
213 =head2 verbose
|
|
|
214
|
|
|
215 Title : verbose
|
|
|
216 Usage : $self->verbose(1)
|
|
|
217 Function: Sets verbose level for how ->warn behaves
|
|
|
218 -1 = no warning
|
|
|
219 0 = standard, small warning
|
|
|
220 1 = warning with stack trace
|
|
|
221 2 = warning becomes throw
|
|
|
222 Returns : The current verbosity setting (integer between -1 to 2)
|
|
|
223 Args : -1,0,1 or 2
|
|
|
224
|
|
|
225
|
|
|
226 =cut
|
|
|
227
|
|
|
228 sub verbose {
|
|
|
229 my ($self,$value) = @_;
|
|
|
230 # allow one to set global verbosity flag
|
|
|
231 return $DEBUG if $DEBUG;
|
|
|
232 return $VERBOSITY unless ref $self;
|
|
|
233
|
|
|
234 if (defined $value || ! defined $self->{'_root_verbose'}) {
|
|
|
235 $self->{'_root_verbose'} = $value || 0;
|
|
|
236 }
|
|
|
237 return $self->{'_root_verbose'};
|
|
|
238 }
|
|
|
239
|
|
|
240 sub _register_for_cleanup {
|
|
|
241 my ($self,$method) = @_;
|
|
|
242 if($method) {
|
|
|
243 if(! exists($self->{'_root_cleanup_methods'})) {
|
|
|
244 $self->{'_root_cleanup_methods'} = [];
|
|
|
245 }
|
|
|
246 push(@{$self->{'_root_cleanup_methods'}},$method);
|
|
|
247 }
|
|
|
248 }
|
|
|
249
|
|
|
250 sub _unregister_for_cleanup {
|
|
|
251 my ($self,$method) = @_;
|
|
|
252 my @methods = grep {$_ ne $method} $self->_cleanup_methods;
|
|
|
253 $self->{'_root_cleanup_methods'} = \@methods;
|
|
|
254 }
|
|
|
255
|
|
|
256
|
|
|
257 sub _cleanup_methods {
|
|
|
258 my $self = shift;
|
|
|
259 return unless ref $self && $self->isa('HASH');
|
|
|
260 my $methods = $self->{'_root_cleanup_methods'} or return;
|
|
|
261 @$methods;
|
|
|
262
|
|
|
263 }
|
|
|
264
|
|
|
265 =head2 throw
|
|
|
266
|
|
|
267 Title : throw
|
|
|
268 Usage : $obj->throw("throwing exception message");
|
|
|
269 or
|
|
|
270 $obj->throw( -class => 'Bio::Root::Exception',
|
|
|
271 -text => "throwing exception message",
|
|
|
272 -value => $bad_value );
|
|
|
273 Function: Throws an exception, which, if not caught with an eval or
|
|
|
274 a try block will provide a nice stack trace to STDERR
|
|
|
275 with the message.
|
|
|
276 If Error.pm is installed, and if a -class parameter is
|
|
|
277 provided, Error::throw will be used, throwing an error
|
|
|
278 of the type specified by -class.
|
|
|
279 If Error.pm is installed and no -class parameter is provided
|
|
|
280 (i.e., a simple string is given), A Bio::Root::Exception
|
|
|
281 is thrown.
|
|
|
282 Returns : n/a
|
|
|
283 Args : A string giving a descriptive error message, optional
|
|
|
284 Named parameters:
|
|
|
285 '-class' a string for the name of a class that derives
|
|
|
286 from Error.pm, such as any of the exceptions
|
|
|
287 defined in Bio::Root::Exception.
|
|
|
288 Default class: Bio::Root::Exception
|
|
|
289 '-text' a string giving a descriptive error message
|
|
|
290 '-value' the value causing the exception, or $! (optional)
|
|
|
291
|
|
|
292 Thus, if only a string argument is given, and Error.pm is available,
|
|
|
293 this is equivalent to the arguments:
|
|
|
294 -text => "message",
|
|
|
295 -class => Bio::Root::Exception
|
|
|
296 Comments : If Error.pm is installed, and you don't want to use it
|
|
|
297 for some reason, you can block the use of Error.pm by
|
|
|
298 Bio::Root::Root::throw() by defining a scalar named
|
|
|
299 $main::DONT_USE_ERROR (define it in your main script
|
|
|
300 and you don't need the main:: part) and setting it to
|
|
|
301 a true value; you must do this within a BEGIN subroutine.
|
|
|
302
|
|
|
303 =cut
|
|
|
304
|
|
|
305 #'
|
|
|
306
|
|
|
307 sub throw{
|
|
|
308 my ($self,@args) = @_;
|
|
|
309
|
|
|
310 my ( $text, $class ) = $self->_rearrange( [qw(TEXT CLASS)], @args);
|
|
|
311
|
|
|
312 if( $ERRORLOADED ) {
|
|
|
313 # print STDERR " Calling Error::throw\n\n";
|
|
|
314
|
|
|
315 # Enable re-throwing of Error objects.
|
|
|
316 # If the error is not derived from Bio::Root::Exception,
|
|
|
317 # we can't guarantee that the Error's value was set properly
|
|
|
318 # and, ipso facto, that it will be catchable from an eval{}.
|
|
|
319 # But chances are, if you're re-throwing non-Bio::Root::Exceptions,
|
|
|
320 # you're probably using Error::try(), not eval{}.
|
|
|
321 # TODO: Fix the MSG: line of the re-thrown error. Has an extra line
|
|
|
322 # containing the '----- EXCEPTION -----' banner.
|
|
|
323 if( ref($args[0])) {
|
|
|
324 if( $args[0]->isa('Error')) {
|
|
|
325 my $class = ref $args[0];
|
|
|
326 throw $class ( @args );
|
|
|
327 } else {
|
|
|
328 my $text .= "\nWARNING: Attempt to throw a non-Error.pm object: " . ref$args[0];
|
|
|
329 my $class = "Bio::Root::Exception";
|
|
|
330 throw $class ( '-text' => $text, '-value' => $args[0] );
|
|
|
331 }
|
|
|
332 } else {
|
|
|
333 $class ||= "Bio::Root::Exception";
|
|
|
334
|
|
|
335 my %args;
|
|
|
336 if( @args % 2 == 0 && $args[0] =~ /^-/ ) {
|
|
|
337 %args = @args;
|
|
|
338 $args{-text} = $text;
|
|
|
339 $args{-object} = $self;
|
|
|
340 }
|
|
|
341
|
|
|
342 throw $class ( scalar keys %args > 0 ? %args : @args ); # (%args || @args) puts %args in scalar context!
|
|
|
343 }
|
|
|
344 }
|
|
|
345 else {
|
|
|
346 # print STDERR " Not calling Error::throw\n\n";
|
|
|
347 $class ||= '';
|
|
|
348 my $std = $self->stack_trace_dump();
|
|
|
349 my $title = "------------- EXCEPTION $class -------------";
|
|
|
350 my $footer = "\n" . '-' x CORE::length($title);
|
|
|
351 $text ||= '';
|
|
|
352
|
|
|
353 my $out = "\n$title\n" .
|
|
|
354 "MSG: $text\n". $std . $footer . "\n";
|
|
|
355
|
|
|
356 die $out;
|
|
|
357 }
|
|
|
358 }
|
|
|
359
|
|
|
360 =head2 debug
|
|
|
361
|
|
|
362 Title : debug
|
|
|
363 Usage : $obj->debug("This is debugging output");
|
|
|
364 Function: Prints a debugging message when verbose is > 0
|
|
|
365 Returns : none
|
|
|
366 Args : message string(s) to print to STDERR
|
|
|
367
|
|
|
368 =cut
|
|
|
369
|
|
|
370 sub debug{
|
|
|
371 my ($self,@msgs) = @_;
|
|
|
372
|
|
|
373 if( $self->verbose > 0 ) {
|
|
|
374 print STDERR join("", @msgs);
|
|
|
375 }
|
|
|
376 }
|
|
|
377
|
|
|
378 =head2 _load_module
|
|
|
379
|
|
|
380 Title : _load_module
|
|
|
381 Usage : $self->_load_module("Bio::SeqIO::genbank");
|
|
|
382 Function: Loads up (like use) the specified module at run time on demand.
|
|
|
383 Example :
|
|
|
384 Returns : TRUE on success. Throws an exception upon failure.
|
|
|
385 .
|
|
|
386 Args : The module to load (_without_ the trailing .pm).
|
|
|
387
|
|
|
388 =cut
|
|
|
389
|
|
|
390 sub _load_module {
|
|
|
391 my ($self, $name) = @_;
|
|
|
392 my ($module, $load, $m);
|
|
|
393 $module = "_<$name.pm";
|
|
|
394 return 1 if $main::{$module};
|
|
|
395
|
|
|
396 # untaint operation for safe web-based running (modified after a fix
|
|
|
397 # a fix by Lincoln) HL
|
|
|
398 if ($name !~ /^([\w:]+)$/) {
|
|
|
399 $self->throw("$name is an illegal perl package name");
|
|
|
400 }
|
|
|
401
|
|
|
402 $load = "$name.pm";
|
|
|
403 my $io = Bio::Root::IO->new();
|
|
|
404 # catfile comes from IO
|
|
|
405 $load = $io->catfile((split(/::/,$load)));
|
|
|
406 eval {
|
|
|
407 require $load;
|
|
|
408 };
|
|
|
409 if ( $@ ) {
|
|
|
410 $self->throw("Failed to load module $name. ".$@);
|
|
|
411 }
|
|
|
412 return 1;
|
|
|
413 }
|
|
|
414
|
|
|
415
|
|
|
416 sub DESTROY {
|
|
|
417 my $self = shift;
|
|
|
418 my @cleanup_methods = $self->_cleanup_methods or return;
|
|
|
419 for my $method (@cleanup_methods) {
|
|
|
420 $method->($self);
|
|
|
421 }
|
|
|
422 }
|
|
|
423
|
|
|
424
|
|
|
425
|
|
|
426 1;
|
|
|
427
|
