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