X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMethod%2FGenerate%2FAccessor.pm;h=8c4b19d6acb5a899e59313e37d8132a650df42b5;hb=99f21475b6ad64c2cb8882ab240f04f1165f3159;hp=c644919ada771e8a43aadf7c3927c59ff193c477;hpb=463df7d2c4547f18a633e204bda2f955d27cef30;p=gitmo%2FMoo.git diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm index c644919..8c4b19d 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; @@ -35,9 +43,19 @@ sub generate_method { } elsif ($is ne 'bare') { die "Unknown is ${is}"; } - $spec->{builder} = '_build_'.$name if ($spec->{builder}||0) eq 1; - die "Invalid builder for $into->$name - not a string" - if exists $spec->{builder} and ref $spec->{builder}; + if (exists $spec->{builder}) { + if(ref $spec->{builder}) { + die "Invalid builder for $into->$name - not a method name, coderef or" + . " code-convertible object" + unless ref $spec->{builder} eq 'CODE' + or (blessed($spec->{builder}) and eval { \&{$spec->{builder}} }); + $spec->{builder_sub} = $spec->{builder}; + $spec->{builder} = 1; + } + $spec->{builder} = '_build_'.$name if ($spec->{builder}||0) eq 1; + die "Invalid builder for $into->$name - not a valid method name" + if $spec->{builder} !~ /\A[A-Za-z_][A-Za-z0-9_]*(?:::[A-Za-z_][A-Za-z0-9_]*)*\z/; + } if (($spec->{predicate}||0) eq 1) { $spec->{predicate} = $name =~ /^_/ ? "_has${name}" : "has_${name}"; } @@ -48,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 @@ -76,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) @@ -94,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) @@ -111,12 +145,19 @@ 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" ; } + if (my $pred = $spec->{builder_sub}) { + _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" @@ -131,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}" => @@ -148,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} ; } @@ -177,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 { @@ -186,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.' }'; + ); } } @@ -224,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 { @@ -253,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"; } @@ -284,10 +338,18 @@ sub generate_coerce { ($code, delete $self->{captures}); } +sub _attr_desc { + my ($name, $init_arg) = @_; + return perlstring($name) if !defined($init_arg) or $init_arg eq $name; + return perlstring($name).' (constructor argument: '.perlstring($init_arg).')'; +} + sub _generate_coerce { - my ($self, $name, $value, $coerce) = @_; + my ($self, $name, $value, $coerce, $init_arg) = @_; $self->_generate_die_prefix( - "coercion for ${\perlstring($name)} failed: ", + $name, + "coercion", + $init_arg, $self->_generate_call_code($name, 'coerce', "${value}", $coerce) ); } @@ -312,36 +374,62 @@ sub generate_isa_check { } sub _generate_die_prefix { - my ($self, $prefix, $inside) = @_; + my ($self, $name, $prefix, $init_arg, $inside) = @_; + + $self->{captures}{'$__DIE__'} ||= \ sub { + our ($CurrentArgument, $CurrentAttribute, $CurrentStep, $OrigSigDie); + $OrigSigDie ||= sub { die $_[0] }; + + $OrigSigDie->( + qq[$CurrentStep for "$CurrentAttribute"] + . ($CurrentArgument && ($CurrentArgument ne $CurrentAttribute) + ? qq[ (constructor argument: "$CurrentArgument")] + : "") + . qq[ failed: $_[0]] + ); + }; + "do {\n" - .' my $sig_die = $SIG{__DIE__} || sub { die $_[0] };'."\n" - .' local $SIG{__DIE__} = sub {'."\n" - .' $sig_die->(ref($_[0]) ? $_[0] : '.perlstring($prefix).'.$_[0]);'."\n" - .' };'."\n" + .' local $Method::Generate::Accessor::CurrentArgument = ' + . B::perlstring($init_arg) . ";\n" + .' local $Method::Generate::Accessor::CurrentAttribute = ' + . B::perlstring($name) . ";\n" + .' local $Method::Generate::Accessor::CurrentStep = ' + . B::perlstring($prefix) . ";\n" + .' local $Method::Generate::Accessor::OrigSigDie = $SIG{__DIE__};'."\n" + .' local $SIG{__DIE__} = $__DIE__;'."\n" .$inside ."}\n" } sub _generate_isa_check { - my ($self, $name, $value, $check) = @_; + my ($self, $name, $value, $check, $init_arg) = @_; $self->_generate_die_prefix( - "isa check for ${\perlstring($name)} failed: ", + $name, + "isa check", + $init_arg, $self->_generate_call_code($name, 'isa_check', $value, $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}}; @@ -358,7 +446,7 @@ sub generate_populate_set { } sub _generate_populate_set { - my ($self, $me, $name, $spec, $source, $test) = @_; + my ($self, $me, $name, $spec, $source, $test, $init_arg) = @_; if ($self->has_eager_default($name, $spec)) { my $get_indent = ' ' x ($spec->{isa} ? 6 : 4); my $get_default = $self->_generate_get_default( @@ -373,13 +461,13 @@ sub _generate_populate_set { if ($spec->{coerce}) { $get_value = $self->_generate_coerce( $name, $get_value, - $spec->{coerce} + $spec->{coerce}, $init_arg ) } ($spec->{isa} ? " {\n my \$value = ".$get_value.";\n " .$self->_generate_isa_check( - $name, '$value', $spec->{isa} + $name, '$value', $spec->{isa}, $init_arg ).";\n" .' '.$self->_generate_simple_set($me, $name, $spec, '$value').";\n" ." }\n" @@ -399,14 +487,14 @@ sub _generate_populate_set { ? " $source = " .$self->_generate_coerce( $name, $source, - $spec->{coerce} + $spec->{coerce}, $init_arg ).";\n" : "" ) .($spec->{isa} ? " " .$self->_generate_isa_check( - $name, $source, $spec->{isa} + $name, $source, $spec->{isa}, $init_arg ).";\n" : "" ) @@ -432,11 +520,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: @@ -447,24 +535,24 @@ 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})"; + 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 } or do { - if( \$@ =~ /Modification of a read-only value attempted/) { - require Carp; - Carp::croak( sprintf ( - 'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3', - $name_str, - ) ); - } else { - die \$@; + eval { Scalar::Util::weaken($simple); 1 } + ? do { no warnings 'void'; $get } + : do { + if( \$@ =~ /Modification of a read-only value attempted/) { + require Carp; + Carp::croak( sprintf ( + 'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3', + $name_str, + ) ); + } else { + die \$@; + } } - }; EOC } else { - $self->_generate_core_set($me, $name, $spec, $value); + $simple; } } @@ -474,6 +562,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 { @@ -501,4 +600,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;