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