+++ /dev/null
-
-package Moose::Meta::Role;
-
-use strict;
-use warnings;
-use metaclass;
-
-use Carp 'confess';
-use Scalar::Util 'blessed', 'reftype';
-use Sub::Name 'subname';
-use B 'svref_2object';
-
-our $VERSION = '0.01';
-
-Moose::Meta::Role->meta->add_attribute('$:package' => (
- reader => 'name',
- init_arg => ':package',
-));
-
-Moose::Meta::Role->meta->add_attribute('@:requires' => (
- reader => 'requires',
- predicate => 'has_requires',
- init_arg => ':requires',
- default => sub { [] }
-));
-
-{
- my %ROLES;
- sub initialize {
- my ($class, %options) = @_;
- my $pkg = $options{':package'};
- $ROLES{$pkg} ||= $class->meta->new_object(%options);
- }
-}
-
-sub add_method {
- my ($self, $method_name, $method) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
- # use reftype here to allow for blessed subs ...
- ('CODE' eq (reftype($method) || ''))
- || confess "Your code block must be a CODE reference";
- my $full_method_name = ($self->name . '::' . $method_name);
-
- no strict 'refs';
- no warnings 'redefine';
- *{$full_method_name} = subname $full_method_name => $method;
-}
-
-sub alias_method {
- my ($self, $method_name, $method) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
- # use reftype here to allow for blessed subs ...
- ('CODE' eq (reftype($method) || ''))
- || confess "Your code block must be a CODE reference";
- my $full_method_name = ($self->name . '::' . $method_name);
-
- no strict 'refs';
- no warnings 'redefine';
- *{$full_method_name} = $method;
-}
-
-sub has_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- my $sub_name = ($self->name . '::' . $method_name);
-
- no strict 'refs';
- return 0 if !defined(&{$sub_name});
- my $method = \&{$sub_name};
- return 0 if (svref_2object($method)->GV->STASH->NAME || '') ne $self->name &&
- (svref_2object($method)->GV->NAME || '') ne '__ANON__';
- return 1;
-}
-
-sub get_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- return unless $self->has_method($method_name);
-
- no strict 'refs';
- return \&{$self->name . '::' . $method_name};
-}
-
-sub remove_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- my $removed_method = $self->get_method($method_name);
-
- no strict 'refs';
- delete ${$self->name . '::'}{$method_name}
- if defined $removed_method;
-
- return $removed_method;
-}
-
-sub get_method_list {
- my $self = shift;
- no strict 'refs';
- grep { !/meta/ && $self->has_method($_) } %{$self->name . '::'};
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-Moose::Meta::Role - The Moose role metaobject
-
-=head1 SYNOPSIS
-
-=head1 DESCRIPTION
-
-=head1 METHODS
-
-=over 4
-
-=back
-
-=head1 BUGS
-
-All complex software has bugs lurking in it, and this module is no
-exception. If you find a bug please either email me, or add the bug
-to cpan-RT.
-
-=head1 AUTHOR
-
-Stevan Little E<lt>stevan@iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
\ No newline at end of file
+++ /dev/null
-
-package Moose::Meta::SafeMixin;
-
-use strict;
-use warnings;
-
-use Scalar::Util 'blessed';
-use Carp 'confess';
-
-our $VERSION = '0.01';
-
-use base 'Class::MOP::Class';
-
-Moose::Meta::SafeMixin->meta->add_attribute('mixed_in' => (
- accessor => 'mixed_in',
- default => sub { [] }
-));
-
-sub mixin {
- # fetch the metaclass for the
- # caller and the mixin arg
- my $metaclass = shift;
- my $mixin = $metaclass->initialize(shift);
-
- # according to Scala, the
- # the superclass of our class
- # must be a subclass of the
- # superclass of the mixin (see above)
- my ($super_meta) = $metaclass->superclasses();
- my ($super_mixin) = $mixin->superclasses();
- ($super_meta->isa($super_mixin))
- || confess "The superclass ($super_meta) must extend a subclass of the " .
- "superclass of the mixin ($super_mixin)"
- if defined $super_mixin && defined $super_meta;
-
- # check for conflicts here ...
-
- $metaclass->has_attribute($_)
- && confess "Attribute conflict ($_)"
- foreach $mixin->get_attribute_list;
-
- foreach my $method_name ($mixin->get_method_list) {
- # skip meta, cause everyone has that :)
- next if $method_name =~ /meta/;
- $metaclass->has_method($method_name) && confess "Method conflict ($method_name)";
- }
-
- # collect all the attributes
- # and clone them so they can
- # associate with the new class
- # add all the attributes in ....
- foreach my $attr ($mixin->get_attribute_list) {
- $metaclass->add_attribute(
- $mixin->get_attribute($attr)->clone()
- );
- }
-
- # add all the methods in ....
- foreach my $method_name ($mixin->get_method_list) {
- # no need to mess with meta
- next if $method_name eq 'meta';
- my $method = $mixin->get_method($method_name);
- # and ignore accessors, the
- # attributes take care of that
- next if blessed($method) && $method->isa('Class::MOP::Attribute::Accessor');
- $metaclass->alias_method($method_name => $method);
- }
-
- push @{$metaclass->mixed_in} => $mixin
- unless $metaclass->name eq 'Moose::Meta::Class';
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-Moose::Meta::SafeMixin - A meta-object for safe mixin-style composition
-
-=head1 SYNOPSIS
-
-=head1 DESCRIPTION
-
-This is a meta-object which provides B<safe> mixin-style composition
-of classes. The key word here is "safe" because we enforce a number
-of rules about mixing in which prevent some of the instability
-inherent in other mixin systems. However, it should be noted that we
-still allow you enough rope with which to shoot yourself in the foot
-if you so desire.
-
-=over 4
-
-=item *
-
-In order to mix classes together, they must inherit from a common
-superclass. This assures at least some level of similarity between
-the classes being mixed together, which should result in a more
-stable end product.
-
-The only exception to this rule is if the class being mixed in has
-no superclasses at all. In this case we assume the mixin is valid.
-
-=item *
-
-Since we enforce a common ancestral relationship, we need to be
-mindful of method and attribute conflicts. The common ancestor
-increases the potential of method conflicts because it is common
-for subclasses to override their parents methods. However, it is
-less common for attributes to be overriden. The way these are
-resolved is to use a Trait/Role-style conflict mechanism.
-
-If two classes are mixed together, any method or attribute conflicts
-will result in a failure of the mixin and a fatal exception. It is
-not possible to resolve a method or attribute conflict dynamically.
-This is because to do so would open the possibility of breaking
-classes in very subtle and dangerous ways, particularly in the area
-of method interdependencies. The amount of implementation knowledge
-which would need to be known by the mixee would (IMO) increase the
-complexity of the feature exponentially for each class mixed in.
-
-However fear not, there is a solution (see below) ...
-
-=item *
-
-Safe mixin's offer the possibility of CLOS style I<before>, I<after>
-and I<around> methods with which method conflicts can be resolved.
-
-A method, which would normally conflict, but which is labeled with
-either a I<before>, I<after> or I<around> attribute, will instead be
-combined with the original method in the way implied by the attribute.
-
-The result of this is a generalized event-handling system for classes.
-Which can be used to create things more specialized, such as plugins
-and decorators.
-
-=back
-
-=head2 What kinda crack are you on ?!?!?!?
-
-This approach may seem crazy, but I am fairly confident that it will
-work, and that it will not tie your hands unnessecarily. All these
-features have been used with certain degrees of success in the object
-systems of other languages, but none (IMO) provided a complete
-solution.
-
-In CLOS, I<before>, I<after> and I<around> methods provide a high
-degree of flexibility for adding behavior to methods, but do not address
-any concerns regarding classes since in CLOS, classes and methods are
-separate components of the system.
-
-In Scala, mixins are restricted by their ancestral relationships, which
-results in a need to have seperate "traits" to get around this restriction.
-In addition, Scala does not seem to have any means of method conflict
-resolution for mixins (at least not that I can find).
-
-In Perl 6, the role system forces manual disambiguation which (as
-mentioned above) can cause issues with method interdependecies when
-composing roles together. This problem will grow exponentially in one
-direction with each role composed and in the other direction with the
-number of roles that role itself is composed of. The result is that the
-complexity of the system becomes unmanagable for all but very simple or
-very shallow roles. Now, this is not to say that roles are unusable, in
-fact, this feature (IMO) promotes good useage of roles by keeping them
-both small and simple. But, the same behaviors cannot be applied to
-class mixins without hitting these barriers all too quickly.
-
-The same too can be said of the original Traits system, with its
-features for aliasing and exclusion of methods.
-
-So after close study of these systems, and in some cases actually
-implementing said systems, I have come to the see that each on it's
-own is not robust enough and that combining the best parts of each
-gives us (what I hope is) a better, safer and saner system.
-
-=head1 METHODS
-
-=over 4
-
-=item B<mixin ($mixin)>
-
-=item B<mixed_in>
-
-Accessor for the cache of mixed-in classes
-
-=back
-
-=head1 AUTHOR
-
-Stevan Little E<lt>stevan@iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
+++ /dev/null
-
-package Moose::Role;
-
-use strict;
-use warnings;
-
-use Carp 'confess';
-use Scalar::Util 'blessed';
-use Sub::Name 'subname';
-
-our $VERSION = '0.01';
-
-use Moose::Meta::Role;
-use Moose::Util::TypeConstraints;
-
-sub import {
- shift;
- my $pkg = caller();
-
- # we should never export to main
- return if $pkg eq 'main';
-
- Moose::Util::TypeConstraints->import($pkg);
-
- my $meta;
- if ($pkg->can('meta')) {
- $meta = $pkg->meta();
- (blessed($meta) && $meta->isa('Moose::Meta::Role'))
- || confess "Whoops, not møøsey enough";
- }
- else {
- $meta = Moose::Meta::Role->initialize(':package' => $pkg);
- $meta->add_method('meta' => sub {
- # re-initialize so it inherits properly
- Moose::Meta::Role->initialize(':package' => $pkg);
- })
- }
-
- # NOTE:
- # &alias_method will install the method, but it
- # will not name it with
- $meta->alias_method('requires' => subname 'Moose::Role::requires' => sub {
- push @{$meta->requires} => @_;
- });
-
-
- # make sure they inherit from Moose::Role::Base
- {
- no strict 'refs';
- @{$meta->name . '::ISA'} = ('Moose::Role::Base');
- }
-
- # we recommend using these things
- # so export them for them
- $meta->alias_method('confess' => \&Carp::confess);
- $meta->alias_method('blessed' => \&Scalar::Util::blessed);
-}
-
-package Moose::Role::Base;
-
-use strict;
-use warnings;
-
-our $VERSION = '0.01';
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-Moose::Role - The Moose role
-
-=head1 SYNOPSIS
-
-=head1 DESCRIPTION
-
-=head1 METHODS
-
-=over 4
-
-=back
-
-=head1 BUGS
-
-All complex software has bugs lurking in it, and this module is no
-exception. If you find a bug please either email me, or add the bug
-to cpan-RT.
-
-=head1 AUTHOR
-
-Stevan Little E<lt>stevan@iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
\ No newline at end of file
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 21;
-
-BEGIN {
- use_ok('Moose');
-}
-
-## Mixin a class without a superclass.
-{
- package FooMixin;
- use Moose;
- sub foo { 'FooMixin::foo' }
-
- package Foo;
- use Moose;
- with 'FooMixin';
-}
-
-my $foo = Foo->new();
-isa_ok($foo, 'Foo');
-
-can_ok($foo, 'foo');
-is($foo->foo, 'FooMixin::foo', '... got the right value from the mixin method');
-
-is_deeply(
- [ sort map { $_->name } @{Foo->meta->mixed_in} ],
- [ 'FooMixin' ],
- '... got the right mixin list');
-
-## Mixin a class who shares a common ancestor
-{
- package Baz;
- use Moose;
- extends 'Foo';
-
- sub baz { 'Baz::baz' }
-
- package Bar;
- use Moose;
- extends 'Foo';
-
- package Foo::Baz;
- use Moose;
- extends 'Foo';
- eval { with 'Baz' };
- ::ok(!$@, '... the classes superclass must extend a subclass of the superclass of the mixins');
-
-}
-
-my $foo_baz = Foo::Baz->new();
-isa_ok($foo_baz, 'Foo::Baz');
-isa_ok($foo_baz, 'Foo');
-
-can_ok($foo_baz, 'baz');
-is($foo_baz->baz(), 'Baz::baz', '... got the right value from the mixin method');
-
-is_deeply(
- [ sort map { $_->name } @{Baz->meta->mixed_in} ],
- [],
- '... got the right mixin list');
-
-is_deeply(
- [ sort map { $_->name } @{Bar->meta->mixed_in} ],
- [],
- '... got the right mixin list');
-
-is_deeply(
- [ sort map { $_->name } @{Foo::Baz->meta->mixed_in} ],
- [ 'Baz' ],
- '... got the right mixin list');
-
-{
- package Foo::Bar;
- use Moose;
- extends 'Foo', 'Bar';
-
- package Foo::Bar::Baz;
- use Moose;
- extends 'Foo::Bar';
- eval { with 'Baz' };
- ::ok(!$@, '... the classes superclass must extend a subclass of the superclass of the mixins');
-}
-
-my $foo_bar_baz = Foo::Bar::Baz->new();
-isa_ok($foo_bar_baz, 'Foo::Bar::Baz');
-isa_ok($foo_bar_baz, 'Foo::Bar');
-isa_ok($foo_bar_baz, 'Foo');
-isa_ok($foo_bar_baz, 'Bar');
-
-can_ok($foo_bar_baz, 'baz');
-is($foo_bar_baz->baz(), 'Baz::baz', '... got the right value from the mixin method');
-
-is_deeply(
- [ sort map { $_->name } @{Foo::Bar::Baz->meta->mixed_in} ],
- [ 'Baz' ],
- '... got the right mixin list');
-
\ No newline at end of file
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 5;
-use SUPER;
-
-BEGIN {
- use_ok('Moose');
-}
-
-=pod
-
-This test demonstrates how simple it is to create Scala Style
-Class Mixin Composition. Below is an example taken from the
-Scala web site's example section, and trancoded to Moose.
-
-L<http://scala.epfl.ch/intro/mixin.html>
-
-A class can only be used as a mixin in the definition of another
-class, if this other class extends a subclass of the superclass
-of the mixin. Since ColoredPoint3D extends Point3D and Point3D
-extends Point2D which is the superclass of ColoredPoint2D, the
-code above is well-formed.
-
- class Point2D(xc: Int, yc: Int) {
- val x = xc;
- val y = yc;
- override def toString() = "x = " + x + ", y = " + y;
- }
-
- class ColoredPoint2D(u: Int, v: Int, c: String) extends Point2D(u, v) {
- val color = c;
- def setColor(newCol: String): Unit = color = newCol;
- override def toString() = super.toString() + ", col = " + color;
- }
-
- class Point3D(xc: Int, yc: Int, zc: Int) extends Point2D(xc, yc) {
- val z = zc;
- override def toString() = super.toString() + ", z = " + z;
- }
-
- class ColoredPoint3D(xc: Int, yc: Int, zc: Int, col: String)
- extends Point3D(xc, yc, zc)
- with ColoredPoint2D(xc, yc, col);
-
-
- Console.println(new ColoredPoint3D(1, 2, 3, "blue").toString())
-
- "x = 1, y = 2, z = 3, col = blue"
-
-=cut
-
-{
- package Point2D;
- use Moose;
-
- has 'x' => (is => 'rw');
- has 'y' => (is => 'rw');
-
- sub to_string {
- my $self = shift;
- "x = " . $self->x . ", y = " . $self->y;
- }
-
- package ColoredPoint2D;
- use Moose;
-
- extends 'Point2D';
-
- has 'color' => (is => 'rw');
-
- sub to_string {
- my $self = shift;
- $self->SUPER . ', col = ' . $self->color;
- }
-
- package Point3D;
- use Moose;
-
- extends 'Point2D';
-
- has 'z' => (is => 'rw');
-
- sub to_string {
- my $self = shift;
- $self->SUPER . ', z = ' . $self->z;
- }
-
- package ColoredPoint3D;
- use Moose;
-
- extends 'Point3D';
- with 'ColoredPoint2D';
-
-}
-
-my $colored_point_3d = ColoredPoint3D->new(x => 1, y => 2, z => 3, color => 'blue');
-isa_ok($colored_point_3d, 'ColoredPoint3D');
-isa_ok($colored_point_3d, 'Point3D');
-isa_ok($colored_point_3d, 'Point2D');
-
-is($colored_point_3d->to_string(),
- 'x = 1, y = 2, z = 3, col = blue',
- '... got the right toString method');
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 5;
-
-BEGIN {
- use_ok('Moose');
-}
-
-{
- package Eq;
- use strict;
- use warnings;
- use Moose::Role;
-
- requires 'equal';
-
- sub not_equal {
- my ($self, $other) = @_;
- !$self->equal($other);
- }
-}
-
-isa_ok(Eq->meta, 'Moose::Meta::Role');
-ok(Eq->isa('Moose::Role::Base'), '... Eq is a role');
-
-is_deeply(
- Eq->meta->requires,
- [ 'equal' ],
- '... got the right required method');
-
-is_deeply(
- [ sort Eq->meta->get_method_list ],
- [ 'not_equal' ],
- '... got the right method list');
-
projects / gitmo/Moose.git / commitdiff