lib/Mouse/Role.pm

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