X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMethod%2FGenerate%2FAccessor.pm;h=4650b19805a6bec9f6e7324be2088ffef07bee04;hb=142218d42fdb85a3394552cbcbfae6a72dc89477;hp=7a7bc26abaa03ac02f8944bddea2f5a3d746582a;hpb=4752c97bb22149613a59912fa5a23b865cadef54;p=gitmo%2FMoo.git diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm index 7a7bc26..4650b19 100644 --- a/lib/Method/Generate/Accessor.pm +++ b/lib/Method/Generate/Accessor.pm @@ -7,6 +7,7 @@ use Sub::Quote; use B 'perlstring'; use Scalar::Util 'blessed'; use overload (); +use Module::Runtime qw(use_module); BEGIN { our $CAN_HAZ_XS = !$ENV{MOO_XS_DISABLE} @@ -17,14 +18,21 @@ BEGIN { ; } +sub _die_overwrite +{ + my ($pkg, $method, $type) = @_; + die "You cannot overwrite a locally defined method ($method) with @{[ $type || 'an accessor' ]}"; +} + sub generate_method { my ($self, $into, $name, $spec, $quote_opts) = @_; - $name =~ s/^\+//; + $spec->{allow_overwrite}++ if $name =~ s/^\+//; die "Must have an is" unless my $is = $spec->{is}; if ($is eq 'ro') { $spec->{reader} = $name unless exists $spec->{reader}; } elsif ($is eq 'rw') { - $spec->{accessor} = $name unless exists $spec->{accessor}; + $spec->{accessor} = $name unless exists $spec->{accessor} + or ( $spec->{reader} and $spec->{writer} ); } elsif ($is eq 'lazy') { $spec->{reader} = $name unless exists $spec->{reader}; $spec->{lazy} = 1; @@ -58,19 +66,31 @@ sub generate_method { $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)'); } - for my $setting (qw( default coerce )) { + for my $setting (qw( isa coerce )) { next if !exists $spec->{$setting}; - my $value = $spec->{$setting}; - my $invalid = "Invalid $setting '" . overload::StrVal($value) - . "' for $into->$name - not a coderef"; - die "$invalid or code-convertible object" - unless ref $value and (ref $value eq 'CODE' or blessed($value)); - die "$invalid and could not be converted to a coderef: $@" - if !eval { \&$value }; + $self->_validate_codulatable($setting, $spec->{$setting}, "$into->$name"); + } + + if (exists $spec->{default}) { + if (!defined $spec->{default} || ref $spec->{default}) { + $self->_validate_codulatable('default', $spec->{default}, "$into->$name", 'or a non-ref'); + } + } + + if (exists $spec->{moosify}) { + if (ref $spec->{moosify} ne 'ARRAY') { + $spec->{moosify} = [$spec->{moosify}]; + } + + for my $spec (@{$spec->{moosify}}) { + $self->_validate_codulatable('moosify', $spec, "$into->$name"); + } } my %methods; if (my $reader = $spec->{reader}) { + _die_overwrite($into, $reader, 'a reader') + if !$spec->{allow_overwrite} && *{_getglob("${into}::${reader}")}{CODE}; if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) { $methods{$reader} = $self->_generate_xs( getters => $into, $reader, $name, $spec @@ -86,6 +106,8 @@ sub generate_method { } } if (my $accessor = $spec->{accessor}) { + _die_overwrite($into, $accessor, 'an accessor') + if !$spec->{allow_overwrite} && *{_getglob("${into}::${accessor}")}{CODE}; if ( our $CAN_HAZ_XS && $self->is_simple_get($name, $spec) @@ -104,6 +126,8 @@ sub generate_method { } } if (my $writer = $spec->{writer}) { + _die_overwrite($into, $writer, 'a writer') + if !$spec->{allow_overwrite} && *{_getglob("${into}::${writer}")}{CODE}; if ( our $CAN_HAZ_XS && $self->is_simple_set($name, $spec) @@ -121,6 +145,8 @@ sub generate_method { } } if (my $pred = $spec->{predicate}) { + _die_overwrite($into, $pred, 'a predicate') + if !$spec->{allow_overwrite} && *{_getglob("${into}::${pred}")}{CODE}; $methods{$pred} = quote_sub "${into}::${pred}" => ' '.$self->_generate_simple_has('$_[0]', $name, $spec)."\n" @@ -130,6 +156,8 @@ sub generate_method { _install_coderef( "${into}::$spec->{builder}" => $spec->{builder_sub} ); } if (my $cl = $spec->{clearer}) { + _die_overwrite($into, $cl, 'a clearer') + if !$spec->{allow_overwrite} && *{_getglob("${into}::${cl}")}{CODE}; $methods{$cl} = quote_sub "${into}::${cl}" => $self->_generate_simple_clear('$_[0]', $name, $spec)."\n" @@ -144,13 +172,15 @@ sub generate_method { map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ], keys %$hspec; } elsif (!ref($hspec)) { - map [ $_ => $_ ], Role::Tiny->methods_provided_by($hspec); + map [ $_ => $_ ], use_module('Role::Tiny')->methods_provided_by(use_module($hspec)) } else { die "You gave me a handles of ${hspec} and I have no idea why"; } }; - foreach my $spec (@specs) { - my ($proxy, $target, @args) = @$spec; + foreach my $delegation_spec (@specs) { + my ($proxy, $target, @args) = @$delegation_spec; + _die_overwrite($into, $proxy, 'a delegation') + if !$spec->{allow_overwrite} && *{_getglob("${into}::${proxy}")}{CODE}; $self->{captures} = {}; $methods{$proxy} = quote_sub "${into}::${proxy}" => @@ -161,9 +191,10 @@ sub generate_method { } if (my $asserter = $spec->{asserter}) { $self->{captures} = {}; + + $methods{$asserter} = - quote_sub "${into}::${asserter}" => - 'do { '.$self->_generate_get($name, $spec).qq! }||die "Attempted to access '${name}' but it is not set"!, + quote_sub "${into}::${asserter}" => $self->_generate_asserter($name, $spec), delete $self->{captures} ; } @@ -190,7 +221,7 @@ sub is_simple_set { sub has_eager_default { my ($self, $name, $spec) = @_; - (!$spec->{lazy} and ($spec->{default} or $spec->{builder})); + (!$spec->{lazy} and (exists $spec->{default} or $spec->{builder})); } sub _generate_get { @@ -199,15 +230,10 @@ sub _generate_get { if ($self->is_simple_get($name, $spec)) { $simple; } else { - 'do { '.$self->_generate_use_default( + $self->_generate_use_default( '$_[0]', $name, $spec, $self->_generate_simple_has('$_[0]', $name, $spec), - ).'; ' - .($spec->{isa} - ?($self->_generate_isa_check($name, $simple, $spec->{isa}).'; ') - :'' - ) - .$simple.' }'; + ); } } @@ -237,16 +263,26 @@ sub _generate_use_default { $spec->{coerce} ) } - $self->_generate_simple_set( - $me, $name, $spec, $get_value - ).' unless '.$test; + $test." ? \n" + .$self->_generate_simple_get($me, $name, $spec)."\n:" + .($spec->{isa} + ? " do {\n my \$value = ".$get_value.";\n" + ." ".$self->_generate_isa_check($name, '$value', $spec->{isa}).";\n" + ." ".$self->_generate_simple_set($me, $name, $spec, '$value')."\n" + ." }\n" + : ' ('.$self->_generate_simple_set($me, $name, $spec, $get_value).")\n"); } sub _generate_get_default { my ($self, $me, $name, $spec) = @_; - $spec->{default} - ? $self->_generate_call_code($name, 'default', $me, $spec->{default}) - : "${me}->${\$spec->{builder}}" + if (exists $spec->{default}) { + ref $spec->{default} + ? $self->_generate_call_code($name, 'default', $me, $spec->{default}) + : perlstring $spec->{default}; + } + else { + "${me}->${\$spec->{builder}}" + } } sub generate_simple_get { @@ -266,22 +302,27 @@ sub _generate_set { $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]'); } else { my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)}; - my $simple = $self->_generate_simple_set('$self', $name, $spec, '$value'); - my $code = "do { my (\$self, \$value) = \@_;\n"; + my $value_store = '$_[0]'; + my $code; if ($coerce) { - $code .= - " \$value = " - .$self->_generate_coerce($name, '$value', $coerce).";\n"; + $value_store = '$value'; + $code = "do { my (\$self, \$value) = \@_;\n" + ." \$value = " + .$self->_generate_coerce($name, $value_store, $coerce).";\n"; + } + else { + $code = "do { my \$self = shift;\n"; } if ($isa_check) { $code .= - " ".$self->_generate_isa_check($name, '$value', $isa_check).";\n"; + " ".$self->_generate_isa_check($name, $value_store, $isa_check).";\n"; } + my $simple = $self->_generate_simple_set('$self', $name, $spec, $value_store); if ($trigger) { - my $fire = $self->_generate_trigger($name, '$self', '$value', $trigger); + my $fire = $self->_generate_trigger($name, '$self', $value_store, $trigger); $code .= " ".$simple.";\n ".$fire.";\n" - ." \$value;\n"; + ." $value_store;\n"; } else { $code .= " ".$simple.";\n"; } @@ -351,16 +392,22 @@ sub _generate_isa_check { sub _generate_call_code { my ($self, $name, $type, $values, $sub) = @_; + $sub = \&{$sub} if blessed($sub); # coderef if blessed if (my $quoted = quoted_from_sub($sub)) { + my $local = 1; + if ($values eq '@_' || $values eq '$_[0]') { + $local = 0; + $values = '@_'; + } my $code = $quoted->[1]; if (my $captures = $quoted->[2]) { my $cap_name = qq{\$${type}_captures_for_${name}}; $self->{captures}->{$cap_name} = \$captures; Sub::Quote::inlinify( - $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6), 1 + $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6), $local ); } else { - Sub::Quote::inlinify($code, $values, undef, 1); + Sub::Quote::inlinify($code, $values, undef, $local); } } else { my $cap_name = qq{\$${type}_for_${name}}; @@ -451,11 +498,11 @@ sub _generate_core_set { sub _generate_simple_set { my ($self, $me, $name, $spec, $value) = @_; my $name_str = perlstring $name; + my $simple = $self->_generate_core_set($me, $name, $spec, $value); if ($spec->{weak_ref}) { - $value = '$preserve = '.$value; - my $simple = $self->_generate_core_set($me, $name, $spec, $value); require Scalar::Util; + my $get = $self->_generate_simple_get($me, $name, $spec); # Perl < 5.8.3 can't weaken refs to readonly vars # (e.g. string constants). This *can* be solved by: @@ -466,12 +513,10 @@ sub _generate_simple_set { # # but requires XS and is just too damn crazy # so simply throw a better exception - my $weak_simple = "my \$preserve; Scalar::Util::weaken(${simple}); no warnings 'void'; \$preserve"; + my $weak_simple = "do { Scalar::Util::weaken(${simple}); no warnings 'void'; $get }"; Moo::_Utils::lt_5_8_3() ? <<"EOC" : $weak_simple; - - my \$preserve; eval { Scalar::Util::weaken($simple); 1 } - ? do { no warnings 'void'; \$preserve; } + ? do { no warnings 'void'; $get } : do { if( \$@ =~ /Modification of a read-only value attempted/) { require Carp; @@ -485,7 +530,7 @@ sub _generate_simple_set { } EOC } else { - $self->_generate_core_set($me, $name, $spec, $value); + $simple; } } @@ -495,6 +540,17 @@ sub _generate_getset { ."\n : ".$self->_generate_get($name, $spec)."\n )"; } +sub _generate_asserter { + my ($self, $name, $spec) = @_; + + "do {\n" + ." my \$val = ".$self->_generate_get($name, $spec).";\n" + ." unless (".$self->_generate_simple_has('$_[0]', $name, $spec).") {\n" + .qq! die "Attempted to access '${name}' but it is not set";\n! + ." }\n" + ." \$val;\n" + ."}\n"; +} sub _generate_delegation { my ($self, $asserter, $target, $args) = @_; my $arg_string = do { @@ -522,4 +578,21 @@ sub _generate_xs { sub default_construction_string { '{}' } +sub _validate_codulatable { + my ($self, $setting, $value, $into, $appended) = @_; + my $invalid = "Invalid $setting '" . overload::StrVal($value) + . "' for $into not a coderef"; + $invalid .= " $appended" if $appended; + + unless (ref $value and (ref $value eq 'CODE' or blessed($value))) { + die "$invalid or code-convertible object"; + } + + unless (eval { \&$value }) { + die "$invalid and could not be converted to a coderef: $@"; + } + + 1; +} + 1;