drop t/01_main.t from git which is not in the orig tarball
Gbp-Dch: Ignore
gregor herrmann
6 years ago
| 0 | #!/usr/bin/perl -w | |
| 1 | ||
| 2 | # Formal testing for Object::Destroyer | |
| 3 | ||
| 4 | use strict; | |
| 5 | use File::Spec::Functions qw{:ALL}; | |
| 6 | use lib catdir( updir(), updir(), 'modules' ), # Development testing | |
| 7 | catdir( updir(), 'lib' ); # Installation testing | |
| 8 | use UNIVERSAL 'isa'; | |
| 9 | use Test::More tests => 19; | |
| 10 | use Scalar::Util 'blessed'; | |
| 11 | ||
| 12 | # Check their perl version | |
| 13 | BEGIN { | |
| 14 | $| = 1; | |
| 15 | ok( $] >= 5.005, "Your perl is new enough" ); | |
| 16 | } | |
| 17 | ||
| 18 | ||
| 19 | ||
| 20 | ||
| 21 | ||
| 22 | # Does the module load | |
| 23 | use_ok( 'Object::Destroyer' ); | |
| 24 | ||
| 25 | # Make sure a plain Foo object pair behaves as expected | |
| 26 | is( $Foo::destroy_counter, 0, 'DESTROY counter returns expected value' ); | |
| 27 | my $pair = Foo->new; | |
| 28 | isa_ok( $pair, 'Foo' ); | |
| 29 | isa_ok( $pair->{spouse}, 'Foo' ); | |
| 30 | isa_ok( $pair->{spouse}->{spouse}, 'Foo' ); | |
| 31 | is( $pair->hello, 'Hello World!', 'Foo->hello returns as expected' ); | |
| 32 | is( $pair->hello('Bob'), 'Hello Bob!', 'Foo->hello(args) returns as expected' ); | |
| 33 | $pair->DESTROY; | |
| 34 | is( $Foo::destroy_counter, 2, 'DESTROY counter returns expected value' ); | |
| 35 | ||
| 36 | # Make sure that when we use a lexically scoped circular pair, they leak as expected | |
| 37 | { Foo->new } | |
| 38 | is( $Foo::destroy_counter, 2, "Circularly dependant object don't automatically DESTROY" ); | |
| 39 | ||
| 40 | ||
| 41 | ||
| 42 | ||
| 43 | ||
| 44 | # Create a Object::Destroyer object with a pair in it | |
| 45 | my $temp = Foo->new; | |
| 46 | my $Foo = Object::Destroyer->new( $temp ); | |
| 47 | is( blessed $Foo, 'Object::Destroyer', 'New object is an Object::Destroyer' ); | |
| 48 | isa_ok( $$Foo, 'Foo' ); | |
| 49 | is( $Foo->hello, 'Hello World!', 'Normals methods pass through correctly' ); | |
| 50 | is( $Foo->hello('Sam'), 'Hello Sam!', 'Normals methods with params pass through correctly' ); | |
| 51 | eval { $temp->foo; }; my $native_error = $@; eval { $Foo->foo; }; | |
| 52 | $DB::single = $DB::single = 1; | |
| 53 | $native_error =~ s/\.(?=\n$)//; # perl adds a trailing fullstop, Carp doesn't. | |
| 54 | is( $native_error, $@, 'Errors match on bad method case' ); | |
| 55 | ||
| 56 | # Does the ->new method pass through the Wrapper | |
| 57 | isa_ok( $Foo->new, 'Foo' ); | |
| 58 | ||
| 59 | is( $Foo::destroy_counter, 2, 'DESTROY counter returns as expected' ); | |
| 60 | undef $Foo; | |
| 61 | is( $Foo::destroy_counter, 4, 'DESTROY counter returns as expected' ); | |
| 62 | ||
| 63 | ||
| 64 | ||
| 65 | ||
| 66 | ||
| 67 | # Test a fully implicit create, dropping out of scope, DESTROY cycle | |
| 68 | { Object::Destroyer->new( Foo->new ) } | |
| 69 | is( $Foo::destroy_counter, 6, 'Implicit create/exitscope/DESTROY cycle worked' ); | |
| 70 | ||
| 71 | ||
| 72 | ||
| 73 | ||
| 74 | ||
| 75 | ||
| 76 | ##################################################################### | |
| 77 | # Test Classes | |
| 78 | ||
| 79 | package Foo; | |
| 80 | ||
| 81 | use vars qw{$destroy_counter}; | |
| 82 | BEGIN { $destroy_counter = 0 } | |
| 83 | ||
| 84 | sub new { | |
| 85 | my $class = ref $_[0] ? ref shift : shift; | |
| 86 | ||
| 87 | # Create TWO object, that reference each other in a circular | |
| 88 | # relationship, and return one of them. | |
| 89 | my $first = bless {}, $class; | |
| 90 | my $second = bless { spouse => $first }, $class; | |
| 91 | $first->{spouse} = $second; | |
| 92 | ||
| 93 | $first; | |
| 94 | } | |
| 95 | ||
| 96 | sub hello { shift; @_ ? "Hello $_[0]!" : "Hello World!" } | |
| 97 | ||
| 98 | sub DESTROY { | |
| 99 | if ( keys %{$_[0]} ) { | |
| 100 | %{$_[0]} = (); | |
| 101 | $destroy_counter++; | |
| 102 | } | |
| 103 | } | |
| 104 | ||
| 105 | 1; |