lib/MooseX/Role/Parameterized.pm

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