Suppose you are a leading political figure and want certain persons to disappear. You also have members of your organisation that make this happen. But you do not trust them, in fact, you do not trust anyone - that is how you got to your position in the first place. So you want to make sure that the members of your cleanup service do their work, but if they do their work right, they will not be able to show evidence. So how can you make sure that the target is actually eliminated and not only vanished from your grasp?
If your organisation has a "mark of the beast" for every subject, then asserting the demise of unwanted individuals becomes easy as your minions only have to bring a vital and uniquely identifiable part of the target, for example, the heart, against which a DNA test can be made, or the implanted RF chip, if the removal of that chip is lethal.
A similar situation arises when you want to test whether the destructors of your class work: You can't tell whether an object really has gone away as long as you hold a reference to it, and if you release your last reference to it, you can't inspect whether it has gone away. In most cases, this is not of much interest, but if you have circular references, for example through XML tree structures where each node knows its children and the parent, cleanup becomes something that should be tested.
Luckily, Perl has all the mechanisms in place to supervise the extermination of the unwanted subjects in our influence :
The "mark of the beast" of every object is the stringified object, or in presence of overload.pm, it is overload::AddrRef. We have a central morgue in the form of the DESTROY method for every class. So if we want to check whether an object goes away, we assume we hold the last reference to it, install a temporary DESTROY subroutine that counts how often it sees the "mark of the beast" of the object, and we then release our stranglehold on that object.
If we see the mark of the beast exactly once, nobody else had a reference to the object anymore, and all was well. If we never see it, somebody else still has a live reference to the object. If we see the reference more than once, something is really wrong.
So now, here's the code, plus some questions :
First the example how the module would be used in your tests :
And here is the module itself (in its current incarnation, without POD):#!/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");
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); }; };
|
|---|
| Replies are listed 'Best First'. | |
|---|---|
|
Re: RFC: Test::Destroy ('Chasing shadows')
by adrianh (Chancellor) on May 24, 2003 at 14:58 UTC |