#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)
dVAR;
OP *kid;
const char* useless = NULL;
+ U32 useless_is_utf8 = 0;
SV* sv;
U8 want;
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" */
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)";
- if (o->op_private & OPpCONST_ARYBASE)
- useless = NULL;
/* don't warn on optimised away booleans, eg
* use constant Foo, 5; Foo || print; */
if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
break;
}
+ case OP_AASSIGN: {
+ inplace_aassign(o);
+ break;
+ }
+
case OP_OR:
case OP_AND:
kid = cLOGOPo->op_first;
return scalar(o);
}
if (useless)
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
+ newSVpvn_flags(useless, strlen(useless),
+ SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
return o;
}
LEAVE;
}
-void
+STATIC void
S_finalize_op(pTHX_ OP* o)
{
PERL_ARGS_ASSERT_FINALIZE_OP;
localize = 0;
PL_modcount++;
return o;
- case OP_CONST:
- if (!(o->op_private & OPpCONST_ARYBASE))
- goto nomod;
- localize = 0;
- if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
- CopARYBASE_set(&PL_compiling,
- (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
- PL_eval_start = 0;
- }
- else if (!type) {
- SAVECOPARYBASE(&PL_compiling);
- CopARYBASE_set(&PL_compiling, 0);
- }
- else if (type == OP_REFGEN)
- goto nomod;
- else
- Perl_croak(aTHX_ "That use of $[ is unsupported");
- break;
case OP_STUB:
if ((o->op_flags & OPf_PARENS) || PL_madskills)
break;
o->op_private &= ~1;
}
else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
- o->op_private |= OPpENTERSUB_DEREF;
+ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+ : type == OP_RV2HV ? OPpDEREF_HV
+ : OPpDEREF_SV);
o->op_flags |= OPf_MOD;
}
|| 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 &&
return o;
}
+PERL_STATIC_INLINE OP *
+S_op_std_init(pTHX_ OP *o)
+{
+ I32 type = o->op_type;
+
+ PERL_ARGS_ASSERT_OP_STD_INIT;
+
+ if (PL_opargs[type] & OA_RETSCALAR)
+ scalar(o);
+ if (PL_opargs[type] & OA_TARGET && !o->op_targ)
+ o->op_targ = pad_alloc(type, SVs_PADTMP);
+
+ return o;
+}
+
+PERL_STATIC_INLINE OP *
+S_op_integerize(pTHX_ OP *o)
+{
+ I32 type = o->op_type;
+
+ PERL_ARGS_ASSERT_OP_INTEGERIZE;
+
+ /* integerize op, unless it happens to be C<-foo>.
+ * XXX should pp_i_negate() do magic string negation instead? */
+ if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
+ && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
+ && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
+ {
+ dVAR;
+ o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
+ }
+
+ if (type == OP_NEGATE)
+ /* XXX might want a ck_negate() for this */
+ cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
+
+ return o;
+}
+
static OP *
S_fold_constants(pTHX_ register OP *o)
{
PERL_ARGS_ASSERT_FOLD_CONSTANTS;
- if (PL_opargs[type] & OA_RETSCALAR)
- scalar(o);
- if (PL_opargs[type] & OA_TARGET && !o->op_targ)
- o->op_targ = pad_alloc(type, SVs_PADTMP);
-
- /* integerize op, unless it happens to be C<-foo>.
- * XXX should pp_i_negate() do magic string negation instead? */
- if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
- && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
- && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
- {
- o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
- }
-
if (!(PL_opargs[type] & OA_FOLDCONST))
goto nope;
switch (type) {
- case OP_NEGATE:
- /* XXX might want a ck_negate() for this */
- cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
- break;
case OP_UCFIRST:
case OP_LCFIRST:
case OP_UC:
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
if (!(PL_opargs[type] & OA_MARK))
op_null(cLISTOPo->op_first);
+ else {
+ OP * const kid2 = cLISTOPo->op_first->op_sibling;
+ if (kid2 && kid2->op_type == OP_COREARGS) {
+ op_null(cLISTOPo->op_first);
+ kid2->op_private |= OPpCOREARGS_PUSHMARK;
+ }
+ }
o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
if (o->op_type != (unsigned)type)
return o;
- return fold_constants(o);
+ return fold_constants(op_integerize(op_std_init(o)));
}
/*
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
if (unop->op_next)
return (OP*)unop;
- return fold_constants((OP *) unop);
+ return fold_constants(op_integerize(op_std_init((OP *) unop)));
}
/*
binop->op_last = binop->op_first->op_sibling;
- return fold_constants((OP *)binop);
+ return fold_constants(op_integerize(op_std_init((OP *)binop)));
}
static int uvcompare(const void *a, const void *b)
PVOP *pvop;
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);
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
+ HV * const hinthv = GvHV(PL_hintgv);
+ const bool hhoff = !hinthv || !(PL_hints & HINT_LOCALIZE_HH);
+
+ /* 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 (hhoff || !hv_exists(hinthv, "strict/refs", 11))
+ PL_hints |= HINT_STRICT_REFS;
+ if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
+ PL_hints |= HINT_STRICT_SUBS;
+ if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
+ PL_hints |= HINT_STRICT_VARS;
+ }
+ /* otherwise they are off */
+ else {
+ if (hhoff || !hv_exists(hinthv, "strict/refs", 11))
+ PL_hints &= ~HINT_STRICT_REFS;
+ if (hhoff || !hv_exists(hinthv, "strict/subs", 11))
+ PL_hints &= ~HINT_STRICT_SUBS;
+ if (hhoff || !hv_exists(hinthv, "strict/vars", 11))
+ 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
bool maybe_common_vars = TRUE;
PL_modcount = 0;
- /* Grandfathering $[ assignment here. Bletch.*/
- /* Only simple assignments like C<< ($[) = 1 >> are allowed */
- PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
left = op_lvalue(left, OP_AASSIGN);
- if (PL_eval_start)
- PL_eval_start = 0;
- else if (left->op_type == OP_CONST) {
- deprecate("assignment to $[");
- /* FIXME for MAD */
- /* Result of assignment is always 1 (or we'd be dead already) */
- return newSVOP(OP_CONST, 0, newSViv(1));
- }
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
scalar(right));
}
else {
- PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
o = newBINOP(OP_SASSIGN, flags,
scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
- if (PL_eval_start)
- PL_eval_start = 0;
- else {
- if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
- deprecate("assignment to $[");
- op_free(o);
- o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
- o->op_private |= OPpCONST_ARYBASE;
- }
- }
}
return o;
}
cop->op_next = (OP*)cop;
cop->cop_seq = seq;
- /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
- CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
- */
cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
if (label) {
/* This is a default {} block */
enterop->op_first = block;
enterop->op_flags |= OPf_SPECIAL;
+ o ->op_flags |= OPf_SPECIAL;
o->op_next = (OP *) enterop;
}
}
void
-Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
- const STRLEN len)
-{
- PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
-
- /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
- relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
- if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
- || (p && (len != SvCUR(cv) /* Not the same length. */
- || memNE(p, SvPVX_const(cv), len))))
+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 != !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 ");
if (p)
- Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
+ Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
else
sv_catpvs(msg, "none");
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
GV *gv;
const char *ps;
STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
+ U32 ps_utf8 = 0;
register CV *cv = NULL;
SV *const_sv;
/* If the subroutine has no body, no attributes, and no builtin attributes
= (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;
if (proto) {
assert(proto->op_type == OP_CONST);
ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
+ ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
}
else
ps = NULL;
{
Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
}
- cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
+ cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
}
- if (ps)
+ if (ps) {
sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
+ if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
+ }
else
sv_setiv(MUTABLE_SV(gv), -1);
* skipping the prototype check
*/
if (exists || SvPOK(cv))
- cv_ckproto_len(cv, gv, ps, ps_len);
+ cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
if ((!block
&& 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 %s redefined"
- : "Subroutine %s redefined", name);
- 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(NULL, name, 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);
CvOUTSIDE(PL_compcv) = temp_cv;
CvPADLIST(PL_compcv) = temp_av;
-#ifdef USE_ITHREADS
- if (CvFILE(cv) && !CvISXSUB(cv)) {
- /* for XSUBs CvFILE point directly to static memory; __FILE__ */
+ if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
}
-#endif
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
}
}
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)
+ if (ps) {
sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
+ if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
+ }
if (PL_parser && PL_parser->error_count) {
op_free(block);
}
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),
- 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), 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;
}
/*
=for apidoc newCONSTSUB
+See L</newCONSTSUB_flags>.
+
+=cut
+*/
+
+CV *
+Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
+{
+ return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
+}
+
+/*
+=for apidoc newCONSTSUB_flags
+
Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
eligible for inlining at compile-time.
+Currently, the only useful value for C<flags> is SVf_UTF8.
+
Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
which won't be called if used as a destructor, but will suppress the overhead
of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
*/
CV *
-Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, 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);
}
- /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
+ /* file becomes the CvFILE. For an XS, it's usually static storage,
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);
+ 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)
{
- CV *cv = newXS(name, subaddr, filename);
-
PERL_ARGS_ASSERT_NEWXS_FLAGS;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
+ );
+}
- if (flags & XS_DYNAMIC_FILENAME) {
- /* We need to "make arrangements" (ie cheat) to ensure that the
- filename lasts as long as the PVCV we just created, but also doesn't
- leak */
- STRLEN filename_len = strlen(filename);
- STRLEN proto_and_file_len = filename_len;
- char *proto_and_file;
- STRLEN proto_len;
-
- if (proto) {
- proto_len = strlen(proto);
- proto_and_file_len += proto_len;
-
- Newx(proto_and_file, proto_and_file_len + 1, char);
- Copy(proto, proto_and_file, proto_len, char);
- Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
- } else {
- proto_len = 0;
- proto_and_file = savepvn(filename, filename_len);
- }
+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;
- /* This gets free()d. :-) */
- sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
- SV_HAS_TRAILING_NUL);
- if (proto) {
- /* This gives us the correct prototype, rather than one with the
- file name appended. */
- SvCUR_set(cv, proto_len);
- } else {
- SvPOK_off(cv);
- }
- CvFILE(cv) = proto_and_file + proto_len;
- } else {
- sv_setpv(MUTABLE_SV(cv), proto);
+ PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
+
+ {
+ 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);
+
+ if (!subaddr)
+ Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
+
+ if ((cv = (name ? GvCV(gv) : NULL))) {
+ if (GvCVGEN(gv)) {
+ /* just a cached method */
+ SvREFCNT_dec(cv);
+ cv = NULL;
+ }
+ else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
+ /* already defined (or promised) */
+ /* 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 (cv) /* must reuse cv if autoloaded */
+ cv_undef(cv);
+ else {
+ cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ if (name) {
+ GvCV_set(gv,cv);
+ GvCVGEN(gv) = 0;
+ if (HvENAME_HEK(GvSTASH(gv)))
+ mro_method_changed_in(GvSTASH(gv)); /* newXS */
+ }
+ }
+ if (!name)
+ CvANON_on(cv);
+ CvGV_set(cv, gv);
+ (void)gv_fetchfile(filename);
+ CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
+ an external constant string */
+ assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+ CvISXSUB_on(cv);
+ CvXSUB(cv) = subaddr;
+
+ if (name)
+ process_special_blocks(name, gv, cv);
+ }
+
+ if (flags & XS_DYNAMIC_FILENAME) {
+ CvFILE(cv) = savepv(filename);
+ CvDYNFILE_on(cv);
}
+ sv_setpv(MUTABLE_SV(cv), proto);
return cv;
}
CV *
Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
{
- dVAR;
- GV * const gv = gv_fetchpv(name ? name :
- (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
- GV_ADDMULTI, SVt_PVCV);
- register CV *cv;
-
PERL_ARGS_ASSERT_NEWXS;
-
- if (!subaddr)
- Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
-
- if ((cv = (name ? GvCV(gv) : NULL))) {
- if (GvCVGEN(gv)) {
- /* just a cached method */
- SvREFCNT_dec(cv);
- cv = NULL;
- }
- 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);
- }
- }
- }
- }
- SvREFCNT_dec(cv);
- cv = NULL;
- }
- }
-
- if (cv) /* must reuse cv if autoloaded */
- cv_undef(cv);
- else {
- cv = MUTABLE_CV(newSV_type(SVt_PVCV));
- if (name) {
- GvCV_set(gv,cv);
- GvCVGEN(gv) = 0;
- mro_method_changed_in(GvSTASH(gv)); /* newXS */
- }
- }
- if (!name)
- CvANON_on(cv);
- CvGV_set(cv, gv);
- (void)gv_fetchfile(filename);
- CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
- an external constant string */
- CvISXSUB_on(cv);
- CvXSUB(cv) = subaddr;
-
- if (name)
- process_special_blocks(name, gv, cv);
-
- return cv;
+ return newXS_flags(name, subaddr, filename, NULL, 0);
}
#ifdef PERL_MAD
PERL_ARGS_ASSERT_CK_BITOP;
-#define OP_IS_NUMCOMPARE(op) \
- ((op) == OP_LT || (op) == OP_I_LT || \
- (op) == OP_GT || (op) == OP_I_GT || \
- (op) == OP_LE || (op) == OP_I_LE || \
- (op) == OP_GE || (op) == OP_I_GE || \
- (op) == OP_EQ || (op) == OP_I_EQ || \
- (op) == OP_NE || (op) == OP_I_NE || \
- (op) == OP_NCMP || (op) == OP_I_NCMP)
o->op_private = (U8)(PL_hints & HINT_INTEGER);
if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
&& (o->op_type == OP_BIT_OR
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)
{
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;
}
register OP *kid = cLISTOPo->op_first;
OP *sibl;
I32 numargs = 0;
+ bool seen_optional = FALSE;
if (kid->op_type == OP_PUSHMARK ||
(kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
tokid = &kid->op_sibling;
kid = kid->op_sibling;
}
- if (!kid && PL_opargs[type] & OA_DEFGV)
- *tokid = kid = newDEFSVOP();
+ if (kid && kid->op_type == OP_COREARGS) {
+ bool optional = FALSE;
+ while (oa) {
+ numargs++;
+ if (oa & OA_OPTIONAL) optional = TRUE;
+ oa = oa >> 4;
+ }
+ if (optional) o->op_private |= numargs;
+ return o;
+ }
+
+ while (oa) {
+ if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
+ if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
+ *tokid = kid = newDEFSVOP();
+ seen_optional = TRUE;
+ }
+ if (!kid) break;
- while (oa && kid) {
numargs++;
sibl = kid->op_sibling;
#ifdef PERL_MAD
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;
{
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;
{
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 (!(strchr(method, ':') || strchr(method, '\''))) {
OP *cmop;
if (!SvREADONLY(sv) || !SvFAKE(sv)) {
- sv = newSVpvn_share(method, 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
o->op_type = OP_SSELECT;
o->op_ppaddr = PL_ppaddr[OP_SSELECT];
o = ck_fun(o);
- return fold_constants(o);
+ return fold_constants(op_integerize(op_std_init(o)));
}
}
o = ck_fun(o);
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);
+ 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)
proto++;
continue;
default:
- oops:
- Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
- gv_ename(namegv), SVfARG(protosv));
+ oops: {
+ SV* const tmpsv = sv_newmortal();
+ gv_efullname3(tmpsv, namegv, NULL);
+ Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
+ SVfARG(tmpsv), SVfARG(protosv));
+ }
}
op_lvalue(aop, OP_ENTERSUB);
PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
if (!opnum) {
- OP *prev, *cvop;
+ OP *cvop;
if (!aop->op_sibling)
aop = cUNOPx(aop)->op_first;
- prev = aop;
aop = aop->op_sibling;
for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
}
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
(void)too_many_arguments(aop, GvNAME(namegv));
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);
}
}
OP *
-Perl_ck_unpack(pTHX_ OP *o)
-{
- OP *kid = cLISTOPo->op_first;
-
- PERL_ARGS_ASSERT_CK_UNPACK;
-
- if (kid->op_sibling) {
- kid = kid->op_sibling;
- if (!kid->op_sibling)
- kid->op_sibling = newDEFSVOP();
- }
- return ck_fun(o);
-}
-
-OP *
Perl_ck_substr(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_SUBSTR;
}
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(
+ 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 *
return (OP*)unop;
}
-/* Checks if o acts as an in-place operator on an array. oright points to the
- * beginning of the right-hand side. Returns the left-hand side of the
- * assignment if o acts in-place, or NULL otherwise. */
+/* Check for in place reverse and sort assignments like "@a = reverse @a"
+ and modify the optree to make them work inplace */
-STATIC OP *
-S_is_inplace_av(pTHX_ OP *o, OP *oright) {
- OP *o2;
- OP *oleft = NULL;
+STATIC void
+S_inplace_aassign(pTHX_ OP *o) {
- PERL_ARGS_ASSERT_IS_INPLACE_AV;
+ OP *modop, *modop_pushmark;
+ OP *oright;
+ OP *oleft, *oleft_pushmark;
- if (!oright ||
- (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
- || oright->op_next != o
- || (oright->op_private & OPpLVAL_INTRO)
- )
- return NULL;
+ PERL_ARGS_ASSERT_INPLACE_AASSIGN;
- /* o2 follows the chain of op_nexts through the LHS of the
- * assign (if any) to the aassign op itself */
- o2 = o->op_next;
- if (!o2 || o2->op_type != OP_NULL)
- return NULL;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_PUSHMARK)
- return NULL;
- o2 = o2->op_next;
- if (o2 && o2->op_type == OP_GV)
- o2 = o2->op_next;
- if (!o2
- || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
- || (o2->op_private & OPpLVAL_INTRO)
- )
- return NULL;
- oleft = o2;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_NULL)
- return NULL;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_AASSIGN
- || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
- return NULL;
+ assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
- /* check that the sort is the first arg on RHS of assign */
+ assert(cUNOPo->op_first->op_type == OP_NULL);
+ modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
+ assert(modop_pushmark->op_type == OP_PUSHMARK);
+ modop = modop_pushmark->op_sibling;
- o2 = cUNOPx(o2)->op_first;
- if (!o2 || o2->op_type != OP_NULL)
- return NULL;
- o2 = cUNOPx(o2)->op_first;
- if (!o2 || o2->op_type != OP_PUSHMARK)
- return NULL;
- if (o2->op_sibling != o)
- return NULL;
+ if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
+ return;
+
+ /* no other operation except sort/reverse */
+ if (modop->op_sibling)
+ return;
+
+ assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
+ oright = cUNOPx(modop)->op_first->op_sibling;
+
+ if (modop->op_flags & OPf_STACKED) {
+ /* skip sort subroutine/block */
+ assert(oright->op_type == OP_NULL);
+ oright = oright->op_sibling;
+ }
+
+ assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
+ oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
+ assert(oleft_pushmark->op_type == OP_PUSHMARK);
+ oleft = oleft_pushmark->op_sibling;
+
+ /* Check the lhs is an array */
+ if (!oleft ||
+ (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
+ || oleft->op_sibling
+ || (oleft->op_private & OPpLVAL_INTRO)
+ )
+ return;
+
+ /* Only one thing on the rhs */
+ if (oright->op_sibling)
+ return;
/* check the array is the same on both sides */
if (oleft->op_type == OP_RV2AV) {
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)
)
- return NULL;
+ return;
}
else if (oright->op_type != OP_PADAV
|| oright->op_targ != oleft->op_targ
)
- return NULL;
+ return;
- return oleft;
+ /* This actually is an inplace assignment */
+
+ modop->op_private |= OPpSORT_INPLACE;
+
+ /* transfer MODishness etc from LHS arg to RHS arg */
+ oright->op_flags = oleft->op_flags;
+
+ /* remove the aassign op and the lhs */
+ op_null(o);
+ op_null(oleft_pushmark);
+ if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
+ op_null(cUNOPx(oleft)->op_first);
+ op_null(oleft);
}
#define MAX_DEFERRED 4
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
(OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
- (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
- <= 255 &&
- i >= 0)
+ (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
{
GV *gv;
if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
break;
- case OP_RV2SV:
- case OP_RV2AV:
- case OP_RV2HV:
- if (oldop &&
- (
- (
- ( oldop->op_type == OP_AELEM
- || oldop->op_type == OP_PADSV
- || oldop->op_type == OP_RV2SV
- || oldop->op_type == OP_RV2GV
- || oldop->op_type == OP_HELEM
- )
- && (oldop->op_private & OPpDEREF)
- )
- || ( oldop->op_type == OP_ENTERSUB
- && oldop->op_private & OPpENTERSUB_DEREF )
- )
- ) {
- o->op_private |= OPpDEREFed;
- }
-
case OP_SORT: {
- /* will point to RV2AV or PADAV op on LHS/RHS of assign */
- OP *oleft;
- OP *o2;
-
/* check that RHS of sort is a single plain array */
OP *oright = cUNOPo->op_first;
if (!oright || oright->op_type != OP_PUSHMARK)
break;
+ if (o->op_private & OPpSORT_INPLACE)
+ break;
+
/* reverse sort ... can be optimised. */
if (!cUNOPo->op_sibling) {
/* Nothing follows us on the list. */
}
}
- /* make @a = sort @a act in-place */
-
- oright = cUNOPx(oright)->op_sibling;
- if (!oright)
- break;
- if (oright->op_type == OP_NULL) { /* skip sort block/sub */
- oright = cUNOPx(oright)->op_sibling;
- }
-
- oleft = is_inplace_av(o, oright);
- if (!oleft)
- break;
-
- /* transfer MODishness etc from LHS arg to RHS arg */
- oright->op_flags = oleft->op_flags;
- o->op_private |= OPpSORT_INPLACE;
-
- /* excise push->gv->rv2av->null->aassign */
- o2 = o->op_next->op_next;
- op_null(o2); /* PUSHMARK */
- o2 = o2->op_next;
- if (o2->op_type == OP_GV) {
- op_null(o2); /* GV */
- o2 = o2->op_next;
- }
- op_null(o2); /* RV2AV or PADAV */
- o2 = o2->op_next->op_next;
- op_null(o2); /* AASSIGN */
-
- o->op_next = o2->op_next;
-
break;
}
case OP_REVERSE: {
OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
OP *gvop = NULL;
- OP *oleft, *oright;
LISTOP *enter, *exlist;
- /* @a = reverse @a */
- if ((oright = cLISTOPo->op_first)
- && (oright->op_type == OP_PUSHMARK)
- && (oright = oright->op_sibling)
- && (oleft = is_inplace_av(o, oright))) {
- OP *o2;
-
- /* transfer MODishness etc from LHS arg to RHS arg */
- oright->op_flags = oleft->op_flags;
- o->op_private |= OPpREVERSE_INPLACE;
-
- /* excise push->gv->rv2av->null->aassign */
- o2 = o->op_next->op_next;
- op_null(o2); /* PUSHMARK */
- o2 = o2->op_next;
- if (o2->op_type == OP_GV) {
- op_null(o2); /* GV */
- o2 = o2->op_next;
- }
- op_null(o2); /* RV2AV or PADAV */
- o2 = o2->op_next->op_next;
- op_null(o2); /* AASSIGN */
-
- o->op_next = o2->op_next;
+ if (o->op_private & OPpSORT_INPLACE)
break;
- }
enter = (LISTOP *) o->op_next;
if (!enter)
}
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";
}
oa = PL_opargs[i] >> OASHIFT;
while (oa) {
if (oa & OA_OPTIONAL && !seen_question && (
- !defgv || n || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
+ !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
)) {
seen_question = 1;
str[n++] = ';';
str[n++] = ']';
}
else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
+ if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
+ str[n-1] = '_'; defgv = 0;
+ }
oa = oa >> 4;
}
- if (defgv && str[0] == '$')
- str[0] = '_';
if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
str[n++] = '\0';
sv_setpvn(sv, str, n - 1);
return sv;
}
+OP *
+Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
+ const int opnum)
+{
+ OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
+ OP *o;
+
+ PERL_ARGS_ASSERT_CORESUB_OP;
+
+ switch(opnum) {
+ case 0:
+ return op_append_elem(OP_LINESEQ,
+ argop,
+ newSLICEOP(0,
+ newSVOP(OP_CONST, 0, newSViv(-code % 3)),
+ newOP(OP_CALLER,0)
+ )
+ );
+ case OP_SELECT: /* which represents OP_SSELECT as well */
+ if (code)
+ return newCONDOP(
+ 0,
+ newBINOP(OP_GT, 0,
+ newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
+ newSVOP(OP_CONST, 0, newSVuv(1))
+ ),
+ coresub_op(newSVuv((UV)OP_SSELECT), 0,
+ OP_SSELECT),
+ coresub_op(coreargssv, 0, OP_SELECT)
+ );
+ /* FALL THROUGH */
+ default:
+ switch (PL_opargs[opnum] & OA_CLASS_MASK) {
+ case OA_BASEOP:
+ return op_append_elem(
+ OP_LINESEQ, argop,
+ newOP(opnum,
+ opnum == OP_WANTARRAY || opnum == OP_RUNCV
+ ? OPpOFFBYONE << 8 : 0)
+ );
+ case OA_BASEOP_OR_UNOP:
+ 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:
+ if (is_handle_constructor(o, 1))
+ argop->op_private |= OPpCOREARGS_DEREF1;
+ }
+ return o;
+ default:
+ o = convert(opnum,0,argop);
+ if (is_handle_constructor(o, 2))
+ argop->op_private |= OPpCOREARGS_DEREF2;
+ if (scalar_mod_type(NULL, opnum))
+ argop->op_private |= OPpCOREARGS_SCALARMOD;
+ if (opnum == OP_SUBSTR) {
+ o->op_private |= OPpMAYBE_LVSUB;
+ return o;
+ }
+ else goto 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