From: Matt S Trout Date: Thu, 29 Mar 2012 19:33:24 +0000 (+0000) Subject: split Role::Tiny into its own dist X-Git-Tag: v0.009014~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=70b4b43066b9c5727f25b18150134fbf01783371;p=gitmo%2FMoo.git split Role::Tiny into its own dist --- diff --git a/Changes b/Changes index f6e66fb..28f26bd 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,4 @@ + - Split Role::Tiny out into its own dist - Fix a bug where coercions weren't called on lazy default/builder returns - Switch Moo::Utils to using Module::Runtime, and add the 5.8 %INC leakage fix into Role::Tiny's _load_module to provide partial parity diff --git a/Makefile.PL b/Makefile.PL index 7a550c4..b1dc535 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -13,6 +13,7 @@ my %RUN_DEPS = ( 'Class::Method::Modifiers' => 1.07, 'strictures' => 1.001001, 'Module::Runtime' => 0.013, + 'Role::Tiny' => 1.000000, ); # have to do this since old EUMM dev releases miss the eval $VERSION line diff --git a/lib/Role/Tiny.pm b/lib/Role/Tiny.pm deleted file mode 100644 index db9151e..0000000 --- a/lib/Role/Tiny.pm +++ /dev/null @@ -1,392 +0,0 @@ -package Role::Tiny; - -sub _getglob { \*{$_[0]} } -sub _getstash { \%{"$_[0]::"} } - -use strict; -use warnings FATAL => 'all'; - -our %INFO; -our %APPLIED_TO; -our %COMPOSED; - -# Module state workaround totally stolen from Zefram's Module::Runtime. - -BEGIN { - *_WORK_AROUND_BROKEN_MODULE_STATE = "$]" < 5.009 ? sub(){1} : sub(){0}; -} - -sub Role::Tiny::__GUARD__::DESTROY { - delete $INC{$_[0]->[0]} if @{$_[0]}; -} - -sub _load_module { - (my $proto = $_[0]) =~ s/::/\//g; - $proto .= '.pm'; - return 1 if $INC{$proto}; - # can't just ->can('can') because a sub-package Foo::Bar::Baz - # creates a 'Baz::' key in Foo::Bar's symbol table - return 1 if grep !/::$/, keys %{_getstash($_[0])||{}}; - my $guard = _WORK_AROUND_BROKEN_MODULE_STATE - && bless([ $proto ], 'Role::Tiny::__GUARD__'); - require $proto; - pop @$guard if _WORK_AROUND_BROKEN_MODULE_STATE; - return 1; -} - -sub import { - my $target = caller; - my $me = shift; - strictures->import; - return if $INFO{$target}; # already exported into this package - # get symbol table reference - my $stash = do { no strict 'refs'; \%{"${target}::"} }; - # install before/after/around subs - foreach my $type (qw(before after around)) { - *{_getglob "${target}::${type}"} = sub { - require Class::Method::Modifiers; - push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ]; - }; - } - *{_getglob "${target}::requires"} = sub { - push @{$INFO{$target}{requires}||=[]}, @_; - }; - *{_getglob "${target}::with"} = sub { - die "Only one role supported at a time by with" if @_ > 1; - $me->apply_role_to_package($target, $_[0]); - }; - # grab all *non-constant* (stash slot is not a scalarref) subs present - # in the symbol table and store their refaddrs (no need to forcibly - # inflate constant subs into real subs) - also add '' to here (this - # is used later) - @{$INFO{$target}{not_methods}={}}{ - '', map { *$_{CODE}||() } grep !ref($_), values %$stash - } = (); - # a role does itself - $APPLIED_TO{$target} = { $target => undef }; -} - -sub apply_role_to_package { - my ($me, $to, $role) = @_; - - _load_module($role); - - die "This is apply_role_to_package" if ref($to); - die "${role} is not a Role::Tiny" unless my $info = $INFO{$role}; - - $me->_check_requires($to, $role, @{$info->{requires}||[]}); - - $me->_install_methods($to, $role); - - $me->_install_modifiers($to, $info->{modifiers}); - - # only add does() method to classes and only if they don't have one - if (not $INFO{$to} and not $to->can('does')) { - *{_getglob "${to}::does"} = \&does_role; - } - - # copy our role list into the target's - @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = (); -} - -sub apply_roles_to_object { - my ($me, $object, @roles) = @_; - die "No roles supplied!" unless @roles; - my $class = ref($object); - bless($object, $me->create_class_with_roles($class, @roles)); - $object; -} - -sub create_class_with_roles { - my ($me, $superclass, @roles) = @_; - - die "No roles supplied!" unless @roles; - - my $new_name = join( - '__WITH__', $superclass, my $compose_name = join '__AND__', @roles - ); - - return $new_name if $COMPOSED{class}{$new_name}; - - foreach my $role (@roles) { - _load_module($role); - die "${role} is not a Role::Tiny" unless my $info = $INFO{$role}; - } - - if ($] >= 5.010) { - require mro; - } else { - require MRO::Compat; - } - - my @composable = map $me->_composable_package_for($_), reverse @roles; - - *{_getglob("${new_name}::ISA")} = [ @composable, $superclass ]; - - my @info = map +($INFO{$_} ? $INFO{$_} : ()), @roles; - - $me->_check_requires( - $new_name, $compose_name, - do { my %h; @h{map @{$_->{requires}||[]}, @info} = (); keys %h } - ); - - *{_getglob "${new_name}::does"} = \&does_role unless $new_name->can('does'); - - @{$APPLIED_TO{$new_name}||={}}{ - map keys %{$APPLIED_TO{$_}}, @roles - } = (); - - $COMPOSED{class}{$new_name} = 1; - return $new_name; -} - -sub _composable_package_for { - my ($me, $role) = @_; - my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role; - return $composed_name if $COMPOSED{role}{$composed_name}; - $me->_install_methods($composed_name, $role); - my $base_name = $composed_name.'::_BASE'; - *{_getglob("${composed_name}::ISA")} = [ $base_name ]; - my $modifiers = $INFO{$role}{modifiers}||[]; - my @mod_base; - foreach my $modified ( - do { my %h; @h{map $_->[1], @$modifiers} = (); keys %h } - ) { - push @mod_base, "sub ${modified} { shift->next::method(\@_) }"; - } - { - local $@; - eval(my $code = join "\n", "package ${base_name};", @mod_base); - die "Evaling failed: $@\nTrying to eval:\n${code}" if $@; - } - $me->_install_modifiers($composed_name, $modifiers); - $COMPOSED{role}{$composed_name} = 1; - return $composed_name; -} - -sub _check_requires { - my ($me, $to, $name, @requires) = @_; - if (my @requires_fail = grep !$to->can($_), @requires) { - # role -> role, add to requires, role -> class, error out - if (my $to_info = $INFO{$to}) { - push @{$to_info->{requires}||=[]}, @requires_fail; - } else { - die "Can't apply ${name} to ${to} - missing ".join(', ', @requires_fail); - } - } -} - -sub _concrete_methods_of { - my ($me, $role) = @_; - my $info = $INFO{$role}; - $info->{methods} ||= do { - # grab role symbol table - my $stash = do { no strict 'refs'; \%{"${role}::"}}; - my $not_methods = $info->{not_methods}; - +{ - # grab all code entries that aren't in the not_methods list - map { - my $code = *{$stash->{$_}}{CODE}; - # rely on the '' key we added in import for "no code here" - exists $not_methods->{$code||''} ? () : ($_ => $code) - } grep !ref($stash->{$_}), keys %$stash - }; - }; -} - -sub methods_provided_by { - my ($me, $role) = @_; - die "${role} is not a Role::Tiny" unless my $info = $INFO{$role}; - (keys %{$me->_concrete_methods_of($role)}, @{$info->{requires}||[]}); -} - -sub _install_methods { - my ($me, $to, $role) = @_; - - my $info = $INFO{$role}; - - my $methods = $me->_concrete_methods_of($role); - - # grab target symbol table - my $stash = do { no strict 'refs'; \%{"${to}::"}}; - - # determine already extant methods of target - my %has_methods; - @has_methods{grep - +(ref($stash->{$_}) || *{$stash->{$_}}{CODE}), - keys %$stash - } = (); - - foreach my $i (grep !exists $has_methods{$_}, keys %$methods) { - no warnings 'once'; - *{_getglob "${to}::${i}"} = $methods->{$i}; - } -} - -sub _install_modifiers { - my ($me, $to, $modifiers) = @_; - if (my $info = $INFO{$to}) { - push @{$info->{modifiers}}, @{$modifiers||[]}; - } else { - foreach my $modifier (@{$modifiers||[]}) { - $me->_install_single_modifier($to, @$modifier); - } - } -} - -sub _install_single_modifier { - my ($me, @args) = @_; - Class::Method::Modifiers::install_modifier(@args); -} - -sub does_role { - my ($proto, $role) = @_; - return exists $APPLIED_TO{ref($proto)||$proto}{$role}; -} - -1; - -=head1 NAME - -Role::Tiny - Roles. Like a nouvelle cusine portion size slice of Moose. - -=head1 SYNOPSIS - - package Some::Role; - - use Role::Tiny; - - sub foo { ... } - - sub bar { ... } - - 1; - -else where - - package Some::Class; - - use Role::Tiny::With; - - # bar gets imported, but not foo - with 'Some::Role'; - - sub foo { ... } - - 1; - -=head1 DESCRIPTION - -C is a minimalist role composition tool. - -=head1 ROLE COMPOSITION - -Role composition can be thought of as much more clever and meaningful multiple -inheritance. The basics of this implementation of roles is: - -=over 2 - -=item * - -If a method is already defined on a class, that method will not be composed in -from the role. - -=item * - -If a method that the role L to be implemented is not implemented, -role application will fail loudly. - -=back - -Unlike L, where the B class inherited from "wins," role -composition is the other way around, where first wins. In a more complete -system (see L) roles are checked to see if they clash. The goal of this -is to be much simpler, hence disallowing composition of multiple roles at once. - -=head1 METHODS - -=head2 apply_role_to_package - - Role::Tiny->apply_role_to_package('Some::Package', 'Some::Role'); - -Composes role with package. See also L. - -=head2 apply_roles_to_object - - Role::Tiny->apply_roles_to_object($foo, qw(Some::Role1 Some::Role2)); - -Composes roles in order into object directly. Object is reblessed into the -resulting class. - -=head2 create_class_with_roles - - Role::Tiny->create_class_with_roles('Some::Base', qw(Some::Role1 Some::Role2)); - -Creates a new class based on base, with the roles composed into it in order. -New class is returned. - -=head1 SUBROUTINES - -=head2 does_role - - if (Role::Tiny::does_role($foo, 'Some::Role')) { - ... - } - -Returns true if class has been composed with role. - -This subroutine is also installed as ->does on any class a Role::Tiny is -composed into unless that class already has an ->does method, so - - if ($foo->does_role('Some::Role')) { - ... - } - -will work for classes but to test a role, one must use ::does_role directly - -=head1 IMPORTED SUBROUTINES - -=head2 requires - - requires qw(foo bar); - -Declares a list of methods that must be defined to compose role. - -=head2 with - - with 'Some::Role1'; - with 'Some::Role2'; - -Composes another role into the current role. Only one role may be composed in -at a time to allow the code to remain as simple as possible. - -=head2 before - - before foo => sub { ... }; - -See L<< Class::Method::Modifiers/before method(s) => sub { ... } >> for full -documentation. - -=head2 around - - around foo => sub { ... }; - -See L<< Class::Method::Modifiers/around method(s) => sub { ... } >> for full -documentation. - -=head2 after - - after foo => sub { ... }; - -See L<< Class::Method::Modifiers/after method(s) => sub { ... } >> for full -documentation. - -=head1 AUTHORS - -See L for authors. - -=head1 COPYRIGHT AND LICENSE - -See L for the copyright and license. - -=cut diff --git a/lib/Role/Tiny/With.pm b/lib/Role/Tiny/With.pm deleted file mode 100644 index 4b568ea..0000000 --- a/lib/Role/Tiny/With.pm +++ /dev/null @@ -1,46 +0,0 @@ -package Role::Tiny::With; - -use strict; -use warnings FATAL => 'all'; -use Role::Tiny (); - -use Exporter 'import'; -our @EXPORT = qw( with ); - -sub with { - my $target = caller; - Role::Tiny->apply_role_to_package($target, @_) -} - -1; - -=head1 NAME - -Role::Tiny::With - Neat interface for consumers of Role::Tiny roles - -=head1 SYNOPSIS - - package Some::Class; - - use Role::Tiny::With; - - with 'Some::Role'; - - # The role is now mixed in - -=head1 DESCRIPTION - -C is a minimalist role composition tool. C -provides a C function to compose such roles. - -=head1 AUTHORS - -See L for authors. - -=head1 COPYRIGHT AND LICENSE - -See L for the copyright and license. - -=cut - - diff --git a/t/role-tiny-with.t b/t/role-tiny-with.t deleted file mode 100644 index b77a70c..0000000 --- a/t/role-tiny-with.t +++ /dev/null @@ -1,31 +0,0 @@ -use strictures 1; -use Test::More; - -BEGIN { - package MyRole; - - use Role::Tiny; - - sub bar { 'role bar' } - - sub baz { 'role baz' } -} - -BEGIN { - package MyClass; - - use Role::Tiny::With; - - with 'MyRole'; - - sub foo { 'class foo' } - - sub baz { 'class baz' } - -} - -is(MyClass->foo, 'class foo', 'method from class no override'); -is(MyClass->bar, 'role bar', 'method from role'); -is(MyClass->baz, 'class baz', 'method from class'); - -done_testing; diff --git a/t/role-tiny.t b/t/role-tiny.t deleted file mode 100644 index ebd7b8e..0000000 --- a/t/role-tiny.t +++ /dev/null @@ -1,82 +0,0 @@ -use strictures 1; -use Test::More; -use Test::Fatal; - -BEGIN { - package MyRole; - - use Role::Tiny; - - requires qw(req1 req2); - - around foo => sub { my $orig = shift; join ' ', 'role foo', $orig->(@_) }; - - sub bar { 'role bar' } - - sub baz { 'role baz' } -} - -BEGIN { - package MyClass; - - use constant SIMPLE => 'simple'; - use constant REF_CONST => [ 'ref_const' ]; - use constant VSTRING_CONST => v1; - - sub req1 { } - sub req2 { } - sub foo { 'class foo' } - sub baz { 'class baz' } - -} - -BEGIN { - package ExtraClass; - sub req1 { } - sub req2 { } - sub req3 { } - sub foo { } - sub baz { 'class baz' } -} - -BEGIN { - package IntermediaryRole; - use Role::Tiny; - requires 'req3'; -} - -BEGIN { - package NoMethods; - - package OneMethod; - - sub req1 { } -} - -sub try_apply_to { - my $to = shift; - exception { Role::Tiny->apply_role_to_package($to, 'MyRole') } -} - -is(try_apply_to('MyClass'), undef, 'role applies cleanly'); -is(MyClass->foo, 'role foo class foo', 'method modifier'); -is(MyClass->bar, 'role bar', 'method from role'); -is(MyClass->baz, 'class baz', 'method from class'); -ok(MyClass->does('MyRole'), 'class does role'); -ok(!MyClass->does('Random'), 'class does not do non-role'); - -like(try_apply_to('NoMethods'), qr/req1, req2/, 'error for both methods'); -like(try_apply_to('OneMethod'), qr/req2/, 'error for one method'); - -is exception { - Role::Tiny->apply_role_to_package('IntermediaryRole', 'MyRole'); - Role::Tiny->apply_role_to_package('ExtraClass', 'IntermediaryRole'); -}, undef, 'No errors applying roles'; - -ok(ExtraClass->does('MyRole'), 'ExtraClass does MyRole'); -ok(ExtraClass->does('IntermediaryRole'), 'ExtraClass does IntermediaryRole'); -is(ExtraClass->bar, 'role bar', 'method from role'); -is(ExtraClass->baz, 'class baz', 'method from class'); - -done_testing; -