Add :const anon sub attribute

11 files changed, 56 insertions, 8 deletions

diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index 94d3b219be..b2a75d3970 100644
--- a/ext/Opcode/Opcode.pm
+++ b/ext/Opcode/Opcode.pm
@@ -337,7 +337,7 @@ invert_opset function.
 
     warn die lineseq nextstate scope enter leave
 
-    rv2cv anoncode prototype coreargs
+    rv2cv anoncode prototype coreargs anonconst
 
     entersub leavesub leavesublv return method method_named
     method_super method_redir method_redir_super
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index c496c8ae88..740192dfb5 100644
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -58,7 +58,7 @@ BEGIN {
     # be to fake up a dummy constant that will never actually be true.
     foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
 		OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE
-		RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
+		RXf_PMf_CHARSET RXf_PMf_KEEPCOPY CVf_ANONCONST
 		CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
 		PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES
 		OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV
@@ -1213,11 +1213,12 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
     if ($cv->FLAGS & SVf_POK) {
 	$proto = "(". $cv->PV . ") ";
     }
-    if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
+    if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) {
         $proto .= ": ";
         $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
         $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
         $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
+        $proto .= "const "  if $cv->CvFLAGS & CVf_ANONCONST;
     }
 
     local($self->{'curcv'}) = $cv;
