+#line 2 "op.c"
/* op.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
*/
/*
- * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
- * our Mr. Bilbo's first cousin on the mother's side (her mother being the
- * youngest of the Old Took's daughters); and Mr. Drogo was his second
- * cousin. So Mr. Frodo is his first *and* second cousin, once removed
- * either way, as the saying is, if you follow me." --the Gaffer
+ * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
+ * our Mr. Bilbo's first cousin on the mother's side (her mother being the
+ * youngest of the Old Took's daughters); and Mr. Drogo was his second
+ * cousin. So Mr. Frodo is his first *and* second cousin, once removed
+ * either way, as the saying is, if you follow me.' --the Gaffer
+ *
+ * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
*/
/* This file contains the functions that create, manipulate and optimize
backward in the execution order. (The bottom-up parser builds that
part of the execution order it knows about, but if you follow the "next"
links around, you'll find it's actually a closed loop through the
-top level node.
+top level node.)
Whenever the bottom-up parser gets to a node that supplies context to
its components, it invokes that portion of the top-down pass that applies
#include "keywords.h"
#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
+#define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
#if defined(PL_OP_SLAB_ALLOC)
/* "register" allocation */
PADOFFSET
-Perl_allocmy(pTHX_ const char *const name)
+Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
{
dVAR;
PADOFFSET off;
PERL_ARGS_ASSERT_ALLOCMY;
+ if (flags)
+ Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
+ (UV)flags);
+
+ /* Until we're using the length for real, cross check that we're being
+ told the truth. */
+ assert(strlen(name) == len);
+
/* complain about "my $<special_var>" etc etc */
- if (*name &&
+ if (len &&
!(is_our ||
isALPHA(name[1]) ||
(USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
- (name[1] == '_' && (*name == '$' || name[2]))))
+ (name[1] == '_' && (*name == '$' || len > 2))))
{
/* name[2] is true if strlen(name) > 2 */
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
- yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
- name[0], toCTRL(name[1]), name + 2,
+ yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
+ name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
PL_parser->in_my == KEY_state ? "state" : "my"));
} else {
- yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
+ yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
PL_parser->in_my == KEY_state ? "state" : "my"));
}
}
- /* check for duplicate declaration */
- pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
-
- if (PL_parser->in_my_stash && *name != '$') {
- yyerror(Perl_form(aTHX_
- "Can't declare class for non-scalar %s in \"%s\"",
- name,
- is_our ? "our"
- : PL_parser->in_my == KEY_state ? "state" : "my"));
- }
-
/* allocate a spare slot and store the name in that slot */
- off = pad_add_name(name,
+ off = pad_add_name(name, len,
+ is_our ? padadd_OUR :
+ PL_parser->in_my == KEY_state ? padadd_STATE : 0,
PL_parser->in_my_stash,
(is_our
/* $_ is always in main::, even with our */
? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
: NULL
- ),
- 0, /* not fake */
- PL_parser->in_my == KEY_state
+ )
);
/* anon sub prototypes contains state vars should always be cloned,
* otherwise the state var would be shared between anon subs */
}
}
+ /* Call the op_free hook if it has been set. Do it now so that it's called
+ * at the right time for refcounted ops, but still before all of the kids
+ * are freed. */
+ CALL_OPFREEHOOK(o);
+
if (o->op_flags & OPf_KIDS) {
register OP *kid, *nextkid;
for (kid = cUNOPo->op_first; kid; kid = nextkid) {
o->op_targ = 0;
goto retry;
}
+ case OP_ENTERTRY:
case OP_ENTEREVAL: /* Was holding hints. */
o->op_targ = 0;
break;
case OP_AELEMFAST:
if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
/* not an OP_PADAV replacement */
+ GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
+#ifdef USE_ITHREADS
+ && PL_curpad
+#endif
+ ? cGVOPo_gv : NULL;
+ /* It's possible during global destruction that the GV is freed
+ before the optree. Whilst the SvREFCNT_inc is happy to bump from
+ 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
+ will trigger an assertion failure, because the entry to sv_clear
+ checks that the scalar is not already freed. A check of for
+ !SvIS_FREED(gv) turns out to be invalid, because during global
+ destruction the reference count can be forced down to zero
+ (with SVf_BREAK set). In which case raising to 1 and then
+ dropping to 0 triggers cleanup before it should happen. I
+ *think* that this might actually be a general, systematic,
+ weakness of the whole idea of SVf_BREAK, in that code *is*
+ allowed to raise and lower references during global destruction,
+ so any *valid* code that happens to do this during global
+ destruction might well trigger premature cleanup. */
+ bool still_valid = gv && SvREFCNT(gv);
+
+ if (still_valid)
+ SvREFCNT_inc_simple_void(gv);
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
/* No GvIN_PAD_off(cGVOPo_gv) here, because other references
SvREFCNT_dec(cSVOPo->op_sv);
cSVOPo->op_sv = NULL;
#endif
+ if (still_valid) {
+ int try_downgrade = SvREFCNT(gv) == 2;
+ SvREFCNT_dec(gv);
+ if (try_downgrade)
+ gv_try_downgrade(gv);
+ }
}
break;
case OP_METHOD_NAMED:
pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
}
#else
- SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
+ SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
#endif
/* FALL THROUGH */
case OP_MATCH:
PERL_ARGS_ASSERT_FORGET_PMOP;
if (pmstash && !SvIS_FREED(pmstash)) {
- MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
+ MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
if (mg) {
PMOP **const array = (PMOP**) mg->mg_ptr;
U32 count = mg->mg_len / sizeof(PMOP**);
#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
-OP *
-Perl_linklist(pTHX_ OP *o)
+static OP *
+S_linklist(pTHX_ OP *o)
{
OP *first;
return o->op_next;
}
-OP *
-Perl_scalarkids(pTHX_ OP *o)
+static OP *
+S_scalarkids(pTHX_ OP *o)
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
scalar(kid);
break;
- case OP_SPLIT:
- if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
- if (!kPMOP->op_pmreplrootu.op_pmreplroot)
- deprecate_old("implicit split to @_");
- }
/* FALL THROUGH */
+ case OP_SPLIT:
case OP_MATCH:
case OP_QR:
case OP_SUBST:
PL_curcop = &PL_compiling;
break;
case OP_SORT:
- if (ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
break;
}
return o;
want = o->op_flags & OPf_WANT;
if ((want && want != OPf_WANT_SCALAR)
|| (PL_parser && PL_parser->error_count)
- || o->op_type == OP_RETURN)
+ || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE)
{
return o;
}
useless = OP_DESC(o);
break;
+ case OP_SPLIT:
+ kid = cLISTOPo->op_first;
+ if (kid && kid->op_type == OP_PUSHRE
+#ifdef USE_ITHREADS
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
+#else
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
+#endif
+ useless = OP_DESC(o);
+ break;
+
case OP_NOT:
kid = cUNOPo->op_first;
if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
case OP_ENTEREVAL:
scalarkids(o);
break;
- case OP_REQUIRE:
- /* all requires must return a boolean value */
- o->op_flags &= ~OPf_WANT;
- /* FALL THROUGH */
case OP_SCALAR:
return scalar(o);
- case OP_SPLIT:
- if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
- if (!kPMOP->op_pmreplrootu.op_pmreplroot)
- deprecate_old("implicit split to @_");
- }
- break;
}
- if (useless && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
+ if (useless)
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
return o;
}
-OP *
-Perl_listkids(pTHX_ OP *o)
+static OP *
+S_listkids(pTHX_ OP *o)
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
}
PL_curcop = &PL_compiling;
break;
- case OP_REQUIRE:
- /* all requires must return a boolean value */
- o->op_flags &= ~OPf_WANT;
- return scalar(o);
}
return o;
}
-OP *
-Perl_scalarseq(pTHX_ OP *o)
+static OP *
+S_scalarseq(pTHX_ OP *o)
{
dVAR;
if (o) {
case OP_DBSTATE:
PL_modcount = RETURN_UNLIMITED_NUMBER;
break;
+ case OP_AV2ARYLEN:
+ PL_hints |= HINT_BLOCK_SCOPE;
+ if (type == OP_LEAVESUBLV)
+ o->op_private |= OPpMAYBE_LVSUB;
+ PL_modcount++;
+ break;
case OP_RV2SV:
ref(cUNOPo->op_first, o->op_type);
localize = 1;
/* FALL THROUGH */
case OP_GV:
- case OP_AV2ARYLEN:
PL_hints |= HINT_BLOCK_SCOPE;
case OP_SASSIGN:
case OP_ANDASSIGN:
case 0:
break;
case -1:
- if (ckWARN(WARN_SYNTAX)) {
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Useless localization of %s", OP_DESC(o));
- }
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Useless localization of %s", OP_DESC(o));
}
}
else if (type != OP_GREPSTART && type != OP_ENTERSUB
}
}
-OP *
-Perl_refkids(pTHX_ OP *o, I32 type)
+static OP *
+S_refkids(pTHX_ OP *o, I32 type)
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
prepend_elem(OP_LIST,
newSVOP(OP_CONST, 0,
- newRV((SV*)cv)),
+ newRV(MUTABLE_SV(cv))),
attrs)));
}
PL_parser->in_my_stash = NULL;
apply_attrs(GvSTASH(gv),
(type == OP_RV2SV ? GvSV(gv) :
- type == OP_RV2AV ? (SV*)GvAV(gv) :
- type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
+ type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
+ type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
attrs, FALSE);
}
o->op_private |= OPpOUR_INTRO;
}
OP *
-Perl_my(pTHX_ OP *o)
-{
- PERL_ARGS_ASSERT_MY;
-
- return my_attrs(o, NULL);
-}
-
-OP *
Perl_sawparens(pTHX_ OP *o)
{
PERL_UNUSED_CONTEXT;
S_newDEFSVOP(pTHX)
{
dVAR;
- const PADOFFSET offset = pad_findmy("$_");
+ const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
}
/* Register with debugger */
if (PERLDB_INTER) {
- CV * const cv
- = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
+ CV * const cv = get_cvs("DB::postponed", 0);
if (cv) {
dSP;
PUSHMARK(SP);
- XPUSHs((SV*)CopFILEGV(&PL_compiling));
+ XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
PUTBACK;
- call_sv((SV*)cv, G_DISCARD);
+ call_sv(MUTABLE_SV(cv), G_DISCARD);
}
}
}
return o;
}
-OP *
-Perl_fold_constants(pTHX_ register OP *o)
+static OP *
+S_fold_constants(pTHX_ register OP *o)
{
dVAR;
register OP * VOL curop;
#endif
assert(sv);
if (type == OP_RV2GV)
- newop = newGVOP(OP_GV, 0, (GV*)sv);
+ newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
else
- newop = newSVOP(OP_CONST, 0, (SV*)sv);
+ newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
op_getmad(o,newop,'f');
return newop;
return o;
}
-OP *
-Perl_gen_constant_list(pTHX_ register OP *o)
+static OP *
+S_gen_constant_list(pTHX_ register OP *o)
{
dVAR;
register OP *curop;
/* faked up qw list? */
if (slot == '(' &&
tm->mad_type == MAD_SV &&
- SvPVX((SV*)tm->mad_val)[0] == 'q')
+ SvPVX((SV *)tm->mad_val)[0] == 'q')
slot = 'x';
if (o) {
}
MADPROP *
-Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
+Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
{
MADPROP *mp;
Newxz(mp, 1, MADPROP);
op_free((OP*)mp->mad_val);
break;
case MAD_SV:
- sv_free((SV*)mp->mad_val);
+ sv_free(MUTABLE_SV(mp->mad_val));
break;
default:
PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
return newOP(OP_STUB, 0);
}
-OP *
-Perl_force_list(pTHX_ OP *o)
+static OP *
+S_force_list(pTHX_ OP *o)
{
if (!o || o->op_type != OP_LIST)
o = newLISTOP(OP_LIST, 0, o, NULL);
dVAR;
LISTOP *listop;
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
+
NewOp(1101, listop, 1, LISTOP);
listop->op_type = (OPCODE)type;
{
dVAR;
OP *o;
+
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
+
NewOp(1101, o, 1, OP);
o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
dVAR;
UNOP *unop;
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
+ || type == OP_SASSIGN
+ || type == OP_ENTERTRY
+ || type == OP_NULL );
+
if (!first)
first = newOP(OP_STUB, 0);
if (PL_opargs[type] & OA_MARK)
{
dVAR;
BINOP *binop;
+
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
+ || type == OP_SASSIGN || type == OP_NULL );
+
NewOp(1101, binop, 1, BINOP);
if (!first)
return 0;
}
-OP *
-Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
+static OP *
+S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
{
dVAR;
SV * const tstr = ((SVOP*)expr)->op_sv;
PerlMemShared_free(cPVOPo->op_pv);
cPVOPo->op_pv = NULL;
- swash = (SV*)swash_init("utf8", "", listsv, bits, none);
+ swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
#ifdef USE_ITHREADS
cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
PAD_SETSV(cPADOPo->op_padix, swash);
SvPADTMP_on(swash);
+ SvREADONLY_on(swash);
#else
cSVOPo->op_sv = swash;
#endif
}
}
}
+
+ if(del && rlen == tlen) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
+ } else if(rlen > tlen) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
+ }
+
if (grows)
o->op_private |= OPpTRANS_GROWS;
#ifdef PERL_MAD
dVAR;
PMOP *pmop;
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
+
NewOp(1101, pmop, 1, PMOP);
pmop->op_type = (OPCODE)type;
pmop->op_ppaddr = PL_ppaddr[type];
PERL_ARGS_ASSERT_NEWSVOP;
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
+
NewOp(1101, svop, 1, SVOP);
svop->op_type = (OPCODE)type;
svop->op_ppaddr = PL_ppaddr[type];
PERL_ARGS_ASSERT_NEWPADOP;
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
+
NewOp(1101, padop, 1, PADOP);
padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
{
dVAR;
PVOP *pvop;
+
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
+
NewOp(1101, pvop, 1, PVOP);
pvop->op_type = (OPCODE)type;
pvop->op_ppaddr = PL_ppaddr[type];
#endif
}
+void
+Perl_package_version( pTHX_ OP *v )
+{
+ dVAR;
+ U32 savehints = PL_hints;
+ PERL_ARGS_ASSERT_PACKAGE_VERSION;
+ PL_hints &= ~HINT_STRICT_VARS;
+ sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
+ PL_hints = savehints;
+ op_free(v);
+}
+
#ifdef PERL_MAD
OP*
#else
SV *meth;
if (version->op_type != OP_CONST || !SvNIOKp(vesv))
- Perl_croak(aTHX_ "Version number must be constant number");
+ Perl_croak(aTHX_ "Version number must be a constant number");
/* Make copy of idop so we don't free it twice */
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
(or 0 for no flags). ver, if specified, provides version semantics
similar to C<use Foo::Bar VERSION>. The optional trailing SV*
arguments can be used to specify arguments to the module's import()
-method, similar to C<use Foo::Bar VERSION LIST>.
+method, similar to C<use Foo::Bar VERSION LIST>. They must be
+terminated with a final NULL pointer. Note that this list can only
+be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
+Otherwise at least a single NULL pointer to designate the default
+import list is required.
=cut */
|| left->op_type == OP_PADHV
|| left->op_type == OP_PADANY))
{
- maybe_common_vars = FALSE;
+ if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
if (left->op_private & OPpPAD_STATE) {
/* All single variable list context state assignments, hence
state ($a) = ...
else if (curop->op_type == OP_PUSHRE) {
#ifdef USE_ITHREADS
if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
- GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
+ GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
if (gv == PL_defgv
|| (int)GvASSIGN_GENERATION(gv) == PL_generation)
break;
cPADOPx(tmpop)->op_padix = 0; /* steal it */
#else
pm->op_pmreplrootu.op_pmtargetgv
- = (GV*)cSVOPx(tmpop)->op_sv;
+ = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
cSVOPx(tmpop)->op_sv = NULL; /* steal it */
#endif
pm->op_pmflags |= PMf_ONCE;
((LISTOP*)right)->op_last->op_type == OP_CONST)
{
SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
- if (SvIVX(sv) == 0)
+ if (SvIOK(sv) && SvIVX(sv) == 0)
sv_setiv(sv, PL_modcount+1);
}
}
PL_eval_start = 0;
else {
if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
+ deprecate("assignment to $[");
op_free(o);
o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
o->op_private |= OPpCONST_ARYBASE;
#endif
CopSTASH_set(cop, PL_curstash);
- if (PERLDB_LINE && PL_curstash != PL_debstash) {
+ if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
+ /* this line can have a breakpoint - store the cop in IV */
AV *av = CopFILEAVx(PL_curcop);
if (av) {
SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
if (type == OP_XOR) /* Not short circuit, but here by precedence. */
return newBINOP(type, flags, scalar(first), scalar(other));
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
+
scalarboolean(first);
/* optimize AND and OR ops that have NOTs as children */
if (first->op_type == OP_NOT
if ((cstop = search_const(first))) {
if (cstop->op_private & OPpCONST_STRICT)
no_bareword_allowed(cstop);
- else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
- Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
+ else if ((cstop->op_private & OPpCONST_BARE))
+ Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
(type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
(type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
return newop;
}
op_free(first);
+ if (other->op_type == OP_LEAVE)
+ other = newUNOP(OP_NULL, OPf_SPECIAL, other);
return other;
}
else {
if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
|| o2->op_type == OP_PADHV)
&& o2->op_private & OPpLVAL_INTRO
- && !(o2->op_private & OPpPAD_STATE)
- && ckWARN(WARN_DEPRECATED))
+ && !(o2->op_private & OPpPAD_STATE))
{
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "Deprecated use of my() in false conditional");
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "Deprecated use of my() in false conditional");
}
*otherp = NULL;
op_free(first);
op_free(dead);
}
+ if (live->op_type == OP_LEAVE)
+ live = newUNOP(OP_NULL, OPf_SPECIAL, live);
return live;
}
NewOp(1101, logop, 1, LOGOP);
if (expr) {
if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
return block; /* do {} while 0 does once */
- if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
+ if (expr->op_type == OP_READLINE
+ || expr->op_type == OP_READDIR
+ || expr->op_type == OP_GLOB
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
const OP * const k2 = k1 ? k1->op_sibling : NULL;
switch (expr->op_type) {
case OP_NULL:
- if (k2 && k2->op_type == OP_READLINE
+ if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
&& (k2->op_flags & OPf_STACKED)
&& ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
expr = newUNOP(OP_DEFINED, 0, expr);
PERL_UNUSED_ARG(debuggable);
if (expr) {
- if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
+ if (expr->op_type == OP_READLINE
+ || expr->op_type == OP_READDIR
+ || expr->op_type == OP_GLOB
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
const OP * const k2 = (k1) ? k1->op_sibling : NULL;
switch (expr->op_type) {
case OP_NULL:
- if (k2 && k2->op_type == OP_READLINE
+ if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
&& (k2->op_flags & OPf_STACKED)
&& ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
expr = newUNOP(OP_DEFINED, 0, expr);
}
}
else {
- const PADOFFSET offset = pad_findmy("$_");
+ const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
sv = newGVOP(OP_GV, 0, PL_defgv);
}
PERL_ARGS_ASSERT_NEWLOOPEX;
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
+
if (type != OP_GOTO || label->op_type == OP_CONST) {
/* "last()" means "last" */
if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
switch(o->op_type) {
case OP_OR:
+ case OP_DOR:
return looks_like_bool(cLOGOPo->op_first);
case OP_AND:
&& looks_like_bool(cLOGOPo->op_first->op_sibling));
case OP_NULL:
+ case OP_SCALAR:
return (
o->op_flags & OPf_KIDS
&& looks_like_bool(cUNOPo->op_first));
case OP_ENTERSUB:
case OP_NOT: case OP_XOR:
- /* Note that OP_DOR is not here */
case OP_EQ: case OP_NE: case OP_LT:
case OP_GT: case OP_LE: case OP_GE:
case OP_DEFINED: case OP_EXISTS:
case OP_MATCH: case OP_EOF:
+ case OP_FLOP:
+
return TRUE;
case OP_CONST:
|| cSVOPo->op_sv == &PL_sv_no)
return TRUE;
-
+ else
+ return FALSE;
+
/* FALL THROUGH */
default:
return FALSE;
CvSTART(cv) = NULL;
LEAVE;
}
- SvPOK_off((SV*)cv); /* forget prototype */
+ SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
CvGV(cv) = NULL;
pad_undef(cv);
CvOUTSIDE(cv) = NULL;
}
if (CvCONST(cv)) {
- SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
+ SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
CvCONST_off(cv);
}
if (CvISXSUB(cv) && CvXSUB(cv)) {
return NULL;
if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
return NULL;
- return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
+ return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
dVAR;
- const char *aname;
GV *gv;
const char *ps;
STRLEN ps_len;
|| PL_madskills)
? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
+ bool has_name;
if (proto) {
assert(proto->op_type == OP_CONST);
else
ps = NULL;
- if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
+ if (name) {
+ gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
+ has_name = TRUE;
+ } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
SV * const sv = sv_newmortal();
Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
- aname = SvPVX_const(sv);
+ gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
+ has_name = TRUE;
+ } else if (PL_curstash) {
+ gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
+ has_name = FALSE;
+ } else {
+ gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
+ has_name = FALSE;
}
- else
- aname = NULL;
-
- gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
- : gv_fetchpv(aname ? aname
- : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
- gv_fetch_flags, SVt_PVCV);
if (!PL_madskills) {
if (o)
if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
maximum a prototype before. */
if (SvTYPE(gv) > SVt_NULL) {
- if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
- && ckWARN_d(WARN_PROTOTYPE))
+ if (!SvPOK((const SV *)gv)
+ && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
{
- Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
}
cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
}
if (ps)
- sv_setpvn((SV*)gv, ps, ps_len);
+ sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
else
- sv_setiv((SV*)gv, -1);
+ sv_setiv(MUTABLE_SV(gv), -1);
SvREFCNT_dec(PL_compcv);
cv = PL_compcv = NULL;
cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
-#ifdef GV_UNIQUE_CHECK
- if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
- Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
- }
-#endif
-
if (!block || !ps || *ps || attrs
|| (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
#ifdef PERL_MAD
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
-#ifdef GV_UNIQUE_CHECK
- if (exists && GvUNIQUE(gv)) {
- Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
- }
-#endif
-
/* if the subroutine doesn't exist and wasn't pre-declared
* with a prototype, assume it will be AUTOLOADed,
* skipping the prototype check
)&& !attrs) {
if (CvFLAGS(PL_compcv)) {
/* might have had built-in attrs applied */
- CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
+ if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
+ CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
}
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
SvREFCNT_inc_simple_void_NN(const_sv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
- sv_setpvs((SV*)cv, ""); /* prototype is "" */
+ sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
CvXSUBANY(cv).any_ptr = const_sv;
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
PL_compcv = NULL;
goto done;
}
- if (attrs) {
- HV *stash;
- SV *rcv;
-
- /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
- * before we clobber PL_compcv.
- */
- if (cv && (!block
+ if (cv) { /* must reuse cv if autoloaded */
+ /* transfer PL_compcv to cv */
+ if (block
#ifdef PERL_MAD
- || block->op_type == OP_NULL
+ && block->op_type != OP_NULL
#endif
- )) {
- rcv = (SV*)cv;
- /* Might have had built-in attributes applied -- propagate them. */
- CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
- if (CvGV(cv) && GvSTASH(CvGV(cv)))
- stash = GvSTASH(CvGV(cv));
- else if (CvSTASH(cv))
- stash = CvSTASH(cv);
- else
- stash = PL_curstash;
+ ) {
+ cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
+ cv_undef(cv);
+ CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
+ if (!CvWEAKOUTSIDE(cv))
+ SvREFCNT_dec(CvOUTSIDE(cv));
+ CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
+ CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
+ CvOUTSIDE(PL_compcv) = 0;
+ CvPADLIST(cv) = CvPADLIST(PL_compcv);
+ CvPADLIST(PL_compcv) = 0;
+ /* inner references to PL_compcv must be fixed up ... */
+ pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
+ if (PERLDB_INTER)/* Advice debugger on the new sub. */
+ ++PL_sub_generation;
}
else {
- /* possibly about to re-define existing subr -- ignore old cv */
- rcv = (SV*)PL_compcv;
- if (name && GvSTASH(gv))
- stash = GvSTASH(gv);
- else
- stash = PL_curstash;
- }
- apply_attrs(stash, rcv, attrs, FALSE);
- }
- if (cv) { /* must reuse cv if autoloaded */
- if (
-#ifdef PERL_MAD
- (
-#endif
- !block
-#ifdef PERL_MAD
- || block->op_type == OP_NULL) && !PL_madskills
-#endif
- ) {
- /* got here with just attrs -- work done, so bug out */
- SAVEFREESV(PL_compcv);
- goto done;
+ /* Might have had built-in attributes applied -- propagate them. */
+ CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
}
- /* transfer PL_compcv to cv */
- cv_undef(cv);
- CvFLAGS(cv) = CvFLAGS(PL_compcv);
- if (!CvWEAKOUTSIDE(cv))
- SvREFCNT_dec(CvOUTSIDE(cv));
- CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
- CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
- CvOUTSIDE(PL_compcv) = 0;
- CvPADLIST(cv) = CvPADLIST(PL_compcv);
- CvPADLIST(PL_compcv) = 0;
- /* inner references to PL_compcv must be fixed up ... */
- pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
/* ... before we throw it away */
SvREFCNT_dec(PL_compcv);
PL_compcv = cv;
- if (PERLDB_INTER)/* Advice debugger on the new sub. */
- ++PL_sub_generation;
}
else {
cv = PL_compcv;
GvCV(gv) = cv;
if (PL_madskills) {
if (strEQ(name, "import")) {
- PL_formfeed = (SV*)cv;
- Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
+ PL_formfeed = MUTABLE_SV(cv);
+ /* diag_listed_as: SKIPME */
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
}
}
GvCVGEN(gv) = 0;
mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
}
}
- CvGV(cv) = gv;
- CvFILE_set_from_cop(cv, PL_curcop);
- CvSTASH(cv) = PL_curstash;
+ if (!CvGV(cv)) {
+ CvGV(cv) = gv;
+ CvFILE_set_from_cop(cv, PL_curcop);
+ CvSTASH(cv) = PL_curstash;
+ }
+ if (attrs) {
+ /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
+ HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+ apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
+ }
if (ps)
- sv_setpvn((SV*)cv, ps, ps_len);
+ sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
if (PL_parser && PL_parser->error_count) {
op_free(block);
if (!block)
goto done;
+ /* If we assign an optree to a PVCV, then we've defined a subroutine that
+ the debugger could be able to set a breakpoint in, so signal to
+ pp_entereval that it should not throw away any saved lines at scope
+ exit. */
+
+ PL_breakable_sub_gen++;
if (CvLVALUE(cv)) {
CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
mod(scalarseq(block), OP_LEAVESUBLV));
CvCONST_on(cv);
}
- if (name || aname) {
+ if (has_name) {
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV * const sv = newSV(0);
SV * const tmpstr = sv_newmortal();
PUSHMARK(SP);
XPUSHs(tmpstr);
PUTBACK;
- call_sv((SV*)pcv, G_DISCARD);
+ call_sv(MUTABLE_SV(pcv), G_DISCARD);
}
}
}
SAVECOPLINE(&PL_compiling);
DEBUG_x( dump_sub(gv) );
- Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
+ Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
GvCV(gv) = 0; /* cv has been hijacked */
call_list(oldscope, PL_beginav);
if (*name == 'E') {
if strEQ(name, "END") {
DEBUG_x( dump_sub(gv) );
- Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
+ Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
} else
return;
} else if (*name == 'U') {
if (strEQ(name, "UNITCHECK")) {
/* It's never too late to run a unitcheck block */
- Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
+ Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
}
else
return;
} else if (*name == 'C') {
if (strEQ(name, "CHECK")) {
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID),
- "Too late to run CHECK block");
- Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
+ if (PL_main_start)
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Too late to run CHECK block");
+ Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
}
else
return;
} else if (*name == 'I') {
if (strEQ(name, "INIT")) {
- if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ packWARN(WARN_VOID),
- "Too late to run INIT block");
- Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
+ if (PL_main_start)
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Too late to run INIT block");
+ Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
}
else
return;
Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
eligible for inlining at compile-time.
+Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
+which won't be called if used as a destructor, but will suppress the overhead
+of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
+compile time.)
+
=cut
*/
dVAR;
CV* cv;
#ifdef USE_ITHREADS
- const char *const temp_p = CopFILE(PL_curcop);
- const STRLEN len = temp_p ? strlen(temp_p) : 0;
+ const char *const file = CopFILE(PL_curcop);
#else
SV *const temp_sv = CopFILESV(PL_curcop);
- STRLEN len;
- const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
+ const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
#endif
- char *const file = savepvn(temp_p, temp_p ? len : 0);
ENTER;
and so doesn't get free()d. (It's expected to be from the C pre-
processor __FILE__ directive). But we need a dynamically allocated one,
and we need it to get freed. */
- cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
+ cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
+ XS_DYNAMIC_FILENAME);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
- Safefree(file);
#ifdef USE_ITHREADS
if (stash)
}
/* This gets free()d. :-) */
- sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
+ sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
SV_HAS_TRAILING_NUL);
if (proto) {
/* This gives us the correct prototype, rather than one with the
}
CvFILE(cv) = proto_and_file + proto_len;
} else {
- sv_setpv((SV *)cv, proto);
+ sv_setpv(MUTABLE_SV(cv), proto);
}
return cv;
}
? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
: gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
-#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE(gv)) {
- Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
- }
-#endif
GvMULTI_on(gv);
if ((cv = GvFORM(gv))) {
if (ckWARN(WARN_REDEFINE)) {
const line_t oldline = CopLINE(PL_curcop);
if (PL_parser && PL_parser->copline != NOLINE)
CopLINE_set(PL_curcop, PL_parser->copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- o ? "Format %"SVf" redefined"
- : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
+ if (o) {
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
+ } else {
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ "Format STDOUT redefined");
+ }
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
{
return newUNOP(OP_REFGEN, 0,
newSVOP(OP_ANONCODE, 0,
- (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
+ MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
}
OP *
break;
default:
- if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
break;
}
return o;
break;
default:
- if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
break;
}
return o;
o->op_ppaddr = PL_ppaddr[OP_PADAV];
return o;
}
- else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
- && ckWARN(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "Using an array as a reference is deprecated");
+ else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "Using an array as a reference is deprecated");
}
return newUNOP(OP_RV2AV, 0, scalar(o));
}
o->op_ppaddr = PL_ppaddr[OP_PADHV];
return o;
}
- else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
- && ckWARN(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "Using a hash as a reference is deprecated");
+ else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "Using a hash as a reference is deprecated");
}
return newUNOP(OP_RV2HV, 0, scalar(o));
}
(left->op_flags & OPf_PARENS) == 0) ||
(OP_IS_NUMCOMPARE(right->op_type) &&
(right->op_flags & OPf_PARENS) == 0))
- if (ckWARN(WARN_PRECEDENCE))
- Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
- "Possible precedence problem on bitwise %c operator",
- o->op_type == OP_BIT_OR ? '|'
- : o->op_type == OP_BIT_AND ? '&' : '^'
- );
+ Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
+ "Possible precedence problem on bitwise %c operator",
+ o->op_type == OP_BIT_OR ? '|'
+ : o->op_type == OP_BIT_AND ? '&' : '^'
+ );
}
return o;
}
Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
OP_DESC(o));
}
+ if (kid->op_private & OPpLVAL_INTRO)
+ o->op_private |= OPpLVAL_INTRO;
op_null(kid);
}
return o;
if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
/* Store a copy of %^H that pp_entereval can pick up. */
OP *hhop = newSVOP(OP_HINTSEVAL, 0,
- (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
+ MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
cUNOPo->op_first->op_sibling = hhop;
o->op_private |= OPpEVAL_HAS_HH;
}
kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
GvIN_PAD_on(gv);
- PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
+ PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
#else
kid->op_sv = SvREFCNT_inc_simple_NN(gv);
#endif
break;
case OA_AVREF:
if ((type == OP_PUSH || type == OP_UNSHIFT)
- && !kid->op_sibling && ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Useless use of %s with no values",
- PL_op_desc[type]);
+ && !kid->op_sibling)
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Useless use of %s with no values",
+ PL_op_desc[type]);
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
OP * const newop = newAVREF(newGVOP(OP_GV, 0,
gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
- if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
- SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
+ SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
op_getmad(kid,newop,'K');
#else
{
OP * const newop = newHVREF(newGVOP(OP_GV, 0,
gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
- if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
- SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
+ SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
op_getmad(kid,newop,'K');
#else
gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
GvCV(gv) = GvCV(glob_gv);
- SvREFCNT_inc_void((SV*)GvCV(gv));
+ SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
GvIMPORTED_CV_on(gv);
LEAVE;
}
if (o->op_flags & OPf_STACKED) {
OP* k;
o = ck_sort(o);
- kid = cLISTOPo->op_first->op_sibling;
- if (!cUNOPx(kid)->op_next)
- Perl_croak(aTHX_ "panic: ck_grep");
- for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
+ kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
+ if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
+ return no_fh_allowed(o);
+ for (k = kid; k; k = k->op_next) {
kid = k;
}
NewOp(1101, gwop, 1, LOGOP);
gwop->op_flags |= OPf_KIDS;
gwop->op_other = LINKLIST(kid);
kid->op_next = (OP*)gwop;
- offset = pad_findmy("$_");
+ offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
o->op_private = gwop->op_private = 0;
gwop->op_targ = pad_alloc(type, SVs_PADTMP);
{
PERL_ARGS_ASSERT_CK_DEFINED;
- if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
+ if ((o->op_flags & OPf_KIDS)) {
switch (cUNOPo->op_first->op_type) {
case OP_RV2AV:
/* This is needed for
break; /* Globals via GV can be undef */
case OP_PADAV:
case OP_AASSIGN: /* Is this a good idea? */
- Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "defined(@array) is deprecated");
- Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "\t(Maybe you should just omit the defined()?)\n");
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "defined(@array) is deprecated");
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "\t(Maybe you should just omit the defined()?)\n");
break;
case OP_RV2HV:
- /* This is needed for
- if (defined %stash::)
- to work. Do not break Tk.
- */
- break; /* Globals via GV can be undef */
case OP_PADHV:
- Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "defined(%%hash) is deprecated");
- Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "\t(Maybe you should just omit the defined()?)\n");
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "defined(%%hash) is deprecated");
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "\t(Maybe you should just omit the defined()?)\n");
break;
default:
/* no warning */
PERL_ARGS_ASSERT_CK_MATCH;
if (o->op_type != OP_QR && PL_compcv) {
- const PADOFFSET offset = pad_findmy("$_");
+ const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
o->op_targ = offset;
o->op_private |= OPpTARGET_MY;
return newop;
}
- return ck_fun(o);
+ return scalar(ck_fun(o));
}
OP *
Perl_ck_return(pTHX_ OP *o)
{
dVAR;
+ OP *kid;
PERL_ARGS_ASSERT_CK_RETURN;
+ kid = cLISTOPo->op_first->op_sibling;
if (CvLVALUE(PL_compcv)) {
- OP *kid;
- for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (; kid; kid = kid->op_sibling)
mod(kid, OP_LEAVESUBLV);
+ } else {
+ for (; kid; kid = kid->op_sibling)
+ if ((kid->op_type == OP_NULL)
+ && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
+ /* This is a do block */
+ OP *op = kUNOP->op_first;
+ if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
+ op = cUNOPx(op)->op_first;
+ assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
+ /* Force the use of the caller's context */
+ op->op_flags |= OPf_SPECIAL;
+ }
+ }
}
+
return o;
}
PERL_ARGS_ASSERT_CK_SHIFT;
if (!(o->op_flags & OPf_KIDS)) {
- OP *argop;
- /* FIXME - this can be refactored to reduce code in #ifdefs */
-#ifdef PERL_MAD
- OP * const oldo = o;
-#else
- op_free(o);
-#endif
- argop = newUNOP(OP_RV2AV, 0,
+ OP *argop = newUNOP(OP_RV2AV, 0,
scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
#ifdef PERL_MAD
+ OP * const oldo = o;
o = newUNOP(type, 0, scalar(argop));
op_getmad(oldo,o,'O');
return o;
#else
+ op_free(o);
return newUNOP(type, 0, scalar(argop));
#endif
}
kid->op_type = OP_PUSHRE;
kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
scalar(kid);
- if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
- Perl_warner(aTHX_ packWARN(WARN_REGEXP),
- "Use of /g modifier is meaningless in split");
+ if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
+ "Use of /g modifier is meaningless in split");
}
if (!kid->op_sibling)
if (kid && kid->op_type == OP_MATCH) {
if (ckWARN(WARN_SYNTAX)) {
const REGEXP *re = PM_GETRE(kPMOP);
- const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
+ const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
const STRLEN len = re ? RX_PRELEN(re) : 6;
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"/%.*s/ should probably be written as \"%.*s\"",
o->op_private |= OPpENTERSUB_HASTARG;
for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
if (cvop->op_type == OP_RV2CV) {
- SVOP* tmpop;
o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
op_null(cvop); /* disable rv2cv */
- tmpop = (SVOP*)((UNOP*)cvop)->op_first;
- if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
- GV *gv = cGVOPx_gv(tmpop);
- cv = GvCVu(gv);
- if (!cv)
- tmpop->op_private |= OPpEARLY_CV;
- else {
- if (SvPOK(cv)) {
- STRLEN len;
- namegv = CvANON(cv) ? gv : CvGV(cv);
- proto = SvPV((SV*)cv, len);
- proto_end = proto + len;
- }
+ if (!(o->op_private & OPpENTERSUB_AMPER)) {
+ SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
+ GV *gv = NULL;
+ switch (tmpop->op_type) {
+ case OP_GV: {
+ gv = cGVOPx_gv(tmpop);
+ cv = GvCVu(gv);
+ if (!cv)
+ tmpop->op_private |= OPpEARLY_CV;
+ } break;
+ case OP_CONST: {
+ SV *sv = cSVOPx_sv(tmpop);
+ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
+ cv = (CV*)SvRV(sv);
+ } break;
+ }
+ if (cv && SvPOK(cv)) {
+ STRLEN len;
+ namegv = gv && CvANON(cv) ? gv : CvGV(cv);
+ proto = SvPV(MUTABLE_SV(cv), len);
+ proto_end = proto + len;
}
}
}
const char *p = proto;
const char *const end = proto;
contextclass = 0;
- while (*--p != '[');
+ while (*--p != '[') {}
bad_type(arg, Perl_form(aTHX_ "one of %.*s",
(int)(end - p), p),
gv_ename(namegv), o3);
Perl_ck_each(pTHX_ OP *o)
{
dVAR;
- OP *kid = cLISTOPo->op_first;
+ OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
PERL_ARGS_ASSERT_CK_EACH;
- if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
- const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
- : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
- o->op_type = new_type;
- o->op_ppaddr = PL_ppaddr[new_type];
- }
- else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
- || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
- )) {
- bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
- return o;
+ if (kid) {
+ if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
+ const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
+ : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
+ o->op_type = new_type;
+ o->op_ppaddr = PL_ppaddr[new_type];
+ }
+ else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
+ || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
+ )) {
+ bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
+ return o;
+ }
}
return ck_fun(o);
}
+/* caller is supposed to assign the return to the
+ container of the rep_op var */
+STATIC OP *
+S_opt_scalarhv(pTHX_ OP *rep_op) {
+ dVAR;
+ UNOP *unop;
+
+ PERL_ARGS_ASSERT_OPT_SCALARHV;
+
+ NewOp(1101, unop, 1, UNOP);
+ unop->op_type = (OPCODE)OP_BOOLKEYS;
+ unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
+ unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
+ unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
+ unop->op_first = rep_op;
+ unop->op_next = rep_op->op_next;
+ rep_op->op_next = (OP*)unop;
+ rep_op->op_flags|=(OPf_REF | OPf_MOD);
+ unop->op_sibling = rep_op->op_sibling;
+ rep_op->op_sibling = NULL;
+ /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
+ if (rep_op->op_type == OP_PADHV) {
+ rep_op->op_flags &= ~OPf_WANT_SCALAR;
+ rep_op->op_flags |= OPf_WANT_LIST;
+ }
+ return (OP*)unop;
+}
+
+/* Checks if o acts as an in-place operator on an array. oright points to the
+ * beginning of the right-hand side. Returns the left-hand side of the
+ * assignment if o acts in-place, or NULL otherwise. */
+
+STATIC OP *
+S_is_inplace_av(pTHX_ OP *o, OP *oright) {
+ OP *o2;
+ OP *oleft = NULL;
+
+ PERL_ARGS_ASSERT_IS_INPLACE_AV;
+
+ if (!oright ||
+ (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
+ || oright->op_next != o
+ || (oright->op_private & OPpLVAL_INTRO)
+ )
+ return NULL;
+
+ /* o2 follows the chain of op_nexts through the LHS of the
+ * assign (if any) to the aassign op itself */
+ o2 = o->op_next;
+ if (!o2 || o2->op_type != OP_NULL)
+ return NULL;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_PUSHMARK)
+ return NULL;
+ o2 = o2->op_next;
+ if (o2 && o2->op_type == OP_GV)
+ o2 = o2->op_next;
+ if (!o2
+ || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
+ || (o2->op_private & OPpLVAL_INTRO)
+ )
+ return NULL;
+ oleft = o2;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_NULL)
+ return NULL;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_AASSIGN
+ || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
+ return NULL;
+
+ /* check that the sort is the first arg on RHS of assign */
+
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_NULL)
+ return NULL;
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_PUSHMARK)
+ return NULL;
+ if (o2->op_sibling != o)
+ return NULL;
+
+ /* check the array is the same on both sides */
+ if (oleft->op_type == OP_RV2AV) {
+ if (oright->op_type != OP_RV2AV
+ || !cUNOPx(oright)->op_first
+ || cUNOPx(oright)->op_first->op_type != OP_GV
+ || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
+ cGVOPx_gv(cUNOPx(oright)->op_first)
+ )
+ return NULL;
+ }
+ else if (oright->op_type != OP_PADAV
+ || oright->op_targ != oleft->op_targ
+ )
+ return NULL;
+
+ return oleft;
+}
+
/* A peephole optimizer. We visit the ops in the order they're to execute.
* See the comments at the top of this file for more details about when
* peep() is called */
}
break;
+
+ {
+ OP *fop;
+ OP *sop;
+
+ case OP_NOT:
+ fop = cUNOP->op_first;
+ sop = NULL;
+ goto stitch_keys;
+ break;
- case OP_MAPWHILE:
- case OP_GREPWHILE:
- case OP_AND:
+ case OP_AND:
case OP_OR:
case OP_DOR:
+ fop = cLOGOP->op_first;
+ sop = fop->op_sibling;
+ while (cLOGOP->op_other->op_type == OP_NULL)
+ cLOGOP->op_other = cLOGOP->op_other->op_next;
+ peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
+
+ stitch_keys:
+ o->op_opt = 1;
+ if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
+ || ( sop &&
+ (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
+ )
+ ){
+ OP * nop = o;
+ OP * lop = o;
+ if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
+ while (nop && nop->op_next) {
+ switch (nop->op_next->op_type) {
+ case OP_NOT:
+ case OP_AND:
+ case OP_OR:
+ case OP_DOR:
+ lop = nop = nop->op_next;
+ break;
+ case OP_NULL:
+ nop = nop->op_next;
+ break;
+ default:
+ nop = NULL;
+ break;
+ }
+ }
+ }
+ if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
+ if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
+ cLOGOP->op_first = opt_scalarhv(fop);
+ if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
+ cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
+ }
+ }
+
+
+ break;
+ }
+
+ case OP_MAPWHILE:
+ case OP_GREPWHILE:
case OP_ANDASSIGN:
case OP_ORASSIGN:
case OP_DORASSIGN:
/* Make the CONST have a shared SV */
svp = cSVOPx_svp(((BINOP*)o)->op_last);
- if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
+ if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
key = SvPV_const(sv, keylen);
lexname = newSVpvn_share(key,
SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
oright = cUNOPx(oright)->op_sibling;
}
- if (!oright ||
- (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
- || oright->op_next != o
- || (oright->op_private & OPpLVAL_INTRO)
- )
- break;
-
- /* o2 follows the chain of op_nexts through the LHS of the
- * assign (if any) to the aassign op itself */
- o2 = o->op_next;
- if (!o2 || o2->op_type != OP_NULL)
- break;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_PUSHMARK)
- break;
- o2 = o2->op_next;
- if (o2 && o2->op_type == OP_GV)
- o2 = o2->op_next;
- if (!o2
- || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
- || (o2->op_private & OPpLVAL_INTRO)
- )
- break;
- oleft = o2;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_NULL)
- break;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_AASSIGN
- || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
- break;
-
- /* check that the sort is the first arg on RHS of assign */
-
- o2 = cUNOPx(o2)->op_first;
- if (!o2 || o2->op_type != OP_NULL)
- break;
- o2 = cUNOPx(o2)->op_first;
- if (!o2 || o2->op_type != OP_PUSHMARK)
- break;
- if (o2->op_sibling != o)
- break;
-
- /* check the array is the same on both sides */
- if (oleft->op_type == OP_RV2AV) {
- if (oright->op_type != OP_RV2AV
- || !cUNOPx(oright)->op_first
- || cUNOPx(oright)->op_first->op_type != OP_GV
- || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
- cGVOPx_gv(cUNOPx(oright)->op_first)
- )
- break;
- }
- else if (oright->op_type != OP_PADAV
- || oright->op_targ != oleft->op_targ
- )
+ oleft = is_inplace_av(o, oright);
+ if (!oleft)
break;
/* transfer MODishness etc from LHS arg to RHS arg */
case OP_REVERSE: {
OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
OP *gvop = NULL;
+ OP *oleft, *oright;
LISTOP *enter, *exlist;
+ /* @a = reverse @a */
+ if ((oright = cLISTOPo->op_first)
+ && (oright->op_type == OP_PUSHMARK)
+ && (oright = oright->op_sibling)
+ && (oleft = is_inplace_av(o, oright))) {
+ OP *o2;
+
+ /* transfer MODishness etc from LHS arg to RHS arg */
+ oright->op_flags = oleft->op_flags;
+ o->op_private |= OPpREVERSE_INPLACE;
+
+ /* excise push->gv->rv2av->null->aassign */
+ o2 = o->op_next->op_next;
+ op_null(o2); /* PUSHMARK */
+ o2 = o2->op_next;
+ if (o2->op_type == OP_GV) {
+ op_null(o2); /* GV */
+ o2 = o2->op_next;
+ }
+ op_null(o2); /* RV2AV or PADAV */
+ o2 = o2->op_next->op_next;
+ op_null(o2); /* AASSIGN */
+
+ o->op_next = o2->op_next;
+ break;
+ }
+
enter = (LISTOP *) o->op_next;
if (!enter)
break;
{
dVAR;
dXSARGS;
+ SV *const sv = MUTABLE_SV(XSANY.any_ptr);
if (items != 0) {
NOOP;
#if 0
+ /* diag_listed_as: SKIPME */
Perl_croak(aTHX_ "usage: %s::%s()",
HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
#endif
}
+ if (!sv) {
+ XSRETURN(0);
+ }
EXTEND(sp, 1);
- ST(0) = (SV*)XSANY.any_ptr;
+ ST(0) = sv;
XSRETURN(1);
}