o->op_targ = 0;
break;
default:
- if (!(o->op_flags & OPf_REF)
- || (PL_check[o->op_type] != Perl_ck_ftst))
+ if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
break;
/* FALLTHROUGH */
case OP_GVSV:
/* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
their argument is a filehandle; thus \stat(".") should not set
it. AMS 20011102 */
- if (type == OP_REFGEN &&
- PL_check[o->op_type] == Perl_ck_ftst)
+ if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
return o;
if (type != OP_LEAVESUBLV)
{
dVAR;
LISTOP *listop;
+ /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
+ * pushmark is banned. So do it now while existing ops are in a
+ * consistent state, in case they suddenly get freed */
+ OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
|| type == OP_CUSTOM);
NewOp(1101, listop, 1, LISTOP);
-
OpTYPE_set(listop, type);
if (first || last)
flags |= OPf_KIDS;
OpMORESIB_set(first, last);
listop->op_first = first;
listop->op_last = last;
- if (type == OP_LIST) {
- OP* const pushop = newOP(OP_PUSHMARK, 0);
+
+ if (pushop) {
OpMORESIB_set(pushop, first);
listop->op_first = pushop;
listop->op_flags |= OPf_KIDS;
Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
{
OP *veop, *imop;
- OP * const modname = newSVOP(OP_CONST, 0, name);
+ OP * modname;
+ I32 floor;
PERL_ARGS_ASSERT_VLOAD_MODULE;
+ /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
+ * that it has a PL_parser to play with while doing that, and also
+ * that it doesn't mess with any existing parser, by creating a tmp
+ * new parser with lex_start(). This won't actually be used for much,
+ * since pp_require() will create another parser for the real work.
+ * The ENTER/LEAVE pair protect callers from any side effects of use.
+ *
+ * start_subparse() creates a new PL_compcv. This means that any ops
+ * allocated below will be allocated from that CV's op slab, and so
+ * will be automatically freed if the utilise() fails
+ */
+
+ ENTER;
+ SAVEVPTR(PL_curcop);
+ lex_start(NULL, NULL, LEX_START_SAME_FILTER);
+ floor = start_subparse(FALSE, 0);
+
+ modname = newSVOP(OP_CONST, 0, name);
modname->op_private |= OPpCONST_BARE;
if (ver) {
veop = newSVOP(OP_CONST, 0, ver);
}
}
- /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
- * that it has a PL_parser to play with while doing that, and also
- * that it doesn't mess with any existing parser, by creating a tmp
- * new parser with lex_start(). This won't actually be used for much,
- * since pp_require() will create another parser for the real work.
- * The ENTER/LEAVE pair protect callers from any side effects of use. */
-
- ENTER;
- SAVEVPTR(PL_curcop);
- lex_start(NULL, NULL, LEX_START_SAME_FILTER);
- utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
- veop, modname, imop);
+ utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
LEAVE;
}
))
/* Return the block now, so that S_new_logop does not try to
fold it away. */
- return block; /* do {} while 0 does once */
+ {
+ op_free(expr);
+ return block; /* do {} while 0 does once */
+ }
+
if (expr->op_type == OP_READLINE
|| expr->op_type == OP_READDIR
|| expr->op_type == OP_GLOB
if (cv) { /* must reuse cv in case stub is referenced elsewhere */
/* transfer PL_compcv to cv */
if (block) {
+ bool free_file = CvFILE(cv) && CvDYNFILE(cv);
cv_flags_t preserved_flags =
CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
PADLIST *const temp_padl = CvPADLIST(cv);
CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
CvFLAGS(compcv) |= other_flags;
- if (CvFILE(cv) && CvDYNFILE(cv)) {
+ if (free_file) {
Safefree(CvFILE(cv));
+ CvFILE(cv) = NULL;
}
/* inner references to compcv must be fixed up ... */
if (const_sv)
goto clone;
+ if (CvFILE(cv) && CvDYNFILE(cv))
+ Safefree(CvFILE(cv));
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
return FALSE;
} else {
if (*name == 'E') {
- if strEQ(name, "END") {
+ if (strEQ(name, "END")) {
DEBUG_x( dump_sub(gv) );
Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
} else
scalar((OP *) kid);
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
o->op_private |= OPpFT_ACCESS;
- if (type != OP_STAT && type != OP_LSTAT
- && PL_check[kidtype] == Perl_ck_ftst
- && kidtype != OP_STAT && kidtype != OP_LSTAT
+ if (OP_IS_FILETEST(type)
+ && OP_IS_FILETEST(kidtype)
) {
o->op_private |= OPpFT_STACKED;
kid->op_private |= OPpFT_STACKING;
*tmpbuf = '&';
assert (len < 256);
Copy(name, tmpbuf+1, len, char);
- off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
+ off = pad_findmy_pvn(tmpbuf, len+1, 0);
if (off != NOT_IN_PAD) {
if (PAD_COMPNAME_FLAGS_isOUR(off)) {
SV * const fq =
case OA_UNOP:
case OA_BASEOP_OR_UNOP:
case OA_FILESTATOP:
- return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
+ if (!aop)
+ return newOP(opnum,flags); /* zero args */
+ if (aop == prev)
+ return newUNOP(opnum,flags,aop); /* one arg */
+ /* too many args */
+ /* FALLTHROUGH */
case OA_BASEOP:
if (aop) {
- SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
+ SV *namesv;
+ OP *nextop;
+
+ namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
SVfARG(namesv)), SvUTF8(namesv));
- op_free(aop);
+ while (aop) {
+ nextop = OpSIBLING(aop);
+ op_free(aop);
+ aop = nextop;
+ }
+
}
return opnum == OP_RUNCV
? newPVOP(OP_RUNCV,0,NULL)
=cut
*/
+
+/* use PERL_MAGIC_ext to call a function to free the xop structure when
+ * freeing PL_custom_ops */
+
+static int
+custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
+{
+ XOP *xop;
+
+ PERL_UNUSED_ARG(mg);
+ xop = INT2PTR(XOP *, SvIV(sv));
+ Safefree(xop->xop_name);
+ Safefree(xop->xop_desc);
+ Safefree(xop);
+ return 0;
+}
+
+
+static const MGVTBL custom_op_register_vtbl = {
+ 0, /* get */
+ 0, /* set */
+ 0, /* len */
+ 0, /* clear */
+ custom_op_register_free, /* free */
+ 0, /* copy */
+ 0, /* dup */
+#ifdef MGf_LOCAL
+ 0, /* local */
+#endif
+};
+
+
XOPRETANY
Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
{
if (PL_custom_ops)
he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
- /* assume noone will have just registered a desc */
+ /* See if the op isn't registered, but its name *is* registered.
+ * That implies someone is using the pre-5.14 API,where only name and
+ * description could be registered. If so, fake up a real
+ * registration.
+ * We only check for an existing name, and assume no one will have
+ * just registered a desc */
if (!he && PL_custom_op_names &&
(he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
) {
XopENTRY_set(xop, xop_desc, savepvn(pv, l));
}
Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
+ he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
+ /* add magic to the SV so that the xop struct (pointed to by
+ * SvIV(sv)) is freed. Normally a static xop is registered, but
+ * for this backcompat hack, we've alloced one */
+ (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
+ &custom_op_register_vtbl, NULL, 0);
+
}
else {
if (!he)
Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
const int opnum)
{
- OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
+ OP * const argop = (opnum == OP_SELECT && code) ? NULL :
+ newSVOP(OP_COREARGS,0,coreargssv);
OP *o;
PERL_ARGS_ASSERT_CORESUB_OP;
https://perl5.git.perl.org / perl5.git / blobdiff