view release on metacpan or  search on metacpan

Bio/Root/RootI.pm  view on Meta::CPAN

                -message => 'use of the method foo() is deprecated, use bar() instead',
                -version => 1.006  # throw if $VERSION is >= this version
                );

           or timed to go off at a certain point:

           $obj->deprecated(
                -message => 'use of the method foo() is deprecated, use bar() instead',
                -warn_version    => 1.006 # warn if $VERSION is >= this version
                -throw_version   => 1.007 # throw if $VERSION is >= this version
                );

           Using the last two named argument versions is suggested and will
           likely be the only supported way of calling this method in the future
           Yes, we see the irony of deprecating that particular usage of
           deprecated().

           The main difference between usage of the two named argument versions
           is that by designating a 'warn_version' one indicates the
           functionality is officially deprecated beginning in a future version
           of BioPerl (so warnings are issued only after that point), whereas
           setting either 'version' or 'throw_version' (synonyms) converts the
           deprecation warning to an exception.

           For proper comparisons one must use a version in lines with the
           current versioning scheme for Perl and BioPerl, (i.e. where 1.006000
           indicates v1.6.0, 5.010000 for v5.10.0, etc.).

=cut

sub deprecated{
    my ($self) = shift;

    my $class = ref $self || $self;
    my $class_version = do {
        no strict 'refs';
        ${"${class}::VERSION"}
    };

    if( $class_version && $class_version =~ /set by/ ) {
        $class_version = 0.0001;
    }

    my ($msg, $version, $warn_version, $throw_version) =
        $self->_rearrange([qw(MESSAGE VERSION WARN_VERSION THROW_VERSION)], @_);

    $throw_version ||= $version;
    $warn_version  ||= $class_version;
    
    $throw_version =~ s/_//g;
    $warn_version =~ s/_//g;
    
    for my $v ( $warn_version, $throw_version) {
        no warnings 'numeric';
        $self->throw("Version must be numerical, such as 1.006000 for v1.6.0, not $v")
            unless !defined $v || $v + 0 == $v;
    }

    # below default insinuates we're deprecating a method and not a full module
    # but it's the most common use case
    $msg ||= "Use of ".(caller(1))[3]."() is deprecated.";

    if( $throw_version && $class_version && $class_version >= $throw_version ) {
        $self->throw($msg)
    }
    elsif( $warn_version && $class_version && $class_version >= $warn_version ) {

        $msg .= "\nTo be removed in $throw_version." if $throw_version;

        # passing this on to warn() should deal properly with verbosity issues
        $self->warn($msg);
    }
}

=head2 stack_trace_dump

 Title   : stack_trace_dump
 Usage   :
 Function:
 Example :
 Returns :
 Args    :


=cut

sub stack_trace_dump{
    my ($self) = @_;

    my @stack = $self->stack_trace();

    shift @stack;
    shift @stack;
    shift @stack;

    my $out;
    my ($module,$function,$file,$position);


    foreach my $stack ( @stack) {
        ($module,$file,$position,$function) = @{$stack};
        $out .= "STACK $function $file:$position\n";
    }

    return $out;
}


=head2 stack_trace

 Title   : stack_trace
 Usage   : @stack_array_ref= $self->stack_trace
 Function: gives an array to a reference of arrays with stack trace info
           each coming from the caller(stack_number) call
 Returns : array containing a reference of arrays
 Args    : none


=cut

sub stack_trace{
    my ($self) = @_;

    my $i = 0;
    my @out = ();
    my $prev = [];
    while( my @call = caller($i++)) {
        # major annoyance that caller puts caller context as
        # function name. Hence some monkeying around...
        $prev->[3] = $call[3];
        push(@out,$prev);
        $prev = \@call;
    }
    $prev->[3] = 'toplevel';
    push(@out,$prev);
    return @out;
}


