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