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" */
|| 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(NULL, 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 &&
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
= (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 char * const name = o ? SvPV_const(cSVOPo->op_sv, namlen) : NULL;
bool has_name;
bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0;
&& 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
}
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
+ );
}
stash =
(CvGV(cv) && GvSTASH(CvGV(cv)))
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;
}
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);
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) */
- 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 ( redefined_name &&
- 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;
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 = 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)
{
}
}
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_IS_ENABLED("unieval"))
+ o->op_private |= OPpEVAL_UNICODE;
}
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);
#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 */
+#endif /* !PERL_EXTERNAL_GLOB */
- assert(!(o->op_flags & OPf_SPECIAL));
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
/* convert
* glob
o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
return o;
}
+ else o->op_flags &= ~OPf_SPECIAL;
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;
}
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
}
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
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(
+ NULL, 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 *
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)
)
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);
+}
+
#include "XSUB.h"
/* Efficient sub that returns a constant scalar value. */
https://perl5.git.perl.org / perl5.git / blobdiff