Skip to content

Commit

Permalink
rewrite deprecated() to work with the PACKAGE version of the caller
Browse files Browse the repository at this point in the history
  • Loading branch information
@rbuels
rbuels committed Aug 18, 2011
1 parent 60c5a48 commit 82ff771
Show file tree
Hide file tree
Showing 2 changed files with 80 additions and 59 deletions.
52 changes: 33 additions & 19 deletions lib/Bio/Root/RootI.pm
View file
Expand Up @@ -106,9 +106,7 @@ use vars qw($DEBUG $ID $VERBOSITY);
use strict;
use Carp 'confess','carp';

use Bio::Root::Version;

BEGIN {
BEGIN {
$ID = 'Bio::Root::RootI';
$DEBUG = 0;
$VERBOSITY = 0;
Expand Down Expand Up @@ -243,27 +241,43 @@ sub warn {

sub deprecated{
my ($self) = shift;

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

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

my ($msg, $version, $warn_version, $throw_version) =
$self->_rearrange([qw(MESSAGE VERSION WARN_VERSION THROW_VERSION)], @_);
$version ||= $throw_version;
for my $v ($warn_version, $version) {
next unless defined $v;
$self->throw('Version must be numerical, such as 1.006000 for v1.6.0, not '.
$v) unless $v =~ /^\d+\.\d+$/;
$self->_rearrange([qw(MESSAGE VERSION WARN_VERSION THROW_VERSION)], @_);

$throw_version ||= $version;
$warn_version ||= $class_version;

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 eq $v;
}
return if ($warn_version && $Bio::Root::Version::VERSION < $warn_version);

# 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";
# delegate to either warn or throw based on whether a version is given
if ($version) {
$msg .= "\nTo be removed in $version";
if ($Bio::Root::Version::VERSION >= $version) {
$self->throw($msg)
}
$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);
}
# passing this on to warn() should deal properly with verbosity issues
$self->warn($msg);
}

=head2 stack_trace_dump
Expand Down
87 changes: 47 additions & 40 deletions t/Root/RootI.t
View file
Expand Up @@ -83,7 +83,7 @@ my $seq = Bio::Seq->new();
is $seq->verbose, 1;

# test for bug #1343
my @vals = Bio::Root::RootI->_rearrange([qw(apples pears)],
my @vals = Bio::Root::RootI->_rearrange([qw(apples pears)],
-apples => 'up the',
-pears => 'stairs');
is shift @vals, 'up the';
Expand All @@ -92,36 +92,41 @@ is shift @vals, 'stairs';
# test deprecated()

# class method
warning_like{ Bio::Root::Root->deprecated('Test1') } qr/Test1/, 'simple';
warning_like{ Bio::Root::Root->deprecated(-message => 'Test2') } qr/Test2/, 'simple';
warning_like{ Bio::Root::Root->deprecated('Test3', 999.999) } qr/Test3/,
'warns for versions below current version '.$Bio::Root::Version::VERSION;
warning_like{ Bio::Root::Root->deprecated(-message => 'Test4',
-version => 999.999) } qr/Test4/,
'warns for versions below current version '.$Bio::Root::Version::VERSION;
throws_ok{ Bio::Root::Root->deprecated('Test5', 0.001) } qr/Test5/,
'throws for versions above '.$Bio::Root::Version::VERSION;
throws_ok{ Bio::Root::Root->deprecated(-message => 'Test6',
-version => 0.001) } qr/Test6/,
'throws for versions above '.$Bio::Root::Version::VERSION;
throws_ok{ Bio::Root::Root->deprecated(-message => 'Test6',
-version => $Bio::Root::Version::VERSION) } qr/Test6/,
'throws for versions equal to '.$Bio::Root::Version::VERSION;

# object method
my $root = Bio::Root::Root->new();
warning_like{ $root->deprecated('Test1') } qr/Test1/, 'simple';
warning_like{ $root->deprecated(-message => 'Test2') } qr/Test2/, 'simple';
warning_like{ $root->deprecated('Test3', 999.999) } qr/Test3/,
'warns for versions below current version '.$Bio::Root::Version::VERSION;
warning_like{ $root->deprecated(-message => 'Test4',
-version => 999.999) } qr/Test4/,
'warns for versions below current version '.$Bio::Root::Version::VERSION;
throws_ok{ $root->deprecated('Test5', 0.001) } qr/Test5/,
'throws for versions above '.$Bio::Root::Version::VERSION;
throws_ok{ $root->deprecated(-message => 'Test6',
-version => 0.001) } qr/Test6/,
'throws for versions above '.$Bio::Root::Version::VERSION;
{
local $Bio::Root::Root::VERSION = 8.9;
warning_like{ Bio::Root::Root->deprecated('Test1') } qr/Test1/, 'simple';
warning_like{ Bio::Root::Root->deprecated(-message => 'Test2') } qr/Test2/, 'simple';
warning_like{ Bio::Root::Root->deprecated('Test3', 999.999) } qr/Test3/,
'warns for versions below current version';
warning_like{ Bio::Root::Root->deprecated(-message => 'Test4',
-version => 999.999) } qr/Test4/,
'warns for versions below current version';
throws_ok{ Bio::Root::Root->deprecated('Test5', 0.001) } qr/Test5/,
'throws for versions above current version';
throws_ok{ Bio::Root::Root->deprecated(-message => 'Test6',
-version => 0.001) } qr/Test6/,
'throws for versions above current version';

throws_ok{ Bio::Root::Root->deprecated(-message => 'Test6',
-version => $Bio::Root::Root::VERSION) } qr/Test6/,
'throws for versions equal to current version';

# object method
my $root = Bio::Root::Root->new();
warning_like{ $root->deprecated('Test1') } qr/Test1/, 'simple';
warning_like{ $root->deprecated(-message => 'Test2') } qr/Test2/, 'simple';
warning_like{ $root->deprecated('Test3', 999.999) } qr/Test3/,
'warns for versions below current version';
warning_like{ $root->deprecated(-message => 'Test4',
-version => 999.999) } qr/Test4/,
'warns for versions below current version';
throws_ok{ $root->deprecated('Test5', 0.001) } qr/Test5/,
'throws for versions above current version';
throws_ok{ $root->deprecated(-message => 'Test6',
-version => 0.001) } qr/Test6/,
'throws for versions above current version';

}

# tests for _set_from_args()
# Let's not pollute Bio::Root::Root namespace if possible
Expand All @@ -131,6 +136,7 @@ throws_ok{ $root->deprecated(-message => 'Test6',

package Bio::Foo1;
use base qw(Bio::Root::Root);
our $VERSION = '2.00';
sub new {
my $class = shift;
my $self = {};
Expand Down Expand Up @@ -245,9 +251,10 @@ is($obj->t7, 1, 'original is not modified');
{
package Bio::Foo5;
use base qw(Bio::Root::Root);

our $v = $Bio::Root::Version::VERSION;


our $v = '18.001';
our $VERSION = $v;

sub not_good {
my $self = shift;
$self->deprecated(-message => 'This is not good',
Expand Down Expand Up @@ -297,16 +304,16 @@ throws_ok { $foo->plain_incorrect } qr/Version must be numerical/,
'must use proper versioning scheme';

warning_like{ $foo->not_good } qr/This is not good/,
'warns for versions >= '.$Bio::Root::Version::VERSION;
'warns for versions >= current version';
# this tests the three-arg (non-named) form just to make sure it works, even
# though we probably won't support it
warning_like{ $foo->not_good2 } qr/This is not good/,
'warns for versions >= '.$Bio::Root::Version::VERSION;
'warns for versions >= current version';

throws_ok { $foo->really_not_good } qr/This is really not good/,
'throws for versions >= '.$Bio::Root::Version::VERSION;
'throws for versions >= current version';
throws_ok { $foo->still_very_bad } qr/This is still very bad/,
'throws for versions >= '.$Bio::Root::Version::VERSION;
lives_ok { $foo->okay_for_now } 'No warnings/exceptions below '.$Bio::Root::Version::VERSION;
'throws for versions >= current version';
lives_ok { $foo->okay_for_now } 'No warnings/exceptions below current version';


0 comments on commit 82ff771

Please sign in to comment.