← Back to branch summary

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

« back to all changes in this revision

Viewing changes to t/accessors.t

  • Committer: Bazaar Package Importer
  • Author(s): gregor herrmann, Ansgar Burchardt, Antony Gelberg, gregor herrmann
  • Date: 2011-01-24 18:49:35 UTC
  • mfrom: (1.1.9 upstream)
  • Revision ID: james.westby@ubuntu.com-20110124184935-j6jm3u3vn42tklq0
Tags: 0.10002-1
[ Ansgar Burchardt ]
* Update my email address.

[ Antony Gelberg ]
* New upstream release

[ gregor herrmann ]
* debian/copyright: update formatting and list of packagers.
* debian/control: update build dependencies.

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/accessors.t
1
 
use Test::More tests => 62;
 
1
use Test::More tests => 117;
2
2
use strict;
3
3
use warnings;
4
4
use lib 't/lib';
5
 
use Sub::Identify qw/sub_name sub_fullname/;
 
5
use B qw/svref_2object/;
6
6
 
7
7
# we test the pure-perl versions only, but allow overrides
8
8
# from the accessor_xs test-umbrella
9
9
# Also make sure a rogue envvar will not interfere with
10
10
# things
 
11
my $use_xs;
11
12
BEGIN {
12
13
    $Class::Accessor::Grouped::USE_XS = 0
13
14
        unless defined $Class::Accessor::Grouped::USE_XS;
14
15
    $ENV{CAG_USE_XS} = 1;
 
16
    $use_xs = $Class::Accessor::Grouped::USE_XS;
15
17
};
16
18
 
17
 
use AccessorGroups;
18
 
 
19
 
my $class = AccessorGroups->new;
 
19
use AccessorGroupsSubclass;
20
20
 
21
21
{
 
22
    my $obj = AccessorGroupsSubclass->new;
 
23
    my $class = ref $obj;
 
24
    my $name = 'multiple1';
 
25
    my $alias = "_${name}_accessor";
 
26
 
22
27
    my $warned = 0;
23
 
 
24
28
    local $SIG{__WARN__} = sub {
25
29
        if  (shift =~ /DESTROY/i) {
26
30
            $warned++;
27
31
        };
28
32
    };
29
33
 
 
34
    no warnings qw/once/;
 
35
    local *AccessorGroupsSubclass::DESTROY = sub {};
 
36
 
30
37
    $class->mk_group_accessors('warnings', 'DESTROY');
31
 
 
32
38
    ok($warned);
33
 
 
34
 
    # restore non-accessorized DESTROY
35
 
    no warnings;
36
 
    *AccessorGroups::DESTROY = sub {};
37
 
};
38
 
 
39
 
{
40
 
  my $class_name = ref $class;
41
 
  my $name = 'multiple1';
42
 
  my $alias = "_${name}_accessor";
43
 
  my $accessor = $class->can($name);
44
 
  my $alias_accessor = $class->can($alias);
45
 
  isnt(sub_name($accessor), '__ANON__', 'accessor is named');
46
 
  isnt(sub_name($alias_accessor), '__ANON__', 'alias is named');
47
 
  is(sub_fullname($accessor), join('::',$class_name,$name), 'accessor FQ name');
48
 
  is(sub_fullname($alias_accessor), join('::',$class_name,$alias), 'alias FQ name');
49
 
}
50
 
 
51
 
foreach (qw/singlefield multiple1 multiple2/) {
52
 
    my $name = $_;
53
 
    my $alias = "_${name}_accessor";
54
 
 
55
 
    can_ok($class, $name, $alias);
56
 
 
57
 
    is($class->$name, undef);
58
 
    is($class->$alias, undef);
59
 
 
60
 
    # get/set via name
61
 
    is($class->$name('a'), 'a');
62
 
    is($class->$name, 'a');
63
 
    is($class->{$name}, 'a');
64
 
 
65
 
    # alias gets same as name
66
 
    is($class->$alias, 'a');
67
 
 
68
 
    # get/set via alias
69
 
    is($class->$alias('b'), 'b');
70
 
    is($class->$alias, 'b');
71
 
    is($class->{$name}, 'b');
72
 
 
73
 
    # alias gets same as name
74
 
    is($class->$name, 'b');
75
 
};
76
 
 
77
 
