local-lib5/lib/perl5/MooseX/MultiMethods.pm

   1 package MooseX::MultiMethods;
   2 our $VERSION = '0.10';
   3 # ABSTRACT: Multi Method Dispatch based on Moose type constraints
   4
   5 use Moose;
   6 use Devel::Declare ();
   7 use MooseX::Method::Signatures;
   8 use Sub::Install qw/install_sub/;
   9 use MooseX::Types::Moose qw/HashRef ClassName/;
  10 use aliased 'Devel::Declare::Context::Simple' => 'DDContext';
  11 use aliased 'MooseX::MultiMethods::Meta::Method' => 'MetaMethod';
  12
  13 use namespace::autoclean;
  14
  15
  16 has _dd_context => (
  17     is      => 'ro',
  18     isa     => DDContext,
  19     lazy    => 1,
  20     builder => '_build_dd_context',
  21     handles => qr/.*/,
  22 );
  23
  24 has _dd_init_args => (
  25     is      => 'rw',
  26     isa     => HashRef,
  27     default => sub { {} },
  28 );
  29
  30 has class => (
  31     is       => 'ro',
  32     isa      => ClassName,
  33     required => 1,
  34 );
  35
  36 method BUILD ($args) {
  37     $self->_dd_init_args($args);
  38 }
  39
  40 method _build_dd_context {
  41     return DDContext->new(%{ $self->_dd_init_args });
  42 }
  43
  44 method import (ClassName $class:) {
  45     my $setup_class = caller;
  46     $class->setup_for($setup_class);
  47 }
  48
  49 method setup_for (ClassName $class: ClassName $setup_class, HashRef $args = {}) {
  50     Devel::Declare->setup_for($setup_class, {
  51         'multi' => {
  52             const => sub {
  53                 my $self = $class->new({ class => $setup_class, %{ $args } });
  54                 $self->init(@_);
  55                 return $self->parse;
  56             },
  57         },
  58     });
  59
  60     install_sub({
  61         code => sub {},
  62         into => $setup_class,
  63         as   => 'multi',
  64     });
  65
  66     MooseX::Method::Signatures->setup_for($setup_class)
  67         unless $setup_class->can('method');
  68 }
  69
  70 method parse {
  71     $self->skip_declarator;
  72     $self->skipspace;
  73
  74     my $thing = $self->strip_name;
  75     confess "expected 'method', got '${thing}'"
  76         unless $thing eq 'method';
  77
  78     $self->skipspace;
  79
  80     my $name = $self->strip_name;
  81     confess "anonymous multi methods not allowed"
  82         unless defined $name && length $name;
  83
  84     my $proto = $self->strip_proto || '';
  85     my $proto_variant = MooseX::Method::Signatures::Meta::Method->wrap(
  86         signature    => "(${proto})",
  87         package_name => $self->get_curstash_name,
  88         name         => $name,
  89     );
  90
  91     $self->inject_if_block($self->scope_injector_call . $proto_variant->injectable_code, 'sub');
  92
  93     my $meta = Class::MOP::class_of($self->class);
  94     my $meta_method = $meta->get_method($name);
  95     unless ($meta_method) {
  96         $meta_method = MetaMethod->new(
  97             name         => $name,
  98             package_name => $self->class,
  99         );
 100         $meta->add_method($name => $meta_method);
 101     }
 102
 103     confess "method '${name}' is already defined"
 104         unless $meta_method->isa(MetaMethod);
 105
 106     $self->shadow(sub {
 107         my $variant = $proto_variant->reify(actual_body => $_[0]);
 108         $meta_method->add_variant($variant->type_constraint => $variant);
 109     });
 110 }
 111
 112 1;
 113
 114 __END__
 115 =pod
 116
 117 =head1 NAME
 118
 119 MooseX::MultiMethods - Multi Method Dispatch based on Moose type constraints
 120
 121 =head1 VERSION
 122
 123 version 0.10
 124
 125 =head1 SYNOPSIS
 126
 127     package Paper;    use Moose;
 128     package Scissors; use Moose;
 129     package Rock;     use Moose;
 130     package Lizard;   use Moose;
 131     package Spock;    use Moose;
 132
 133     package Game;
 134     use Moose;
 135     use MooseX::MultiMethods;
 136
 137     multi method play (Paper    $x, Rock     $y) { 1 }
 138     multi method play (Paper    $x, Spock    $y) { 1 }
 139     multi method play (Scissors $x, Paper    $y) { 1 }
 140     multi method play (Scissors $x, Lizard   $y) { 1 }
 141     multi method play (Rock     $x, Scissors $y) { 1 }
 142     multi method play (Rock     $x, Lizard   $y) { 1 }
 143     multi method play (Lizard   $x, Paper    $y) { 1 }
 144     multi method play (Lizard   $x, Spock    $y) { 1 }
 145     multi method play (Spock    $x, Rock     $y) { 1 }
 146     multi method play (Spock    $x, Scissors $y) { 1 }
 147     multi method play (Any      $x, Any      $y) { 0 }
 148
 149     my $game = Game->new;
 150     $game->play(Paper->new, Rock->new);     # 1, Paper covers Rock
 151     $game->play(Spock->new, Paper->new);    # 0, Paper disproves Spock
 152     $game->play(Spock->new, Scissors->new); # 1, Spock smashes Scissors
 153
 154 =head1 DESCRIPTION
 155
 156 This module provides multi method dispatch based on Moose type constraints. It
 157 does so by providing a C<multi> keyword that extends the C<method> keyword
 158 provided by L<MooseX::Method::Signatures|MooseX::Method::Signatures>.
 159
 160 When invoking a method declared as C<multi> a matching variant is being
 161 searched in all the declared multi variants based on the passed parameters and
 162 the declared type constraints. If a variant has been found, it will be invoked.
 163 If no variant could be found, an exception will be thrown.
 164
 165 =head1 AUTHOR
 166
 167   Florian Ragwitz <rafl@debian.org>
 168
 169 =head1 COPYRIGHT AND LICENSE
 170
 171 This software is copyright (c) 2010 by Florian Ragwitz.
 172
 173 This is free software; you can redistribute it and/or modify it under
 174 the same terms as the Perl 5 programming language system itself.
 175
 176 =cut
 177