case G_ARRAY: return list(o);
case G_VOID: return scalarvoid(o);
default:
- Perl_croak(aTHX_ "panic: op_contextualize bad context");
+ Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
+ (long) context);
return o;
}
}
no_bareword_allowed(o);
else {
if (ckWARN(WARN_VOID)) {
- if (SvOK(sv)) {
- SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
- "a constant (%"SVf")", sv));
- useless = SvPV_nolen(msv);
- useless_is_utf8 = SvUTF8(msv);
- }
- else
- useless = "a constant (undef)";
/* don't warn on optimised away booleans, eg
* use constant Foo, 5; Foo || print; */
if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
strnEQ(maybe_macro, "ds", 2) ||
strnEQ(maybe_macro, "ig", 2))
useless = NULL;
+ else {
+ SV * const dsv = newSVpvs("");
+ SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
+ "a constant (%s)",
+ pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
+ SvREFCNT_dec(dsv);
+ useless = SvPV_nolen(msv);
+ useless_is_utf8 = SvUTF8(msv);
+ }
+ }
+ else if (SvOK(sv)) {
+ SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
+ "a constant (%"SVf")", sv));
+ useless = SvPV_nolen(msv);
}
+ else
+ useless = "a constant (undef)";
}
}
op_null(o); /* don't execute or even remember it */
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
my_kid(kid, attrs, imopsp);
+ return o;
} else if (type == OP_UNDEF
#ifdef PERL_MAD
|| type == OP_STUB
&& (gv = cGVOPx_gv(cUNOPx(left)->op_first))
? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
: NULL
- : varname(NULL, isary ? '@' : '%', left->op_targ, NULL, 0, 1);
+ : varname(
+ (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
+ );
if (name)
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %"SVf" will act on scalar(%"SVf")",
case OP_SCMP:
case OP_SPRINTF:
/* XXX what about the numeric ops? */
- if (PL_hints & HINT_LOCALE)
+ if (IN_LOCALE_COMPILETIME)
goto nope;
break;
}
if (PL_hints & HINT_RE_TAINT)
pmop->op_pmflags |= PMf_RETAINT;
- if (PL_hints & HINT_LOCALE) {
+ if (IN_LOCALE_COMPILETIME) {
set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
}
- else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
+ else if ((! (PL_hints & HINT_BYTES))
+ /* Both UNI_8_BIT and locale :not_characters imply Unicode */
+ && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
+ {
set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
}
if (PL_hints & HINT_RE_FLAGS) {
CV *
Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
+ return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
+}
+
+CV *
+Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
+ OP *block, U32 flags)
+{
dVAR;
GV *gv;
const char *ps;
|| PL_madskills)
? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
STRLEN namlen = 0;
- const char * const name = o ? SvPV_const(cSVOPo->op_sv, namlen) : NULL;
+ const bool o_is_gv = flags & 1;
+ const char * const name =
+ o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
- bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0;
+ bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
if (proto) {
assert(proto->op_type == OP_CONST);
else
ps = NULL;
- if (name) {
+ if (o_is_gv) {
+ gv = (GV*)o;
+ o = NULL;
+ has_name = TRUE;
+ } else if (name) {
gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
has_name = TRUE;
} else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
if (ckWARN(WARN_SYNTAX)) {
const OP *kid = cUNOPo->op_first;
if (kid && (
- is_dollar_bracket(aTHX_ kid)
- || ((kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
+ (
+ is_dollar_bracket(aTHX_ kid)
+ && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
+ )
+ || ( kid->op_type == OP_CONST
+ && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"$[ used in %s (did you mean $] ?)", OP_DESC(o));
&& kidtype != OP_STAT && kidtype != OP_LSTAT) {
o->op_private |= OPpFT_STACKED;
kid->op_private |= OPpFT_STACKING;
+ if (kidtype == OP_FTTTY && (
+ !(kid->op_private & OPpFT_STACKED)
+ || kid->op_private & OPpFT_AFTER_t
+ ))
+ o->op_private |= OPpFT_AFTER_t;
}
}
else {
return o;
kid = cLISTOPo->op_first->op_sibling;
if (kid->op_type != OP_NULL)
- Perl_croak(aTHX_ "panic: ck_grep");
+ Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
kid = kUNOP->op_first;
if (!gwop)
if ((o->op_flags & OPf_KIDS)) {
switch (cUNOPo->op_first->op_type) {
case OP_RV2AV:
- /* This is needed for
- if (defined %stash::)
- to work. Do not break Tk.
- */
- break; /* Globals via GV can be undef */
case OP_PADAV:
case OP_AASSIGN: /* Is this a good idea? */
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
kid = cLISTOPo->op_first;
if (kid->op_type != OP_NULL)
- Perl_croak(aTHX_ "panic: ck_split");
+ Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
kid = kid->op_sibling;
op_free(cLISTOPo->op_first);
if (kid)
const char *e = NULL;
PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
- Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
+ Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
+ "flags=%lx", (unsigned long) SvFLAGS(protosv));
if (SvTYPE(protosv) == SVt_PVCV)
proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
else proto = SvPV(protosv, proto_len);
continue;
case '_':
/* _ must be at the end */
- if (proto[1] && proto[1] != ';')
+ if (proto[1] && !strchr(";@%", proto[1]))
goto oops;
case '$':
proto++;
for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
aop = aop->op_sibling;
- continue;
}
if (aop != cvop)
(void)too_many_arguments(entersubop, GvNAME(namegv));
case OP_PADHV:
case OP_PADAV:
name = varname(
- NULL, hash ? '%' : '@', kid->op_targ, NULL, 0, 1
+ (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
+ NULL, 0, 1
);
break;
case OP_RV2HV:
return;
assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
- oright = cUNOPx(modop)->op_first->op_sibling;
+ if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
if (modop->op_flags & OPf_STACKED) {
/* skip sort subroutine/block */