X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMethod%2FGenerate%2FAccessor.pm;h=135ec698223450d1658f459a52d7d8f91eebbadb;hb=2f425b5770149d4ed2e59da001c3be052cbd6bc1;hp=f8b1fbf09f23c1014ba8264cbaed78efa65f6e01;hpb=59812c87b1b00da1098f22c77e02db83ff594f22;p=gitmo%2FMoo.git diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm index f8b1fbf..135ec69 100644 --- a/lib/Method/Generate/Accessor.pm +++ b/lib/Method/Generate/Accessor.pm @@ -5,36 +5,97 @@ 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} && _maybe_load_module('Class::XSAccessor') && - (Class::XSAccessor->VERSION > 1.06) + (eval { Class::XSAccessor->VERSION('1.07') }) ; } +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) = @_; + $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->{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}"; } + 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}"; + } + 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.'(@_)'); + } + + 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 }; + } + + 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 }; + } + } + + 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 + getters => $into, $reader, $name, $spec ); } else { $self->{captures} = {}; @@ -47,13 +108,15 @@ 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) && $self->is_simple_set($name, $spec) ) { $methods{$accessor} = $self->_generate_xs( - accessors => $into, $accessor, $name + accessors => $into, $accessor, $name, $spec ); } else { $self->{captures} = {}; @@ -65,12 +128,14 @@ 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) ) { $methods{$writer} = $self->_generate_xs( - setters => $into, $writer, $name + setters => $into, $writer, $name, $spec ); } else { $self->{captures} = {}; @@ -82,15 +147,22 @@ 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)."\n" + ' '.$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}" => - " delete \$_[0]->{${\perlstring $name}}\n" + $self->_generate_simple_clear('$_[0]', $name, $spec)."\n" ; } if (my $hspec = $spec->{handles}) { @@ -102,13 +174,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}" => @@ -119,9 +193,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} ; } @@ -153,14 +228,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 +249,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,16 +263,28 @@ 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; } 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 { @@ -212,7 +309,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 .= @@ -238,9 +335,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, $obj, $value, $coerce) = @_; - $self->_generate_call_code($name, 'coerce', "${value}", $coerce); + my ($self, $name, $value, $coerce, $init_arg) = @_; + $self->_generate_die_prefix( + "coercion for ${\_attr_desc($name, $init_arg)} failed: ", + $self->_generate_call_code($name, 'coerce', "${value}", $coerce) + ); } sub generate_trigger { @@ -262,24 +368,38 @@ 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); + my ($self, $name, $value, $check, $init_arg) = @_; + $self->_generate_die_prefix( + "isa check for ${\_attr_desc($name, $init_arg)} failed: ", + $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 $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}}; @@ -296,7 +416,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( @@ -308,16 +428,16 @@ 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}, $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" @@ -326,7 +446,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,15 +456,15 @@ sub _generate_populate_set { .($spec->{coerce} ? " $source = " .$self->_generate_coerce( - $name, $me, $source, - $spec->{coerce} + $name, $source, + $spec->{coerce}, $init_arg ).";\n" : "" ) .($spec->{isa} ? " " .$self->_generate_isa_check( - $name, $source, $spec->{isa} + $name, $source, $spec->{isa}, $init_arg ).";\n" : "" ) @@ -352,7 +472,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 +481,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,22 +505,26 @@ 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})"; - - eval { Scalar::Util::weaken($simple); 1 } or do { - if( \$@ =~ /Modification of a read-only value attempted/) { - { local $@; require Carp; } - Carp::croak( sprintf ( - 'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3', - $name_str, - ) ); - } else { - die \$@; + my $weak_simple = "my \$preserve; Scalar::Util::weaken(${simple}); no warnings 'void'; \$preserve"; + Moo::_Utils::lt_5_8_3() ? <<"EOC" : $weak_simple; + + my \$preserve; + eval { Scalar::Util::weaken($simple); 1 } + ? do { no warnings 'void'; \$preserve; } + : 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 { - $simple; + $self->_generate_core_set($me, $name, $spec, $value); } } @@ -408,6 +534,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 { @@ -427,9 +564,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;