dVAR;
OP *kid;
const char* useless = NULL;
+ U32 useless_is_utf8 = 0;
SV* sv;
U8 want;
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)
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;
}
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;
}
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:
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)));
}
/*
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)
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) {
? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
bool has_name;
+ bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0;
if (proto) {
assert(proto->op_type == OP_CONST);
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);
+ CvCONST(cv) ? "Constant subroutine %"SVf" redefined"
+ : "Subroutine %"SVf" redefined",
+ SVfARG(cSVOPo->op_sv));
CopLINE_set(PL_curcop, oldline);
}
#ifdef PERL_MAD
}
else {
GvCV_set(gv, NULL);
- cv = newCONSTSUB(NULL, name, const_sv);
+ cv = newCONSTSUB_flags(NULL, name, name_is_utf8 ? SVf_UTF8 : 0, const_sv);
}
mro_method_changed_in( /* sub Foo::Bar () { 123 } */
(CvGV(cv) && GvSTASH(CvGV(cv)))
(long)CopLINE(PL_curcop));
gv_efullname3(tmpstr, gv, NULL);
(void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
- SvCUR(tmpstr), sv, 0);
+ SvUTF8(tmpstr) ? -SvCUR(tmpstr) : 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) ? -SvCUR(tmpstr) : SvCUR(tmpstr))) {
CV * const pcv = GvCV(db_postponed);
if (pcv) {
dSP;
/*
=for apidoc newCONSTSUB
+See L</newCONSTSUB_flags>.
+
+=cut
+*/
+
+CV *
+Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
+{
+ return newCONSTSUB_flags(stash, name, 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, U32 flags, SV *sv)
{
dVAR;
CV* cv;
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);
+ 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);
+ CV *cv;
PERL_ARGS_ASSERT_NEWXS_FLAGS;
+ {
+ GV * const gv = gv_fetchpv(name ? name :
+ (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) */
+ /* 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 */
+ 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);
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 */
- assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
- 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
tokid = &kid->op_sibling;
kid = kid->op_sibling;
}
- if (kid && kid->op_type == OP_COREARGS) return o;
+ 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 (!(strchr(method, ':') || strchr(method, '\''))) {
OP *cmop;
if (!SvREADONLY(sv) || !SvFAKE(sv)) {
- sv = newSVpvn_share(method, SvCUR(sv), 0);
+ sv = newSVpvn_share(method, SvUTF8(sv) ? -SvCUR(sv) : SvCUR(sv), 0);
}
else {
kSVOP->op_sv = NULL;
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_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) {
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)
const int opnum)
{
OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
+ OP *o;
PERL_ARGS_ASSERT_CORESUB_OP;
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:
opnum == OP_WANTARRAY ? OPpOFFBYONE << 8 : 0)
);
case OA_BASEOP_OR_UNOP:
- return newUNOP(opnum,0,argop);
+ 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:
- return convert(opnum,0,argop);
+ 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;
}
}
}
https://perl5.git.perl.org / perl5.git / blobdiff