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