1use strict;
2use warnings;
3use Test::More tests => 19;
4
5package Ray;
6use base qw(Class::Data::Accessor);
7Ray->mk_classaccessors('Ubu');
8Ray->mk_classaccessor(DataFile => '/etc/stuff/data');
9
10package Gun;
11use base qw(Ray);
12Gun->Ubu('Pere');
13
14package Suitcase;
15use base qw(Gun);
16Suitcase->DataFile('/etc/otherstuff/data');
17
18package main;
19
20foreach my $class (qw/Ray Gun Suitcase/) {
21	can_ok $class =>
22		qw/mk_classaccessor Ubu _Ubu_accessor DataFile _DataFile_accessor/;
23}
24
25# Test that superclasses effect children.
26is +Gun->Ubu, 'Pere', 'Ubu in Gun';
27is +Suitcase->Ubu, 'Pere', "Inherited into children";
28is +Ray->Ubu, undef, "But not set in parent";
29
30# Set value with data
31is +Ray->DataFile, '/etc/stuff/data', "Ray datafile";
32is +Gun->DataFile, '/etc/stuff/data', "Inherited into gun";
33is +Suitcase->DataFile, '/etc/otherstuff/data', "Different in suitcase";
34
35# Now set the parent
36ok +Ray->DataFile('/tmp/stuff'), "Set data in parent";
37is +Ray->DataFile, '/tmp/stuff', " - it sticks";
38is +Gun->DataFile, '/tmp/stuff', "filters down to unchanged children";
39is +Suitcase->DataFile, '/etc/otherstuff/data', "but not to changed";
40
41
42my $obj = bless {}, 'Gun';
43eval { $obj->mk_classaccessor('Ubu') };
44ok $@ =~ /^mk_classaccessor\(\) is a class method, not an object method/,
45"Can't create classaccessor for an object";
46
47is $obj->DataFile, "/tmp/stuff", "But objects can access the data";
48
49is $obj->DataFile("/tmp/morestuff"), "/tmp/morestuff",
50  "And they can set their own copy";
51
52is +Gun->DataFile, "/tmp/stuff", "But it doesn't touch the value on the class";
53
54
55{
56    my $warned = 0;
57
58    local $SIG{__WARN__} = sub {
59        if  (shift =~ /DESTROY/i) {
60            $warned++;
61        };
62    };
63
64    Ray->mk_classaccessor('DESTROY');
65
66    ok($warned, 'Warn when creating DESTROY');
67
68    # restore non-accessorized DESTROY
69    no warnings;
70    *Ray::DESTROY = sub {};
71};
72
73eval {
74    $obj->mk_classaccessor('foo');
75};
76like($@, qr{not an object method}, 'Die when used as an object method');
77
78