From 2ad24d90acdb253eb535b47415cd1dadcced2ef6 Mon Sep 17 00:00:00 2001 From: Matt S Trout Date: Fri, 12 Dec 2008 08:06:53 +0000 Subject: [PATCH] sub construction recording --- lib/MooseX/Antlers/Recorder.pm | 97 ++++++++++++++++++++++++++++------ t/refwalk.t | 52 +++++++++++++----- 2 files changed, 121 insertions(+), 28 deletions(-) diff --git a/lib/MooseX/Antlers/Recorder.pm b/lib/MooseX/Antlers/Recorder.pm index a428693..280013e 100644 --- a/lib/MooseX/Antlers/Recorder.pm +++ b/lib/MooseX/Antlers/Recorder.pm @@ -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'; @@ -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}; @@ -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}; @@ -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 { @@ -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! @@ -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->(@_); } diff --git a/t/refwalk.t b/t/refwalk.t index 4676163..0d16b43 100644 --- a/t/refwalk.t +++ b/t/refwalk.t @@ -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}(), ] } } @@ -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 }); @@ -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; @@ -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)) { @@ -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");