Polyfill for __SUB__ token

ListUtil.xs

@@ -2027,3 +2027,19 @@ BOOT:
     sv_setsv(rmcsv, &PL_sv_no);
 #endif
 }
+
+PROTOTYPES: ENABLE
+
+SV *
+ROUTINE()
+    PREINIT:
+        CV *cv;
+    CODE:
+        cv = Perl_find_runcv(aTHX_ NULL);
+        if (CvUNIQUE(cv) && !CvSPECIAL(cv))
+            RETVAL = &PL_sv_undef;
+        else
+            RETVAL = newRV((SV*)cv);
+    OUTPUT:
+        RETVAL
+

lib/Sub/Util.pm

@@ -21,6 +21,28 @@ $VERSION =~ tr/_//d;
 require List::Util; # as it has the XS
 List::Util->VERSION( $VERSION ); # Ensure we got the right XS version (RT#100863)
 
+use constant CAN_SUB => $] >= 5.016;
+
+use if CAN_SUB, feature => 'current_sub';
+
+unless (CAN_SUB) {
+  push @EXPORT_OK, '__SUB__';
+  *__SUB__ = \&ROUTINE;
+}
+
+sub import {
+  my ($class, @args) = @_;
+  if (CAN_SUB) {
+    my @new_args = grep { $_ ne '__SUB__' } @args;
+    if (@args != @new_args) {
+      feature->import('current_sub');
+      @_ = ($class, @new_args);
+    }
+  }
+
+  goto &Exporter::import;
+}
+
 =head1 NAME
 
 Sub::Util - A selection of utility subroutines for subs and CODE references

t/current_sub.t

@@ -0,0 +1,108 @@
+#!perl
+
+use strict;
+use warnings;
+use Test::More tests => 28;
+
+use Sub::Util '__SUB__';
+
+# basic.t
+
+sub davros { __SUB__ }
+is(davros(), \&davros, 'davros');
+
+sub borusa {
+    my $coderef = __SUB__;
+    is($coderef, \&borusa, 'borusa');
+}
+borusa();
+
+sub romana {
+    @_ = (__SUB__, \&romana, 'romana');
+    &is;
+}
+romana();
+
+sub rassilon {
+    is(__SUB__, \&rassilon, 'rassilon');
+}
+rassilon();
+
+# specialblocks.t
+
+BEGIN { ok( defined __SUB__, "Don't point to BEGIN" ); }
+CHECK { ok( defined __SUB__, "Don't point to CHECK" ); }
+INIT  { ok( defined __SUB__, "Don't point to INIT" ); }
+END   { ok( defined __SUB__, "Don't point to END" ); }
+
+# autoload.t
+
+sub AUTOLOAD {
+    is(__SUB__, \&AUTOLOAD, "AUTOLOAD $::AUTOLOAD");
+}
+sarah_jane();
+leela();
+sarah_jane(); # again
+
+# main.t
+
+ok( !defined __SUB__, "Don't point to main CV" );
+
+# prototype.t
+
+# polyfill prototype must be ''
+ok( defined prototype \&Sub::Util::ROUTINE, 'proto defined' );
+is( prototype \&Sub::Util::ROUTINE, '', 'proto empty' );
+
+# and this should compile
+sub skaro { __SUB__ }
+is(skaro(), \&skaro, 'skaro');
+
+# eval.t
+
+sub runcible {
+    is(eval { __SUB__ }, \&runcible, "runcible");
+}
+runcible();
+
+sub omega {
+    # eval("") is a special block context
+    ok(!defined eval q{ __SUB__ }, "omega");
+}
+omega();
+
+sub master {
+    is(do { __SUB__ }, \&master, "master");
+}
+master();
+
+# recurse.t
+
+our $i = 0;
+sub recurse {
+    if ($i++ < 4) {
+        ok(1, "test i$i");
+        __SUB__->();
+    }
+}
+recurse();
+
+sub recurse2 {
+    my $j = shift;
+    if ($j > 0) {
+        ok(1, "test j$j");
+        __SUB__->($j - 1);
+    }
+}
+recurse2(4);
+
+# anon.t
+
+my $anon;
+$anon = sub {
+    is(__SUB__, $anon, "anon sub");
+};
+$anon->();
+my $copy = $anon;
+$copy->();
+