X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/53a7735b62aee14640bc8ca619b4267f07d686b9..225593e1515f97126032fb4da0b1aafeb00e8e99:/op.c

diff --git a/op.c b/op.c
index 1c793e3..731dce4 100644
--- a/op.c
+++ b/op.c
@@ -352,7 +352,7 @@ Perl_allocmy(pTHX_ const char *const name)
 {
     dVAR;
     PADOFFSET off;
-    const bool is_our = (PL_in_my == KEY_our);
+    const bool is_our = (PL_parser->in_my == KEY_our);
 
     /* complain about "my $<special_var>" etc etc */
     if (*name &&
@@ -373,24 +373,25 @@ Perl_allocmy(pTHX_ const char *const name)
     /* check for duplicate declaration */
     pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
 
-    if (PL_in_my_stash && *name != '$') {
+    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_in_my == KEY_state ? "state" : "my"));
+ 		     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,
-		    PL_in_my_stash,
+		    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_in_my == KEY_state
+		    PL_parser->in_my == KEY_state
     );
     return off;
 }
@@ -798,7 +799,8 @@ Perl_scalar(pTHX_ OP *o)
     OP *kid;
 
     /* assumes no premature commitment */
-    if (!o || PL_error_count || (o->op_flags & OPf_WANT)
+    if (!o || (PL_parser && PL_parser->error_count)
+	 || (o->op_flags & OPf_WANT)
 	 || o->op_type == OP_RETURN)
     {
 	return o;
@@ -896,7 +898,8 @@ Perl_scalarvoid(pTHX_ OP *o)
 
     /* assumes no premature commitment */
     want = o->op_flags & OPf_WANT;
-    if ((want && want != OPf_WANT_SCALAR) || PL_error_count
+    if ((want && want != OPf_WANT_SCALAR)
+	 || (PL_parser && PL_parser->error_count)
 	 || o->op_type == OP_RETURN)
     {
 	return o;
@@ -1141,7 +1144,8 @@ Perl_list(pTHX_ OP *o)
     OP *kid;
 
     /* assumes no premature commitment */
-    if (!o || (o->op_flags & OPf_WANT) || PL_error_count
+    if (!o || (o->op_flags & OPf_WANT)
+	 || (PL_parser && PL_parser->error_count)
 	 || o->op_type == OP_RETURN)
     {
 	return o;
@@ -1267,7 +1271,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
     int localize = -1;
 
-    if (!o || PL_error_count)
+    if (!o || (PL_parser && PL_parser->error_count))
 	return o;
 
     if ((o->op_private & OPpTARGET_MY)
@@ -1696,7 +1700,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
     dVAR;
     OP *kid;
 
-    if (!o || PL_error_count)
+    if (!o || (PL_parser && PL_parser->error_count))
 	return o;
 
     switch (o->op_type) {
@@ -1944,7 +1948,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
     dVAR;
     I32 type;
 
-    if (!o || PL_error_count)
+    if (!o || (PL_parser && PL_parser->error_count))
 	return o;
 
     type = o->op_type;
@@ -1969,11 +1973,13 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
 	if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
 	    yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
 			OP_DESC(o),
-			PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
+			PL_parser->in_my == KEY_our
+			    ? "our"
+			    : PL_parser->in_my == KEY_state ? "state" : "my"));
 	} else if (attrs) {
 	    GV * const gv = cGVOPx_gv(cUNOPo->op_first);
-	    PL_in_my = FALSE;
-	    PL_in_my_stash = NULL;
+	    PL_parser->in_my = FALSE;
+	    PL_parser->in_my_stash = NULL;
 	    apply_attrs(GvSTASH(gv),
 			(type == OP_RV2SV ? GvSV(gv) :
 			 type == OP_RV2AV ? (SV*)GvAV(gv) :
@@ -1990,14 +1996,16 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
     {
 	yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
 			  OP_DESC(o),
-			  PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
+			  PL_parser->in_my == KEY_our
+			    ? "our"
+			    : PL_parser->in_my == KEY_state ? "state" : "my"));
 	return o;
     }
     else if (attrs && type != OP_PUSHMARK) {
 	HV *stash;
 
-	PL_in_my = FALSE;
-	PL_in_my_stash = NULL;
+	PL_parser->in_my = FALSE;
+	PL_parser->in_my_stash = NULL;
 
 	/* check for C<my Dog $spot> when deciding package */
 	stash = PAD_COMPNAME_TYPE(o->op_targ);
@@ -2007,7 +2015,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
     }
     o->op_flags |= OPf_MOD;
     o->op_private |= OPpLVAL_INTRO;
-    if (PL_in_my == KEY_state)
+    if (PL_parser->in_my == KEY_state)
 	o->op_private |= OPpPAD_STATE;
     return o;
 }
@@ -2041,8 +2049,8 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs)
 	else
 	    o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
     }
-    PL_in_my = FALSE;
-    PL_in_my_stash = NULL;
+    PL_parser->in_my = FALSE;
+    PL_parser->in_my_stash = NULL;
     return o;
 }
 
@@ -2260,10 +2268,11 @@ Perl_localize(pTHX_ OP *o, I32 lex)
 	NOOP;
 #endif
     else {
-	if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
+	if ( PL_parser->bufptr > PL_parser->oldbufptr
+	    && PL_parser->bufptr[-1] == ','
 	    && ckWARN(WARN_PARENTHESIS))
 	{
-	    char *s = PL_bufptr;
+	    char *s = PL_parser->bufptr;
 	    bool sigil = FALSE;
 
 	    /* some heuristics to detect a potential error */
@@ -2286,8 +2295,13 @@ Perl_localize(pTHX_ OP *o, I32 lex)
 	    if (sigil && (*s == ';' || *s == '=')) {
 		Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
 				"Parentheses missing around \"%s\" list",
-				lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
-				: "local");
+				lex
+				    ? (PL_parser->in_my == KEY_our
+					? "our"
+					: PL_parser->in_my == KEY_state
+					    ? "state"
+					    : "my")
+				    : "local");
 	    }
 	}
     }