foreach (qw/lr1 lr2/) {
78
 
    my $name = "$_".'name';
79
 
    my $alias = "_${name}_accessor";
80
 
 
81
 
    my $field = { lr1 => 'lr1;field', lr2 => q{lr2'field} }->{$_};
82
 
 
83
 
    can_ok($class, $name, $alias);
84
 
    ok(!$class->can($field));
85
 
 
86
 
    is($class->$name, undef);
87
 
    is($class->$alias, undef);
88
 
 
89
 
    # get/set via name
90
 
    is($class->$name('c'), 'c');
91
 
    is($class->$name, 'c');
92
 
    is($class->{$field}, 'c');
93
 
 
94
 
    # alias gets same as name
95
 
    is($class->$alias, 'c');
96
 
 
97
 
    # get/set via alias
98
 
    is($class->$alias('d'), 'd');
99
 
    is($class->$alias, 'd');
100
 
    is($class->{$field}, 'd');
101
 
 
102
 
    # alias gets same as name
103
 
    is($class->$name, 'd');
 
39
};
 
40
 
 
41
my $obj = AccessorGroupsSubclass->new;
 
42
 
 
43
my $test_accessors = {
 
44
    singlefield => {
 
45
        is_xs => $use_xs,
 
46
        has_extra => 1,
 
47
    },
 
48
    runtime_around => {
 
49
        # even though this accessor is simple it will *not* be XSified
 
50
        # due to the runtime 'around'
 
51
        is_xs => 0,
 
52
        has_extra => 1,
 
53
    },
 
54
    multiple1 => {
 
55
    },
 
56
    multiple2 => {
 
57
    },
 
58
    lr1name => {
 
59
        custom_field => 'lr1;field',
 
60
    },
 
61
    lr2name => {
 
62
        custom_field => "lr2'field",
 
63
    },
 
64
};
 
65
 
 
66
for my $name (sort keys %$test_accessors) {
 
67
    my $alias = "_${name}_accessor";
 
68
    my $field = $test_accessors->{$name}{custom_field} || $name;
 
69
    my $extra = $test_accessors->{$name}{has_extra};
 
70
 
 
71
    can_ok($obj, $name, $alias);
 
72
    ok(!$obj->can($field))
 
73
      if $field ne $name;
 
74
 
 
75
    for my $meth ($name, $alias) {
 
76
        my $cv = svref_2object( $obj->can($meth) );
 
77
        is($cv->GV->NAME, $meth, "$meth accessor is named");
 
78
        is($cv->GV->STASH->NAME, 'AccessorGroups', "$meth class correct");
 
79
    }
 
80
 
 
81
    is($obj->$name, undef);
 
82
    is($obj->$alias, undef);
 
83
 
 
84
    # get/set via name
 
85
    is($obj->$name('a'), 'a');
 
86
    is($obj->$name, 'a');
 
87
    is($obj->{$field}, $extra ? 'a Extra tackled on' : 'a');
 
88
 
 
89
    # alias gets same as name
 
90
    is($obj->$alias, 'a');
 
91
 
 
92
    # get/set via alias
 
93
    is($obj->$alias('b'), 'b');
 
94
    is($obj->$alias, 'b');
 
95
    is($obj->{$field}, $extra ? 'b Extra tackled on' : 'b');
 
96
 
 
97
    # alias gets same as name
 
98
    is($obj->$name, 'b');
 
99
 
 
100
    for my $meth ($name, $alias) {
 
101
        my $cv = svref_2object( $obj->can($meth) );
 
102
        is($cv->GV->NAME, $meth, "$meth accessor is named after operations");
 
103
        is(
 
104
          $cv->GV->STASH->NAME,
 
105
          # XS lazyinstalls install into each caller, not into the original parent
 
106
          $test_accessors->{$name}{is_xs} ? 'AccessorGroupsSubclass' :'AccessorGroups',
 
107
          "$meth class correct after operations",
 
108
        );
 
109
    }
104
110
};
105
111
 
106
112
# important