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