local-lib5/lib/perl5/Moose/Meta/Method/VariantTable.pm

   1 #!/usr/bin/perl
   2
   3 package Moose::Meta::Method::VariantTable;
   4 use Moose;
   5
   6 extends qw(Moose::Object Moose::Meta::Method);
   7
   8 use MooseX::Types::VariantTable;
   9
  10 use Carp qw(croak);
  11 use Sub::Name qw(subname);
  12
  13 has _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
  20 has class => (
  21     isa => "Class::MOP::Class",
  22     is  => "ro",
  23 );
  24
  25 has name => (
  26     isa => "Str",
  27     is  => "ro",
  28 );
  29
  30 has 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
  40 has super => (
  41     isa => "Maybe[Class::MOP::Method]",
  42     is  => "ro",
  43     lazy_build => 1,
  44 );
  45
  46 sub _build_super {
  47     my $self = shift;
  48
  49     $self->class->find_next_method_by_name($self->name);
  50 }
  51
  52 has body => (
  53     isa => "CodeRef",
  54     is  => "ro",
  55     lazy => 1,
  56     builder => "initialize_body",
  57 );
  58
  59 sub 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
  67 sub 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