@@ -2587,6 +2588,9 @@ sub pp_refgen {
     my $kid = $op->first;
     if ($kid->name eq "null") {
 	my $anoncode = $kid = $kid->first;
+	if ($anoncode->name eq "anonconst") {
+	    $anoncode = $anoncode->first->first->sibling;
+	}
 	if ($anoncode->name eq "anoncode"
 	 or !null($anoncode = $kid->sibling) and
 		 $anoncode->name eq "anoncode") {
diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm
index 32f8e20e6b..9a48b96036 100644
--- a/lib/B/Op_private.pm
+++ b/lib/B/Op_private.pm
@@ -240,6 +240,7 @@ $bits{akeys}{0} = $bf[0];
 $bits{alarm}{0} = $bf[0];
 $bits{and}{0} = $bf[0];
 $bits{andassign}{0} = $bf[0];
+$bits{anonconst}{0} = $bf[0];
 @{$bits{anonhash}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
 @{$bits{anonlist}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
 @{$bits{atan2}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
diff --git a/op.c b/op.c
index c1d41722be..6ed08a35e8 100644
--- a/op.c
+++ b/op.c
@@ -9274,9 +9274,16 @@ Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
 OP *
 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
 {
-    return newUNOP(OP_REFGEN, 0,
+    SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
+    OP * anoncode = 
 	newSVOP(OP_ANONCODE, 0,
-		MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
+		cv);
+    if (CvANONCONST(cv))
+	anoncode = newUNOP(OP_ANONCONST, 0,
+			   op_convert_list(OP_ENTERSUB,
+					   OPf_STACKED|OPf_WANT_SCALAR,
+					   anoncode));
+    return newUNOP(OP_REFGEN, 0, anoncode);
 }
 
 OP *
diff --git a/opcode.h b/opcode.h
index 33e7e3d341..5d910fd7d1 100644
--- a/opcode.h
+++ b/opcode.h
@@ -535,6 +535,7 @@ EXTCONST char* const PL_op_name[] = {
 	"lvref",
 	"lvrefslice",
 	"lvavref",
+	"anonconst",
 	"freed",
 };
 #endif
@@ -930,6 +931,7 @@ EXTCONST char* const PL_op_desc[] = {
 	"lvalue ref assignment",
 	"lvalue ref assignment",
 	"lvalue array reference",
+	"anonymous constant",
 	"freed op",
 };
 #endif
@@ -1339,6 +1341,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
 	Perl_pp_lvref,
 	Perl_pp_lvrefslice,
 	Perl_pp_lvavref,
+	Perl_pp_anonconst,
 }
 #endif
 #ifdef PERL_PPADDR_INITED
@@ -1744,6 +1747,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
 	Perl_ck_null,		/* lvref */
 	Perl_ck_null,		/* lvrefslice */
 	Perl_ck_null,		/* lvavref */
+	Perl_ck_null,		/* anonconst */
 }
 #endif
 #ifdef PERL_CHECK_INITED
@@ -2143,6 +2147,7 @@ EXTCONST U32 PL_opargs[] = {
 	0x00000b40,	/* lvref */
 	0x00000440,	/* lvrefslice */
 	0x00000b40,	/* lvavref */
+	0x00000144,	/* anonconst */
 };
 #endif
 
@@ -2772,6 +2777,7 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
      200, /* lvref */
      206, /* lvrefslice */
      207, /* lvavref */
+       0, /* anonconst */
 
 };
 
@@ -2790,7 +2796,7 @@ EXTCONST I16  PL_op_private_bitdef_ix[] = {
  */
 
 EXTCONST U16  PL_op_private_bitdefs[] = {
-    0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, ucfirst, lcfirst, uc, lc, quotemeta, aeach, akeys, avalues, each, values, pop, shift, range, and, or, dor, andassign, orassign, dorassign, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, reach, rvalues, fc */
+    0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, ucfirst, lcfirst, uc, lc, quotemeta, aeach, akeys, avalues, each, values, pop, shift, range, and, or, dor, andassign, orassign, dorassign, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, reach, rvalues, fc, anonconst */
     0x29dc, 0x3bd9, /* pushmark */
     0x00bd, /* wantarray, runcv */
     0x03b8, 0x1570, 0x3c8c, 0x3748, 0x2da5, /* const */
@@ -3250,6 +3256,7 @@ EXTCONST U8 PL_op_private_valid[] = {
     /* LVREF      */ (OPpARG1_MASK|OPpLVREF_ELEM|OPpLVREF_ITER|OPpLVREF_TYPE|OPpPAD_STATE|OPpLVAL_INTRO),
     /* LVREFSLICE */ (OPpLVAL_INTRO),
     /* LVAVREF    */ (OPpARG1_MASK|OPpPAD_STATE|OPpLVAL_INTRO),
+    /* ANONCONST  */ (OPpARG1_MASK),
 
 };
 
diff --git a/opnames.h b/opnames.h
index 1d259a15dd..013350a765 100644
--- a/opnames.h
+++ b/opnames.h
@@ -401,10 +401,11 @@ typedef enum opcode {
 	OP_LVREF	 = 384,
 	OP_LVREFSLICE	 = 385,
 	OP_LVAVREF	 = 386,
+	OP_ANONCONST	 = 387,
 	OP_max		
 } opcode;
 
-#define MAXO 387
+#define MAXO 388
 #define OP_FREED MAXO
 
 /* the OP_IS_* macros are optimized to a simple range check because
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 650839c1fc..cc46a85d27 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1699,6 +1699,12 @@ to define an overloaded constant, or when trying to find the
 character name specified in the C<\N{...}> escape.  Perhaps you
 forgot to load the corresponding L<overload> pragma?.
 
+=item :const is not permitted on named subroutines
+
+(F) The "const" attribute causes an anonymous subroutine to be run and
+its value captured at the time that it is cloned.  Names subroutines are
+not cloned like this, so the attribute does not make sense on them.
+
 =item Copy method did not return a reference
 
 (F) The method which overloads "=" is buggy.  See
diff --git a/pp.c b/pp.c
index 8c66286b38..c4c4819d34 100644
--- a/pp.c
+++ b/pp.c
@@ -6376,6 +6376,17 @@ PP(pp_lvavref)
     }
 }
 
+PP(pp_anonconst)
+{
+    dSP;
+    dTOPss;
+    SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
+					? CopSTASH(PL_curcop)
+					: NULL,
+				      NULL, SvREFCNT_inc_simple_NN(sv))));
+    RETURN;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
diff --git a/pp_proto.h b/pp_proto.h
index 074f4ab8a3..bbf6cf5f76 100644
--- a/pp_proto.h
+++ b/pp_proto.h
@@ -16,6 +16,7 @@ PERL_CALLCONV OP *Perl_pp_akeys(pTHX);
 PERL_CALLCONV OP *Perl_pp_alarm(pTHX);
 PERL_CALLCONV OP *Perl_pp_and(pTHX);
 PERL_CALLCONV OP *Perl_pp_anoncode(pTHX);
+PERL_CALLCONV OP *Perl_pp_anonconst(pTHX);
 PERL_CALLCONV OP *Perl_pp_anonhash(pTHX);
 PERL_CALLCONV OP *Perl_pp_anonlist(pTHX);
 PERL_CALLCONV OP *Perl_pp_aslice(pTHX);
diff --git a/regen/opcodes b/regen/opcodes
index f585cd2727..3061d33efb 100644
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -565,3 +565,4 @@ refassign	lvalue ref assignment	ck_refassign	ds2
 lvref		lvalue ref assignment	ck_null		d%
 lvrefslice	lvalue ref assignment	ck_null		d@
 lvavref		lvalue array reference	ck_null		d%
+anonconst	anonymous constant	ck_null		ds1
diff --git a/toke.c b/toke.c
index dfb5b20368..ffd6f90805 100644
--- a/toke.c
+++ b/toke.c
@@ -5366,6 +5366,15 @@ Perl_yylex(pTHX)
 			sv_free(sv);
 			CvMETHOD_on(PL_compcv);
 		    }
+		    else if (!PL_in_my && len == 5
+			  && strnEQ(SvPVX(sv), "const", len))
+		    {
+			sv_free(sv);
+			CvANONCONST_on(PL_compcv);
+			if (!CvANON(PL_compcv))
+			    yyerror(":const is not permitted on named "
+				    "subroutines");
+		    }
 		    /* After we've set the flags, it could be argued that
 		       we don't need to do the attributes.pm-based setting
 		       process, and shouldn't bother appending recognized
@@ -10591,7 +10600,7 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
     CvFLAGS(PL_compcv) |= flags;
 
     PL_subline = CopLINE(PL_curcop);
-    CvPADLIST_set(PL_compcv, pad_new(padnew_SAVE|padnew_SAVESUB));
+    CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
     CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
     if (outsidecv && CvPADLIST(outsidecv))