1 package Bio
::Root
::RootI
;
4 use Carp
'confess','carp';
8 Bio::Root::RootI - base interface for all BioPerl classes
12 # any bioperl or bioperl compliant object is a RootI
15 $obj->throw("This is an exception");
18 $obj->throw("This is catching an exception");
22 print "Caught exception";
27 # Using throw_not_implemented() within a RootI-based interface module:
30 use base qw(Bio::Root::RootI);
34 $self->throw_not_implemented;
40 This is just a set of methods which do not assume B<anything> about the object
41 they are on. The methods provide the ability to throw exceptions with nice
44 This is what should be inherited by all Bioperl compliant interfaces, even
45 if they are exotic XS/CORBA/Other perl systems.
47 =head2 Using throw_not_implemented()
49 The method L<throw_not_implemented()|throw_not_implemented> should be
50 called by all methods within interface modules that extend RootI so
51 that if an implementation fails to override them, an exception will be
54 For example, say there is an interface module called C<FooI> that
55 provides a method called C<foo()>. Since this method is considered
56 abstract within FooI and should be implemented by any module claiming to
57 implement C<FooI>, the C<FooI::foo()> method should consist of the
62 $self->throw_not_implemented;
65 So, if an implementer of C<FooI> forgets to implement C<foo()>
66 and a user of the implementation calls C<foo()>, a
67 L<Bio::Exception::NotImplemented> exception will result.
69 Unfortunately, failure to implement a method can only be determined at
70 run time (i.e., you can't verify that an implementation is complete by
71 running C<perl -wc> on it). So it should be standard practice for a test
72 of an implementation to check each method and verify that it doesn't
73 throw a L<Bio::Exception::NotImplemented>.
75 =head1 AUTHOR Steve Chervitz
77 Ewan Birney, Lincoln Stein, Steve Chervitz, Sendu Bala, Jason Stajich
81 use vars
qw($DEBUG $ID $VERBOSITY);
83 $ID = 'Bio::Root::RootI';
95 unless ( $ENV{'BIOPERLDEBUG'} ) {
96 carp("Use of new in Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead");
98 eval "require Bio::Root::Root";
99 return Bio::Root::Root->new(@args);
102 # for backwards compatibility
104 my($self,@args) = @_;
112 Usage : $obj->throw("throwing exception message")
113 Function: Throws an exception, which, if not caught with an eval brace
114 will provide a nice stack trace to STDERR with the message
116 Args : A string giving a descriptive error message
122 my ($self,$string) = @_;
124 my $std = $self->stack_trace_dump();
126 my $out = "\n-------------------- EXCEPTION --------------------\n"
127 . "MSG: " . $string . "\n"
128 . $std."-------------------------------------------\n";
135 Usage : $object->warn("Warning message");
136 Function: Places a warning. What happens now is down to the
137 verbosity of the object (value of $obj->verbose)
138 verbosity 0 or not set => small warning
139 verbosity -1 => no warning
140 verbosity 1 => warning with stack trace
141 verbosity 2 => converts warnings into throw
143 Args : string (the warning message)
148 my ($self,$string) = @_;
150 my $verbose = $self->verbose;
152 my $header = "\n--------------------- WARNING ---------------------\nMSG: ";
153 my $footer = "---------------------------------------------------\n";
156 $self->throw($string);
158 elsif ($verbose <= -1) {
161 elsif ($verbose == 1) {
162 CORE::warn $header, $string, "\n", $self->stack_trace_dump, $footer;
166 CORE::warn $header, $string, "\n", $footer;
172 Usage : $obj->deprecated("Method X is deprecated");
173 $obj->deprecated("Method X is deprecated", 1.007);
174 $obj->deprecated(-message => "Method X is deprecated");
175 $obj->deprecated(-message => "Method X is deprecated",
177 Function: Prints a message about deprecation unless verbose is < 0
178 (which means be quiet)
180 Args : Message string to print to STDERR
181 Version of BioPerl where use of the method results in an exception
183 Notes : This is deprecated. Use Carp::carp to warn about a
184 deprecated method. Just remove the method when it comes to
185 error. If you really want to throw an error insyead of
186 removing, use Carp::croak.
188 The irony of deprecating deprecated() is not lost on us.
189 We hope you also find it more funny that frustrating.
196 carp "deprecated() is deprecated. Just use Carp::carp to warn.";
198 my ($msg, $version, $warn_version, $throw_version) =
199 $self->_rearrange([qw(MESSAGE VERSION WARN_VERSION THROW_VERSION)], @_);
200 # below default insinuates we're deprecating a method and not a full module
201 # but it's the most common use case
202 $msg ||= "Use of ".(caller(1))[3]."() is deprecated.";
204 ## Never documented, but if there is no version information, just
206 if (! defined($version) && ! defined($warn_version)
207 && ! defined($throw_version)) {
212 my $class = ref $self || $self;
213 my $class_version = do {
215 ${"${class}::VERSION"}
218 if( $class_version && $class_version =~ /set by/ ) {
219 $class_version = 0.0001;
222 $throw_version ||= $version;
223 $warn_version ||= $class_version;
225 $throw_version =~ s/_//g;
226 $warn_version =~ s/_//g;
228 for my $v ( $warn_version, $throw_version) {
229 no warnings
'numeric';
230 $self->throw("Version must be numerical, such as 1.006000 for v1.6.0, not $v")
231 unless !defined $v || $v + 0 == $v;
234 if( $throw_version && $class_version && $class_version >= $throw_version ) {
237 elsif( $warn_version && $class_version && $class_version >= $warn_version ) {
239 $msg .= "\nTo be removed in $throw_version." if $throw_version;
241 # passing this on to warn() should deal properly with verbosity issues
246 =head2 stack_trace_dump
248 Title : stack_trace_dump
258 sub stack_trace_dump
{
261 my @stack = $self->stack_trace();
268 my ($module,$function,$file,$position);
271 foreach my $stack ( @stack) {
272 ($module,$file,$position,$function) = @
{$stack};
273 $out .= "STACK $function $file:$position\n";
283 Usage : @stack_array_ref= $self->stack_trace
284 Function: gives an array to a reference of arrays with stack trace info
285 each coming from the caller(stack_number) call
286 Returns : array containing a reference of arrays
298 while( my @call = caller($i++)) {
299 # major annoyance that caller puts caller context as
300 # function name. Hence some monkeying around...
301 $prev->[3] = $call[3];
305 $prev->[3] = 'toplevel';
313 Usage : $object->_rearrange( array_ref, list_of_arguments)
314 Purpose : Rearranges named parameters to requested order.
315 Example : $self->_rearrange([qw(SEQUENCE ID DESC)],@param);
316 : Where @param = (-sequence => $s,
319 Returns : @params - an array of parameters in the requested order.
320 : The above example would return ($s, $i, $d).
321 : Unspecified parameters will return undef. For example, if
322 : @param = (-sequence => $s);
323 : the above _rearrange call would return ($s, undef, undef)
324 Argument : $order : a reference to an array which describes the desired
325 : order of the named parameters.
326 : @param : an array of parameters, either as a list (in
327 : which case the function simply returns the list),
328 : or as an associative array with hyphenated tags
329 : (in which case the function sorts the values
330 : according to @{$order} and returns that new array.)
331 : The tags can be upper, lower, or mixed case
332 : but they must start with a hyphen (at least the
333 : first one should be hyphenated.)
334 Source : This function was taken from CGI.pm, written by Dr. Lincoln
335 : Stein, and adapted for use in Bio::Seq by Richard Resnick and
336 : then adapted for use in Bio::Root::Object.pm by Steve Chervitz,
337 : then migrated into Bio::Root::RootI.pm by Ewan Birney.
339 : Uppercase tags are the norm,
341 : This method may not be appropriate for method calls that are
342 : within in an inner loop if efficiency is a concern.
344 : Parameters can be specified using any of these formats:
345 : @param = (-name=>'me', -color=>'blue');
346 : @param = (-NAME=>'me', -COLOR=>'blue');
347 : @param = (-Name=>'me', -Color=>'blue');
348 : @param = ('me', 'blue');
349 : A leading hyphenated argument is used by this function to
350 : indicate that named parameters are being used.
351 : Therefore, the ('me', 'blue') list will be returned as-is.
353 : Note that Perl will confuse unquoted, hyphenated tags as
354 : function calls if there is a function of the same name
355 : in the current namespace:
356 : -name => 'foo' is interpreted as -&name => 'foo'
358 : For ultimate safety, put single quotes around the tag:
359 : ('-name'=>'me', '-color' =>'blue');
360 : This can be a bit cumbersome and I find not as readable
361 : as using all uppercase, which is also fairly safe:
362 : (-NAME=>'me', -COLOR =>'blue');
364 : Personal note (SAC): I have found all uppercase tags to
365 : be more manageable: it involves less single-quoting,
366 : the key names stand out better, and there are no method naming
368 : The drawbacks are that it's not as easy to type as lowercase,
369 : and lots of uppercase can be hard to read.
371 : Regardless of the style, it greatly helps to line
372 : the parameters up vertically for long/complex lists.
374 : Note that if @param is a single string that happens to start with
375 : a dash, it will be treated as a hash key and probably fail to
376 : match anything in the array_ref, so not be returned as normally
377 : happens when @param is a simple list and not an associative array.
382 my ($self, $order, @args) = @_;
384 return @args unless $args[0] && $args[0] =~ /^\-/;
386 push @args, undef unless $#args % 2;
389 for( my $i = 0; $i < @args; $i += 2 ) {
390 (my $key = $args[$i]) =~ tr/a-z\055/A-Z/d; #deletes all dashes!
391 $param{$key} = $args[$i+1];
393 return @param{map uc, @
$order};
396 =head2 _set_from_args
398 Usage : $object->_set_from_args(\%args, -methods => \@methods)
399 Purpose : Takes a hash of user-supplied args whose keys match method names,
400 : and calls the method supplying it the corresponding value.
401 Example : $self->_set_from_args(\%args, -methods => [qw(sequence id desc)]);
402 : Where %args = (-sequence => $s,
403 : -description => $d,
406 : the above _set_from_args calls the following methods:
407 : $self->sequence($s);
409 : ( $self->description($i) is not called because 'description' wasn't
410 : one of the given methods )
411 Argument : \%args | \@args : a hash ref or associative array ref of arguments
412 : where keys are any-case strings corresponding to
413 : method names but optionally prefixed with
414 : hyphens, and values are the values the method
415 : should be supplied. If keys contain internal
416 : hyphens (eg. to separate multi-word args) they
417 : are converted to underscores, since method names
418 : cannot contain dashes.
419 : -methods => [] : (optional) only call methods with names in this
420 : array ref. Can instead supply a hash ref where
421 : keys are method names (of real existing methods
422 : unless -create is in effect) and values are array
423 : refs of synonyms to allow access to the method
424 : using synonyms. If there is only one synonym it
425 : can be supplied as a string instead of a single-
427 : -force => bool : (optional, default 0) call methods that don't
428 : seem to exist, ie. let AUTOLOAD handle them
429 : -create => bool : (optional, default 0) when a method doesn't
430 : exist, create it as a simple getter/setter
431 : (combined with -methods it would create all the
432 : supplied methods that didn't exist, even if not
433 : mentioned in the supplied %args)
434 : -code => '' | {}: (optional) when creating methods use the supplied
435 : code (a string which will be evaulated as a sub).
436 : The default code is a simple get/setter.
437 : Alternatively you can supply a hash ref where
438 : the keys are method names and the values are
439 : code strings. The variable '$method' will be
440 : available at evaluation time, so can be used in
441 : your code strings. Beware that the strict pragma
443 : -case_sensitive => bool : require case sensitivity on the part of
444 : user (ie. a() and A() are two different
445 : methods and the user must be careful
448 : The \%args argument will usually be the args received during new()
449 : from the user. The user is allowed to get the case wrong, include
450 : 0 or more than one hyphens as a prefix, and to include hyphens as
451 : multi-word arg separators: '--an-arg' => 1, -an_arg => 1 and
452 : An_Arg => 1 are all equivalent, calling an_arg(1). However, in
453 : documentation users should only be told to use the standard form
454 : -an_arg to avoid confusion. A possible exception to this is a
455 : wrapper module where '--an-arg' is what the user is used to
456 : supplying to the program being wrapped.
458 : Another issue with wrapper modules is that there may be an
459 : argument that has meaning both to Bioperl and to the program, eg.
460 : -verbose. The recommended way of dealing with this is to leave
461 : -verbose to set the Bioperl verbosity whilst requesting users use
462 : an invented -program_verbose (or similar) to set the program
463 : verbosity. This can be resolved back with
464 : Bio::Tools::Run::WrapperBase's _setparams() method and code along
466 : my %methods = map { $_ => $_ } @LIST_OF_ALL_ALLOWED_PROGRAM_ARGS
467 : delete $methods{'verbose'};
468 : $methods{'program_verbose'} = 'verbose';
469 : my $param_string = $self->_setparams(-methods => \%methods);
470 : system("$exe $param_string");
475 my ($self, $args, @own_args) = @_;
476 $self->throw("a hash/array ref of arguments must be supplied") unless ref($args);
478 my ($methods, $force, $create, $code, $case);
480 ($methods, $force, $create, $code, $case) =
481 $self->_rearrange([qw(METHODS
485 CASE_SENSITIVE)], @own_args);
487 my $default_code = 'my $self = shift;
488 if (@_) { $self->{\'_\'.$method} = shift }
489 return $self->{\'_\'.$method};';
491 my %method_names = ();
495 if (ref($methods) eq 'HASH') {
496 @names = keys %{$methods};
500 @names = @
{$methods};
501 %syns = map { $_ => $_ } @names;
503 %method_names = map { $case ?
$_ : lc($_) => $_ } @names;
507 my %orig_args = ref($args) eq 'HASH' ?
%{$args} : @
{$args};
509 while (my ($method, $value) = each %orig_args) {
512 $args{$method} = $value;
515 # create non-existing methods on request
518 %syns = map { $_ => $case ?
$_ : lc($_) } keys %args;
521 foreach my $method (keys %syns) {
522 $self->can($method) && next;
524 my $string = $code || $default_code;
525 if (ref($code) && ref($code) eq 'HASH') {
526 $string = $code->{$method} || $default_code;
529 my $sub = eval "sub { $string }";
530 $self->throw("Compilation error for $method : $@") if $@
;
533 *{ref($self).'::'.$method} = $sub;
537 # create synonyms of existing methods
538 while (my ($method, $syn_ref) = each %syns) {
539 my $method_ref = $self->can($method) || next;
541 foreach my $syn (@
{ ref($syn_ref) ?
$syn_ref : [$syn_ref] }) {
542 next if $syn eq $method;
543 $method_names{$case ?
$syn : lc($syn)} = $syn;
544 next if $self->can($syn);
546 *{ref($self).'::'.$syn} = $method_ref;
550 # set values for methods
551 while (my ($method, $value) = each %args) {
552 $method = $method_names{$case ?
$method : lc($method)} || ($methods ?
next : $method);
553 $self->can($method) || next unless $force;
554 $self->$method($value);
559 =head2 _rearrange_old
566 my($self,$order,@param) = @_;
568 # JGRG -- This is wrong, because we don't want
569 # to assign empty string to anything, and this
570 # code is actually returning an array 1 less
571 # than the length of @param:
573 ## If there are no parameters, we simply wish to return
574 ## an empty array which is the size of the @{$order} array.
575 #return ('') x $#{$order} unless @param;
577 # ...all we need to do is return an empty array:
578 # return unless @param;
580 # If we've got parameters, we need to check to see whether
581 # they are named or simply listed. If they are listed, we
582 # can just return them.
584 # The mod test fixes bug where a single string parameter beginning with '-' gets lost.
585 # This tends to happen in error messages such as: $obj->throw("-id not defined")
586 return @param unless (defined($param[0]) && $param[0]=~/^-/o && ($#param % 2));
589 # print "\n_rearrange() named parameters:\n";
590 # my $i; for ($i=0;$i<@param;$i+=2) { printf "%20s => %s\n", $param[$i],$param[$i+1]; }; <STDIN>;
592 # Now we've got to do some work on the named parameters.
593 # The next few lines strip out the '-' characters which
594 # preceed the keys, and capitalizes them.
595 for (my $i=0;$i<@param;$i+=2) {
597 $param[$i]=~tr/a-z/A-Z/;
600 # Now we'll convert the @params variable into an associative array.
601 # local($^W) = 0; # prevent "odd number of elements" warning with -w.
606 # What we intend to do is loop through the @{$order} variable,
607 # and for each value, we use that as a key into our associative
608 # array, pushing the value at that key onto our return array.
611 #foreach (@{$order}) {
612 # my($value) = $param{$key};
613 # delete $param{$key};
614 #push(@return_array,$param{$_});
617 return @param{@
{$order}};
619 # print "\n_rearrange() after processing:\n";
620 # my $i; for ($i=0;$i<@return_array;$i++) { printf "%20s => %s\n", ${$order}[$i], $return_array[$i]; } <STDIN>;
622 # return @return_array;
625 =head2 _register_for_cleanup
627 Title : _register_for_cleanup
628 Usage : -- internal --
629 Function: Register a method to be called at DESTROY time. This is useful
630 and sometimes essential in the case of multiple inheritance for
631 classes coming second in the sequence of inheritance.
633 Args : a code reference
635 The code reference will be invoked with the object as the first
636 argument, as per a method. You may register an unlimited number of
641 sub _register_for_cleanup
{
642 my ($self,$method) = @_;
643 $self->throw_not_implemented();
646 =head2 _unregister_for_cleanup
648 Title : _unregister_for_cleanup
649 Usage : -- internal --
650 Function: Remove a method that has previously been registered to be called
651 at DESTROY time. If called with a method to be called at DESTROY time.
652 Has no effect if the code reference has not previously been registered.
654 Args : a code reference
658 sub _unregister_for_cleanup
{
659 my ($self,$method) = @_;
660 $self->throw_not_implemented();
663 =head2 _cleanup_methods
665 Title : _cleanup_methods
666 Usage : -- internal --
667 Function: Return current list of registered cleanup methods.
668 Returns : list of coderefs
673 sub _cleanup_methods
{
675 unless ( $ENV{'BIOPERLDEBUG'} || $self->verbose > 0 ) {
676 carp
("Use of Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead");
681 =head2 throw_not_implemented
683 Purpose : Throws a Bio::Root::NotImplemented exception.
684 Intended for use in the method definitions of
685 abstract interface modules where methods are defined
686 but are intended to be overridden by subclasses.
687 Usage : $object->throw_not_implemented();
688 Example : sub method_foo {
690 $self->throw_not_implemented();
694 Throws : A Bio::Root::NotImplemented exception.
695 The message of the exception contains
696 - the name of the method
697 - the name of the interface
698 - the name of the implementing class
700 If this object has a throw() method, $self->throw will be used.
701 If the object doesn't have a throw() method,
702 Carp::confess() will be used.
709 sub throw_not_implemented
{
712 # Bio::Root::Root::throw() knows how to check for Error.pm and will
713 # throw an Error-derived object of the specified class (Bio::Root::NotImplemented),
714 # which is defined in Bio::Root::Exception.
715 # If Error.pm is not available, the name of the class is just included in the
718 my $message = $self->_not_implemented_msg;
720 if ( $self->can('throw') ) {
722 if ( $self->isa('Bio::Root::Root') ) {
723 # Use Root::throw() hash-based arguments instead of RootI::throw()
724 # single string argument whenever possible
725 @args = ( -text
=> $message, -class => 'Bio::Root::NotImplemented' );
727 @args = ( $message );
737 =head2 warn_not_implemented
739 Purpose : Generates a warning that a method has not been implemented.
740 Intended for use in the method definitions of
741 abstract interface modules where methods are defined
742 but are intended to be overridden by subclasses.
743 Generally, throw_not_implemented() should be used,
744 but warn_not_implemented() may be used if the method isn't
745 considered essential and convenient no-op behavior can be
746 provided within the interface.
747 Usage : $object->warn_not_implemented( method-name-string );
748 Example : $self->warn_not_implemented( "get_foobar" );
749 Returns : Calls $self->warn on this object, if available.
750 If the object doesn't have a warn() method,
751 Carp::carp() will be used.
759 sub warn_not_implemented
{
761 my $message = $self->_not_implemented_msg;
762 if( $self->can('warn') ) {
763 $self->warn( $message );
769 =head2 _not_implemented_msg
771 Unify 'not implemented' message. -Juguang
774 sub _not_implemented_msg
{
776 my $package = ref $self;
777 my $meth = (caller(2))[3];
778 my $msg =<<EOD_NOT_IMP;
779 Abstract method \"$meth\" is not implemented by package $package.
780 This is not your fault - author of $package should be blamed!