1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
#!/usr/bin/perl
##
## Test for constructor of Object::Destroyer
##
use strict;
use warnings;
use Test::More;
use Object::Destroyer;
my $foo = Foo->new;
my $bar = Bar->new;
##
## Object::destroyer->new($object)
## $object must have 'DESTROY' method
##
ok( Object::Destroyer->new($foo) );
ok( !eval{ Object::Destroyer->new($bar); 1; } );
like( $@, qr/Object::Destroyer requires that Bar has a DESTROY method at.*/ );
##
## Object::Destroyer->new($object, $method)
## $object must have method $method
##
ok( Object::Destroyer->new($foo, 'hello') );
ok( Object::Destroyer->new($foo, 'DESTROY') );
ok( Object::Destroyer->new($foo, 'release') );
ok( Object::Destroyer->new($bar, 'delete') );
##
## Negative tests: non-existent methods, extra params to constructor
## and no method names
##
ok( !eval{ Object::Destroyer->new($foo, 'BAZ'); 1; } );
like( $@, qr/^Object::Destroyer requires that Foo has a BAZ method at.*/ );
ok( !eval{ Object::Destroyer->new($foo, 'hello', 'hello'); 1; } );
like( $@, qr/^Extra arguments to constructor at.*/ );
ok( !eval{ Object::Destroyer->new($foo, $foo); 1; } );
like( $@, qr/^Second argument to constructor must be a method name*/ );
##
## Object::Destroyer->new($codereference);
##
ok( Object::Destroyer->new(sub {}) );
ok( Object::Destroyer->new(\&Foo::hello) );
##
## Negative tests - extra params lead to die()
##
ok( !eval{ Object::Destroyer->new(sub {}, 'extra'); 1;} );
like( $@, qr/^Extra arguments to constructor at.*/ );
##
## Unknown arguments to constructor leads to die
##
ok( !eval{ Object::Destroyer->new('extra'); 1;} );
like( $@, qr/^You should pass an object or code reference to constructor at .*/ );
done_testing;
#####################################################################
# Test Classes
package Foo;
sub new {
my $self = shift;
return bless {}, ref $self || $self;
}
sub hello { }
sub release { }
sub DESTROY { }
package Bar;
sub new {
my $self = shift;
return bless {}, ref $self || $self;
}
sub delete { }
1;
|
