#define PERL_IN_OP_C
#include "perl.h"
#include "keywords.h"
+#include "feature.h"
#define CALL_PEEP(o) PL_peepp(aTHX_ o)
#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
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;
}
}
assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
+ if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
+
switch (o->op_type) {
case OP_UNDEF:
localize = 0;
|(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
PL_modcount = RETURN_UNLIMITED_NUMBER;
if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
- /* Backward compatibility mode: */
+ /* Potential lvalue context: */
o->op_private |= OPpENTERSUB_INARGS;
break;
}
while (kid->op_sibling)
kid = kid->op_sibling;
if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
- /* Indirect call */
- if (kid->op_type == OP_METHOD_NAMED
- || kid->op_type == OP_METHOD)
- {
- UNOP *newop;
-
- NewOp(1101, newop, 1, UNOP);
- newop->op_type = OP_RV2CV;
- newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
- newop->op_first = NULL;
- newop->op_next = (OP*)newop;
- kid->op_sibling = (OP*)newop;
- newop->op_private |= OPpLVAL_INTRO;
- newop->op_private &= ~1;
- break;
- }
-
- if (kid->op_type != OP_RV2CV)
- Perl_croak(aTHX_
- "panic: unexpected lvalue entersub "
- "entry via type/targ %ld:%"UVuf,
- (long)kid->op_type, (UV)kid->op_targ);
- kid->op_private |= OPpLVAL_INTRO;
break; /* Postpone until runtime */
}
"entry via type/targ %ld:%"UVuf,
(long)kid->op_type, (UV)kid->op_targ);
if (kid->op_type != OP_GV) {
- /* Restore RV2CV to check lvalueness */
- restore_2cv:
- if (kid->op_next && kid->op_next != kid) { /* Happens? */
- okid->op_next = kid->op_next;
- kid->op_next = okid;
- }
- else
- okid->op_next = NULL;
- okid->op_type = OP_RV2CV;
- okid->op_targ = 0;
- okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
- okid->op_private |= OPpLVAL_INTRO;
- okid->op_private &= ~1;
break;
}
cv = GvCV(kGVOP_gv);
if (!cv)
- goto restore_2cv;
+ break;
if (CvLVALUE(cv))
break;
}
&& (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) {
if (use_version) {
HV * const hinthv = GvHV(PL_hintgv);
const bool hhoff = !hinthv || !(PL_hints & HINT_LOCALIZE_HH);
- SV *importsv;
-
- /* Turn features off */
- ENTER_with_name("load_feature");
- Perl_load_module(aTHX_
- PERL_LOADMOD_DENY, newSVpvs("feature"), NULL, NULL
- );
- /* If we request a version >= 5.9.5, load feature.pm with the
+ /* Enable the
* feature bundle that corresponds to the required version. */
use_version = sv_2mortal(new_version(use_version));
+ S_enable_feature_bundle(aTHX_ use_version);
- if (vcmp(use_version,
- sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
- importsv = vnormal(use_version);
- *SvPVX_mutable(importsv) = ':';
- }
- else importsv = newSVpvs(":default");
- Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
- LEAVE_with_name("load_feature");
/* If a version >= 5.11.0 is requested, strictures are on by default! */
if (vcmp(use_version,
sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
ps = NULL;
if (name) {
- gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
+ gv = isGV(cSVOPo->op_sv)
+ ? (GV *)cSVOPo->op_sv
+ : 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();
} else if (*name == 'C') {
if (strEQ(name, "CHECK")) {
if (PL_main_start)
+ /* diag_listed_as: Too late to run %s block */
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 if (*name == 'I') {
if (strEQ(name, "INIT")) {
if (PL_main_start)
+ /* diag_listed_as: Too late to run %s block */
Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
"Too late to run INIT block");
Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
"Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
} else {
+ /* diag_listed_as: Format %s redefined */
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
"Format STDOUT redefined");
}
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));
o->op_private |= OPpEVAL_HAS_HH;
if (!(o->op_private & OPpEVAL_BYTES)
- && FEATURE_IS_ENABLED("unieval"))
+ && FEATURE_UNIEVAL_IS_ENABLED)
o->op_private |= OPpEVAL_UNICODE;
}
return o;
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),
{
PERL_ARGS_ASSERT_CK_READLINE;
- if (!(o->op_flags & OPf_KIDS)) {
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cLISTOPo->op_first;
+ if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
+ }
+ else {
OP * const newop
= newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
#ifdef PERL_MAD
if (!kid)
op_append_elem(o->op_type, o, newDEFSVOP());
+ if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
return listkids(o);
}
kid->op_next = k;
o->op_flags |= OPf_SPECIAL;
}
- else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
- op_null(firstkid);
firstkid = firstkid->op_sibling;
}
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);
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 */