lib/MooseX/Role/Parameterized.pm

   1 package MooseX::Role::Parameterized;
   2 use Moose (
   3     extends => { -as => 'moose_extends' },
   4     around  => { -as => 'moose_around' },
   5     qw/confess blessed/,
   6 );
   7 moose_extends 'Moose::Exporter';
   8
   9 use Moose::Role ();
  10
  11 use MooseX::Role::Parameterized::Meta::Role::Parameterizable;
  12
  13 our $CURRENT_METACLASS;
  14
  15 __PACKAGE__->setup_import_methods(
  16     with_caller => ['parameter', 'role', 'method', 'has', 'with', 'extends',
  17                     'requires', 'excludes', 'augment', 'inner', 'before',
  18                     'after', 'around', 'super', 'override'],
  19     as_is => [ 'confess', 'blessed' ],
  20 );
  21
  22 sub parameter {
  23     my $caller = shift;
  24     my $meta   = Class::MOP::Class->initialize($caller);
  25
  26     my $names = shift;
  27     $names = [$names] if !ref($names);
  28
  29     for my $name (@$names) {
  30         $meta->add_parameter($name, @_);
  31     }
  32 }
  33
  34 sub role {
  35     my $caller         = shift;
  36     my $role_generator = shift;
  37     Class::MOP::Class->initialize($caller)->role_generator($role_generator);
  38 }
  39
  40 sub init_meta {
  41     my $self = shift;
  42
  43     return Moose::Role->init_meta(@_,
  44         metaclass => 'MooseX::Role::Parameterized::Meta::Role::Parameterizable',
  45     );
  46 }
  47
  48 # give role a (&) prototype
  49 moose_around _make_wrapper => sub {
  50     my $orig = shift;
  51     my ($self, $caller, $sub, $fq_name) = @_;
  52
  53     if ($fq_name =~ /::role$/) {
  54         return sub (&) { $sub->($caller, @_) };
  55     }
  56
  57     return $orig->(@_);
  58 };
  59
  60 sub has {
  61     my $caller = shift;
  62     my $meta   = $CURRENT_METACLASS || Class::MOP::Class->initialize($caller);
  63
  64     my $names = shift;
  65     $names = [$names] if !ref($names);
  66
  67     for my $name (@$names) {
  68         $meta->add_attribute($name, @_);
  69     }
  70 }
  71
  72 sub method {
  73     my $caller = shift;
  74     my $meta   = $CURRENT_METACLASS || Class::MOP::Class->initialize($caller);
  75
  76     my $name   = shift;
  77     my $body   = shift;
  78
  79     my $method = $meta->method_metaclass->wrap(
  80         package_name => $caller,
  81         name         => $name,
  82         body         => $body,
  83     );
  84
  85     $meta->add_method($name => $method);
  86 }
  87
  88 sub before {
  89     my $caller = shift;
  90     my $meta   = $CURRENT_METACLASS || Class::MOP::Class->initialize($caller);
  91
  92     my $code = pop @_;
  93
  94     for (@_) {
  95         Carp::croak "Roles do not currently support "
  96             . ref($_)
  97             . " references for before method modifiers"
  98             if ref $_;
  99         $meta->add_before_method_modifier($_, $code);
 100     }
 101 }
 102
 103 sub after {
 104     my $caller = shift;
 105     my $meta   = $CURRENT_METACLASS || Class::MOP::Class->initialize($caller);
 106
 107     my $code = pop @_;
 108
 109     for (@_) {
 110         Carp::croak "Roles do not currently support "
 111             . ref($_)
 112             . " references for after method modifiers"
 113             if ref $_;
 114         $meta->add_after_method_modifier($_, $code);
 115     }
 116 }
 117
 118 sub around {
 119     my $caller = shift;
 120     my $meta   = $CURRENT_METACLASS || Class::MOP::Class->initialize($caller);
 121
 122     my $code = pop @_;
 123
 124     for (@_) {
 125         Carp::croak "Roles do not currently support "
 126             . ref($_)
 127             . " references for around method modifiers"
 128             if ref $_;
 129         $meta->add_around_method_modifier($_, $code);
 130     }
 131 }
 132
 133 sub with {
 134     my $caller = shift;
 135     my $meta   = $CURRENT_METACLASS || Class::MOP::Class->initialize($caller);
 136
 137     Moose::Util::apply_all_roles($meta, @_);
 138 }
 139
 140 sub requires {
 141     my $caller = shift;
 142     my $meta   = $CURRENT_METACLASS || Class::MOP::Class->initialize($caller);
 143
 144     Carp::croak "Must specify at least one method" unless @_;
 145     $meta->add_required_methods(@_);
 146 }
 147
 148 sub excludes {
 149     my $caller = shift;
 150     my $meta   = $CURRENT_METACLASS || Class::MOP::Class->initialize($caller);
 151
 152     Carp::croak "Must specify at least one role" unless @_;
 153     $meta->add_excluded_roles(@_);
 154 }
 155
 156 # see Moose.pm for discussion
 157 sub super {
 158     return unless $Moose::SUPER_BODY;
 159     $Moose::SUPER_BODY->(@Moose::SUPER_ARGS);
 160 }
 161
 162 sub override {
 163     my $caller = shift;
 164     my $meta   = $CURRENT_METACLASS || Class::MOP::Class->initialize($caller);
 165
 166     my ($name, $code) = @_;
 167     $meta->add_override_method_modifier($name, $code);
 168 }
 169
 170 sub extends { Carp::croak "Roles do not currently support 'extends'" }
 171
 172 sub inner { Carp::croak "Roles cannot support 'inner'" }
 173
 174 sub augment { Carp::croak "Roles cannot support 'augment'" }
 175
 176 1;
 177
 178 __END__
 179
 180 =head1 NAME
 181
 182 MooseX::Role::Parameterized - parameterized roles
 183
 184 =head1 SYNOPSIS
 185
 186     package MyRole::Counter;
 187     use MooseX::Role::Parameterized;
 188
 189     parameter name => (
 190         is       => 'ro',
 191         isa      => 'Str',
 192         required => 1,
 193     );
 194
 195     role {
 196         my $p = shift;
 197
 198         my $name = $p->name;
 199
 200         has $name => (
 201             is      => 'rw',
 202             isa     => 'Int',
 203             default => 0,
 204         );
 205
 206         method "increment_$name" => sub {
 207             my $self = shift;
 208             $self->$name($self->$name + 1);
 209         };
 210
 211         method "decrement_$name" => sub {
 212             my $self = shift;
 213             $self->$name($self->$name - 1);
 214         };
 215     };
 216
 217     package MyGame::Tile;
 218     use Moose;
 219
 220     with 'MyRole::Counter' => { name => 'stepped_on' };
 221
 222 =head1 L<MooseX::Role::Parameterized::Tutorial>
 223
 224 B<Stop!> If you're new here, please read
 225 L<MooseX::Role::Parameterized::Tutorial>.
 226
 227 =head1 DESCRIPTION
 228
 229 Your parameterized role consists of two things: parameter declarations and a
 230 C<role> block.
 231
 232 Parameters are declared using the L</parameter> keyword which very much
 233 resembles L<Moose/has>. You can use any option that L<Moose/has> accepts.
 234 These parameters will get their values when the consuming class (or role) uses
 235 L<Moose/with>. A parameter object will be constructed with these values, and
 236 passed to the C<role> block.
 237
 238 The C<role> block then uses the usual L<Moose::Role> keywords to build up a
 239 role. You can shift off the parameter object to inspect what the consuming
 240 class provided as parameters. You can use the parameters to make your role
 241 customizable!
 242
 243 There are many paths to parameterized roles (hopefully with a consistent enough
 244 API); I believe this to be the easiest and most flexible implementation.
 245 Coincidentally, Pugs has a very similar design (I'm not yet convinced that that
 246 is a good thing).
 247
 248 =head1 CAVEATS
 249
 250 You must use this syntax to declare methods in the role block:
 251 C<< method NAME => sub { ... }; >>. This is due to a limitation in Perl. In
 252 return though you can use parameters I<in your methods>!
 253
 254 L<Moose::Role/alias> and L<Moose::Role/excludes> are not yet supported. I'm
 255 completely unsure of whether they should be handled by this module. Until we
 256 figure out a plan, both declaring and providing a parameter named C<alias> or
 257 C<excludes> is an error.
 258
 259 =head1 AUTHOR
 260
 261 Shawn M Moore, C<< <sartak@bestpractical.com> >>
 262
 263 =cut
 264