;
}
+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) = @_;
}
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;
}
_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"
;
}
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 {
}
}
+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}}";
($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);
." ".$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");
+ : ' ('.$self->_generate_simple_set($me, $name, $spec, $get_value).")\n");
}
sub _generate_get_default {
$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";
}
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} = {};
}
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"
}
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)
);
}
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}};
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
projects / gitmo/Moo.git / blobdiff