initial checkin

diff --git a/Changes b/Changes
new file mode 100644 (file)
index 0000000..85a36cb
--- /dev/null
+++ b/Changes
@@ -0,0 +1,3 @@
+0.01
+
+- First release

diff --git a/dist.ini b/dist.ini
new file mode 100644 (file)
index 0000000..01bfdc7
--- /dev/null
+++ b/dist.ini
@@ -0,0 +1,41 @@
+name    = Package-DeprecationManager
+author  = Dave Rolsky <autarch@urth.org>
+copyright_year = 2010
+
+version = 0.01
+
+[@Basic]
+
+[InstallGuide]
+[MetaJSON]
+
+[MetaResources]
+bugtracker.web    = http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-DeprecationManager
+bugtracker.mailto = bug-package-deprecationmanager@rt.cpan.org
+repository.url    = git://git.moose.perl.org/Package-DeprecationManager.git
+repository.web    = http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo/Package-DeprecationManager.git;a=summary
+repository.type   = git
+
+[PodWeaver]
+
+[PkgVersion]
+
+[KwaliteeTests]
+[PodTests]
+[NoTabsTests]
+[EOLTests]
+[Signature]
+
+[CheckChangeLog]
+
+[Prereqs]
+Carp         = 0
+Params::Util = 0
+Sub::Install = 0
+
+[Prereqs / TestRequires]
+Test::Exception = 0
+Test::More      = 0.88
+Test::Warn      = 0
+
+[@Git]

diff --git a/lib/Package/DeprecationManager.pm b/lib/Package/DeprecationManager.pm
new file mode 100644 (file)
index 0000000..b18cb65
--- /dev/null
+++ b/lib/Package/DeprecationManager.pm
@@ -0,0 +1,106 @@
+package Package::DeprecationManager;
+
+use strict;
+use warnings;
+
+use Carp qw( croak );
+use Params::Util qw( _HASH );
+use Sub::Install;
+
+sub import {
+    shift;
+    my %args = @_;
+
+    croak
+        'You must provide a hash reference -deprecations parameter when importing Package::DeprecationManager'
+        unless $args{-deprecations} && _HASH( $args{-deprecations} );
+
+    my %registry;
+
+    my $import = _build_import( \%registry );
+    my $warn = _build_warn( \%registry, $args{-deprecations} );
+
+    my $caller = caller();
+
+    Sub::Install::install_sub(
+        {
+            code => $import,
+            into => $caller,
+            as   => 'import',
+        }
+    );
+
+    Sub::Install::install_sub(
+        {
+            code => $warn,
+            into => $caller,
+            as   => 'deprecated',
+        }
+    );
+
+    return;
+}
+
+sub _build_import {
+    my $registry = shift;
+
+    return sub {
+        my $class = shift;
+        my %args  = @_;
+
+        $registry->{ caller() } = $args{-api_version}
+            if $args{-api_version};
+
+        return;
+    };
+}
+
+sub _build_warn {
+    my $registry      = shift;
+    my $deprecated_at = shift;
+
+    my %warned;
+
+    return sub {
+        my ( $package, undef, undef, $sub ) = caller(1);
+
+        my $compat_version = $registry->{$package};
+
+        my $deprecated_at = $deprecated_at->{$sub};
+
+        return
+            if defined $compat_version
+                && defined $deprecated_at
+                && $compat_version lt $deprecated_at;
+
+        return if $warned{$package}{$sub};
+
+        if ( ! @_ ) {
+            my $msg = "$sub has been deprecated";
+            $msg .= " since version $deprecated_at"
+                if defined $deprecated_at;
+
+            @_ = $msg;
+        }
+
+        $warned{$package}{$sub} = 1;
+
+        goto &Carp::cluck;
+    };
+}
+
+1;
+
+# ABSTRACT: Manage deprecation warnings for your distribution
+
+__END__
+
+=pod
+
+=head1 SYNOPSIS
+
+  ...
+
+=head1 DESCRIPTION
+
+=cut

diff --git a/t/basic.t b/t/basic.t
new file mode 100644 (file)
index 0000000..9fadb79
--- /dev/null
+++ b/t/basic.t
@@ -0,0 +1,100 @@
+use strict;
+use warnings;
+
+use Test::Exception;
+use Test::More;
+use Test::Warn;
+
+{
+    throws_ok {
+        eval 'package Foo; use Package::DeprecationManager;';
+        die $@ if $@;
+    }
+    qr/^\QYou must provide a hash reference -deprecations parameter when importing Package::DeprecationManager/,
+        'must provide a set of deprecations when using Package::DeprecationManager';
+}
+
+{
+    package Foo;
+
+    use Package::DeprecationManager -deprecations => {
+        'Foo::foo' => '0.02',
+        'Foo::bar' => '0.03',
+        'Foo::baz' => '1.21',
+    };
+
+    sub foo {
+        deprecated('foo is deprecated');
+    }
+
+    sub bar {
+        deprecated('bar is deprecated');
+    }
+
+    sub baz {
+        deprecated();
+    }
+}
+
+{
+    package Bar;
+
+    Foo->import();
+
+    ::warning_is{ Foo::foo() }
+        { carped => 'foo is deprecated' },
+        'deprecation warning for foo';
+
+    ::warning_is{ Foo::bar() }
+        { carped => 'bar is deprecated' },
+        'deprecation warning for bar';
+
+    ::warning_is{ Foo::baz() }
+        { carped => 'Foo::baz has been deprecated since version 1.21' },
+        'deprecation warning for baz, and message is generated by Package::DeprecationManager';
+
+    ::warning_is{ Foo::foo() } q{}, 'no warning on second call to foo';
+
+    ::warning_is{ Foo::bar() } q{}, 'no warning on second call to bar';
+
+    ::warning_is{ Foo::baz() } q{}, 'no warning on second call to baz';
+}
+
+{
+    package Baz;
+
+    Foo->import( -api_version => '0.01' );
+
+    ::warning_is{ Foo::foo() }
+        q{},
+        'no warning for foo with api_version = 0.01';
+
+    ::warning_is{ Foo::bar() }
+        q{},
+        'no warning for bar with api_version = 0.01';
+
+    ::warning_is{ Foo::baz() }
+        q{},
+        'no warning for baz with api_version = 0.01';
+}
+
+
+{
+    package Quux;
+
+    Foo->import( -api_version => '1.17' );
+
+    ::warning_is{ Foo::foo() }
+        { carped => 'foo is deprecated' },
+        'deprecation warning for foo with api_version = 1.17';
+
+    ::warning_is{ Foo::bar() }
+        { carped => 'bar is deprecated' },
+        'deprecation warning for bar with api_version = 1.17';
+
+    ::warning_is{ Foo::baz() }
+        q{},
+        'no warning for baz with api_version = 1.17';
+}
+
+done_testing();