← Back to branch summary

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

« back to all changes in this revision

Viewing changes to t/accessors_ro.t

  • Committer: Package Import Robot
  • Author(s): Xavier Guimard
  • Date: 2013-03-19 06:29:32 UTC
  • mto: This revision was merged to the branch mainline in revision 16.
  • Revision ID: package-import@ubuntu.com-20130319062932-xngayhbrbvykfcvh
Tags: upstream-0.10009
Import upstream version 0.10009

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/accessors_ro.t
1
 
use Test::More tests => 48;
 
1
use Test::More tests => 58;
2
2
use Test::Exception;
3
3
use strict;
4
4
use warnings;
 
5
use Config;
5
6
use lib 't/lib';
6
7
 
7
8
# we test the pure-perl versions only, but allow overrides
10
11
# things
11
12
my $use_xs;
12
13
BEGIN {
13
 
    $Class::Accessor::Grouped::USE_XS = 0
14
 
        unless defined $Class::Accessor::Grouped::USE_XS;
15
 
    $ENV{CAG_USE_XS} = 1;
16
 
    $use_xs = $Class::Accessor::Grouped::USE_XS;
 
14
  $Class::Accessor::Grouped::USE_XS = 0
 
15
    unless defined $Class::Accessor::Grouped::USE_XS;
 
16
  $ENV{CAG_USE_XS} = 1;
 
17
  $use_xs = $Class::Accessor::Grouped::USE_XS;
17
18
};
18
19
 
19
20
use AccessorGroupsRO;
21
22
my $obj = AccessorGroupsRO->new;
22
23
 
23
24
{
24
 
    my $warned = 0;
 
25
  my $warned = 0;
25
26
 
26
 
    local $SIG{__WARN__} = sub {
27
 
        if  (shift =~ /DESTROY/i) {
28
 
            $warned++;
29
 
        };
 
27
  local $SIG{__WARN__} = sub {
 
28
    if  (shift =~ /DESTROY/i) {
 
29
      $warned++;
30
30
    };
31
 
 
32
 
    no warnings qw/once/;
33
 
    local *AccessorGroupsRO::DESTROY = sub {};
34
 
 
35
 
    $obj->mk_group_ro_accessors('warnings', 'DESTROY');
36
 
 
37
 
    ok($warned);
 
31
  };
 
32
 
 
33
  no warnings qw/once/;
 
34
  local *AccessorGroupsRO::DESTROY = sub {};
 
35
 
 
36
  $obj->mk_group_ro_accessors('warnings', 'DESTROY');
 
37
 
 
38
  ok($warned);
38
39
};
39
40
 
40
41
my $test_accessors = {
41
 
    singlefield => {
42
 
        is_xs => $use_xs,
43
 
    },
44
 
    multiple1 => {
45
 
    },
46
 
    multiple2 => {
47
 
    },
48
 
    lr1name => {
49
 
        custom_field => 'lr1;field',
50
 
    },
51
 
    lr2name => {
52
 
        custom_field => "lr2'field",
53
 
    },
 
42
  singlefield => {
 
43
    is_xs => $use_xs,
 
44
  },
 
45
  multiple1 => {
 
46
  },
 
47
  multiple2 => {
 
48
  },
 
49
  lr1name => {
 
50
    custom_field => 'lr1;field',
 
51
  },
 
52
  lr2name => {
 
53
    custom_field => "lr2'field",
 
54
  },
 
55
  fieldname_torture => {
 
56
    custom_field => join ('', map { chr($_) } (0..255) ),
 
57
    is_xs => $use_xs,
 
58
  },
54
59
};
55
60
 
56
61
for my $name (sort keys %$test_accessors) {
57
62
 
58
 
    my $alias = "_${name}_accessor";
59
 
    my $field = $test_accessors->{$name}{custom_field} || $name;
60
 
 
61
 
    can_ok($obj, $name, $alias);
62
 
 
63
 
    ok(!$obj->can($field))
64
 
      if $field ne $name;
65
 
 
66
 
    is($obj->$name, undef);
67
 
    is($obj->$alias, undef);
68
 
 
69
 
    # get via name
70
 
    $obj->{$field} = 'a';
71
 
    is($obj->$name, 'a');
72
 
 
73
 
    # alias gets same as name
74
 
    is($obj->$alias, 'a');
75
 
 
76
 
    my $ro_regex = $test_accessors->{$name}{is_xs}
77
 
        ? qr/Usage\:.+$name.*\(self\)/
78
 
        : qr/cannot alter the value of '\Q$field\E'/
79
 
    ;
 
63
  my $alias = "_${name}_accessor";
 
64
  my $field = $test_accessors->{$name}{custom_field} || $name;
 
65
 
 
66
  can_ok($obj, $name, $alias);
 
67
 
 
68
  ok(!$obj->can($field))
 
69
    if $field ne $name;
 
70
 
 
71
  is($obj->$name, undef);
 
72
  is($obj->$alias, undef);
 
73
 
 
74
  # get via name
 
75
  $obj->{$field} = 'a';
 
76
  is($obj->$name, 'a');
 
77
 
 
78
  # alias gets same as name
 
79
  is($obj->$alias, 'a');
 
80
 
 
81
  my $ro_regex = $test_accessors->{$name}{is_xs}
 
82
    ? qr/Usage\:.+$name.*\(self\)/
 
83
    : qr/$name(:?_accessor)?\Q' cannot alter its value (read-only attribute of class AccessorGroupsRO)/
 
84
  ;
 
85
 
 
86
  {
 
87
    local $TODO = "Class::XSAccessor emits broken error messages on 5.10 or -DDEBUGGING 5.8"
 
88
      if (
 
89
        $test_accessors->{$name}{is_xs}
 
90
          and
 
91
        $] < '5.011'
 
92
          and
 
93
        ( $] > '5.009' or $Config{config_args} =~ /DEBUGGING/ )
 
94
      );
80
95
 
81
96
    # die on set via name/alias
82
97
    throws_ok {
83
 
        $obj->$name('b');
 
98
      $obj->$name('b');
84
99
    } $ro_regex;
85
100
 
86
101
    throws_ok {
87
 
        $obj->$alias('b');
 
102
      $obj->$alias('b');
88
103
    } $ro_regex;
 
104
  }
89
105
 
90
 
    # value should be unchanged
91
 
    is($obj->$name, 'a');
92
 
    is($obj->$alias, 'a');
 
106
  # value should be unchanged
 
107
  is($obj->$name, 'a');
 
108
  is($obj->$alias, 'a');
93
109
};
94
110
 
95
111
#important