1 package Bio
::Root
::RootI
;
3 use Carp
'confess','carp';
7 # any bioperl or bioperl compliant object is a RootI
10 $obj->throw("This is an exception");
13 $obj->throw("This is catching an exception");
17 print "Caught exception";
22 # Using throw_not_implemented() within a RootI-based interface module:
25 use base qw(Bio::Root::RootI);
29 $self->throw_not_implemented;
35 This is just a set of methods which do not assume B<anything> about the object
36 they are on. The methods provide the ability to throw exceptions with nice
39 This is what should be inherited by all Bioperl compliant interfaces, even
40 if they are exotic XS/CORBA/Other perl systems.
42 =head2 Using throw_not_implemented()
44 The method L<throw_not_implemented()|throw_not_implemented> should be
45 called by all methods within interface modules that extend RootI so
46 that if an implementation fails to override them, an exception will be
49 For example, say there is an interface module called C<FooI> that
50 provides a method called C<foo()>. Since this method is considered
51 abstract within FooI and should be implemented by any module claiming to
52 implement C<FooI>, the C<FooI::foo()> method should consist of the
57 $self->throw_not_implemented;
60 So, if an implementer of C<FooI> forgets to implement C<foo()>
61 and a user of the implementation calls C<foo()>, a
62 L<Bio::Exception::NotImplemented> exception will result.
64 Unfortunately, failure to implement a method can only be determined at
65 run time (i.e., you can't verify that an implementation is complete by
66 running C<perl -wc> on it). So it should be standard practice for a test
67 of an implementation to check each method and verify that it doesn't
68 throw a L<Bio::Exception::NotImplemented>.
70 =head1 AUTHOR Steve Chervitz
72 Ewan Birney, Lincoln Stein, Steve Chervitz, Sendu Bala, Jason Stajich
76 use vars
qw($DEBUG $ID $VERBOSITY);
78 $ID = 'Bio::Root::RootI';
90 unless ( $ENV{'BIOPERLDEBUG'} ) {
91 carp("Use of new in Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead");
93 eval "require Bio::Root::Root";
94 return Bio::Root::Root->new(@args);
97 # for backwards compatibility
107 Usage : $obj->throw("throwing exception message")
108 Function: Throws an exception, which, if not caught with an eval brace
109 will provide a nice stack trace to STDERR with the message
111 Args : A string giving a descriptive error message
117 my ($self,$string) = @_;
119 my $std = $self->stack_trace_dump();
121 my $out = "\n-------------------- EXCEPTION --------------------\n"
122 . "MSG: " . $string . "\n"
123 . $std."-------------------------------------------\n";
130 Usage : $object->warn("Warning message");
131 Function: Places a warning. What happens now is down to the
132 verbosity of the object (value of $obj->verbose)
133 verbosity 0 or not set => small warning
134 verbosity -1 => no warning
135 verbosity 1 => warning with stack trace
136 verbosity 2 => converts warnings into throw
138 Args : string (the warning message)
143 my ($self,$string) = @_;
145 my $verbose = $self->verbose;
147 my $header = "\n--------------------- WARNING ---------------------\nMSG: ";
148 my $footer = "---------------------------------------------------\n";
151 $self->throw($string);
153 elsif ($verbose <= -1) {
156 elsif ($verbose == 1) {
157 CORE::warn $header, $string, "\n", $self->stack_trace_dump, $footer;
161 CORE::warn $header, $string, "\n", $footer;
167 Usage : $obj->deprecated("Method X is deprecated");
168 $obj->deprecated("Method X is deprecated", 1.007);
169 $obj->deprecated(-message => "Method X is deprecated");
170 $obj->deprecated(-message => "Method X is deprecated",
172 Function: Prints a message about deprecation unless verbose is < 0
173 (which means be quiet)
175 Args : Message string to print to STDERR
176 Version of BioPerl where use of the method results in an exception
177 Notes : The method can be called two ways, either by positional arguments:
179 $obj->deprecated('This module is deprecated', 1.006);
181 or by named arguments:
184 -message => 'use of the method foo() is deprecated, use bar() instead',
185 -version => 1.006 # throw if $VERSION is >= this version
188 or timed to go off at a certain point:
191 -message => 'use of the method foo() is deprecated, use bar() instead',
192 -warn_version => 1.006 # warn if $VERSION is >= this version
193 -throw_version => 1.007 # throw if $VERSION is >= this version
196 Using the last two named argument versions is suggested and will
197 likely be the only supported way of calling this method in the future
198 Yes, we see the irony of deprecating that particular usage of
201 The main difference between usage of the two named argument versions
202 is that by designating a 'warn_version' one indicates the
203 functionality is officially deprecated beginning in a future version
204 of BioPerl (so warnings are issued only after that point), whereas
205 setting either 'version' or 'throw_version' (synonyms) converts the
206 deprecation warning to an exception.
208 For proper comparisons one must use a version in lines with the
209 current versioning scheme for Perl and BioPerl, (i.e. where 1.006000
210 indicates v1.6.0, 5.010000 for v5.10.0, etc.).
217 my $class = ref $self || $self;
218 my $class_version = do {
220 ${"${class}::VERSION"}
223 if( $class_version && $class_version =~ /set by/ ) {
224 $class_version = 0.0001;
227 my ($msg, $version, $warn_version, $throw_version) =
228 $self->_rearrange([qw(MESSAGE VERSION WARN_VERSION THROW_VERSION)], @_);
230 $throw_version ||= $version;
231 $warn_version ||= $class_version;
233 for my $v ( $warn_version, $throw_version) {
234 no warnings
'numeric';
235 $self->throw("Version must be numerical, such as 1.006000 for v1.6.0, not $v")
236 unless !defined $v || $v + 0 eq $v;
239 # below default insinuates we're deprecating a method and not a full module
240 # but it's the most common use case
241 $msg ||= "Use of ".(caller(1))[3]."() is deprecated.";
243 if( $throw_version && $class_version && $class_version >= $throw_version ) {
246 elsif( $warn_version && $class_version && $class_version >= $warn_version ) {
248 $msg .= "\nTo be removed in $throw_version." if $throw_version;
250 # passing this on to warn() should deal properly with verbosity issues
255 =head2 stack_trace_dump
257 Title : stack_trace_dump
267 sub stack_trace_dump
{
270 my @stack = $self->stack_trace();
277 my ($module,$function,$file,$position);
280 foreach my $stack ( @stack) {
281 ($module,$file,$position,$function) = @
{$stack};
282 $out .= "STACK $function $file:$position\n";
292 Usage : @stack_array_ref= $self->stack_trace
293 Function: gives an array to a reference of arrays with stack trace info
294 each coming from the caller(stack_number) call
295 Returns : array containing a reference of arrays
307 while( my @call = caller($i++)) {
308 # major annoyance that caller puts caller context as
309 # function name. Hence some monkeying around...
310 $prev->[3] = $call[3];
314 $prev->[3] = 'toplevel';
322 Usage : $object->_rearrange( array_ref, list_of_arguments)
323 Purpose : Rearranges named parameters to requested order.
324 Example : $self->_rearrange([qw(SEQUENCE ID DESC)],@param);
325 : Where @param = (-sequence => $s,
328 Returns : @params - an array of parameters in the requested order.
329 : The above example would return ($s, $i, $d).
330 : Unspecified parameters will return undef. For example, if
331 : @param = (-sequence => $s);
332 : the above _rearrange call would return ($s, undef, undef)
333 Argument : $order : a reference to an array which describes the desired
334 : order of the named parameters.
335 : @param : an array of parameters, either as a list (in
336 : which case the function simply returns the list),
337 : or as an associative array with hyphenated tags
338 : (in which case the function sorts the values
339 : according to @{$order} and returns that new array.)
340 : The tags can be upper, lower, or mixed case
341 : but they must start with a hyphen (at least the
342 : first one should be hyphenated.)
343 Source : This function was taken from CGI.pm, written by Dr. Lincoln
344 : Stein, and adapted for use in Bio::Seq by Richard Resnick and
345 : then adapted for use in Bio::Root::Object.pm by Steve Chervitz,
346 : then migrated into Bio::Root::RootI.pm by Ewan Birney.
348 : Uppercase tags are the norm,
350 : This method may not be appropriate for method calls that are
351 : within in an inner loop if efficiency is a concern.
353 : Parameters can be specified using any of these formats:
354 : @param = (-name=>'me', -color=>'blue');
355 : @param = (-NAME=>'me', -COLOR=>'blue');
356 : @param = (-Name=>'me', -Color=>'blue');
357 : @param = ('me', 'blue');
358 : A leading hyphenated argument is used by this function to
359 : indicate that named parameters are being used.
360 : Therefore, the ('me', 'blue') list will be returned as-is.
362 : Note that Perl will confuse unquoted, hyphenated tags as
363 : function calls if there is a function of the same name
364 : in the current namespace:
365 : -name => 'foo' is interpreted as -&name => 'foo'
367 : For ultimate safety, put single quotes around the tag:
368 : ('-name'=>'me', '-color' =>'blue');
369 : This can be a bit cumbersome and I find not as readable
370 : as using all uppercase, which is also fairly safe:
371 : (-NAME=>'me', -COLOR =>'blue');
373 : Personal note (SAC): I have found all uppercase tags to
374 : be more manageable: it involves less single-quoting,
375 : the key names stand out better, and there are no method naming
377 : The drawbacks are that it's not as easy to type as lowercase,
378 : and lots of uppercase can be hard to read.
380 : Regardless of the style, it greatly helps to line
381 : the parameters up vertically for long/complex lists.
383 : Note that if @param is a single string that happens to start with
384 : a dash, it will be treated as a hash key and probably fail to
385 : match anything in the array_ref, so not be returned as normally
386 : happens when @param is a simple list and not an associative array.
391 my ($self, $order, @args) = @_;
393 return @args unless $args[0] && $args[0] =~ /^\-/;
395 push @args, undef unless $#args % 2;
398 for( my $i = 0; $i < @args; $i += 2 ) {
399 (my $key = $args[$i]) =~ tr/a-z\055/A-Z/d; #deletes all dashes!
400 $param{$key} = $args[$i+1];
402 return @param{map uc, @
$order};
405 =head2 _set_from_args
407 Usage : $object->_set_from_args(\%args, -methods => \@methods)
408 Purpose : Takes a hash of user-supplied args whose keys match method names,
409 : and calls the method supplying it the corresponding value.
410 Example : $self->_set_from_args(\%args, -methods => [qw(sequence id desc)]);
411 : Where %args = (-sequence => $s,
412 : -description => $d,
415 : the above _set_from_args calls the following methods:
416 : $self->sequence($s);
418 : ( $self->description($i) is not called because 'description' wasn't
419 : one of the given methods )
420 Argument : \%args | \@args : a hash ref or associative array ref of arguments
421 : where keys are any-case strings corresponding to
422 : method names but optionally prefixed with
423 : hyphens, and values are the values the method
424 : should be supplied. If keys contain internal
425 : hyphens (eg. to separate multi-word args) they
426 : are converted to underscores, since method names
427 : cannot contain dashes.
428 : -methods => [] : (optional) only call methods with names in this
429 : array ref. Can instead supply a hash ref where
430 : keys are method names (of real existing methods
431 : unless -create is in effect) and values are array
432 : refs of synonyms to allow access to the method
433 : using synonyms. If there is only one synonym it
434 : can be supplied as a string instead of a single-
436 : -force => bool : (optional, default 0) call methods that don't
437 : seem to exist, ie. let AUTOLOAD handle them
438 : -create => bool : (optional, default 0) when a method doesn't
439 : exist, create it as a simple getter/setter
440 : (combined with -methods it would create all the
441 : supplied methods that didn't exist, even if not
442 : mentioned in the supplied %args)
443 : -code => '' | {}: (optional) when creating methods use the supplied
444 : code (a string which will be evaulated as a sub).
445 : The default code is a simple get/setter.
446 : Alternatively you can supply a hash ref where
447 : the keys are method names and the values are
448 : code strings. The variable '$method' will be
449 : available at evaluation time, so can be used in
450 : your code strings. Beware that the strict pragma
452 : -case_sensitive => bool : require case sensitivity on the part of
453 : user (ie. a() and A() are two different
454 : methods and the user must be careful
457 : The \%args argument will usually be the args received during new()
458 : from the user. The user is allowed to get the case wrong, include
459 : 0 or more than one hyphens as a prefix, and to include hyphens as
460 : multi-word arg separators: '--an-arg' => 1, -an_arg => 1 and
461 : An_Arg => 1 are all equivalent, calling an_arg(1). However, in
462 : documentation users should only be told to use the standard form
463 : -an_arg to avoid confusion. A possible exception to this is a
464 : wrapper module where '--an-arg' is what the user is used to
465 : supplying to the program being wrapped.
467 : Another issue with wrapper modules is that there may be an
468 : argument that has meaning both to Bioperl and to the program, eg.
469 : -verbose. The recommended way of dealing with this is to leave
470 : -verbose to set the Bioperl verbosity whilst requesting users use
471 : an invented -program_verbose (or similar) to set the program
472 : verbosity. This can be resolved back with
473 : Bio::Tools::Run::WrapperBase's _setparams() method and code along
475 : my %methods = map { $_ => $_ } @LIST_OF_ALL_ALLOWED_PROGRAM_ARGS
476 : delete $methods{'verbose'};
477 : $methods{'program_verbose'} = 'verbose';
478 : my $param_string = $self->_setparams(-methods => \%methods);
479 : system("$exe $param_string");
484 my ($self, $args, @own_args) = @_;
485 $self->throw("a hash/array ref of arguments must be supplied") unless ref($args);
487 my ($methods, $force, $create, $code, $case);
489 ($methods, $force, $create, $code, $case) =
490 $self->_rearrange([qw(METHODS
494 CASE_SENSITIVE)], @own_args);
496 my $default_code = 'my $self = shift;
497 if (@_) { $self->{\'_\'.$method} = shift }
498 return $self->{\'_\'.$method};';
500 my %method_names = ();
504 if (ref($methods) eq 'HASH') {
505 @names = keys %{$methods};
509 @names = @
{$methods};
510 %syns = map { $_ => $_ } @names;
512 %method_names = map { $case ?
$_ : lc($_) => $_ } @names;
516 my %orig_args = ref($args) eq 'HASH' ?
%{$args} : @
{$args};
518 while (my ($method, $value) = each %orig_args) {
521 $args{$method} = $value;
524 # create non-existing methods on request
527 %syns = map { $_ => $case ?
$_ : lc($_) } keys %args;
530 foreach my $method (keys %syns) {
531 $self->can($method) && next;
533 my $string = $code || $default_code;
534 if (ref($code) && ref($code) eq 'HASH') {
535 $string = $code->{$method} || $default_code;
538 my $sub = eval "sub { $string }";
539 $self->throw("Compilation error for $method : $@") if $@
;
542 *{ref($self).'::'.$method} = $sub;
546 # create synonyms of existing methods
547 while (my ($method, $syn_ref) = each %syns) {
548 my $method_ref = $self->can($method) || next;
550 foreach my $syn (@
{ ref($syn_ref) ?
$syn_ref : [$syn_ref] }) {
551 next if $syn eq $method;
552 $method_names{$case ?
$syn : lc($syn)} = $syn;
553 next if $self->can($syn);
555 *{ref($self).'::'.$syn} = $method_ref;
559 # set values for methods
560 while (my ($method, $value) = each %args) {
561 $method = $method_names{$case ?
$method : lc($method)} || ($methods ?
next : $method);
562 $self->can($method) || next unless $force;
563 $self->$method($value);
568 =head2 _rearrange_old
575 my($self,$order,@param) = @_;
577 # JGRG -- This is wrong, because we don't want
578 # to assign empty string to anything, and this
579 # code is actually returning an array 1 less
580 # than the length of @param:
582 ## If there are no parameters, we simply wish to return
583 ## an empty array which is the size of the @{$order} array.
584 #return ('') x $#{$order} unless @param;
586 # ...all we need to do is return an empty array:
587 # return unless @param;
589 # If we've got parameters, we need to check to see whether
590 # they are named or simply listed. If they are listed, we
591 # can just return them.
593 # The mod test fixes bug where a single string parameter beginning with '-' gets lost.
594 # This tends to happen in error messages such as: $obj->throw("-id not defined")
595 return @param unless (defined($param[0]) && $param[0]=~/^-/o && ($#param % 2));
598 # print "\n_rearrange() named parameters:\n";
599 # my $i; for ($i=0;$i<@param;$i+=2) { printf "%20s => %s\n", $param[$i],$param[$i+1]; }; <STDIN>;
601 # Now we've got to do some work on the named parameters.
602 # The next few lines strip out the '-' characters which
603 # preceed the keys, and capitalizes them.
604 for (my $i=0;$i<@param;$i+=2) {
606 $param[$i]=~tr/a-z/A-Z/;
609 # Now we'll convert the @params variable into an associative array.
610 # local($^W) = 0; # prevent "odd number of elements" warning with -w.
615 # What we intend to do is loop through the @{$order} variable,
616 # and for each value, we use that as a key into our associative
617 # array, pushing the value at that key onto our return array.
620 #foreach (@{$order}) {
621 # my($value) = $param{$key};
622 # delete $param{$key};
623 #push(@return_array,$param{$_});
626 return @param{@
{$order}};
628 # print "\n_rearrange() after processing:\n";
629 # my $i; for ($i=0;$i<@return_array;$i++) { printf "%20s => %s\n", ${$order}[$i], $return_array[$i]; } <STDIN>;
631 # return @return_array;
634 =head2 _register_for_cleanup
636 Title : _register_for_cleanup
637 Usage : -- internal --
638 Function: Register a method to be called at DESTROY time. This is useful
639 and sometimes essential in the case of multiple inheritance for
640 classes coming second in the sequence of inheritance.
642 Args : a code reference
644 The code reference will be invoked with the object as the first
645 argument, as per a method. You may register an unlimited number of
650 sub _register_for_cleanup
{
651 my ($self,$method) = @_;
652 $self->throw_not_implemented();
655 =head2 _unregister_for_cleanup
657 Title : _unregister_for_cleanup
658 Usage : -- internal --
659 Function: Remove a method that has previously been registered to be called
660 at DESTROY time. If called with a method to be called at DESTROY time.
661 Has no effect if the code reference has not previously been registered.
663 Args : a code reference
667 sub _unregister_for_cleanup
{
668 my ($self,$method) = @_;
669 $self->throw_not_implemented();
672 =head2 _cleanup_methods
674 Title : _cleanup_methods
675 Usage : -- internal --
676 Function: Return current list of registered cleanup methods.
677 Returns : list of coderefs
682 sub _cleanup_methods
{
684 unless ( $ENV{'BIOPERLDEBUG'} || $self->verbose > 0 ) {
685 carp
("Use of Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead");
690 =head2 throw_not_implemented
692 Purpose : Throws a Bio::Root::NotImplemented exception.
693 Intended for use in the method definitions of
694 abstract interface modules where methods are defined
695 but are intended to be overridden by subclasses.
696 Usage : $object->throw_not_implemented();
697 Example : sub method_foo {
699 $self->throw_not_implemented();
703 Throws : A Bio::Root::NotImplemented exception.
704 The message of the exception contains
705 - the name of the method
706 - the name of the interface
707 - the name of the implementing class
709 If this object has a throw() method, $self->throw will be used.
710 If the object doesn't have a throw() method,
711 Carp::confess() will be used.
718 sub throw_not_implemented
{
721 # Bio::Root::Root::throw() knows how to check for Error.pm and will
722 # throw an Error-derived object of the specified class (Bio::Root::NotImplemented),
723 # which is defined in Bio::Root::Exception.
724 # If Error.pm is not available, the name of the class is just included in the
727 my $message = $self->_not_implemented_msg;
729 if ( $self->can('throw') ) {
731 if ( $self->isa('Bio::Root::Root') ) {
732 # Use Root::throw() hash-based arguments instead of RootI::throw()
733 # single string argument whenever possible
734 @args = ( -text
=> $message, -class => 'Bio::Root::NotImplemented' );
736 @args = ( $message );
746 =head2 warn_not_implemented
748 Purpose : Generates a warning that a method has not been implemented.
749 Intended for use in the method definitions of
750 abstract interface modules where methods are defined
751 but are intended to be overridden by subclasses.
752 Generally, throw_not_implemented() should be used,
753 but warn_not_implemented() may be used if the method isn't
754 considered essential and convenient no-op behavior can be
755 provided within the interface.
756 Usage : $object->warn_not_implemented( method-name-string );
757 Example : $self->warn_not_implemented( "get_foobar" );
758 Returns : Calls $self->warn on this object, if available.
759 If the object doesn't have a warn() method,
760 Carp::carp() will be used.
768 sub warn_not_implemented
{
770 my $message = $self->_not_implemented_msg;
771 if( $self->can('warn') ) {
772 $self->warn( $message );
778 =head2 _not_implemented_msg
780 Unify 'not implemented' message. -Juguang
783 sub _not_implemented_msg
{
785 my $package = ref $self;
786 my $meth = (caller(2))[3];
787 my $msg =<<EOD_NOT_IMP;
788 Abstract method \"$meth\" is not implemented by package $package.
789 This is not your fault - author of $package should be blamed!