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=594c81c58c70be58c441069a05f00f176848bb64;hpb=6d92e9d862d632eccdb89205bddf3ca29ce83a83;p=gitmo%2FMoo.git diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm index 594c81c..d0ab970 100644 --- a/lib/Method/Generate/Accessor.pm +++ b/lib/Method/Generate/Accessor.pm @@ -18,6 +18,19 @@ 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) = @_; @@ -45,10 +58,8 @@ sub generate_method { } 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}} }); + $self->_validate_codulatable('builder', $spec->{builder}, + "$into->$name", 'or a method name'); $spec->{builder_sub} = $spec->{builder}; $spec->{builder} = 1; } @@ -66,28 +77,26 @@ sub generate_method { $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)'); } - if (exists $spec->{coerce}) { - my $value = $spec->{coerce}; - my $invalid = "Invalid coerce '" . 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 }; + for my $setting (qw( isa coerce )) { + next if !exists $spec->{$setting}; + $self->_validate_codulatable($setting, $spec->{$setting}, "$into->$name"); } if (exists $spec->{default}) { - my $value = $spec->{default}; - if (!defined $value || ref $value) { - my $invalid = "Invalid default '" . overload::StrVal($value) - . "' for $into->$name - not a coderef or non-ref"; - 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 }; + 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}) { @@ -161,7 +170,7 @@ sub generate_method { _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" ; } @@ -223,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 { @@ -232,18 +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), - ).'; ' - .($spec->{isa} - ?($self->_generate_isa_check($name, $simple, $spec->{isa}).'; ') - :'' - ) - .$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}}"; @@ -261,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); @@ -270,9 +288,14 @@ 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 { @@ -304,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"; } @@ -344,11 +372,13 @@ sub _attr_desc { sub _generate_coerce { my ($self, $name, $value, $coerce, $init_arg) = @_; $self->_generate_die_prefix( - "coercion for ${\_attr_desc($name, $init_arg)} failed: ", + $name, + "coercion", + $init_arg, $self->_generate_call_code($name, 'coerce', "${value}", $coerce) ); } - + sub generate_trigger { my $self = shift; $self->{captures} = {}; @@ -369,12 +399,15 @@ sub generate_isa_check { } sub _generate_die_prefix { - my ($self, $prefix, $inside) = @_; + my ($self, $name, $prefix, $arg, $inside) = @_; "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::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" } @@ -382,23 +415,31 @@ sub _generate_die_prefix { sub _generate_isa_check { my ($self, $name, $value, $check, $init_arg) = @_; $self->_generate_die_prefix( - "isa check for ${\_attr_desc($name, $init_arg)} 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}}; @@ -419,9 +460,9 @@ sub _generate_populate_set { 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 @@ -489,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: @@ -504,12 +545,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; @@ -523,7 +562,7 @@ sub _generate_simple_set { } EOC } else { - $self->_generate_core_set($me, $name, $spec, $value); + $simple; } } @@ -538,7 +577,7 @@ sub _generate_asserter { "do {\n" ." my \$val = ".$self->_generate_get($name, $spec).";\n" - ." unless (".$self->_generate_simple_has('$_[0]', $name).") {\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" @@ -571,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;