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
  94     my $name = shift;
  95     my %opts = @_;
  96
  97     $meta->add_attribute($name => \%opts);
  98 }
  99
 100 sub extends  {
 101     Carp::croak "Roles do not support 'extends'"
 102 }
 103
 104 sub with     {
 105     my $meta = Mouse::Meta::Role->initialize(scalar caller);
 106     Mouse::Util::apply_all_roles($meta->name, @_);
 107 }
 108
 109 sub requires {
 110     my $meta = Mouse::Meta::Role->initialize(scalar caller);
 111     $meta->throw_error("Must specify at least one method") unless @_;
 112     $meta->add_required_methods(@_);
 113 }
 114
 115 sub excludes {
 116     not_supported;
 117 }
 118
 119 sub import {
 120     my $class = shift;
 121
 122     strict->import;
 123     warnings->import;
 124
 125     my $caller = caller;
 126
 127     # we should never export to main
 128     if ($caller eq 'main') {
 129         warn qq{$class does not export its sugar to the 'main' package.\n};
 130         return;
 131     }
 132
 133     Mouse::Meta::Role->initialize($caller)->add_method(meta => sub {
 134         return Mouse::Meta::Role->initialize(ref($_[0]) || $_[0]);
 135     });
 136
 137     Mouse::Role->export_to_level(1, @_);
 138 }
 139
 140 sub unimport {
 141     my $caller = caller;
 142
 143     my $stash = do{
 144         no strict 'refs';
 145         \%{$caller . '::'}
 146     };
 147
 148     for my $keyword (@EXPORT) {
 149         my $code;
 150         if(exists $is_removable{$keyword}
 151             && ($code = $caller->can($keyword))
 152             && (Mouse::Util::get_code_info($code))[0] eq __PACKAGE__){
 153
 154             delete $stash->{$keyword};
 155         }
 156     }
 157     return;
 158 }
 159
 160 1;
 161
 162 __END__
 163
 164 =head1 NAME
 165
 166 Mouse::Role - define a role in Mouse
 167
 168 =head1 KEYWORDS
 169
 170 =head2 meta -> Mouse::Meta::Role
 171
 172 Returns this role's metaclass instance.
 173
 174 =head2 before (method|methods) => Code
 175
 176 Sets up a "before" method modifier. See L<Moose/before> or
 177 L<Class::Method::Modifiers/before>.
 178
 179 =head2 after (method|methods) => Code
 180
 181 Sets up an "after" method modifier. See L<Moose/after> or
 182 L<Class::Method::Modifiers/after>.
 183
 184 =head2 around (method|methods) => Code
 185
 186 Sets up an "around" method modifier. See L<Moose/around> or
 187 L<Class::Method::Modifiers/around>.
 188
 189 =over 4
 190
 191 =item B<super>
 192
 193 Sets up the "super" keyword. See L<Moose/super>.
 194
 195 =item B<override ($name, &sub)>
 196
 197 Sets up an "override" method modifier. See L<Moose/Role/override>.
 198
 199 =item B<inner>
 200
 201 This is not supported and emits an error. See L<Moose/Role>.
 202
 203 =item B<augment ($name, &sub)>
 204
 205 This is not supported and emits an error. See L<Moose/Role>.
 206
 207 =back
 208
 209 =head2 has (name|names) => parameters
 210
 211 Sets up an attribute (or if passed an arrayref of names, multiple attributes) to
 212 this role. See L<Mouse/has>.
 213
 214 =head2 confess error -> BOOM
 215
 216 L<Carp/confess> for your convenience.
 217
 218 =head2 blessed value -> ClassName | undef
 219
 220 L<Scalar::Util/blessed> for your convenience.
 221
 222 =head1 MISC
 223
 224 =head2 import
 225
 226 Importing Mouse::Role will give you sugar.
 227
 228 =head2 unimport
 229
 230 Please unimport Mouse (C<no Mouse::Role>) so that if someone calls one of the
 231 keywords (such as L</has>) it will break loudly instead breaking subtly.
 232
 233 =cut
 234