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