}
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));
if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
if (SvROK(sv)) {
wasref:
- sv = amagic_deref_call(sv, to_gv_amg);
- SPAGAIN;
-
+ if (SvAMAGIC(sv)) {
+ sv = amagic_deref_call(sv, to_gv_amg);
+ SPAGAIN;
+ }
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVIO) {
GV * const gv = MUTABLE_GV(sv_newmortal());
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);
if (!(PL_op->op_private & OPpDEREFed))
SvGETMAGIC(sv);
if (SvROK(sv)) {
- sv = amagic_deref_call(sv, to_sv_amg);
- SPAGAIN;
+ if (SvAMAGIC(sv)) {
+ sv = amagic_deref_call(sv, to_sv_amg);
+ SPAGAIN;
+ }
sv = SvRV(sv);
switch (SvTYPE(sv)) {
/* Lvalue operators. */
+static void
+S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
+{
+ dVAR;
+ STRLEN len;
+ char *s;
+
+ PERL_ARGS_ASSERT_DO_CHOMP;
+
+ if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
+ return;
+ if (SvTYPE(sv) == SVt_PVAV) {
+ I32 i;
+ AV *const av = MUTABLE_AV(sv);
+ const I32 max = AvFILL(av);
+
+ for (i = 0; i <= max; i++) {
+ sv = MUTABLE_SV(av_fetch(av, i, FALSE));
+ if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
+ do_chomp(retval, sv, chomping);
+ }
+ return;
+ }
+ else if (SvTYPE(sv) == SVt_PVHV) {
+ HV* const hv = MUTABLE_HV(sv);
+ HE* entry;
+ (void)hv_iterinit(hv);
+ while ((entry = hv_iternext(hv)))
+ do_chomp(retval, hv_iterval(hv,entry), chomping);
+ return;
+ }
+ else if (SvREADONLY(sv)) {
+ if (SvFAKE(sv)) {
+ /* SV is copy-on-write */
+ sv_force_normal_flags(sv, 0);
+ }
+ if (SvREADONLY(sv))
+ Perl_croak_no_modify(aTHX);
+ }
+
+ if (PL_encoding) {
+ if (!SvUTF8(sv)) {
+ /* XXX, here sv is utf8-ized as a side-effect!
+ If encoding.pm is used properly, almost string-generating
+ operations, including literal strings, chr(), input data, etc.
+ should have been utf8-ized already, right?
+ */
+ sv_recode_to_utf8(sv, PL_encoding);
+ }
+ }
+
+ s = SvPV(sv, len);
+ if (chomping) {
+ char *temp_buffer = NULL;
+ SV *svrecode = NULL;
+
+ if (s && len) {
+ s += --len;
+ if (RsPARA(PL_rs)) {
+ if (*s != '\n')
+ goto nope;
+ ++SvIVX(retval);
+ while (len && s[-1] == '\n') {
+ --len;
+ --s;
+ ++SvIVX(retval);
+ }
+ }
+ else {
+ STRLEN rslen, rs_charlen;
+ const char *rsptr = SvPV_const(PL_rs, rslen);
+
+ rs_charlen = SvUTF8(PL_rs)
+ ? sv_len_utf8(PL_rs)
+ : rslen;
+
+ if (SvUTF8(PL_rs) != SvUTF8(sv)) {
+ /* Assumption is that rs is shorter than the scalar. */
+ if (SvUTF8(PL_rs)) {
+ /* RS is utf8, scalar is 8 bit. */
+ bool is_utf8 = TRUE;
+ temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
+ &rslen, &is_utf8);
+ if (is_utf8) {
+ /* Cannot downgrade, therefore cannot possibly match
+ */
+ assert (temp_buffer == rsptr);
+ temp_buffer = NULL;
+ goto nope;
+ }
+ rsptr = temp_buffer;
+ }
+ else if (PL_encoding) {
+ /* RS is 8 bit, encoding.pm is used.
+ * Do not recode PL_rs as a side-effect. */
+ svrecode = newSVpvn(rsptr, rslen);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ rsptr = SvPV_const(svrecode, rslen);
+ rs_charlen = sv_len_utf8(svrecode);
+ }
+ else {
+ /* RS is 8 bit, scalar is utf8. */
+ temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
+ rsptr = temp_buffer;
+ }
+ }
+ if (rslen == 1) {
+ if (*s != *rsptr)
+ goto nope;
+ ++SvIVX(retval);
+ }
+ else {
+ if (len < rslen - 1)
+ goto nope;
+ len -= rslen - 1;
+ s -= rslen - 1;
+ if (memNE(s, rsptr, rslen))
+ goto nope;
+ SvIVX(retval) += rs_charlen;
+ }
+ }
+ s = SvPV_force_nolen(sv);
+ SvCUR_set(sv, len);
+ *SvEND(sv) = '\0';
+ SvNIOK_off(sv);
+ SvSETMAGIC(sv);
+ }
+ nope:
+
+ SvREFCNT_dec(svrecode);
+
+ Safefree(temp_buffer);
+ } else {
+ if (len && !SvPOK(sv))
+ s = SvPV_force_nomg(sv, len);
+ if (DO_UTF8(sv)) {
+ if (s && len) {
+ char * const send = s + len;
+ char * const start = s;
+ s = send - 1;
+ while (s > start && UTF8_IS_CONTINUATION(*s))
+ s--;
+ if (is_utf8_string((U8*)s, send - s)) {
+ sv_setpvn(retval, s, send - s);
+ *s = '\0';
+ SvCUR_set(sv, s - start);
+ SvNIOK_off(sv);
+ SvUTF8_on(retval);
+ }
+ }
+ else
+ sv_setpvs(retval, "");
+ }
+ else if (s && len) {
+ s += --len;
+ sv_setpvn(retval, s, 1);
+ *s = '\0';
+ SvCUR_set(sv, len);
+ SvUTF8_off(sv);
+ SvNIOK_off(sv);
+ }
+ else
+ sv_setpvs(retval, "");
+ SvSETMAGIC(sv);
+ }
+}
+
PP(pp_schop)
{
dVAR; dSP; dTARGET;
- do_chop(TARG, TOPs);
+ const bool chomping = PL_op->op_type == OP_SCHOMP;
+
+ if (chomping)
+ sv_setiv(TARG, 0);
+ do_chomp(TARG, TOPs, chomping);
SETTARG;
RETURN;
}
PP(pp_chop)
{
dVAR; dSP; dMARK; dTARGET; dORIGMARK;
+ const bool chomping = PL_op->op_type == OP_CHOMP;
+
+ if (chomping)
+ sv_setiv(TARG, 0);
while (MARK < SP)
- do_chop(TARG, *++MARK);
+ do_chomp(TARG, *++MARK, chomping);
SP = ORIGMARK;
XPUSHTARG;
RETURN;
}
-PP(pp_schomp)
-{
- dVAR; dSP; dTARGET;
- SETi(do_chomp(TOPs));
- RETURN;
-}
-
-PP(pp_chomp)
-{
- dVAR; dSP; dMARK; dTARGET;
- register I32 count = 0;
-
- while (SP > MARK)
- count += do_chomp(POPs);
- XPUSHi(count);
- RETURN;
-}
-
PP(pp_undef)
{
dVAR; dSP;
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");
PP(pp_left_shift)
{
dVAR; dSP; dATARGET; SV *svl, *svr;
- tryAMAGICbin_MG(lshift_amg, AMGf_assign);
+ tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
svr = POPs;
svl = TOPs;
{
PP(pp_right_shift)
{
dVAR; dSP; dATARGET; SV *svl, *svr;
- tryAMAGICbin_MG(rshift_amg, AMGf_assign);
+ tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
svr = POPs;
svl = TOPs;
{
PP(pp_lt)
{
dVAR; dSP;
- tryAMAGICbin_MG(lt_amg, AMGf_set);
+ tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
#ifdef PERL_PRESERVE_IVUV
SvIV_please_nomg(TOPs);
if (SvIOK(TOPs)) {
PP(pp_gt)
{
dVAR; dSP;
- tryAMAGICbin_MG(gt_amg, AMGf_set);
+ tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
#ifdef PERL_PRESERVE_IVUV
SvIV_please_nomg(TOPs);
if (SvIOK(TOPs)) {
PP(pp_le)
{
dVAR; dSP;
- tryAMAGICbin_MG(le_amg, AMGf_set);
+ tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
#ifdef PERL_PRESERVE_IVUV
SvIV_please_nomg(TOPs);
if (SvIOK(TOPs)) {
PP(pp_ge)
{
dVAR; dSP;
- tryAMAGICbin_MG(ge_amg,AMGf_set);
+ tryAMAGICbin_MG(ge_amg,AMGf_set|AMGf_numeric);
#ifdef PERL_PRESERVE_IVUV
SvIV_please_nomg(TOPs);
if (SvIOK(TOPs)) {
PP(pp_ne)
{
dVAR; dSP;
- tryAMAGICbin_MG(ne_amg,AMGf_set);
+ tryAMAGICbin_MG(ne_amg,AMGf_set|AMGf_numeric);
#ifndef NV_PRESERVES_UV
if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
PP(pp_ncmp)
{
dVAR; dSP; dTARGET;
- tryAMAGICbin_MG(ncmp_amg, 0);
+ tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
#ifndef NV_PRESERVES_UV
if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
const UV right = PTR2UV(SvRV(POPs));
PP(pp_complement)
{
dVAR; dSP; dTARGET;
- tryAMAGICun_MG(compl_amg, 0);
+ tryAMAGICun_MG(compl_amg, AMGf_numeric);
{
dTOPss;
if (SvNIOKp(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;
}
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 %%{}",
}
if ( SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV ) {
- DIE(aTHX_ Perl_form(aTHX_ "Type of argument to %s must be hashref or arrayref",
- PL_op_desc[PL_op->op_type] ));
+ DIE(aTHX_ "Type of argument to %s must be hashref or arrayref",
+ PL_op_desc[PL_op->op_type] );
}
/* Delegate to correct function for op type */
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