lib/MooseX/Role/Parameterized.pm

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