=head2 _rearrange

 Usage     : $object->_rearrange( array_ref, list_of_arguments)
 Purpose   : Rearranges named parameters to requested order.
 Example   : $self->_rearrange([qw(SEQUENCE ID DESC)],@param);
           : Where @param = (-sequence => $s,
           :                 -desc     => $d,
           :                 -id       => $i);
 Returns   : @params - an array of parameters in the requested order.
           : The above example would return ($s, $i, $d).
           : Unspecified parameters will return undef. For example, if
           :        @param = (-sequence => $s);
           : the above _rearrange call would return ($s, undef, undef)
 Argument  : $order : a reference to an array which describes the desired
           :          order of the named parameters.
           : @param : an array of parameters, either as a list (in
           :          which case the function simply returns the list),
           :          or as an associative array with hyphenated tags
           :          (in which case the function sorts the values
           :          according to @{$order} and returns that new array.)
           :          The tags can be upper, lower, or mixed case
           :          but they must start with a hyphen (at least the
           :          first one should be hyphenated.)
 Source    : This function was taken from CGI.pm, written by Dr. Lincoln
           : Stein, and adapted for use in Bio::Seq by Richard Resnick and
           : then adapted for use in Bio::Root::Object.pm by Steve Chervitz,
           : then migrated into Bio::Root::RootI.pm by Ewan Birney.
 Comments  :
           : Uppercase tags are the norm,
           : (SAC)
           : This method may not be appropriate for method calls that are
           : within in an inner loop if efficiency is a concern.
           :
           : Parameters can be specified using any of these formats:
           :  @param = (-name=>'me', -color=>'blue');
           :  @param = (-NAME=>'me', -COLOR=>'blue');
           :  @param = (-Name=>'me', -Color=>'blue');
           :  @param = ('me', 'blue');
           : A leading hyphenated argument is used by this function to
           : indicate that named parameters are being used.
           : Therefore, the ('me', 'blue') list will be returned as-is.
           :
           : Note that Perl will confuse unquoted, hyphenated tags as
           : function calls if there is a function of the same name
           : in the current namespace:
           :    -name => 'foo' is interpreted as -&name => 'foo'
           :
           : For ultimate safety, put single quotes around the tag:

Bio/Root/RootI.pm  view on Meta::CPAN

    my $message = $self->_not_implemented_msg;

    if ( $self->can('throw') ) {
        my @args;
        if ( $self->isa('Bio::Root::Root') ) {
            # Use Root::throw() hash-based arguments instead of RootI::throw()
            # single string argument whenever possible
            @args = ( -text  => $message, -class => 'Bio::Root::NotImplemented' );
        } else {
            @args = ( $message );
        }
        $self->throw(@args);

    } else {
        confess $message;
    }
}


=head2 warn_not_implemented

 Purpose : Generates a warning that a method has not been implemented.
           Intended for use in the method definitions of
           abstract interface modules where methods are defined
           but are intended to be overridden by subclasses.
           Generally, throw_not_implemented() should be used,
           but warn_not_implemented() may be used if the method isn't
           considered essential and convenient no-op behavior can be
           provided within the interface.
 Usage   : $object->warn_not_implemented( method-name-string );
 Example : $self->warn_not_implemented( "get_foobar" );
 Returns : Calls $self->warn on this object, if available.
           If the object doesn't have a warn() method,
           Carp::carp() will be used.
 Args    : n/a


=cut

#'

sub warn_not_implemented {
    my $self = shift;
    my $message = $self->_not_implemented_msg;
    if( $self->can('warn') ) {
        $self->warn( $message );
    }else {
        carp $message ;
    }
}

=head2 _not_implemented_msg

Unify 'not implemented' message. -Juguang
=cut

sub _not_implemented_msg {
    my $self = shift;
    my $package = ref $self;
    my $meth = (caller(2))[3];
    my $msg =<<EOD_NOT_IMP;
Abstract method \"$meth\" is not implemented by package $package.
This is not your fault - author of $package should be blamed!
EOD_NOT_IMP
    return $msg;
}

1;