{
/* 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 \"my\"",
- 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]), name + 2,
+ PL_parser->in_my == KEY_state ? "state" : "my"));
} else {
- yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
+ yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
+ PL_parser->in_my == KEY_state ? "state" : "my"));
}
}
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 */
+
+ if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
+ CvCLONE_on(PL_compcv);
+
return off;
}
dVAR;
OPCODE type;
- if (!o || o->op_static)
+ if (!o)
return;
if (o->op_latefreed) {
if (o->op_latefree)
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;
/* 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;
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;
/* -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)
dVAR;
OP *kid;
- if (!o || PL_error_count)
+ if (!o || (PL_parser && PL_parser->error_count))
return o;
switch (o->op_type) {
dVAR;
I32 type;
- if (!o || PL_error_count)
+ if (!o || (PL_parser && PL_parser->error_count))
return o;
type = o->op_type;
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)) {
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);
}
MADPROP *
-Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
+Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
{
MADPROP *mp;
Newxz(mp, 1, MADPROP);
pm = (PMOP*)o;
if (expr->op_type == OP_CONST) {
- STRLEN plen;
SV * const pat = ((SVOP*)expr)->op_sv;
- const char *p = SvPV_const(pat, plen);
U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
- if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
- U32 was_readonly = SvREADONLY(pat);
- if (was_readonly) {
- if (SvFAKE(pat)) {
- sv_force_normal_flags(pat, 0);
- assert(!SvREADONLY(pat));
- was_readonly = 0;
- } else {
- SvREADONLY_off(pat);
- }
- }
+ if (o->op_flags & OPf_SPECIAL)
+ pm_flags |= RXf_SPLIT;
- sv_setpvn(pat, "\\s+", 3);
-
- SvFLAGS(pat) |= was_readonly;
-
- p = SvPV_const(pat, plen);
- pm_flags |= RXf_SKIPWHITE;
- }
- if (DO_UTF8(pat))
+ if (DO_UTF8(pat))
pm_flags |= RXf_UTF8;
+
PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
#ifdef PERL_MAD
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;
if (curop == repl
&& !(repl_has_vars
&& (!PM_GETRE(pm)
- || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
+ || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
{
pm->op_pmflags |= PMf_CONST; /* const for long enough */
prepend_elem(o->op_type, scalar(repl), o);
}
if (is_list_assignment(left)) {
+ static const char no_list_state[] = "Initialization of state variables"
+ " in list context currently forbidden";
OP *curop;
PL_modcount = 0;
/* Grandfathering $[ assignment here. Bletch.*/
/* Only simple assignments like C<< ($[) = 1 >> are allowed */
- PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
+ PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
left = mod(left, OP_AASSIGN);
if (PL_eval_start)
PL_eval_start = 0;
o->op_private |= OPpASSIGN_COMMON;
}
- if (right && right->op_type == OP_SPLIT) {
+ if ((left->op_type == OP_LIST
+ || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) {
+ OP* lop = ((LISTOP*)left)->op_first;
+ while (lop) {
+ if (lop->op_type == OP_PADSV ||
+ lop->op_type == OP_PADAV ||
+ lop->op_type == OP_PADHV ||
+ lop->op_type == OP_PADANY) {
+ if (lop->op_private & OPpPAD_STATE) {
+ if (left->op_private & OPpLVAL_INTRO) {
+ /* Each variable in state($a, $b, $c) = ... */
+ }
+ else {
+ /* Each state variable in
+ (state $a, my $b, our $c, $d, undef) = ... */
+ }
+ yyerror(no_list_state);
+ } else {
+ /* Each my variable in
+ (state $a, my $b, our $c, $d, undef) = ... */
+ }
+ } else {
+ /* Other ops in the list. undef may be interesting in
+ (state $a, undef, state $c) */
+ }
+ lop = lop->op_sibling;
+ }
+ }
+ else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
+ == (OPpLVAL_INTRO | OPpPAD_STATE))
+ && ( left->op_type == OP_PADSV
+ || left->op_type == OP_PADAV
+ || left->op_type == OP_PADHV
+ || left->op_type == OP_PADANY))
+ {
+ /* All single variable list context state assignments, hence
+ state ($a) = ...
+ (state $a) = ...
+ state @a = ...
+ state (@a) = ...
+ (state @a) = ...
+ state %a = ...
+ state (%a) = ...
+ (state %a) = ...
+ */
+ yyerror(no_list_state);
+ }
+
+ 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;
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;
/* 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;
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) {
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))
{
Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
looks_like_bool(cLOGOPo->op_first)
&& looks_like_bool(cLOGOPo->op_first->op_sibling));
+ case OP_NULL:
+ return (
+ o->op_flags & OPf_KIDS
+ && looks_like_bool(cUNOPo->op_first));
+
case OP_ENTERSUB:
case OP_NOT: case OP_XOR:
Perl_cv_undef(pTHX_ CV *cv)
{
dVAR;
+
+ DEBUG_X(PerlIO_printf(Perl_debug_log,
+ "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
+ PTR2UV(cv), PTR2UV(PL_comppad))
+ );
+
#ifdef USE_ITHREADS
if (CvFILE(cv) && !CvISXSUB(cv)) {
/* for XSUBs CvFILE point directly to static memory; __FILE__ */
dVAR;
SV *sv = NULL;
+ if (PL_madskills)
+ return NULL;
+
if (!o)
return NULL;
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) {
CopFILE(PL_curcop),
(long)PL_subline, (long)CopLINE(PL_curcop));
gv_efullname3(tmpstr, gv, NULL);
- hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
+ (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
+ SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
CV * const pcv = GvCV(db_postponed);
}
}
- if (name && !PL_error_count)
+ if (name && ! (PL_parser && PL_parser->error_count))
process_special_blocks(name, gv, cv);
}
ENTER;
+ if (IN_PERL_RUNTIME) {
+ /* at runtime, it's not safe to manipulate PL_curcop: it may be
+ * an op shared between threads. Use a non-shared COP for our
+ * dirty work */
+ SAVEVPTR(PL_curcop);
+ PL_curcop = &PL_compiling;
+ }
SAVECOPLINE(PL_curcop);
CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
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;
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;
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)
OP *
Perl_ck_sassign(pTHX_ OP *o)
{
+ dVAR;
OP * const kid = cLISTOPo->op_first;
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
return kid;
}
}
+ if (kid->op_sibling) {
+ OP *kkid = kid->op_sibling;
+ if (kkid->op_type == OP_PADSV
+ && (kkid->op_private & OPpLVAL_INTRO)
+ && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
+ const PADOFFSET target = kkid->op_targ;
+ OP *const other = newOP(OP_PADSV,
+ kkid->op_flags
+ | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
+ OP *const first = newOP(OP_NULL, 0);
+ OP *const nullop = newCONDOP(0, first, o, other);
+ OP *const condop = first->op_next;
+ /* hijacking PADSTALE for uninitialized state variables */
+ SvPADSTALE_on(PAD_SVl(target));
+
+ condop->op_type = OP_ONCE;
+ condop->op_ppaddr = PL_ppaddr[OP_ONCE];
+ condop->op_targ = target;
+ other->op_targ = target;
+
+ /* Because we change the type of the op here, we will skip the
+ assinment binop->op_last = binop->op_first->op_sibling; at the
+ end of Perl_newBINOP(). So need to do it here. */
+ cBINOPo->op_last = cBINOPo->op_first->op_sibling;
+
+ return nullop;
+ }
+ }
return o;
}
SV * const sv = kid->op_sv;
U32 was_readonly = SvREADONLY(sv);
char *s;
+ STRLEN len;
+ const char *end;
if (was_readonly) {
if (SvFAKE(sv)) {
}
}
- for (s = SvPVX(sv); *s; s++) {
+ s = SvPVX(sv);
+ len = SvCUR(sv);
+ end = s + len;
+ for (; s < end; s++) {
if (*s == ':' && s[1] == ':') {
- const STRLEN len = strlen(s+2)+1;
*s = '/';
- Move(s+2, s+1, len, char);
- SvCUR_set(sv, SvCUR(sv) - 1);
+ Move(s+2, s+1, end - s - 1, char);
+ --end;
}
}
+ SvEND_set(sv, end);
sv_catpvs(sv, ".pm");
SvFLAGS(sv) |= was_readonly;
}
if (kid && kid->op_type == OP_MATCH) {
if (ckWARN(WARN_SYNTAX)) {
const REGEXP *re = PM_GETRE(kPMOP);
- const char *pmstr = re ? re->precomp : "STRING";
- const STRLEN len = re ? re->prelen : 6;
+ const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
+ const STRLEN len = re ? RX_PRELEN(re) : 6;
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"/%.*s/ should probably be written as \"%.*s\"",
(int)len, pmstr, (int)len, pmstr);
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");
- }
- }
- }
}
}
}
return o;
}
+OP *
+Perl_ck_each(pTHX_ OP *o)
+{
+
+ OP *kid = cLISTOPo->op_first;
+
+ 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);
+}
+
/* 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 */
case OP_DORASSIGN:
case OP_COND_EXPR:
case OP_RANGE:
+ case OP_ONCE:
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 */
UNOP *refgen, *rv2cv;
LISTOP *exlist;
- if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
+ if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
break;
if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
LEAVE;
}
-char*
+const char*
Perl_custom_op_name(pTHX_ const OP* o)
{
dVAR;
return SvPV_nolen(HeVAL(he));
}
-char*
+const char*
Perl_custom_op_desc(pTHX_ const OP* o)
{
dVAR;
https://perl5.git.perl.org / perl5.git / blobdiff