@@ -2295,8 +2309,8 @@ Perl_localize(pTHX_ OP *o, I32 lex)
 	o = my(o);
     else
 	o = mod(o, OP_NULL);		/* a bit kludgey */
-    PL_in_my = FALSE;
-    PL_in_my_stash = NULL;
+    PL_parser->in_my = FALSE;
+    PL_parser->in_my_stash = NULL;
     return o;
 }
 
@@ -2362,7 +2376,7 @@ Perl_fold_constants(pTHX_ register OP *o)
 	    goto nope;
     }
 
-    if (PL_error_count)
+    if (PL_parser && PL_parser->error_count)
 	goto nope;		/* Don't try to run w/ errors */
 
     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
@@ -2448,7 +2462,7 @@ Perl_gen_constant_list(pTHX_ register OP *o)
     const I32 oldtmps_floor = PL_tmps_floor;
 
     list(o);
-    if (PL_error_count)
+    if (PL_parser && PL_parser->error_count)
 	return o;		/* Don't attempt to run with errors */
 
     PL_op = curop = LINKLIST(o);
@@ -2817,7 +2831,7 @@ Perl_mad_free(pTHX_ MADPROP* mp)
 	return;
     if (mp->mad_next)
 	mad_free(mp->mad_next);
-/*    if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
+/*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
 	PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
     switch (mp->mad_type) {
     case MAD_NULL:
@@ -3483,8 +3497,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
 	OP *curop;
 	if (pm->op_pmflags & PMf_EVAL) {
 	    curop = NULL;
-	    if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
-		CopLINE_set(PL_curcop, (line_t)PL_multi_end);
+	    if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
+		CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
 	}
 	else if (repl->op_type == OP_CONST)
 	    curop = repl;
@@ -3865,7 +3879,7 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
 
     ENTER;
     SAVEVPTR(PL_curcop);
-    lex_start(NULL);
+    lex_start(NULL, NULL, FALSE);
     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
 	    veop, modname, imop);
     LEAVE;
@@ -4062,7 +4076,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 		o->op_private |= OPpASSIGN_COMMON;
 	}
 
-	if (right && right->op_type == OP_SPLIT) {
+	if (right && right->op_type == OP_SPLIT && !PL_madskills) {
 	    OP* tmpop = ((LISTOP*)right)->op_first;
 	    if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
 		PMOP * const pm = (PMOP*)tmpop;
@@ -4092,11 +4106,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 			tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
 			tmpop->op_sibling = NULL;	/* don't free split */
 			right->op_next = tmpop->op_next;  /* fix starting loc */
-#ifdef PERL_MAD
-			op_getmad(o,right,'R');		/* blow off assign */
-#else
 			op_free(o);			/* blow off assign */
-#endif
 			right->op_flags &= ~OPf_WANT;
 				/* "I don't know and I don't care." */
 			return right;
