if (PL_op->op_flags & OPf_REF) {
PUSHs(TARG);
RETURN;
- } else if (LVRET) {
+ } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (GIMME == G_SCALAR)
Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
PUSHs(TARG);
RETURN;
+ }
}
gimme = GIMME_V;
if (gimme == G_ARRAY) {
SAVECLEARSV(PAD_SVl(PL_op->op_targ));
if (PL_op->op_flags & OPf_REF)
RETURN;
- else if (LVRET) {
+ else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (GIMME == G_SCALAR)
Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
RETURN;
+ }
}
gimme = GIMME_V;
if (gimme == G_ARRAY) {
- RETURNOP(do_kv());
+ RETURNOP(Perl_do_kv(aTHX));
}
else if (gimme == G_SCALAR) {
SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
Perl_die(aTHX_ PL_no_usym, what);
}
if (!SvOK(sv)) {
- if (PL_op->op_flags & OPf_REF)
+ if (
+ PL_op->op_flags & OPf_REF &&
+ PL_op->op_next->op_type != OP_BOOLKEYS
+ )
Perl_die(aTHX_ PL_no_usym, what);
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
RETPUSHYES;
}
s = (unsigned char*)(SvPV(sv, len));
- pos = len;
- if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
+ if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv)) {
/* No point in studying a zero length string, and not safe to study
anything that doesn't appear to be a simple scalar (and hence might
change between now and when the regexp engine runs without our set
stringification. */
RETPUSHNO;
}
+ pos = len;
if (PL_lastscream) {
SvSCREAM_off(PL_lastscream);
}
PL_lastscream = SvREFCNT_inc_simple(sv);
- s = (unsigned char*)(SvPV(sv, len));
- pos = len;
- if (pos <= 0)
- RETPUSHNO;
if (pos > PL_maxscream) {
if (PL_maxscream < 0) {
PL_maxscream = pos + 80;
gp_free(MUTABLE_GV(sv));
Newxz(gp, 1, GP);
- GvGP(sv) = gp_ref(gp);
+ GvGP_set(sv, gp_ref(gp));
GvSV(sv) = newSV(0);
GvLINE(sv) = CopLINE(PL_curcop);
GvEGV(sv) = MUTABLE_GV(sv);
SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
if (!p) {
- sv_setsv(TARG, &PL_sv_undef);
- SETTARG;
+ if (!SvPADTMP(TARG)) {
+ sv_setsv(TARG, &PL_sv_undef);
+ SETTARG;
+ }
+ SETs(&PL_sv_undef);
}
else if (DO_UTF8(sv)) {
SETi(utf8_length((U8*)p, (U8*)p + len));
else
SETi(sv_len(sv));
} else {
- sv_setsv_nomg(TARG, &PL_sv_undef);
- SETTARG;
+ if (!SvPADTMP(TARG)) {
+ sv_setsv_nomg(TARG, &PL_sv_undef);
+ SETTARG;
+ }
+ SETs(&PL_sv_undef);
}
RETURN;
}
}
}
SPAGAIN;
- PUSHs(TARG); /* avoid SvSETMAGIC here */
+ SvSETMAGIC(TARG);
+ PUSHs(TARG);
RETURN;
bound_fail:
PP(pp_sprintf)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- if (SvTAINTED(MARK[1]))
- TAINT_PROPER("sprintf");
SvTAINTED_off(TARG);
do_sprintf(TARG, SP-MARK, MARK+1);
TAINT_IF(SvTAINTED(TARG));
/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
* most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
-/* Both the characters below can be stored in two UTF-8 bytes. In UTF-8 the max
- * character that 2 bytes can hold is U+07FF, and in UTF-EBCDIC it is U+03FF.
- * See http://www.unicode.org/unicode/reports/tr16 */
-#define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178 /* Also is title case */
-#define GREEK_CAPITAL_LETTER_MU 0x039C /* Upper and title case of MICRON */
-
/* Below are several macros that generate code */
/* Generates code to store a unicode codepoint c that is known to occupy
* exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
SvCUR_set(dest, need - 1);
}
}
+ if (dest != source && SvTAINTED(source))
+ SvTAINT(dest);
SvSETMAGIC(dest);
RETURN;
}
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
}
} /* End of isn't utf8 */
+ if (dest != source && SvTAINTED(source))
+ SvTAINT(dest);
SvSETMAGIC(dest);
RETURN;
}
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
}
}
+ if (dest != source && SvTAINTED(source))
+ SvTAINT(dest);
SvSETMAGIC(dest);
RETURN;
}
dSP;
dPOPss;
- if (!SvOK(sv))
- RETURN;
-
- if (SvROK(sv)) {
- SvGETMAGIC(sv);
- if (SvAMAGIC(sv)) {
- /* N.B.: AMG macros return sv if no overloading is found */
- SV *maybe_hv = AMG_CALLunary(sv, to_hv_amg);
- SV *maybe_av = AMG_CALLunary(sv, to_av_amg);
- if ( maybe_hv != sv && maybe_av != sv ) {
- Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
- Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
- PL_op_desc[PL_op->op_type]
- )
- );
- sv = maybe_hv;
- }
- else if ( maybe_av != sv ) {
- if ( SvTYPE(SvRV(sv)) == SVt_PVHV ) {
- /* @{} overload, but underlying reftype is HV */
- Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
- Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as @{}",
- PL_op_desc[PL_op->op_type]
- )
- );
- }
- sv = maybe_av;
- }
- else if ( maybe_hv != sv ) {
- if ( SvTYPE(SvRV(sv)) == SVt_PVAV ) {
- /* %{} overload, but underlying reftype is AV */
- Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
- Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
- PL_op_desc[PL_op->op_type]
- )
- );
- }
- sv = maybe_hv;
- }
- }
- sv = SvRV(sv);
- }
-
- if ( SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV ) {
- DIE(aTHX_ "Type of argument to %s must be hashref or arrayref",
+ SvGETMAGIC(sv);
+
+ if (
+ !SvROK(sv)
+ || (sv = SvRV(sv),
+ (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
+ || SvOBJECT(sv)
+ )
+ ) {
+ DIE(aTHX_
+ "Type of argument to %s must be unblessed hashref or arrayref",
PL_op_desc[PL_op->op_type] );
}
+ if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
+ DIE(aTHX_
+ "Can't modify %s in %s",
+ PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
+ );
+
/* Delegate to correct function for op type */
PUSHs(sv);
if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
RETURN;
}
+static AV *
+S_deref_plain_array(pTHX_ AV *ary)
+{
+ if (SvTYPE(ary) == SVt_PVAV) return ary;
+ SvGETMAGIC((SV *)ary);
+ if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
+ Perl_die(aTHX_ "Not an ARRAY reference");
+ else if (SvOBJECT(SvRV(ary)))
+ Perl_die(aTHX_ "Not an unblessed ARRAY reference");
+ return (AV *)SvRV(ary);
+}
+
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define DEREF_PLAIN_ARRAY(ary) \
+ ({ \
+ AV *aRrRay = ary; \
+ SvTYPE(aRrRay) == SVt_PVAV \
+ ? aRrRay \
+ : S_deref_plain_array(aTHX_ aRrRay); \
+ })
+#else
+# define DEREF_PLAIN_ARRAY(ary) \
+ ( \
+ PL_Sv = (SV *)(ary), \
+ SvTYPE(PL_Sv) == SVt_PVAV \
+ ? (AV *)PL_Sv \
+ : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
+ )
+#endif
+
PP(pp_splice)
{
dVAR; dSP; dMARK; dORIGMARK;
- register AV *ary = MUTABLE_AV(*++MARK);
+ register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
register SV **src;
register SV **dst;
register I32 i;
PP(pp_push)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- register AV * const ary = MUTABLE_AV(*++MARK);
+ register AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
if (mg) {
dVAR;
dSP;
AV * const av = PL_op->op_flags & OPf_SPECIAL
- ? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs);
+ ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
EXTEND(SP, 1);
assert (sv);
PP(pp_unshift)
{
dVAR; dSP; dMARK; dORIGMARK; dTARGET;
- register AV *ary = MUTABLE_AV(*++MARK);
+ register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
if (mg) {
DIE(aTHX_ "panic: pp_split");
rx = PM_GETRE(pm);
- TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
+ TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
(RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
RX_MATCH_UTF8_set(rx, do_utf8);
while (*s == ' ' || is_utf8_space((U8*)s))
s += UTF8SKIP(s);
}
- else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
+ else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
while (isSPACE_LC(*s))
s++;
}
s++;
}
}
- if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
+ if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
multiline = 1;
}
else
m += t;
}
- } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
+ }
+ else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
while (m < strend && !isSPACE_LC(*m))
++m;
} else {
if (do_utf8) {
while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
s += UTF8SKIP(s);
- } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
+ }
+ else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
while (s < strend && isSPACE_LC(*s))
++s;
} else {
NULL doesn't generate a useful error message. "custom" does. */
const char *const name = op_type >= OP_max
? "[out of range]" : PL_op_name[PL_op->op_type];
+ if(OP_IS_SOCKET(op_type))
+ DIE(aTHX_ PL_no_sock_func, name);
DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
}
dSP;
HV * const hv = (HV*)POPs;
+ if (SvTYPE(hv) != SVt_PVHV) { XPUSHs(&PL_sv_no); RETURN; }
+
if (SvRMAGICAL(hv)) {
MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
if (mg) {
}
}
- XPUSHs(boolSV(HvKEYS(hv) != 0));
+ XPUSHs(boolSV(HvUSEDKEYS(hv) != 0));
RETURN;
}
https://perl5.git.perl.org / perl5.git / blobdiff