X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMethod%2FGenerate%2FAccessor.pm;h=d0ab97061a2654ea7cb7aa931bc0d2d3df78e169;hb=42865691a20eb4d33df037c9677b9766126c98ec;hp=10040e9928754b08a1bd1158e2d84fddca20eae4;hpb=9f10cfe08cb754b4cdb85c1ac771606fbb98c770;p=gitmo%2FMoo.git diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm index 10040e9..d0ab970 100644 --- a/lib/Method/Generate/Accessor.pm +++ b/lib/Method/Generate/Accessor.pm @@ -5,6 +5,9 @@ use Moo::_Utils; use base qw(Moo::Object); 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} @@ -15,14 +18,34 @@ BEGIN { ; } +sub _SIGDIE +{ + our ($CurrentAttribute, $OrigSigDie); + my $sigdie = $OrigSigDie && $OrigSigDie != \&_SIGDIE + ? $OrigSigDie + : sub { die $_[0] }; + + return $sigdie->(@_) if ref($_[0]); + + my $attr_desc = _attr_desc(@$CurrentAttribute{qw(name init_arg)}); + $sigdie->("$CurrentAttribute->{step} for $attr_desc failed: $_[0]"); +} + +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; @@ -33,7 +56,17 @@ sub generate_method { } elsif ($is ne 'bare') { die "Unknown is ${is}"; } - $spec->{builder} = '_build_'.$name if ($spec->{builder}||0) eq 1; + if (exists $spec->{builder}) { + if(ref $spec->{builder}) { + $self->_validate_codulatable('builder', $spec->{builder}, + "$into->$name", 'or a method name'); + $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}"; } @@ -43,8 +76,32 @@ sub generate_method { if (($spec->{trigger}||0) eq 1) { $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)'); } + + for my $setting (qw( isa coerce )) { + next if !exists $spec->{$setting}; + $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 @@ -60,6 +117,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) @@ -78,6 +137,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) @@ -95,14 +156,21 @@ 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}" => + quote_sub "${into}::${cl}" => $self->_generate_simple_clear('$_[0]', $name, $spec)."\n" ; } @@ -115,13 +183,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}" => @@ -132,9 +202,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} ; } @@ -161,7 +232,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 { @@ -170,13 +241,20 @@ 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), - ).'; '.$simple.' }'; + ); } } +sub generate_simple_has { + my $self = shift; + $self->{captures} = {}; + my $code = $self->_generate_simple_has(@_); + ($code, delete $self->{captures}); +} + sub _generate_simple_has { my ($self, $me, $name) = @_; "exists ${me}->{${\perlstring $name}}"; @@ -194,6 +272,13 @@ sub generate_get_default { ($code, delete $self->{captures}); } +sub generate_use_default { + my $self = shift; + $self->{captures} = {}; + my $code = $self->_generate_use_default(@_); + ($code, delete $self->{captures}); +} + sub _generate_use_default { my ($self, $me, $name, $spec, $test) = @_; my $get_value = $self->_generate_get_default($me, $name, $spec); @@ -203,16 +288,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 { @@ -232,22 +327,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"; + $code .= + " ".$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"; } @@ -263,11 +363,22 @@ 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) = @_; - $self->_generate_call_code($name, 'coerce', "${value}", $coerce); + my ($self, $name, $value, $coerce, $init_arg) = @_; + $self->_generate_die_prefix( + $name, + "coercion", + $init_arg, + $self->_generate_call_code($name, 'coerce', "${value}", $coerce) + ); } - + sub generate_trigger { my $self = shift; $self->{captures} = {}; @@ -287,24 +398,48 @@ sub generate_isa_check { ($code, delete $self->{captures}); } +sub _generate_die_prefix { + my ($self, $name, $prefix, $arg, $inside) = @_; + "do {\n" + .' local $Method::Generate::Accessor::CurrentAttribute = {' + .' init_arg => '.(defined $arg ? B::perlstring($arg) : 'undef') . ",\n" + .' name => '.B::perlstring($name).",\n" + .' step => '.B::perlstring($prefix).",\n" + ." };\n" + .' local $Method::Generate::Accessor::OrigSigDie = $SIG{__DIE__};'."\n" + .' local $SIG{__DIE__} = \&Method::Generate::Accessor::_SIGDIE;'."\n" + .$inside + ."}\n" +} + sub _generate_isa_check { - my ($self, $name, $value, $check) = @_; - $self->_generate_call_code($name, 'isa_check', $value, $check); + my ($self, $name, $value, $check, $init_arg) = @_; + $self->_generate_die_prefix( + $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]; - my $at_ = '@_ = ('.$values.');'; 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) + $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6), $local ); } else { - Sub::Quote::inlinify($code, $values); + Sub::Quote::inlinify($code, $values, undef, $local); } } else { my $cap_name = qq{\$${type}_for_${name}}; @@ -321,13 +456,13 @@ 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( - '$new', $_, $spec + '$new', $name, $spec ); - my $get_value = + my $get_value = defined($spec->{init_arg}) ? "(\n${get_indent} ${test}\n${get_indent} ? ${source}\n${get_indent} : " .$get_default @@ -336,13 +471,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" @@ -362,14 +497,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" : "" ) @@ -386,11 +521,6 @@ sub _generate_populate_set { } } -sub generate_multi_set { - my ($self, $me, $to_set, $from) = @_; - "\@{${me}}{qw(${\join ' ', @$to_set})} = $from"; -} - sub _generate_core_set { my ($self, $me, $name, $spec, $value) = @_; my $name_str = perlstring $name; @@ -400,11 +530,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: @@ -415,24 +545,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; } } @@ -442,6 +572,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 { @@ -469,4 +610,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;