Skip to content

Commit

Permalink
sub construction recording
Browse files Browse the repository at this point in the history
  • Loading branch information
@shadowcat-mst
shadowcat-mst committed Dec 12, 2008
1 parent 10d8aff commit 2ad24d9
Show file tree
Hide file tree
Showing 2 changed files with 121 additions and 28 deletions.
97 changes: 82 additions & 15 deletions lib/MooseX/Antlers/Recorder.pm
View file
Expand Up @@ -13,16 +13,33 @@ sub new {

sub instrument_routines {
my ($self, @names) = @_;
$self->_instrument_calls(
sub {
my $orig = shift;
sub {
# we keep $copy in scope because otherwise the refaddr can get
# re-used, thus completely messing up the $builder stuff.
# of course, this indicates we may be screwed by this some other
# way at some later point, which probably indicates we need to
# use Variable::Magic or Scalar::Annotate to tag buildables.
my $copy = [ @_ ];
$self->record_call($copy);
$orig->(@_);
};
},
@names
);
}

sub _instrument_calls {
my ($self, $builder, @names) = @_;
foreach my $name (@names) {
(my $pack = $name) =~ s/\::([^:]+)$//;
my $sub = $1;
my $orig = $pack->can($sub);
$self->{saved_routines}{$name} = $orig;
# Note: if we stored $new that would be a circular reference
my $new = sub {
$self->record_call([ @_ ]);
$orig->(@_);
};
my $new = $builder->($orig);
{
no strict 'refs';
no warnings 'redefine';
Expand All @@ -31,6 +48,22 @@ sub instrument_routines {
}
}

sub instrument_sub_constructors {
my ($self, @names) = @_;
$self->_instrument_calls(
sub {
my $orig = shift;
sub {
my ($obj, $captures, $body) = @_;
my $cr = $orig->(@_);
$self->record_coderef_construction($captures, $body, $cr);
return $cr;
};
},
@names
);
}

sub deinstrument_routines {
my ($self) = @_;
my $save = $self->{saved_routines};
Expand Down Expand Up @@ -70,6 +103,33 @@ sub build_seen_handler {
};
}

sub record_coderef_construction {
my ($self, $captures, $body, $coderef) = @_;
$self->{buildable}{$coderef} = sub {
my $constructors = $self->{coderef_constructors};
my $val_str = $self->next_values_member;
my $captures_dump = $self->with_custom_dumper_do($captures);
$captures_dump =~ s/^\$VAR1/my \$__captures/;
my $serialise_captures = $self->build_capture_constructor($captures);
push(@$constructors,
q!sub { !.$captures_dump.$serialise_captures.$val_str.q! = !.$body.q! }!
);
return $val_str;
}
}

sub build_capture_constructor {
my ($self, $captures) = @_;
join(
"\n",
(map {
/^([\@\%\$])/ or die "capture key should start with \@, \% or \$: $_";
q!my !.$_.q! = !.$1.q!{$__captures->{'!.$_.q!'}};!;
} keys %$captures),
'' # trailing \n
);
}

sub next_values_member {
my ($self) = @_;
my $value_index = $self->{value_map_index};
Expand Down Expand Up @@ -98,11 +158,10 @@ sub next_values_member {
sub emit_call_results {
my ($self, $final) = @_;
local $self->{value_mapback} = {};
local $self->{save_during_replay} = [];
local $self->{value_map_index} = 0;
local $self->{save_during_replay} = [];
local $self->{coderef_constructors} = [];
my $final_dump = $self->with_custom_dumper_do($final);
#warn Dumper(\@save);
#warn $final_dump;
my @save_subs = map {
if (defined $_) {
my $code = q!sub {
Expand All @@ -113,7 +172,14 @@ sub emit_call_results {
'undef';
}
} @{$self->{save_during_replay}};
my $dump_sub = qq!sub {my ${final_dump}}!;
#warn join("\n----\n", @save_subs);
#warn join("\n----\n", @{$self->{coderef_constructors}});

my $dump_sub = q!sub {
!.join("\n", map { "$_->();" } @{$self->{coderef_constructors}}).qq!
my ${final_dump}
}!;
#warn $dump_sub;
return q!my @values;
[
!.join(', ', @save_subs).q!
Expand Down Expand Up @@ -141,16 +207,17 @@ sub dumper_handler {
my ($s, $val, $name) = @_;
my $values = $self->{value_mapback};
my $save = $self->{save_during_replay};
if (ref($val) eq 'CODE') {
if (ref($val)) {
if (my $builder = $self->{buildable}->{$val}) {
return $values->{$val} ||= $builder->();
} else {
my ($pack, $name) = Sub::Identify::get_code_info($val);
if ($name !~ /__ANON__/) {
return "\\&${pack}::${name}";
}
}
warn "Coderef ${val} not recognised, only superman can save us!";
}
if (ref($val) eq 'CODE') {
my ($pack, $name) = Sub::Identify::get_code_info($val);
if ($name !~ /__ANON__/) {
return "\\&${pack}::${name}";
}
warn "Coderef ${val} not recognised, only superman can save us!";
}
return $_dump->(@_);
}
Expand Down
52 changes: 39 additions & 13 deletions t/refwalk.t
View file
Expand Up @@ -28,11 +28,30 @@ use MooseX::Antlers::Recorder;
$built->{ary} = [ 1, $in->{three}{sub3} ];
}

sub build_4 {
my ($in) = @_;
&build_4_crmaker('x', { '$foo' => \$in->{aryref} }, q!sub { $foo }!);
}

sub build_4_crmaker {
my ($obj, $__captures, $body) = @_;
$built->{sub} = do {
my $code =
MooseX::Antlers::Recorder->build_capture_constructor($__captures)
.$body
;
my $cr = eval $code;
die "code $code, error $@" if $@;
$cr;
};
}

sub do_stuff {
[
$built->{foo}{bar}(),
$built->{quux}(),
$built->{ary}->[1]->(),
$built->{sub}(),
]
}
}
Expand Down Expand Up @@ -60,7 +79,9 @@ sub setup_stuff {

reset_built;

my ($x, $y, $z);
my ($x, $y, $z, $ary);

$ary = [];

my ($sub1, $sub2, $sub3) = (sub { $x }, sub { $y }, sub { $z });

Expand All @@ -69,22 +90,25 @@ sub setup_stuff {
&build_1({ sub1 => $sub1 });
&build_2([ 0, 0, { sub2 => $sub2 } ]);
&build_3({ three => { sub3 => $sub3 } });
&build_4({ aryref => $ary });

($x, $y, $z) = @_;

push(@$ary, @{$_[3]}); # fourth element of @_
}

setup_stuff(10, 11, 12);
setup_stuff(10, 11, 12, [ 1, 2, 3 ]);

is_deeply(do_stuff(), [ 10, 11, 12 ], "captures ok");
is_deeply(do_stuff(), [ 10, 11, 12, [ 1, 2, 3 ] ], "captures ok");

my $rec = MooseX::Antlers::Recorder->new;

$rec->instrument_routines(map { "main::build_$_" } qw(1 2 3));
$rec->instrument_routines(map { "main::build_$_" } qw(1 2 3 4));
$rec->instrument_sub_constructors("main::build_4_crmaker");

setup_stuff(13, 14, 15);
setup_stuff(13, 14, 15, [ 4, 5, 6 ]);

is_deeply(do_stuff(13, 14, 15), [ 13, 14, 15 ], "logged ok");
is_deeply(do_stuff(13, 14, 15), [ 13, 14, 15, [ 4, 5, 6 ] ], "logged ok");

#use Data::Dumper;

Expand All @@ -98,11 +122,6 @@ my ($save, $final) = eval $results;

die $@ if $@;

#use Data::Dumper;
#$Data::Dumper::Deparse = 1;
#warn Dumper($save);
#warn Dumper($final);

{
my $save_user = sub {
if (my $code = shift(@$save)) {
Expand All @@ -113,10 +132,17 @@ die $@ if $@;
local *build_1 = $save_user;
local *build_2 = $save_user;
local *build_3 = $save_user;
local *build_4 = $save_user;

setup_stuff(14, 15, 16);
setup_stuff(14, 15, 16, [ 7, 8, 9 ]);
}

set_built($final->());

is_deeply(do_stuff(), [ 14, 15, 16 ], "replay ok");
#use Data::Dumper;
#$Data::Dumper::Deparse = 1;
#warn Dumper(get_built);
#warn Dumper($save);
#warn Dumper($final);

is_deeply(do_stuff(), [ 14, 15, 16, [ 7, 8, 9 ] ], "replay ok");

0 comments on commit 2ad24d9

Please sign in to comment.