lib/Mouse/Role.pm

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