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/ );
|