From: Matt S Trout Date: Wed, 2 May 2012 20:10:38 +0000 (+0000) Subject: factor out accessor generation code a bit X-Git-Tag: v0.091002~20 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=02e9ef74cf0e746aad5bed3684661622017dad87;p=gitmo%2FMoo.git factor out accessor generation code a bit --- diff --git a/Changes b/Changes index 89b4f59..ef33b2e 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,5 @@ + - factor out accessor generation code a bit more to enable extension + 0.091001 - 2012-05-02 - bump Role::Tiny dependency to require de-strictures-ed version - fix test failure where Class::XSAccessor is not available diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm index ea5a4ed..9d15768 100644 --- a/lib/Method/Generate/Accessor.pm +++ b/lib/Method/Generate/Accessor.pm @@ -102,7 +102,7 @@ sub generate_method { if (my $cl = $spec->{clearer}) { $methods{$cl} = quote_sub "${into}::${cl}" => - " delete \$_[0]->{${\perlstring $name}}\n" + $self->_generate_simple_clear('$_[0]', $name)."\n" ; } if (my $hspec = $spec->{handles}) { @@ -181,6 +181,11 @@ sub _generate_simple_has { "exists ${me}->{${\perlstring $name}}"; } +sub _generate_simple_clear { + my ($self, $me, $name) = @_; + " delete ${me}->{${\perlstring $name}}\n" +} + sub generate_get_default { my $self = shift; $self->{captures} = {}; @@ -451,4 +456,6 @@ sub _generate_xs { $into->can($name); } +sub default_construction_string { '{}' } + 1; diff --git a/lib/Method/Generate/Constructor.pm b/lib/Method/Generate/Constructor.pm index 86c5afb..d24a457 100644 --- a/lib/Method/Generate/Constructor.pm +++ b/lib/Method/Generate/Constructor.pm @@ -7,8 +7,13 @@ use Sub::Defer; use B 'perlstring'; sub register_attribute_specs { - my ($self, %spec) = @_; - @{$self->{attribute_specs}||={}}{keys %spec} = values %spec; + my ($self, @new_specs) = @_; + my $specs = $self->{attribute_specs}||={}; + while (my ($name, $new_spec) = splice @new_specs, 0, 2) { + $new_spec->{index} = scalar keys %$specs + unless exists $new_spec->{index}; + $specs->{$name} = $new_spec; + } $self; } @@ -22,7 +27,10 @@ sub accessor_generator { sub construction_string { my ($self) = @_; - $self->{construction_string} or 'bless({}, $class);' + $self->{construction_string} + or 'bless(' + .$self->accessor_generator->default_construction_string + .', $class);' } sub install_delayed { diff --git a/lib/Moo.pm b/lib/Moo.pm index 1875989..6d402ae 100644 --- a/lib/Moo.pm +++ b/lib/Moo.pm @@ -33,12 +33,10 @@ sub import { $MAKERS{$target} = {}; _install_coderef "${target}::has" => sub { my ($name, %spec) = @_; - ($MAKERS{$target}{accessor} ||= do { - require Method::Generate::Accessor; - Method::Generate::Accessor->new - })->generate_method($target, $name, \%spec); $class->_constructor_maker_for($target) ->register_attribute_specs($name, \%spec); + $class->_accessor_maker_for($target) + ->generate_method($target, $name, \%spec); }; foreach my $type (qw(before after around)) { _install_coderef "${target}::${type}" => sub { @@ -57,6 +55,31 @@ sub import { } } +sub _accessor_maker_for { + my ($class, $target) = @_; + return unless $MAKERS{$target}; + $MAKERS{$target}{accessor} ||= do { + my $maker_class = do { + if (my $m = do { + if (my $defer_target = + (Sub::Defer::defer_info($target->can('new'))||[])->[0] + ) { + my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/); + $MAKERS{$pkg} && $MAKERS{$pkg}{accessor}; + } else { + undef; + } + }) { + ref($m); + } else { + require Method::Generate::Accessor; + 'Method::Generate::Accessor' + } + }; + $maker_class->new; + } +} + sub _constructor_maker_for { my ($class, $target, $select_super) = @_; return unless $MAKERS{$target}; @@ -84,13 +107,10 @@ sub _constructor_maker_for { $moo_constructor = 1; # no other constructor, make a Moo one } }; - Method::Generate::Constructor + ($con ? ref($con) : 'Method::Generate::Constructor') ->new( package => $target, - accessor_generator => do { - require Method::Generate::Accessor; - Method::Generate::Accessor->new; - }, + accessor_generator => $class->_accessor_maker_for($target), construction_string => ( $moo_constructor ? ($con ? $con->construction_string : undef)