1#!/usr/bin/perl 2 3use strict; 4use warnings; 5 6require q(./test.pl); plan(tests => 10); 7 8use utf8; 9use open qw( :utf8 :std ); 10 11=pod 12 13This tests the classic diamond inheritance pattern. 14 15 <A> 16 / \ 17<B> <C> 18 \ / 19 <D> 20 21=cut 22 23{ 24 package ���i������d_A; 25 use mro 'c3'; 26 sub ���a�� { '���i������d_A::���a��' } 27 sub ����� { '���i������d_A::�����' } 28} 29{ 30 package ���i������d_B; 31 use base '���i������d_A'; 32 use mro 'c3'; 33 sub ����� { '���i������d_B::����� => ' . (shift)->next::method() } 34} 35{ 36 package ���i������d_C; 37 use mro 'c3'; 38 use base '���i������d_A'; 39 sub ��� { '���i������d_C::���' } 40 sub bu�� { '���i������d_C::bu��' } 41 42 sub wo��� { '���i������d_C::wo���' } 43 sub ma���b�� { '���i������d_C::ma���b��' } 44} 45{ 46 package ���i������d_D; 47 use base ('���i������d_B', '���i������d_C'); 48 use mro 'c3'; 49 sub ��� { '���i������d_D::��� => ' . (shift)->next::method() } 50 sub ���a�� { '���i������d_D::���a�� => ' . (shift)->next::method() } 51 sub bu�� { '���i������d_D::bu�� => ' . (shift)->�����() } 52 sub fuz { '���i������d_D::fuz => ' . (shift)->next::method() } 53 54 sub wo��� { '���i������d_D::wo��� can => ' . ((shift)->next::can() ? 1 : 0) } 55 sub noz { '���i������d_D::noz can => ' . ((shift)->next::can() ? 1 : 0) } 56 57 sub ma���b�� { '���i������d_D::ma���b�� => ' . ((shift)->maybe::next::method() || 0) } 58 sub ���y��� { '���i������d_D::���y��� => ' . ((shift)->maybe::next::method() || 0) } 59 60} 61 62ok(eq_array( 63 mro::get_linear_isa('���i������d_D'), 64 [ qw(���i������d_D ���i������d_B ���i������d_C ���i������d_A) ] 65), '... got the right MRO for ���i������d_D'); 66 67is(���i������d_D->���, '���i������d_D::��� => ���i������d_C::���', '... skipped B and went to C correctly'); 68is(���i������d_D->���a��, '���i������d_D::���a�� => ���i������d_A::���a��', '... skipped B & C and went to A correctly'); 69is(���i������d_D->�����, '���i������d_B::����� => ���i������d_A::�����', '... called B method, skipped C and went to A correctly'); 70is(���i������d_D->bu��, '���i������d_D::bu�� => ���i������d_B::����� => ���i������d_A::�����', '... called D method dispatched to , different method correctly'); 71eval { ���i������d_D->fuz }; 72like($@, qr/^No next::method 'fuz' found for ���i������d_D/u, '... cannot re-dispatch to a method which is not there'); 73is(���i������d_D->wo���, '���i������d_D::wo��� can => 1', '... can re-dispatch figured out correctly'); 74is(���i������d_D->noz, '���i������d_D::noz can => 0', '... cannot re-dispatch figured out correctly'); 75 76is(���i������d_D->ma���b��, '���i������d_D::ma���b�� => ���i������d_C::ma���b��', '... redispatched D to C when it exists'); 77is(���i������d_D->���y���, '���i������d_D::���y��� => 0', '... quietly failed redispatch from D'); 78