-#!/usr/bin/env perl
package Mouse::Role;
use strict;
use warnings;
+use base 'Exporter';
-use Sub::Exporter;
-use Carp 'confess';
-use Scalar::Util;
+use Carp 'confess', 'croak';
+use Scalar::Util 'blessed';
use Mouse::Meta::Role;
-do {
- my $CALLER;
-
- my %exports = (
- meta => sub {
- my $meta = Mouse::Meta::Role->initialize($CALLER);
- return sub { $meta };
- },
- extends => sub {
- return sub {
- confess "Role does not currently support 'extends'";
- }
- },
- before => sub {
- return sub { }
- },
- after => sub {
- return sub { }
- },
- around => sub {
- return sub { }
- },
- has => sub {
- my $caller = $CALLER;
- return sub {
- my $name = shift;
- my %opts = @_;
-
- $caller->meta->add_attribute($name => \%opts);
- }
- },
- with => sub {
- return sub {
- confess "Role does not currently support 'with'";
- }
- },
- requires => sub {
- return sub { }
- },
- excludes => sub {
- return sub { }
- },
- blessed => sub {
- return \&Scalar::Util::blessed;
- },
- confess => sub {
- return \&Carp::confess;
- },
- );
-
- my $exporter = Sub::Exporter::build_exporter({
- exports => \%exports,
- groups => { default => [':all'] },
+our @EXPORT = qw(before after around super override inner augment has extends with requires excludes confess blessed);
+
+sub before {
+ my $meta = Mouse::Meta::Role->initialize(caller);
+
+ my $code = pop;
+ for (@_) {
+ $meta->add_before_method_modifier($_ => $code);
+ }
+}
+
+sub after {
+ my $meta = Mouse::Meta::Role->initialize(caller);
+
+ my $code = pop;
+ for (@_) {
+ $meta->add_after_method_modifier($_ => $code);
+ }
+}
+
+sub around {
+ my $meta = Mouse::Meta::Role->initialize(caller);
+
+ my $code = pop;
+ for (@_) {
+ $meta->add_around_method_modifier($_ => $code);
+ }
+}
+
+
+sub super {
+ return unless $Mouse::SUPER_BODY;
+ $Mouse::SUPER_BODY->(@Mouse::SUPER_ARGS);
+}
+
+sub override {
+ my $classname = caller;
+ my $meta = Mouse::Meta::Role->initialize($classname);
+
+ my $name = shift;
+ my $code = shift;
+ my $fullname = "${classname}::${name}";
+
+ defined &$fullname
+ && confess "Cannot add an override of method '$fullname' " .
+ "because there is a local version of '$fullname'";
+
+ $meta->add_override_method_modifier($name => sub {
+ local $Mouse::SUPER_PACKAGE = shift;
+ local $Mouse::SUPER_BODY = shift;
+ local @Mouse::SUPER_ARGS = @_;
+
+ $code->(@_);
});
+}
+
+# We keep the same errors messages as Moose::Role emits, here.
+sub inner {
+ croak "Moose::Role cannot support 'inner'";
+}
+
+sub augment {
+ croak "Moose::Role cannot support 'augment'";
+}
+
+sub has {
+ my $meta = Mouse::Meta::Role->initialize(caller);
- sub import {
- $CALLER = caller;
+ my $name = shift;
+ my %opts = @_;
- strict->import;
- warnings->import;
+ $meta->add_attribute($name => \%opts);
+}
- goto $exporter;
+sub extends { confess "Roles do not currently support 'extends'" }
+
+sub with {
+ my $meta = Mouse::Meta::Role->initialize(caller);
+ my $role = shift;
+ my $args = shift || {};
+ confess "Mouse::Role only supports 'with' on individual roles at a time" if @_ || !ref $args;
+
+ Mouse::load_class($role);
+ $role->meta->apply($meta, %$args);
+}
+
+sub requires {
+ my $meta = Mouse::Meta::Role->initialize(caller);
+ Carp::croak "Must specify at least one method" unless @_;
+ $meta->add_required_methods(@_);
+}
+
+sub excludes { confess "Mouse::Role does not currently support 'excludes'" }
+
+sub import {
+ my $class = shift;
+
+ strict->import;
+ warnings->import;
+
+ my $caller = caller;
+
+ # we should never export to main
+ if ($caller eq 'main') {
+ warn qq{$class does not export its sugar to the 'main' package.\n};
+ return;
}
- sub unimport {
- my $caller = caller;
+ my $meta = Mouse::Meta::Role->initialize(caller);
+
+ no strict 'refs';
+ no warnings 'redefine';
+ *{$caller.'::meta'} = sub { $meta };
+
+ Mouse::Role->export_to_level(1, @_);
+}
- no strict 'refs';
- for my $keyword (keys %exports) {
- next if $keyword eq 'meta'; # we don't delete this one
- delete ${ $caller . '::' }{$keyword};
- }
+sub unimport {
+ my $caller = caller;
+
+ no strict 'refs';
+ for my $keyword (@EXPORT) {
+ delete ${ $caller . '::' }{$keyword};
}
-};
+}
1;
=head1 NAME
-Mouse::Role
+Mouse::Role - define a role in Mouse
=head1 KEYWORDS
Sets up an "around" method modifier. See L<Moose/around> or
L<Class::Method::Modifiers/around>.
+=item B<super>
+
+Sets up the "super" keyword. See L<Moose/super>.
+
+=item B<override ($name, &sub)>
+
+Sets up an "override" method modifier. See L<Moose/Role/override>.
+
+=item B<inner>
+
+This is not supported and emits an error. See L<Moose/Role>.
+
+=item B<augment ($name, &sub)>
+
+This is not supported and emits an error. See L<Moose/Role>.
+
=head2 has (name|names) => parameters
Sets up an attribute (or if passed an arrayref of names, multiple attributes) to