sub import {
my $target = caller;
+ my $class = shift;
strictures->import;
*{_getglob("${target}::extends")} = sub {
*{_getglob("${target}::ISA")} = \@_;
die "Only one role supported at a time by with" if @_ > 1;
Role::Tiny->apply_role_to_package($_[0], $target);
};
+ $MAKERS{$target} = {};
*{_getglob("${target}::has")} = sub {
my ($name, %spec) = @_;
($MAKERS{$target}{accessor} ||= do {
require Method::Generate::Accessor;
Method::Generate::Accessor->new
})->generate_method($target, $name, \%spec);
- ($MAKERS{$target}{constructor} ||= do {
- require Method::Generate::Constructor;
- Method::Generate::Constructor
- ->new(package => $target)
- ->install_delayed
- ->register_attribute_specs(do {
- my @spec;
- if (my $super = do { no strict 'refs'; ${"${target}::ISA"}[0] }) {
- if (my $con = $MAKERS{$super}{constructor}) {
- @spec = %{$con->all_attribute_specs};
- }
- }
- @spec;
- });
- })->register_attribute_specs($name, \%spec);
+ $class->_constructor_maker_for($target)
+ ->register_attribute_specs($name, \%spec);
};
foreach my $type (qw(before after around)) {
*{_getglob "${target}::${type}"} = sub {
}
}
+sub _constructor_maker_for {
+ my ($class, $target) = @_;
+ return unless $MAKERS{$target};
+ $MAKERS{$target}{constructor} ||= do {
+ require Method::Generate::Constructor;
+ Method::Generate::Constructor
+ ->new(
+ package => $target,
+ accessor_generator => do {
+ require Method::Generate::Accessor;
+ Method::Generate::Accessor->new;
+ }
+ )
+ ->install_delayed
+ ->register_attribute_specs(do {
+ my @spec;
+ if (my $super = do { no strict 'refs'; ${"${target}::ISA"}[0] }) {
+ if (my $con = $MAKERS{$super}{constructor}) {
+ @spec = %{$con->all_attribute_specs};
+ }
+ }
+ @spec;
+ });
+ }
+}
+
1;
sub generate_method {
my ($self, $into, $name, $spec, $quote_opts) = @_;
die "Must have an is" unless my $is = $spec->{is};
- my $name_str = perlstring $name;
+ local $self->{captures} = {};
my $body = do {
if ($is eq 'ro') {
- $self->_generate_get($name_str)
+ $self->_generate_get($name)
} elsif ($is eq 'rw') {
- $self->_generate_getset($name_str)
+ $self->_generate_getset($name, $spec)
} else {
die "Unknown is ${is}";
}
};
quote_sub
"${into}::${name}" => ' '.$body."\n",
- (ref($quote_opts) ? ({}, $quote_opts) : ())
+ $self->{captures}, $quote_opts||{}
;
}
sub _generate_get {
- my ($self, $name_str) = @_;
- "\$_[0]->{${name_str}}";
+ my ($self, $name) = @_;
+ $self->_generate_simple_get('$_[0]', $name);
+}
+
+sub generate_simple_get {
+ shift->_generate_simple_get(@_);
+}
+
+sub _generate_simple_get {
+ my ($self, $me, $name) = @_;
+ my $name_str = perlstring $name;
+ "${me}->{${name_str}}";
}
sub _generate_set {
- my ($self, $name_str, $value) = @_;
+ my ($self, $name, $value, $spec) = @_;
+ my $simple = $self->_generate_simple_set($name, $value);
+ if (my $trigger = $spec->{trigger}) {
+ my $value = '$value';
+ my $fire = $self->_generate_trigger($name, '$_[0]', '$value', $trigger);
+ return 'do { '
+ .'my $value = '.$simple.'; '.$fire.'; '
+ .'$value }'
+ ;
+ }
+ return $simple;
+}
+
+sub generate_trigger {
+ my $self = shift;
+ local $self->{captures} = {};
+ my $code = $self->_generate_trigger(@_);
+ return ($code, $self->{captures});
+}
+
+sub _generate_trigger {
+ my ($self, $name, $obj, $value, $trigger) = @_;
+ my $cap_name = qq{\$trigger_for_${name}};
+ $self->{captures}->{$cap_name} = \$trigger;
+ "${cap_name}->(${obj}, ${value})";
+}
+
+sub _generate_simple_set {
+ my ($self, $name, $value) = @_;
+ my $name_str = perlstring $name;
"\$_[0]->{${name_str}} = ${value}";
}
sub _generate_getset {
- my ($self, $name_str) = @_;
- q{(@_ > 1 ? }.$self->_generate_set($name_str, q{$_[1]})
- .' : '.$self->_generate_get($name_str).')';
+ my ($self, $name, $spec) = @_;
+ q{(@_ > 1 ? }.$self->_generate_set($name, q{$_[1]}, $spec)
+ .' : '.$self->_generate_get($name).')';
}
1;
use Sub::Quote;
use base qw(Class::Tiny::Object);
use Sub::Defer;
+use B 'perlstring';
sub register_attribute_specs {
my ($self, %spec) = @_;
$_[0]->{attribute_specs}
}
+sub accessor_generator {
+ $_[0]->{accessor_generator}
+}
+
sub install_delayed {
my ($self) = @_;
my $package = $self->{package};
foreach my $no_init (grep !exists($spec->{$_}{init_arg}), keys %$spec) {
$spec->{$no_init}{init_arg} = $no_init;
}
+ local $self->{captures} = {};
my $body = ' my $class = shift;'."\n";
$body .= $self->_generate_args;
$body .= $self->_check_required($spec);
$body .= ' my $new = bless({}, $class);'."\n";
$body .= $self->_assign_new($spec);
+ $body .= $self->_fire_triggers($spec);
$body .= ' return $new;'."\n";
quote_sub
"${into}::${name}" => $body,
- (ref($quote_opts) ? ({}, $quote_opts) : ())
+ $self->{captures}, $quote_opts||{}
;
}
." }\n";
}
+sub _fire_triggers {
+ my ($self, $spec) = @_;
+ my @fire = map {
+ [ $_, $spec->{$_}{init_arg}, $spec->{$_}{trigger} ]
+ } grep { $spec->{$_}{init_arg} && $spec->{$_}{trigger} } keys %$spec;
+ my $acc = $self->accessor_generator;
+ my $captures = $self->{captures};
+ my $fire = '';
+ foreach my $name (keys %$spec) {
+ my ($init, $trigger) = @{$spec->{$name}}{qw(init_arg trigger)};
+ next unless $init && $trigger;
+ my ($code, $add_captures) = $acc->generate_trigger(
+ $name, '$new', $acc->generate_simple_get('$new', $name), $trigger
+ );
+ @{$captures}{keys %$add_captures} = values %$add_captures;
+ $fire .= " ${code} if exists \$args->{${\perlstring $init}};\n";
+ }
+ return $fire;
+}
+
1;
if ($INFO{$to}) {
@{$INFO{$to}{attributes}||={}}{keys %$attr_info} = values %$attr_info;
} else {
- my $con = $Class::Tiny::MAKERS{$to}{constructor} ||= do {
- require Method::Generate::Constructor;
- Method::Generate::Constructor
- ->new(package => $to)
- ->install_delayed
- ->register_attribute_specs(do {
- my @spec;
- if (my $super = do { no strict 'refs'; ${"${to}::ISA"}[0] }) {
- if (my $con = $Class::Tiny::MAKERS{$super}{constructor}) {
- @spec = %{$con->all_attribute_specs};
- }
- }
- @spec;
- });
- };
- $con->register_attribute_specs(%$attr_info);
+ # only fiddle with the constructor if the target is a Class::Tiny class
+ if (my $con = Class::Tiny->_constructor_maker_for($to)) {
+ $con->register_attribute_specs(%$attr_info);
+ }
}
}
$make_sub .= "}\n";
$assembled_code .= $make_sub;
}
+ my $debug_code = $assembled_code;
if (@localize_these) {
- $ENV{SUB_QUOTE_DEBUG} && warn
+ $debug_code =
"# localizing: ".join(', ', @localize_these)."\n"
.$assembled_code;
$assembled_code = join("\n",
(map { "local *${_};" } @localize_these),
- 'eval '.perlstring $assembled_code
+ 'eval '.perlstring($assembled_code).'; die $@ if $@;'
);
} else {
$ENV{SUB_QUOTE_DEBUG} && warn $assembled_code;
}
- _clean_eval $assembled_code, \@assembled_captures;
- if ($@) {
- die "Eval went very, very wrong:\n\n${assembled_code}\n\n$@";
+ $assembled_code .= "\n1;";
+ unless (_clean_eval $assembled_code, \@assembled_captures) {
+ die "Eval went very, very wrong:\n\n${debug_code}\n\n$@";
}
+ $ENV{SUB_QUOTE_DEBUG} && warn $debug_code;
%QUOTE_OUTSTANDING = ();
}
--- /dev/null
+use strictures 1;
+use Test::More;
+
+my @one_tr;
+
+{
+ package Foo;
+
+ use Class::Tiny;
+
+ has one => (is => 'rw', trigger => sub { push @one_tr, $_[1] });
+}
+
+my $foo = Foo->new;
+
+ok(!@one_tr, "trigger not fired with no value");
+
+$foo = Foo->new(one => 1);
+
+is_deeply(\@one_tr, [ 1 ], "trigger fired on new");
+
+my $res = $foo->one(2);
+
+is_deeply(\@one_tr, [ 1, 2 ], "trigger fired on set");
+
+is($res, 2, "return from set ok");
+
+is($foo->one, 2, "return from accessor ok");
+
+is_deeply(\@one_tr, [ 1, 2 ], "trigger not fired for accessor as get");
+
+done_testing;
projects / gitmo/Role-Tiny.git / commitdiff