From: Matt S Trout Date: Sun, 7 Nov 2010 01:03:10 +0000 (+0000) Subject: add Sub::Quote and rename Defer routines X-Git-Tag: 0.009001~75 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a165a07fdceff024146c494a3e3923492a9b3d8d;p=gitmo%2FRole-Tiny.git add Sub::Quote and rename Defer routines --- diff --git a/lib/Class/Tiny/_Utils.pm b/lib/Class/Tiny/_Utils.pm index 1131e1e..b046068 100644 --- a/lib/Class/Tiny/_Utils.pm +++ b/lib/Class/Tiny/_Utils.pm @@ -11,8 +11,13 @@ sub _install_modifier { require Class::Method::Modifiers; my ($into, $type, $name, $code) = @_; my $ref = ref(my $to_modify = $into->can($name)); - if ($ref && $ref =~ /Sub::Defer::Deferred/) { - require Sub::Defer; undefer($to_modify); + + # if it isn't CODE, then either we're about to die, or it's a blessed + # coderef - if it's a blessed coderef it might be deferred, and the + # user's already doing something clever so a minor speed hit is meh. + + if ($ref && $ref ne 'CODE') { + require Sub::Defer; Sub::Defer::undefer_sub($to_modify); } Class::Method::Modifiers::install_modifier(@_); } diff --git a/lib/Sub/Defer.pm b/lib/Sub/Defer.pm index 15f2cee..acbf42c 100644 --- a/lib/Sub/Defer.pm +++ b/lib/Sub/Defer.pm @@ -4,30 +4,33 @@ use strictures 1; use base qw(Exporter); use Class::Tiny::_Utils; -our @EXPORT = qw(defer undefer); +our @EXPORT = qw(defer_sub undefer_sub); our %DEFERRED; -sub undefer { +sub undefer_sub { my ($deferred) = @_; my ($target, $maker, $undeferred_ref) = @{ $DEFERRED{$deferred}||return $deferred }; ${$undeferred_ref} = my $made = $maker->(); - { no warnings 'redefine'; *{_getglob($target)} = $made } + if (defined($target)) { + no warnings 'redefine'; + *{_getglob($target)} = $made; + } return $made; } -sub defer { +sub defer_sub { my ($target, $maker) = @_; my $undeferred; my $deferred_string; my $deferred = bless(sub { - goto &{$undeferred ||= undefer($deferred_string)}; + goto &{$undeferred ||= undefer_sub($deferred_string)}; }, 'Sub::Defer::Deferred'); $deferred_string = "$deferred"; $DEFERRED{$deferred} = [ $target, $maker, \$undeferred ]; - *{_getglob $target} = $deferred; + *{_getglob $target} = $deferred if defined($target); return $deferred; } diff --git a/lib/Sub/Quote.pm b/lib/Sub/Quote.pm new file mode 100644 index 0000000..7015651 --- /dev/null +++ b/lib/Sub/Quote.pm @@ -0,0 +1,99 @@ +package Sub::Quote; + +use strictures 1; + +sub _clean_eval { eval $_[0] } + +use Sub::Defer; +use B 'perlstring'; +use base qw(Exporter); + +our @EXPORT = qw(quote_sub unquote_sub); + +our %QUOTE_OUTSTANDING; + +our %QUOTED; + +sub _unquote_all_outstanding { + return unless %QUOTE_OUTSTANDING; + my ($assembled_code, @assembled_captures, @localize_these) = ''; + foreach my $outstanding (keys %QUOTE_OUTSTANDING) { + my ($name, $code, $captures) = @{$QUOTE_OUTSTANDING{$outstanding}}; + + push @localize_these, $name if $name; + + my $make_sub = "{\n"; + + if (keys %$captures) { + my $ass_cap_count = @assembled_captures; + $make_sub .= join( + "\n", + map { + /^([\@\%\$])/ + or die "capture key should start with \@, \% or \$: $_"; + qq{ my ${_} = ${1}{\$_[1][${ass_cap_count}]{${\perlstring $_}}};\n}; + } keys %$captures + ); + push @assembled_captures, $captures; + } + + my $o_quoted = perlstring $outstanding; + $make_sub .= ( + $name + ? " no warnings 'closure';\n sub ${name} {\n" + : " \$Sub::Quote::QUOTED{${o_quoted}}[3] = sub {\n" + ); + $make_sub .= $code; + $make_sub .= " }".($name ? '' : ';')."\n"; + if ($name) { + $make_sub .= " \$Sub::Quote::QUOTED{${o_quoted}}[3] = \\&${name}\n"; + } + $make_sub .= "}\n"; + $assembled_code .= $make_sub; + } + if (@localize_these) { + $assembled_code = join("\n", + (map { "local *${_};" } @localize_these), + 'eval '.perlstring $assembled_code + ); + } + $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$@"; + } + %QUOTE_OUTSTANDING = (); +} + +sub quote_sub { + # HOLY DWIMMERY, BATMAN! + # $name => $code => \%captures + # $name => $code + # $code => \%captures + # $code + my $captures = pop if ref($_[-1]) eq 'HASH'; + my $code = pop; + my $name = $_[0]; + my $outstanding; + my $deferred = defer_sub $name => sub { + unquote_sub($outstanding); + }; + $outstanding = "$deferred"; + $QUOTE_OUTSTANDING{$outstanding} = $QUOTED{$outstanding} = [ + $name, $code, $captures + ]; + return $deferred; +} + +sub quoted_from_sub { + my ($sub) = @_; + $QUOTED{$sub}; +} + +sub unquote_sub { + my ($sub) = @_; + _unquote_all_outstanding; + $QUOTED{$sub}[3]; +} + +1; diff --git a/t/sub-defer.t b/t/sub-defer.t index 7675560..a5309b0 100644 --- a/t/sub-defer.t +++ b/t/sub-defer.t @@ -4,12 +4,12 @@ use Sub::Defer; my %made; -my $one_defer = defer 'Foo::one' => sub { +my $one_defer = defer_sub 'Foo::one' => sub { die "remade - wtf" if $made{'Foo::one'}; $made{'Foo::one'} = sub { 'one' } }; -my $two_defer = defer 'Foo::two' => sub { +my $two_defer = defer_sub 'Foo::two' => sub { die "remade - wtf" if $made{'Foo::two'}; $made{'Foo::two'} = sub { 'two' } }; @@ -27,7 +27,7 @@ is($one_defer->(), 'one', 'one (deferred) still runs'); is(Foo->one, 'one', 'one (undeferred) runs'); -is(my $two_made = undefer($two_defer), $made{'Foo::two'}, 'make two'); +is(my $two_made = undefer_sub($two_defer), $made{'Foo::two'}, 'make two'); is($two_made, \&Foo::two, 'two installed'); @@ -37,6 +37,6 @@ is($two_made->(), 'two', 'two (undeferred) runs'); my $three = sub { 'three' }; -is(undefer($three), $three, 'undefer non-deferred is a no-op'); +is(undefer_sub($three), $three, 'undefer non-deferred is a no-op'); done_testing; diff --git a/t/sub-quote.t b/t/sub-quote.t new file mode 100644 index 0000000..c610766 --- /dev/null +++ b/t/sub-quote.t @@ -0,0 +1,50 @@ +use strictures 1; +use Test::More; +use Test::Fatal; + +use Sub::Quote; + +our %EVALED; + +my $one = quote_sub q{ + BEGIN { $::EVALED{'one'} = 1 } + 42 +}; + +my $two = quote_sub q{ + BEGIN { $::EVALED{'two'} = 1 } + 3 + $x++ +} => { '$x' => \do { my $x = 0 } }; + +ok(!keys %EVALED, 'Nothing evaled yet'); + +my $u_one = unquote_sub $one; + +is_deeply( + [ keys %EVALED ], [ qw(one two) ], + 'Both subs evaled' +); + +is($one->(), 42, 'One (quoted version)'); + +is($u_one->(), 42, 'One (unquoted version)'); + +is($two->(), 3, 'Two (quoted version)'); +is(unquote_sub($two)->(), 4, 'Two (unquoted version)'); +is($two->(), 5, 'Two (quoted version again)'); + +my $three = quote_sub 'Foo::three' => q{ + $x = $_[1] if $_[1]; + die +(caller(0))[3] if @_ > 2; + return $x; +} => { '$x' => \do { my $x = 'spoon' } }; + +is(Foo->three, 'spoon', 'get ok (named method)'); +is(Foo->three('fork'), 'fork', 'set ok (named method)'); +is(Foo->three, 'fork', 're-get ok (named method)'); +like( + exception { Foo->three(qw(full cutlery set)) }, qr/Foo::three/, + 'exception contains correct name' +); + +done_testing;