1use strict; 2$^W++; 3use Class::Prototyped qw(:EZACCESS :SUPER); 4use Data::Dumper; 5use Test; 6 7BEGIN { 8 $|++; 9 plan tests => 14; 10} 11 12$Data::Dumper::Sortkeys = 1; 13$Data::Dumper::Sortkeys = 1; 14 15package A; 16sub a { 17 my $self = shift; 18 (ref($self) ? $self->name : $self) . 'A.a' 19} 20 21package main; 22 23my $p1 = Class::Prototyped->new( 24 name => 'p1', 25 m1 => sub { $_[0]->name . ".m1" }, 26); 27 28my $p2 = Class::Prototyped->new( 29 name => 'p2', 30 m2 => sub { $_[0]->name . ".m2" }, 31 m2a => sub { $_[0]->name . ".m2a" }, 32); 33 34my $p3 = Class::Prototyped->new( 35 name => 'p3', 36 'parent*' => $p1, 37 p2 => $p2, 38 s1 => sub {}, 39); 40 41ok( $p1->m1, 'p1.m1' ); 42ok( $p2->m2, 'p2.m2' ); 43ok( $p2->m2a, 'p2.m2a' ); 44ok( $p3->m1, 'p3.m1' ); # inheritance 45 46$p3->reflect->delegate( 47 m1 => 'parent*', 48 m2 => $p2, 49 m2a => 'p2', 50 m3 => [ $p1, 'm1' ], 51 m3a => [ 'parent*', 'm1' ], 52 m4 => [ $p2, 'm2' ], 53 m4a => [ 'p2', 'm2a' ], 54); 55 56ok( $p3->m1, 'p1.m1' ); # delegation 57ok( $p3->m2, 'p2.m2' ); 58ok( $p3->m3, 'p1.m1' ); 59ok( $p3->m3a, 'p1.m1' ); 60ok( $p3->m4, 'p2.m2' ); 61ok( $p3->m4a, 'p2.m2a' ); 62 63# detect exceptions 64eval { $p3->reflect->delegate( m9 => 's1' ) }; 65ok( $@ =~ /delegate to a subroutine/ ); 66 67eval { $p3->reflect->delegate( m1 => 'p1' ) }; 68ok( $@ =~ /conflict with existing/ ); 69 70my $p4 = Class::Prototyped->new( 71 name => 'p4', 72 'parent*' => 'A', 73); 74 75ok( $p4->a, 'p4A.a' ); 76$p4->reflect->delegate( 'b' => [ 'parent*', 'a' ] ); 77ok( $p4->b, 'AA.a' ); 78 79# vim: ft=perl 80