From: gfx Date: Thu, 24 Sep 2009 05:00:27 +0000 (+0900) Subject: Refactor the constructor of Attribute X-Git-Tag: 0.35~33^2~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2efc0af104c1926c066f50e1785236254bda12a2;p=gitmo%2FMouse.git Refactor the constructor of Attribute --- diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index 429b6f9..dec1a54 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -2,29 +2,179 @@ 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; +#my %valid_attrs = map{ $_ => undef } qw( +# name +# reader writer accessor clearer predicate +# builder init_arg default initializer definition_context +# +# is +# isa does +# required +# lazy +# lazy_build +# coerce +# weak_ref +# auto_deref +# type_constraint +# trigger +# handles +# documentation +# traits +#); + sub new { my ($class, $name, %options) = @_; + # taken from Class::MOP::Attribute::new + + defined($name) + or $class->throw_error('You must provide a name for the attribute'); $options{name} = $name; - $options{init_arg} = $name - unless exists $options{init_arg}; + if(!exists $options{init_arg}){ + $options{init_arg} = $name; + } + + # 'required' requires eigher 'init_arg', 'builder', or 'default' + my $can_be_required = defined( $options{init_arg} ); + + if(exists $options{builder}){ + $class->throw_error('builder must be a defined scalar value which is a method name') + if ref $options{builder} || !(defined $options{builder}); + + $can_be_required++; + } + elsif(exists $options{default}){ + if(ref $options{default} && ref($options{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( $options{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_options + + if(exists $options{is}){ + my $is = $options{is}; + + if($is eq 'ro'){ + $options{reader} ||= $name; + } + elsif($is eq 'rw'){ + if(exists $options{writer}){ + $options{reader} ||= $name; + } + else{ + $options{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 $options{isa}){ + $options{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa}); + } + elsif(exists $options{does}){ + $options{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($options{does}); + } + $tc = $options{type_constraint}; + + if($options{coerce}){ + defined($tc) + || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)"); + + $options{weak_ref} + && $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)"); + } + + if ($options{lazy_build}) { + exists($options{default}) + && $class->throw_error("You can not use lazy_build and default for the same attribute ($name)"); + + $options{lazy} = 1; + $options{builder} ||= "_build_${name}"; + if ($name =~ /^_/) { + $options{clearer} ||= "_clear${name}"; + $options{predicate} ||= "_has${name}"; + } + else { + $options{clearer} ||= "clear_${name}"; + $options{predicate} ||= "has_${name}"; + } + } + + if ($options{auto_deref}) { + defined($tc) + || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)"); + + ( $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)"); + } + + if (exists $options{trigger}) { + ('CODE' eq ref $options{trigger}) + || $class->throw_error("Trigger must be a CODE ref on attribute ($name)"); + } - my $is = $options{is} ||= ''; + if ($options{lazy}) { + (exists $options{default} || defined $options{builder}) + || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it"); + } - if($is eq 'rw'){ - $options{accessor} = $name if !exists $options{accessor}; + if(my $metaclass = delete $options{metaclass}){ + $class = Mouse::Util::resolve_metaclass_alias( Attribute => $metaclass ); } - elsif($is eq 'ro'){ - $options{reader} = $name if !exists $options{reader}; + + if(my $traits_ref = delete $options{traits}){ + my @traits; + for (my $i = 9; $i < @{$traits_ref}; $i++) { + my $trait = Mouse::Util::resolve_metaclass_alias(Attribute => $traits_ref->[$i], trait => 1); + + next if $class->does($trait); + + push @traits, $trait; + + # are there options? + push @traits, $traits_ref->[++$i] + if ref($traits_ref->[$i+1]); + } + + if (@traits) { + $class = Mouse::Meta::Class->create_anon_class( + superclasses => [ $class ], + roles => [ @traits ], + cache => 1, + )->name; + } } - bless \%options, $class; +# XXX: there is no fast way to check attribute validity +# my @bad = grep{ !exists $valid_attrs{$_} } keys %options; +# if(@bad){ +# @bad = sort @bad; +# Carp::cluck("Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad"); +# } + + return bless \%options, $class; } # readers @@ -47,14 +197,11 @@ 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} } # predicates @@ -80,25 +227,12 @@ sub accessor_metaclass { 'Mouse::Meta::Method::Accessor' } sub create { my ($self, $class, $name, %args) = @_; - $args{name} = $name; - $args{associated_class} = $class; - - %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); - } - my $attribute = $self->new($name, %args); $attribute->_create_args(\%args); $class->add_attribute($attribute); + weaken($attribute->{associated_class} = $class); my $associated_methods = 0; @@ -119,65 +253,6 @@ sub create { return $attribute; } -sub canonicalize_args { - my $self = shift; - my $name = shift; - my %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}); - } - } - - 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."); - } - - $self->throw_error("Trigger must be a CODE ref on attribute ($name)") - if ref($args->{trigger}) ne 'CODE'; - } - - return 1; -} - sub verify_against_type_constraint { my ($self, $value) = @_; my $tc = $self->type_constraint; @@ -337,3 +412,4 @@ C. =cut + \ No newline at end of file diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index c1e614a..1093e02 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -192,6 +192,10 @@ sub new_object { $trigger->($instance, $value); } + if($self->is_anon_class){ + $instance->{__METACLASS__} = $self; + } + return $instance; } 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/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index 8694163..dbd639e 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -6,7 +6,7 @@ use base 'Exporter'; use Carp (); use Scalar::Util qw/blessed looks_like_number openhandle/; -use Mouse::Util qw(does_role); +use Mouse::Util qw(does_role not_supported); use Mouse::Meta::Module; # class_of use Mouse::Meta::TypeConstraint; @@ -216,7 +216,7 @@ 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}; + subtype $name => (as => $conf->{class}); } else { subtype $name => ( @@ -229,14 +229,14 @@ sub role_type { my($name, $conf) = @_; my $role = $conf->{role}; subtype $name => ( - $name => where => sub { does_role($_, $role) }, + 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 ) { @@ -274,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); @@ -359,6 +362,10 @@ sub find_type_constraint { } } +sub find_or_create_does_type_constraint{ + not_supported; +} + sub find_or_create_isa_type_constraint { my $type_constraint = shift; @@ -369,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;