Revision history for Mouse
+0.32
+
+
0.31 Tue Sep 22 11:08:12 2009
* Add find_meta() and does_role() to Mouse::Util (gfx)
use Mouse::Meta::Attribute;
use Mouse::Meta::Module;
use Mouse::Meta::Class;
+use Mouse::Meta::Role;
use Mouse::Object;
use Mouse::Util::TypeConstraints;
\@{ $args{package} . '::ISA' };
};
- bless \%args, $class;
+ #return Mouse::Meta::Class->initialize($class)->new_object(%args)
+ # if $class ne __PACKAGE__;
+
+ return bless \%args, $class;
+}
+
+sub create_anon_class{
+ my $self = shift;
+ return $self->create(undef, @_);
+}
+
+sub is_anon_class{
+ return exists $_[0]->{anon_serial_id};
}
sub roles { $_[0]->{roles} }
if (@_ == 1 && blessed($_[0])) {
my $attr = shift @_;
$self->{'attributes'}{$attr->name} = $attr;
- } else {
+ }
+ else {
my $names = shift @_;
$names = [$names] if !ref($names);
my $metaclass = 'Mouse::Meta::Attribute';
- my %options = @_;
+ my %options = (@_ == 1 ? %{$_[0]} : @_);
if ( my $metaclass_name = delete $options{metaclass} ) {
my $new_class = Mouse::Util::resolve_metaclass_alias(
for my $name (@$names) {
if ($name =~ s/^\+//) {
- $metaclass->clone_parent($self, $name, @_);
+ $metaclass->clone_parent($self, $name, %options);
}
else {
- $metaclass->create($self, $name, @_);
+ $metaclass->create($self, $name, %options);
}
}
}
sub new_object {
my $self = shift;
- my $args = (@_ == 1) ? $_[0] : { @_ };
+ my %args = (@_ == 1 ? %{$_[0]} : @_);
my $instance = bless {}, $self->name;
my $from = $attribute->init_arg;
my $key = $attribute->name;
- if (defined($from) && exists($args->{$from})) {
- $args->{$from} = $attribute->coerce_constraint($args->{$from})
+ if (defined($from) && exists($args{$from})) {
+ $args{$from} = $attribute->coerce_constraint($args{$from})
if $attribute->should_coerce;
- $attribute->verify_against_type_constraint($args->{$from});
+ $attribute->verify_against_type_constraint($args{$from});
- $instance->{$key} = $args->{$from};
+ $instance->{$key} = $args{$from};
weaken($instance->{$key})
if ref($instance->{$key}) && $attribute->is_weak_ref;
if ($attribute->has_trigger) {
- $attribute->trigger->($instance, $args->{$from});
+ $attribute->trigger->($instance, $args{$from});
}
}
else {
return 0;
}
-sub create {
- my ($class, $package_name, %options) = @_;
-
- (ref $options{superclasses} eq 'ARRAY')
- || $class->throw_error("You must pass an ARRAY ref of superclasses")
- if exists $options{superclasses};
-
- (ref $options{attributes} eq 'ARRAY')
- || $class->throw_error("You must pass an ARRAY ref of attributes")
- if exists $options{attributes};
-
- (ref $options{methods} eq 'HASH')
- || $class->throw_error("You must pass a HASH ref of methods")
- if exists $options{methods};
-
- (ref $options{roles} eq 'ARRAY')
- || $class->throw_error("You must pass an ARRAY ref of roles")
- if exists $options{roles};
-
- # instantiate a module
- {
- ( defined $package_name && $package_name )
- || $class->throw_error("You must pass a package name");
-
- no strict 'refs';
- ${ $package_name . '::VERSION' } = $options{version} if exists $options{version};
- ${ $package_name . '::AUTHORITY' } = $options{authority} if exists $options{authority};
- }
-
- my %initialize_options = %options;
- delete @initialize_options{qw(
- package
- superclasses
- attributes
- methods
- roles
- version
- authority
- )};
- my $meta = $class->initialize( $package_name => %initialize_options );
-
- # FIXME totally lame
- $meta->add_method('meta' => sub {
- Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
- });
-
- $meta->superclasses(@{$options{superclasses}})
- if exists $options{superclasses};
-
- # NOTE:
- # process attributes first, so that they can
- # install accessors, but locally defined methods
- # can then overwrite them. It is maybe a little odd, but
- # I think this should be the order of things.
- if (exists $options{attributes}) {
- foreach my $attr (@{$options{attributes}}) {
- Mouse::Meta::Attribute->create($meta, $attr->{name}, %$attr);
- }
- }
- if (exists $options{methods}) {
- foreach my $method_name (keys %{$options{methods}}) {
- $meta->add_method($method_name, $options{methods}->{$method_name});
- }
- }
- if (exists $options{roles}){
- Mouse::Util::apply_all_roles($package_name, @{$options{roles}});
- }
- return $meta;
-}
-
-{
- my $ANON_CLASS_SERIAL = 0;
- my $ANON_CLASS_PREFIX = 'Mouse::Meta::Class::__ANON__::SERIAL::';
-
- my %IMMORTAL_ANON_CLASSES;
- sub create_anon_class {
- my ( $class, %options ) = @_;
-
- my $cache = $options{cache};
- my $cache_key;
-
- if($cache){ # anonymous but not mortal
- # something like Super::Class|Super::Class::2=Role|Role::1\r
- $cache_key = join '=' => (\r
- join('|', @{$options{superclasses} || []}),\r
- join('|', sort @{$options{roles} || []}),\r
- );
- return $IMMORTAL_ANON_CLASSES{$cache_key} if exists $IMMORTAL_ANON_CLASSES{$cache_key};
- }
- my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
- my $meta = $class->create( $package_name, anon_class_id => $ANON_CLASS_SERIAL, %options );
-
- if($cache){
- $IMMORTAL_ANON_CLASSES{$cache_key} = $meta;
- }
- else{
- Mouse::Meta::Module::weaken_metaclass($package_name);
- }
- return $meta;
- }
-
- sub is_anon_class{
- return exists $_[0]->{anon_class_id};
- }
-
-
- sub DESTROY{
- my($self) = @_;
-
- my $serial_id = $self->{anon_class_id};
-
- return if !$serial_id;
-
- my $stash = $self->namespace;
-
- @{$self->{sperclasses}} = ();
- %{$stash} = ();
- Mouse::Meta::Module::remove_metaclass_by_name($self->name);
-
- no strict 'refs';
- delete ${$ANON_CLASS_PREFIX}{ $serial_id . '::' };
-
- return;
- }
-
-}
-
1;
__END__
use Mouse::Util qw/get_code_info not_supported load_class/;
use Scalar::Util qw/blessed weaken/;
-
{
my %METACLASS_CACHE;
return grep { $self->has_method($_) } keys %{ $self->namespace };\r
}
+{
+ my $ANON_SERIAL = 0;
+ my $ANON_PREFIX = 'Mouse::Meta::Module::__ANON__::';
+
+ my %IMMORTALS;
+
+ sub create {
+ my ($class, $package_name, %options) = @_;
+
+ $class->throw_error('You must pass a package name') if @_ == 1;
+
+
+ if(exists $options{superclasses}){
+ if($class->isa('Mouse::Meta::Class')){
+ (ref $options{superclasses} eq 'ARRAY')
+ || $class->throw_error("You must pass an ARRAY ref of superclasses");
+ }
+ else{ # role
+ delete $options{superclasses};
+ }
+ }
+
+ my $attributes;
+ if(exists $options{attributes}){
+ $attributes = delete $options{attributes};
+ (ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH')
+ || $class->throw_error("You must pass an ARRAY ref of attributes")
+ }
+
+ (ref $options{methods} eq 'HASH')
+ || $class->throw_error("You must pass a HASH ref of methods")
+ if exists $options{methods};
+
+ (ref $options{roles} eq 'ARRAY')
+ || $class->throw_error("You must pass an ARRAY ref of roles")
+ if exists $options{roles};
+
+
+ my @extra_options;
+ my $mortal;
+ my $cache_key;
+
+ if(!defined $package_name){ # anonymous
+ $mortal = !$options{cache};
+
+ # anonymous but immortal
+ if(!$mortal){
+ # something like Super::Class|Super::Class::2=Role|Role::1\r
+ $cache_key = join '=' => (\r
+ join('|', @{$options{superclasses} || []}),\r
+ join('|', sort @{$options{roles} || []}),\r
+ );
+ return $IMMORTALS{$cache_key} if exists $IMMORTALS{$cache_key};
+ }
+ $package_name = $ANON_PREFIX . ++$ANON_SERIAL;
+
+ push @extra_options, (anon_serial_id => $ANON_SERIAL);
+ }
+
+ # instantiate a module
+ {
+ no strict 'refs';
+ ${ $package_name . '::VERSION' } = delete $options{version} if exists $options{version};
+ ${ $package_name . '::AUTHORITY' } = delete $options{authority} if exists $options{authority};
+ }
+
+ my %initialize_options = %options;
+ delete @initialize_options{qw(
+ package
+ superclasses
+ attributes
+ methods
+ roles
+ )};
+ my $meta = $class->initialize( $package_name, %initialize_options, @extra_options);
+
+ Mouse::Meta::Module::weaken_metaclass($package_name)
+ if $mortal;
+
+ # FIXME totally lame
+ $meta->add_method('meta' => sub {
+ $class->initialize(ref($_[0]) || $_[0]);
+ });
+
+ $meta->superclasses(@{$options{superclasses}})
+ if exists $options{superclasses};
+
+ # NOTE:
+ # process attributes first, so that they can
+ # install accessors, but locally defined methods
+ # can then overwrite them. It is maybe a little odd, but
+ # I think this should be the order of things.
+ if (defined $attributes) {
+ if(ref($attributes) eq 'ARRAY'){
+ foreach my $attr (@{$attributes}) {
+ $meta->add_attribute($attr->{name} => $attr);
+ }
+ }
+ else{
+ while(my($name, $attr) = each %{$attributes}){
+ $meta->add_attribute($name => $attr);
+ }
+ }
+ }
+ if (exists $options{methods}) {
+ foreach my $method_name (keys %{$options{methods}}) {
+ $meta->add_method($method_name, $options{methods}->{$method_name});
+ }
+ }
+ if (exists $options{roles}){
+ Mouse::Util::apply_all_roles($package_name, @{$options{roles}});
+ }
+
+ if(!$mortal && exists $meta->{anon_serial_id}){
+ $IMMORTALS{$cache_key} = $meta;
+ }
+
+ return $meta;
+ }
+
+ sub DESTROY{
+ my($self) = @_;
+
+ my $serial_id = $self->{anon_serial_id};
+
+ return if !$serial_id;
+
+ my $stash = $self->namespace;
+
+ @{$self->{superclasses}} = () if exists $self->{superclasses};
+ %{$stash} = ();
+ Mouse::Meta::Module::remove_metaclass_by_name($self->name);
+
+ no strict 'refs';
+ delete ${$ANON_PREFIX}{ $serial_id . '::' };
+
+ return;
+ }
+}
+
sub throw_error{
my($class, $message, %args) = @_;
sub _new {
my $class = shift;
+
my %args = @_;
$args{methods} ||= {};
$args{required_methods} ||= [];
$args{roles} ||= [];
- bless \%args, $class;
+# return Mouse::Meta::Class->initialize($class)->new_object(%args)
+# if $class ne __PACKAGE__;
+
+ return bless \%args, $class;
+}
+
+sub create_anon_role{
+ my $self = shift;
+ return $self->create(undef, @_);
+}
+
+sub is_anon_role{
+ return exists $_[0]->{anon_serial_id};
}
sub get_roles { $_[0]->{roles} }
$self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ };
}
+sub _canonicalize_apply_args{
+ my($self, $applicant, %args) = @_;
+
+ if($applicant->isa('Mouse::Meta::Class')){
+ $args{_to} = 'class';
+ }
+ elsif($applicant->isa('Mouse::Meta::Role')){
+ $args{_to} = 'role';
+ }
+ else{
+ $args{_to} = 'instance';
+
+ not_supported 'Application::ToInstance';
+ }
+
+ if($args{alias} && !exists $args{-alias}){
+ $args{-alias} = $args{alias};
+ }
+ if($args{excludes} && !exists $args{-excludes}){
+ $args{-excludes} = $args{excludes};
+ }
+
+ if(my $excludes = $args{-excludes}){
+ $args{-excludes} = {}; # replace with a hash ref
+ if(ref $excludes){
+ %{$args{-excludes}} = (map{ $_ => undef } @{$excludes});
+ }
+ else{
+ $args{-excludes}{$excludes} = undef;
+ }
+ }
+
+ return \%args;
+}
+
sub _check_required_methods{
my($role, $class, $args, @other_roles) = @_;
- if($class->isa('Mouse::Meta::Class')){
+ if($args->{_to} eq 'class'){
my $class_name = $class->name;
+ my $role_name = $role->name;
+ my @missing;
foreach my $method_name(@{$role->{required_methods}}){
- unless($class_name->can($method_name)){
- my $role_name = $role->name;
+ if(!$class_name->can($method_name)){
my $has_method = 0;
foreach my $another_role_spec(@other_roles){
last;
}
}
-
- $role->throw_error("'$role_name' requires the method '$method_name' to be implemented by '$class_name'")
- unless $has_method;
+
+ push @missing, $method_name if !$has_method;
}
}
+ if(@missing){
+ $class->throw_error("'$role_name' requires the "
+ . (@missing == 1 ? 'method' : 'methods')
+ . " "
+ . english_list(map{ sprintf q{'%s'}, $_ } @missing)
+ . " to be implemented by '$class_name'");
+ }
+ }
+ elsif($args->{_to} eq 'role'){
+ # apply role($role) to role($class)
+ foreach my $method_name($role->get_required_method_list){
+ next if $class->has_method($method_name); # already has it
+ $class->add_required_methods($method_name);
+ }
}
return;
my $role_name = $role->name;
my $class_name = $class->name;
- my $alias = (exists $args->{alias} && !exists $args->{-alias}) ? $args->{alias} : $args->{-alias};
- my $excludes = (exists $args->{excludes} && !exists $args->{-excludes}) ? $args->{excludes} : $args->{-excludes};
-
- my %exclude_map;
-
- if(defined $excludes){
- if(ref $excludes){
- %exclude_map = map{ $_ => undef } @{$excludes};
- }
- else{
- $exclude_map{$excludes} = undef;
- }
- }
+ my $alias = $args->{-alias};
+ my $excludes = $args->{-excludes};
foreach my $method_name($role->get_method_list){
next if $method_name eq 'meta';
my $code = $role_name->can($method_name);
- if(!exists $exclude_map{$method_name}){
+ if(!exists $excludes->{$method_name}){
if(!$class->has_method($method_name)){
$class->add_method($method_name => $code);
}
if($alias && $alias->{$method_name}){
my $dstname = $alias->{$method_name};
- my $slot = do{ no strict 'refs'; \*{$class_name . '::' . $dstname} };
- if(defined(*{$slot}{CODE}) && *{$slot}{CODE} != $code){
+ my $dstcode = do{ no strict 'refs'; *{$class_name . '::' . $dstname}{CODE} };
+
+ if(defined($dstcode) && $dstcode != $code){
$class->throw_error("Cannot create a method alias if a local method of the same name exists");
}
else{
sub _apply_attributes{
my($role, $class, $args) = @_;
- if ($class->isa('Mouse::Meta::Class')) {
+ if ($args->{_to} eq 'class') {
# apply role to class
for my $attr_name ($role->get_attribute_list) {
next if $class->has_attribute($attr_name);
$attr_metaclass->create($class, $attr_name => %$spec);
}
- } else {
+ }
+ elsif($args->{_to} eq 'role'){
# apply role to role
for my $attr_name ($role->get_attribute_list) {
next if $class->has_attribute($attr_name);
sub _apply_modifiers{
my($role, $class, $args) = @_;
- for my $modifier_type (qw/before after around override/) {
+ for my $modifier_type (qw/override before around after/) {
my $add_modifier = "add_${modifier_type}_method_modifier";
my $modifiers = $role->{"${modifier_type}_method_modifiers"};
sub _append_roles{
my($role, $class, $args) = @_;
- my $roles = $class->isa('Mouse::Meta::Class') ? $class->roles : $class->get_roles;
+ my $roles = ($args->{_to} eq 'class') ? $class->roles : $class->get_roles;
foreach my $r($role, @{$role->get_roles}){
if(!$class->does_role($r->name)){
# Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
sub apply {
- my($self, $class, %args) = @_;
+ my $self = shift;
+ my $applicant = shift;
- if ($class->isa('Mouse::Object')) {
- not_supported 'Application::ToInstance';
- }
+ my $args = $self->_canonicalize_apply_args($applicant, @_);
- $self->_check_required_methods($class, \%args);
- $self->_apply_methods($class, \%args);
- $self->_apply_attributes($class, \%args);
- $self->_apply_modifiers($class, \%args);
- $self->_append_roles($class, \%args);
+ $self->_check_required_methods($applicant, $args);
+ $self->_apply_methods($applicant, $args);
+ $self->_apply_attributes($applicant, $args);
+ $self->_apply_modifiers($applicant, $args);
+ $self->_append_roles($applicant, $args);
return;
}
sub combine_apply {
my(undef, $class, @roles) = @_;
+ if($class->isa('Mouse::Object')){
+ not_supported 'Application::ToInstance';
+ }
+
# check conflicting
my %method_provided;
my @method_conflicts;
my $role = $role_name->meta;
+ $args = $role->_canonicalize_apply_args($class, %{$args});
+
$role->_check_required_methods($class, $args, @roles);
$role->_apply_methods($class, $args);
$role->_apply_attributes($class, $args);
# Moose::Util compatible utilities
sub find_meta{
- return Mouse::Module::class_of( $_[0] );
+ return Mouse::Meta::Module::class_of( $_[0] );
}
sub does_role{
my ($class_or_obj, $role) = @_;\r
\r
- my $meta = Mouse::Module::class_of($class_or_obj);\r
+ my $meta = Mouse::Meta::Module::class_of($class_or_obj);\r
\r
return 0 unless defined $meta;\r
return 1 if $meta->does_role($role);\r
}
sub subtype {
- my $pkg = caller(0);
- my($name, %conf) = @_;
+ my $pkg = caller;
+
+ my $name;
+ my %conf;
+
+ if(@_ % 2){ # odd number of arguments
+ $name = shift;
+ %conf = @_;
+ }
+ else{
+ %conf = @_;
+ $name = $conf{name} || '__ANON__';
+ }
+
if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
};
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+use Test::Exception;
+
+
+
+{
+
+ package Foo::Role;
+ use Mouse::Role;
+
+ requires 'foo';
+}
+
+is_deeply(
+ [ sort Foo::Role->meta->get_required_method_list ],
+ ['foo'],
+ '... the Foo::Role has a required method (foo)'
+);
+
+# classes which does not implement required method
+{
+
+ package Foo::Class;
+ use Mouse;
+
+ ::dies_ok { with('Foo::Role') }
+ '... no foo method implemented by Foo::Class';
+}
+
+# class which does implement required method
+{
+
+ package Bar::Class;
+ use Mouse;
+
+ ::dies_ok { with('Foo::Class') }
+ '... cannot consume a class, it must be a role';
+ ::lives_ok { with('Foo::Role') }
+ '... has a foo method implemented by Bar::Class';
+
+ sub foo {'Bar::Class::foo'}
+}
+
+# role which does implement required method
+{
+
+ package Bar::Role;
+ use Mouse::Role;
+
+ ::lives_ok { with('Foo::Role') }
+ '... has a foo method implemented by Bar::Role';
+
+ sub foo {'Bar::Role::foo'}
+}
+
+is_deeply(
+ [ sort Bar::Role->meta->get_required_method_list ],
+ [],
+ '... the Bar::Role has not inherited the required method from Foo::Role'
+);
+
+# role which does not implement required method
+{
+
+ package Baz::Role;
+ use Mouse::Role;
+
+ ::lives_ok { with('Foo::Role') }
+ '... no foo method implemented by Baz::Role';
+}
+
+is_deeply(
+ [ sort Baz::Role->meta->get_required_method_list ],
+ ['foo'],
+ '... the Baz::Role has inherited the required method from Foo::Role'
+);
+
+# classes which does not implement required method
+{
+
+ package Baz::Class;
+ use Mouse;
+
+ ::dies_ok { with('Baz::Role') }
+ '... no foo method implemented by Baz::Class2';
+}
+
+# class which does implement required method
+{
+
+ package Baz::Class2;
+ use Mouse;
+
+ ::lives_ok { with('Baz::Role') }
+ '... has a foo method implemented by Baz::Class2';
+
+ sub foo {'Baz::Class2::foo'}
+}
+
+
+{
+ package Quux::Role;
+ use Mouse::Role;
+
+ requires qw( meth1 meth2 meth3 meth4 );
+}
+
+# RT #41119
+{
+
+ package Quux::Class;
+ use Mouse;
+
+ ::throws_ok { with('Quux::Role') }
+ qr/\Q'Quux::Role' requires the methods 'meth1', 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class'/,
+ 'exception mentions all the missing required methods at once';
+}
+
+{
+ package Quux::Class2;
+ use Mouse;
+
+ sub meth1 { }
+
+ ::throws_ok { with('Quux::Role') }
+ qr/'Quux::Role' requires the methods 'meth2', 'meth3', and '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 Mouse;
+
+ has 'meth1' => ( is => 'ro' );
+ has 'meth2' => ( is => 'ro' );
+
+ ::throws_ok { with('Quux::Role') }
+ qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class3'/,
+ 'exception mentions all the missing methods at once, but not the accessors';
+}
+
+{
+ package Quux::Class4;
+ use Mouse;
+
+ sub meth1 { }
+ has 'meth2' => ( is => 'ro' );
+
+ ::throws_ok { with('Quux::Role') }
+ qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class4'/,
+ 'exception mentions all the require methods that are accessors at once, as well as missing methods, but not the one that exists';
+}
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 4;
+use Mouse ();
+
+my $role = Mouse::Meta::Role->create(
+ 'MyItem::Role::Equipment',
+ attributes => {
+ is_worn => {
+ is => 'rw',
+ isa => 'Bool',
+ },
+ },
+ methods => {
+ remove => sub { shift->is_worn(0) },
+ },
+);
+
+my $class = Mouse::Meta::Class->create('MyItem::Armor::Helmet' =>
+ roles => ['MyItem::Role::Equipment'],
+);
+
+my $visored = $class->new_object(is_worn => 0);
+ok(!$visored->is_worn, "attribute, accessor was consumed");
+$visored->is_worn(1);
+ok($visored->is_worn, "accessor was consumed");
+$visored->remove;
+ok(!$visored->is_worn, "method was consumed");
+
+ok(!$role->is_anon_role, "the role is not anonymous");
+
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 7;
+use Mouse ();
+
+my $role = Mouse::Meta::Role->create_anon_role(
+ attributes => {
+ is_worn => {
+ is => 'rw',
+ isa => 'Bool',
+ },
+ },
+ methods => {
+ remove => sub { shift->is_worn(0) },
+ },
+);
+
+my $class = Mouse::Meta::Class->create('MyItem::Armor::Helmet');
+$role->apply($class);
+# XXX: Mouse::Util::apply_all_roles doesn't cope with references yet
+
+my $visored = $class->new_object(is_worn => 0);
+ok(!$visored->is_worn, "attribute, accessor was consumed");
+$visored->is_worn(1);
+ok($visored->is_worn, "accessor was consumed");
+$visored->remove;
+ok(!$visored->is_worn, "method was consumed");
+
+like($role->name, qr/::__ANON__::/, "the role name (is " . $role->name . ")");
+ok($role->is_anon_role, "the role knows it's anonymous");
+
+ok(Mouse::Util::is_class_loaded(Mouse::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes is_class_loaded");
+ok(Mouse::Util::find_meta(Mouse::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes class_of");
+
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 4;
+use Mouse ();
+use Scalar::Util 'weaken';
+
+my $weak;
+my $name;
+do {
+ my $anon_class;
+
+ do {
+ my $role = Mouse::Meta::Role->create_anon_role(
+ methods => {
+ improperly_freed => sub { 1 },
+ },
+ );
+ weaken($weak = $role);
+
+ $name = $role->name;
+
+ $anon_class = Mouse::Meta::Class->create_anon_class(
+ roles => [ $role->name ],
+ );
+ };
+
+ ok($weak, "we still have the role metaclass because the anonymous class that consumed it is still alive");
+ ok($name->can('improperly_freed'), "we have not blown away the role's symbol table");
+};
+
+ok(!$weak, "the role metaclass is freed after its last reference (from a consuming anonymous class) is freed");
+
+ok(!$name->can('improperly_freed'), "we blew away the role's symbol table entries");
ok(!My::OtherRole->meta->requires_method('foo'), '... and the &foo method is not required');
ok(My::OtherRole->meta->requires_method('bar'), '... and the &bar method is required');
-
+use Data::Dumper; print Dumper(My::OtherRole->meta->{required_methods});
{
package Foo::Role;
use Mouse::Role;
};
my $role = My::Meta::Role->create_anon_role;
+#use Data::Dumper; $Data::Dumper::Deparse = 1; print Dumper $role->can('test_serial');
is($role->test_serial, 1, "default value for the serial attribute");
my $nine_role = My::Meta::Role->create_anon_role(test_serial => 9);
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 20;
+use Test::Exception;
+
+
+
+## Roles
+
+{
+ package Constraint;
+ use Mouse::Role;
+
+ has 'value' => (isa => 'Num', is => 'ro');
+
+ around 'validate' => sub {
+ my $c = shift;
+ my ($self, $field) = @_;
+ return undef if $c->($self, $self->validation_value($field));
+ return $self->error_message;
+ };
+
+ sub validation_value {
+ my ($self, $field) = @_;
+ return $field;
+ }
+
+ sub error_message { confess "Abstract method!" }
+
+ package Constraint::OnLength;
+ use Mouse::Role;
+
+ has 'units' => (isa => 'Str', is => 'ro');
+
+ override 'validation_value' => sub {
+ return length(super());
+ };
+
+ override 'error_message' => sub {
+ my $self = shift;
+ return super() . ' ' . $self->units;
+ };
+
+}
+
+## Classes
+
+{
+ package Constraint::AtLeast;
+ use Mouse;
+
+ with 'Constraint';
+
+ sub validate {
+ my ($self, $field) = @_;
+ ($field >= $self->value);
+ }
+
+ sub error_message { 'must be at least ' . (shift)->value; }
+
+ package Constraint::NoMoreThan;
+ use Mouse;
+
+ with 'Constraint';
+
+ sub validate {
+ my ($self, $field) = @_;
+ ($field <= $self->value);
+ }
+
+ sub error_message { 'must be no more than ' . (shift)->value; }
+
+ package Constraint::LengthNoMoreThan;
+ use Mouse;
+
+ extends 'Constraint::NoMoreThan';
+ with 'Constraint::OnLength';
+
+ package Constraint::LengthAtLeast;
+ use Mouse;
+
+ extends 'Constraint::AtLeast';
+ with 'Constraint::OnLength';
+}
+
+my $no_more_than_10 = Constraint::NoMoreThan->new(value => 10);
+isa_ok($no_more_than_10, 'Constraint::NoMoreThan');
+
+ok($no_more_than_10->does('Constraint'), '... Constraint::NoMoreThan does Constraint');
+
+ok(!defined($no_more_than_10->validate(1)), '... validated correctly');
+is($no_more_than_10->validate(11), 'must be no more than 10', '... validation failed correctly');
+
+my $at_least_10 = Constraint::AtLeast->new(value => 10);
+isa_ok($at_least_10, 'Constraint::AtLeast');
+
+ok($at_least_10->does('Constraint'), '... Constraint::AtLeast does Constraint');
+
+ok(!defined($at_least_10->validate(11)), '... validated correctly');
+is($at_least_10->validate(1), 'must be at least 10', '... validation failed correctly');
+
+# onlength
+
+my $no_more_than_10_chars = Constraint::LengthNoMoreThan->new(value => 10, units => 'chars');
+isa_ok($no_more_than_10_chars, 'Constraint::LengthNoMoreThan');
+isa_ok($no_more_than_10_chars, 'Constraint::NoMoreThan');
+
+ok($no_more_than_10_chars->does('Constraint'), '... Constraint::LengthNoMoreThan does Constraint');
+ok($no_more_than_10_chars->does('Constraint::OnLength'), '... Constraint::LengthNoMoreThan does Constraint::OnLength');
+
+ok(!defined($no_more_than_10_chars->validate('foo')), '... validated correctly');
+is($no_more_than_10_chars->validate('foooooooooo'),
+ 'must be no more than 10 chars',
+ '... validation failed correctly');
+
+my $at_least_10_chars = Constraint::LengthAtLeast->new(value => 10, units => 'chars');
+isa_ok($at_least_10_chars, 'Constraint::LengthAtLeast');
+isa_ok($at_least_10_chars, 'Constraint::AtLeast');
+
+ok($at_least_10_chars->does('Constraint'), '... Constraint::LengthAtLeast does Constraint');
+ok($at_least_10_chars->does('Constraint::OnLength'), '... Constraint::LengthAtLeast does Constraint::OnLength');
+
+ok(!defined($at_least_10_chars->validate('barrrrrrrrr')), '... validated correctly');
+is($at_least_10_chars->validate('bar'), 'must be at least 10 chars', '... validation failed correctly');
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 30;
+use Test::Exception;
+
+sub U {
+ my $f = shift;
+ sub { $f->($f, @_) };
+}
+
+sub Y {
+ my $f = shift;
+ U(sub { my $h = shift; sub { $f->(U($h)->())->(@_) } })->();
+}
+
+{
+ package List;
+ use Mouse::Role;
+
+ has '_list' => (
+ is => 'ro',
+ isa => 'ArrayRef',
+ init_arg => '::',
+ default => sub { [] }
+ );
+
+ sub head { (shift)->_list->[0] }
+ sub tail {
+ my $self = shift;
+ (ref $self)->new(
+ '::' => [
+ @{$self->_list}[1 .. $#{$self->_list}]
+ ]
+ );
+ }
+
+ sub print {
+ join ", " => @{$_[0]->_list};
+ }
+
+ package List::Immutable;
+ use Mouse::Role;
+
+ requires 'head';
+ requires 'tail';
+
+ sub is_empty { not defined ($_[0]->head) }
+
+ sub length {
+ my $self = shift;
+ (::Y(sub {
+ my $redo = shift;
+ sub {
+ my ($list, $acc) = @_;
+ return $acc if $list->is_empty;
+ $redo->($list->tail, $acc + 1);
+ }
+ }))->($self, 0);
+ }
+
+ sub apply {
+ my ($self, $function) = @_;
+ (::Y(sub {
+ my $redo = shift;
+ sub {
+ my ($list, $func, $acc) = @_;
+ return (ref $list)->new('::' => $acc)
+ if $list->is_empty;
+ $redo->(
+ $list->tail,
+ $func,
+ [ @{$acc}, $func->($list->head) ]
+ );
+ }
+ }))->($self, $function, []);
+ }
+
+ package My::List1;
+ use Mouse;
+
+ ::lives_ok {
+ with 'List', 'List::Immutable';
+ } '... successfully composed roles together';
+
+ package My::List2;
+ use Mouse;
+
+ ::lives_ok {
+ with 'List::Immutable', 'List';
+ } '... successfully composed roles together';
+
+}
+
+{
+ my $coll = My::List1->new;
+ isa_ok($coll, 'My::List1');
+
+ ok($coll->does('List'), '... $coll does List');
+ ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
+
+ ok($coll->is_empty, '... we have an empty collection');
+ is($coll->length, 0, '... we have a length of 1 for the collection');
+}
+
+{
+ my $coll = My::List2->new;
+ isa_ok($coll, 'My::List2');
+
+ ok($coll->does('List'), '... $coll does List');
+ ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
+
+ ok($coll->is_empty, '... we have an empty collection');
+ is($coll->length, 0, '... we have a length of 1 for the collection');
+}
+
+{
+ my $coll = My::List1->new('::' => [ 1 .. 10 ]);
+ isa_ok($coll, 'My::List1');
+
+ ok($coll->does('List'), '... $coll does List');
+ ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
+
+ ok(!$coll->is_empty, '... we do not have an empty collection');
+ is($coll->length, 10, '... we have a length of 10 for the collection');
+
+ is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value');
+
+ my $coll2 = $coll->apply(sub { $_[0] * $_[0] });
+ isa_ok($coll2, 'My::List1');
+
+ is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same');
+ is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed');
+}
+
+{
+ my $coll = My::List2->new('::' => [ 1 .. 10 ]);
+ isa_ok($coll, 'My::List2');
+
+ ok($coll->does('List'), '... $coll does List');
+ ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
+
+ ok(!$coll->is_empty, '... we do not have an empty collection');
+ is($coll->length, 10, '... we have a length of 10 for the collection');
+
+ is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value');
+
+ my $coll2 = $coll->apply(sub { $_[0] * $_[0] });
+ isa_ok($coll2, 'My::List2');
+
+ is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same');
+ is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed');
+}
+
+
+
+
+
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+=pod
+
+This tests how well Mouse type constraints
+play with Declare::Constraints::Simple.
+
+Pretty well if I do say so myself :)
+
+=cut
+
+BEGIN {
+ eval "use Declare::Constraints::Simple;";
+ plan skip_all => "Declare::Constraints::Simple is required for this test" if $@;
+ plan tests => 9;
+}
+
+use Test::Exception;
+
+{
+ package Foo;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+ use Declare::Constraints::Simple -All;
+
+ # define your own type ...
+ type( 'HashOfArrayOfObjects',
+ where => IsHashRef(
+ -keys => HasLength,
+ -values => IsArrayRef(IsObject)
+ )
+ );
+
+ has 'bar' => (
+ is => 'rw',
+ isa => 'HashOfArrayOfObjects',
+ );
+
+ # inline the constraints as anon-subtypes
+ has 'baz' => (
+ is => 'rw',
+ isa => subtype( as => 'ArrayRef', where => IsArrayRef(IsInt) ),
+ );
+
+ package Bar;
+ use Mouse;
+}
+
+my $hash_of_arrays_of_objs = {
+ foo1 => [ Bar->new ],
+ foo2 => [ Bar->new, Bar->new ],
+};
+
+my $array_of_ints = [ 1 .. 10 ];
+
+my $foo;
+lives_ok {
+ $foo = Foo->new(
+ 'bar' => $hash_of_arrays_of_objs,
+ 'baz' => $array_of_ints,
+ );
+} '... construction succeeded';
+isa_ok($foo, 'Foo');
+
+is_deeply($foo->bar, $hash_of_arrays_of_objs, '... got our value correctly');
+is_deeply($foo->baz, $array_of_ints, '... got our value correctly');
+
+dies_ok {
+ $foo->bar([]);
+} '... validation failed correctly';
+
+dies_ok {
+ $foo->bar({ foo => 3 });
+} '... validation failed correctly';
+
+dies_ok {
+ $foo->bar({ foo => [ 1, 2, 3 ] });
+} '... validation failed correctly';
+
+
+dies_ok {
+ $foo->baz([ "foo" ]);
+} '... validation failed correctly';
+
+dies_ok {
+ $foo->baz({});
+} '... validation failed correctly';
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+=pod
+
+This tests how well Mouse type constraints
+play with Test::Deep.
+
+Its not as pretty as Declare::Constraints::Simple,
+but it is not completely horrid either.
+
+=cut
+
+BEGIN {
+ eval "use Test::Deep;";
+ plan skip_all => "Test::Deep is required for this test" if $@;
+ plan tests => 5;
+}
+
+use Test::Exception;
+
+{
+ package Foo;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ use Test::Deep qw[
+ eq_deeply array_each subhashof ignore
+ ];
+
+ # define your own type ...
+ type 'ArrayOfHashOfBarsAndRandomNumbers'
+ => where {
+ eq_deeply($_,
+ array_each(
+ subhashof({
+ bar => Test::Deep::isa('Bar'),
+ random_number => ignore()
+ })
+ )
+ )
+ };
+
+ has 'bar' => (
+ is => 'rw',
+ isa => 'ArrayOfHashOfBarsAndRandomNumbers',
+ );
+
+ package Bar;
+ use Mouse;
+}
+
+my $array_of_hashes = [
+ { bar => Bar->new, random_number => 10 },
+ { bar => Bar->new },
+];
+
+my $foo;
+lives_ok {
+ $foo = Foo->new('bar' => $array_of_hashes);
+} '... construction succeeded';
+isa_ok($foo, 'Foo');
+
+is_deeply($foo->bar, $array_of_hashes, '... got our value correctly');
+
+dies_ok {
+ $foo->bar({});
+} '... validation failed correctly';
+
+dies_ok {
+ $foo->bar([{ foo => 3 }]);
+} '... validation failed correctly';
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 23;
+
+=pod
+
+Some examples of triggers and how they can
+be used to manage parent-child relationships.
+
+=cut
+
+{
+
+ package Parent;
+ use Mouse;
+
+ has 'last_name' => (
+ is => 'rw',
+ isa => 'Str',
+ trigger => sub {
+ my $self = shift;
+
+ # if the parents last-name changes
+ # then so do all the childrens
+ foreach my $child ( @{ $self->children } ) {
+ $child->last_name( $self->last_name );
+ }
+ }
+ );
+
+ has 'children' =>
+ ( is => 'rw', isa => 'ArrayRef', default => sub { [] } );
+}
+{
+
+ package Child;
+ use Mouse;
+
+ has 'parent' => (
+ is => 'rw',
+ isa => 'Parent',
+ required => 1,
+ trigger => sub {
+ my $self = shift;
+
+ # if the parent is changed,..
+ # make sure we update
+ $self->last_name( $self->parent->last_name );
+ }
+ );
+
+ has 'last_name' => (
+ is => 'rw',
+ isa => 'Str',
+ lazy => 1,
+ default => sub { (shift)->parent->last_name }
+ );
+
+}
+
+my $parent = Parent->new( last_name => 'Smith' );
+isa_ok( $parent, 'Parent' );
+
+is( $parent->last_name, 'Smith',
+ '... the parent has the last name we expected' );
+
+$parent->children( [ map { Child->new( parent => $parent ) } ( 0 .. 3 ) ] );
+
+foreach my $child ( @{ $parent->children } ) {
+ is( $child->last_name, $parent->last_name,
+ '... parent and child have the same last name ('
+ . $parent->last_name
+ . ')' );
+}
+
+$parent->last_name('Jones');
+is( $parent->last_name, 'Jones', '... the parent has the new last name' );
+
+foreach my $child ( @{ $parent->children } ) {
+ is( $child->last_name, $parent->last_name,
+ '... parent and child have the same last name ('
+ . $parent->last_name
+ . ')' );
+}
+
+# make a new parent
+
+my $parent2 = Parent->new( last_name => 'Brown' );
+isa_ok( $parent2, 'Parent' );
+
+# orphan the child
+
+my $orphan = pop @{ $parent->children };
+
+# and then the new parent adopts it
+
+$orphan->parent($parent2);
+
+foreach my $child ( @{ $parent->children } ) {
+ is( $child->last_name, $parent->last_name,
+ '... parent and child have the same last name ('
+ . $parent->last_name
+ . ')' );
+}
+
+isnt( $orphan->last_name, $parent->last_name,
+ '... the orphan child does not have the same last name anymore ('
+ . $parent2->last_name
+ . ')' );
+is( $orphan->last_name, $parent2->last_name,
+ '... parent2 and orphan child have the same last name ('
+ . $parent2->last_name
+ . ')' );
+
+# make sure that changes still will not propagate
+
+$parent->last_name('Miller');
+is( $parent->last_name, 'Miller',
+ '... the parent has the new last name (again)' );
+
+foreach my $child ( @{ $parent->children } ) {
+ is( $child->last_name, $parent->last_name,
+ '... parent and child have the same last name ('
+ . $parent->last_name
+ . ')' );
+}
+
+isnt( $orphan->last_name, $parent->last_name,
+ '... the orphan child is not affected by changes in the parent anymore' );
+is( $orphan->last_name, $parent2->last_name,
+ '... parent2 and orphan child have the same last name ('
+ . $parent2->last_name
+ . ')' );
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+use Test::Exception;
+
+
+
+{
+ package Record;
+ use Mouse;
+
+ has 'first_name' => (is => 'ro', isa => 'Str');
+ has 'last_name' => (is => 'ro', isa => 'Str');
+
+ package RecordSet;
+ use Mouse;
+
+ has 'data' => (
+ is => 'ro',
+ isa => 'ArrayRef[Record]',
+ default => sub { [] },
+ );
+
+ has 'index' => (
+ is => 'rw',
+ isa => 'Int',
+ default => sub { 0 },
+ );
+
+ sub next {
+ my $self = shift;
+ my $i = $self->index;
+ $self->index($i + 1);
+ return $self->data->[$i];
+ }
+
+ package RecordSetIterator;
+ use Mouse;
+
+ has 'record_set' => (
+ is => 'rw',
+ isa => 'RecordSet',
+ );
+
+ # list the fields you want to
+ # fetch from the current record
+ my @fields = Record->meta->get_attribute_list;
+
+ has 'current_record' => (
+ is => 'rw',
+ isa => 'Record',
+ lazy => 1,
+ default => sub {
+ my $self = shift;
+ $self->record_set->next() # grab the first one
+ },
+ trigger => sub {
+ my $self = shift;
+ # whenever this attribute is
+ # updated, it will clear all
+ # the fields for you.
+ $self->$_() for map { '_clear_' . $_ } @fields;
+ }
+ );
+
+ # define the attributes
+ # for all the fields.
+ for my $field (@fields) {
+ has $field => (
+ is => 'ro',
+ isa => 'Any',
+ lazy => 1,
+ default => sub {
+ my $self = shift;
+ # fetch the value from
+ # the current record
+ $self->current_record->$field();
+ },
+ # make sure they have a clearer ..
+ clearer => ('_clear_' . $field)
+ );
+ }
+
+ sub get_next_record {
+ my $self = shift;
+ $self->current_record($self->record_set->next());
+ }
+}
+
+my $rs = RecordSet->new(
+ data => [
+ Record->new(first_name => 'Bill', last_name => 'Smith'),
+ Record->new(first_name => 'Bob', last_name => 'Jones'),
+ Record->new(first_name => 'Jim', last_name => 'Johnson'),
+ ]
+);
+isa_ok($rs, 'RecordSet');
+
+my $rsi = RecordSetIterator->new(record_set => $rs);
+isa_ok($rsi, 'RecordSetIterator');
+
+is($rsi->first_name, 'Bill', '... got the right first name');
+is($rsi->last_name, 'Smith', '... got the right last name');
+
+$rsi->get_next_record;
+
+is($rsi->first_name, 'Bob', '... got the right first name');
+is($rsi->last_name, 'Jones', '... got the right last name');
+
+$rsi->get_next_record;
+
+is($rsi->first_name, 'Jim', '... got the right first name');
+is($rsi->last_name, 'Johnson', '... got the right last name');
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+#!/usr/bin/perl\r
+\r
+use strict;\r
+use warnings;\r
+\r
+use Test::More tests => 8;\r
+\r
+BEGIN {\r
+ use_ok('Mouse::Util', ':all');\r
+}\r
+\r
+{\r
+ package Foo;\r
+\r
+ use Mouse::Role;\r
+}\r
+\r
+{\r
+ package Bar;\r
+\r
+ use Mouse;\r
+\r
+ with qw/Foo/;\r
+}\r
+\r
+{\r
+ package Baz;\r
+\r
+ use Mouse;\r
+}\r
+\r
+{\r
+ package Quux;\r
+\r
+ use metaclass;\r
+}\r
+\r
+{\r
+ package Foo::Foo;\r
+\r
+ use Mouse::Role;\r
+\r
+ with 'Foo';\r
+}\r
+\r
+# Classes\r
+\r
+ok(does_role('Bar', 'Foo'), '... Bar does Foo');\r
+\r
+ok(!does_role('Baz', 'Foo'), '... Baz doesnt do Foo');\r
+\r
+# Objects\r
+\r
+my $bar = Bar->new;\r
+\r
+ok(does_role($bar, 'Foo'), '... $bar does Foo');\r
+\r
+my $baz = Baz->new;\r
+\r
+ok(!does_role($baz, 'Foo'), '... $baz doesnt do Foo');\r
+\r
+# Invalid values\r
+\r
+ok(!does_role(undef,'Foo'), '... undef doesnt do Foo');\r
+\r
+ok(!does_role(1,'Foo'), '... 1 doesnt do Foo');\r
+\r
+# non Mouse metaclass\r
+\r
+ok(!does_role('Quux', 'Foo'), '... Quux doesnt do Foo (does not die tho)');\r
+\r
+# TODO: make the below work, maybe?\r
+\r
+# Self\r
+\r
+#ok(does_role('Foo', 'Foo'), '... Foo does do Foo');\r
+\r
+# sub-Roles\r
+\r
+#ok(does_role('Foo::Foo', 'Foo'), '... Foo::Foo does do Foo');\r
+\r
\r
use strict;\r
use warnings;\r
+use Carp qw(croak);\r
use Mouse::Util qw(find_meta does_role);\r
\r
use base qw(Test::Builder::Module);\r
sub does_ok ($$;$) {\r
my ($class_or_obj, $does, $message) = @_;\r
\r
+ if(!defined $does){\r
+ croak "You must pass a role name";\r
+ }\r
$message ||= "The object does $does";\r
\r
if (does_ok($class_or_obj)) {\r
projects / gitmo/Mouse.git / commitdiff