X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMethod%2FGenerate%2FAccessor.pm;h=bfecf26c8d30f313ba2be576a33cd36de3d0dec8;hb=5a1cfeaac93cc99bb25f45e7f68b400bad1a6bac;hp=204330b6ed150d8911828b94f4b391c061af57b3;hpb=673eb4988f20b57235a6e8b9ff7035b95ba98baa;p=gitmo%2FMoo.git diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm index 204330b..bfecf26 100644 --- a/lib/Method/Generate/Accessor.pm +++ b/lib/Method/Generate/Accessor.pm @@ -5,6 +5,8 @@ use Moo::_Utils; use base qw(Moo::Object); use Sub::Quote; use B 'perlstring'; +use Scalar::Util 'blessed'; +use overload (); BEGIN { our $CAN_HAZ_XS = !$ENV{MOO_XS_DISABLE} @@ -17,24 +19,52 @@ BEGIN { sub generate_method { my ($self, $into, $name, $spec, $quote_opts) = @_; + $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}; } elsif ($is eq 'lazy') { - $spec->{init_arg} = undef unless exists $spec->{init_arg}; $spec->{reader} = $name unless exists $spec->{reader}; $spec->{lazy} = 1; $spec->{builder} ||= '_build_'.$name unless $spec->{default}; + } elsif ($is eq 'rwp') { + $spec->{reader} = $name unless exists $spec->{reader}; + $spec->{writer} = "_set_${name}" unless exists $spec->{writer}; } 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 valid method name" + if exists $spec->{builder} and (ref $spec->{builder} + or $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}"; + } + if (($spec->{clearer}||0) eq 1) { + $spec->{clearer} = $name =~ /^_/ ? "_clear${name}" : "clear_${name}"; + } + if (($spec->{trigger}||0) eq 1) { + $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)'); + } + + for my $setting (qw( default 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 }; + } + my %methods; if (my $reader = $spec->{reader}) { if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) { $methods{$reader} = $self->_generate_xs( - getters => $into, $reader, $name + getters => $into, $reader, $name, $spec ); } else { $self->{captures} = {}; @@ -53,7 +83,7 @@ sub generate_method { && $self->is_simple_set($name, $spec) ) { $methods{$accessor} = $self->_generate_xs( - accessors => $into, $accessor, $name + accessors => $into, $accessor, $name, $spec ); } else { $self->{captures} = {}; @@ -70,7 +100,7 @@ sub generate_method { && $self->is_simple_set($name, $spec) ) { $methods{$writer} = $self->_generate_xs( - setters => $into, $writer, $name + setters => $into, $writer, $name, $spec ); } else { $self->{captures} = {}; @@ -84,13 +114,13 @@ sub generate_method { if (my $pred = $spec->{predicate}) { $methods{$pred} = quote_sub "${into}::${pred}" => - ' '.$self->_generate_simple_has('$_[0]', $name)."\n" + ' '.$self->_generate_simple_has('$_[0]', $name, $spec)."\n" ; } if (my $cl = $spec->{clearer}) { $methods{$cl} = quote_sub "${into}::${cl}" => - " delete \$_[0]->{${\perlstring $name}}\n" + $self->_generate_simple_clear('$_[0]', $name, $spec)."\n" ; } if (my $hspec = $spec->{handles}) { @@ -153,14 +183,19 @@ sub has_eager_default { sub _generate_get { my ($self, $name, $spec) = @_; - my $simple = $self->_generate_simple_get('$_[0]', $name); + my $simple = $self->_generate_simple_get('$_[0]', $name, $spec); if ($self->is_simple_get($name, $spec)) { $simple; } else { 'do { '.$self->_generate_use_default( '$_[0]', $name, $spec, - $self->_generate_simple_has('$_[0]', $name), - ).'; '.$simple.' }'; + $self->_generate_simple_has('$_[0]', $name, $spec), + ).'; ' + .($spec->{isa} + ?($self->_generate_isa_check($name, $simple, $spec->{isa}).'; ') + :'' + ) + .$simple.' }'; } } @@ -169,6 +204,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} = {}; @@ -178,8 +218,15 @@ sub generate_get_default { sub _generate_use_default { my ($self, $me, $name, $spec, $test) = @_; + my $get_value = $self->_generate_get_default($me, $name, $spec); + if ($spec->{coerce}) { + $get_value = $self->_generate_coerce( + $name, $get_value, + $spec->{coerce} + ) + } $self->_generate_simple_set( - $me, $name, $spec, $self->_generate_get_default($me, $name, $spec) + $me, $name, $spec, $get_value ).' unless '.$test; } @@ -212,7 +259,7 @@ sub _generate_set { if ($coerce) { $code .= " \$value = " - .$self->_generate_coerce($name, '$self', '$value', $coerce).";\n"; + .$self->_generate_coerce($name, '$value', $coerce).";\n"; } if ($isa_check) { $code .= @@ -239,8 +286,11 @@ sub generate_coerce { } sub _generate_coerce { - my ($self, $name, $obj, $value, $coerce) = @_; - $self->_generate_call_code($name, 'coerce', "${value}", $coerce); + my ($self, $name, $value, $coerce) = @_; + $self->_generate_die_prefix( + "coercion for ${\perlstring($name)} failed: ", + $self->_generate_call_code($name, 'coerce', "${value}", $coerce) + ); } sub generate_trigger { @@ -262,24 +312,37 @@ sub generate_isa_check { ($code, delete $self->{captures}); } +sub _generate_die_prefix { + my ($self, $prefix, $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" + .$inside + ."}\n" +} + sub _generate_isa_check { my ($self, $name, $value, $check) = @_; - $self->_generate_call_code($name, 'isa_check', $value, $check); + $self->_generate_die_prefix( + "isa check for ${\perlstring($name)} failed: ", + $self->_generate_call_code($name, 'isa_check', $value, $check) + ); } sub _generate_call_code { my ($self, $name, $type, $values, $sub) = @_; if (my $quoted = quoted_from_sub($sub)) { 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), 1 ); } else { - Sub::Quote::inlinify($code, $values); + Sub::Quote::inlinify($code, $values, undef, 1); } } else { my $cap_name = qq{\$${type}_for_${name}}; @@ -308,11 +371,11 @@ sub _generate_populate_set { .$get_default ."\n${get_indent})" : $get_default; - if ( $spec->{coerce} ) { - $get_value = $self->_generate_coerce( - $name, $me, $get_value, - $spec->{coerce} - ) + if ($spec->{coerce}) { + $get_value = $self->_generate_coerce( + $name, $get_value, + $spec->{coerce} + ) } ($spec->{isa} ? " {\n my \$value = ".$get_value.";\n " @@ -326,7 +389,7 @@ sub _generate_populate_set { .($spec->{trigger} ? ' ' .$self->_generate_trigger( - $name, $me, $self->_generate_simple_get($me, $name), + $name, $me, $self->_generate_simple_get($me, $name, $spec), $spec->{trigger} )." if ${test};\n" : '' @@ -336,7 +399,7 @@ sub _generate_populate_set { .($spec->{coerce} ? " $source = " .$self->_generate_coerce( - $name, $me, $source, + $name, $source, $spec->{coerce} ).";\n" : "" @@ -352,7 +415,7 @@ sub _generate_populate_set { .($spec->{trigger} ? " " .$self->_generate_trigger( - $name, $me, $self->_generate_simple_get($me, $name), + $name, $me, $self->_generate_simple_get($me, $name, $spec), $spec->{trigger} ).";\n" : "" @@ -361,18 +424,20 @@ 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; + "${me}->{${name_str}} = ${value}"; } sub _generate_simple_set { my ($self, $me, $name, $spec, $value) = @_; my $name_str = perlstring $name; - my $simple = "${me}->{${name_str}} = ${value}"; if ($spec->{weak_ref}) { - { local $@; require Scalar::Util; } + $value = '$preserve = '.$value; + my $simple = $self->_generate_core_set($me, $name, $spec, $value); + require Scalar::Util; # Perl < 5.8.3 can't weaken refs to readonly vars # (e.g. string constants). This *can* be solved by: @@ -383,11 +448,13 @@ sub _generate_simple_set { # # but requires XS and is just too damn crazy # so simply throw a better exception - Moo::_Utils::lt_5_8_3() ? <<"EOC" : "Scalar::Util::weaken(${simple})"; + my $weak_simple = "my \$preserve; Scalar::Util::weaken(${simple})"; + 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/) { - { local \$@; require Carp; } + require Carp; Carp::croak( sprintf ( 'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3', $name_str, @@ -398,7 +465,7 @@ sub _generate_simple_set { }; EOC } else { - $simple; + $self->_generate_core_set($me, $name, $spec, $value); } } @@ -427,9 +494,12 @@ sub _generate_xs { my ($self, $type, $into, $name, $slot) = @_; Class::XSAccessor->import( class => $into, - $type => { $name => $slot } + $type => { $name => $slot }, + replace => 1, ); $into->can($name); } +sub default_construction_string { '{}' } + 1;