lib/MooseX/Role/Parameterized.pm

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