Bio::Tools::CodonTable and Bio::Tools::IUPAC: prepare with dzil.
[bioperl-live.git] / lib / Bio / Root / RootI.pm
blob97c1b08d07d41f6b57271f70c2f667da284e553b
1 package Bio::Root::RootI;
3 use strict;
4 use Carp 'confess','carp';
6 =head1 NAME
8 Bio::Root::RootI - base interface for all BioPerl classes
10 =head1 SYNOPSIS
12 # any bioperl or bioperl compliant object is a RootI
13 # compliant object
15 $obj->throw("This is an exception");
17 eval {
18 $obj->throw("This is catching an exception");
21 if( $@ ) {
22 print "Caught exception";
23 } else {
24 print "no exception";
27 # Using throw_not_implemented() within a RootI-based interface module:
29 package Foo;
30 use base qw(Bio::Root::RootI);
32 sub foo {
33 my $self = shift;
34 $self->throw_not_implemented;
38 =head1 DESCRIPTION
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
42 stack traces.
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
52 thrown.
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
58 following:
60 sub foo {
61 my $self = shift;
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
79 =cut
81 use vars qw($DEBUG $ID $VERBOSITY);
82 BEGIN {
83 $ID = 'Bio::Root::RootI';
84 $DEBUG = 0;
85 $VERBOSITY = 0;
88 =head2 new
90 =cut
92 sub new {
93 my $class = shift;
94 my @args = @_;
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
103 sub _initialize {
104 my($self,@args) = @_;
105 return 1;
109 =head2 throw
111 Title : throw
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
115 Returns : nothing
116 Args : A string giving a descriptive error message
119 =cut
121 sub throw{
122 my ($self,$string) = @_;
124 my $std = $self->stack_trace_dump();
126 my $out = "\n-------------------- EXCEPTION --------------------\n"
127 . "MSG: " . $string . "\n"
128 . $std."-------------------------------------------\n";
129 die $out;
132 =head2 warn
134 Title : warn
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
142 Returns : n/a
143 Args : string (the warning message)
145 =cut
147 sub warn {
148 my ($self,$string) = @_;
150 my $verbose = $self->verbose;
152 my $header = "\n--------------------- WARNING ---------------------\nMSG: ";
153 my $footer = "---------------------------------------------------\n";
155 if ($verbose >= 2) {
156 $self->throw($string);
158 elsif ($verbose <= -1) {
159 return;
161 elsif ($verbose == 1) {
162 CORE::warn $header, $string, "\n", $self->stack_trace_dump, $footer;
163 return;
166 CORE::warn $header, $string, "\n", $footer;
169 =head2 deprecated
171 Title : deprecated
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",
176 -version => 1.007);
177 Function: Prints a message about deprecation unless verbose is < 0
178 (which means be quiet)
179 Returns : none
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.
191 =cut
193 sub deprecated{
194 my ($self) = shift;
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
205 ## give a warning.
206 if (! defined($version) && ! defined($warn_version)
207 && ! defined($throw_version)) {
208 carp($msg);
209 return;
212 my $class = ref $self || $self;
213 my $class_version = do {
214 no strict 'refs';
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 ) {
235 $self->throw($msg)
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
242 $self->warn($msg);
246 =head2 stack_trace_dump
248 Title : stack_trace_dump
249 Usage :
250 Function:
251 Example :
252 Returns :
253 Args :
256 =cut
258 sub stack_trace_dump{
259 my ($self) = @_;
261 my @stack = $self->stack_trace();
263 shift @stack;
264 shift @stack;
265 shift @stack;
267 my $out;
268 my ($module,$function,$file,$position);
271 foreach my $stack ( @stack) {
272 ($module,$file,$position,$function) = @{$stack};
273 $out .= "STACK $function $file:$position\n";
276 return $out;
280 =head2 stack_trace
282 Title : stack_trace
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
287 Args : none
290 =cut
292 sub stack_trace{
293 my ($self) = @_;
295 my $i = 0;
296 my @out = ();
297 my $prev = [];
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];
302 push(@out,$prev);
303 $prev = \@call;
305 $prev->[3] = 'toplevel';
306 push(@out,$prev);
307 return @out;
311 =head2 _rearrange
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,
317 : -desc => $d,
318 : -id => $i);
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.
338 Comments :
339 : Uppercase tags are the norm,
340 : (SAC)
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
367 : conflicts.
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.
379 =cut
381 sub _rearrange {
382 my ($self, $order, @args) = @_;
384 return @args unless $args[0] && $args[0] =~ /^\-/;
386 push @args, undef unless $#args % 2;
388 my %param;
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,
404 : -ID => $i);
406 : the above _set_from_args calls the following methods:
407 : $self->sequence($s);
408 : $self->id($i);
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-
426 : element array ref
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
442 : will be in effect.
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
446 : which they use).
447 Comments :
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
465 : the lines of:
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");
472 =cut
474 sub _set_from_args {
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);
479 if (@own_args) {
480 ($methods, $force, $create, $code, $case) =
481 $self->_rearrange([qw(METHODS
482 FORCE
483 CREATE
484 CODE
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 = ();
492 my %syns = ();
493 if ($methods) {
494 my @names;
495 if (ref($methods) eq 'HASH') {
496 @names = keys %{$methods};
497 %syns = %{$methods};
499 else {
500 @names = @{$methods};
501 %syns = map { $_ => $_ } @names;
503 %method_names = map { $case ? $_ : lc($_) => $_ } @names;
506 # deal with hyphens
507 my %orig_args = ref($args) eq 'HASH' ? %{$args} : @{$args};
508 my %args;
509 while (my ($method, $value) = each %orig_args) {
510 $method =~ s/^-+//;
511 $method =~ s/-/_/g;
512 $args{$method} = $value;
515 # create non-existing methods on request
516 if ($create) {
517 unless ($methods) {
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 $@;
532 no strict 'refs';
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);
545 no strict 'refs';
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
561 =cut
563 #----------------'
564 sub _rearrange_old {
565 #----------------
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));
588 # Tester
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) {
596 $param[$i]=~s/^\-//;
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.
602 my(%param) = @param;
604 # my(@return_array);
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.
609 # my($key);
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.
632 Returns :
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
637 cleanup methods.
639 =cut
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.
653 Returns : nothing
654 Args : a code reference
656 =cut
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
669 Args : none
671 =cut
673 sub _cleanup_methods {
674 my $self = shift;
675 unless ( $ENV{'BIOPERLDEBUG'} || $self->verbose > 0 ) {
676 carp("Use of Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead");
678 return;
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 {
689 $self = shift;
690 $self->throw_not_implemented();
692 Returns : n/a
693 Args : n/a
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.
705 =cut
709 sub throw_not_implemented {
710 my $self = shift;
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
716 # error message.
718 my $message = $self->_not_implemented_msg;
720 if ( $self->can('throw') ) {
721 my @args;
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' );
726 } else {
727 @args = ( $message );
729 $self->throw(@args);
731 } else {
732 confess $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.
752 Args : n/a
755 =cut
759 sub warn_not_implemented {
760 my $self = shift;
761 my $message = $self->_not_implemented_msg;
762 if( $self->can('warn') ) {
763 $self->warn( $message );
764 }else {
765 carp $message ;
769 =head2 _not_implemented_msg
771 Unify 'not implemented' message. -Juguang
772 =cut
774 sub _not_implemented_msg {
775 my $self = shift;
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!
781 EOD_NOT_IMP
782 return $msg;