#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)
o->op_ppaddr = PL_ppaddr[type]; \
} STMT_END
-STATIC const char*
+STATIC SV*
S_gv_ename(pTHX_ GV *gv)
{
SV* const tmpsv = sv_newmortal();
PERL_ARGS_ASSERT_GV_ENAME;
gv_efullname3(tmpsv, gv, NULL);
- return SvPV_nolen_const(tmpsv);
+ return tmpsv;
}
STATIC OP *
}
STATIC OP *
-S_too_few_arguments(pTHX_ OP *o, const char *name)
+S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
{
- PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
+ PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
+ yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
+ SvUTF8(namesv) | flags);
+ return o;
+}
- yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
+STATIC OP *
+S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
+{
+ PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
+ yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
+ return o;
+}
+
+STATIC OP *
+S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
+{
+ PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
+
+ yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
return o;
}
STATIC OP *
-S_too_many_arguments(pTHX_ OP *o, const char *name)
+S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
{
- PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
+ PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
- yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
+ yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
+ SvUTF8(namesv) | flags);
return o;
}
STATIC void
-S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
+S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
{
- PERL_ARGS_ASSERT_BAD_TYPE;
+ PERL_ARGS_ASSERT_BAD_TYPE_PV;
- yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
- (int)n, name, t, OP_DESC(kid)));
+ yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
+ (int)n, name, t, OP_DESC(kid)), flags);
+}
+
+STATIC void
+S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
+{
+ PERL_ARGS_ASSERT_BAD_TYPE_SV;
+
+ yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
+ (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
}
STATIC void
if (len &&
!(is_our ||
isALPHA(name[1]) ||
- ((flags & SVf_UTF8) && UTF8_IS_START(name[1])) ||
+ ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
(name[1] == '_' && (*name == '$' || len > 2))))
{
/* name[2] is true if strlen(name) > 2 */
- if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
+ if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
+ && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
PL_parser->in_my == KEY_state ? "state" : "my"));
} else {
- yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
- PL_parser->in_my == KEY_state ? "state" : "my"));
+ yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
+ PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
}
}
PERL_ARGS_ASSERT_FORGET_PMOP;
- if (pmstash && !SvIS_FREED(pmstash)) {
+ if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
if (mg) {
PMOP **const array = (PMOP**) mg->mg_ptr;
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;
}
}
case OP_GGRGID:
case OP_GETLOGIN:
case OP_PROTOTYPE:
+ case OP_RUNCV:
func_ops:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
/* Otherwise it's "Useless use of grep iterator" */
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 */
LEAVE;
}
-void
+STATIC void
S_finalize_op(pTHX_ OP* o)
{
PERL_ARGS_ASSERT_FINALIZE_OP;
key = SvPV_const(*svp, keylen);
if (!hv_fetch(GvHV(*fields), key,
SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
- Perl_croak(aTHX_ "No such class field \"%s\" "
- "in variable %s of type %s",
- key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
+ Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
+ "in variable %"SVf" of type %"HEKf,
+ SVfARG(*svp), SVfARG(lexname),
+ HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
}
break;
}
key = SvPV_const(*svp, keylen);
if (!hv_fetch(GvHV(*fields), key,
SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
- Perl_croak(aTHX_ "No such class field \"%s\" "
- "in variable %s of type %s",
- key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
+ Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
+ "in variable %"SVf" of type %"HEKf,
+ SVfARG(*svp), SVfARG(lexname),
+ HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
}
}
break;
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;
PL_modcount++;
return o;
case OP_STUB:
|(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;
}
else { /* Compile-time error message: */
OP *kid = cUNOPo->op_first;
CV *cv;
- OP *okid;
if (kid->op_type != OP_PUSHMARK) {
if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
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 */
}
- okid = kid;
kid = kUNOP->op_first;
if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
kid = kUNOP->op_first;
"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;
}
STATIC bool
S_scalar_mod_type(const OP *o, I32 type)
{
- assert(o || type != OP_SASSIGN);
-
switch (type) {
+ case OP_POS:
case OP_SASSIGN:
+ assert(o);
if (o->op_type == OP_RV2GV)
return FALSE;
/* FALL THROUGH */
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
|| rtype == OP_TRANSR
)
? (int)rtype : OP_MATCH];
- const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
+ const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
+ GV *gv;
+ SV * const name =
+ (ltype == OP_RV2AV || ltype == OP_RV2HV)
+ ? cUNOPx(left)->op_first->op_type == OP_GV
+ && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
+ ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
+ : NULL
+ : 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")",
+ desc, name, name);
+ else {
+ const char * const sample = (isary
? "@array" : "%hash");
- Perl_warner(aTHX_ packWARN(WARN_MISC),
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %s will act on scalar(%s)",
desc, sample, sample);
+ }
}
if (rtype == OP_CONST &&
if (PL_in_eval) {
PERL_CONTEXT *cx;
+ I32 i;
if (PL_eval_root)
return;
PL_eval_root = newUNOP(OP_LEAVEEVAL,
PL_eval_root->op_private |= OPpREFCOUNTED;
OpREFCNT_set(PL_eval_root, 1);
PL_eval_root->op_next = 0;
+ i = PL_savestack_ix;
+ SAVEFREEOP(o);
+ ENTER;
CALL_PEEP(PL_eval_start);
finalize_optree(PL_eval_root);
-
+ LEAVE;
+ PL_savestack_ix = i;
}
else {
if (o->op_type == OP_STUB) {
case OP_SCMP:
case OP_SPRINTF:
/* XXX what about the numeric ops? */
- if (PL_hints & HINT_LOCALE)
+ if (IN_LOCALE_COMPILETIME)
goto nope;
break;
}
Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
{
dVAR;
+ if (type < 0) type = -type, flags |= OPf_SPECIAL;
if (!o || o->op_type != OP_LIST)
o = newLISTOP(OP_LIST, 0, o, NULL);
else
dVAR;
OP *o;
+ if (type == -OP_ENTEREVAL) {
+ type = OP_ENTEREVAL;
+ flags |= OPpEVAL_BYTES<<8;
+ }
+
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
dVAR;
UNOP *unop;
+ if (type == -OP_ENTEREVAL) {
+ type = OP_ENTEREVAL;
+ flags |= OPpEVAL_BYTES<<8;
+ }
+
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
else
bits = 8;
- PerlMemShared_free(cPVOPo->op_pv);
- cPVOPo->op_pv = NULL;
-
swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
#ifdef USE_ITHREADS
cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
return o;
}
- tbl = (short*)cPVOPo->op_pv;
+ tbl = (short*)PerlMemShared_calloc(
+ (o->op_private & OPpTRANS_COMPLEMENT) &&
+ !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
+ sizeof(short));
+ cPVOPo->op_pv = (char*)tbl;
if (complement) {
- Zero(tbl, 256, short);
for (i = 0; i < (I32)tlen; i++)
tbl[t[i]] = -1;
for (i = 0, j = 0; i < 256; i++) {
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) {
Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
{
dVAR;
+ const bool utf8 = cBOOL(flags & SVf_UTF8);
PVOP *pvop;
+ flags &= ~SVf_UTF8;
+
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
+ || type == OP_RUNCV
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, pvop, 1, PVOP);
pvop->op_pv = pv;
pvop->op_next = (OP*)pvop;
pvop->op_flags = (U8)flags;
+ pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
if (PL_opargs[type] & OA_RETSCALAR)
scalar((OP*)pvop);
if (PL_opargs[type] & OA_TARGET)
PERL_ARGS_ASSERT_PACKAGE;
- save_hptr(&PL_curstash);
+ SAVEGENERICSV(PL_curstash);
save_item(PL_curstname);
- PL_curstash = gv_stashsv(sv, GV_ADD);
+ PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
sv_setsv(PL_curstname, sv);
newSTATEOP(0, NULL, imop) ));
if (use_version) {
- /* 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) {
- SV *const importsv = vnormal(use_version);
- *SvPVX_mutable(importsv) = ':';
- ENTER_with_name("load_feature");
- 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) {
- PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
+ PL_hints |= HINT_STRICT_REFS;
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
+ PL_hints |= HINT_STRICT_SUBS;
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
+ PL_hints |= HINT_STRICT_VARS;
+ }
+ /* otherwise they are off */
+ else {
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
+ PL_hints &= ~HINT_STRICT_REFS;
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
+ PL_hints &= ~HINT_STRICT_SUBS;
+ if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
+ PL_hints &= ~HINT_STRICT_VARS;
}
}
Note that the actual module name, not its filename, should be given.
Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
-(or 0 for no flags). ver, if specified, provides version semantics
+(or 0 for no flags). ver, if specified and not NULL, provides version semantics
similar to C<use Foo::Bar VERSION>. The optional trailing SV*
arguments can be used to specify arguments to the module's import()
method, similar to C<use Foo::Bar VERSION LIST>. They must be
Otherwise at least a single NULL pointer to designate the default
import list is required.
+The reference count for each specified C<SV*> parameter is decremented.
+
=cut */
void
}
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
- doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
+ doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, term,
scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0, gv))))));
+ newGVOP(OP_GV, 0, gv)))));
}
else {
doop = newUNOP(OP_DOFILE, 0, scalar(term));
{
dVAR;
const U32 seq = intro_my();
+ const U32 utf8 = flags & SVf_UTF8;
register COP *cop;
+ flags &= ~SVf_UTF8;
+
NewOp(1101, cop, 1, COP);
if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
cop->op_type = OP_DBSTATE;
cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
if (label) {
- Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
-
+ Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
+
PL_hints |= HINT_BLOCK_SCOPE;
/* It seems that we need to defer freeing this pointer, as other parts
of the grammar end up wanting to copy it after this op has been
if (expr->op_type == OP_READLINE
|| expr->op_type == OP_READDIR
|| expr->op_type == OP_GLOB
+ || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
if (expr->op_type == OP_READLINE
|| expr->op_type == OP_READDIR
|| expr->op_type == OP_GLOB
+ || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
- if (type != OP_GOTO || label->op_type == OP_CONST) {
+ if (type != OP_GOTO) {
/* "last()" means "last" */
if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
o = newOP(type, OPf_SPECIAL);
else {
- o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
- ? SvPV_nolen_const(((SVOP*)label)->op_sv)
- : ""));
+ const_label:
+ o = newPVOP(type,
+ label->op_type == OP_CONST
+ ? SvUTF8(((SVOP*)label)->op_sv)
+ : 0,
+ savesharedpv(label->op_type == OP_CONST
+ ? SvPV_nolen_const(((SVOP*)label)->op_sv)
+ : ""));
}
#ifdef PERL_MAD
op_getmad(label,o,'L');
if (label->op_type == OP_ENTERSUB
&& !(label->op_flags & OPf_STACKED))
label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
+ else if (label->op_type == OP_CONST) {
+ SV * const sv = ((SVOP *)label)->op_sv;
+ STRLEN l;
+ const char *s = SvPV_const(sv,l);
+ if (l == strlen(s)) goto const_label;
+ }
o = newUNOP(type, OPf_STACKED, label);
}
PL_hints |= HINT_BLOCK_SCOPE;
/* This is a default {} block */
enterop->op_first = block;
enterop->op_flags |= OPf_SPECIAL;
+ o ->op_flags |= OPf_SPECIAL;
o->op_next = (OP *) enterop;
}
Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
const STRLEN len, const U32 flags)
{
+ const char * const cvp = CvPROTO(cv);
+ const STRLEN clen = CvPROTOLEN(cv);
+
PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
- if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
- || (p && !sv_eq((SV*)cv, newSVpvn_flags(p, len, flags | SVs_TEMP))))
+
+ if (((!p != !cvp) /* One has prototype, one has not. */
+ || (p && (
+ (flags & SVf_UTF8) == SvUTF8(cv)
+ ? len != clen || memNE(cvp, p, len)
+ : flags & SVf_UTF8
+ ? bytes_cmp_utf8((const U8 *)cvp, clen,
+ (const U8 *)p, len)
+ : bytes_cmp_utf8((const U8 *)p, len,
+ (const U8 *)cvp, clen)
+ )
+ )
+ )
&& ckWARN_d(WARN_PROTOTYPE)) {
SV* const msg = sv_newmortal();
SV* name = NULL;
if (name)
Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
if (SvPOK(cv))
- Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
+ Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
+ SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
+ );
else
sv_catpvs(msg, ": none");
sv_catpvs(msg, " vs ");
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;
= (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
|| PL_madskills)
? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
- const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
+ STRLEN namlen = 0;
+ 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)) {
&& block->op_type != OP_NULL
#endif
) {
- if (ckWARN(WARN_REDEFINE)
- || (CvCONST(cv)
- && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
- {
- const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE)
+ const line_t oldline = CopLINE(PL_curcop);
+ if (PL_parser && PL_parser->copline != NOLINE)
CopLINE_set(PL_curcop, PL_parser->copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv) ? "Constant subroutine %"SVf" redefined"
- : "Subroutine %"SVf" redefined",
- SVfARG(cSVOPo->op_sv));
- CopLINE_set(PL_curcop, oldline);
- }
+ report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
+ CopLINE_set(PL_curcop, oldline);
#ifdef PERL_MAD
if (!PL_minus_c) /* keep old one around for madskills */
#endif
}
}
if (const_sv) {
+ HV *stash;
SvREFCNT_inc_simple_void_NN(const_sv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
}
else {
GvCV_set(gv, NULL);
- cv = newCONSTSUB_flags(NULL, name, name_is_utf8 ? SVf_UTF8 : 0, const_sv);
+ cv = newCONSTSUB_flags(
+ NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
+ const_sv
+ );
}
- mro_method_changed_in( /* sub Foo::Bar () { 123 } */
+ stash =
(CvGV(cv) && GvSTASH(CvGV(cv)))
? GvSTASH(CvGV(cv))
: CvSTASH(cv)
? CvSTASH(cv)
- : PL_curstash
- );
+ : PL_curstash;
+ if (HvENAME_HEK(stash))
+ mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
if (PL_madskills)
goto install_block;
op_free(block);
}
}
GvCVGEN(gv) = 0;
- mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
+ if (HvENAME_HEK(GvSTASH(gv)))
+ /* sub Foo::bar { (shift)+1 } */
+ mro_method_changed_in(GvSTASH(gv));
}
}
if (!CvGV(cv)) {
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
}
- attrs:
- if (attrs) {
- /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
- HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
- apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
- }
if (ps) {
sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
}
install_block:
if (!block)
- goto done;
+ goto attrs;
/* If we assign an optree to a PVCV, then we've defined a subroutine that
the debugger could be able to set a breakpoint in, so signal to
CvCONST_on(cv);
}
- if (has_name) {
+ attrs:
+ if (attrs) {
+ /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
+ HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+ apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
+ }
+
+ if (block && has_name) {
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV * const tmpstr = sv_newmortal();
GV * const db_postponed = gv_fetchpvs("DB::postponed",
(long)CopLINE(PL_curcop));
gv_efullname3(tmpstr, gv, NULL);
(void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
- SvUTF8(tmpstr) ? -SvCUR(tmpstr) : SvCUR(tmpstr), sv, 0);
+ SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
- if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -SvCUR(tmpstr) : SvCUR(tmpstr))) {
+ if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
CV * const pcv = GvCV(db_postponed);
if (pcv) {
dSP;
ENTER;
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
+ SAVEVPTR(PL_curcop);
DEBUG_x( dump_sub(gv) );
Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
GvCV_set(gv,0); /* cv has been hijacked */
call_list(oldscope, PL_beginav);
- PL_curcop = &PL_compiling;
CopHINTS_set(&PL_compiling, PL_hints);
LEAVE;
}
} 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));
CV *
Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
{
- return newCONSTSUB_flags(stash, name, 0, sv);
+ return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
}
/*
*/
CV *
-Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, U32 flags, SV *sv)
+Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
+ U32 flags, SV *sv)
{
dVAR;
CV* cv;
* an op shared between threads. Use a non-shared COP for our
* dirty work */
SAVEVPTR(PL_curcop);
+ SAVECOMPILEWARNINGS();
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
PL_curcop = &PL_compiling;
}
SAVECOPLINE(PL_curcop);
PL_hints &= ~HINT_BLOCK_SCOPE;
if (stash) {
- SAVESPTR(PL_curstash);
+ SAVEGENERICSV(PL_curstash);
SAVECOPSTASH(PL_curcop);
- PL_curstash = stash;
+ PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
CopSTASH_set(PL_curcop,stash);
}
and so doesn't get free()d. (It's expected to be from the C pre-
processor __FILE__ directive). But we need a dynamically allocated one,
and we need it to get freed. */
- cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
- XS_DYNAMIC_FILENAME | flags);
+ cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
+ &sv, XS_DYNAMIC_FILENAME | flags);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
const char *const filename, const char *const proto,
U32 flags)
{
+ PERL_ARGS_ASSERT_NEWXS_FLAGS;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
+ );
+}
+
+CV *
+Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
+ XSUBADDR_t subaddr, const char *const filename,
+ const char *const proto, SV **const_svp,
+ U32 flags)
+{
CV *cv;
- PERL_ARGS_ASSERT_NEWXS_FLAGS;
+ PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
{
- GV * const gv = gv_fetchpv(name ? name :
+ GV * const gv = name
+ ? gv_fetchpvn(
+ name,len,GV_ADDMULTI|flags,SVt_PVCV
+ )
+ : gv_fetchpv(
(PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
GV_ADDMULTI | flags, SVt_PVCV);
}
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
- /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
- if (ckWARN(WARN_REDEFINE)) {
- GV * const gvcv = CvGV(cv);
- if (gvcv) {
- HV * const stash = GvSTASH(gvcv);
- if (stash) {
- const char *redefined_name = HvNAME_get(stash);
- if ( strEQ(redefined_name,"autouse") ) {
- const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE)
- CopLINE_set(PL_curcop, PL_parser->copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv) ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined"
- ,name);
- CopLINE_set(PL_curcop, oldline);
- }
- }
- }
+ /* Redundant check that allows us to avoid creating an SV
+ most of the time: */
+ if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
+ const line_t oldline = CopLINE(PL_curcop);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_parser->copline);
+ report_redefined_cv(newSVpvn_flags(
+ name,len,(flags&SVf_UTF8)|SVs_TEMP
+ ),
+ cv, const_svp);
+ CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
cv = NULL;
if (name) {
GvCV_set(gv,cv);
GvCVGEN(gv) = 0;
- mro_method_changed_in(GvSTASH(gv)); /* newXS */
+ if (HvENAME_HEK(GvSTASH(gv)))
+ mro_method_changed_in(GvSTASH(gv)); /* newXS */
}
}
if (!name)
Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
{
PERL_ARGS_ASSERT_NEWXS;
- return newXS_flags(name, subaddr, filename, NULL, 0);
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
+ );
}
#ifdef PERL_MAD
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");
}
return o;
}
+PERL_STATIC_INLINE bool
+is_dollar_bracket(pTHX_ const OP * const o)
+{
+ const OP *kid;
+ return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
+ && (kid = cUNOPx(o)->op_first)
+ && kid->op_type == OP_GV
+ && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
+}
+
+OP *
+Perl_ck_cmp(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_CK_CMP;
+ if (ckWARN(WARN_SYNTAX)) {
+ const OP *kid = cUNOPo->op_first;
+ if (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));
+ }
+ return o;
+}
+
OP *
Perl_ck_concat(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_EOF;
if (o->op_flags & OPf_KIDS) {
+ OP *kid;
if (cLISTOPo->op_first->op_type == OP_STUB) {
OP * const newop
= newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
#endif
o = newop;
}
- return ck_fun(o);
+ o = ck_fun(o);
+ kid = cLISTOPo->op_first;
+ if (kid->op_type == OP_RV2GV)
+ kid->op_private |= OPpALLOW_FAKE;
}
return o;
}
}
}
else {
+ const U8 priv = o->op_private;
#ifdef PERL_MAD
OP* const oldo = o;
#else
op_free(o);
#endif
- o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
+ o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
op_getmad(oldo,o,'O');
}
o->op_targ = (PADOFFSET)PL_hints;
- if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
+ if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
+ if ((PL_hints & HINT_LOCALIZE_HH) != 0
+ && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
/* Store a copy of %^H that pp_entereval can pick up. */
OP *hhop = newSVOP(OP_HINTSEVAL, 0,
MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
cUNOPo->op_first->op_sibling = hhop;
o->op_private |= OPpEVAL_HAS_HH;
}
+ if (!(o->op_private & OPpEVAL_BYTES)
+ && FEATURE_UNIEVAL_IS_ENABLED)
+ o->op_private |= OPpEVAL_UNICODE;
return 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 {
if (numargs == 1 && !(oa >> 4)
&& kid->op_type == OP_LIST && type != OP_SCALAR)
{
- return too_many_arguments(o,PL_op_desc[type]);
+ return too_many_arguments_pv(o,PL_op_desc[type], 0);
}
scalar(kid);
break;
&& ( !SvROK(cSVOPx_sv(kid))
|| SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
)
- bad_type(numargs, "array", PL_op_desc[type], kid);
+ bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
/* Defer checks to run-time if we have a scalar arg */
if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
op_lvalue(kid, type);
*tokid = kid;
}
else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
- bad_type(numargs, "hash", PL_op_desc[type], kid);
+ bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
op_lvalue(kid, type);
break;
case OA_CVREF:
}
else if (kid->op_type == OP_READLINE) {
/* neophyte patrol: open(<FH>), close(<FH>) etc. */
- bad_type(numargs, "HANDLE", OP_DESC(o), kid);
+ bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
}
else {
I32 flags = OPf_SPECIAL;
if (is_handle_constructor(o,numargs)) {
const char *name = NULL;
STRLEN len = 0;
+ U32 name_utf8 = 0;
+ bool want_dollar = TRUE;
flags = 0;
/* Set a flag to tell rv2gv to vivify
SV *const namesv
= PAD_COMPNAME_SV(kid->op_targ);
name = SvPV_const(namesv, len);
+ name_utf8 = SvUTF8(namesv);
}
else if (kid->op_type == OP_RV2SV
&& kUNOP->op_first->op_type == OP_GV)
GV * const gv = cGVOPx_gv(kUNOP->op_first);
name = GvNAME(gv);
len = GvNAMELEN(gv);
+ name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
}
else if (kid->op_type == OP_AELEM
|| kid->op_type == OP_HELEM)
}
if (tmpstr) {
name = SvPV_const(tmpstr, len);
+ name_utf8 = SvUTF8(tmpstr);
sv_2mortal(tmpstr);
}
}
if (!name) {
name = "__ANONIO__";
len = 10;
+ want_dollar = FALSE;
}
op_lvalue(kid, type);
}
targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
namesv = PAD_SVl(targ);
SvUPGRADE(namesv, SVt_PV);
- if (*name != '$')
+ if (want_dollar && *name != '$')
sv_setpvs(namesv, "$");
sv_catpvn(namesv, name, len);
+ if ( name_utf8 ) SvUTF8_on(namesv);
}
}
kid->op_sibling = 0;
}
#ifdef PERL_MAD
if (kid && kid->op_type != OP_STUB)
- return too_many_arguments(o,OP_DESC(o));
+ return too_many_arguments_pv(o,OP_DESC(o), 0);
o->op_private |= numargs;
#else
/* FIXME - should the numargs move as for the PERL_MAD case? */
o->op_private |= numargs;
if (kid)
- return too_many_arguments(o,OP_DESC(o));
+ return too_many_arguments_pv(o,OP_DESC(o), 0);
#endif
listkids(o);
}
while (oa & OA_OPTIONAL)
oa >>= 4;
if (oa && oa != OA_LIST)
- return too_few_arguments(o,OP_DESC(o));
+ return too_few_arguments_pv(o,OP_DESC(o), 0);
}
return o;
}
{
dVAR;
GV *gv;
+ const bool core = o->op_flags & OPf_SPECIAL;
PERL_ARGS_ASSERT_CK_GLOB;
if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
- if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
+ if (core) gv = NULL;
+ else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
&& GvCVu(gv) && GvIMPORTED_CV(gv)))
{
- gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
+ GV * const * const gvp =
+ (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
+ gv = gvp ? *gvp : NULL;
}
-#if !defined(PERL_EXTERNAL_GLOB)
- if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
- GV *glob_gv;
- ENTER;
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvs("File::Glob"), NULL, NULL, NULL);
- if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
- gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
- GvCV_set(gv, GvCV(glob_gv));
- SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
- GvIMPORTED_CV_on(gv);
- }
- LEAVE;
- }
-#endif /* PERL_EXTERNAL_GLOB */
-
- assert(!(o->op_flags & OPf_SPECIAL));
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
/* convert
* glob
op_append_elem(OP_LIST, o,
scalar(newUNOP(OP_RV2CV, 0,
newGVOP(OP_GV, 0, gv)))));
- o = newUNOP(OP_NULL, 0, ck_subr(o));
+ o = newUNOP(OP_NULL, 0, o);
o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
return o;
}
+ else o->op_flags &= ~OPf_SPECIAL;
+#if !defined(PERL_EXTERNAL_GLOB)
+ if (!PL_globhook) {
+ ENTER;
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ newSVpvs("File::Glob"), NULL, NULL, NULL);
+ LEAVE;
+ }
+#endif /* !PERL_EXTERNAL_GLOB */
gv = newGVgen("main");
gv_IOadd(gv);
+#ifndef PERL_EXTERNAL_GLOB
+ sv_setiv(GvSVn(gv),PL_glob_index++);
+#endif
op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
scalarkids(o);
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)
kid = cLISTOPo->op_first->op_sibling;
if (!kid || !kid->op_sibling)
- return too_few_arguments(o,OP_DESC(o));
+ return too_few_arguments_pv(o,OP_DESC(o), 0);
for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
op_lvalue(kid, OP_GREPSTART);
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);
}
if (!(strchr(method, ':') || strchr(method, '\''))) {
OP *cmop;
if (!SvREADONLY(sv) || !SvFAKE(sv)) {
- sv = newSVpvn_share(method, SvUTF8(sv) ? -SvCUR(sv) : SvCUR(sv), 0);
+ sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
}
else {
kSVOP->op_sv = NULL;
}
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
- OP * const kid = cUNOPo->op_first;
- OP * newop;
-
- cUNOPo->op_first = 0;
+ OP *kid, *newop;
+ if (o->op_flags & OPf_KIDS) {
+ kid = cUNOPo->op_first;
+ cUNOPo->op_first = NULL;
+ }
+ else {
+ kid = newDEFSVOP();
+ }
#ifndef PERL_MAD
op_free(o);
#endif
- newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
+ newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, kid,
scalar(newUNOP(OP_RV2CV, 0,
newGVOP(OP_GV, 0,
- gv))))));
+ gv)))));
op_getmad(o,newop,'O');
return newop;
}
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)
scalar(kid);
if (kid->op_sibling)
- return too_many_arguments(o,OP_DESC(o));
+ return too_many_arguments_pv(o,OP_DESC(o), 0);
return o;
}
if (kid && kid->op_type == OP_MATCH) {
if (ckWARN(WARN_SYNTAX)) {
const REGEXP *re = PM_GETRE(kPMOP);
- const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
- const STRLEN len = re ? RX_PRELEN(re) : 6;
+ const SV *msg = re
+ ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
+ SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
+ : newSVpvs_flags( "STRING", SVs_TEMP );
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "/%.*s/ should probably be written as \"%.*s\"",
- (int)len, pmstr, (int)len, pmstr);
+ "/%"SVf"/ should probably be written as \"%"SVf"\"",
+ SVfARG(msg), SVfARG(msg));
}
}
return ck_fun(o);
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");
- proto = SvPV(protosv, proto_len);
+ 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);
proto_end = proto + proto_len;
aop = cUNOPx(entersubop)->op_first;
if (!aop->op_sibling)
o3 = aop;
if (proto >= proto_end)
- return too_many_arguments(entersubop, gv_ename(namegv));
+ return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
switch (*proto) {
case ';':
continue;
case '_':
/* _ must be at the end */
- if (proto[1] && proto[1] != ';')
+ if (proto[1] && !strchr(";@%", proto[1]))
goto oops;
case '$':
proto++;
proto++;
arg++;
if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
- bad_type(arg,
+ bad_type_sv(arg,
arg == 1 ? "block or sub {}" : "sub {}",
- gv_ename(namegv), o3);
+ gv_ename(namegv), 0, o3);
break;
case '*':
/* '*' allows any scalar type, including bareword */
OP_READ, /* not entersub */
OP_LVALUE_NO_CROAK
)) goto wrapref;
- bad_type(arg, Perl_form(aTHX_ "one of %.*s",
+ bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
(int)(end - p), p),
- gv_ename(namegv), o3);
+ gv_ename(namegv), 0, o3);
} else
goto oops;
break;
if (o3->op_type == OP_RV2GV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "symbol", gv_ename(namegv), o3);
+ bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
break;
case '&':
if (o3->op_type == OP_ENTERSUB)
goto wrapref;
if (!contextclass)
- bad_type(arg, "subroutine entry", gv_ename(namegv),
+ bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
o3);
break;
case '$':
OP_READ, /* not entersub */
OP_LVALUE_NO_CROAK
)) goto wrapref;
- bad_type(arg, "scalar", gv_ename(namegv), o3);
+ bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
}
break;
case '@':
o3->op_type == OP_PADAV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "array", gv_ename(namegv), o3);
+ bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
break;
case '%':
if (o3->op_type == OP_RV2HV ||
o3->op_type == OP_PADHV)
goto wrapref;
if (!contextclass)
- bad_type(arg, "hash", gv_ename(namegv), o3);
+ bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
break;
wrapref:
{
}
if (!optional && proto_end > proto &&
(*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
- return too_few_arguments(entersubop, gv_ename(namegv));
+ return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
return entersubop;
}
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));
+ (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
op_free(entersubop);
switch(GvNAME(namegv)[2]) {
}
else {
OP *prev, *cvop;
- U32 paren;
+ U32 flags;
#ifdef PERL_MAD
bool seenarg = FALSE;
#endif
#endif
;
prev->op_sibling = NULL;
- paren = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
+ flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
op_free(cvop);
if (aop == cvop) aop = NULL;
op_free(entersubop);
+ if (opnum == OP_ENTEREVAL
+ && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
+ flags |= OPpEVAL_BYTES <<8;
+
switch (PL_opargs[opnum] & OA_CLASS_MASK) {
case OA_UNOP:
case OA_BASEOP_OR_UNOP:
case OA_FILESTATOP:
- return aop ? newUNOP(opnum,paren,aop) : newOP(opnum,paren);
+ return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
case OA_BASEOP:
if (aop) {
#ifdef PERL_MAD
if (!PL_madskills || seenarg)
#endif
- (void)too_many_arguments(aop, GvNAME(namegv));
+ (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
op_free(aop);
}
- return newOP(opnum,0);
+ return opnum == OP_RUNCV
+ ? newPVOP(OP_RUNCV,0,NULL)
+ : newOP(opnum,0);
default:
return convert(opnum,0,aop);
}
SvREFCNT_inc_simple_void_NN(ckobj);
callmg->mg_flags |= MGf_REFCOUNTED;
}
+ callmg->mg_flags |= MGf_COPY;
}
}
}
OP *
+Perl_ck_tell(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_CK_TELL;
+ o = ck_fun(o);
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cLISTOPo->op_first;
+ if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
+ if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
+ }
+ return o;
+}
+
+OP *
Perl_ck_each(pTHX_ OP *o)
{
dVAR;
return o->op_type == ref_type ? o : ck_fun(o);
}
+OP *
+Perl_ck_length(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_CK_LENGTH;
+
+ o = ck_fun(o);
+
+ if (ckWARN(WARN_SYNTAX)) {
+ const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
+
+ if (kid) {
+ SV *name = NULL;
+ const bool hash = kid->op_type == OP_PADHV
+ || kid->op_type == OP_RV2HV;
+ switch (kid->op_type) {
+ case OP_PADHV:
+ case OP_PADAV:
+ name = varname(
+ (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
+ NULL, 0, 1
+ );
+ break;
+ case OP_RV2HV:
+ case OP_RV2AV:
+ if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
+ {
+ GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
+ if (!gv) break;
+ name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
+ }
+ break;
+ default:
+ return o;
+ }
+ if (name)
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
+ ")\"?)",
+ name, hash ? "keys " : "", name
+ );
+ else if (hash)
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
+ else
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "length() used on @array (did you mean \"scalar(@array)\"?)");
+ }
+ }
+
+ return o;
+}
+
/* caller is supposed to assign the return to the
container of the rep_op var */
STATIC OP *
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 */
if (oright->op_type != OP_RV2AV
|| !cUNOPx(oright)->op_first
|| cUNOPx(oright)->op_first->op_type != OP_GV
+ || cUNOPx(oleft )->op_first->op_type != OP_GV
|| cGVOPx_gv(cUNOPx(oleft)->op_first) !=
cGVOPx_gv(cUNOPx(oright)->op_first)
)
firstcop->cop_line = secondcop->cop_line;
#ifdef USE_ITHREADS
firstcop->cop_stashpv = secondcop->cop_stashpv;
+ firstcop->cop_stashlen = secondcop->cop_stashlen;
firstcop->cop_file = secondcop->cop_file;
#else
firstcop->cop_stash = secondcop->cop_stash;
}
break;
+ case OP_RUNCV:
+ if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
+ SV *sv;
+ if (CvUNIQUE(PL_compcv)) sv = &PL_sv_undef;
+ else {
+ sv = newRV((SV *)PL_compcv);
+ sv_rvweaken(sv);
+ SvREADONLY_on(sv);
+ }
+ o->op_type = OP_CONST;
+ o->op_ppaddr = PL_ppaddr[OP_CONST];
+ o->op_flags |= OPf_SPECIAL;
+ cSVOPo->op_sv = sv;
+ }
+ break;
+
+ case OP_SASSIGN:
+ if (OP_GIMME(o,0) == G_VOID) {
+ OP *right = cBINOP->op_first;
+ if (right) {
+ OP *left = right->op_sibling;
+ if (left->op_type == OP_SUBSTR
+ && (left->op_private & 7) < 4) {
+ op_null(o);
+ cBINOP->op_first = left;
+ right->op_sibling =
+ cBINOPx(left)->op_first->op_sibling;
+ cBINOPx(left)->op_first->op_sibling = right;
+ left->op_private |= OPpSUBSTR_REPL_FIRST;
+ left->op_flags =
+ (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+ }
+ }
+ }
+ break;
+
case OP_CUSTOM: {
Perl_cpeep_t cpeep =
XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
retsetpvs("+;$$@", OP_SPLICE);
case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
retsetpvs("", 0);
+ case KEY_evalbytes:
+ name = "entereval"; break;
case KEY_readpipe:
name = "backtick";
}
return op_append_elem(
OP_LINESEQ, argop,
newOP(opnum,
- opnum == OP_WANTARRAY ? OPpOFFBYONE << 8 : 0)
+ opnum == OP_WANTARRAY || opnum == OP_RUNCV
+ ? OPpOFFBYONE << 8 : 0)
);
case OA_BASEOP_OR_UNOP:
- o = newUNOP(opnum,0,argop);
+ if (opnum == OP_ENTEREVAL) {
+ o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
+ if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
+ }
+ else o = newUNOP(opnum,0,argop);
if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
else {
onearg:
}
}
+void
+Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
+ SV * const *new_const_svp)
+{
+ const char *hvname;
+ bool is_const = !!CvCONST(old_cv);
+ SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
+
+ PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
+
+ if (is_const && new_const_svp && old_const_sv == *new_const_svp)
+ return;
+ /* They are 2 constant subroutines generated from
+ the same constant. This probably means that
+ they are really the "same" proxy subroutine
+ instantiated in 2 places. Most likely this is
+ when a constant is exported twice. Don't warn.
+ */
+ if (
+ (ckWARN(WARN_REDEFINE)
+ && !(
+ CvGV(old_cv) && GvSTASH(CvGV(old_cv))
+ && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
+ && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
+ strEQ(hvname, "autouse"))
+ )
+ )
+ || (is_const
+ && ckWARN_d(WARN_REDEFINE)
+ && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
+ )
+ )
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ is_const
+ ? "Constant subroutine %"SVf" redefined"
+ : "Subroutine %"SVf" redefined",
+ name);
+}
+
+/*
+=head1 Hook manipulation
+
+These functions provide convenient and thread-safe means of manipulating
+hook variables.
+
+=cut
+*/
+
+/*
+=for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
+
+Puts a C function into the chain of check functions for a specified op
+type. This is the preferred way to manipulate the L</PL_check> array.
+I<opcode> specifies which type of op is to be affected. I<new_checker>
+is a pointer to the C function that is to be added to that opcode's
+check chain, and I<old_checker_p> points to the storage location where a
+pointer to the next function in the chain will be stored. The value of
+I<new_pointer> is written into the L</PL_check> array, while the value
+previously stored there is written to I<*old_checker_p>.
+
+L</PL_check> is global to an entire process, and a module wishing to
+hook op checking may find itself invoked more than once per process,
+typically in different threads. To handle that situation, this function
+is idempotent. The location I<*old_checker_p> must initially (once
+per process) contain a null pointer. A C variable of static duration
+(declared at file scope, typically also marked C<static> to give
+it internal linkage) will be implicitly initialised appropriately,
+if it does not have an explicit initialiser. This function will only
+actually modify the check chain if it finds I<*old_checker_p> to be null.
+This function is also thread safe on the small scale. It uses appropriate
+locking to avoid race conditions in accessing L</PL_check>.
+
+When this function is called, the function referenced by I<new_checker>
+must be ready to be called, except for I<*old_checker_p> being unfilled.
+In a threading situation, I<new_checker> may be called immediately,
+even before this function has returned. I<*old_checker_p> will always
+be appropriately set before I<new_checker> is called. If I<new_checker>
+decides not to do anything special with an op that it is given (which
+is the usual case for most uses of op check hooking), it must chain the
+check function referenced by I<*old_checker_p>.
+
+If you want to influence compilation of calls to a specific subroutine,
+then use L</cv_set_call_checker> rather than hooking checking of all
+C<entersub> ops.
+
+=cut
+*/
+
+void
+Perl_wrap_op_checker(pTHX_ Optype opcode,
+ Perl_check_t new_checker, Perl_check_t *old_checker_p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
+ if (*old_checker_p) return;
+ OP_CHECK_MUTEX_LOCK;
+ if (!*old_checker_p) {
+ *old_checker_p = PL_check[opcode];
+ PL_check[opcode] = new_checker;
+ }
+ OP_CHECK_MUTEX_UNLOCK;
+}
+
#include "XSUB.h"
/* Efficient sub that returns a constant scalar value. */
https://perl5.git.perl.org / perl5.git / blobdiff