Role-Basic-0.16000755000765000024 014755276471 12627 5ustar00ovidstaff000000000000Role-Basic-0.16/Build.PL000444000765000024 151714755276471 14264 0ustar00ovidstaff000000000000use strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'Role::Basic', license => 'perl', dist_author => q{Curtis 'Ovid' Poe }, dist_version_from => 'lib/Role/Basic.pm', build_requires => { 'Test::More' => 0, }, # we could probably handle a somewhat older version, but this is six years # old and shouldn't be too problematic (we hope). This does mean that if # your perl < 5.7.3, it's possible you will have to install this. requires => { 'Storable' => '2.15', }, add_to_cleanup => ['Role-Basic-*'], create_makefile_pl => 'traditional', recursive_test_files => 1, meta_merge => { resources => { repository => 'https://github.com/Ovid/Role-Basic' } }, ); $builder->create_build_script(); Role-Basic-0.16/Changes000444000765000024 630614755276471 14264 0ustar00ovidstaff000000000000Revision history for Role-Basic The token "[!Moose]" documents features which diverge from Moose. 0.16 Feb 19, 2025 - Fix metadata information (abstract) and remove Try::Tiny dependency. 0.15 Feb 18, 2025 - Bump version number to work around possible PAUSE bug: Duplicate entry 'O/OV/OVID/Role-Basic-0.14.tar.gz' for key 'PRIMARY' 1739891425 [Tue Feb 18 15:10:25 2025 UTC] I had not previously uploaded the file. 0.14 Feb 18, 2025 - Applied haarg's fix which corrected for a BBC (blead-breaks Perl) bug. Thanks, haarg! 0.13 Apr 3, 2012 - Add SEE ALSO to the docs to let people know what the main alternatives are. 0.12 Apr 17, 2011 - Fixed a bug where constants could confuse _get_valid_method. Thanks to Marcel Grünauer. 0.11 Feb 11, 2011 - Allow constants in roles. Thanks to Marcel Grünauer. 0.10 Jan 29, 2011 - Bump up version number for "beta" release. No functional changes. 0.0804 Jan 25, 2011 - Finally ran ./Build manifest like a good boy. 0.0803 Jan 24, 2011 - Add MyTests to the Manifest (oops) 0.0802 Jan 23, 2011 - Ensure that all tests which use MyTests have the correct lib. 0.0801 Jan 23, 2011 - Make sure people can run all of the tests, not just the top-level - Bugfix: -rename => { x => y, y => x } now works - Add a "philosophy" document. - Aliasing $old to $new should fulfill requirements for $new, if any 0.08 Jan 22, 2011 - Methods which point to the same reference do not conflict (because they're the same method). - [!Moose] Excluded methods are now required. See [https://rt.cpan.org/Public/Bug/Display.html?id=45591] in Moose. - [!Moose] Added -rename, a combination of -alias and -excludes. - Add -version for roles - Bug fix: make sure that -alias doesn't also -exclude - Bug fix: Can't alias over an existing method - Removed a number of Moose tests which don't apply 0.0701 Jan 9, 2011 - Bug fix: add t/lib to t/composition.t (Marcel Grünauer) 0.07 Jan 8, 2011 - Fix problem where 'allowed' methods in one role weren't carried over into another. Reported by Marcel Grünauer. I really need to grab the Moose tests. - Documented the ALPHA nature of the code. 0.06 Jan 6, 2011 - Allow roles to have getter/setter generators (Marcel Grünauer pointed this out). - Work around 5.6.x bug where ->can('can') was always returning true. Thanks to Ben Morrow for spotting the bug. 0.05 Jan 4, 2011 - Remove Test::Most dependency. All deps are now core. 0.04 Jan 3, 2011 - Ensure that multiple roles flattening in identical methods from same role don't cause conflicts (report by Marcel Grünauer) - List repository in Build.PL so that people people on CPAN can find the github version. 0.03 Jan 1, 2011 - Bugfix: rename '-aliases' to '-alias' for Moose compatability. 0.02 Dec 29, 2010 - Remove Carp::Always. Oops :) 0.01 Dec 28, 2010 - Minimal role support with a Moose-like syntax Role-Basic-0.16/MANIFEST000444000765000024 127714755276471 14124 0ustar00ovidstaff000000000000Build.PL Changes examples/currency.pl lib/Role/Basic.pm lib/Role/Basic/Philosophy.pod Makefile.PL MANIFEST META.yml README t/00-load.t t/basic.t t/bugs.t t/composition.t t/exceptions.t t/internals.t t/lib/My/Does/Basic.pm t/lib/My/Example.pm t/lib/MyTests.pm t/lib/TestMethods.pm t/moose/003_apply_role.t t/moose/004_role_composition_errors.t t/moose/005_role_conflict_detection.t t/moose/011_overriding.t t/moose/012_method_exclusion_in_composition.t t/moose/013_method_aliasing_in_composition.t t/moose/014_more_alias_and_exclude.t t/moose/032_roles_and_method_cloning.t t/moose/033_role_exclusion_and_alias_bug.t t/moose/043_conflict_many_methods.t xt/manifest.t xt/pod-coverage.t xt/pod.t META.json Role-Basic-0.16/META.json000444000765000024 210314755276471 14401 0ustar00ovidstaff000000000000{ "abstract" : "Just roles. Nothing else.", "author" : [ "Curtis 'Ovid' Poe " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4234", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Role-Basic", "prereqs" : { "build" : { "requires" : { "Test::More" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.42" } }, "runtime" : { "requires" : { "Storable" : "2.15" } } }, "provides" : { "Role::Basic" : { "file" : "lib/Role/Basic.pm", "version" : "0.16" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/Ovid/Role-Basic" } }, "version" : "0.16", "x_serialization_backend" : "JSON::PP version 4.16" } Role-Basic-0.16/META.yml000444000765000024 123614755276471 14237 0ustar00ovidstaff000000000000--- abstract: 'Just roles. Nothing else.' author: - "Curtis 'Ovid' Poe " build_requires: Test::More: '0' configure_requires: Module::Build: '0.42' dynamic_config: 1 generated_by: 'Module::Build version 0.4234, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Role-Basic provides: Role::Basic: file: lib/Role/Basic.pm version: '0.16' requires: Storable: '2.15' resources: license: http://dev.perl.org/licenses/ repository: https://github.com/Ovid/Role-Basic version: '0.16' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Role-Basic-0.16/Makefile.PL000444000765000024 75114755276471 14721 0ustar00ovidstaff000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4234 use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'Role::Basic', 'VERSION_FROM' => 'lib/Role/Basic.pm', 'PREREQ_PM' => { 'Storable' => '2.15', 'Test::More' => 0 }, 'INSTALLDIRS' => 'site', 'EXE_FILES' => [], 'PL_FILES' => {}, 'test' => { 'TESTS' => 't/*.t t/lib/*.t t/lib/My/*.t t/lib/My/Does/*.t t/moose/*.t' } ) ; Role-Basic-0.16/README000444000765000024 2541414755276471 13672 0ustar00ovidstaff000000000000Role-Basic INSTALLATION To install this module, run the following commands: perl Build.PL ./Build ./Build test ./Build install If you prefer a Makefile.PL: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Role::Basic NAME Role::Basic - Just roles. Nothing else. VERSION Version 0.01 SYNOPSIS In a role: package Does::Serialize::AsYAML; use Role::Basic; use YAML::Syck; requires 'as_hash'; sub serialize { my $self = shift; return Dump( $self->as_hash ); } 1; In your class: package My::Class; use Role::Basic 'with'; with qw( Does::Serialize::AsYAML ); sub as_hash { ... } # because the role requires it DESCRIPTION Sometimes you want roles. You're not sure about Moose, Mouse, Moo and what *was* that damned Squirrel thing anyway? Then there's Class::Trait, but it has a funky syntax and the maintainer's deprecated it in favor of Moose::Role and you really don't care that it handles overloading, instance application or has a workaround for the SUPER:: bug. You think a meta-object protocol sounds nifty, but you don't understand it. Maybe you're not sure you want the syntactic sugar for object declaration. Maybe you've convinced your colleagues that roles are a good idea but they're leery of dragging in Moose (your author has had this happen more than once and heard of others making the same complaint). Sometimes you just want good old-fashioned roles which let you separate class responsibility from code reuse. Whatever your reasons, this is the module you're looking for. It only provides roles and its major design goals are safety and simplicity. It also aims to be a *subset* of Moose::Role behavior so that when/if you're ready to upgrade, there will be minimal pain. DECLARING A ROLE To declare the current package as a role, simply add the following line to the package: use Role::Basic; You can then use "with" to consume other roles and "requires" to list the methods this role requires. Note that the *only* methods the role will provide are methods declared directly in the role or consumed from other roles. Thus: package My::Role; use Role::Basic; use List::Util 'sum'; # this will not be provided by the role with 'Some::Other::Role'; # any methods from this role will be provided sub some_method {...} # this will be provided by the role CONSUMING ROLES To declare the current package as a class that will use roles, simply add the following line to the package: use Role::Basic 'with'; Just as with Moose, you can have "-aliases" and list "-excludes". EXPORT Both roles and classes will receive the following methods: * "with" "with" accepts a list and may only be called once per role or class. This is because calling it multiple times removes composition safety. Just as with Moose::Role, any class may also have "-aliases" or "-excludes". package My::Class; use Role::Basic 'with'; with 'Does::Serialize::AsYAML' => { -aliases => { serialize => 'as_yaml' } }; And later: print $object->as_yaml; * "DOES" Returns true if the class or role consumes a role of the given name: if ( $class->DOES('Does::Serialize::AsYAML') ) { ... } Further, if you're a role, you can also specify methods you require: * "requires" package Some::Role; use Role::Basic; # roles can consume other roles with 'Another::Role'; requires qw( first_method second_method another_method ); In the example above, if "Another::Role" has methods it requires, they will be added to the requirements of "Some::Role". DESIGN GOALS AND LIMITATIONS There are two overriding design goals for "Role::Basic": simplicity and safety. We make it a bit harder to shoot yourself in the foot and we aim to keep the code as simple as possible. Feature requests are welcomed, but will not be acted upon if they violate either of these two design goals. Thus, if you need something which "Role::Basic" does not support, you're strongly encouraged to consider Moose or Mouse. The following list details the outcomes of this module's goals. * Basic role support This includes composing into your class, composing roles from other roles, roles declaring requirements and conflict resolution. * Moose-like syntax To ease migration difficulties, we use a Moose-like syntax. If you wish to upgrade to Moose later, or you find that others on your project are already familiar with Moose, this should make "Role::Basic" easier to learn. * No handling of SUPER:: bug A well-known bug in OO Perl is that a SUPER:: method is invoked against the class its declared in, not against the class of the invocant. Handling this properly generally involves eval'ing a method directly into the correct package: eval <<"END_METHOD"; package $some_package; sub some_method { ... } END_METHOD Or using a different method resolution order (MRO) such as with Class::C3 or friends. We alert you to this limitation but make no attempt to address it. We consider this a feature because roles should not know or care how they are composed and probably should not know if a superclass exists. This helps to keep this module simple, a primary design goal. * Composition Safety In addition to the normal conflict resolution, only one "with" statement is allowed: package Foo; use Role::Basic; with 'Some::Role'; with 'Another::Role'; # boom! This is because when you have more than one "with" statement, the latter will ignore conflicts with the first. We could work around this, but this would be significantly different from the behavior of Moose. * Override Safety By default, we aim to behave like Moose::Role. This means that if a class consuming a role has a method with the same name the role provides, the class *silently* wins. This has been a somewhat contentious issue in the "Moose" community and the "silent" behaviour has won. However, there are those who prefer that they don't have their methods silently ignored. We provide two optional environment variables to handle this: $ENV{PERL_ROLE_OVERRIDE_WARN} $ENV{PERL_ROLE_OVERRIDE_DIE} If you prefer, you can set one of those to true and a class overridding a role's method will "warn" or "die", as appropriate. As you might expect, you can handle this with normal role behaviour or exclusion or aliasing. package My::Class; use Role::Basic 'with'; with 'My::Role' => { -excludes => 'conflicting_method' }; From your author's email exchanges with the authors of the original traits paper (referenced here with permission), the "class silently wins" behaviour was not intended. About this, Dr. Andrew P. Black wrote the following: Yes, it is really important that a programmer can see clearly when a trait method is being overridden -- just as it is important that it is clear when an inherited method is being overridden. In Smalltalk, where a program is viewed as a graph of objects, the obvious solution to this problem is to provide an adequate tool to show the programmer interesting properties of the program. The original traits browser did this for Smalltalk; the reason that we implemented it is that traits were really NOT a good idea (that is,they were not very usable or maintainable) without it. Since then, the same sort of "virtual protocols" have been built into the browser for other properties, like "overridden methods". Note that those are provided as environment variables and not as syntax in the code itself to help keep the code closer to the Moose syntax. * No instance application "Role::Basic" does not support applying roles to object instances. This may change in the future. * No method modifiers These have been especially problematic. Consider a "before" modifier which multiplies a value by 2 and another before modifier which divides a value by 3. The order in which those modifiers are applied becomes extremely important. and role-consumption is no longer entirely declarative, but becomes partially procedural. This causes enough problems that on Sep 14, 2010 on the Moose mailing list, Stevan Little wrote: I totally agree [with the described application order problems], and if I had to do it over again, I would not have allowed method modifiers in roles. They ruin the unordered-ness of roles and bring about edge cases like this that are not so easily solved. Thus, "Role::Basic" does not and *will not* support method modifiers. If you need them, consider Moose. AUTHOR Curtis 'Ovid' Poe, "" BUGS Please report any bugs or feature requests to "bug-role-basic at rt.cpan.org", or through the web interface at . I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. SUPPORT You can find documentation for this module with the perldoc command. perldoc Role::Basic You can also look for information at: * RT: CPAN's request tracker * AnnoCPAN: Annotated CPAN documentation * CPAN Ratings * Search CPAN ACKNOWLEDGEMENTS LICENSE AND COPYRIGHT Copyright 2010 Curtis 'Ovid' Poe. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. Role-Basic-0.16/examples000755000765000024 014755276471 14445 5ustar00ovidstaff000000000000Role-Basic-0.16/examples/currency.pl000444000765000024 353014755276471 16772 0ustar00ovidstaff000000000000#!/usr/bin/env perl use strict; use warnings; { package Eq; use Role::Basic; requires 'equal_to'; sub not_equal_to { my ( $self, $other ) = @_; not $self->equal_to($other); } package Comparable; use Role::Basic; with 'Eq'; requires 'compare'; sub equal_to { my ( $self, $other ) = @_; $self->compare($other) == 0; } sub greater_than { my ( $self, $other ) = @_; $self->compare($other) == 1; } sub less_than { my ( $self, $other ) = @_; $self->compare($other) == -1; } sub greater_than_or_equal_to { my ( $self, $other ) = @_; $self->greater_than($other) || $self->equal_to($other); } sub less_than_or_equal_to { my ( $self, $other ) = @_; $self->less_than($other) || $self->equal_to($other); } package Printable; use Role::Basic; requires 'to_string'; package US::Currency; use Role::Basic 'with'; with 'Comparable', 'Printable'; # note that writing this constructor would not be needed with Moose and it # would have better validation sub new { my ( $class, $arg_for ) = @_; $arg_for ||= {}; my $amount = $arg_for->{amount} || 0; bless { amount => $amount } => $class; } sub amount { my $self = shift; return $self->{amount} unless @_; $self->{amount} = shift; } sub compare { my ( $self, $other ) = @_; $self->amount <=> $other->amount; } sub to_string { my $self = shift; sprintf '$%0.2f USD' => $self->amount; } } my $first = US::Currency->new({ amount => 3.12 }); my $second = US::Currency->new({ amount => 1 }); print $first->to_string, "\n"; print $second->to_string, "\n"; print $first->greater_than($second) ? 'yes' : 'no'; Role-Basic-0.16/lib000755000765000024 014755276471 13375 5ustar00ovidstaff000000000000Role-Basic-0.16/lib/Role000755000765000024 014755276471 14276 5ustar00ovidstaff000000000000Role-Basic-0.16/lib/Role/Basic.pm000444000765000024 6227414755276471 16045 0ustar00ovidstaff000000000000package Role::Basic; sub _getglob { \*{ $_[0] } } use strict; use warnings FATAL => 'all'; use B qw/svref_2object/; use Storable (); use Carp (); use Data::Dumper (); our $VERSION = '0.16'; # eventually clean these up my ( %IS_ROLE, %REQUIRED_BY, %HAS_ROLES, %ALLOWED_BY, %PROVIDES ); sub import { my $class = shift; my $target = caller; # everybody gets 'with' and 'DOES' *{ _getglob "${target}::with" } = sub { $class->apply_roles_to_package( $target, @_ ); }; # everybody gets 'with' and 'DOES' *{ _getglob "${target}::DOES" } = sub { my ( $proto, $role ) = @_; my $class_or_role = ref $proto || $proto; return 1 if $class_or_role eq $role; return exists $HAS_ROLES{$class_or_role}{$role} ? 1 : 0; }; if ( 1 == @_ && 'with' eq $_[0] ) { # this is a class which is consuming roles return; } elsif ( 2 == @_ && 'allow' eq $_[0] ) { # this is a role which allows methods from a foreign class my $foreign_class = $_[1]; push @{ $ALLOWED_BY{$foreign_class} } => $target; $class->_declare_role($target); } elsif (@_) { my $args = join ', ' => @_; # more explicit than $" Carp::confess( "Multiple or unknown argument(s) in import list: ($args)"); } else { $class->_declare_role($target); } } sub _declare_role { my ($class, $target) = @_; $IS_ROLE{$target} = 1; *{ _getglob "${target}::requires" } = sub { $class->add_to_requirements( $target, @_ ); }; } sub add_to_requirements { my ( $class, $role, @methods ) = @_; $REQUIRED_BY{$role} ||= []; push @{ $REQUIRED_BY{$role} } => @methods; my %seen; @{ $REQUIRED_BY{$role} } = grep { not $seen{$_}++ } @{ $REQUIRED_BY{$role} }; } sub get_required_by { my ( $class, $role ) = @_; return unless my $requirements = $REQUIRED_BY{$role}; return @$requirements; } sub requires_method { my ( $class, $role, $method ) = @_; return unless $IS_ROLE{$role}; my %requires = map { $_ => 1 } $class->get_required_by($role); return $requires{$method}; } sub _roles { my ( $class, $target ) = @_; return unless $HAS_ROLES{$target}; my @roles; my %seen; foreach my $role ( keys %{ $HAS_ROLES{$target} } ) { my $modifiers = $HAS_ROLES{$target}{$role}; my $role_name = $class->_get_role_name($role,$modifiers); unless ( $seen{$role_name} ) { push @roles => $role_name, $class->_roles($role); } } return @roles; } sub apply_roles_to_package { my ( $class, $target, @roles ) = @_; if ( $HAS_ROLES{$target} ) { Carp::confess("with() may not be called more than once for $target"); } my ( %provided_by, %requires ); my %is_applied; # these are roles which a class does not use directly, but are contained in # the roles the class consumes. my %contained_roles; while ( my $role = shift @roles ) { # will need to verify that they're actually a role! my $role_modifiers = shift @roles if ref $roles[0]; $role_modifiers ||= {}; my $role_name = $class->_get_role_name( $role, $role_modifiers ); $is_applied{$role_name} = 1; $class->_load_role( $role, $role_modifiers->{'-version'} ); # XXX this is awful. Don't tell anyone I wrote this my $role_methods = $class->_add_role_methods_to_target( $role, $target, $role_modifiers ); # DOES() in some cases if ( my $roles = $HAS_ROLES{$role} ) { foreach my $role ( keys %$roles ) { $HAS_ROLES{$target}{$role} = $roles->{$role}; } } foreach my $method ( $class->get_required_by($role) ) { push @{ $requires{$method} } => $role; } # roles consuming roles should have the same requirements. if ( $IS_ROLE{$target} ) { $class->add_to_requirements( $target, $class->get_required_by($role) ); } while ( my ( $method, $data ) = each %$role_methods ) { $PROVIDES{$role_name}{$method} ||= $data; } # any extra roles contained in applied roles must be added # (helps with conflict resolution) $contained_roles{$role_name} = 1; foreach my $contained_role ( $class->_roles($role) ) { next if $is_applied{$contained_role}; $contained_roles{$contained_role} = 1; $is_applied{$contained_role} = 1; } } foreach my $contained_role (keys %contained_roles) { my ( $role, $modifiers ) = split /-/ => $contained_role, 2; foreach my $method ( $class->get_required_by($role) ) { push @{ $requires{$method} } => $role; } # a role is not a name. A role is a role plus its alias/exclusion. We # now store those in $HAS_ROLE so pull from them if ( my $methods = $PROVIDES{$contained_role} ) { foreach my $method (keys %$methods) { push @{ $provided_by{$method} } => $methods->{$method}; } } } $class->_check_conflicts( $target, \%provided_by ); $class->_check_requirements( $target, \%requires ); } sub _uniq (@) { my %seen = (); grep { not $seen{$_}++ } @_; } sub _check_conflicts { my ( $class, $target, $provided_by ) = @_; my @errors; foreach my $method (keys %$provided_by) { my $sources = $provided_by->{$method}; next if 1 == @$sources; my %seen; # what we're doing here is checking to see if code references point to # the same reference. If they do, they can't possibly be in conflict # because they're the same method. This seems strange, but it does # follow the original spec. my @sources = do { no warnings 'uninitialized'; map { $_->{source} } grep { !$seen{ $_->{code} }++ } @$sources; }; # more than one role provides the method and it's not overridden by # the consuming class having that method if ( @sources > 1 && $target ne _sub_package( $target->can($method) ) ) { my $sources = join "' and '" => sort @sources; push @errors => "Due to a method name conflict in roles '$sources', the method '$method' must be implemented or excluded by '$target'"; } } if ( my $errors = join "\n" => @errors ) { Carp::confess($errors); } } sub _check_requirements { my ( $class, $target, $requires ) = @_; # we return if the target is a role because requirements can be deferred # until final composition return if $IS_ROLE{$target}; my @errors; foreach my $method ( keys %$requires ) { unless ( $target->can($method) ) { my $roles = join '|' => _uniq sort @{ $requires->{$method} }; push @errors => "'$roles' requires the method '$method' to be implemented by '$target'"; } } if (@errors) { Carp::confess( join "\n" => @errors ); } } sub _get_role_name { my ( $class, $role, $modifiers ) = @_; local $Data::Dumper::Indent = 0; local $Data::Dumper::Terse = 1; local $Data::Dumper::Sortkeys = 1; return "$role-" . Data::Dumper::Dumper($modifiers); } sub _add_role_methods_to_target { my ( $class, $role, $target, $role_modifiers) = @_; my $copied_modifiers = Storable::dclone($role_modifiers); my $role_name = $class->_get_role_name( $role, $copied_modifiers ); my $target_methods = $class->_get_methods($target); my $is_loaded = $PROVIDES{$role_name}; my $code_for = $is_loaded || $class->_get_methods($role); my %original_code_for = %$code_for; delete $role_modifiers->{'-version'}; my ( $is_excluded, $aliases ) = $class->_get_excludes_and_aliases( $target, $role, $role_modifiers ); my $stash = do { no strict 'refs'; \%{"${target}::"} }; while ( my ( $old_method, $new_method ) = each %$aliases ) { if ( !$is_loaded ) { if ( exists $code_for->{$new_method} && !$is_excluded->{$new_method} ) { Carp::confess( "Cannot alias '$old_method' to existing method '$new_method' in $role" ); } else { $code_for->{$new_method} = $original_code_for{$old_method}; } } # We do this because $target->can($new_method) wouldn't be appropriate # since it's OK for a role method to -alias over an inherited one. You # can -alias directly on top of an existing method, though. if ( exists $stash->{$new_method} ) { Carp::confess("Cannot alias '$old_method' to '$new_method' as a method of that name already exists in $target"); } } my %was_aliased = reverse %$aliases; foreach my $method ( keys %$code_for ) { if ( $is_excluded->{$method} ) { unless ($was_aliased{$method}) { delete $code_for->{$method}; $class->add_to_requirements( $target, $method ); next; } } if ( exists $target_methods->{$method} ) { if ( $ENV{PERL_ROLE_OVERRIDE_DIE} ) { Carp::confess( "Role '$role' not overriding method '$method' in '$target'" ); } if ( $ENV{PERL_ROLE_OVERRIDE_WARN} ) { Carp::carp( "Role '$role' not overriding method '$method' in '$target'" ); } next; } # XXX we're going to handle this ourselves no strict 'refs'; no warnings 'redefine'; *{"${target}::$method"} = $code_for->{$method}{code}; } $HAS_ROLES{$target}{$role} = $copied_modifiers; return $code_for; } sub _get_excludes_and_aliases { my ( $class, $target, $role, $role_modifiers ) = @_; # figure out which methods to exclude my $excludes = delete $role_modifiers->{'-excludes'} || []; my $aliases = delete $role_modifiers->{'-alias'} || {}; my $renames = delete $role_modifiers->{'-rename'} || {}; $excludes = [$excludes] unless ref $excludes; my %is_excluded = map { $_ => 1 } @$excludes; while ( my ( $old_method, $new_method ) = each %$renames ) { $is_excluded{$old_method} = 1; $aliases->{$old_method} = $new_method; } unless ( 'ARRAY' eq ref $excludes ) { Carp::confess( "Argument to '-excludes' in package $target must be a scalar or array reference" ); } # rename methods to alias unless ( 'HASH' eq ref $aliases ) { Carp::confess( "Argument to '-alias' in package $target must be a hash reference" ); } if ( my $unknown = join ', ' => keys %$role_modifiers ) { Carp::confess("Unknown arguments in 'with()' statement for $role"); } return ( \%is_excluded, $aliases ); } # We can cache this at some point, but for now, the return value is munged sub _get_methods { my ( $class, $target ) = @_; my $stash = do { no strict 'refs'; \%{"${target}::"} }; my %methods; foreach my $name ( keys %$stash ) { my $item = $stash->{$name}; next unless my $code = _get_valid_method( $target, $item ); # this prevents a "modification of read-only value" error. my $source = _sub_package($code); $methods{$name} = { code => $code, source => $source, }; } return \%methods; } sub _get_valid_method { my ( $target, $item ) = @_; my $code = ref $item eq 'CODE' ? $item : ref \$item eq 'GLOB' ? *$item{CODE} : undef; return if !defined $code; my $source = _sub_package($code) or return; # XXX There's a potential bug where some idiot could use Role::Basic to # create exportable functions and those get exported into a role. That's # far-fetched enough that I'm not worried about it. my $is_valid = # declared in package, not imported $target eq $source || # unless we're a role and they're composed from another role $IS_ROLE{$target} && $IS_ROLE{$source}; unless ($is_valid) { foreach my $role (@{ $ALLOWED_BY{$source} }) { return $code if $target->DOES($role); } } return $is_valid ? $code : (); } sub _sub_package { my ($code) = @_; my $source_package; eval { my $stash = svref_2object($code)->STASH; if ( $stash && $stash->can('NAME') ) { $source_package = $stash->NAME; } else { $source_package = ''; } }; if ( my $error = $@ ) { warn "Could not determine calling source_package: $error"; } return $source_package || ''; } sub _load_role { my ( $class, $role, $version ) = @_; $version ||= ''; my $stash = do { no strict 'refs'; \%{"${role}::"} }; if ( exists $stash->{requires} ) { my $package = $role; $package =~ s{::}{/}g; $package .= ".pm"; if ( not exists $INC{$package} ) { # embedded role, not a separate package $INC{"$package"} = "added to inc by $class"; } } eval "use $role $version"; Carp::confess($@) if $@; return 1 if $IS_ROLE{$role}; my $requires = $role->can('requires'); if ( !$requires || $class ne _sub_package($requires) ) { Carp::confess( "Only roles defined with $class may be loaded with _load_role. '$role' is not allowed."); } $IS_ROLE{$role} = 1; return 1; } 1; __END__ =head1 NAME Role::Basic - Just roles. Nothing else. =head1 VERSION Version 0.13 =head1 SYNOPSIS In a role: package Does::Serialize::AsYAML; use Role::Basic; use YAML::Syck; requires 'as_hash'; sub serialize { my $self = shift; return Dump( $self->as_hash ); } 1; In your class: package My::Class; use Role::Basic 'with'; with qw( Does::Serialize::AsYAML ); sub as_hash { ... } # because the role requires it =head1 BETA CODE This code appears to be stable and currently passes over 300 tests. We've not (yet) heard of any bugs. There are no functional changes with this release. It's merely here to let early-adopters know it's safe to give it a spin. =head1 DESCRIPTION For an extended discussion, see L. Sometimes you want roles. You're not sure about L, L, L and what I that damned L thing anyway? Then there's L, but it has a funky syntax and the maintainer's deprecated it in favor of L and you really don't care that it handles overloading, instance application or has a workaround for the SUPER:: bug. You think a meta-object protocol sounds nifty, but you don't understand it. Maybe you're not sure you want the syntactic sugar for object declaration. Maybe you've convinced your colleagues that roles are a good idea but they're leery of dragging in Moose (your author has had this happen more than once and heard of others making the same complaint). Sometimes you just want good old-fashioned roles which let you separate class responsibility from code reuse. Whatever your reasons, this is the module you're looking for. It only provides roles and its major design goals are safety and simplicity. It also aims to be a I of L behavior so that when/if you're ready to upgrade, there will be minimal pain. =head1 DECLARING A ROLE To declare the current package as a role, simply add the following line to the package: use Role::Basic; You can then use C to consume other roles and C to list the methods this role requires. Note that the I methods the role will provide are methods declared directly in the role or consumed from other roles. Thus: package My::Role; use Role::Basic; use List::Util 'sum'; # this will not be provided by the role with 'Some::Other::Role'; # any methods from this role will be provided sub some_method {...} # this will be provided by the role =head2 Allowed methods in roles B: this functionality is experimental and is subject to change with no warning. As mentioned, methods imported into a role are not provided by that role. However, this can make it very hard when you want to provide simple getters/setters. To get around this limitation, a role (and only roles, not classes) may specify one class which they 'allow' to provide additional methods: package My::Role; use Role::Basic allow => 'Class::BuildMethods'; use Class::BuildMethods qw/foo bar/; # your role will now provide foo and bar methods # rest of role definition here Please note that if you do this, the code which provides these 'extra' methods should not provide them in a way which is incompatible with your objects. For example, many getter/setters generation classes assume you're using a blessed hashref. Most objects are, but the role should not make such an assumption about the class which consumes it. In the above example, we use L. It's agnostic about your object implementation, but it's slow. See L and search for 'glue' to understand why this is important. =head1 CONSUMING ROLES To declare the current package as a class that will use roles, simply add the following line to the package: use Role::Basic 'with'; Just as with L, you can have C<-alias>, C<-excludes>, and C<-version>. Unlike Moose, we also provide a C<-rename> target. It combines C<-alias> and C<-excludes>. This code: package My::Class; use Role::Basic 'with'; with 'My::Role' => { -rename => { foo => 'baz', bar => 'gorch' }, }; Is identical to this code: package My::Class; use Role::Basic 'with'; with 'My::Role' => { -alias => { foo => 'baz', bar => 'gorch' }, -excludes => [qw/foo bar/], }; =head1 EXPORT Both roles and classes will receive the following methods: =over 4 =item * C C accepts a list and may only be called B per role or class. This is because calling it multiple times removes composition safety. Just as with L, any class may also have C<-alias> or C<-excludes>. package My::Class; use Role::Basic 'with'; with 'Does::Serialize::AsYAML' => { -alias => { serialize => 'as_yaml' } }; And later: print $object->as_yaml; =item * C Returns true if the class or role consumes a role of the given name: if ( $class->DOES('Does::Serialize::AsYAML') ) { ... } Every role "DOES" itself. =back Further, if you're a role, you can also specify methods you require: =over 4 =item * C package Some::Role; use Role::Basic; # roles can consume other roles with 'Another::Role'; requires qw( first_method second_method another_method ); In the example above, if C has methods it requires, they will be added to the requirements of C. =back =head1 DESIGN GOALS AND LIMITATIONS There are two overriding design goals for C: B and B. We make it a bit harder to shoot yourself in the foot and we aim to keep the code as simple as possible. Feature requests are welcomed, but will not be acted upon if they violate either of these two design goals. Thus, if you need something which C does not support, you're strongly encouraged to consider L or L. The following list details the outcomes of this module's goals. =over 4 =item * Basic role support This includes composing into your class, composing roles from other roles, roles declaring requirements and conflict resolution. =item * Moose-like syntax To ease migration difficulties, we use a Moose-like syntax. If you wish to upgrade to Moose later, or you find that others on your project are already familiar with Moose, this should make C easier to learn. =item * No handling of SUPER:: bug A well-known bug in OO Perl is that a SUPER:: method is invoked against the class its declared in, not against the class of the invocant. Handling this properly generally involves eval'ing a method directly into the correct package: eval <<"END_METHOD"; package $some_package; sub some_method { ... } END_METHOD Or using a different method resolution order (MRO) such as with L or friends. We alert you to this limitation but make no attempt to address it. We consider this a feature because roles should not know or care how they are composed and probably should not know if a superclass exists. This helps to keep this module simple, a primary design goal. =item * Composition Safety In addition to the normal conflict resolution, only one C statement is allowed: package Foo; use Role::Basic; with 'Some::Role'; with 'Another::Role'; # boom! This is because when you have more than one C statement, the latter will ignore conflicts with the first. We could work around this, but this would be significantly different from the behavior of L. =item * Override Safety By default, we aim to behave like L. This means that if a class consuming a role has a method with the same name the role provides, the class I wins. This has been a somewhat contentious issue in the C community and the "silent" behaviour has won. However, there are those who prefer that they don't have their methods silently ignored. We provide two optional environment variables to handle this: $ENV{PERL_ROLE_OVERRIDE_WARN} $ENV{PERL_ROLE_OVERRIDE_DIE} If you prefer, you can set one of those to true and a class overridding a role's method will C or C, as appropriate. As you might expect, you can handle this with normal role behaviour or exclusion or aliasing. package My::Class; use Role::Basic 'with'; with 'My::Role' => { -excludes => 'conflicting_method' }; From your author's email exchanges with the authors of the original traits paper (referenced here with permission), the "class silently wins" behaviour was not intended. About this, Dr. Andrew P. Black wrote the following: Yes, it is really important that a programmer can see clearly when a trait method is being overridden -- just as it is important that it is clear when an inherited method is being overridden. In Smalltalk, where a program is viewed as a graph of objects, the obvious solution to this problem is to provide an adequate tool to show the programmer interesting properties of the program. The original traits browser did this for Smalltalk; the reason that we implemented it is that traits were really NOT a good idea (that is,they were not very usable or maintainable) without it. Since then, the same sort of "virtual protocols" have been built into the browser for other properties, like "overridden methods". Note that those are provided as environment variables and not as syntax in the code itself to help keep the code closer to the L syntax. =item * No instance application C does not support applying roles to object instances. This may change in the future. =item * No method modifiers These have been especially problematic. Consider a "before" modifier which multiplies a value by 2 and another before modifier which divides a value by 3. The order in which those modifiers are applied becomes extremely important. and role-consumption is no longer entirely declarative, but becomes partially procedural. This causes enough problems that on Sep 14, 2010 on the Moose mailing list, Stevan Little wrote: I totally agree [with the described application order problems], and if I had to do it over again, I would not have allowed method modifiers in roles. They ruin the unordered-ness of roles and bring about edge cases like this that are not so easily solved. Thus, C does not and I support method modifiers. If you need them, consider L. =back =head1 AUTHOR Curtis 'Ovid' Poe, C<< >> =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Role::Basic You can also look for information at: =over 4 =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 SEE ALSO =over 4 =item * L =item * L =item * L =back =head1 LICENSE AND COPYRIGHT Copyright 2010 Curtis 'Ovid' Poe. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; # End of Role::Basic Role-Basic-0.16/lib/Role/Basic000755000765000024 014755276471 15317 5ustar00ovidstaff000000000000Role-Basic-0.16/lib/Role/Basic/Philosophy.pod000444000765000024 2063114755276471 20340 0ustar00ovidstaff000000000000=head1 NAME Role::Basic::Philosophy - Why Role::Basic exists. =head1 RATIONALE Note: the words "trait" and "role" will be used interchangeably throughout this documentation. After years of using roles, your author has found that many people would be happy to use roles but are not willing/comfortable with using L. This module implements roles and nothing else. It does so in a (relatively) simple bit of code. However, you should be aware that there are some differences between L and L. L is a fantastic technology and your author is quite happy with it. He urges you to check it out and perhaps even consider L a "stepping-stone" to L. However, after an informal poll with many respondents replying on blogs.perl.org, Twitter, Facebook and private email I saying they wanted this module for roles and not as a stepping-stone to Moose, your author took the liberty of deciding to implement I in a rather faithful fashion, rather than strictly adhere to the design of L. For areas where we differ, L intends to be more restrictive when syntax is the same. This allows an easier migration to L when the time is right. Otherwise, L will offer a different syntax to avoid confusion. =head1 TRAITS As most of you probably know, roles are the Perl implmentation of traits as described in L. (The name "role" was chosen because "trait" was already used in Perl 6.) In particular, we direct you to two papers, both of which are easy to read: =over 4 =item * L The seminal "traits paper" which much of the documentation refers to. =item * L "Traits: The Formal Model". While less well-known, this relatively easy to read paper outlines the mathematical underpinnings of traits and explains several design decisions taken here. =back It is important to refer back to those papers because L attempts to implements traits as described in the research, whereas L attempts to implement something very similar to traits, but with more of a "Perlish" feel. This is not intended as a criticism of L, but merely an attempt to alert the reader to key differences. =head2 The Basics Roles are simply bundles of behavior which classes may use. If you have two completely unrelated classes, your code may still require each of them to serialize themselves as JSON even though neither class naturally has anything to do with JSON (for example, C and C classes). There are a number of approaches to this problem but if you're here I'll skip the explanation and assume that you already understand roles and would like to know why we don't follow the L specification. As you already probably know, roles allow you to state that your class "DOES" some behaviour, and allows you to exclude or alias bits and pieces of the roles you're including. The original specification of traits made it clear that this was to be done in such a fashion that no matter how you grouped the traits or in which order you used them, the outcome behavior would be the same. That's why we have subtle but forward-compatible differences with L. =head3 Commutative The formal model (L) states that trait composition must be commutative (section 3.4, proposition 1). This means that: (A + B) = (B + A) In other words, it should not matter what order you compose the traits in. It is well known that with both inheritance and mixins, this does not hold (making refactoring a dicey proposition at times), but when method modifiers are used with L, the same issues arises (from L): { package Some::Role; use Moose::Role; requires qw(some_method); before some_method => sub { my $self = shift; $self->some_number( $self->some_number + 2 ); }; } { package Another::Role; use Moose::Role; requires qw(some_method); before some_method => sub { my $self = shift; $self->some_number( $self->some_number / 2 ); }; } { package Some::Class; use Moose; my @roles = int( rand(2) ) ? qw(Another::Role Some::Role) : qw(Some::Role Another::Role); with @roles; has some_number => ( is => 'rw', isa => 'Num' ); sub some_method { print shift->some_number, $/ } } my $o = Some::Class->new( { some_number => 7 } ); $o->some_method; If you run this code, it might print 4.5, but it might print 5.5. As with mixins and multiple inheritance, you have no way of knowing the exact behaviour which will be exhibited short of running the code. No introspection will help. This is not an issue with L because we do not allow method modifiers. If you think you need them, please consider L. =head3 Associative The formal model (L) states that trait composition must be associative (section 3.4, proposition 1). This means that: (A + B) + C = A + (B + C) Moose is associative if and only if you do not have multiple methods with the same name. In Moose, if a role providing method I consumes B other role which also provides method I, we have a conflict: package Some::Role; use Moose::Role; sub bar { __PACKAGE__ } package Some::Other::Role; use Moose::Role; with 'Some::Role'; sub bar { __PACKAGE__ } package Some::Class; use Moose; with 'Some::Other::Role'; package main; my $o = Some::Class->new; print $o->bar; However, if the role consumes B other roles which provide the same method, we I have a conflict: package Some::Role; use Moose::Role; sub bar { __PACKAGE__ } package Some::Other::Role; use Moose::Role; sub bar { __PACKAGE__ } package Another::Role; use Moose::Role; with qw(Some::Role Some::Other::Role); sub bar { __PACKAGE__ } package Some::Class; use Moose; with 'Another::Role'; package main; my $o = Some::Class->new; print $o->bar; This is because, in Moose, when you have two or more roles consumed, any conflicting methods are excluded and considered to be requirements. See "Moose::Role composition edge cases" for more explanation: L. This makes roles easy to use at times, but it means that the following three groups of roles are not guaranteed to provide the same behavior: RoleA does RoleB, RoleC RoleB does RoleA, RoleC RoleC does RoleA, RoleB Further, you as a developer have no way of knowing that we have had methods silently excluded without reading all of the code. For L there are no edge cases. If C, C, and C all provide method I, you are guaranteed to get a conflict at composition time and must specifically address the problem. This addresses the associative issue because strictly speaking, a trait is merely a bundle of services provided, not its name. Thus, a trait with its C method excluded is not the same as itself without the C method excluded. =head3 Benefits of associative and commutative behaviour While we recognize that not everyone will be happy with the decisions we have made, we have several benefits here: =over 4 =item * We adhere to the formal definition of traits =item * Ordering and grouping of traits does not alter their behavior =item * We're forward-compatible with L =back =head1 CONCLUSION The primary goal of L is to provide traits in a simple and safe manner. We are I fans of L and L and suggest that everyone check them out. The decision of L to deviate from the "associative" and "commutative" deviations from the original traits model is, in our experience, less likely to occur with roles than with mixins and inhertance, so please do not take this as an indictment, but rather in the spirit of TIMTOWTDI. Role-Basic-0.16/t000755000765000024 014755276471 13072 5ustar00ovidstaff000000000000Role-Basic-0.16/t/00-load.t000444000765000024 27714755276471 14536 0ustar00ovidstaff000000000000#!perl -T use Test::More tests => 1; BEGIN { use_ok( 'Role::Basic' ) || BAIL_OUT "Could not load Role::Basic: $!"; } diag( "Testing Role::Basic $Role::Basic::VERSION, Perl $], $^X" ); Role-Basic-0.16/t/basic.t000444000765000024 45114755276471 14455 0ustar00ovidstaff000000000000#!/usr/bin/env perl use Test::More tests => 3; use lib 'lib', 't/lib'; use_ok 'My::Example' or BAIL_OUT 'Could not load test module My::Example'; can_ok 'My::Example', 'no_conflict'; is +My::Example->no_conflict, 'My::Does::Basic::no_conflict', '... and it should return the correct value'; Role-Basic-0.16/t/bugs.t000444000765000024 430714755276471 14360 0ustar00ovidstaff000000000000#!/usr/bin/env perl use lib 'lib', 't/lib'; use MyTests tests => 13; # multiple roles with the same role { package RoleC; use Role::Basic; sub baz { 'baz' } package RoleB; use Role::Basic; with 'RoleC'; sub bar { 'bar' } package RoleA; use Role::Basic; with 'RoleC'; sub foo { 'foo' } package Foo; use strict; use warnings; use Role::Basic 'with'; ::is( ::exception { with 'RoleA', 'RoleB'; }, undef, 'Composing multiple roles which use the same role should not have conflicts' ); sub new { bless {} => shift } my $object = Foo->new; foreach my $method (qw/foo bar baz/) { ::can_ok $object, $method; ::is $object->$method, $method, '... and all methods should be composed in correctly'; } } { no warnings 'redefine'; local *UNIVERSAL::can = sub { 1 }; eval <<' END'; package Can::Can; use Role::Basic 'with'; with 'A::NonExistent::Role'; END my $error = $@ || ''; like $error, qr{^Can't locate A/NonExistent/Role.pm}, 'If ->can always returns true, we should still not think we loaded the role' or diag "Error found: $error"; } { package Some::Role::AliasBug; use Role::Basic; sub bar { __PACKAGE__ } sub boom { 'whoa!' } package Another::Role::AliasBug; use Role::Basic; with 'Some::Role::AliasBug' => { -excludes => [ 'boom', 'bar' ], -alias => { boom => 'bar' }, }; sub boom {} package Some::Class; use Role::Basic 'with'; ::is( ::exception{ with 'Another::Role::AliasBug' }, undef, 'Aliasing a $old to $new should fulfill requirements for $new' ); } { package Role::Bar::Boom; use Role::Basic; sub bar { 'bar' } sub boom { 'boom' } package Double::Alias; use Role::Basic 'with'; $ENV{DEBUG} = 1; with 'Role::Bar::Boom' => { -rename => { boom => 'bar', bar => 'boom' }, }; sub new { bless {} => shift } package main; my $o = Double::Alias->new; can_ok $o, 'boom'; is $o->boom, 'bar', '... boom() is replaced with bar()'; can_ok $o, 'bar'; is $o->bar, 'boom', '... bar() is replaced with boom()'; } Role-Basic-0.16/t/composition.t000444000765000024 612114755276471 15757 0ustar00ovidstaff000000000000#!/usr/bin/env perl use lib 'lib', 't/lib'; use MyTests tests => 27; require Role::Basic; { package My::Does::Basic1; use Role::Basic; requires 'turbo_charger'; sub method { return __PACKAGE__ . " method"; } } { package My::Does::Basic2; use Role::Basic; requires 'turbo_charger'; sub method2 { return __PACKAGE__ . " method2"; } } eval <<'END_PACKAGE'; package My::Class1; use Role::Basic 'with'; with qw( My::Does::Basic1 My::Does::Basic2 ); sub turbo_charger {} END_PACKAGE ok !$@, 'We should be able to use two roles with the same requirements' or die $@; { package My::Does::Basic3; use Role::Basic; with 'My::Does::Basic2'; sub method3 { return __PACKAGE__ . " method3"; } } eval <<'END_PACKAGE'; package My::Class2; use Role::Basic 'with'; with qw( My::Does::Basic3 ); sub new { bless {} => shift } sub turbo_charger {} END_PACKAGE ok !$@, 'We should be able to use roles which consume roles' or die $@; can_ok 'My::Class2', 'method2'; is My::Class2->method2, 'My::Does::Basic2 method2', '... and it should be the correct method'; can_ok 'My::Class2', 'method3'; is My::Class2->method3, 'My::Does::Basic3 method3', '... and it should be the correct method'; can_ok 'My::Class2', 'DOES'; ok My::Class2->DOES('My::Does::Basic3'), 'A class DOES roles which it consumes'; ok My::Class2->DOES('My::Does::Basic2'), '... and should do roles which its roles consumes'; ok !My::Class2->DOES('My::Does::Basic1'), '... but not roles which it never consumed'; my $object = My::Class2->new; can_ok $object, 'DOES'; ok $object->DOES('My::Does::Basic3'), 'An instance DOES roles which its class consumes'; ok $object->DOES('My::Does::Basic2'), '... and should do roles which its roles consumes'; ok !$object->DOES('My::Does::Basic1'), '... but not roles which it never consumed'; { { package Role::Which::Imports; use Role::Basic allow => 'TestMethods'; use TestMethods qw(this that); } { package Class::With::ImportingRole; use Role::Basic 'with'; with 'Role::Which::Imports'; sub new { bless {} => shift } } my $o = Class::With::ImportingRole->new; foreach my $method (qw/this that/) { can_ok $o, $method; ok $o->$method($method), '... and calling "allow"ed methods should succeed'; is $o->$method, $method, '... and it should function correctly'; } } { { package Role::WithImportsOnceRemoved; use Role::Basic; with 'Role::Which::Imports'; } { package Class::With::ImportingRole2; use Role::Basic 'with'; $ENV{DEBUG} = 1; with 'Role::WithImportsOnceRemoved'; sub new { bless {} => shift } } ok my $o = Class::With::ImportingRole2->new, 'We should be able to use roles which compose roles which import'; foreach my $method (qw/this that/) { can_ok $o, $method; ok $o->$method($method), '... and calling "allow"ed methods should succeed'; is $o->$method, $method, '... and it should function correctly'; } } Role-Basic-0.16/t/exceptions.t000444000765000024 1111614755276471 15615 0ustar00ovidstaff000000000000#!/usr/bin/env perl use lib 'lib', 't/lib'; use MyTests tests => 12; require Role::Basic; { package My::Does::Basic; use Role::Basic; requires 'turbo_charger'; sub conflict { return "My::Does::Basic::conflict"; } } eval { Role::Basic->_load_role('My::Example') }; my $error = $@; like $error, qr/Only roles defined with Role::Basic may be loaded/, 'Trying to load non-roles should fail'; eval <<'END_PACKAGE'; package My::Bad::MultipleWith; use Role::Basic 'with'; with 'My::Does::Basic'; with 'My::Does::Basic'; # can't use with() more than once sub turbo_charger {} END_PACKAGE like $@, qr/with\(\) may not be called more than once for My::Bad::MultipleWith/, 'Trying to use with() more than once in a package should fail'; eval <<'END_PACKAGE'; package My::Bad::Import; use Role::Basic 'wtih'; # with, not 'wtih' END_PACKAGE like $@, qr/\QMultiple or unknown argument(s) in import list: (wtih)/, 'Trying to use Role::Basic with an import argument other than "with" should fail'; eval <<'END_PACKAGE'; package My::Bad::MultipleArgsToImport; use Role::Basic qw(with this); END_PACKAGE like $@, qr/\QMultiple or unknown argument(s) in import list: (with, this)/, 'Trying to use Role::Basic multiple arguments to the import list should fail'; eval <<'END_PACKAGE'; package My::Bad::Requirement; use Role::Basic 'with'; with 'My::Does::Basic'; # requires turbo_charger END_PACKAGE like $@, qr/'My::Does::Basic' requires the method 'turbo_charger' to be implemented by 'My::Bad::Requirement'/, 'Trying to use a role without providing required methods should fail'; { local $ENV{PERL_ROLE_OVERRIDE_DIE} = 1; eval <<' END_PACKAGE'; package My::Bad::Override; use Role::Basic 'with'; with 'My::Does::Basic'; # requires turbo_charger sub turbo_charger {} sub conflict {} END_PACKAGE like $@, qr/Role 'My::Does::Basic' not overriding method 'conflict' in 'My::Bad::Override'/, 'Trying to override methods with roles should die if PERL_ROLE_OVERRIDE_DIE is set'; } { { package My::Conflict; use Role::Basic; sub conflict {}; } eval <<' END_PACKAGE'; package My::Bad::MethodConflicts; use Role::Basic 'with'; with qw(My::Does::Basic My::Conflict); sub turbo_charger {} END_PACKAGE like $@, qr/Due to a method name conflict in roles 'My::Conflict' and 'My::Does::Basic', the method 'conflict' must be implemented or excluded by 'My::Bad::MethodConflicts'/, 'Trying to use multiple roles with the same method should fail'; } { local $ENV{PERL_ROLE_OVERRIDE_DIE} = 1; { package My::Conflict2; use Role::Basic; sub conflict {}; } eval <<' END_PACKAGE'; package My::Bad::MethodConflicts2; use Role::Basic 'with'; with 'My::Does::Basic', 'My::Conflict2' => { -alias => { conflict => 'turbo_charger' } }; sub turbo_charger {} END_PACKAGE like $@, qr/\QCannot alias 'conflict' to 'turbo_charger' as a method of that name already exists in My::Bad::MethodConflicts2/, 'Trying to alias a conflicting method to an existing one in the package should fail'; } { eval <<' END_PACKAGE'; { package My::Does::AnotherConflict; use Role::Basic; sub conflict {}; } package My::Bad::NoMethodConflicts; use Role::Basic 'with'; with 'My::Does::Basic' => { -excludes => 'conflict' }, 'My::Does::AnotherConflict'; sub turbo_charger {} END_PACKAGE ok !$@, 'Excluding role methods should succeed' or diag $@; } { { package Role1; use Role::Basic; requires 'missing_method'; sub method1 { 'method1' } } { package Role2; use Role::Basic; with 'Role1'; sub method2 { 'method2' } } eval <<" END"; package My::Class::Missing1; use Role::Basic 'with'; with 'Role2'; END like $@, qr/'Role1|Role2' requires the method 'missing_method' to be implemented by 'My::Class::Missing1'/, 'Roles composed from roles should propogate requirements upwards'; } { { package Role3; use Role::Basic; requires qw(this that); } eval <<" END"; package My::Class::Missing2; use Role::Basic 'with'; with 'Role3'; END like $@, qr/'Role3' requires the method 'this' to be implemented by 'My::Class::Missing2'/, 'Roles should be able to require multiple methods'; like $@, qr/'Role3' requires the method 'that' to be implemented by 'My::Class::Missing2'/, '... and have all of them provided in the error messages'; } Role-Basic-0.16/t/internals.t000444000765000024 177714755276471 15427 0ustar00ovidstaff000000000000#!/usr/bin/env perl use Test::More tests => 5; use lib 'lib', 't/lib'; use Role::Basic (); eval { Role::Basic->_load_role('My::Does::Basic') }; ok !$@, 'Role::Basic->_load_role should succeed loading a package'; ok exists $INC{'My/Does/Basic.pm'}, 'and it should be in the %INC hash'; eval { Role::Basic->_load_role('My::Does::Basic') }; ok !$@, 'and trying to load a role more than once should be OK'; eval { Role::Basic->_load_role('No::Such::Role') }; like $@, qr{Can't locate No/Such/Role\.pm in \@INC}, 'but trying to load a non-existent package should fail'; { package My::Example; use Role::Basic 'with'; with 'My::Does::Basic'; sub new { bless {} => shift } sub turbo_charger {} sub foo() {} } my $methods = [sort keys %{ Role::Basic->_get_methods('My::Example') } ]; is_deeply $methods, [qw/foo new turbo_charger/], 'Role::Basic->_get_methods should only return methods defined in the package' or do { require Data::Dumper; diag Data::Dumper::Dumper($methods); }; Role-Basic-0.16/t/lib000755000765000024 014755276471 13640 5ustar00ovidstaff000000000000Role-Basic-0.16/t/lib/MyTests.pm000444000765000024 146614755276471 15752 0ustar00ovidstaff000000000000package MyTests; use strict; use warnings; use Test::More (); sub import { my $class = shift; my $caller = caller; no strict 'refs'; *{"${caller}::exception"} = \&exception; local $" = ", "; use Data::Dumper; $Data::Dumper::Terse = 1; @_ = Dumper(@_); eval <<" END"; package $caller; no strict; use Test::More @_; END die $@ if $@; } sub exception (&) { my ($code) = @_; my $result; eval { $code->(); $result = undef; 1; } or do { if ( $result = $@ ) { # do nothing } else { my $problem = defined $_ ? 'false' : 'undef'; Carp::confess("$problem exception caught by Test::Fatal::exception"); } }; return $result; } 1; Role-Basic-0.16/t/lib/TestMethods.pm000444000765000024 73314755276471 16561 0ustar00ovidstaff000000000000package TestMethods; use strict; use warnings; sub import { my ( $class, @methods ) = @_; my $target = caller; foreach my $method (@methods) { my $fq_method = $target . "::$method"; no strict 'refs'; *$fq_method = sub { local *__ANON__ = "__ANON__$fq_method"; my $self = shift; return $self->{$method} unless @_; $self->{$method} = shift; return $self; }; } } 1; Role-Basic-0.16/t/lib/My000755000765000024 014755276471 14225 5ustar00ovidstaff000000000000Role-Basic-0.16/t/lib/My/Example.pm000444000765000024 24414755276471 16273 0ustar00ovidstaff000000000000package My::Example; use Role::Basic 'with'; with 'My::Does::Basic'; sub new { bless {} => shift } sub turbo_charger {} $My::Example::foo = 1; sub foo() {} 1; Role-Basic-0.16/t/lib/My/Does000755000765000024 014755276471 15117 5ustar00ovidstaff000000000000Role-Basic-0.16/t/lib/My/Does/Basic.pm000444000765000024 45614755276471 16620 0ustar00ovidstaff000000000000package My::Does::Basic; use Role::Basic; requires 'turbo_charger'; use constant FOO => 'bar'; use constant a_scalar => 2; use constant a_sub => sub { 3 }; use constant an_array => [ 4, 5 ]; use constant a_hash => { 6 => 7 }; sub no_conflict { return "My::Does::Basic::no_conflict"; } 1; Role-Basic-0.16/t/moose000755000765000024 014755276471 14214 5ustar00ovidstaff000000000000Role-Basic-0.16/t/moose/003_apply_role.t000444000765000024 604514755276471 17273 0ustar00ovidstaff000000000000#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use MyTests tests => 51; { package FooRole; our $VERSION = 23; use Role::Basic allow => 'TestMethods'; use TestMethods qw(bar baz); sub goo {'FooRole::goo'} sub foo {'FooRole::foo'} } { package BarRole; use Role::Basic;; sub woot {'BarRole::woot'} } { package BarClass; sub boo {'BarClass::boo'} sub foo {'BarClass::foo'} # << the role overrides this ... } { package FooClass; use Role::Basic 'with'; use base 'BarClass'; sub new { bless {} => shift } eval { with 'FooRole' => { -version => 42 }; 1 } or my $error = $@; ::like $error, qr/FooRole version 42 required--this is only version 23/, 'applying role with unsatisfied version requirement'; $error = ''; eval { with 'FooRole' => { -version => 13 }; 1 } or $error = $@; ::ok !$error, 'applying role with satisfied version requirement'; sub goo {'FooClass::goo'} # << overrides the one from the role ... } { package FooBarClass; use Role::Basic 'with'; use base 'FooClass'; with 'FooRole', 'BarRole'; } foreach my $method_name (qw(bar baz foo boo goo)) { can_ok 'FooBarClass', $method_name; } can_ok( 'FooClass', 'DOES' ); ok( FooClass->DOES('FooRole'), '... the FooClass DOES FooRole' ); ok( !FooClass->DOES('BarRole'), '... the FooClass DOES not do BarRole' ); ok( !FooClass->DOES('OtherRole'), '... the FooClass DOES not do OtherRole' ); can_ok( 'FooBarClass', 'DOES' ); ok( FooBarClass->DOES('FooRole'), '... the FooClass DOES FooRole' ); ok( FooBarClass->DOES('BarRole'), '... the FooBarClass DOES FooBarRole' ); ok( !FooBarClass->DOES('OtherRole'), '... the FooBarClass DOES not do OtherRole' ); my $foo = FooClass->new(); isa_ok( $foo, 'FooClass' ); my $foobar = FooBarClass->new(); isa_ok( $foobar, 'FooBarClass' ); is( $foo->goo, 'FooClass::goo', '... got the right value of goo' ); is( $foobar->goo, 'FooRole::goo', '... got the right value of goo' ); is( $foo->boo, 'BarClass::boo', '... got the right value from ->boo' ); is( $foobar->boo, 'BarClass::boo', '... got the right value from ->boo (double wrapped)' ); foreach my $foo ( $foo, $foobar ) { can_ok( $foo, 'DOES' ); ok( $foo->DOES('FooRole'), '... an instance of FooClass DOES FooRole' ); ok( !$foo->DOES('OtherRole'), '... and instance of FooClass DOES not do OtherRole' ); can_ok( $foobar, 'DOES' ); ok( $foobar->DOES('FooRole'), '... an instance of FooBarClass DOES FooRole' ); ok( $foobar->DOES('BarRole'), '... an instance of FooBarClass DOES BarRole' ); ok( !$foobar->DOES('OtherRole'), '... and instance of FooBarClass DOES not do OtherRole' ); for my $method (qw/bar baz foo boo goo/) { ok $foo->can($method), "$foo should be able to do $method"; } is( $foo->foo, 'FooRole::foo', '... got the right value of foo' ); ok( !defined( $foo->baz ), '... $foo->baz is undefined' ); ok( !defined( $foo->bar ), '... $foo->bar is undefined' ); } Role-Basic-0.16/t/moose/004_role_composition_errors.t000444000765000024 1140314755276471 22120 0ustar00ovidstaff000000000000#!/usr/bin/perl use strict; use warnings; use lib 'lib', 't/lib'; use MyTests tests => 21; { package Foo::Role; use Role::Basic; requires 'foo'; } is_deeply( [ Role::Basic->get_required_by('Foo::Role') ], ['foo'], '... the Foo::Role has a required method (foo)' ); # classes which does not implement required method { package Foo::Class; use Role::Basic 'with'; ::isnt( ::exception { with('Foo::Role') }, undef, '... no foo method implemented by Foo::Class' ); } # class which does implement required method { package Bar::Class; use Role::Basic 'with'; ::isnt( ::exception { with('Foo::Class') }, undef, '... cannot consume a class, it must be a role' ); ::is( ::exception { with('Foo::Role') }, undef, '... has a foo method implemented by Bar::Class' ); sub foo {'Bar::Class::foo'} } # role which does implement required method { package Bar::Role; use Role::Basic; ::is( ::exception { with('Foo::Role') }, undef, '... has a foo method implemented by Bar::Role' ); sub foo {'Bar::Role::foo'} } # XXX this is different from Moose. In Moose, roles can be applied # dynamically, so sharing the requirements on a class basis is bad. We don't # allow this in Role::Basic, so it's OK. is_deeply( [ sort Role::Basic->get_required_by('Bar::Role') ], ['foo'], '... the Bar::Role has inherited the required method from Foo::Role' ); # role which does not implement required method { package Baz::Role; use Role::Basic; ::is( ::exception { with('Foo::Role') }, undef, '... no foo method implemented by Baz::Role' ); } is_deeply( [ Role::Basic->get_required_by('Baz::Role') ], ['foo'], '... the Baz::Role has inherited the required method from Foo::Role' ); # classes which does not implement required method { package Baz::Class; use Role::Basic 'with'; ::isnt( ::exception { with('Baz::Role') }, undef, '... no foo method implemented by Baz::Class2' ); } # class which does implement required method { package Baz::Class2; use Role::Basic 'with'; ::is( ::exception { with('Baz::Role') }, undef, '... has a foo method implemented by Baz::Class2' ); sub foo {'Baz::Class2::foo'} } { package Quux::Role; use Role::Basic; requires qw( meth1 meth2 meth3 meth4 ); } # RT #41119 { package Quux::Class; use Role::Basic 'with'; my $exception = ::exception { with('Quux::Role') }; ::like( $exception, qr/\Q'Quux::Role' requires the method 'meth1' to be implemented by 'Quux::Class'/, 'exception mentions all the missing required methods at once' ); ::like( $exception, qr/\Q'Quux::Role' requires the method 'meth2' to be implemented by 'Quux::Class'/, 'exception mentions all the missing required methods at once' ); ::like( $exception, qr/\Q'Quux::Role' requires the method 'meth3' to be implemented by 'Quux::Class'/, 'exception mentions all the missing required methods at once' ); ::like( $exception, qr/\Q'Quux::Role' requires the method 'meth4' to be implemented by 'Quux::Class'/, 'exception mentions all the missing required methods at once' ); } { package Quux::Class2; use Role::Basic 'with'; sub meth1 { } my $exception = ::exception { with('Quux::Role') }; ::like( $exception, qr/'Quux::Role' requires the method 'meth2' to be implemented by 'Quux::Class2'/, 'exception mentions all the missing required methods at once, but not the one that exists' ); ::like( $exception, qr/'Quux::Role' requires the method 'meth3' to be implemented by 'Quux::Class2'/, 'exception mentions all the missing required methods at once, but not the one that exists' ); ::like( $exception, qr/'Quux::Role' requires the method 'meth4' to be implemented by 'Quux::Class2'/, 'exception mentions all the missing required methods at once, but not the one that exists' ); } { package Quux::Class3; use Role::Basic 'with'; my $exception = ::exception { with('Quux::Role') }; ::like( $exception, qr/'Quux::Role' requires the method 'meth3' to be implemented by 'Quux::Class3'/, 'exception mentions all the missing methods at once, but not the accessors' ); ::like( $exception, qr/'Quux::Role' requires the method 'meth4' to be implemented by 'Quux::Class3'/, 'exception mentions all the missing methods at once, but not the accessors' ); } { package Quux::Class4; use Role::Basic 'with'; sub meth1 { } my $exception = ::exception { with('Quux::Role') }; ::like( $exception, qr/'Quux::Role' requires the method 'meth3' to be implemented by 'Quux::Class4'/, 'exception mentions all the missing methods at once, but not the accessors' ); ::like( $exception, qr/'Quux::Role' requires the method 'meth4' to be implemented by 'Quux::Class4'/, 'exception mentions all the missing methods at once, but not the accessors' ); } Role-Basic-0.16/t/moose/005_role_conflict_detection.t000444000765000024 1160614755276471 22026 0ustar00ovidstaff000000000000#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use MyTests tests => 38; =pod Mutually recursive roles. =cut { package Role::Foo; use Role::Basic; requires 'foo'; sub bar { 'Role::Foo::bar' } package Role::Bar; use Role::Basic; requires 'bar'; sub foo { 'Role::Bar::foo' } } { package My::Test1; use Role::Basic 'with'; sub new { {} => shift } ::is( ::exception { with 'Role::Foo', 'Role::Bar'; }, undef, '... our mutually recursive roles combine okay' ); package My::Test2; use Role::Basic 'with'; sub new { bless {} => shift } ::is( ::exception { with 'Role::Bar', 'Role::Foo'; }, undef, '... our mutually recursive roles combine okay (no matter what order)' ); } my $test1 = My::Test1->new; isa_ok($test1, 'My::Test1'); ok($test1->DOES('Role::Foo'), '... $test1 does Role::Foo'); ok($test1->DOES('Role::Bar'), '... $test1 does Role::Bar'); can_ok($test1, 'foo'); can_ok($test1, 'bar'); is($test1->foo, 'Role::Bar::foo', '... $test1->foo worked'); is($test1->bar, 'Role::Foo::bar', '... $test1->bar worked'); my $test2 = My::Test2->new; isa_ok($test2, 'My::Test2'); ok($test2->DOES('Role::Foo'), '... $test2 does Role::Foo'); ok($test2->DOES('Role::Bar'), '... $test2 does Role::Bar'); can_ok($test2, 'foo'); can_ok($test2, 'bar'); is($test2->foo, 'Role::Bar::foo', '... $test2->foo worked'); is($test2->bar, 'Role::Foo::bar', '... $test2->bar worked'); # check some meta-stuff ok(Role::Foo->can('bar'), '... it still has the bar method'); ok(Role::Basic->requires_method('Role::Foo','foo'), '... it still has the required foo method'); ok(Role::Bar->can('foo'), '... it still has the foo method'); ok(Role::Basic->requires_method('Role::Bar','bar'), '... it still has the required bar method'); =pod Role method conflicts =cut { package Role::Bling; use Role::Basic; sub bling { 'Role::Bling::bling' } package Role::Bling::Bling; use Role::Basic; sub bling { 'Role::Bling::Bling::bling' } } { package My::Test3; use Role::Basic 'with'; sub new { bless {} => shift } ::like( ::exception { with 'Role::Bling', 'Role::Bling::Bling'; }, qr/Due to a method name conflict in roles 'Role::Bling' and 'Role::Bling::Bling', the method 'bling' must be implemented or excluded by 'My::Test3'/, '... role methods conflict and method was required' ); package My::Test4; use Role::Basic 'with'; sub new { bless {} => shift } # XXX Moose allows multiple 'with' statements. Role::Basic does not ::like( ::exception{ with 'Role::Bling'; with 'Role::Bling::Bling'; }, qr/with\(\) may not be called more than once for My::Test4/, '... role methods cannot be manually combined' ); package My::Test6; use Role::Basic 'with'; sub new { bless {} => shift } ::is( ::exception { with 'Role::Bling::Bling', 'Role::Bling'; }, undef, '... role methods didnt conflict when manually resolved' ); sub bling { 'My::Test6::bling' } } TODO: { local $TODO = 'Do not flatten methods into a class if there are conflicts'; ok(!My::Test3->can('bling'), '... we didnt get any methods in the conflict'); } ok(My::Test4->can('bling'), '... we did get the method when manually dealt with'); ok(My::Test6->can('bling'), '... we did get the method when manually dealt with'); TODO: { local $TODO = 'Do not compose roles into a class if there are conflicts'; ok(!My::Test3->DOES('Role::Bling'), '... our class does() the correct roles'); ok(!My::Test3->DOES('Role::Bling::Bling'), '... our class does() the correct roles'); } ok(My::Test4->DOES('Role::Bling'), '... our class does() the correct roles'); # XXX another difference from Moose ok(!My::Test4->DOES('Role::Bling::Bling'), '... our class does not support multiple with()'); ok(My::Test6->DOES('Role::Bling'), '... our class does() the correct roles'); ok(My::Test6->DOES('Role::Bling::Bling'), '... our class does() the correct roles'); is(My::Test4->bling, 'Role::Bling::bling', '... and we got the first method that was added'); is(My::Test6->bling, 'My::Test6::bling', '... and we got the local method'); # check how this affects role compostion { package Role::Bling::Bling::Bling; use Role::Basic; with 'Role::Bling::Bling'; sub bling { 'Role::Bling::Bling::Bling::bling' } } ok(Role::Bling::Bling->can('bling'), '... still got the bling method in Role::Bling::Bling'); ok(Role::Bling::Bling->DOES('Role::Bling::Bling'), '... our role correctly does() itself'); ok(Role::Bling::Bling::Bling->can('bling'), '... dont have the bling method in Role::Bling::Bling::Bling'); is(Role::Bling::Bling::Bling->can('bling')->(), 'Role::Bling::Bling::Bling::bling', '... still got the bling method in Role::Bling::Bling::Bling'); # the rest of this is truncated because we make no distinction between # atttributes and methods Role-Basic-0.16/t/moose/011_overriding.t000444000765000024 1374514755276471 17321 0ustar00ovidstaff000000000000#!/usr/bin/perl use strict; use warnings; use lib 'lib', 't/lib'; use MyTests tests => 29; { # test no conflicts here package Role::A; use Role::Basic; sub bar { 'Role::A::bar' } package Role::B; use Role::Basic; sub xxy { 'Role::B::xxy' } package Role::C; use Role::Basic; ::is( ::exception { with qw(Role::A Role::B); # no conflict here }, undef, "define role C" ); sub foo { 'Role::C::foo' } sub zot { 'Role::C::zot' } package Class::A; use Role::Basic 'with'; sub new { bless {} => shift } ::is( ::exception { with qw(Role::C); }, undef, "define class A" ); sub zot { 'Class::A::zot' } } can_ok( Class::A->new, qw(foo bar xxy zot) ); is( Class::A->new->foo, "Role::C::foo", "... got the right foo method" ); is( Class::A->new->zot, "Class::A::zot", "... got the right zot method" ); is( Class::A->new->bar, "Role::A::bar", "... got the right bar method" ); is( Class::A->new->xxy, "Role::B::xxy", "... got the right xxy method" ); { # check that when a role is added to another role # and they conflict and the method they conflict # with is then required. package Role::A::Conflict; use Role::Basic; with 'Role::A'; sub bar { 'Role::A::Conflict::bar' } package Class::A::Conflict; use Role::Basic 'with'; ::like( ::exception{ with 'Role::A::Conflict'; }, qr/Due to a method name conflict in roles 'Role::A' and 'Role::A::Conflict', the method 'bar' must be implemented or excluded by 'Class::A::Conflict'/, '... did not fulfill the requirement of &bar method' ); package Class::A::Resolved; use Role::Basic 'with'; sub new { bless {} => shift } ::is( ::exception { with 'Role::A::Conflict'; }, undef, '... did fufill the requirement of &bar method' ); sub bar { 'Class::A::Resolved::bar' } } TODO: { local $TODO = 'Check to see why this is done and if we need it'; ok( Role::Basic->requires_method( 'Role::A::Conflict', 'bar' ), '... Role::A::Conflict created the bar requirement' ); } can_ok( Class::A::Resolved->new, qw(bar) ); is( Class::A::Resolved->new->bar, 'Class::A::Resolved::bar', "... got the right bar method" ); { # check that when two roles are composed, they conflict # but the composing role can resolve that conflict package Role::D; use Role::Basic; sub foo { 'Role::D::foo' } sub bar { 'Role::D::bar' } package Role::E; use Role::Basic; sub foo { 'Role::E::foo' } sub xxy { 'Role::E::xxy' } package Role::F; use Role::Basic; ::is( ::exception { with qw(Role::D Role::E); # conflict between 'foo's here }, undef, "define role Role::F" ); sub foo { 'Role::F::foo' } sub zot { 'Role::F::zot' } package Class::B; use Role::Basic 'with'; sub new { bless {} => shift } # XXX this is different from Moose. Traits are required, amongst other # things, as being "associative". Moose breaks with that. We keep this # behavior (for now) as it's easier to be restrictive and let up than the # other way around. See # http://blogs.perl.org/users/ovid/2011/01/rolebasic-what-is-a-conflict.html # for more detail. ::like( ::exception { with qw(Role::F); }, qr/\QDue to a method name conflict in roles 'Role::D' and 'Role::E' and 'Role::F', the method 'foo' must be implemented or excluded by 'Class::B'/, "define class Class::B" ); sub zot { 'Class::B::zot' } } # XXX lots of Moose tests deleted as they don't apply to Role::Basic { # conflict propagation package Role::H; use Role::Basic; sub foo { 'Role::H::foo' } sub bar { 'Role::H::bar' } package Role::J; use Role::Basic; sub foo { 'Role::J::foo' } sub xxy { 'Role::J::xxy' } package Role::I; use Role::Basic; # XXX another difference with Moose. Originally we deferred conflicts to # the consuming class, but their was no syntax to allow the class to # understand the role's composition and pick it apart (i.e., exclude # methods from the roles this role consumed). Thus, we throw an exception # as it's safer. ::isnt( ::exception { with qw(Role::J Role::H); # conflict between 'foo's here }, undef, "define role Role::I" ); sub zot { 'Role::I::zot' } sub zzy { 'Role::I::zzy' } package Class::C; use Role::Basic 'with'; ::like( ::exception { with qw(Role::I); }, qr/Due to a method name conflict in roles 'Role::H' and 'Role::J', the method 'foo' must be implemented or excluded by 'Class::C'/, "defining class Class::C fails" ); sub zot { 'Class::C::zot' } package Class::E; use Role::Basic 'with'; sub new { bless {} => shift } ::is( ::exception { with qw(Role::I); }, undef, "resolved with method" ); sub foo { 'Class::E::foo' } sub zot { 'Class::E::zot' } } can_ok( Class::E->new, qw(foo bar xxy zot) ); is( Class::E->new->foo, "Class::E::foo", "... got the right &foo method" ); is( Class::E->new->zot, "Class::E::zot", "... got the right &zot method" ); is( Class::E->new->bar, "Role::H::bar", "... got the right &bar method" ); is( Class::E->new->xxy, "Role::J::xxy", "... got the right &xxy method" ); TODO: { local $TODO = 'We do not convert conflicts to requirements. Should we?'; ok( Role::Basic->requires_method( 'Role::I', 'foo' ), '... Role::I still have the &foo requirement' ); } { is( exception { package Class::D; use Role::Basic 'with'; sub new { bless {} => shift } sub foo { "Class::D::foo" } sub zot { 'Class::D::zot' } with qw(Role::I); }, undef, "resolved with attr" ); can_ok( Class::D->new, qw(foo bar xxy zot) ); is( eval { Class::D->new->bar }, "Role::H::bar", "bar" ); is( eval { Class::D->new->zzy }, "Role::I::zzy", "zzy" ); is( eval { Class::D->new->foo }, "Class::D::foo", "foo" ); is( eval { Class::D->new->zot }, "Class::D::zot", "zot" ); } Role-Basic-0.16/t/moose/012_method_exclusion_in_composition.t000444000765000024 622114755276471 23603 0ustar00ovidstaff000000000000#!/usr/bin/perl use strict; use warnings; use lib 'lib', 't/lib'; use MyTests tests => 19; { package My::Role; use Role::Basic; sub foo { 'Foo::foo' } sub bar { 'Foo::bar' } sub baz { 'Foo::baz' } package My::Class; use Role::Basic 'with'; with 'My::Role' => { -excludes => 'bar' }; } ok(My::Class->can($_), "we have a $_ method") for qw(foo baz); ok(!My::Class->can('bar'), '... but we excluded bar'); { package My::OtherRole; use Role::Basic; with 'My::Role' => { -excludes => 'foo' }; sub foo { 'My::OtherRole::foo' } sub bar { 'My::OtherRole::bar' } } ok(My::OtherRole->can($_), "we have a $_ method") for qw(foo bar baz); # XXX [!Moose] ok(Role::Basic->requires_method("My::OtherRole", 'foo'), 'Excluded methods should be required'); # XXX [!Moose] ok(!Role::Basic->requires_method("My::OtherRole", 'bar'), '... but provided methods should not'); { package Foo::Role; use Role::Basic; sub foo { 'Foo::Role::foo' } package Bar::Role; use Role::Basic; sub foo { 'Bar::Role::foo' } package Baz::Role; use Role::Basic; sub foo { 'Baz::Role::foo' } package My::Foo::Class; use Role::Basic 'with'; sub new { bless {} => shift } ::is( ::exception { with 'Foo::Role' => { -excludes => 'foo' }, 'Bar::Role' => { -excludes => 'foo' }, 'Baz::Role'; }, undef, '... composed our roles correctly' ); package My::Foo::Class::Broken; use Role::Basic 'with'; ::like( ::exception { with 'Foo::Role', 'Bar::Role' => { -excludes => 'foo' }, 'Baz::Role'; }, qr/Due to a method name conflict in roles 'Baz::Role' and 'Foo::Role', the method 'foo' must be implemented or excluded by 'My::Foo::Class::Broken'/, '... composed our roles correctly' ); } { my $foo = My::Foo::Class->new; isa_ok($foo, 'My::Foo::Class'); can_ok($foo, 'foo'); is($foo->foo, 'Baz::Role::foo', '... got the right method'); } { package My::Foo::Role; use Role::Basic; ::is( ::exception { with 'Foo::Role' => { -excludes => 'foo' }, 'Bar::Role' => { -excludes => 'foo' }, 'Baz::Role'; }, undef, '... composed our roles correctly' ); } ok(My::Foo::Role->can('foo'), "we have a foo method"); # XXX [!Moose] ok(Role::Basic->requires_method("My::Foo::Role", 'foo'), '... and the excluded &foo method is required'); { package My::Foo::Role::Other; use Role::Basic; # XXX again, a difference with Moose. We guarantee the property of # associativity in roles, Moose does not. ::like( ::exception { with 'Foo::Role', 'Bar::Role' => { -excludes => 'foo' }, 'Baz::Role'; }, qr/Due to a method name conflict in roles 'Baz::Role' and 'Foo::Role', the method 'foo' must be implemented or excluded by 'My::Foo::Role::Other'/, '... composed our roles correctly' ); } TODO: { local $TODO = 'We probably should make no guarantees about these failures'; ok(!My::Foo::Role::Other->can('foo'), "we dont have a foo method"); } ok(Role::Basic->requires_method("My::Foo::Role::Other", 'foo'), '... and the &foo method is required'); Role-Basic-0.16/t/moose/013_method_aliasing_in_composition.t000444000765000024 1374014755276471 23406 0ustar00ovidstaff000000000000#!/usr/bin/perl use strict; use warnings; use lib 'lib', 't/lib'; use MyTests tests => 46; { package My::Role; use Role::Basic; sub foo { 'Foo::foo' } sub bar { 'Foo::bar' } sub baz { 'Foo::baz' } requires 'role_bar'; package My::Class; use Role::Basic 'with'; ::is( ::exception { with 'My::Role' => { -alias => { bar => 'role_bar' } }; }, undef, '... this succeeds' ); package My::Class::Failure; use Role::Basic 'with'; ::like( ::exception { with 'My::Role' => { -alias => { bar => 'role_bar' } }; }, qr/Cannot alias 'bar' to 'role_bar' as a method of that name already exists in My::Class::Failure/, '... this succeeds' ); sub role_bar { 'FAIL' } } ok(My::Class->can($_), "we have a $_ method") for qw(foo baz bar role_bar); { package My::OtherRole; use Role::Basic; ::is( ::exception { with 'My::Role' => { -alias => { bar => 'role_bar' } }; }, undef, '... this succeeds' ); sub bar { 'My::OtherRole::bar' } package My::OtherRole::Failure; use Role::Basic; ::like( ::exception { with 'My::Role' => { -alias => { bar => 'role_bar' } }; }, qr/Cannot alias 'bar' to 'role_bar' as a method of that name already exists in My::OtherRole::Failure/, '... cannot alias to a name that exists' ); sub role_bar { 'FAIL' } } ok(My::OtherRole->can($_), "we have a $_ method") for qw(foo baz role_bar); TODO: { local $TODO = 'Still unsure if this behavior us needed. Failure provides no guarantees'; ok(Role::Basic->requires_method("My::OtherRole", 'bar'), '... and the &bar method is required'); ok(!Role::Basic->requires_method("My::OtherRole", 'role_bar'), '... and the &role_bar method is not required'); } { package My::AliasingRole; use Role::Basic; ::is( ::exception { with 'My::Role' => { -alias => { bar => 'role_bar' } }; }, undef, '... this succeeds' ); } ok(My::AliasingRole->can($_), "we have a $_ method") for qw(foo baz role_bar); ok(!Role::Basic->requires_method("My::AliasingRole", 'bar'), '... and the &bar method is not required'); { package Foo::Role; use Role::Basic; sub foo { 'Foo::Role::foo' } package Bar::Role; use Role::Basic; sub foo { 'Bar::Role::foo' } package Baz::Role; use Role::Basic; sub foo { 'Baz::Role::foo' } package My::Foo::Class; use Role::Basic 'with'; sub new { bless {} => shift } ::is( ::exception { with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' }, 'Baz::Role'; }, undef, '... composed our roles correctly' ); package My::Foo::Class::Broken; use Role::Basic 'with'; # XXX due to how we're structured, we hit the 'alias' error before the # "method conflict" error which Moose gets ::like( ::exception { with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, 'Baz::Role'; }, qr/Cannot alias 'foo' to 'foo_foo' as a method of that name already exists in My::Foo::Class::Broken/, '... composed our roles correctly' ); } { my $foo = My::Foo::Class->new; isa_ok($foo, 'My::Foo::Class'); can_ok($foo, $_) for qw/foo foo_foo bar_foo/; is($foo->foo, 'Baz::Role::foo', '... got the right method'); is($foo->foo_foo, 'Foo::Role::foo', '... got the right method'); is($foo->bar_foo, 'Bar::Role::foo', '... got the right method'); } { package My::Foo::Role; use Role::Basic; ::is( ::exception { with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' }, 'Baz::Role'; }, undef, '... composed our roles correctly' ); } ok(My::Foo::Role->can($_), "we have a $_ method") for qw/foo foo_foo bar_foo/;; # XXX [!Moose] TODO: { local $TODO = 'fix requires'; ok(Role::Basic->requires_method("My::Foo::Role", 'foo'), '... and the &foo method is required'); } { package My::Foo::Role::Other; use Role::Basic; # XXX again, we propogate errors immediately rather than generating # requirements ::isnt( ::exception { with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, 'Baz::Role'; }, undef, '... composed our roles correctly' ); } TODO: { local $TODO = 'We probably should make no guarantees on failure'; ok(!My::Foo::Role::Other->can('foo_foo'), "we dont have a foo_foo method"); ok(Role::Basic->requires_method("My::Foo::Role::Other", 'foo_foo'), '... and the &foo method is required'); } { package My::Foo::AliasOnly; use Role::Basic 'with'; ::is( ::exception { with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' } }, }, undef, '... composed our roles correctly' ); } ok(My::Foo::AliasOnly->can('foo'), 'we have a foo method'); ok(My::Foo::AliasOnly->can('foo_foo'), '.. and the aliased foo_foo method'); { package Role::Foo; use Role::Basic; sub x1 {} sub y1 {} } { package Role::Bar; use Role::Basic; ::is( ::exception { with 'Role::Foo' => { -alias => { x1 => 'foo_x1' }, -excludes => ['y1'], }; }, undef, 'Compose Role::Foo into Role::Bar with alias and exclude' ); sub x1 {} sub y1 {} } { ok( Role::Bar->can($_), "can $_ method" ) for qw( x1 y1 foo_x1 ); } { package Role::Baz; use Role::Basic; ::is( ::exception { with 'Role::Foo' => { -alias => { x1 => 'foo_x1' }, -excludes => ['y1'], }; }, undef, 'Compose Role::Foo into Role::Baz with alias and exclude' ); } { ok( Role::Baz->can($_), "has $_ method" ) for qw( x1 foo_x1 ); ok( ! Role::Baz->can('y1'), 'Role::Baz has no y1 method' ); } Role-Basic-0.16/t/moose/014_more_alias_and_exclude.t000444000765000024 325614755276471 21576 0ustar00ovidstaff000000000000#!/usr/bin/perl use strict; use warnings; use lib 'lib', 't/lib'; use MyTests tests => 9; { package Foo; use Role::Basic; sub foo { 'Foo::foo' } sub bar { 'Foo::bar' } sub baz { 'Foo::baz' } sub gorch { 'Foo::gorch' } package Bar; use Role::Basic; sub foo { 'Bar::foo' } sub bar { 'Bar::bar' } sub baz { 'Bar::baz' } sub gorch { 'Bar::gorch' } package Baz; use Role::Basic; sub foo { 'Baz::foo' } sub bar { 'Baz::bar' } sub baz { 'Baz::baz' } sub gorch { 'Baz::gorch' } package Gorch; use Role::Basic; sub foo { 'Gorch::foo' } sub bar { 'Gorch::bar' } sub baz { 'Gorch::baz' } sub gorch { 'Gorch::gorch' } } { package My::Class; use Role::Basic 'with'; sub new { bless {} => shift } ::is( ::exception { with 'Foo' => { -excludes => [qw/bar baz gorch/], -alias => { gorch => 'foo_gorch' } }, 'Bar' => { -excludes => [qw/foo baz gorch/] }, 'Baz' => { -excludes => [qw/foo bar gorch/], -alias => { foo => 'baz_foo', bar => 'baz_bar' } }, 'Gorch' => { -excludes => [qw/foo bar baz/] }; }, undef, '... everything works out all right' ); } my $c = My::Class->new; isa_ok($c, 'My::Class'); is($c->foo, 'Foo::foo', '... got the right method'); is($c->bar, 'Bar::bar', '... got the right method'); is($c->baz, 'Baz::baz', '... got the right method'); is($c->gorch, 'Gorch::gorch', '... got the right method'); is($c->foo_gorch, 'Foo::gorch', '... got the right method'); is($c->baz_foo, 'Baz::foo', '... got the right method'); is($c->baz_bar, 'Baz::bar', '... got the right method'); Role-Basic-0.16/t/moose/032_roles_and_method_cloning.t000444000765000024 237614755276471 22151 0ustar00ovidstaff000000000000#!/usr/bin/perl use strict; use warnings; use lib 'lib', 't/lib'; use MyTests tests => 10; { package Role::Foo; use Role::Basic; sub foo { (caller(0))[3] } } { package ClassA; use Role::Basic 'with'; with 'Role::Foo'; } { my $meth = ClassA->can('foo'); ok( $meth, 'ClassA has a foo method' ); is( $meth, Role::Foo->can('foo'), 'ClassA->foo was cloned from Role::Foo->foo' ); } { package Role::Bar; use Role::Basic; with 'Role::Foo'; sub bar { } } { my $meth = Role::Bar->can('foo'); ok( $meth, 'Role::Bar has a foo method' ); is( $meth, Role::Foo->can('foo'), 'Role::Bar->foo was cloned from Role::Foo->foo' ); } { package ClassB; use Role::Basic 'with'; with 'Role::Bar'; } { my $meth = ClassB->can('foo'); ok( $meth, 'ClassB has a foo method' ); is( $meth, Role::Bar->can('foo'), 'ClassA->foo was cloned from Role::Bar->foo' ); is( $meth, Role::Foo->can('foo'), '... which in turn was cloned from Role::Foo->foo' ); } isnt( ClassA->foo, "ClassB::foo", "ClassA::foo is not confused with ClassB::foo"); is( ClassB->foo, 'Role::Foo::foo', 'ClassB::foo knows its name' ); is( ClassA->foo, 'Role::Foo::foo', 'ClassA::foo knows its name' ); Role-Basic-0.16/t/moose/033_role_exclusion_and_alias_bug.t000444000765000024 341714755276471 23012 0ustar00ovidstaff000000000000#!/usr/bin/perl use strict; use warnings; use lib 'lib', 't/lib'; use MyTests tests => 17; { package My::Role; use Role::Basic; sub foo { "FOO" } sub bar { "BAR" } } { package My::Class; use Role::Basic 'with'; sub new { bless {} => shift } with 'My::Role' => { -rename => { foo => 'baz', bar => 'gorch' }, }; } { my $x = My::Class->new; isa_ok($x, 'My::Class'); ok $x->DOES('My::Role'), 'My::Class should do My::Role'; can_ok($x, $_) for qw[baz gorch]; ok(!$x->can($_), '... cant call method ' . $_) for qw[foo bar]; is($x->baz, 'FOO', '... got the right value'); is($x->gorch, 'BAR', '... got the right value'); } { package My::Role::Again; use Role::Basic; with 'My::Role' => { -rename => { foo => 'baz', bar => 'gorch' }, }; package My::Class::Again; use Role::Basic 'with'; sub new { bless {} => shift } sub foo {} sub bar {} with 'My::Role::Again'; } { my $x = My::Class::Again->new; isa_ok($x, 'My::Class::Again'); ok $x->DOES('My::Role::Again'), 'My::Class::Again should do My::Role::Again'; ok $x->DOES('My::Role'), 'My::Class::Again should do My::Role'; can_ok($x, $_) for qw[baz gorch]; # XXX [!Moose] We use -rename above. This is a combination of -alias and # -excludes. Because -excludes adds the methods to requirements, they now # much be provided. This guarantess that if a class responds to # $class->DOES($role), you can guarantee that methods of the same name as # $role methods will exist, even if you can't guarantee that they'll be # the same methods. ok($x->can($_), '... cant call method ' . $_) for qw[foo bar]; is($x->baz, 'FOO', '... got the right value'); is($x->gorch, 'BAR', '... got the right value'); } Role-Basic-0.16/t/moose/043_conflict_many_methods.t000444000765000024 226414755276471 21500 0ustar00ovidstaff000000000000#!/usr/bin/perl use strict; use warnings; use lib 'lib', 't/lib'; use MyTests tests => 3; { package Bomb; use Role::Basic; sub fuse { } sub explode { } package Spouse; use Role::Basic; sub fuse { } sub explode { } package Caninish; use Role::Basic; sub bark { } package Treeve; use Role::Basic; sub bark { } } { package PracticalJoke; use Role::Basic 'with'; my $exception = ::exception { with 'Bomb', 'Spouse' }; ::like( $exception, qr/Due to a method name conflict in roles 'Bomb' and 'Spouse', the method 'fuse' must be implemented or excluded by 'PracticalJoke'/ ); ::like $exception, qr/Due to a method name conflict in roles 'Bomb' and 'Spouse', the method 'explode' must be implemented or excluded by 'PracticalJoke'/, '... and all methods will be listed in the exception'; package PracticalJoke2; use Role::Basic 'with'; ::like( ::exception { with ( 'Bomb', 'Spouse', 'Caninish', 'Treeve', ); }, qr/Due to a method name conflict in roles 'Caninish' and 'Treeve', the method 'bark' must be implemented or excluded by 'PracticalJoke2'/ ); } Role-Basic-0.16/xt000755000765000024 014755276471 13262 5ustar00ovidstaff000000000000Role-Basic-0.16/xt/manifest.t000444000765000024 42014755276471 15366 0ustar00ovidstaff000000000000#!perl -T use strict; use warnings; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } eval "use Test::CheckManifest 0.9"; plan skip_all => "Test::CheckManifest 0.9 required" if $@; ok_manifest(); Role-Basic-0.16/xt/pod-coverage.t000444000765000024 104714755276471 16161 0ustar00ovidstaff000000000000use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); Role-Basic-0.16/xt/pod.t000444000765000024 35014755276471 14344 0ustar00ovidstaff000000000000#!perl -T use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok();