From: gfx Date: Thu, 24 Sep 2009 07:30:10 +0000 (+0900) Subject: Merge branch 'blead' X-Git-Tag: 0.35~33 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=ef9070cc6ee59ca3691f3765ad96ef0922e064ca;hp=bfaf1f2bd008b9a7958d2bbc8b4e98d10d1cfa5e Merge branch 'blead' Conflicts: Changes TODO lib/Mouse/Meta/Method.pm --- diff --git a/Changes b/Changes index 1150ec0..8125f8a 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,8 @@ Revision history for Mouse +0.33_01 Thu Sep 24 16:16:57 2009 + * Implement traits => [...] in has() (gfx) + 0.33 Wed Sep 23 15:06:40 2009 * Fix RT #49902: 0.32 fails tests reported by GRUBER (gfx) diff --git a/Makefile.PL b/Makefile.PL index 20396d5..81c3dfe 100755 --- a/Makefile.PL +++ b/Makefile.PL @@ -17,8 +17,8 @@ test_requires 'Test::More' => 0.80; if ($Module::Install::AUTHOR) { local @INC = ('lib', @INC); - require 'lib/Mouse.pm'; # for moose_version() - my $require_version = Mouse->moose_version; + require 'lib/Mouse/Spec.pm'; + my $require_version = Mouse::Spec->MooseVersion; if (eval{ require Moose; Moose->VERSION($require_version) }) { if (eval 'use Module::Install::AuthorTests; 1') { diff --git a/TODO b/TODO index 265910a..aa73df2 100644 --- a/TODO +++ b/TODO @@ -3,8 +3,6 @@ TODO: Mouse * smart exporters -* method confliction -* trait mechanism * native traits MouseX diff --git a/lib/Mouse.pm b/lib/Mouse.pm index 6e208e7..a18bef8 100644 --- a/lib/Mouse.pm +++ b/lib/Mouse.pm @@ -6,8 +6,6 @@ use base 'Exporter'; our $VERSION = '0.33'; -sub moose_version(){ 0.90 } # which Mouse is a subset of - use Carp 'confess'; use Scalar::Util 'blessed'; @@ -38,7 +36,9 @@ sub extends { Mouse::Meta::Class->initialize(scalar caller)->superclasses(@_) } sub has { my $meta = Mouse::Meta::Class->initialize(scalar caller); - $meta->add_attribute(@_); + my $name = shift; + + $meta->add_attribute($_ => @_) for ref($name) ? @{$name} : $name; } sub before { diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index 429b6f9..8511bc2 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -2,31 +2,168 @@ package Mouse::Meta::Attribute; use strict; use warnings; +use Carp (); +use Scalar::Util qw(weaken); + use Mouse::Util; use Mouse::Meta::TypeConstraint; use Mouse::Meta::Method::Accessor; +sub BUILDARGS{ + my $class = shift; + my $name = shift; + my %args = (@_ == 1) ? %{$_[0]} : @_; + + $args{name} = $name; + + # XXX: for backward compatibility (with method modifiers) + if($class->can('canonicalize_args') != \&canonicalize_args){ + %args = $class->canonicalize_args($name, %args); + } + + return \%args; +} + sub new { - my ($class, $name, %options) = @_; + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my $name = $args->{name}; + + # taken from Class::MOP::Attribute::new + + defined($name) + or $class->throw_error('You must provide a name for the attribute'); + + if(!exists $args->{init_arg}){ + $args->{init_arg} = $name; + } + + # 'required' requires eigher 'init_arg', 'builder', or 'default' + my $can_be_required = defined( $args->{init_arg} ); + + if(exists $args->{builder}){ + $class->throw_error('builder must be a defined scalar value which is a method name') + if ref $args->{builder} || !(defined $args->{builder}); + + $can_be_required++; + } + elsif(exists $args->{default}){ + if(ref $args->{default} && ref($args->{default}) ne 'CODE'){ + $class->throw_error("References are not allowed as default values, you must " + . "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])"); + } + $can_be_required++; + } + + if( $args->{required} && !$can_be_required ) { + $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg"); + } + + # taken from Mouse::Meta::Attribute->new and _process_args-> + + if(exists $args->{is}){ + my $is = $args->{is}; + + if($is eq 'ro'){ + $args->{reader} ||= $name; + } + elsif($is eq 'rw'){ + if(exists $args->{writer}){ + $args->{reader} ||= $name; + } + else{ + $args->{accessor} ||= $name; + } + } + elsif($is eq 'bare'){ + # do nothing, but don't complain (later) about missing methods + } + else{ + $is = 'undef' if !defined $is; + $class->throw_error("I do not understand this option (is => $is) on attribute ($name)"); + } + } + + my $tc; + if(exists $args->{isa}){ + $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{isa}); + } + elsif(exists $args->{does}){ + $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does}); + } + $tc = $args->{type_constraint}; + + if($args->{coerce}){ + defined($tc) + || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)"); + + $args->{weak_ref} + && $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)"); + } + + if ($args->{lazy_build}) { + exists($args->{default}) + && $class->throw_error("You can not use lazy_build and default for the same attribute ($name)"); + + $args->{lazy} = 1; + $args->{builder} ||= "_build_${name}"; + if ($name =~ /^_/) { + $args->{clearer} ||= "_clear${name}"; + $args->{predicate} ||= "_has${name}"; + } + else { + $args->{clearer} ||= "clear_${name}"; + $args->{predicate} ||= "has_${name}"; + } + } - $options{name} = $name; + if ($args->{auto_deref}) { + defined($tc) + || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)"); - $options{init_arg} = $name - unless exists $options{init_arg}; + ( $tc->is_a_type_of('ArrayRef') || $tc->is_a_type_of('HashRef') ) + || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)"); + } - my $is = $options{is} ||= ''; + if (exists $args->{trigger}) { + ('CODE' eq ref $args->{trigger}) + || $class->throw_error("Trigger must be a CODE ref on attribute ($name)"); + } - if($is eq 'rw'){ - $options{accessor} = $name if !exists $options{accessor}; + if ($args->{lazy}) { + (exists $args->{default} || defined $args->{builder}) + || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it"); } - elsif($is eq 'ro'){ - $options{reader} = $name if !exists $options{reader}; + + my $instance = bless $args, $class; + + # extra attributes + if($class ne __PACKAGE__){ + $class->meta->_initialize_instance($instance, $args); } - bless \%options, $class; +# XXX: there is no fast way to check attribute validity +# my @bad = ...; +# if(@bad){ +# @bad = sort @bad; +# Carp::cluck("Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad"); +# } + + return $instance } +sub does { + my ($self, $role_name) = @_; + my $meta = Mouse::Meta::Class->initialize(ref($self) || $self); + + (defined $role_name) + || $meta->throw_error("You must supply a role name to does()"); + + return $meta->does_role($role_name); +}; + # readers sub name { $_[0]->{name} } @@ -47,14 +184,14 @@ sub is_lazy_build { $_[0]->{lazy_build} } sub is_weak_ref { $_[0]->{weak_ref} } sub init_arg { $_[0]->{init_arg} } sub type_constraint { $_[0]->{type_constraint} } -sub find_type_constraint { - Carp::carp("This method was deprecated"); - $_[0]->type_constraint(); -} + sub trigger { $_[0]->{trigger} } sub builder { $_[0]->{builder} } sub should_auto_deref { $_[0]->{auto_deref} } -sub should_coerce { $_[0]->{should_coerce} } +sub should_coerce { $_[0]->{coerce} } + +sub get_read_method { $_[0]->{reader} || $_[0]->{accessor} } +sub get_write_method { $_[0]->{writer} || $_[0]->{accessor} } # predicates @@ -70,6 +207,9 @@ sub has_type_constraint { exists $_[0]->{type_constraint} } sub has_trigger { exists $_[0]->{trigger} } sub has_builder { exists $_[0]->{builder} } +sub has_read_method { exists $_[0]->{reader} || exists $_[0]->{accessor} } +sub has_write_method { exists $_[0]->{writer} || exists $_[0]->{accessor} } + sub _create_args { $_[0]->{_create_args} = $_[1] if @_ > 1; $_[0]->{_create_args} @@ -77,105 +217,59 @@ sub _create_args { sub accessor_metaclass { 'Mouse::Meta::Method::Accessor' } -sub create { - my ($self, $class, $name, %args) = @_; - - $args{name} = $name; - $args{associated_class} = $class; +sub interpolate_class_and_new{ + my($class, $name, $args) = @_; - %args = $self->canonicalize_args($name, %args); - $self->validate_args($name, \%args); - - $args{should_coerce} = delete $args{coerce} - if exists $args{coerce}; - - if (exists $args{isa}) { - my $type_constraint = delete $args{isa}; - $args{type_constraint}= Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($type_constraint); + if(my $metaclass = delete $args->{metaclass}){ + $class = Mouse::Util::resolve_metaclass_alias( Attribute => $metaclass ); } - my $attribute = $self->new($name, %args); - $attribute->_create_args(\%args); + if(my $traits_ref = delete $args->{traits}){ + my @traits; + for (my $i = 0; $i < @{$traits_ref}; $i++) { + my $trait = Mouse::Util::resolve_metaclass_alias(Attribute => $traits_ref->[$i], trait => 1); - $class->add_attribute($attribute); + next if $class->does($trait); - my $associated_methods = 0; + push @traits, $trait; - my $generator_class = $self->accessor_metaclass; - foreach my $type(qw(accessor reader writer predicate clearer handles)){ - if(exists $attribute->{$type}){ - my $installer = '_install_' . $type; - $generator_class->$installer($attribute, $attribute->{$type}, $class); - $associated_methods++; + # are there options? + push @traits, $traits_ref->[++$i] + if ref($traits_ref->[$i+1]); } - } - if($associated_methods == 0 && ($attribute->_is_metadata || '') ne 'bare'){ - Carp::cluck(qq{Attribute ($name) of class }.$class->name.qq{ has no associated methods (did you mean to provide an "is" argument?)}); + if (@traits) { + $class = Mouse::Meta::Class->create_anon_class( + superclasses => [ $class ], + roles => \@traits, + cache => 1, + )->name; + $args->{traits} = \@traits; + } } - return $attribute; + return $class->new($name, $args); } -sub canonicalize_args { - my $self = shift; - my $name = shift; - my %args = @_; +sub canonicalize_args{ + my ($self, $name, %args) = @_; - if ($args{lazy_build}) { - $args{lazy} = 1; - $args{required} = 1; - $args{builder} = "_build_${name}" - if !exists($args{builder}); - if ($name =~ /^_/) { - $args{clearer} = "_clear${name}" if !exists($args{clearer}); - $args{predicate} = "_has${name}" if !exists($args{predicate}); - } - else { - $args{clearer} = "clear_${name}" if !exists($args{clearer}); - $args{predicate} = "has_${name}" if !exists($args{predicate}); - } - } + Carp::cluck("$self->canonicalize_args has been deprecated." + . "Use \$self->BUILDARGS instead."); return %args; } -sub validate_args { - my $self = shift; - my $name = shift; - my $args = shift; - - $self->throw_error("You can not use lazy_build and default for the same attribute ($name)") - if $args->{lazy_build} && exists $args->{default}; - - $self->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it") - if $args->{lazy} - && !exists($args->{default}) - && !exists($args->{builder}); - - $self->throw_error("References are not allowed as default values, you must wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])") - if ref($args->{default}) - && ref($args->{default}) ne 'CODE'; - - $self->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)") - if $args->{auto_deref} && !exists($args->{isa}); - - $self->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)") - if $args->{auto_deref} - && $args->{isa} !~ /^(?:ArrayRef|HashRef)(?:\[.*\])?$/; - - if ($args->{trigger}) { - if (ref($args->{trigger}) eq 'HASH') { - $self->throw_error("HASH-based form of trigger has been removed. Only the coderef form of triggers are now supported."); - } +sub create { + my ($self, $class, $name, %args) = @_; - $self->throw_error("Trigger must be a CODE ref on attribute ($name)") - if ref($args->{trigger}) ne 'CODE'; - } + Carp::cluck("$self->create has been deprecated." + . "Use \$meta->add_attribute and \$attr->install_accessors instead."); - return 1; + # noop + return $self; } sub verify_against_type_constraint { @@ -215,12 +309,23 @@ sub _canonicalize_handles { } } +sub clone_and_inherit_options{ + my $self = shift; + my $name = shift; + + return ref($self)->new($name, %{$self}, @_ == 1 ? %{$_[0]} : @_); +} + sub clone_parent { my $self = shift; my $class = shift; my $name = shift; my %args = ($self->get_parent_args($class, $name), @_); + Carp::cluck("$self->clone_parent has been deprecated." + . "Use \$meta->add_attribute and \$attr->install_accessors instead."); + + $self->create($class, $name, %args); } @@ -238,6 +343,27 @@ sub get_parent_args { $self->throw_error("Could not find an attribute by the name of '$name' to inherit from"); } +sub install_accessors{ + my($attribute) = @_; + + my $metaclass = $attribute->{associated_class}; + my $generator_class = $attribute->accessor_metaclass; + + foreach my $type(qw(accessor reader writer predicate clearer handles)){ + if(exists $attribute->{$type}){ + my $installer = '_install_' . $type; + $generator_class->$installer($attribute, $attribute->{$type}, $metaclass); + $attribute->{associated_methods}++; + } + } + + if($attribute->can('create') != \&create){ + $attribute->create($metaclass, $attribute->name, %{$attribute}); + } + + return; +} + sub throw_error{ my $self = shift; diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index 46b4a15..06c4f35 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -14,7 +14,7 @@ use base qw(Mouse::Meta::Module); sub method_metaclass(){ 'Mouse::Meta::Method' } # required for get_method() -sub _new { +sub _construct_meta { my($class, %args) = @_; $args{attributes} ||= {}; @@ -29,7 +29,7 @@ sub _new { #return Mouse::Meta::Class->initialize($class)->new_object(%args) # if $class ne __PACKAGE__; - return bless \%args, $class; + return bless \%args, ref($class) || $class; } sub create_anon_class{ @@ -51,7 +51,23 @@ sub superclasses { @{ $self->{superclasses} } = @_; } - @{ $self->{superclasses} }; + return @{ $self->{superclasses} }; +} + +sub find_method_by_name{ + my($self, $method_name) = @_; + defined($method_name) + or $self->throw_error('You must define a method name to find'); + foreach my $class( $self->linearized_isa ){ + my $method = $self->initialize($class)->get_method($method_name); + return $method if defined $method; + } + return undef; +} + +sub get_all_methods { + my($self) = @_; + return map{ $self->find_method_by_name($self) } $self->get_all_method_names; } sub get_all_method_names { @@ -62,40 +78,52 @@ sub get_all_method_names { $self->linearized_isa; } -sub add_attribute { +sub _process_attribute{ my $self = shift; + my $name = shift; - if (@_ == 1 && blessed($_[0])) { - my $attr = shift @_; - $self->{'attributes'}{$attr->name} = $attr; - } - else { - my $names = shift @_; - $names = [$names] if !ref($names); - my $metaclass = 'Mouse::Meta::Attribute'; - my %options = (@_ == 1 ? %{$_[0]} : @_); - - if ( my $metaclass_name = delete $options{metaclass} ) { - my $new_class = Mouse::Util::resolve_metaclass_alias( - 'Attribute', - $metaclass_name - ); - if ( $metaclass ne $new_class ) { - $metaclass = $new_class; - } - } + my $args = (@_ == 1) ? $_[0] : { @_ }; - for my $name (@$names) { - if ($name =~ s/^\+//) { - $metaclass->clone_parent($self, $name, %options); - } - else { - $metaclass->create($self, $name, %options); - } + defined($name) + or $self->throw_error('You must provide a name for the attribute'); + + if ($name =~ s/^\+//) { + my $inherited_attr; + + foreach my $class($self->linearized_isa){ + my $meta = Mouse::Meta::Module::get_metaclass_by_name($class) or next; + $inherited_attr = $meta->get_attribute($name) and last; } + + defined($inherited_attr) + or $self->throw_error("Could not find an attribute by the name of '$name' to inherit from in ".$self->name); + + return $inherited_attr->clone_and_inherit_options($name, $args); + } + else{ + return Mouse::Meta::Attribute->interpolate_class_and_new($name, $args); } } +sub add_attribute { + my $self = shift; + + my $attr = blessed($_[0]) ? $_[0] : $self->_process_attribute(@_); + + $attr->isa('Mouse::Meta::Attribute') + || $self->throw_error("Your attribute must be an instance of Mouse::Meta::Attribute (or a subclass)"); + + weaken( $attr->{associated_class} = $self ); + + $self->{attributes}{$attr->name} = $attr; + $attr->install_accessors(); + + if(!$attr->{associated_methods} && ($attr->{is} || '') ne 'bare'){ + Carp::cluck(qq{Attribute (}.$attr->name.qq{) of class }.$self->name.qq{ has no associated methods (did you mean to provide an "is" argument?)}); + } + return $attr; +} + sub compute_all_applicable_attributes { shift->get_all_attributes(@_) } sub get_all_attributes { my $self = shift; @@ -122,24 +150,32 @@ sub new_object { my $instance = bless {}, $self->name; + $self->_initialize_instance($instance, \%args); + return $instance; +} + +sub _initialize_instance{ + my($self, $instance, $args) = @_; + my @triggers_queue; foreach my $attribute ($self->get_all_attributes) { 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}); - $instance->{$key} = $args{$from}; + $attribute->verify_against_type_constraint($args->{$from}); + + $instance->{$key} = $args->{$from}; weaken($instance->{$key}) if ref($instance->{$key}) && $attribute->is_weak_ref; if ($attribute->has_trigger) { - push @triggers_queue, [ $attribute->trigger, $args{$from} ]; + push @triggers_queue, [ $attribute->trigger, $args->{$from} ]; } } else { @@ -176,6 +212,10 @@ sub new_object { $trigger->($instance, $value); } + if($self->is_anon_class){ + $instance->{__METACLASS__} = $self; + } + return $instance; } diff --git a/lib/Mouse/Meta/Method.pm b/lib/Mouse/Meta/Method.pm index a64dce8..a423012 100755 --- a/lib/Mouse/Meta/Method.pm +++ b/lib/Mouse/Meta/Method.pm @@ -13,9 +13,9 @@ sub new{ return bless \%args, $class; } -sub body { $_[0]->{body} } -sub name { $_[0]->{name} } -sub package{ $_[0]->{name} } +sub body { $_[0]->{body} } +sub name { $_[0]->{name} } +sub package_name{ $_[0]->{package} } 1; diff --git a/lib/Mouse/Meta/Method/Constructor.pm b/lib/Mouse/Meta/Method/Constructor.pm index cff5fc3..d8d8ab5 100644 --- a/lib/Mouse/Meta/Method/Constructor.pm +++ b/lib/Mouse/Meta/Method/Constructor.pm @@ -3,13 +3,13 @@ use strict; use warnings; sub generate_constructor_method_inline { - my ($class, $meta) = @_; + my ($class, $metaclass) = @_; - my $associated_metaclass_name = $meta->name; - my @attrs = $meta->get_all_attributes; - my $buildall = $class->_generate_BUILDALL($meta); - my $buildargs = $class->_generate_BUILDARGS($meta); - my $processattrs = $class->_generate_processattrs($meta, \@attrs); + my $associated_metaclass_name = $metaclass->name; + my @attrs = $metaclass->get_all_attributes; + my $buildall = $class->_generate_BUILDALL($metaclass); + my $buildargs = $class->_generate_BUILDARGS($metaclass); + my $processattrs = $class->_generate_processattrs($metaclass, \@attrs); my @compiled_constraints = map { $_ ? $_->{_compiled_type_constraint} : undef } map { $_->{type_constraint} } @attrs; my $code = <<"..."; @@ -33,9 +33,11 @@ sub generate_constructor_method_inline { } sub _generate_processattrs { - my ($class, $meta, $attrs) = @_; + my ($class, $metaclass, $attrs) = @_; my @res; + my $has_triggers; + for my $index (0 .. @$attrs - 1) { my $attr = $attrs->[$index]; my $key = $attr->name; @@ -74,6 +76,7 @@ sub _generate_processattrs { } if ($attr->has_trigger) { + $has_triggers++; $code .= "push \@triggers, [\$attrs[$index]->{trigger}, \$value];\n"; } @@ -138,14 +141,22 @@ sub _generate_processattrs { push @res, $code; } - return join "\n", q{my @triggers;}, @res, q{$_->[0]->($instance, $_->[1]) for @triggers;}; + if($metaclass->is_anon_class){ + push @res, q{$instnace->{__METACLASS__} = $metaclass;}; + } + + if($has_triggers){ + unshift @res, q{my @triggers;}; + push @res, q{$_->[0]->($instance, $_->[1]) for @triggers;}; + } + + return join "\n", @res; } sub _generate_BUILDARGS { - my $self = shift; - my $meta = shift; + my($self, $metaclass) = @_; - if ($meta->name->can('BUILDARGS') && $meta->name->can('BUILDARGS') != Mouse::Object->can('BUILDARGS')) { + if ($metaclass->name->can('BUILDARGS') && $metaclass->name->can('BUILDARGS') != Mouse::Object->can('BUILDARGS')) { return 'my $args = $class->BUILDARGS(@_)'; } @@ -163,15 +174,15 @@ sub _generate_BUILDARGS { } sub _generate_BUILDALL { - my ($class, $meta) = @_; - return '' unless $meta->name->can('BUILD'); + my ($class, $metaclass) = @_; + return '' unless $metaclass->name->can('BUILD'); my @code = (); push @code, q{no strict 'refs';}; push @code, q{no warnings 'once';}; no strict 'refs'; no warnings 'once'; - for my $klass ($meta->linearized_isa) { + for my $klass ($metaclass->linearized_isa) { if (*{ $klass . '::BUILD' }{CODE}) { unshift @code, qq{${klass}::BUILD(\$instance, \$args);}; } diff --git a/lib/Mouse/Meta/Module.pm b/lib/Mouse/Meta/Module.pm index be2c7f6..ac15fcc 100755 --- a/lib/Mouse/Meta/Module.pm +++ b/lib/Mouse/Meta/Module.pm @@ -24,7 +24,7 @@ use Mouse::Util qw/get_code_info not_supported load_class/; || $class->throw_error("You must pass a package name and it cannot be blessed"); return $METACLASS_CACHE{$package_name} - ||= $class->_new(package => $package_name, @args); + ||= $class->_construct_meta(package => $package_name, @args); } sub class_of{ @@ -51,7 +51,6 @@ sub meta{ Mouse::Meta::Class->initialize(ref $_[0] || $_[0]) } sub _new{ Carp::croak("Mouse::Meta::Module is an abstract class") } sub name { $_[0]->{package} } -sub _method_map{ $_[0]->{methods} } sub version { no strict 'refs'; ${shift->name.'::VERSION'} } sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} } @@ -82,13 +81,17 @@ sub add_method { my($self, $name, $code) = @_; if(!defined $name){ - $self->throw_error("You must pass a defined name"); + $self->throw_error('You must pass a defined name'); } + if(!defined $code){ + $self->throw_error('You must pass a defined code'); + } + if(ref($code) ne 'CODE'){ not_supported 'add_method for a method object'; } - $self->_method_map->{$name}++; # Moose stores meta object here. + $self->{methods}->{$name}++; # Moose stores meta object here. my $pkg = $self->name; no strict 'refs'; @@ -108,7 +111,7 @@ sub _code_is_mine { # taken from Class::MOP::Class sub has_method { my($self, $method_name) = @_; - return 1 if $self->_method_map->{$method_name}; + return 1 if $self->{methods}->{$method_name}; my $code = $self->name->can($method_name); return $code && $self->_code_is_mine($code); diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm index 8b437ec..f29dae0 100644 --- a/lib/Mouse/Meta/Role.pm +++ b/lib/Mouse/Meta/Role.pm @@ -9,7 +9,7 @@ use base qw(Mouse::Meta::Module); sub method_metaclass(){ 'Mouse::Meta::Role::Method' } # required for get_method() -sub _new { +sub _construct_meta { my $class = shift; my %args = @_; @@ -22,7 +22,7 @@ sub _new { # return Mouse::Meta::Class->initialize($class)->new_object(%args) # if $class ne __PACKAGE__; - return bless \%args, $class; + return bless \%args, ref($class) || $class; } sub create_anon_role{ @@ -181,15 +181,7 @@ sub _apply_attributes{ my $spec = $role->get_attribute($attr_name); - my $attr_metaclass = 'Mouse::Meta::Attribute'; - if ( my $metaclass_name = $spec->{metaclass} ) { - $attr_metaclass = Mouse::Util::resolve_metaclass_alias( - 'Attribute', - $metaclass_name - ); - } - - $attr_metaclass->create($class, $attr_name => %$spec); + $class->add_attribute($attr_name => %{$spec}); } } elsif($args->{_to} eq 'role'){ diff --git a/lib/Mouse/Object.pm b/lib/Mouse/Object.pm index 911954d..16846f5 100644 --- a/lib/Mouse/Object.pm +++ b/lib/Mouse/Object.pm @@ -71,7 +71,8 @@ sub dump { require 'Data/Dumper.pm'; # we don't want to create its namespace my $dd = Data::Dumper->new([$self]); - $dd->Maxdepth($maxdepth || 1); + $dd->Maxdepth(defined($maxdepth) ? $maxdepth : 2); + $dd->Indent(1); return $dd->Dump(); } diff --git a/lib/Mouse/Role.pm b/lib/Mouse/Role.pm index df249a8..59cccd2 100644 --- a/lib/Mouse/Role.pm +++ b/lib/Mouse/Role.pm @@ -90,11 +90,9 @@ sub augment { sub has { my $meta = Mouse::Meta::Role->initialize(scalar caller); - my $name = shift; - my %opts = @_; - $meta->add_attribute($name => \%opts); + $meta->add_attribute($_ => @_) for ref($name) ? @{$name} : $name; } sub extends { diff --git a/lib/Mouse/Spec.pm b/lib/Mouse/Spec.pm new file mode 100644 index 0000000..ae173c1 --- /dev/null +++ b/lib/Mouse/Spec.pm @@ -0,0 +1,16 @@ +package Mouse::Spec; + +use strict; +use version; + +our $VERSION = '0.33'; + +our $MouseVersion = $VERSION; +our $MooseVersion = '0.90'; + +sub MouseVersion{ $MouseVersion } +sub MooseVersion{ $MooseVersion } + + +1; +__END__ diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm index b51f7bc..8923749 100644 --- a/lib/Mouse/Util.pm +++ b/lib/Mouse/Util.pm @@ -281,8 +281,8 @@ sub not_supported{ $feature ||= ( caller(1) )[3]; # subroutine name - local $Carp::CarpLevel = $Carp::CarpLevel + 2; - Carp::croak("Mouse does not currently support $feature"); + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + Carp::confess("Mouse does not currently support $feature"); } 1; diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index adda8f1..dbd639e 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -6,7 +6,8 @@ use base 'Exporter'; use Carp (); use Scalar::Util qw/blessed looks_like_number openhandle/; -use Mouse::Util; +use Mouse::Util qw(does_role not_supported); +use Mouse::Meta::Module; # class_of use Mouse::Meta::TypeConstraint; our @EXPORT = qw( @@ -32,21 +33,8 @@ sub message (&) { sub from { @_ } sub via (&) { $_[0] } -sub export_type_constraints_as_functions { - my $into = caller; - - foreach my $constraint ( values %TYPE ) { - my $tc = $constraint->{_compiled_type_constraint}; - my $as = $into . '::' . $constraint->{name}; - - no strict 'refs'; - *{$as} = sub{ &{$tc} || undef }; - } - return; -} - BEGIN { - %TYPE = ( + my %builtins = ( Any => sub { 1 }, Item => sub { 1 }, @@ -77,7 +65,8 @@ BEGIN { ClassName => sub { Mouse::Util::is_class_loaded($_[0]) }, RoleName => sub { (Mouse::Util::find_meta($_[0]) || return 0)->isa('Mouse::Meta::Role') }, ); - while (my ($name, $code) = each %TYPE) { + + while (my ($name, $code) = each %builtins) { $TYPE{$name} = Mouse::Meta::TypeConstraint->new( name => $name, _compiled_type_constraint => $code, @@ -87,8 +76,10 @@ BEGIN { sub optimized_constraints { \%TYPE } - my @TYPE_KEYS = keys %TYPE; - sub list_all_builtin_type_constraints { @TYPE_KEYS } + my @builtins = keys %TYPE; + sub list_all_builtin_type_constraints { @builtins } + + sub list_all_type_constraints { keys %TYPE } } sub type { @@ -225,10 +216,11 @@ sub class_type { if ($conf && $conf->{class}) { # No, you're using this wrong warn "class_type() should be class_type(ClassName). Perhaps you're looking for subtype $name => as '$conf->{class}'?"; - subtype($name, as => $conf->{class}); - } else { - subtype( - $name => where => sub { $_->isa($name) } + subtype $name => (as => $conf->{class}); + } + else { + subtype $name => ( + where => sub { blessed($_) && $_->isa($name) }, ); } } @@ -236,18 +228,15 @@ sub class_type { sub role_type { my($name, $conf) = @_; my $role = $conf->{role}; - subtype( - $name => where => sub { - return unless defined $_ && ref($_) && $_->isa('Mouse::Object'); - $_->meta->does_role($role); - } + subtype $name => ( + where => sub { does_role($_, $role) }, ); } # this is an original method for Mouse sub typecast_constraints { my($class, $pkg, $types, $value) = @_; - Carp::croak("wrong arguments count") unless @_==4; + Carp::croak("wrong arguments count") unless @_ == 4; local $_; for my $type ( split /\|/, $types ) { @@ -285,18 +274,21 @@ sub enum { } sub _build_type_constraint { + my($spec) = @_; - my $spec = shift; my $code; $spec =~ s/\s+//g; - if ($spec =~ /^([^\[]+)\[(.+)\]$/) { + + if ($spec =~ /\A (\w+) \[ (.+) \] \z/xms) { # parameterized my $constraint = $1; my $param = $2; my $parent; + if ($constraint eq 'Maybe') { $parent = _build_type_constraint('Undef'); - } else { + } + else { $parent = _build_type_constraint($constraint); } my $child = _build_type_constraint($param); @@ -361,8 +353,17 @@ sub _build_type_constraint { } sub find_type_constraint { - my $type_constraint = shift; - return $TYPE{$type_constraint}; + my($type) = @_; + if(blessed($type) && $type->isa('Mouse::Meta::TypeConstraint')){ + return $type; + } + else{ + return $TYPE{$type}; + } +} + +sub find_or_create_does_type_constraint{ + not_supported; } sub find_or_create_isa_type_constraint { @@ -375,33 +376,34 @@ sub find_or_create_isa_type_constraint { $1 ne 'Maybe' ; - my $code; $type_constraint =~ s/\s+//g; - $code = $TYPE{$type_constraint}; - if (! $code) { + my $tc = find_type_constraint($type_constraint); + if (!$tc) { my @type_constraints = split /\|/, $type_constraint; if (@type_constraints == 1) { - $code = $TYPE{$type_constraints[0]} || + $tc = $TYPE{$type_constraints[0]} || _build_type_constraint($type_constraints[0]); - } else { + } + else { my @code_list = map { $TYPE{$_} || _build_type_constraint($_) } @type_constraints; - $code = Mouse::Meta::TypeConstraint->new( + + $tc = Mouse::Meta::TypeConstraint->new( + name => $type_constraint, + _compiled_type_constraint => sub { - my $i = 0; - for my $code (@code_list) { + foreach my $code (@code_list) { return 1 if $code->check($_[0]); } return 0; }, - name => $type_constraint, ); } } - return $code; + return $tc; } 1; diff --git a/t/000-recipes/moose_cookbook_meta_recipe3.t b/t/000-recipes/moose_cookbook_meta_recipe3.t new file mode 100644 index 0000000..fe1ab24 --- /dev/null +++ b/t/000-recipes/moose_cookbook_meta_recipe3.t @@ -0,0 +1,85 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More 'no_plan'; +use Test::Exception; +$| = 1; + + + +# =begin testing SETUP +{ + + package MyApp::Meta::Attribute::Trait::Labeled; + use Mouse::Role; + + has label => ( + is => 'rw', + isa => 'Str', + predicate => 'has_label', + ); + + package Mouse::Meta::Attribute::Custom::Trait::Labeled; + sub register_implementation {'MyApp::Meta::Attribute::Trait::Labeled'} + + package MyApp::Website; + use Mouse; + + has url => ( + traits => [qw/Labeled/], + is => 'rw', + isa => 'Str', + label => "The site's URL", + ); + + has name => ( + is => 'rw', + isa => 'Str', + ); + + sub dump { + my $self = shift; + + my $dump = ''; + + my %attributes = %{ $self->meta->get_attribute_map }; + for my $name ( sort keys %attributes ) { + my $attribute = $attributes{$name}; + + if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled') + && $attribute->has_label ) { + $dump .= $attribute->label; + } + else { + $dump .= $name; + } + + my $reader = $attribute->get_read_method; + $dump .= ": " . $self->$reader . "\n"; + } + + return $dump; + } + + package main; + + my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); +} + + + +# =begin testing +{ +my $app2 + = MyApp::Website->new( url => "http://google.com", name => "Google" ); +is( + $app2->dump, q{name: Google +The site's URL: http://google.com +}, '... got the expected dump value' +); +} + + + + +1; diff --git a/t/020_attributes/015_attribute_traits.t b/t/020_attributes/015_attribute_traits.t new file mode 100644 index 0000000..2c557ca --- /dev/null +++ b/t/020_attributes/015_attribute_traits.t @@ -0,0 +1,80 @@ +#!/usr/bin/perl +use lib 't/lib'; + +use strict; +use warnings; + +use Test::More; +BEGIN{ + if(eval{ require Class::Method::Modifiers::Fast } || eval{ require Class::Method::Modifiers }){ + plan tests => 12; + } + else{ + plan skip_all => 'This test requires Class::Method::Modifiers(::Fast)?'; + } +} +use Test::Exception; +use Test::Mouse; + + + +{ + package My::Attribute::Trait; + use Mouse::Role; + + has 'alias_to' => (is => 'ro', isa => 'Str'); + + has foo => ( is => "ro", default => "blah" ); + + after 'install_accessors' => sub { + my $self = shift; + my $reader = $self->get_read_method; + + $self->associated_class->add_method( + $self->alias_to, + sub { shift->$reader(@_) }, + ); + }; +} + +{ + package My::Class; + use Mouse; + + has 'bar' => ( + traits => [qw/My::Attribute::Trait/], + is => 'ro', + isa => 'Int', + alias_to => 'baz', + ); + + has 'gorch' => ( + is => 'ro', + isa => 'Int', + default => sub { 10 } + ); +} + +my $c = My::Class->new(bar => 100); +isa_ok($c, 'My::Class'); + +is($c->bar, 100, '... got the right value for bar'); +is($c->gorch, 10, '... got the right value for gorch'); + +can_ok($c, 'baz'); +is($c->baz, 100, '... got the right value for baz'); + +my $bar_attr = $c->meta->get_attribute('bar'); + +does_ok($bar_attr, 'My::Attribute::Trait'); +ok($bar_attr->has_applied_traits, '... got the applied traits'); +is_deeply($bar_attr->applied_traits, [qw/My::Attribute::Trait/], '... got the applied traits'); +is($bar_attr->foo, "blah", "attr initialized"); + +my $gorch_attr = $c->meta->get_attribute('gorch'); +ok(!$gorch_attr->does('My::Attribute::Trait'), '... gorch doesnt do the trait'); +ok(!$gorch_attr->has_applied_traits, '... no traits applied'); +is($gorch_attr->applied_traits, undef, '... no traits applied'); + + + diff --git a/t/040_type_constraints/003_util_std_type_constraints.t b/t/040_type_constraints/003_util_std_type_constraints.t index f0a77ce..6340227 100644 --- a/t/040_type_constraints/003_util_std_type_constraints.t +++ b/t/040_type_constraints/003_util_std_type_constraints.t @@ -1,11 +1,14 @@ #!/usr/bin/perl +use lib 't/lib'; use strict; use warnings; use Test::More tests => 277; use Test::Exception; +use Test::Mouse; + use Scalar::Util (); BEGIN { diff --git a/t/043-parameterized-type.t b/t/043-parameterized-type.t index 8c20411..a7eae99 100644 --- a/t/043-parameterized-type.t +++ b/t/043-parameterized-type.t @@ -1,11 +1,19 @@ #!/usr/bin/env perl use strict; use warnings; -use Test::More tests => 9; +use Test::More tests => 16; use Test::Exception; { { + package My::Role; + use Mouse::Role; + + package My::Class; + use Mouse; + + with 'My::Role'; + package Foo; use Mouse; @@ -19,10 +27,20 @@ use Test::Exception; isa => 'ArrayRef[Int]', ); - has 'complex' => ( - is => 'rw', + has complex => ( + is => 'rw', isa => 'ArrayRef[HashRef[Int]]' ); + + has my_class => ( + is => 'rw', + isa => 'ArrayRef[My::Class]', + ); + + has my_role => ( + is => 'rw', + isa => 'ArrayRef[My::Role]', + ); }; ok(Foo->meta->has_attribute('foo')); @@ -36,6 +54,14 @@ use Test::Exception; is_deeply($foo->foo(), $hash, "foo is a proper hash"); is_deeply($foo->bar(), $array, "bar is a proper array"); is_deeply($foo->complex(), $complex, "complex is a proper ... structure"); + + $foo->my_class([My::Class->new]); + is ref($foo->my_class), 'ARRAY'; + isa_ok $foo->my_class->[0], 'My::Class'; + + $foo->my_role([My::Class->new]); + is ref($foo->my_role), 'ARRAY'; + } "Parameterized constraints work"; # check bad args @@ -50,6 +76,21 @@ use Test::Exception; throws_ok { Foo->new( complex => [ { a => 1, b => 1 }, { c => "d", e => "f" } ] ) } qr/Attribute \(complex\) does not pass the type constraint because: Validation failed for 'ArrayRef\[HashRef\[Int\]\]' failed with value/, "Bad args for complex types throws an exception"; + + throws_ok { + Foo->new( my_class => [ 10 ] ); + } qr/Attribute \(my_class\) does not pass the type constraint because: Validation failed for 'ArrayRef\[My::Class\]' failed with value/; + throws_ok { + Foo->new( my_class => [ {foo => 'bar'} ] ); + } qr/Attribute \(my_class\) does not pass the type constraint because: Validation failed for 'ArrayRef\[My::Class\]' failed with value/; + + + throws_ok { + Foo->new( my_role => [ 20 ] ); + } qr/Attribute \(my_role\) does not pass the type constraint because: Validation failed for 'ArrayRef\[My::Role\]' failed with value/; + throws_ok { + Foo->new( my_role => [ {foo => 'bar'} ] ); + } qr/Attribute \(my_role\) does not pass the type constraint because: Validation failed for 'ArrayRef\[My::Role\]' failed with value/; } { diff --git a/t/044-attribute-metaclass.t b/t/044-attribute-metaclass.t index e0d4e07..bb10b1e 100644 --- a/t/044-attribute-metaclass.t +++ b/t/044-attribute-metaclass.t @@ -5,6 +5,8 @@ use Test::More tests => 2; use lib 't/lib'; do { + local $SIG{__WARN__} = sub{ $_[0] =~ /deprecated/ or warn @_ }; + package MouseX::AttributeHelpers::Number; use Mouse; extends 'Mouse::Meta::Attribute'; diff --git a/t/047-attribute-metaclass-role.t b/t/047-attribute-metaclass-role.t index 7dbb2de..a4b1945 100644 --- a/t/047-attribute-metaclass-role.t +++ b/t/047-attribute-metaclass-role.t @@ -5,6 +5,8 @@ use Test::More tests => 7; use lib 't/lib'; do { + local $SIG{__WARN__} = sub{ $_[0] =~ /deprecated/ or warn @_ }; + package MouseX::AttributeHelpers::Number; use Mouse; extends 'Mouse::Meta::Attribute'; @@ -90,3 +92,4 @@ do { is $k->i, 7; } + diff --git a/t/100-meta-class.t b/t/100-meta-class.t index 264a81e..7a921bb 100644 --- a/t/100-meta-class.t +++ b/t/100-meta-class.t @@ -1,19 +1,38 @@ #!/usr/bin/env perl use strict; use warnings; -use Test::More tests => 15; - -do { +use Test::More tests => 22; +use Test::Exception; +{ package Class; use Mouse; + use Scalar::Util qw(blessed weaken); # import external functions has pawn => ( is => 'rw', predicate => 'has_pawn', ); + use constant MY_CONST => 42; + + sub stub; + sub stub_with_attr :method; + no Mouse; -}; +} +{ + package Child; + use Mouse; + use Carp qw(carp croak); # import extenral functions + + extends 'Class'; + + has bishop => ( + is => 'rw', + ); + + sub child_method{ } +} my $meta = Class->meta; isa_ok($meta, 'Mouse::Meta::Class'); @@ -23,37 +42,44 @@ is_deeply([$meta->superclasses], ['Mouse::Object'], "correctly inherting from Mo my $meta2 = Class->meta; is($meta, $meta2, "same metaclass instance"); -can_ok($meta, 'name', 'get_attribute_map', 'get_attribute_list'); +can_ok($meta, qw( + name meta + has_attribute get_attribute get_attribute_list get_all_attributes + has_method get_method get_method_list get_all_methods +)); ok($meta->has_attribute('pawn')); my $attr = $meta->get_attribute('pawn'); isa_ok($attr, 'Mouse::Meta::Attribute'); is($attr->name, 'pawn', 'got the correct attribute'); -my $map = $meta->get_attribute_map; -is_deeply($map, { pawn => $attr }, "attribute map"); - my $list = [$meta->get_attribute_list]; is_deeply($list, [ 'pawn' ], "attribute list"); ok(!$meta->has_attribute('nonexistent_attribute')); -eval " +ok($meta->has_method('pawn')); +lives_and{ + ok($meta->get_method('pawn')); + is($meta->get_method('pawn')->name, 'pawn'); + is($meta->get_method('pawn')->package_name, 'Class'); +}; + +is( join(' ', sort $meta->get_method_list), + join(' ', sort qw(meta pawn has_pawn MY_CONST stub stub_with_attr)) +); + +eval q{ package Class; use Mouse; no Mouse; -"; +}; my $meta3 = Class->meta; is($meta, $meta3, "same metaclass instance, even if use Mouse is performed again"); is($meta->name, 'Class', "name for the metaclass"); -do { - package Child; - use Mouse; - extends 'Class'; -}; my $child_meta = Child->meta; isa_ok($child_meta, 'Mouse::Meta::Class'); @@ -61,3 +87,12 @@ isa_ok($child_meta, 'Mouse::Meta::Class'); isnt($meta, $child_meta, "different metaclass instances for the two classes"); is_deeply([$child_meta->superclasses], ['Class'], "correct superclasses"); + + +ok($child_meta->has_attribute('bishop')); +ok($child_meta->has_method('child_method')); + + +is( join(' ', sort $child_meta->get_method_list), + join(' ', sort qw(meta bishop child_method)) +); diff --git a/t/lib/Test/Mouse.pm b/t/lib/Test/Mouse.pm index c166c7b..8d219dd 100644 --- a/t/lib/Test/Mouse.pm +++ b/t/lib/Test/Mouse.pm @@ -30,7 +30,7 @@ sub does_ok ($$;$) { } $message ||= "The object does $does"; - if (does_ok($class_or_obj)) { + if (does_role($class_or_obj, $does)) { return __PACKAGE__->builder->ok(1, $message) } else { @@ -53,6 +53,30 @@ sub has_attribute_ok ($$;$) { } } +# Moose compatible methods/functions + +package Mouse::Util::TypeConstraints; + +use Mouse::Util::TypeConstraints (); + +sub export_type_constraints_as_functions { # TEST ONLY + my $into = caller; + + foreach my $type( list_all_type_constraints() ) { + my $tc = find_type_constraint($type)->{_compiled_type_constraint}; + my $as = $into . '::' . $type; + + no strict 'refs'; + *{$as} = sub{ &{$tc} || undef }; + } + return; +} + +package Mouse::Meta::Attribute; + +sub applied_traits{ $_[0]->{traits} } # TEST ONLY +sub has_applied_traits{ exists $_[0]->{traits} } # TEST ONLY + 1; __END__