#!/usr/bin/perl -w
use strict;

use Test::More;
use Test::DESTROY tests => 6;

my $foo = bless {},'My::Test::Class';
destroyed_ok($foo,"Simple class");

my $foo1 = bless {},'My::Test::Class';
my $bar = $foo1;

destroyed_ok($foo1,"Simple class with two references (expected fail)");

my $foo2 = bless {},'My::Test::Class';
$foo2->{child1} = bless {},'My::Test::Class';
$foo2->{child2} = bless {},'My::Test::Class';
destroyed_ok($foo2,"Simple class with two references");

my $foo3 = bless {},'My::Test::Class';
$bar = $foo3;
$foo3->{child1} = bless {},'My::Test::Class';
$foo3->{child2} = bless {},'My::Test::Class';
destroyed_ok($foo3,"Simple class with two references (expected fail)");

my $foo4 = bless {},'My::Test::Class::Destructor';
my $called = 0;
sub My::Test::Class::Destructor::DESTROY { $called++; };
destroyed_ok($foo4,"Simple class with two references");
is($called,1,"Previous destructor gets called");

##</code><code>##

package Test::DESTROY;
use strict;
use Test::Builder;
require Exporter;
use vars qw( @ISA @EXPORT );
@ISA = qw(Exporter);
@EXPORT = qw(destroyed_ok);

my $Test = Test::Builder->new;

sub import {
  my($self) = shift;
  my $pack = caller;

  $Test->exported_to($pack);
  $Test->plan(@_);

  $self->export_to_level(1, $self, 'destroyed_ok');
};

sub object_id {
  my $id;
  eval {
    require overload;
    $id = overload::AddrRef( $_[0] );
  };

  # If we couldn't load overload, assume nobody else could either,
  # so simple stringification should work
  $id = "$_[0]" if $@;

  $id;
};

sub destroyed_ok {
  my $name = $_[1];
  $name ||= "The object";
  $name = "$name was destroyed";

  my $fail_reason;
  if (ref $_[0]) {
    if (UNIVERSAL::isa($_[0],'UNIVERSAL')) {
      my $class = ref $_[0];
      my $id = object_id( $_[0] );
      my $count = 0;

      no strict 'refs';
      my $prev_destructor = *{$class . "::DESTROY"}{CODE};
      local *{$class . "::DESTROY"} = sub {
        $count++ if object_id($_[0]) eq $id;
        goto $prev_destructor if $prev_destructor
      };
      undef $_[0];

      if ($count == 1) {
        $Test->ok(1,$name);
      } elsif ($count > 1) {
        $fail_reason = "${class}::DESTROY was called $count times";
      } else {
        $fail_reason = "${class}::DESTROY was never called for $id";
      };
    } else {
      $fail_reason = "$_[0] is not a blessed reference.";
    };
  } else {
    $fail_reason = "$_[0] is not a reference.";
  };

  if ($fail_reason) {
    $Test->ok(0,$name);
    $Test->diag($fail_reason);
  };
};