@@ -4229,7 +4239,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
     if (first->op_type == OP_NOT
 	&& (first->op_flags & OPf_SPECIAL)
-	&& (first->op_flags & OPf_KIDS)) {
+	&& (first->op_flags & OPf_KIDS)
+	&& !PL_madskills) {
 	if (type == OP_AND || type == OP_OR) {
 	    if (type == OP_AND)
 		type = OP_OR;
@@ -4240,11 +4251,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
 	    if (o->op_next)
 		first->op_next = o->op_next;
 	    cUNOPo->op_first = NULL;
-#ifdef PERL_MAD
-	    op_getmad(o,first,'O');
-#else
 	    op_free(o);
-#endif
 	}
     }
     if (first->op_type == OP_CONST) {
@@ -5451,7 +5458,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     if (ps)
 	sv_setpvn((SV*)cv, ps, ps_len);
 
-    if (PL_error_count) {
+    if (PL_parser && PL_parser->error_count) {
 	op_free(block);
 	block = NULL;
 	if (name) {
@@ -5536,7 +5543,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    }
 	}
 
-	if (name && !PL_error_count)
+	if (name && ! (PL_parser && PL_parser->error_count))
 	    process_special_blocks(name, gv, cv);
     }
 
@@ -6239,7 +6246,8 @@ Perl_ck_exists(pTHX_ OP *o)
 	OP * const kid = cUNOPo->op_first;
 	if (kid->op_type == OP_ENTERSUB) {
 	    (void) ref(kid, o->op_type);
-	    if (kid->op_type != OP_RV2CV && !PL_error_count)
+	    if (kid->op_type != OP_RV2CV
+			&& !(PL_parser && PL_parser->error_count))
 		Perl_croak(aTHX_ "%s argument is not a subroutine name",
 			    OP_DESC(o));
 	    o->op_private |= OPpEXISTS_SUB;
@@ -6755,7 +6763,7 @@ Perl_ck_grep(pTHX_ OP *o)
     PADOFFSET offset;
 
     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
-    /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
+    /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
 
     if (o->op_flags & OPf_STACKED) {
 	OP* k;
@@ -6776,7 +6784,7 @@ Perl_ck_grep(pTHX_ OP *o)
     else
 	scalar(kid);
     o = ck_fun(o);
-    if (PL_error_count)
+    if (PL_parser && PL_parser->error_count)
 	return o;
     kid = cLISTOPo->op_first->op_sibling;
     if (kid->op_type != OP_NULL)
@@ -6964,7 +6972,10 @@ Perl_ck_sassign(pTHX_ OP *o)
     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
 	&& !(kid->op_flags & OPf_STACKED)
 	/* Cannot steal the second time! */
-	&& !(kid->op_private & OPpTARGET_MY))
+	&& !(kid->op_private & OPpTARGET_MY)
+	/* Keep the full thing for madskills */
+	&& !PL_madskills
+	)
     {
 	OP * const kkid = kid->op_sibling;
 
@@ -6977,13 +6988,8 @@ Perl_ck_sassign(pTHX_ OP *o)
 	    /* Now we do not need PADSV and SASSIGN. */
 	    kid->op_sibling = o->op_sibling;	/* NULL */
 	    cLISTOPo->op_first = NULL;
-#ifdef PERL_MAD
-	    op_getmad(o,kid,'O');
-	    op_getmad(kkid,kid,'M');
-#else
 	    op_free(o);
 	    op_free(kkid);
-#endif
 	    kid->op_private |= OPpTARGET_MY;	/* Used for context settings */
 	    return kid;
 	}
@@ -7501,26 +7507,6 @@ Perl_ck_subr(pTHX_ OP *o)
 		    proto = SvPV((SV*)cv, len);
 		    proto_end = proto + len;
 		}
-		if (CvASSERTION(cv)) {
-		    U32 asserthints = 0;
-		    HV *const hinthv = GvHV(PL_hintgv);
-		    if (hinthv) {
-			SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
-			if (svp && *svp)
-			    asserthints = SvUV(*svp);
-		    }
-		    if (asserthints & HINT_ASSERTING) {
-			if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
-			    o->op_private |= OPpENTERSUB_DB;
-		    }
-		    else {
-			delete_op = 1;
-			if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
-			    Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
-					"Impossible to activate assertion call");
-			}
-		    }
-		}
 	    }
 	}
     }
@@ -8418,7 +8404,7 @@ Perl_peep(pTHX_ register OP *o)
     LEAVE;
 }
 
-char*
+const char*
 Perl_custom_op_name(pTHX_ const OP* o)
 {
     dVAR;
@@ -8438,7 +8424,7 @@ Perl_custom_op_name(pTHX_ const OP* o)
     return SvPV_nolen(HeVAL(he));
 }
 
-char*
+const char*
 Perl_custom_op_desc(pTHX_ const OP* o)
 {
     dVAR;