1#!/usr/bin/perl
2
3package Moose::Meta::Method::VariantTable;
4use Moose;
5
6extends qw(Moose::Object Moose::Meta::Method);
7
8use MooseX::Types::VariantTable;
9
10use Carp qw(croak);
11use Sub::Name qw(subname);
12
13has _variant_table => (
14    isa => "MooseX::Types::VariantTable",
15    is  => "ro",
16    default => sub { MooseX::Types::VariantTable->new },
17    handles => qr/^(?: \w+_variant$ | has_ )/x,
18);
19
20has class => (
21    isa => "Class::MOP::Class",
22    is  => "ro",
23);
24
25has name => (
26    isa => "Str",
27    is  => "ro",
28);
29
30has full_name => (
31    isa => "Str",
32    is  => "ro",
33    lazy => 1,
34    default => sub {
35        my $self = shift;
36        join "::", $self->class->name, $self->name;
37    },
38);
39
40has super => (
41    isa => "Maybe[Class::MOP::Method]",
42    is  => "ro",
43    lazy_build => 1,
44);
45
46sub _build_super {
47    my $self = shift;
48
49    $self->class->find_next_method_by_name($self->name);
50}
51
52has body => (
53    isa => "CodeRef",
54    is  => "ro",
55    lazy => 1,
56    builder => "initialize_body",
57);
58
59sub merge {
60    my ( $self, @others ) = @_;
61
62    return ( ref $self )->new(
63        _variant_table => $self->_variant_table->merge(map { $_->_variant_table } @others),
64    );
65}
66
67sub initialize_body {
68    my $self = shift;
69
70    my $variant_table = $self->_variant_table;
71
72    my $super = $self->super;
73    my $super_body = $super && $super->body;
74
75    my $name = $self->name;
76
77    return subname $self->full_name, sub {
78        my ( $self, $value, @args ) = @_;
79
80        if ( my ( $result, $type ) = $variant_table->find_variant($value) ) {
81            my $method = (ref($result)||'') eq 'CODE'
82                ? $result
83                : $self->can($result);
84
85            goto $method;
86        } else {
87            return $self->next::method($value, @args);
88        }
89
90        my $dump = eval { require Devel::PartialDump; 1 }
91            ? \&Devel::PartialDump::dump
92            : sub { return join $", map { overload::StrVal($_) } @_ };
93
94        croak "No variant of method '$name' found for ", $dump->($value, @args);
95    };
96}
97
98
99__PACKAGE__
100
101__END__
102
103