package WebGUI::Deprecate;

=head1 NAME

WebGUI::Deprecate - Warn about subroutine deprecations

=head1 SYNOPSIS

 use WebGUI::Deprecate;

 deprecate oldMethod => 'newMethod';
 sub newMethod { # will get called either way }

=head1 DESCRIPTION

Deprecate a subroutine, spitting out a warning whenever it is used.

=cut

use strict;
use warnings;

use Sub::Exporter -setup => {
    exports => [ 'deprecate' ],
    groups => {
        default => [ 'deprecate' ],
    }
};

my %warned;
sub deprecate ($$) {
    my ($old_method, $new_method) = @_;
    my $package = caller;
    no strict 'refs';
    no warnings 'redefine';

    my %deep;
    # keep a copy since it will be replaced
    my $new_sub = \&{"$package\::$new_method"};
    # call new method instead.  if 
    *{"$package\::$old_method"} = sub {
        my $self = shift;
        my $message = "$package\::$old_method is deprecated and should be replaced with $new_method at " . join( "-", (caller(0))[0,2] );
        warn $message
            unless $warned{$message}++;

        local $deep{1} = 1;
        $self->$new_method(@_);
    };
    *{"$package\::$new_method"} = sub {
        my $self = $_[0];
        if (!$deep{1}) {
            my $old_sub = $self->can($old_method);
            if ($old_sub ne \&{"$package\::$old_method"}) {
                my $message = "Subclass of $package uses deprecated method $old_method, which should be replaced with $new_method";
                carp $message
                    unless $warned{$message}++;
                goto $old_sub;
            }
        }
        goto $new_sub;
    };
}

1;