use Moose;
use MooseX::Antlers::ErrorThrower;
+use aliased 'MooseX::Antlers::RefFilter';
use Scalar::Util qw(weaken refaddr);
use PadWalker qw(closed_over);
use Sub::Identify qw(sub_fullname);
use B qw(perlstring);
use namespace::clean -except => 'meta';
+use String::TT qw(tt strip);
+use Data::Dumper::Concise;
has '_original_eval_closure' => (is => 'ro', lazy_build => 1);
has '_our_eval_closure' => (is => 'ro', lazy_build => 1);
#warn Dumper($body);
}
+sub serialized_construction {
+ my ($self, $externals) = @_;
+ my $code = strip q{
+ package Class::MOP::Method::Generated;
+ use strict;
+ use warnings;
+ };
+ foreach my $recorded (@{$self->recorded_coderefs}) {
+ my ($cr, $captures, $body) = @{$recorded};
+ my $name = sub_fullname($cr);
+ my $name_string = perlstring($name);
+ my $filter = RefFilter->new(
+ external_mappings => $externals,
+ root_name => '$__captures'
+ );
+ my $filtered_captures = Dumper($filter->visit($captures));
+ my $fixup_code = $filter->fixup_code;
+ my $use_captures = $self->_generate_capture_constructor($captures);
+ $code .= strip tt q{
+ {
+ my $__captures = [% filtered_captures %];
+ [% fixup_code %]
+ [% use_captures %]
+ *[% name %] = Sub::Name::subname [% name_string %] => [% body %];
+ }
+ };
+ }
+ return $code;
+}
+
sub _generate_coderef_constructor {
my ($self, $entry) = @_;
my ($cr, $captures, $body) = @{$entry};
--- /dev/null
+package MooseX::Antlers::StealImport;
+
+use strict;
+use warnings FATAL => 'all';
+
+my %saved_import;
+my %saved_inc;
+
+sub import {
+ my ($class, %steal_classes) = @_;
+ foreach my $to_steal (keys %steal_classes) {
+ (my $pm_file = $to_steal) =~ s/::/\//g;
+ if (exists $INC{"${pm_file}.pm"}) {
+ $saved_inc{$to_steal} = $INC{"${pm_file}.pm"}
+ }
+ $INC{"${pm_file}.pm"} = __FILE__;
+ my %steal_methods = %{$steal_classes{$to_steal}};
+ {
+ no strict 'refs';
+ no warnings 'redefine';
+ $saved_import{$to_steal} = $to_steal->can('import');
+ my $do = delete $steal_methods{-do};
+ *{"${to_steal}::import"} = sub {
+ my $targ = caller;
+ $do->(@_) if $do;
+ foreach my $meth (keys %steal_methods) {
+ *{"${targ}::${meth}"} = $steal_methods{$meth};
+ }
+ };
+ }
+ }
+}
+
+sub unimport {
+ my ($class, @unsteal_classes) = @_;
+ foreach my $unsteal (@unsteal_classes) {
+ if (exists $saved_inc{$unsteal}) {
+ (my $pm_file = $unsteal) =~ s/::/\//g;
+ $INC{"${pm_file}.pm"} = delete $saved_inc{$unsteal};
+ }
+ if (defined $saved_import{$unsteal}) {
+ {
+ no strict 'refs';
+ no warnings 'redefine';
+ *{"${unsteal}::import"} = delete $saved_import{$unsteal};
+ }
+ } else {
+ {
+ no strict 'refs';
+ delete ${"${unsteal}::"}{import};
+ }
+ }
+ }
+}
+
+1;
use B qw(perlstring);
use lib 't/lib';
use Test::More;
+use Test::Exception;
+use Class::Unload;
+use String::TT qw(tt strip);
+use IO::All qw(io);
my %attr_refs;
-my %attr_methods;
+my %attr_et;
+my $im_et;
{
require Moose;
- my $orig = Moose->can('import');
+ my $orig_import = Moose->can('import');
no warnings 'redefine';
local *Moose::import = sub {
my $targ = caller;
- Moose->$orig({ into => $targ });
+ Moose->$orig_import({ into => $targ });
my $has = $targ->can('has');
{
no strict 'refs';
*{"${targ}::has"} = sub {
- $attr_refs{$_[0]} = RefTracker->trace_refs(
- '$attributes{'.perlstring($_[0]).'}'
- => \@_
- );
+ $attr_refs{$_[0]} = [
+ map RefTracker->trace_refs( $_ => \@_ ),
+ '(\@_)', '$has_args{'.perlstring($_[0]).'}'
+ ];
my $et = EvalTracker->new->enable;
$has->(@_);
- $attr_methods{$_[0]} = $et->recorded_coderefs;
+ $attr_et{$_[0]} = $et->disable;
+ return;
};
}
};
+ my $orig_immutable = Moose::Meta::Class->can('make_immutable');
+ local *Moose::Meta::Class::make_immutable = sub {
+ my $et = EvalTracker->new->enable;
+ $orig_immutable->(@_);
+ $im_et = $et->disable;
+ return;
+ };
require One;
}
-ok(One->can('foo'), 'foo accessor installed');
+sub foo_called {
+ &cmp_ok(One->get_called_foo, '==', @_); # cmp_ok has a $$$;$ proto
+}
+
+sub test_One {
+
+ ok(One->can('foo'), 'foo accessor installed');
+
+ dies_ok { One->new } 'foo is required';
+
+ foo_called(0 => 'trigger not called yet');
+
+ my $one = One->new(foo => 1);
+
+ foo_called(1 => 'trigger called once (constructor)');
+
+ cmp_ok($one->foo, '==', 1, 'read ok');
+
+ foo_called(1 => 'trigger not called for read');
+
+ $one->foo(2);
+
+ foo_called(2 => 'trigger called for setter');
+}
+
+my %orig_src = map +($_ => join '', Dump(One->can($_))), qw(new DESTROY one);
+
+my $orig_foo_meta = Dump(One->meta);
+
+test_One();
use Data::Dump::Streamer;
-my $orig_foo_src = Dump(One->can('foo'));
+my $one_source_code = io($INC{'One.pm'})->all;
+
+#warn $attr_et{'foo'}->serialized_construction($attr_refs{'foo'});
+
+#my @has = (
+
+my $foo_build = $attr_et{'foo'}->serialized_construction($attr_refs{'foo'}[0]);
+
+my $im_build = $im_et->serialized_construction($attr_refs{'foo'}[1]);
+
+my $preamble = strip tt q{
+ my %replay_has;
+ my %has_args;
+ BEGIN {
+ %replay_has = (
+ foo => sub {
+ [% foo_build %]
+ }
+ );
+ }
+ sub MooseX::Antlers::ImmutableHackFor::Foo::make_immutable {
+[% im_build %]
+ }
+ use MooseX::Antlers::StealImport
+ Moose => {
+ -do => sub {
+ strict->import;
+ warnings->import;
+ },
+ has => sub {
+ $has_args{$_[0]} = \@_;
+ ($replay_has{$_[0]}||die "Can't find replay for $_[0]")
+ ->(@_);
+ },
+ meta => sub { 'MooseX::Antlers::ImmutableHackFor::Foo' }
+ };
+};
+
+my $postamble = strip q{
+ no MooseX::Antlers::StealImport qw(Moose);
+};
+
+my $compiled = join("\n", $preamble, $one_source_code, $postamble);
+
+#warn $compiled; done_testing; exit 0;
+
+Class::Unload->unload('One');
+Class::MOP::remove_metaclass_by_name('One');
+
+eval $compiled; die "Shit. failed.\n\n${compiled}\n\nError: $@" if $@;
+
+use Data::Dumper::Concise;
+
+my %compiled_src = map +($_ => join '', Dump(One->can($_))), qw(new DESTROY one);
+
+#foreach my $method (qw(new DESTROY one)) {
+# is($compiled_src{$method}, $orig_src{$method}, "${method} restored ok");
+#}
+
+test_One;
# write test_class method that checks method including call
# Class::Unload One
# eval compiled source
# run test_class after that as well as before unload
-use Data::Dumper::Concise;
-
#warn Dumper \%attr_refs;
-#warn Dumper \%attr_methods;
+#warn Dumper \%attr_et;
+#warn Dumper $im_et;
done_testing;
projects / gitmo/MooseX-Antlers.git / commitdiff