}
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);
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);
warning before dieing, hence this test goes here.
If it were immediately before the second SvIV_please, then
DIE() would be invoked before left was even inspected, so
- no inpsection would give no warning. */
+ no inspection would give no warning. */
if (right == 0)
DIE(aTHX_ "Illegal division by zero");
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;
}
SvGETMAGIC(sv);
if (SvAMAGIC(sv)) {
/* N.B.: AMG macros return sv if no overloading is found */
- SV *maybe_hv = AMG_CALLun(sv,to_hv);
- SV *maybe_av = AMG_CALLun(sv,to_av);
+ 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 %%{}",
const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
if (mg) {
- *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
- PUSHMARK(MARK);
- PUTBACK;
- ENTER_with_name("call_SPLICE");
- call_method("SPLICE",GIMME_V);
- LEAVE_with_name("call_SPLICE");
- SPAGAIN;
- RETURN;
+ return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
+ GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
+ sp - mark);
}
SP++;
if (AvREAL(ary)) {
EXTEND_MORTAL(length);
for (i = length, dst = MARK; i; i--) {
- sv_2mortal(*dst); /* free them eventualy */
+ sv_2mortal(*dst); /* free them eventually */
dst++;
}
}
if (AvREAL(ary)) {
EXTEND_MORTAL(length);
for (i = length, dst = MARK; i; i--) {
- sv_2mortal(*dst); /* free them eventualy */
+ sv_2mortal(*dst); /* free them eventually */
dst++;
}
}
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 {
PP(unimplemented_op)
{
dVAR;
- DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
- PL_op->op_type);
+ const Optype op_type = PL_op->op_type;
+ /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
+ with out of range op numbers - it only "special" cases op_custom.
+ Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
+ if we get here for a custom op then that means that the custom op didn't
+ have an implementation. Given that OP_NAME() looks up the custom op
+ by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
+ registers &PL_unimplemented_op as the address of their custom op.
+ 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);
}
PP(pp_boolkeys)
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) {
https://perl5.git.perl.org / perl5.git / blobdiff