X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FRole.pm;h=bc326656c02deb05988b025ab2b61e26278b9583;hp=8eeadc9c481e704859fb38cd82d730c8d896464e;hb=01afd8ffba9b9783e84c6cfc8ba45e11a0f5d8f4;hpb=eb812bdec4270b062ab0f35e2d22696e92324dfe diff --git a/lib/Mouse/Role.pm b/lib/Mouse/Role.pm index 8eeadc9..bc32665 100644 --- a/lib/Mouse/Role.pm +++ b/lib/Mouse/Role.pm @@ -1,60 +1,240 @@ -#!/usr/bin/env perl package Mouse::Role; use strict; use warnings; -use Sub::Exporter; +use Exporter; + use Carp 'confess'; +use Scalar::Util 'blessed'; + +use Mouse::Util qw(load_class get_code_package not_supported); +use Mouse (); + +our @ISA = qw(Exporter); + +our @EXPORT = qw( + extends with + has + before after around + override super + augment inner + + requires excludes + + blessed confess +); + +our %is_removable = map{ $_ => undef } @EXPORT; +delete $is_removable{confess}; +delete $is_removable{blessed}; + +sub before { + my $meta = Mouse::Meta::Role->initialize(scalar caller); + + my $code = pop; + for (@_) { + $meta->add_before_method_modifier($_ => $code); + } +} + +sub after { + my $meta = Mouse::Meta::Role->initialize(scalar caller); + + my $code = pop; + for (@_) { + $meta->add_after_method_modifier($_ => $code); + } +} + +sub around { + my $meta = Mouse::Meta::Role->initialize(scalar 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); -do { - my $CALLER; - - my %exports = ( - 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 { - return sub { } - }, - with => sub { - return sub { } - }, - requires => sub { - return sub { } - }, - excludes => sub { - return sub { } - }, - ); - - my $exporter = Sub::Exporter::build_exporter({ - exports => \%exports, - groups => { default => [':all'] }, + my $name = shift; + my $code = shift; + my $fullname = "${classname}::${name}"; + + defined &$fullname + && $meta->throw_error("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 { + Carp::croak "Roles cannot support 'inner'"; +} + +sub augment { + Carp::croak "Roles cannot support 'augment'"; +} + +sub has { + my $meta = Mouse::Meta::Role->initialize(scalar caller); + my $name = shift; + + $meta->add_attribute($_ => @_) for ref($name) ? @{$name} : $name; +} + +sub extends { + Carp::croak "Roles do not support 'extends'" +} + +sub with { + my $meta = Mouse::Meta::Role->initialize(scalar caller); + Mouse::Util::apply_all_roles($meta->name, @_); +} - sub import { - $CALLER = caller; +sub requires { + my $meta = Mouse::Meta::Role->initialize(scalar caller); + $meta->throw_error("Must specify at least one method") unless @_; + $meta->add_required_methods(@_); +} - strict->import; - warnings->import; +sub excludes { + not_supported; +} - goto $exporter; +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 { + Mouse::Meta::Role->initialize($caller)->add_method(meta => sub { + return Mouse::Meta::Role->initialize(ref($_[0]) || $_[0]); + }); + + Mouse::Role->export_to_level(1, @_); +} + +sub unimport { + my $caller = caller; + + my $stash = do{ + no strict 'refs'; + \%{$caller . '::'} + }; + + for my $keyword (@EXPORT) { + my $code; + if(exists $is_removable{$keyword} + && ($code = $caller->can($keyword)) + && get_code_package($code) eq __PACKAGE__){ + + delete $stash->{$keyword}; + } } -}; + return; +} 1; +__END__ + +=head1 NAME + +Mouse::Role - The Mouse Role + +=head1 SYNOPSIS + + package MyRole; + use Mouse::Role; + +=head1 KEYWORDS + +=head2 C<< meta -> Mouse::Meta::Role >> + +Returns this role's metaclass instance. + +=head2 C<< before (method|methods) -> CodeRef >> + +Sets up a B method modifier. See L or +L. + +=head2 C<< after (method|methods) => CodeRef >> + +Sets up an B method modifier. See L or +L. + +=head2 C<< around (method|methods) => CodeRef >> + +Sets up an B method modifier. See L or +L. + +=head2 C + +Sets up the B keyword. See L. + +=head2 C<< override method => CodeRef >> + +Sets up an B method modifier. See L. + +=head2 C + +This is not supported in roles and emits an error. See L. + +=head2 C<< augment method => CodeRef >> + +This is not supported in roles and emits an error. See L. + +=head2 C<< has (name|names) => parameters >> + +Sets up an attribute (or if passed an arrayref of names, multiple attributes) to +this role. See L. + +=head2 C<< confess(error) -> BOOM >> + +L for your convenience. + +=head2 C<< blessed(value) -> ClassName | undef >> + +L for your convenience. + +=head1 MISC + +=head2 import + +Importing Mouse::Role will give you sugar. + +=head2 unimport + +Please unimport (C<< no Mouse::Role >>) so that if someone calls one of the +keywords (such as L) it will break loudly instead breaking subtly. + +=head1 SEE ALSO + +L + +=cut +