← Back to branch summary

~ubuntu-branches/ubuntu/maverick/libclass-accessor-grouped-perl/maverick

« back to all changes in this revision

Viewing changes to t/accessors_ro.t

  • Committer: Bazaar Package Importer
  • Author(s): gregor herrmann
  • Date: 2007-07-14 21:51:56 UTC
  • Revision ID: james.westby@ubuntu.com-20070714215156-l0iazyikbi21rpu8
Tags: upstream-0.07000
Import upstream version 0.07000

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/accessors_ro.t
 
1
use Test::More tests => 48;
 
2
use strict;
 
3
use warnings;
 
4
use lib 't/lib';
 
5
use AccessorGroupsRO;
 
6
 
 
7
my $class = AccessorGroupsRO->new;
 
8
 
 
9
{
 
10
    my $warned = 0;
 
11
 
 
12
    local $SIG{__WARN__} = sub {
 
13
        if  (shift =~ /DESTROY/i) {
 
14
            $warned++;
 
15
        };
 
16
    };
 
17
 
 
18
    $class->mk_group_ro_accessors('warnings', 'DESTROY');
 
19
 
 
20
    ok($warned);
 
21
 
 
22
    # restore non-accessorized DESTROY
 
23
    no warnings;
 
24
    *AccessorGroupsRO::DESTROY = sub {};
 
25
};
 
26
 
 
27
foreach (qw/singlefield multiple1 multiple2/) {
 
28
    my $name = $_;
 
29
    my $alias = "_${name}_accessor";
 
30
 
 
31
    can_ok($class, $name, $alias);
 
32
 
 
33
    is($class->$name, undef);
 
34
    is($class->$alias, undef);
 
35
 
 
36
    # get via name
 
37
    $class->{$name} = 'a';
 
38
    is($class->$name, 'a');
 
39
 
 
40
    # alias gets same as name
 
41
    is($class->$alias, 'a');
 
42
 
 
43
    # die on set via name/alias
 
44
    eval {
 
45
        $class->$name('b');
 
46
    };
 
47
    ok($@ =~ /cannot alter/);
 
48
 
 
49
    eval {
 
50
        $class->$alias('b');
 
51
    };
 
52
    ok($@ =~ /cannot alter/);
 
53
 
 
54
    # value should be unchanged
 
55
    is($class->$name, 'a');
 
56
    is($class->$alias, 'a');
 
57
};
 
58
 
 
59
foreach (qw/lr1 lr2/) {
 
60
    my $name = "$_".'name';
 
61
    my $alias = "_${name}_accessor";
 
62
    my $field = "$_".'field';
 
63
 
 
64
    can_ok($class, $name, $alias);
 
65
    ok(!$class->can($field));
 
66
 
 
67
    is($class->$name, undef);
 
68
    is($class->$alias, undef);
 
69
 
 
70
    # get via name
 
71
    $class->{$field} = 'c';
 
72
    is($class->$name, 'c');
 
73
 
 
74
    # alias gets same as name
 
75
    is($class->$alias, 'c');
 
76
 
 
77
    # die on set via name/alias
 
78
    eval {
 
79
        $class->$name('d');
 
80
    };
 
81
    ok($@ =~ /cannot alter/);
 
82
 
 
83
    eval {
 
84
        $class->$alias('d');
 
85
    };
 
86
    ok($@ =~ /cannot alter/);
 
87
 
 
88
    # value should be unchanged
 
89
    is($class->$name, 'c');
 
90
    is($class->$alias, 'c');
 
91
};