local-lib5/lib/perl5/MooseX/Role/Parameterized.pm

   1 package MooseX::Role::Parameterized;
   2 use 5.008001;
   3 use Moose::Role ();
   4 use Moose::Exporter;
   5 use Carp 'confess';
   6 use Scalar::Util 'blessed';
   7
   8 use MooseX::Role::Parameterized::Meta::Role::Parameterizable;
   9
  10 our $VERSION = '0.14';
  11 our $CURRENT_METACLASS;
  12
  13 Moose::Exporter->setup_import_methods(
  14     with_caller => ['parameter', 'role', 'method', 'has', 'with', 'extends',
  15                     'requires', 'excludes', 'augment', 'inner', 'before',
  16                     'after', 'around', 'super', 'override'],
  17     as_is => [ 'confess', 'blessed' ],
  18 );
  19
  20 sub current_metaclass { $CURRENT_METACLASS }
  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 && $CURRENT_METACLASS->genitor->name eq $caller;
  27
  28     my $meta   = Class::MOP::class_of($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_of($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 sub has {
  53     my $caller = shift;
  54     my $meta   = $CURRENT_METACLASS || Class::MOP::class_of($caller);
  55
  56     my $names = shift;
  57     $names = [$names] if !ref($names);
  58
  59     for my $name (@$names) {
  60         $meta->add_attribute($name, @_);
  61     }
  62 }
  63
  64 sub method {
  65     my $caller = shift;
  66     my $meta   = $CURRENT_METACLASS || Class::MOP::class_of($caller);
  67
  68     my $name   = shift;
  69     my $body   = shift;
  70
  71     my $method = $meta->method_metaclass->wrap(
  72         package_name => $caller,
  73         name         => $name,
  74         body         => $body,
  75     );
  76
  77     $meta->add_method($name => $method);
  78 }
  79
  80 sub _add_method_modifier {
  81     my $type   = shift;
  82     my $caller = shift;
  83     my $meta   = $CURRENT_METACLASS || Class::MOP::class_of($caller);
  84
  85     my $code = pop @_;
  86
  87     for (@_) {
  88         Carp::croak "Roles do not currently support "
  89             . ref($_)
  90             . " references for $type method modifiers"
  91             if ref $_;
  92
  93         my $add_method = "add_${type}_method_modifier";
  94         $meta->$add_method($_, $code);
  95     }
  96 }
  97
  98 sub before {
  99     _add_method_modifier('before', @_);
 100 }
 101
 102 sub after {
 103     _add_method_modifier('after', @_);
 104 }
 105
 106 sub around {
 107     _add_method_modifier('around', @_);
 108 }
 109
 110 sub with {
 111     my $caller = shift;
 112     my $meta   = $CURRENT_METACLASS || Class::MOP::class_of($caller);
 113
 114     Moose::Util::apply_all_roles($meta, @_);
 115 }
 116
 117 sub requires {
 118     my $caller = shift;
 119     my $meta   = $CURRENT_METACLASS || Class::MOP::class_of($caller);
 120
 121     Carp::croak "Must specify at least one method" unless @_;
 122     $meta->add_required_methods(@_);
 123 }
 124
 125 sub excludes {
 126     my $caller = shift;
 127     my $meta   = $CURRENT_METACLASS || Class::MOP::class_of($caller);
 128
 129     Carp::croak "Must specify at least one role" unless @_;
 130     $meta->add_excluded_roles(@_);
 131 }
 132
 133 # see Moose.pm for discussion
 134 sub super {
 135     return unless $Moose::SUPER_BODY;
 136     $Moose::SUPER_BODY->(@Moose::SUPER_ARGS);
 137 }
 138
 139 sub override {
 140     my $caller = shift;
 141     my $meta   = $CURRENT_METACLASS || Class::MOP::class_of($caller);
 142
 143     my ($name, $code) = @_;
 144     $meta->add_override_method_modifier($name, $code);
 145 }
 146
 147 sub extends { Carp::croak "Roles do not currently support 'extends'" }
 148
 149 sub inner { Carp::croak "Roles cannot support 'inner'" }
 150
 151 sub augment { Carp::croak "Roles cannot support 'augment'" }
 152
 153 1;
 154
 155 __END__
 156
 157 =head1 NAME
 158
 159 MooseX::Role::Parameterized - roles with composition parameters
 160
 161 =head1 SYNOPSIS
 162
 163     package Counter;
 164     use MooseX::Role::Parameterized;
 165
 166     parameter name => (
 167         isa      => 'Str',
 168         required => 1,
 169     );
 170
 171     role {
 172         my $p = shift;
 173
 174         my $name = $p->name;
 175
 176         has $name => (
 177             is      => 'rw',
 178             isa     => 'Int',
 179             default => 0,
 180         );
 181
 182         method "increment_$name" => sub {
 183             my $self = shift;
 184             $self->$name($self->$name + 1);
 185         };
 186
 187         method "reset_$name" => sub {
 188             my $self = shift;
 189             $self->$name(0);
 190         };
 191     };
 192
 193     package MyGame::Weapon;
 194     use Moose;
 195
 196     with Counter => { name => 'enchantment' };
 197
 198     package MyGame::Wand;
 199     use Moose;
 200
 201     with Counter => { name => 'zapped' };
 202
 203 =head1 L<MooseX::Role::Parameterized::Tutorial>
 204
 205 B<Stop!> If you're new here, please read
 206 L<MooseX::Role::Parameterized::Tutorial> for a much gentler introduction.
 207
 208 =head1 DESCRIPTION
 209
 210 Your parameterized role consists of two new things: parameter declarations
 211 and a C<role> block.
 212
 213 Parameters are declared using the L</parameter> keyword which very much
 214 resembles L<Moose/has>. You can use any option that L<Moose/has> accepts. The
 215 default value for the C<is> option is C<ro> as that's a very common case. Use
 216 C<< is => 'bare' >> if you want no accessor. These parameters will get their
 217 values when the consuming class (or role) uses L<Moose/with>. A parameter
 218 object will be constructed with these values, and passed to the C<role> block.
 219
 220 The C<role> block then uses the usual L<Moose::Role> keywords to build up a
 221 role. You can shift off the parameter object to inspect what the consuming
 222 class provided as parameters. You use the parameters to customize your
 223 role however you wish.
 224
 225 There are many possible implementations for parameterized roles (hopefully with
 226 a consistent enough API); I believe this to be the easiest and most flexible
 227 design. Coincidentally, Pugs originally had an eerily similar design.
 228
 229 =head2 Why a parameters object?
 230
 231 I've been asked several times "Why use a parameter I<object> and not just a
 232 parameter I<hashref>? That would eliminate the need to explicitly declare your
 233 parameters."
 234
 235 The benefits of using an object are similar to the benefits of using Moose. You
 236 get an easy way to specify lazy defaults, type constraint, delegation, and so
 237 on. You get to use MooseX modules.
 238
 239 You also get the usual introspective and intercessory abilities that come
 240 standard with the metaobject protocol. Ambitious users should be able to add
 241 traits to the parameters metaclass to further customize behavior. Please let
 242 me know if you're doing anything viciously complicated with this extension. :)
 243
 244 =head1 CAVEATS
 245
 246 You must use this syntax to declare methods in the role block:
 247 C<< method NAME => sub { ... }; >>. This is due to a limitation in Perl. In
 248 return though you can use parameters I<in your methods>!
 249
 250 L<Moose::Role/alias> and L<Moose::Role/excludes> are not yet supported. I'm
 251 completely unsure of whether they should be handled by this module. Until we
 252 figure out a plan, either declaring or providing a parameter named C<alias> or
 253 C<excludes> is an error.
 254
 255 =head1 AUTHOR
 256
 257 Shawn M Moore, C<sartak@gmail.com>
 258
 259 =head1 EXAMPLES
 260
 261 =over 4
 262
 263 =item L<Fey::Role::HasAliasName>
 264
 265 =item L<Fey::Role::MakesAliasObjects>
 266
 267 =item L<Fey::Role::SQL::Cloneable>
 268
 269 =item L<Fey::Role::SetOperation>
 270
 271 =item L<IM::Engine::PluggableConstructor>
 272
 273 =item L<IM::Engine::RequiresPlugins>
 274
 275 =item L<KiokuDB::Role::Scan>
 276
 277 =item L<MooseX::RelatedClassRoles>
 278
 279 =item L<MooseX::Role::Matcher>
 280
 281 =item L<MooseX::Role::XMLRPC::Client>
 282
 283 =item L<MooseX::WithCache>
 284
 285 =item L<Net::Journyx::Object::Loadable>
 286
 287 =item L<NetHack::Item::Role::IncorporatesStats>
 288
 289 =item L<TAEB::Action::Role::Item>
 290
 291 =item L<WWW::Mechanize::TreeBuilder>
 292
 293 =back
 294
 295 =head1 SEE ALSO
 296
 297 L<http://sartak.blogspot.com/2009/05/parameterized-roles.html>
 298
 299 L<http://stevan-little.blogspot.com/2009/07/thoughts-on-parameterized-roles.html>
 300
 301 L<http://sartak.org/talks/yapc-asia-2009/(parameterized)-roles/>
 302
 303 =head1 COPYRIGHT AND LICENSE
 304
 305 Copyright 2007-2009 Infinity Interactive
 306
 307 This program is free software; you can redistribute it and/or modify it
 308 under the same terms as Perl itself.
 309
 310 =cut
 311