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