File: tied.t

package info (click to toggle)
libclass-prototyped-perl 1.11-3
  • links: PTS, VCS
  • area: main
  • in suites: wheezy
  • size: 544 kB
  • sloc: perl: 1,448; makefile: 8
file content (105 lines) | stat: -rwxr-xr-x 3,375 bytes parent folder | download | duplicates (8)
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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
use strict;
$^W++;
use Class::Prototyped qw(:NEW_MAIN);
use Data::Dumper;
use Test;

BEGIN {
	$|++;
	plan tests => 57;
}

$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Sortkeys = 1;

my $p1 = new( a => 2, b => sub {'b'} );

ok( $p1->a, 2 );
ok( $p1->{a}, 2 );

ok( $p1->a(3), 3 );
ok( $p1->{a}, 3 );
ok( $p1->a, 3 );

ok( $p1->{a} = 4, 4 );
ok( $p1->a, 4 );
ok( $p1->{a}, 4 );

ok( $p1->b, 'b' );
ok( !(defined(eval { $p1->{b} })));
ok( $@ =~ /^attempt to access METHOD slot through tied hash object interface/ );

ok( !(defined(eval { $p1->{b} = 'c' })));
ok( $@ =~ /^attempt to access METHOD slot through tied hash object interface/ );

ok( !(defined(eval { $p1->{c} })));
ok( $@ =~ /^attempt to access non-existent slot through tied hash object interface/ );

ok( !(defined(eval { $p1->{c} = 'c' })));
ok( $@ =~ /^attempt to access non-existent slot through tied hash object interface/ );

ok( !(defined(eval { %{$p1} = (a => 2) })));
ok( $@ =~ /^attempt to call CLEAR on the hash interface of a Class::Prototyped object/ );

ok( join('|', keys %{$p1}), 'a');

$p1->reflect->addSlot('parent*' => new( d => 5, e => sub {'e'}));
ok( join('|', keys %{$p1}), 'parent*|a');

ok( $p1->d, 5);
ok( !(defined(eval { $p1->{d} })));
ok( $@ =~ /^attempt to access non-existent slot through tied hash object interface/ );

ok( $p1->reflect->getSlot('parent*')->{d} = 7, 7);
ok( $p1->d, 7);

my $p3 = $p1->clone;
ok( $p1->reflect->tiedInterfacePackage(), 'Class::Prototyped::Tied::Default');
ok( $p3->reflect->tiedInterfacePackage(), 'Class::Prototyped::Tied::Default');
$p3->reflect->tiedInterfacePackage('autovivify');
ok( $p3->reflect->tiedInterfacePackage(), 'Class::Prototyped::Tied::AutoVivify');
ok( $p1->reflect->getSlot('parent*')->{d} = 7, 7);
ok( $p1->d, 7);
ok( !(defined($p3->{d})));
ok( $p3->{d} = 4, 4 );
ok( $p3->d, 4 );
ok( $p3->b, 'b' );
ok( !(defined(eval { $p3->{b} })));
ok( $@ =~ /^attempt to access METHOD slot through tied hash object interface/ );

my $p4 = $p1->clone;
ok( $p4->reflect->tiedInterfacePackage(), 'Class::Prototyped::Tied::Default');
ok( !(defined(eval { $p4->{d} })));
ok( $@ =~ /^attempt to access non-existent slot through tied hash object interface/ );

my $p5 = $p3->clone;
ok( Class::Prototyped->reflect->tiedInterfacePackage(), 'Class::Prototyped::Tied::Default');
ok( $p5->reflect->tiedInterfacePackage(), 'Class::Prototyped::Tied::AutoVivify');
ok( (defined(eval { $p3->{d} })));

@Test::Default_A1::ISA = qw(Class::Prototyped);
@Test::Default_A2::ISA = qw(Test::Default_A1);
my $p6 = Test::Default_A2->new(c => 5);
ok( $p6->c, 5 );
ok( $p6->{c}, 5);
ok( $p6->{c} = 7, 7);
ok( $p6->{c}, 7);
ok( !(defined(eval { $p6->{d} })));
ok( $@ =~ /^attempt to access non-existent slot through tied hash object interface/ );

@Test::Autovivify_A1::ISA = qw(Class::Prototyped);
@Test::Autovivify_A2::ISA = qw(Test::Autovivify_A1);
@Test::Autovivify_A3::ISA = qw(Test::Autovivify_A2);
Test::Autovivify_A1->reflect->tiedInterfacePackage('autovivify');
my $p7 = Test::Autovivify_A3->new(c => 5);
ok( $p7->c, 5 );
ok( $p7->{c}, 5);
ok( $p7->{c} = 7, 7);
ok( $p7->{c}, 7);
ok( $p7->{d} = 4, 4 );
ok( (defined(eval { $p7->{d} })));

@Test::Default_B1::ISA = qw(Test::Default_A2 Test::Autovivify_A3);
my $p8 = Test::Default_B1->new();
ok( !(defined(eval { $p8->{d} })));
ok( $@ =~ /^attempt to access non-existent slot through tied hash object interface/ );