Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 215 lines (172 sloc) 5.751 kb
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 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214
use v6;

use Test;

plan 32;

# L<S12/"Multisubs and Multimethods">
# L<S12/"Trusts">

class Foo {
    multi method bar() {
        return "Foo.bar() called with no args";
    }

    multi method bar(Str $str) {
        return "Foo.bar() called with Str : $str";
    }

    multi method bar(Int $int) {
        return "Foo.bar() called with Int : $int";
    }
    
    multi method bar(Numeric $num) {
        return "Foo.bar() called with Numeric : $num";
    }
    
    multi method baz($f) {
        return "Foo.baz() called with parm : $f";
    }
}


my $foo = Foo.new();
is($foo.bar(), 'Foo.bar() called with no args', '... multi-method dispatched on no args');

is($foo.bar("Hello"), 'Foo.bar() called with Str : Hello', '... multi-method dispatched on Str');

is($foo.bar(5), 'Foo.bar() called with Int : 5', '... multi-method dispatched on Int');
is($foo.bar(4.2), 'Foo.bar() called with Numeric : 4.2', '... multi-method dispatched on Numeric');

#?rakudo todo 'RT 66006'
try { EVAL '$foo.baz()' };
#?niecza todo 'This test is pretty dubious IMO'
ok ~$! ~~ /:i argument[s?]/, 'Call with wrong number of args should complain about args';

role R1 {
    method foo($x) { 1 } #OK not used
}
role R2 {
    method foo($x, $y) { 2 } #OK not used
}
eval_dies_ok 'class X does R1 does R2 { }', 'sanity: get composition conflict error';
class C does R1 does R2 {
    proto method foo(|) { * }
}
my $obj = C.new;
#?rakudo 2 skip 'proto does not promote to multi'
#?niecza skip 'No candidates for dispatch to C.foo'
is($obj.foo('a'), 1, 'method composed into multi from role called');
#?niecza skip 'No candidates for dispatch to C.foo'
is($obj.foo('a','b'), 2, 'method composed into multi from role called');


class Foo2 {
    multi method a($d) { #OK not used
        "Any-method in Foo";
    }
}
class Bar is Foo2 {
    multi method a(Int $d) { #OK not used
        "Int-method in Bar";
    }
}

is Bar.new.a("not an Int"), 'Any-method in Foo';

# RT #67024
{
    try { EVAL 'class RT67024 { method a(){0}; method a($x){1} }' };
    #?niecza skip 'Exception NYI'
    ok $! ~~ Exception, 'redefinition of non-multi method (RT 67024)';
    #?niecza todo 'depends on previous test'
    ok "$!" ~~ /multi/, 'error message mentions multi-ness';
}

# RT 69192
#?rakudo skip 'unknown bug'
#?niecza skip 'NYI dottyop form .*'
{
    role R5 {
        multi method rt69192() { push @.order, 'empty' }
        multi method rt69192(Str $a) { push @.order, 'Str' } #OK not used
    }
    role R6 {
        multi method rt69192(Numeric $a) { push @.order, 'Numeric' } #OK not used
    }
    class RT69192 { has @.order }

    {
        my RT69192 $bot .= new();
        ($bot does R5) does R6;
        $bot.*rt69192;
        is $bot.order, <empty>, 'multi method called once on empty signature';
    }

    {
        my RT69192 $bot .= new();
        ($bot does R5) does R6;
        $bot.*rt69192('RT #69192');
        is $bot.order, <Str>, 'multi method called once on Str signature';
    }

    {
        my RT69192 $bot .= new();
        ($bot does R5) does R6;
        $bot.*rt69192( 69192 );
        is $bot.order, <Numeric>, 'multi method called once on Numeric signature';
    }
}

#?niecza skip 'ambiguous'
{
    role RoleS {
        multi method d( Str $x ) { 'string' } #OK not used
    }
    role RoleI {
        multi method d( Int $x ) { 'integer' } #OK not used
    }
    class M does RoleS does RoleI {
        multi method d( Any $x ) { 'any' } #OK not used
    }

    my M $m .= new;

    is $m.d( 876 ), 'integer', 'dispatch to one role';
    is $m.d( '7' ), 'string', 'dispatch to other role';
    is $m.d( 1.2 ), 'any', 'dispatch to the class with the roles';

    my @multi_method = $m.^methods.grep({ ~$_ eq 'd' });
    is @multi_method.elems, 1, '.^methods returns one element for a multi';

    my $routine = @multi_method[0];
    ok $routine ~~ Routine, 'multi method from ^methods is a Routine';
    my @candies = $routine.candidates;
    is @candies.elems, 3, 'got three candidates for multi method';

    ok @candies[0] ~~ Method, 'candidate 0 is a method';
    ok @candies[1] ~~ Method, 'candidate 1 is a method';
    ok @candies[2] ~~ Method, 'candidate 2 is a method';
}

{
    class BrokenTie {
        multi method has_tie(Int $x) { 'tie1' }; #OK not used
        multi method has_tie(Int $y) { 'tie2' }; #OK not used
    }

    dies_ok { BrokenTie.has_tie( 42 ) }, 'call to tied method dies';

    class WorkingTie is BrokenTie {
        multi method has_tie(Int $z) { 'tie3' }; #OK not used
        multi method has_tie(Str $s) { 'tie4' }; #OK not used
    }

    is WorkingTie.has_tie( 42 ), 'tie3', 'broken class fixed by subclass (1)';
    is WorkingTie.has_tie( 'x' ), 'tie4', 'broken class fixed by subclass (2)';

    my $error;
    try {
        WorkingTie.new.has_tie([]);
    }
    $error = "$!";
    ok $error ~~ /<< 'has_tie' >>/,
        'error message for failed dispatch contains method name';
    ok $error ~~ /<< 'WorkingTie' >>/,
        'error message for failed dispatch contains invocant type';
}

# RT #68996
{
    class A {
        has $.foo = "bar";
        multi method foo(Str $test) {
            return $test;
        }
    };

    my $a = A.new;
    
    is $a.foo("oh hai"), "oh hai",
        'foo() method works when $.foo attribute is present';

    dies_ok { $a.foo },
        '$.foo attribute has no accessor when foo() method is present';
}

# RT #57788
{
    eval_dies_ok 'class RT57788 { method m() { }; method m() { } }';
}

{
    class B {
        multi method foo() { }
        multi method bar() { }
    }

    lives_ok { B.new.foo() },
        'multis with different names but same signatures are not ambiguous';
}

done;

# vim: ft=perl6
Something went wrong with that request. Please try again.