X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FRole.pm;h=43bcdd9f392b0a964b6e9f57cbe7d162b0427056;hp=678d4e92b84ab5f61a4b67854db27f35de51b81d;hb=3a63a2e7ef8fbac5f61eab04baecbf5d19374b83;hpb=4377514b87240cd2caab82bc09a7ab3f7ba688c3 diff --git a/lib/Mouse/Role.pm b/lib/Mouse/Role.pm index 678d4e9..43bcdd9 100644 --- a/lib/Mouse/Role.pm +++ b/lib/Mouse/Role.pm @@ -1,67 +1,228 @@ -#!/usr/bin/env perl package Mouse::Role; use strict; use warnings; +use base 'Exporter'; -use Sub::Exporter; -use Carp 'confess'; -use Scalar::Util; - -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 { } - }, - blessed => sub { - return \&Scalar::Util::blessed; - }, - confess => sub { - return \&Carp::confess; - }, - ); - - my $exporter = Sub::Exporter::build_exporter({ - exports => \%exports, - groups => { default => [':all'] }, +use Carp 'confess', 'croak'; +use Scalar::Util 'blessed'; + +use Mouse::Meta::Role; +use Mouse::Util; + +our @EXPORT = qw(before after around super override inner augment has extends with requires excludes confess blessed); +our %is_removable = map{ $_ => undef } @EXPORT; +delete $is_removable{confess}; +delete $is_removable{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->(@_); }); +} - sub import { - $CALLER = caller; +# We keep the same errors messages as Moose::Role emits, here. +sub inner { + croak "Moose::Role cannot support 'inner'"; +} - strict->import; - warnings->import; +sub augment { + croak "Moose::Role cannot support 'augment'"; +} - goto $exporter; +sub has { + my $meta = Mouse::Meta::Role->initialize(caller); + + my $name = shift; + my %opts = @_; + + $meta->add_attribute($name => \%opts); +} + +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 $meta_method = sub{ + Mouse::Meta::Role->initialize(ref($_[0]) || $_[0]); + }; + + 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)) + && (Mouse::Util::get_code_info($code))[0] eq __PACKAGE__){ + + delete $stash->{$keyword}; + } } -}; + return; +} 1; +__END__ + +=head1 NAME + +Mouse::Role - define a role in Mouse + +=head1 KEYWORDS + +=head2 meta -> Mouse::Meta::Role + +Returns this role's metaclass instance. + +=head2 before (method|methods) => Code + +Sets up a "before" method modifier. See L or +L. + +=head2 after (method|methods) => Code + +Sets up an "after" method modifier. See L or +L. + +=head2 around (method|methods) => Code + +Sets up an "around" method modifier. See L or +L. + +=over 4 + +=item B + +Sets up the "super" keyword. See L. + +=item B + +Sets up an "override" method modifier. See L. + +=item B + +This is not supported and emits an error. See L. + +=item B + +This is not supported and emits an error. See L. + +=back + +=head2 has (name|names) => parameters + +Sets up an attribute (or if passed an arrayref of names, multiple attributes) to +this role. See L. + +=head2 confess error -> BOOM + +L for your convenience. + +=head2 blessed value -> ClassName | undef + +L for your convenience. + +=head1 MISC + +=head2 import + +Importing Mouse::Role will give you sugar. + +=head2 unimport + +Please unimport Mouse (C) so that if someone calls one of the +keywords (such as L) it will break loudly instead breaking subtly. + +=cut +