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 (file)
--- 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 (file)
--- 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 (file)
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 (file)
--- 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 (file)
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;