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