lib/Mouse/Role.pm

   1 package Mouse::Role;
   2 use strict;
   3 use warnings;
   4 use base 'Exporter';
   5
   6 use Carp 'confess', 'croak';
   7 use Scalar::Util 'blessed';
   8
   9 use Mouse::Meta::Role;
  10
  11 our @EXPORT = qw(before after around super override inner augment has extends with requires excludes confess blessed);
  12
  13 sub before {
  14     my $meta = Mouse::Meta::Role->initialize(caller);
  15
  16     my $code = pop;
  17     for (@_) {
  18         $meta->add_before_method_modifier($_ => $code);
  19     }
  20 }
  21
  22 sub after {
  23     my $meta = Mouse::Meta::Role->initialize(caller);
  24
  25     my $code = pop;
  26     for (@_) {
  27         $meta->add_after_method_modifier($_ => $code);
  28     }
  29 }
  30
  31 sub around {
  32     my $meta = Mouse::Meta::Role->initialize(caller);
  33
  34     my $code = pop;
  35     for (@_) {
  36         $meta->add_around_method_modifier($_ => $code);
  37     }
  38 }
  39
  40
  41 sub super {
  42     return unless $Mouse::SUPER_BODY;
  43     $Mouse::SUPER_BODY->(@Mouse::SUPER_ARGS);
  44 }
  45
  46 sub override {
  47     my $classname = caller;
  48     my $meta = Mouse::Meta::Role->initialize($classname);
  49
  50     my $name = shift;
  51     my $code = shift;
  52     my $fullname = "${classname}::${name}";
  53
  54     defined &$fullname
  55         && confess "Cannot add an override of method '$fullname' " .
  56                    "because there is a local version of '$fullname'";
  57
  58     $meta->add_override_method_modifier($name => sub {
  59         local $Mouse::SUPER_PACKAGE = shift;
  60         local $Mouse::SUPER_BODY = shift;
  61         local @Mouse::SUPER_ARGS = @_;
  62
  63         $code->(@_);
  64     });
  65 }
  66
  67 # We keep the same errors messages as Moose::Role emits, here.
  68 sub inner {
  69     croak "Moose::Role cannot support 'inner'";
  70 }
  71
  72 sub augment {
  73     croak "Moose::Role cannot support 'augment'";
  74 }
  75
  76 sub has {
  77     my $meta = Mouse::Meta::Role->initialize(caller);
  78
  79     my $name = shift;
  80     my %opts = @_;
  81
  82     $meta->add_attribute($name => \%opts);
  83 }
  84
  85 sub extends  { confess "Roles do not currently support 'extends'" }
  86
  87 sub with     {
  88     my $meta = Mouse::Meta::Role->initialize(caller);
  89     my $role  = shift;
  90     my $args  = shift || {};
  91     confess "Mouse::Role only supports 'with' on individual roles at a time" if @_ || !ref $args;
  92
  93     Mouse::load_class($role);
  94     $role->meta->apply($meta, %$args);
  95 }
  96
  97 sub requires {
  98     my $meta = Mouse::Meta::Role->initialize(caller);
  99     Carp::croak "Must specify at least one method" unless @_;
 100     $meta->add_required_methods(@_);
 101 }
 102
 103 sub excludes { confess "Mouse::Role does not currently support 'excludes'" }
 104
 105 sub import {
 106     my $class = shift;
 107
 108     strict->import;
 109     warnings->import;
 110
 111     my $caller = caller;
 112
 113     # we should never export to main
 114     if ($caller eq 'main') {
 115         warn qq{$class does not export its sugar to the 'main' package.\n};
 116         return;
 117     }
 118
 119     my $meta = Mouse::Meta::Role->initialize(caller);
 120
 121     no strict 'refs';
 122     no warnings 'redefine';
 123     *{$caller.'::meta'} = sub { $meta };
 124
 125     Mouse::Role->export_to_level(1, @_);
 126 }
 127
 128 sub unimport {
 129     my $caller = caller;
 130
 131     no strict 'refs';
 132     for my $keyword (@EXPORT) {
 133         delete ${ $caller . '::' }{$keyword};
 134     }
 135 }
 136
 137 1;
 138
 139 __END__
 140
 141 =head1 NAME
 142
 143 Mouse::Role - define a role in Mouse
 144
 145 =head1 KEYWORDS
 146
 147 =head2 meta -> Mouse::Meta::Role
 148
 149 Returns this role's metaclass instance.
 150
 151 =head2 before (method|methods) => Code
 152
 153 Sets up a "before" method modifier. See L<Moose/before> or
 154 L<Class::Method::Modifiers/before>.
 155
 156 =head2 after (method|methods) => Code
 157
 158 Sets up an "after" method modifier. See L<Moose/after> or
 159 L<Class::Method::Modifiers/after>.
 160
 161 =head2 around (method|methods) => Code
 162
 163 Sets up an "around" method modifier. See L<Moose/around> or
 164 L<Class::Method::Modifiers/around>.
 165
 166 =item B<super>
 167
 168 Sets up the "super" keyword. See L<Moose/super>.
 169
 170 =item B<override ($name, &sub)>
 171
 172 Sets up an "override" method modifier. See L<Moose/Role/override>.
 173
 174 =item B<inner>
 175
 176 This is not supported and emits an error. See L<Moose/Role>.
 177
 178 =item B<augment ($name, &sub)>
 179
 180 This is not supported and emits an error. See L<Moose/Role>.
 181
 182 =head2 has (name|names) => parameters
 183
 184 Sets up an attribute (or if passed an arrayref of names, multiple attributes) to
 185 this role. See L<Mouse/has>.
 186
 187 =head2 confess error -> BOOM
 188
 189 L<Carp/confess> for your convenience.
 190
 191 =head2 blessed value -> ClassName | undef
 192
 193 L<Scalar::Util/blessed> for your convenience.
 194
 195 =head1 MISC
 196
 197 =head2 import
 198
 199 Importing Mouse::Role will give you sugar.
 200
 201 =head2 unimport
 202
 203 Please unimport Mouse (C<no Mouse::Role>) so that if someone calls one of the
 204 keywords (such as L</has>) it will break loudly instead breaking subtly.
 205
 206 =cut
 207