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=65173ef5be2b477b0ee22e2e07b9b36772c62753;hpb=82a5b14633cd191acbfa31c8ace0569baa85183a;p=gitmo%2FMoo.git diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm index 65173ef..bfecf26 100644 --- a/lib/Method/Generate/Accessor.pm +++ b/lib/Method/Generate/Accessor.pm @@ -5,40 +5,73 @@ 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} + && _maybe_load_module('Class::XSAccessor') && - (Class::XSAccessor->VERSION > 1.06) + (eval { Class::XSAccessor->VERSION('1.07') }) ; } 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} = {}; $methods{$reader} = quote_sub "${into}::${reader}" - => $self->_generate_get($name, $spec) + => ' die "'.$reader.' is a read-only accessor" if @_ > 1;'."\n" + .$self->_generate_get($name, $spec) => delete $self->{captures} ; } @@ -50,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} = {}; @@ -67,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} = {}; @@ -81,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}) { @@ -150,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.' }'; } } @@ -166,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} = {}; @@ -175,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; } @@ -209,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 .= @@ -236,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 { @@ -259,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}}; @@ -305,6 +371,12 @@ sub _generate_populate_set { .$get_default ."\n${get_indent})" : $get_default; + if ($spec->{coerce}) { + $get_value = $self->_generate_coerce( + $name, $get_value, + $spec->{coerce} + ) + } ($spec->{isa} ? " {\n my \$value = ".$get_value.";\n " .$self->_generate_isa_check( @@ -317,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" : '' @@ -327,7 +399,7 @@ sub _generate_populate_set { .($spec->{coerce} ? " $source = " .$self->_generate_coerce( - $name, $me, $source, + $name, $source, $spec->{coerce} ).";\n" : "" @@ -343,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" : "" @@ -352,17 +424,19 @@ 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}) { + $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 @@ -374,8 +448,10 @@ 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/) { require Carp; @@ -389,7 +465,7 @@ sub _generate_simple_set { }; EOC } else { - $simple; + $self->_generate_core_set($me, $name, $spec, $value); } } @@ -418,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;