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