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
|
use strict;
use warnings;
use Test::More tests => 19;
package Ray;
use base qw(Class::Data::Accessor);
Ray->mk_classaccessors('Ubu');
Ray->mk_classaccessor(DataFile => '/etc/stuff/data');
package Gun;
use base qw(Ray);
Gun->Ubu('Pere');
package Suitcase;
use base qw(Gun);
Suitcase->DataFile('/etc/otherstuff/data');
package main;
foreach my $class (qw/Ray Gun Suitcase/) {
can_ok $class =>
qw/mk_classaccessor Ubu _Ubu_accessor DataFile _DataFile_accessor/;
}
# Test that superclasses effect children.
is +Gun->Ubu, 'Pere', 'Ubu in Gun';
is +Suitcase->Ubu, 'Pere', "Inherited into children";
is +Ray->Ubu, undef, "But not set in parent";
# Set value with data
is +Ray->DataFile, '/etc/stuff/data', "Ray datafile";
is +Gun->DataFile, '/etc/stuff/data', "Inherited into gun";
is +Suitcase->DataFile, '/etc/otherstuff/data', "Different in suitcase";
# Now set the parent
ok +Ray->DataFile('/tmp/stuff'), "Set data in parent";
is +Ray->DataFile, '/tmp/stuff', " - it sticks";
is +Gun->DataFile, '/tmp/stuff', "filters down to unchanged children";
is +Suitcase->DataFile, '/etc/otherstuff/data', "but not to changed";
my $obj = bless {}, 'Gun';
eval { $obj->mk_classaccessor('Ubu') };
ok $@ =~ /^mk_classaccessor\(\) is a class method, not an object method/,
"Can't create classaccessor for an object";
is $obj->DataFile, "/tmp/stuff", "But objects can access the data";
is $obj->DataFile("/tmp/morestuff"), "/tmp/morestuff",
"And they can set their own copy";
is +Gun->DataFile, "/tmp/stuff", "But it doesn't touch the value on the class";
{
my $warned = 0;
local $SIG{__WARN__} = sub {
if (shift =~ /DESTROY/i) {
$warned++;
};
};
Ray->mk_classaccessor('DESTROY');
ok($warned, 'Warn when creating DESTROY');
# restore non-accessorized DESTROY
no warnings;
*Ray::DESTROY = sub {};
};
eval {
$obj->mk_classaccessor('foo');
};
like($@, qr{not an object method}, 'Die when used as an object method');
|
