← Index
NYTProf Performance Profile   « block view • line view • sub view »
For bin/pan_genome_post_analysis
  Run on Fri Mar 27 11:43:32 2015
Reported on Fri Mar 27 11:46:08 2015

Filename/Users/ap13/perl5/lib/perl5/Bio/Root/RootI.pm
StatementsExecuted 18 statements in 1.74ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11115µs31µsBio::Root::RootI::::BEGIN@2Bio::Root::RootI::BEGIN@2
11112µs64µsBio::Root::RootI::::BEGIN@84Bio::Root::RootI::BEGIN@84
11110µs22µsBio::Root::RootI::::BEGIN@242Bio::Root::RootI::BEGIN@242
11110µs20µsBio::Root::RootI::::BEGIN@562Bio::Root::RootI::BEGIN@562
1119µs22µsBio::Root::RootI::::BEGIN@227Bio::Root::RootI::BEGIN@227
1118µs19µsBio::Root::RootI::::BEGIN@549Bio::Root::RootI::BEGIN@549
1118µs36µsBio::Root::RootI::::BEGIN@3Bio::Root::RootI::BEGIN@3
1114µs4µsBio::Root::RootI::::BEGIN@85Bio::Root::RootI::BEGIN@85
0000s0sBio::Root::RootI::::_cleanup_methodsBio::Root::RootI::_cleanup_methods
0000s0sBio::Root::RootI::::_initializeBio::Root::RootI::_initialize
0000s0sBio::Root::RootI::::_not_implemented_msgBio::Root::RootI::_not_implemented_msg
0000s0sBio::Root::RootI::::_rearrangeBio::Root::RootI::_rearrange
0000s0sBio::Root::RootI::::_rearrange_oldBio::Root::RootI::_rearrange_old
0000s0sBio::Root::RootI::::_register_for_cleanupBio::Root::RootI::_register_for_cleanup
0000s0sBio::Root::RootI::::_set_from_argsBio::Root::RootI::_set_from_args
0000s0sBio::Root::RootI::::_unregister_for_cleanupBio::Root::RootI::_unregister_for_cleanup
0000s0sBio::Root::RootI::::deprecatedBio::Root::RootI::deprecated
0000s0sBio::Root::RootI::::newBio::Root::RootI::new
0000s0sBio::Root::RootI::::stack_traceBio::Root::RootI::stack_trace
0000s0sBio::Root::RootI::::stack_trace_dumpBio::Root::RootI::stack_trace_dump
0000s0sBio::Root::RootI::::throwBio::Root::RootI::throw
0000s0sBio::Root::RootI::::throw_not_implementedBio::Root::RootI::throw_not_implemented
0000s0sBio::Root::RootI::::warnBio::Root::RootI::warn
0000s0sBio::Root::RootI::::warn_not_implementedBio::Root::RootI::warn_not_implemented
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Bio::Root::RootI;
2237µs248µs
# spent 31µs (15+17) within Bio::Root::RootI::BEGIN@2 which was called: # once (15µs+17µs) by base::import at line 2
use strict;
# spent 31µs making 1 call to Bio::Root::RootI::BEGIN@2 # spent 17µs making 1 call to strict::import
3255µs265µs
# spent 36µs (8+28) within Bio::Root::RootI::BEGIN@3 which was called: # once (8µs+28µs) by base::import at line 3
use Carp 'confess','carp';
# spent 36µs making 1 call to Bio::Root::RootI::BEGIN@3 # spent 28µs making 1 call to Exporter::import
4
5# ABSTRACT: abstract interface to root object code
6# AUTHOR: Steve Chervitz <sac@bioperl.org>
7# AUTHOR: Ewan Birney <birney@ebi.ac.uk>
8# AUTHOR: Lincoln Stein
9# OWNER: Steve Chervitz
10# OWNER: Ewan Birney
11# OWNER: Lincoln Stein
12# LICENSE: Perl_5
13
14# CONTRIBUTOR: Sendu Bala <bix@sendu.me.uk>
15# CONTRIBUTOR: Jason Stajich
16
17=head1 SYNOPSIS
18
19 # any bioperl or bioperl compliant object is a RootI
20 # compliant object
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 # Using throw_not_implemented() within a RootI-based interface module:
35
36 package Foo;
37 use base qw(Bio::Root::RootI);
38
39 sub foo {
40 my $self = shift;
41 $self->throw_not_implemented;
42 }
43
44
45=head1 DESCRIPTION
46
47This is just a set of methods which do not assume B<anything> about the object
48they are on. The methods provide the ability to throw exceptions with nice
49stack traces.
50
51This is what should be inherited by all Bioperl compliant interfaces, even
52if they are exotic XS/CORBA/Other perl systems.
53
54=head2 Using throw_not_implemented()
55
56The method L<throw_not_implemented()|throw_not_implemented> should be
57called by all methods within interface modules that extend RootI so
58that if an implementation fails to override them, an exception will be
59thrown.
60
61For example, say there is an interface module called C<FooI> that
62provides a method called C<foo()>. Since this method is considered
63abstract within FooI and should be implemented by any module claiming to
64implement C<FooI>, the C<FooI::foo()> method should consist of the
65following:
66
67 sub foo {
68 my $self = shift;
69 $self->throw_not_implemented;
70 }
71
72So, if an implementer of C<FooI> forgets to implement C<foo()>
73and a user of the implementation calls C<foo()>, a
74L<Bio::Exception::NotImplemented> exception will result.
75
76Unfortunately, failure to implement a method can only be determined at
77run time (i.e., you can't verify that an implementation is complete by
78running C<perl -wc> on it). So it should be standard practice for a test
79of an implementation to check each method and verify that it doesn't
80throw a L<Bio::Exception::NotImplemented>.
81
82=cut
83
84238µs2117µs
# spent 64µs (12+53) within Bio::Root::RootI::BEGIN@84 which was called: # once (12µs+53µs) by base::import at line 84
use vars qw($DEBUG $ID $VERBOSITY);
# spent 64µs making 1 call to Bio::Root::RootI::BEGIN@84 # spent 53µs making 1 call to vars::import
85
# spent 4µs within Bio::Root::RootI::BEGIN@85 which was called: # once (4µs+0s) by base::import at line 89
BEGIN {
861400ns $ID = 'Bio::Root::RootI';
871100ns $DEBUG = 0;
8813µs $VERBOSITY = 0;
891318µs14µs}
# spent 4µs making 1 call to Bio::Root::RootI::BEGIN@85
90
91=head2 new
92
93=cut
94
95sub new {
96 my $class = shift;
97 my @args = @_;
98 unless ( $ENV{'BIOPERLDEBUG'} ) {
99 carp("Use of new in Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead");
100 }
101 eval "require Bio::Root::Root";
102 return Bio::Root::Root->new(@args);
103}
104
105# for backwards compatibility
106sub _initialize {
107 my($self,@args) = @_;
108 return 1;
109}
110
111
112=head2 throw
113
114 Title : throw
115 Usage : $obj->throw("throwing exception message")
116 Function: Throws an exception, which, if not caught with an eval brace
117 will provide a nice stack trace to STDERR with the message
118 Returns : nothing
119 Args : A string giving a descriptive error message
120
121
122=cut
123
124sub throw{
125 my ($self,$string) = @_;
126
127 my $std = $self->stack_trace_dump();
128
129 my $out = "\n-------------------- EXCEPTION --------------------\n"
130 . "MSG: " . $string . "\n"
131 . $std."-------------------------------------------\n";
132 die $out;
133}
134
135=head2 warn
136
137 Title : warn
138 Usage : $object->warn("Warning message");
139 Function: Places a warning. What happens now is down to the
140 verbosity of the object (value of $obj->verbose)
141 verbosity 0 or not set => small warning
142 verbosity -1 => no warning
143 verbosity 1 => warning with stack trace
144 verbosity 2 => converts warnings into throw
145 Returns : n/a
146 Args : string (the warning message)
147
148=cut
149
150sub warn {
151 my ($self,$string) = @_;
152
153 my $verbose = $self->verbose;
154
155 my $header = "\n--------------------- WARNING ---------------------\nMSG: ";
156 my $footer = "---------------------------------------------------\n";
157
158 if ($verbose >= 2) {
159 $self->throw($string);
160 }
161 elsif ($verbose <= -1) {
162 return;
163 }
164 elsif ($verbose == 1) {
165 CORE::warn $header, $string, "\n", $self->stack_trace_dump, $footer;
166 return;
167 }
168
169 CORE::warn $header, $string, "\n", $footer;
170}
171
172=head2 deprecated
173
174 Title : deprecated
175 Usage : $obj->deprecated("Method X is deprecated");
176 $obj->deprecated("Method X is deprecated", 1.007);
177 $obj->deprecated(-message => "Method X is deprecated");
178 $obj->deprecated(-message => "Method X is deprecated",
179 -version => 1.007);
180 Function: Prints a message about deprecation unless verbose is < 0
181 (which means be quiet)
182 Returns : none
183 Args : Message string to print to STDERR
184 Version of BioPerl where use of the method results in an exception
185 Notes : The method can be called two ways, either by positional arguments:
186
187 $obj->deprecated('This module is deprecated', 1.006);
188
189 or by named arguments:
190
191 $obj->deprecated(
192 -message => 'use of the method foo() is deprecated, use bar() instead',
193 -version => 1.006 # throw if $VERSION is >= this version
194 );
195
196 or timed to go off at a certain point:
197
198 $obj->deprecated(
199 -message => 'use of the method foo() is deprecated, use bar() instead',
200 -warn_version => 1.006 # warn if $VERSION is >= this version
201 -throw_version => 1.007 # throw if $VERSION is >= this version
202 );
203
204 Using the last two named argument versions is suggested and will
205 likely be the only supported way of calling this method in the future
206 Yes, we see the irony of deprecating that particular usage of
207 deprecated().
208
209 The main difference between usage of the two named argument versions
210 is that by designating a 'warn_version' one indicates the
211 functionality is officially deprecated beginning in a future version
212 of BioPerl (so warnings are issued only after that point), whereas
213 setting either 'version' or 'throw_version' (synonyms) converts the
214 deprecation warning to an exception.
215
216 For proper comparisons one must use a version in lines with the
217 current versioning scheme for Perl and BioPerl, (i.e. where 1.006000
218 indicates v1.6.0, 5.010000 for v5.10.0, etc.).
219
220=cut
221
222sub deprecated{
223 my ($self) = shift;
224
225 my $class = ref $self || $self;
226 my $class_version = do {
227296µs234µs
# spent 22µs (9+12) within Bio::Root::RootI::BEGIN@227 which was called: # once (9µs+12µs) by base::import at line 227
no strict 'refs';
# spent 22µs making 1 call to Bio::Root::RootI::BEGIN@227 # spent 12µs making 1 call to strict::unimport
228 ${"${class}::VERSION"}
229 };
230
231 if( $class_version && $class_version =~ /set by/ ) {
232 $class_version = 0.0001;
233 }
234
235 my ($msg, $version, $warn_version, $throw_version) =
236 $self->_rearrange([qw(MESSAGE VERSION WARN_VERSION THROW_VERSION)], @_);
237
238 $throw_version ||= $version;
239 $warn_version ||= $class_version;
240
241 for my $v ( $warn_version, $throw_version) {
2422631µs234µs
# spent 22µs (10+12) within Bio::Root::RootI::BEGIN@242 which was called: # once (10µs+12µs) by base::import at line 242
no warnings 'numeric';
# spent 22µs making 1 call to Bio::Root::RootI::BEGIN@242 # spent 12µs making 1 call to warnings::unimport
243 $self->throw("Version must be numerical, such as 1.006000 for v1.6.0, not $v")
244 unless !defined $v || $v + 0 eq $v;
245 }
246
247 # below default insinuates we're deprecating a method and not a full module
248 # but it's the most common use case
249 $msg ||= "Use of ".(caller(1))[3]."() is deprecated.";
250
251 if( $throw_version && $class_version && $class_version >= $throw_version ) {
252 $self->throw($msg)
253 }
254 elsif( $warn_version && $class_version && $class_version >= $warn_version ) {
255
256 $msg .= "\nTo be removed in $throw_version." if $throw_version;
257
258 # passing this on to warn() should deal properly with verbosity issues
259 $self->warn($msg);
260 }
261}
262
263=head2 stack_trace_dump
264
265 Title : stack_trace_dump
266 Usage :
267 Function:
268 Example :
269 Returns :
270 Args :
271
272
273=cut
274
275sub stack_trace_dump{
276 my ($self) = @_;
277
278 my @stack = $self->stack_trace();
279
280 shift @stack;
281 shift @stack;
282 shift @stack;
283
284 my $out;
285 my ($module,$function,$file,$position);
286
287
288 foreach my $stack ( @stack) {
289 ($module,$file,$position,$function) = @{$stack};
290 $out .= "STACK $function $file:$position\n";
291 }
292
293 return $out;
294}
295
296
297=head2 stack_trace
298
299 Title : stack_trace
300 Usage : @stack_array_ref= $self->stack_trace
301 Function: gives an array to a reference of arrays with stack trace info
302 each coming from the caller(stack_number) call
303 Returns : array containing a reference of arrays
304 Args : none
305
306
307=cut
308
309sub stack_trace{
310 my ($self) = @_;
311
312 my $i = 0;
313 my @out = ();
314 my $prev = [];
315 while( my @call = caller($i++)) {
316 # major annoyance that caller puts caller context as
317 # function name. Hence some monkeying around...
318 $prev->[3] = $call[3];
319 push(@out,$prev);
320 $prev = \@call;
321 }
322 $prev->[3] = 'toplevel';
323 push(@out,$prev);
324 return @out;
325}
326
327
328=head2 _rearrange
329
330 Usage : $object->_rearrange( array_ref, list_of_arguments)
331 Purpose : Rearranges named parameters to requested order.
332 Example : $self->_rearrange([qw(SEQUENCE ID DESC)],@param);
333 : Where @param = (-sequence => $s,
334 : -desc => $d,
335 : -id => $i);
336 Returns : @params - an array of parameters in the requested order.
337 : The above example would return ($s, $i, $d).
338 : Unspecified parameters will return undef. For example, if
339 : @param = (-sequence => $s);
340 : the above _rearrange call would return ($s, undef, undef)
341 Argument : $order : a reference to an array which describes the desired
342 : order of the named parameters.
343 : @param : an array of parameters, either as a list (in
344 : which case the function simply returns the list),
345 : or as an associative array with hyphenated tags
346 : (in which case the function sorts the values
347 : according to @{$order} and returns that new array.)
348 : The tags can be upper, lower, or mixed case
349 : but they must start with a hyphen (at least the
350 : first one should be hyphenated.)
351 Source : This function was taken from CGI.pm, written by Dr. Lincoln
352 : Stein, and adapted for use in Bio::Seq by Richard Resnick and
353 : then adapted for use in Bio::Root::Object.pm by Steve Chervitz,
354 : then migrated into Bio::Root::RootI.pm by Ewan Birney.
355 Comments :
356 : Uppercase tags are the norm,
357 : (SAC)
358 : This method may not be appropriate for method calls that are
359 : within in an inner loop if efficiency is a concern.
360 :
361 : Parameters can be specified using any of these formats:
362 : @param = (-name=>'me', -color=>'blue');
363 : @param = (-NAME=>'me', -COLOR=>'blue');
364 : @param = (-Name=>'me', -Color=>'blue');
365 : @param = ('me', 'blue');
366 : A leading hyphenated argument is used by this function to
367 : indicate that named parameters are being used.
368 : Therefore, the ('me', 'blue') list will be returned as-is.
369 :
370 : Note that Perl will confuse unquoted, hyphenated tags as
371 : function calls if there is a function of the same name
372 : in the current namespace:
373 : -name => 'foo' is interpreted as -&name => 'foo'
374 :
375 : For ultimate safety, put single quotes around the tag:
376 : ('-name'=>'me', '-color' =>'blue');
377 : This can be a bit cumbersome and I find not as readable
378 : as using all uppercase, which is also fairly safe:
379 : (-NAME=>'me', -COLOR =>'blue');
380 :
381 : Personal note (SAC): I have found all uppercase tags to
382 : be more manageable: it involves less single-quoting,
383 : the key names stand out better, and there are no method naming
384 : conflicts.
385 : The drawbacks are that it's not as easy to type as lowercase,
386 : and lots of uppercase can be hard to read.
387 :
388 : Regardless of the style, it greatly helps to line
389 : the parameters up vertically for long/complex lists.
390 :
391 : Note that if @param is a single string that happens to start with
392 : a dash, it will be treated as a hash key and probably fail to
393 : match anything in the array_ref, so not be returned as normally
394 : happens when @param is a simple list and not an associative array.
395
396=cut
397
398sub _rearrange {
399 my ($self, $order, @args) = @_;
400
401 return @args unless $args[0] && $args[0] =~ /^\-/;
402
403 push @args, undef unless $#args % 2;
404
405 my %param;
406 for( my $i = 0; $i < @args; $i += 2 ) {
407 (my $key = $args[$i]) =~ tr/a-z\055/A-Z/d; #deletes all dashes!
408 $param{$key} = $args[$i+1];
409 }
410 return @param{map uc, @$order};
411}
412
413=head2 _set_from_args
414
415 Usage : $object->_set_from_args(\%args, -methods => \@methods)
416 Purpose : Takes a hash of user-supplied args whose keys match method names,
417 : and calls the method supplying it the corresponding value.
418 Example : $self->_set_from_args(\%args, -methods => [qw(sequence id desc)]);
419 : Where %args = (-sequence => $s,
420 : -description => $d,
421 : -ID => $i);
422 :
423 : the above _set_from_args calls the following methods:
424 : $self->sequence($s);
425 : $self->id($i);
426 : ( $self->description($i) is not called because 'description' wasn't
427 : one of the given methods )
428 Argument : \%args | \@args : a hash ref or associative array ref of arguments
429 : where keys are any-case strings corresponding to
430 : method names but optionally prefixed with
431 : hyphens, and values are the values the method
432 : should be supplied. If keys contain internal
433 : hyphens (eg. to separate multi-word args) they
434 : are converted to underscores, since method names
435 : cannot contain dashes.
436 : -methods => [] : (optional) only call methods with names in this
437 : array ref. Can instead supply a hash ref where
438 : keys are method names (of real existing methods
439 : unless -create is in effect) and values are array
440 : refs of synonyms to allow access to the method
441 : using synonyms. If there is only one synonym it
442 : can be supplied as a string instead of a single-
443 : element array ref
444 : -force => bool : (optional, default 0) call methods that don't
445 : seem to exist, ie. let AUTOLOAD handle them
446 : -create => bool : (optional, default 0) when a method doesn't
447 : exist, create it as a simple getter/setter
448 : (combined with -methods it would create all the
449 : supplied methods that didn't exist, even if not
450 : mentioned in the supplied %args)
451 : -code => '' | {}: (optional) when creating methods use the supplied
452 : code (a string which will be evaulated as a sub).
453 : The default code is a simple get/setter.
454 : Alternatively you can supply a hash ref where
455 : the keys are method names and the values are
456 : code strings. The variable '$method' will be
457 : available at evaluation time, so can be used in
458 : your code strings. Beware that the strict pragma
459 : will be in effect.
460 : -case_sensitive => bool : require case sensitivity on the part of
461 : user (ie. a() and A() are two different
462 : methods and the user must be careful
463 : which they use).
464 Comments :
465 : The \%args argument will usually be the args received during new()
466 : from the user. The user is allowed to get the case wrong, include
467 : 0 or more than one hyphens as a prefix, and to include hyphens as
468 : multi-word arg separators: '--an-arg' => 1, -an_arg => 1 and
469 : An_Arg => 1 are all equivalent, calling an_arg(1). However, in
470 : documentation users should only be told to use the standard form
471 : -an_arg to avoid confusion. A possible exception to this is a
472 : wrapper module where '--an-arg' is what the user is used to
473 : supplying to the program being wrapped.
474 :
475 : Another issue with wrapper modules is that there may be an
476 : argument that has meaning both to Bioperl and to the program, eg.
477 : -verbose. The recommended way of dealing with this is to leave
478 : -verbose to set the Bioperl verbosity whilst requesting users use
479 : an invented -program_verbose (or similar) to set the program
480 : verbosity. This can be resolved back with
481 : Bio::Tools::Run::WrapperBase's _setparams() method and code along
482 : the lines of:
483 : my %methods = map { $_ => $_ } @LIST_OF_ALL_ALLOWED_PROGRAM_ARGS
484 : delete $methods{'verbose'};
485 : $methods{'program_verbose'} = 'verbose';
486 : my $param_string = $self->_setparams(-methods => \%methods);
487 : system("$exe $param_string");
488
489=cut
490
491sub _set_from_args {
492 my ($self, $args, @own_args) = @_;
493 $self->throw("a hash/array ref of arguments must be supplied") unless ref($args);
494
495 my ($methods, $force, $create, $code, $case);
496 if (@own_args) {
497 ($methods, $force, $create, $code, $case) =
498 $self->_rearrange([qw(METHODS
499 FORCE
500 CREATE
501 CODE
502 CASE_SENSITIVE)], @own_args);
503 }
504 my $default_code = 'my $self = shift;
505 if (@_) { $self->{\'_\'.$method} = shift }
506 return $self->{\'_\'.$method};';
507
508 my %method_names = ();
509 my %syns = ();
510 if ($methods) {
511 my @names;
512 if (ref($methods) eq 'HASH') {
513 @names = keys %{$methods};
514 %syns = %{$methods};
515 }
516 else {
517 @names = @{$methods};
518 %syns = map { $_ => $_ } @names;
519 }
520 %method_names = map { $case ? $_ : lc($_) => $_ } @names;
521 }
522
523 # deal with hyphens
524 my %orig_args = ref($args) eq 'HASH' ? %{$args} : @{$args};
525 my %args;
526 while (my ($method, $value) = each %orig_args) {
527 $method =~ s/^-+//;
528 $method =~ s/-/_/g;
529 $args{$method} = $value;
530 }
531
532 # create non-existing methods on request
533 if ($create) {
534 unless ($methods) {
535 %syns = map { $_ => $case ? $_ : lc($_) } keys %args;
536 }
537
538 foreach my $method (keys %syns) {
539 $self->can($method) && next;
540
541 my $string = $code || $default_code;
542 if (ref($code) && ref($code) eq 'HASH') {
543 $string = $code->{$method} || $default_code;
544 }
545
546 my $sub = eval "sub { $string }";
547 $self->throw("Compilation error for $method : $@") if $@;
548
549289µs230µs
# spent 19µs (8+11) within Bio::Root::RootI::BEGIN@549 which was called: # once (8µs+11µs) by base::import at line 549
no strict 'refs';
# spent 19µs making 1 call to Bio::Root::RootI::BEGIN@549 # spent 11µs making 1 call to strict::unimport
550 *{ref($self).'::'.$method} = $sub;
551 }
552 }
553
554 # create synonyms of existing methods
555 while (my ($method, $syn_ref) = each %syns) {
556 my $method_ref = $self->can($method) || next;
557
558 foreach my $syn (@{ ref($syn_ref) ? $syn_ref : [$syn_ref] }) {
559 next if $syn eq $method;
560 $method_names{$case ? $syn : lc($syn)} = $syn;
561 next if $self->can($syn);
5622467µs229µs
# spent 20µs (10+10) within Bio::Root::RootI::BEGIN@562 which was called: # once (10µs+10µs) by base::import at line 562
no strict 'refs';
# spent 20µs making 1 call to Bio::Root::RootI::BEGIN@562 # spent 10µs making 1 call to strict::unimport
563 *{ref($self).'::'.$syn} = $method_ref;
564 }
565 }
566
567 # set values for methods
568 while (my ($method, $value) = each %args) {
569 $method = $method_names{$case ? $method : lc($method)} || ($methods ? next : $method);
570 $self->can($method) || next unless $force;
571 $self->$method($value);
572 }
573}
574
575
576=head2 _rearrange_old
577
578=cut
579
580#----------------'
581sub _rearrange_old {
582#----------------
583 my($self,$order,@param) = @_;
584
585 # JGRG -- This is wrong, because we don't want
586 # to assign empty string to anything, and this
587 # code is actually returning an array 1 less
588 # than the length of @param:
589
590 ## If there are no parameters, we simply wish to return
591 ## an empty array which is the size of the @{$order} array.
592 #return ('') x $#{$order} unless @param;
593
594 # ...all we need to do is return an empty array:
595 # return unless @param;
596
597 # If we've got parameters, we need to check to see whether
598 # they are named or simply listed. If they are listed, we
599 # can just return them.
600
601 # The mod test fixes bug where a single string parameter beginning with '-' gets lost.
602 # This tends to happen in error messages such as: $obj->throw("-id not defined")
603 return @param unless (defined($param[0]) && $param[0]=~/^-/o && ($#param % 2));
604
605 # Tester
606# print "\n_rearrange() named parameters:\n";
607# my $i; for ($i=0;$i<@param;$i+=2) { printf "%20s => %s\n", $param[$i],$param[$i+1]; }; <STDIN>;
608
609 # Now we've got to do some work on the named parameters.
610 # The next few lines strip out the '-' characters which
611 # preceed the keys, and capitalizes them.
612 for (my $i=0;$i<@param;$i+=2) {
613 $param[$i]=~s/^\-//;
614 $param[$i]=~tr/a-z/A-Z/;
615 }
616
617 # Now we'll convert the @params variable into an associative array.
618 # local($^W) = 0; # prevent "odd number of elements" warning with -w.
619 my(%param) = @param;
620
621 # my(@return_array);
622
623 # What we intend to do is loop through the @{$order} variable,
624 # and for each value, we use that as a key into our associative
625 # array, pushing the value at that key onto our return array.
626 # my($key);
627
628 #foreach (@{$order}) {
629 # my($value) = $param{$key};
630 # delete $param{$key};
631 #push(@return_array,$param{$_});
632 #}
633
634 return @param{@{$order}};
635
636# print "\n_rearrange() after processing:\n";
637# my $i; for ($i=0;$i<@return_array;$i++) { printf "%20s => %s\n", ${$order}[$i], $return_array[$i]; } <STDIN>;
638
639 # return @return_array;
640}
641
642=head2 _register_for_cleanup
643
644 Title : _register_for_cleanup
645 Usage : -- internal --
646 Function: Register a method to be called at DESTROY time. This is useful
647 and sometimes essential in the case of multiple inheritance for
648 classes coming second in the sequence of inheritance.
649 Returns :
650 Args : a code reference
651
652The code reference will be invoked with the object as the first
653argument, as per a method. You may register an unlimited number of
654cleanup methods.
655
656=cut
657
658sub _register_for_cleanup {
659 my ($self,$method) = @_;
660 $self->throw_not_implemented();
661}
662
663=head2 _unregister_for_cleanup
664
665 Title : _unregister_for_cleanup
666 Usage : -- internal --
667 Function: Remove a method that has previously been registered to be called
668 at DESTROY time. If called with a method to be called at DESTROY time.
669 Has no effect if the code reference has not previously been registered.
670 Returns : nothing
671 Args : a code reference
672
673=cut
674
675sub _unregister_for_cleanup {
676 my ($self,$method) = @_;
677 $self->throw_not_implemented();
678}
679
680=head2 _cleanup_methods
681
682 Title : _cleanup_methods
683 Usage : -- internal --
684 Function: Return current list of registered cleanup methods.
685 Returns : list of coderefs
686 Args : none
687
688=cut
689
690sub _cleanup_methods {
691 my $self = shift;
692 unless ( $ENV{'BIOPERLDEBUG'} || $self->verbose > 0 ) {
693 carp("Use of Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead");
694 }
695 return;
696}
697
698=head2 throw_not_implemented
699
700 Purpose : Throws a Bio::Root::NotImplemented exception.
701 Intended for use in the method definitions of
702 abstract interface modules where methods are defined
703 but are intended to be overridden by subclasses.
704 Usage : $object->throw_not_implemented();
705 Example : sub method_foo {
706 $self = shift;
707 $self->throw_not_implemented();
708 }
709 Returns : n/a
710 Args : n/a
711 Throws : A Bio::Root::NotImplemented exception.
712 The message of the exception contains
713 - the name of the method
714 - the name of the interface
715 - the name of the implementing class
716
717 If this object has a throw() method, $self->throw will be used.
718 If the object doesn't have a throw() method,
719 Carp::confess() will be used.
720
721
722=cut
723
724#'
725
726sub throw_not_implemented {
727 my $self = shift;
728
729 # Bio::Root::Root::throw() knows how to check for Error.pm and will
730 # throw an Error-derived object of the specified class (Bio::Root::NotImplemented),
731 # which is defined in Bio::Root::Exception.
732 # If Error.pm is not available, the name of the class is just included in the
733 # error message.
734
735 my $message = $self->_not_implemented_msg;
736
737 if ( $self->can('throw') ) {
738 my @args;
739 if ( $self->isa('Bio::Root::Root') ) {
740 # Use Root::throw() hash-based arguments instead of RootI::throw()
741 # single string argument whenever possible
742 @args = ( -text => $message, -class => 'Bio::Root::NotImplemented' );
743 } else {
744 @args = ( $message );
745 }
746 $self->throw(@args);
747
748 } else {
749 confess $message;
750 }
751}
752
753
754=head2 warn_not_implemented
755
756 Purpose : Generates a warning that a method has not been implemented.
757 Intended for use in the method definitions of
758 abstract interface modules where methods are defined
759 but are intended to be overridden by subclasses.
760 Generally, throw_not_implemented() should be used,
761 but warn_not_implemented() may be used if the method isn't
762 considered essential and convenient no-op behavior can be
763 provided within the interface.
764 Usage : $object->warn_not_implemented( method-name-string );
765 Example : $self->warn_not_implemented( "get_foobar" );
766 Returns : Calls $self->warn on this object, if available.
767 If the object doesn't have a warn() method,
768 Carp::carp() will be used.
769 Args : n/a
770
771
772=cut
773
774#'
775
776sub warn_not_implemented {
777 my $self = shift;
778 my $message = $self->_not_implemented_msg;
779 if( $self->can('warn') ) {
780 $self->warn( $message );
781 }else {
782 carp $message ;
783 }
784}
785
786=head2 _not_implemented_msg
787
788Unify 'not implemented' message. -Juguang
789=cut
790
791sub _not_implemented_msg {
792 my $self = shift;
793 my $package = ref $self;
794 my $meth = (caller(2))[3];
795 my $msg =<<EOD_NOT_IMP;
796Abstract method \"$meth\" is not implemented by package $package.
797This is not your fault - author of $package should be blamed!
798EOD_NOT_IMP
799 return $msg;
800}
801
80212µs1;