summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ext/Opcode/Opcode.pm2
-rw-r--r--lib/B/Deparse.pm8
-rw-r--r--lib/B/Op_private.pm1
-rw-r--r--op.c11
-rw-r--r--opcode.h9
-rw-r--r--opnames.h3
-rw-r--r--pod/perldiag.pod6
-rw-r--r--pp.c11
-rw-r--r--pp_proto.h1
-rw-r--r--regen/opcodes1
-rw-r--r--toke.c11
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))