This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perldelta for 0fd86aa72aab
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
1129b882
NC
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805 5 *
a0d0e21e
LW
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
79072805 8 *
a0d0e21e
LW
9 */
10
11/*
4ac71550
TC
12 * 'It's a big house this, and very peculiar. Always a bit more
13 * to discover, and no knowing what you'll find round a corner.
14 * And Elves, sir!' --Samwise Gamgee
15 *
16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
a0d0e21e 17 */
79072805 18
166f8a29
DM
19/* This file contains general pp ("push/pop") functions that execute the
20 * opcodes that make up a perl program. A typical pp function expects to
21 * find its arguments on the stack, and usually pushes its results onto
22 * the stack, hence the 'pp' terminology. Each OP structure contains
23 * a pointer to the relevant pp_foo() function.
24 */
25
79072805 26#include "EXTERN.h"
864dbfa3 27#define PERL_IN_PP_C
79072805 28#include "perl.h"
77bc9082 29#include "keywords.h"
79072805 30
a4af207c 31#include "reentr.h"
685289b5 32#include "regcharclass.h"
a4af207c 33
dfe9444c
AD
34/* XXX I can't imagine anyone who doesn't have this actually _needs_
35 it, since pid_t is an integral type.
36 --AD 2/20/1998
37*/
38#ifdef NEED_GETPID_PROTO
39extern Pid_t getpid (void);
8ac85365
NIS
40#endif
41
0630166f
SP
42/*
43 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44 * This switches them over to IEEE.
45 */
46#if defined(LIBM_LIB_VERSION)
47 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
48#endif
49
a78bc3c6
KW
50static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
51static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
52
13017935
SM
53/* variations on pp_null */
54
93a17b20
LW
55PP(pp_stub)
56{
39644a26 57 dSP;
54310121 58 if (GIMME_V == G_SCALAR)
3280af22 59 XPUSHs(&PL_sv_undef);
93a17b20
LW
60 RETURN;
61}
62
79072805
LW
63/* Pushy stuff. */
64
bdaf10a5 65/* This is also called directly by pp_lvavref. */
93a17b20
LW
66PP(pp_padav)
67{
20b7effb 68 dSP; dTARGET;
13017935 69 I32 gimme;
e190e9b4 70 assert(SvTYPE(TARG) == SVt_PVAV);
3dbcc5e0
SM
71 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
72 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
a5911867 73 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
85e6fe83 74 EXTEND(SP, 1);
533c011a 75 if (PL_op->op_flags & OPf_REF) {
85e6fe83 76 PUSHs(TARG);
93a17b20 77 RETURN;
40c94d11
FC
78 } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
79 const I32 flags = is_lvalue_sub();
80 if (flags && !(flags & OPpENTERSUB_INARGS)) {
82334630 81 if (GIMME_V == G_SCALAR)
a84828f3 82 /* diag_listed_as: Can't return %s to lvalue scalar context */
78f9721b
SM
83 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
84 PUSHs(TARG);
85 RETURN;
40c94d11 86 }
85e6fe83 87 }
13017935
SM
88 gimme = GIMME_V;
89 if (gimme == G_ARRAY) {
d5524600 90 /* XXX see also S_pushav in pp_hot.c */
052a7c76 91 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
85e6fe83 92 EXTEND(SP, maxarg);
93965878 93 if (SvMAGICAL(TARG)) {
052a7c76 94 SSize_t i;
c70927a6 95 for (i=0; i < maxarg; i++) {
502c6561 96 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
3280af22 97 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878
NIS
98 }
99 }
100 else {
052a7c76
DM
101 SSize_t i;
102 for (i=0; i < maxarg; i++) {
428ccf1e
FC
103 SV * const sv = AvARRAY((const AV *)TARG)[i];
104 SP[i+1] = sv ? sv : &PL_sv_undef;
105 }
93965878 106 }
85e6fe83
LW
107 SP += maxarg;
108 }
13017935 109 else if (gimme == G_SCALAR) {
1b6737cc 110 SV* const sv = sv_newmortal();
c70927a6 111 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
85e6fe83
LW
112 sv_setiv(sv, maxarg);
113 PUSHs(sv);
114 }
115 RETURN;
93a17b20
LW
116}
117
118PP(pp_padhv)
119{
20b7effb 120 dSP; dTARGET;
54310121
PP
121 I32 gimme;
122
e190e9b4 123 assert(SvTYPE(TARG) == SVt_PVHV);
93a17b20 124 XPUSHs(TARG);
3dbcc5e0
SM
125 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
126 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
a5911867 127 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
533c011a 128 if (PL_op->op_flags & OPf_REF)
93a17b20 129 RETURN;
40c94d11
FC
130 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
131 const I32 flags = is_lvalue_sub();
132 if (flags && !(flags & OPpENTERSUB_INARGS)) {
82334630 133 if (GIMME_V == G_SCALAR)
a84828f3 134 /* diag_listed_as: Can't return %s to lvalue scalar context */
78f9721b
SM
135 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
136 RETURN;
40c94d11 137 }
78f9721b 138 }
54310121
PP
139 gimme = GIMME_V;
140 if (gimme == G_ARRAY) {
981b7185 141 RETURNOP(Perl_do_kv(aTHX));
85e6fe83 142 }
c8fe3bdf 143 else if ((PL_op->op_private & OPpTRUEBOOL
adc42c31 144 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
c8fe3bdf
FC
145 && block_gimme() == G_VOID ))
146 && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
147 SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
54310121 148 else if (gimme == G_SCALAR) {
85fbaab2 149 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
85e6fe83 150 SETs(sv);
85e6fe83 151 }
54310121 152 RETURN;
93a17b20
LW
153}
154
ac217057
FC
155PP(pp_padcv)
156{
20b7effb 157 dSP; dTARGET;
97b03d64
FC
158 assert(SvTYPE(TARG) == SVt_PVCV);
159 XPUSHs(TARG);
160 RETURN;
ac217057
FC
161}
162
ecf9c8b7
FC
163PP(pp_introcv)
164{
20b7effb 165 dTARGET;
6d5c2147
FC
166 SvPADSTALE_off(TARG);
167 return NORMAL;
ecf9c8b7
FC
168}
169
13f89586
FC
170PP(pp_clonecv)
171{
20b7effb 172 dTARGET;
0f94cb1f
FC
173 CV * const protocv = PadnamePROTOCV(
174 PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
175 );
6d5c2147 176 assert(SvTYPE(TARG) == SVt_PVCV);
0f94cb1f
FC
177 assert(protocv);
178 if (CvISXSUB(protocv)) { /* constant */
6d5c2147 179 /* XXX Should we clone it here? */
6d5c2147
FC
180 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
181 to introcv and remove the SvPADSTALE_off. */
182 SAVEPADSVANDMORTALIZE(ARGTARG);
0f94cb1f 183 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
6d5c2147
FC
184 }
185 else {
0f94cb1f
FC
186 if (CvROOT(protocv)) {
187 assert(CvCLONE(protocv));
188 assert(!CvCLONED(protocv));
6d5c2147 189 }
0f94cb1f 190 cv_clone_into(protocv,(CV *)TARG);
6d5c2147
FC
191 SAVECLEARSV(PAD_SVl(ARGTARG));
192 }
193 return NORMAL;
13f89586
FC
194}
195
79072805
LW
196/* Translations. */
197
6f7909da
FC
198/* In some cases this function inspects PL_op. If this function is called
199 for new op types, more bool parameters may need to be added in place of
200 the checks.
201
202 When noinit is true, the absence of a gv will cause a retval of undef.
203 This is unrelated to the cv-to-gv assignment case.
6f7909da
FC
204*/
205
206static SV *
207S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
208 const bool noinit)
209{
f64c9ac5 210 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
ed6116ce 211 if (SvROK(sv)) {
93d7320b
DM
212 if (SvAMAGIC(sv)) {
213 sv = amagic_deref_call(sv, to_gv_amg);
93d7320b 214 }
e4a1664f 215 wasref:
ed6116ce 216 sv = SvRV(sv);
b1dadf13 217 if (SvTYPE(sv) == SVt_PVIO) {
159b6efe 218 GV * const gv = MUTABLE_GV(sv_newmortal());
885f468a 219 gv_init(gv, 0, "__ANONIO__", 10, 0);
a45c7426 220 GvIOp(gv) = MUTABLE_IO(sv);
b37c2d43 221 SvREFCNT_inc_void_NN(sv);
ad64d0ec 222 sv = MUTABLE_SV(gv);
ef54e1a4 223 }
81d52ecd
JH
224 else if (!isGV_with_GP(sv)) {
225 Perl_die(aTHX_ "Not a GLOB reference");
226 }
79072805
LW
227 }
228 else {
6e592b3a 229 if (!isGV_with_GP(sv)) {
f132ae69 230 if (!SvOK(sv)) {
b13b2135 231 /* If this is a 'my' scalar and flag is set then vivify
853846ea 232 * NI-S 1999/05/07
b13b2135 233 */
f132ae69 234 if (vivify_sv && sv != &PL_sv_undef) {
2c8ac474 235 GV *gv;
ce74145d 236 if (SvREADONLY(sv))
cb077ed2 237 Perl_croak_no_modify();
2c8ac474 238 if (cUNOP->op_targ) {
0bd48802 239 SV * const namesv = PAD_SV(cUNOP->op_targ);
94e7eb6f
FC
240 HV *stash = CopSTASH(PL_curcop);
241 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
159b6efe 242 gv = MUTABLE_GV(newSV(0));
94e7eb6f 243 gv_init_sv(gv, stash, namesv, 0);
2c8ac474
GS
244 }
245 else {
0bd48802 246 const char * const name = CopSTASHPV(PL_curcop);
6b10071b 247 gv = newGVgen_flags(name,
d14578b8 248 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
7bdb4ff0 249 SvREFCNT_inc_simple_void_NN(gv);
1d8d4d2a 250 }
43230e26 251 prepare_SV_for_RV(sv);
ad64d0ec 252 SvRV_set(sv, MUTABLE_SV(gv));
853846ea 253 SvROK_on(sv);
1d8d4d2a 254 SvSETMAGIC(sv);
853846ea 255 goto wasref;
2c8ac474 256 }
81d52ecd
JH
257 if (PL_op->op_flags & OPf_REF || strict) {
258 Perl_die(aTHX_ PL_no_usym, "a symbol");
259 }
599cee73 260 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 261 report_uninit(sv);
6f7909da 262 return &PL_sv_undef;
a0d0e21e 263 }
6f7909da 264 if (noinit)
35cd451c 265 {
77cb3b01
FC
266 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
267 sv, GV_ADDMG, SVt_PVGV
23496c6e 268 ))))
6f7909da 269 return &PL_sv_undef;
35cd451c
GS
270 }
271 else {
81d52ecd
JH
272 if (strict) {
273 Perl_die(aTHX_
fedf30e1 274 PL_no_symref_sv,
81d52ecd
JH
275 sv,
276 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
277 "a symbol"
278 );
279 }
e26df76a
NC
280 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
281 == OPpDONT_INIT_GV) {
282 /* We are the target of a coderef assignment. Return
283 the scalar unchanged, and let pp_sasssign deal with
284 things. */
6f7909da 285 return sv;
e26df76a 286 }
77cb3b01 287 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
35cd451c 288 }
2acc3314 289 /* FAKE globs in the symbol table cause weird bugs (#77810) */
96293f45 290 SvFAKE_off(sv);
93a17b20 291 }
79072805 292 }
8dc99089 293 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
2acc3314 294 SV *newsv = sv_newmortal();
5cf4b255 295 sv_setsv_flags(newsv, sv, 0);
2acc3314 296 SvFAKE_off(newsv);
d8906c05 297 sv = newsv;
2acc3314 298 }
6f7909da
FC
299 return sv;
300}
301
302PP(pp_rv2gv)
303{
20b7effb 304 dSP; dTOPss;
6f7909da
FC
305
306 sv = S_rv2gv(aTHX_
307 sv, PL_op->op_private & OPpDEREF,
308 PL_op->op_private & HINT_STRICT_REFS,
309 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
310 || PL_op->op_type == OP_READLINE
311 );
d8906c05
FC
312 if (PL_op->op_private & OPpLVAL_INTRO)
313 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
314 SETs(sv);
79072805
LW
315 RETURN;
316}
317
dc3c76f8
NC
318/* Helper function for pp_rv2sv and pp_rv2av */
319GV *
fe9845cc
RB
320Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
321 const svtype type, SV ***spp)
dc3c76f8 322{
dc3c76f8
NC
323 GV *gv;
324
7918f24d
NC
325 PERL_ARGS_ASSERT_SOFTREF2XV;
326
dc3c76f8
NC
327 if (PL_op->op_private & HINT_STRICT_REFS) {
328 if (SvOK(sv))
fedf30e1 329 Perl_die(aTHX_ PL_no_symref_sv, sv,
bf3d870f 330 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
dc3c76f8
NC
331 else
332 Perl_die(aTHX_ PL_no_usym, what);
333 }
334 if (!SvOK(sv)) {
fd1d9b5c 335 if (
c8fe3bdf 336 PL_op->op_flags & OPf_REF
fd1d9b5c 337 )
dc3c76f8
NC
338 Perl_die(aTHX_ PL_no_usym, what);
339 if (ckWARN(WARN_UNINITIALIZED))
340 report_uninit(sv);
341 if (type != SVt_PV && GIMME_V == G_ARRAY) {
342 (*spp)--;
343 return NULL;
344 }
345 **spp = &PL_sv_undef;
346 return NULL;
347 }
348 if ((PL_op->op_flags & OPf_SPECIAL) &&
349 !(PL_op->op_flags & OPf_MOD))
350 {
77cb3b01 351 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
dc3c76f8
NC
352 {
353 **spp = &PL_sv_undef;
354 return NULL;
355 }
356 }
357 else {
77cb3b01 358 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
dc3c76f8
NC
359 }
360 return gv;
361}
362
79072805
LW
363PP(pp_rv2sv)
364{
20b7effb 365 dSP; dTOPss;
c445ea15 366 GV *gv = NULL;
79072805 367
9026059d 368 SvGETMAGIC(sv);
ed6116ce 369 if (SvROK(sv)) {
93d7320b
DM
370 if (SvAMAGIC(sv)) {
371 sv = amagic_deref_call(sv, to_sv_amg);
93d7320b 372 }
f5284f61 373
ed6116ce 374 sv = SvRV(sv);
69f00f67 375 if (SvTYPE(sv) >= SVt_PVAV)
cea2e8a9 376 DIE(aTHX_ "Not a SCALAR reference");
79072805
LW
377 }
378 else {
159b6efe 379 gv = MUTABLE_GV(sv);
748a9306 380
6e592b3a 381 if (!isGV_with_GP(gv)) {
dc3c76f8
NC
382 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
383 if (!gv)
384 RETURN;
463ee0b2 385 }
29c711a3 386 sv = GvSVn(gv);
a0d0e21e 387 }
533c011a 388 if (PL_op->op_flags & OPf_MOD) {
82d03984
RGS
389 if (PL_op->op_private & OPpLVAL_INTRO) {
390 if (cUNOP->op_first->op_type == OP_NULL)
159b6efe 391 sv = save_scalar(MUTABLE_GV(TOPs));
82d03984
RGS
392 else if (gv)
393 sv = save_scalar(gv);
394 else
f1f66076 395 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
82d03984 396 }
533c011a 397 else if (PL_op->op_private & OPpDEREF)
9026059d 398 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
79072805 399 }
a0d0e21e 400 SETs(sv);
79072805
LW
401 RETURN;
402}
403
404PP(pp_av2arylen)
405{
20b7effb 406 dSP;
502c6561 407 AV * const av = MUTABLE_AV(TOPs);
02d85cc3
EB
408 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
409 if (lvalue) {
8160c8f5
DM
410 SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
411 if (!*svp) {
412 *svp = newSV_type(SVt_PVMG);
413 sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
02d85cc3 414 }
8160c8f5 415 SETs(*svp);
02d85cc3 416 } else {
e1dccc0d 417 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
79072805 418 }
79072805
LW
419 RETURN;
420}
421
a0d0e21e
LW
422PP(pp_pos)
423{
27a8dde8 424 dSP; dTOPss;
8ec5e241 425
78f9721b 426 if (PL_op->op_flags & OPf_MOD || LVRET) {
d14578b8 427 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
16eb5365
FC
428 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
429 LvTYPE(ret) = '.';
430 LvTARG(ret) = SvREFCNT_inc_simple(sv);
27a8dde8 431 SETs(ret); /* no SvSETMAGIC */
a0d0e21e
LW
432 }
433 else {
96c2a8ff 434 const MAGIC * const mg = mg_find_mglob(sv);
6174b39a 435 if (mg && mg->mg_len != -1) {
2154eca7 436 dTARGET;
6174b39a 437 STRLEN i = mg->mg_len;
25fdce4a 438 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
6174b39a 439 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
27a8dde8
FC
440 SETu(i);
441 return NORMAL;
a0d0e21e 442 }
27a8dde8 443 SETs(&PL_sv_undef);
a0d0e21e 444 }
27a8dde8 445 return NORMAL;
a0d0e21e
LW
446}
447
79072805
LW
448PP(pp_rv2cv)
449{
20b7effb 450 dSP;
79072805 451 GV *gv;
1eced8f8 452 HV *stash_unused;
c445ea15 453 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
9da346da 454 ? GV_ADDMG
d14578b8
KW
455 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
456 == OPpMAY_RETURN_CONSTANT)
c445ea15
AL
457 ? GV_ADD|GV_NOEXPAND
458 : GV_ADD;
4633a7c4
LW
459 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
460 /* (But not in defined().) */
e26df76a 461
1eced8f8 462 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
5a20ba3d 463 if (cv) NOOP;
e26df76a 464 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
2eaf799e
FC
465 cv = SvTYPE(SvRV(gv)) == SVt_PVCV
466 ? MUTABLE_CV(SvRV(gv))
467 : MUTABLE_CV(gv);
e26df76a 468 }
07055b4c 469 else
ea726b52 470 cv = MUTABLE_CV(&PL_sv_undef);
ad64d0ec 471 SETs(MUTABLE_SV(cv));
3d79e3ee 472 return NORMAL;
79072805
LW
473}
474
c07a80fd
PP
475PP(pp_prototype)
476{
20b7effb 477 dSP;
c07a80fd
PP
478 CV *cv;
479 HV *stash;
480 GV *gv;
fabdb6c0 481 SV *ret = &PL_sv_undef;
c07a80fd 482
6954f42f 483 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
b6c543e3 484 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
e3f73d4e 485 const char * s = SvPVX_const(TOPs);
b6c543e3 486 if (strnEQ(s, "CORE::", 6)) {
be1b855b 487 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
a96df643 488 if (!code)
b17a0679
FC
489 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
490 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
4e338c21 491 {
b66130dd
FC
492 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
493 if (sv) ret = sv;
494 }
b8c38f0a 495 goto set;
b6c543e3
IZ
496 }
497 }
f2c0649b 498 cv = sv_2cv(TOPs, &stash, &gv, 0);
5f05dabc 499 if (cv && SvPOK(cv))
8fa6a409
FC
500 ret = newSVpvn_flags(
501 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
502 );
b6c543e3 503 set:
c07a80fd
PP
504 SETs(ret);
505 RETURN;
506}
507
a0d0e21e
LW
508PP(pp_anoncode)
509{
20b7effb 510 dSP;
ea726b52 511 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
a5f75d66 512 if (CvCLONE(cv))
ad64d0ec 513 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
5f05dabc 514 EXTEND(SP,1);
ad64d0ec 515 PUSHs(MUTABLE_SV(cv));
a0d0e21e
LW
516 RETURN;
517}
518
519PP(pp_srefgen)
79072805 520{
20b7effb 521 dSP;
71be2cbc 522 *SP = refto(*SP);
3ed34c76 523 return NORMAL;
8ec5e241 524}
a0d0e21e
LW
525
526PP(pp_refgen)
527{
20b7effb 528 dSP; dMARK;
82334630 529 if (GIMME_V != G_ARRAY) {
5f0b1d4e
GS
530 if (++MARK <= SP)
531 *MARK = *SP;
532 else
1d51ab6c
FC
533 {
534 MEXTEND(SP, 1);
3280af22 535 *MARK = &PL_sv_undef;
1d51ab6c 536 }
5f0b1d4e
GS
537 *MARK = refto(*MARK);
538 SP = MARK;
539 RETURN;
a0d0e21e 540 }
bbce6d69 541 EXTEND_MORTAL(SP - MARK);
71be2cbc
PP
542 while (++MARK <= SP)
543 *MARK = refto(*MARK);
a0d0e21e 544 RETURN;
79072805
LW
545}
546
76e3520e 547STATIC SV*
cea2e8a9 548S_refto(pTHX_ SV *sv)
71be2cbc
PP
549{
550 SV* rv;
551
7918f24d
NC
552 PERL_ARGS_ASSERT_REFTO;
553
71be2cbc
PP
554 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
555 if (LvTARGLEN(sv))
68dc0745
PP
556 vivify_defelem(sv);
557 if (!(sv = LvTARG(sv)))
3280af22 558 sv = &PL_sv_undef;
0dd88869 559 else
b37c2d43 560 SvREFCNT_inc_void_NN(sv);
71be2cbc 561 }
d8b46c1b 562 else if (SvTYPE(sv) == SVt_PVAV) {
502c6561
NC
563 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
564 av_reify(MUTABLE_AV(sv));
d8b46c1b 565 SvTEMP_off(sv);
b37c2d43 566 SvREFCNT_inc_void_NN(sv);
d8b46c1b 567 }
60779a30 568 else if (SvPADTMP(sv)) {
f2933f5f 569 sv = newSVsv(sv);
60779a30 570 }
71be2cbc
PP
571 else {
572 SvTEMP_off(sv);
b37c2d43 573 SvREFCNT_inc_void_NN(sv);
71be2cbc
PP
574 }
575 rv = sv_newmortal();
4df7f6af 576 sv_upgrade(rv, SVt_IV);
b162af07 577 SvRV_set(rv, sv);
71be2cbc
PP
578 SvROK_on(rv);
579 return rv;
580}
581
79072805
LW
582PP(pp_ref)
583{
3c1e67ac
DD
584 dSP;
585 SV * const sv = TOPs;
f12c7020 586
511ddbdf
FC
587 SvGETMAGIC(sv);
588 if (!SvROK(sv))
3c1e67ac
DD
589 SETs(&PL_sv_no);
590 else {
591 dTARGET;
592 SETs(TARG);
593 /* use the return value that is in a register, its the same as TARG */
594 TARG = sv_ref(TARG,SvRV(sv),TRUE);
595 SvSETMAGIC(TARG);
596 }
79072805 597
3c1e67ac 598 return NORMAL;
79072805
LW
599}
600
601PP(pp_bless)
602{
20b7effb 603 dSP;
463ee0b2 604 HV *stash;
79072805 605
463ee0b2 606 if (MAXARG == 1)
dcdfe746 607 {
c2f922f1 608 curstash:
11faa288 609 stash = CopSTASH(PL_curcop);
dcdfe746
FC
610 if (SvTYPE(stash) != SVt_PVHV)
611 Perl_croak(aTHX_ "Attempt to bless into a freed package");
612 }
7b8d334a 613 else {
1b6737cc 614 SV * const ssv = POPs;
7b8d334a 615 STRLEN len;
e1ec3a88 616 const char *ptr;
81689caa 617
c2f922f1 618 if (!ssv) goto curstash;
8d9dd4b9 619 SvGETMAGIC(ssv);
c7ea825d
FC
620 if (SvROK(ssv)) {
621 if (!SvAMAGIC(ssv)) {
622 frog:
81689caa 623 Perl_croak(aTHX_ "Attempt to bless into a reference");
c7ea825d
FC
624 }
625 /* SvAMAGIC is on here, but it only means potentially overloaded,
626 so after stringification: */
627 ptr = SvPV_nomg_const(ssv,len);
628 /* We need to check the flag again: */
629 if (!SvAMAGIC(ssv)) goto frog;
630 }
631 else ptr = SvPV_nomg_const(ssv,len);
a2a5de95
NC
632 if (len == 0)
633 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
634 "Explicit blessing to '' (assuming package main)");
e69c50fe 635 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
7b8d334a 636 }
a0d0e21e 637
5d3fdfeb 638 (void)sv_bless(TOPs, stash);
79072805
LW
639 RETURN;
640}
641
fb73857a
PP
642PP(pp_gelem)
643{
20b7effb 644 dSP;
b13b2135 645
1b6737cc 646 SV *sv = POPs;
a180b31a
BF
647 STRLEN len;
648 const char * const elem = SvPV_const(sv, len);
5695161e 649 GV * const gv = MUTABLE_GV(TOPs);
c445ea15 650 SV * tmpRef = NULL;
1b6737cc 651
c445ea15 652 sv = NULL;
c4ba80c3
NC
653 if (elem) {
654 /* elem will always be NUL terminated. */
1b6737cc 655 const char * const second_letter = elem + 1;
c4ba80c3
NC
656 switch (*elem) {
657 case 'A':
a180b31a 658 if (len == 5 && strEQ(second_letter, "RRAY"))
e14698d8 659 {
ad64d0ec 660 tmpRef = MUTABLE_SV(GvAV(gv));
e14698d8
FC
661 if (tmpRef && !AvREAL((const AV *)tmpRef)
662 && AvREIFY((const AV *)tmpRef))
663 av_reify(MUTABLE_AV(tmpRef));
664 }
c4ba80c3
NC
665 break;
666 case 'C':
a180b31a 667 if (len == 4 && strEQ(second_letter, "ODE"))
ad64d0ec 668 tmpRef = MUTABLE_SV(GvCVu(gv));
c4ba80c3
NC
669 break;
670 case 'F':
a180b31a 671 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
c4ba80c3
NC
672 /* finally deprecated in 5.8.0 */
673 deprecate("*glob{FILEHANDLE}");
ad64d0ec 674 tmpRef = MUTABLE_SV(GvIOp(gv));
c4ba80c3
NC
675 }
676 else
a180b31a 677 if (len == 6 && strEQ(second_letter, "ORMAT"))
ad64d0ec 678 tmpRef = MUTABLE_SV(GvFORM(gv));
c4ba80c3
NC
679 break;
680 case 'G':
a180b31a 681 if (len == 4 && strEQ(second_letter, "LOB"))
ad64d0ec 682 tmpRef = MUTABLE_SV(gv);
c4ba80c3
NC
683 break;
684 case 'H':
a180b31a 685 if (len == 4 && strEQ(second_letter, "ASH"))
ad64d0ec 686 tmpRef = MUTABLE_SV(GvHV(gv));
c4ba80c3
NC
687 break;
688 case 'I':
a180b31a 689 if (*second_letter == 'O' && !elem[2] && len == 2)
ad64d0ec 690 tmpRef = MUTABLE_SV(GvIOp(gv));
c4ba80c3
NC
691 break;
692 case 'N':
a180b31a 693 if (len == 4 && strEQ(second_letter, "AME"))
a663657d 694 sv = newSVhek(GvNAME_HEK(gv));
c4ba80c3
NC
695 break;
696 case 'P':
a180b31a 697 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
7fa3a4ab
NC
698 const HV * const stash = GvSTASH(gv);
699 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
396482e1 700 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
c4ba80c3
NC
701 }
702 break;
703 case 'S':
a180b31a 704 if (len == 6 && strEQ(second_letter, "CALAR"))
f9d52e31 705 tmpRef = GvSVn(gv);
c4ba80c3 706 break;
39b99f21 707 }
fb73857a 708 }
76e3520e
GS
709 if (tmpRef)
710 sv = newRV(tmpRef);
fb73857a
PP
711 if (sv)
712 sv_2mortal(sv);
713 else
3280af22 714 sv = &PL_sv_undef;
5695161e 715 SETs(sv);
fb73857a
PP
716 RETURN;
717}
718
a0d0e21e 719/* Pattern matching */
79072805 720
a0d0e21e 721PP(pp_study)
79072805 722{
add3e777 723 dSP; dTOPss;
a0d0e21e
LW
724 STRLEN len;
725
1fa930f2 726 (void)SvPV(sv, len);
bc9a5256 727 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
32f0ea87 728 /* Historically, study was skipped in these cases. */
add3e777
FC
729 SETs(&PL_sv_no);
730 return NORMAL;
a4f4e906
NC
731 }
732
a58a85fa 733 /* Make study a no-op. It's no longer useful and its existence
32f0ea87 734 complicates matters elsewhere. */
add3e777
FC
735 SETs(&PL_sv_yes);
736 return NORMAL;
79072805
LW
737}
738
b1c05ba5
DM
739
740/* also used for: pp_transr() */
741
a0d0e21e 742PP(pp_trans)
79072805 743{
6442877a 744 dSP;
a0d0e21e
LW
745 SV *sv;
746
533c011a 747 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 748 sv = POPs;
79072805 749 else {
a0d0e21e 750 EXTEND(SP,1);
f605e527 751 if (ARGTARG)
6442877a 752 sv = PAD_SV(ARGTARG);
f605e527
FC
753 else {
754 sv = DEFSV;
755 }
79072805 756 }
bb16bae8 757 if(PL_op->op_type == OP_TRANSR) {
290797f7
FC
758 STRLEN len;
759 const char * const pv = SvPV(sv,len);
760 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
bb16bae8 761 do_trans(newsv);
290797f7 762 PUSHs(newsv);
bb16bae8 763 }
5bbe7184 764 else {
bcb10b84
VP
765 I32 i = do_trans(sv);
766 mPUSHi(i);
5bbe7184 767 }
a0d0e21e 768 RETURN;
79072805
LW
769}
770
a0d0e21e 771/* Lvalue operators. */
79072805 772
f595e19f 773static size_t
81745e4e
NC
774S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
775{
81745e4e
NC
776 STRLEN len;
777 char *s;
f595e19f 778 size_t count = 0;
81745e4e
NC
779
780 PERL_ARGS_ASSERT_DO_CHOMP;
781
782 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
f595e19f 783 return 0;
81745e4e
NC
784 if (SvTYPE(sv) == SVt_PVAV) {
785 I32 i;
786 AV *const av = MUTABLE_AV(sv);
787 const I32 max = AvFILL(av);
788
789 for (i = 0; i <= max; i++) {
790 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
791 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
f595e19f 792 count += do_chomp(retval, sv, chomping);
81745e4e 793 }
f595e19f 794 return count;
81745e4e
NC
795 }
796 else if (SvTYPE(sv) == SVt_PVHV) {
797 HV* const hv = MUTABLE_HV(sv);
798 HE* entry;
799 (void)hv_iterinit(hv);
800 while ((entry = hv_iternext(hv)))
f595e19f
FC
801 count += do_chomp(retval, hv_iterval(hv,entry), chomping);
802 return count;
81745e4e
NC
803 }
804 else if (SvREADONLY(sv)) {
cb077ed2 805 Perl_croak_no_modify();
81745e4e
NC
806 }
807
47e13f24 808 if (IN_ENCODING) {
81745e4e
NC
809 if (!SvUTF8(sv)) {
810 /* XXX, here sv is utf8-ized as a side-effect!
811 If encoding.pm is used properly, almost string-generating
812 operations, including literal strings, chr(), input data, etc.
813 should have been utf8-ized already, right?
814 */
ad2de1b2 815 sv_recode_to_utf8(sv, _get_encoding());
81745e4e
NC
816 }
817 }
818
819 s = SvPV(sv, len);
820 if (chomping) {
81745e4e 821 if (s && len) {
997c424a
DD
822 char *temp_buffer = NULL;
823 SV *svrecode = NULL;
81745e4e
NC
824 s += --len;
825 if (RsPARA(PL_rs)) {
826 if (*s != '\n')
997c424a 827 goto nope_free_nothing;
f595e19f 828 ++count;
81745e4e
NC
829 while (len && s[-1] == '\n') {
830 --len;
831 --s;
f595e19f 832 ++count;
81745e4e
NC
833 }
834 }
835 else {
836 STRLEN rslen, rs_charlen;
837 const char *rsptr = SvPV_const(PL_rs, rslen);
838
839 rs_charlen = SvUTF8(PL_rs)
840 ? sv_len_utf8(PL_rs)
841 : rslen;
842
843 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
844 /* Assumption is that rs is shorter than the scalar. */
845 if (SvUTF8(PL_rs)) {
846 /* RS is utf8, scalar is 8 bit. */
847 bool is_utf8 = TRUE;
848 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
849 &rslen, &is_utf8);
850 if (is_utf8) {
997c424a
DD
851 /* Cannot downgrade, therefore cannot possibly match.
852 At this point, temp_buffer is not alloced, and
853 is the buffer inside PL_rs, so dont free it.
81745e4e
NC
854 */
855 assert (temp_buffer == rsptr);
997c424a 856 goto nope_free_sv;
81745e4e
NC
857 }
858 rsptr = temp_buffer;
859 }
47e13f24 860 else if (IN_ENCODING) {
81745e4e
NC
861 /* RS is 8 bit, encoding.pm is used.
862 * Do not recode PL_rs as a side-effect. */
863 svrecode = newSVpvn(rsptr, rslen);
ad2de1b2 864 sv_recode_to_utf8(svrecode, _get_encoding());
81745e4e
NC
865 rsptr = SvPV_const(svrecode, rslen);
866 rs_charlen = sv_len_utf8(svrecode);
867 }
868 else {
869 /* RS is 8 bit, scalar is utf8. */
870 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
871 rsptr = temp_buffer;
872 }
873 }
874 if (rslen == 1) {
875 if (*s != *rsptr)
997c424a 876 goto nope_free_all;
f595e19f 877 ++count;
81745e4e
NC
878 }
879 else {
880 if (len < rslen - 1)
997c424a 881 goto nope_free_all;
81745e4e
NC
882 len -= rslen - 1;
883 s -= rslen - 1;
884 if (memNE(s, rsptr, rslen))
997c424a 885 goto nope_free_all;
f595e19f 886 count += rs_charlen;
81745e4e
NC
887 }
888 }
3b7ded39 889 SvPV_force_nomg_nolen(sv);
81745e4e
NC
890 SvCUR_set(sv, len);
891 *SvEND(sv) = '\0';
892 SvNIOK_off(sv);
893 SvSETMAGIC(sv);
81745e4e 894
997c424a
DD
895 nope_free_all:
896 Safefree(temp_buffer);
897 nope_free_sv:
898 SvREFCNT_dec(svrecode);
899 nope_free_nothing: ;
900 }
81745e4e 901 } else {
f8c80a8e 902 if (len && (!SvPOK(sv) || SvIsCOW(sv)))
81745e4e
NC
903 s = SvPV_force_nomg(sv, len);
904 if (DO_UTF8(sv)) {
905 if (s && len) {
906 char * const send = s + len;
907 char * const start = s;
908 s = send - 1;
909 while (s > start && UTF8_IS_CONTINUATION(*s))
910 s--;
911 if (is_utf8_string((U8*)s, send - s)) {
912 sv_setpvn(retval, s, send - s);
913 *s = '\0';
914 SvCUR_set(sv, s - start);
915 SvNIOK_off(sv);
916 SvUTF8_on(retval);
917 }
918 }
919 else
920 sv_setpvs(retval, "");
921 }
922 else if (s && len) {
923 s += --len;
924 sv_setpvn(retval, s, 1);
925 *s = '\0';
926 SvCUR_set(sv, len);
927 SvUTF8_off(sv);
928 SvNIOK_off(sv);
929 }
930 else
931 sv_setpvs(retval, "");
932 SvSETMAGIC(sv);
933 }
f595e19f 934 return count;
81745e4e
NC
935}
936
b1c05ba5
DM
937
938/* also used for: pp_schomp() */
939
a0d0e21e
LW
940PP(pp_schop)
941{
20b7effb 942 dSP; dTARGET;
fa54efae
NC
943 const bool chomping = PL_op->op_type == OP_SCHOMP;
944
f595e19f 945 const size_t count = do_chomp(TARG, TOPs, chomping);
fa54efae 946 if (chomping)
f595e19f 947 sv_setiv(TARG, count);
a0d0e21e 948 SETTARG;
ee41d8c7 949 return NORMAL;
79072805
LW
950}
951
b1c05ba5
DM
952
953/* also used for: pp_chomp() */
954
a0d0e21e 955PP(pp_chop)
79072805 956{
20b7effb 957 dSP; dMARK; dTARGET; dORIGMARK;
fa54efae 958 const bool chomping = PL_op->op_type == OP_CHOMP;
f595e19f 959 size_t count = 0;
8ec5e241 960
20cf1f79 961 while (MARK < SP)
f595e19f
FC
962 count += do_chomp(TARG, *++MARK, chomping);
963 if (chomping)
964 sv_setiv(TARG, count);
20cf1f79
NC
965 SP = ORIGMARK;
966 XPUSHTARG;
a0d0e21e 967 RETURN;
79072805
LW
968}
969
a0d0e21e
LW
970PP(pp_undef)
971{
20b7effb 972 dSP;
a0d0e21e
LW
973 SV *sv;
974
533c011a 975 if (!PL_op->op_private) {
774d564b 976 EXTEND(SP, 1);
a0d0e21e 977 RETPUSHUNDEF;
774d564b 978 }
79072805 979
821f14b0 980 sv = TOPs;
a0d0e21e 981 if (!sv)
821f14b0
FC
982 {
983 SETs(&PL_sv_undef);
984 return NORMAL;
985 }
85e6fe83 986
4dda930b
FC
987 if (SvTHINKFIRST(sv))
988 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
85e6fe83 989
a0d0e21e
LW
990 switch (SvTYPE(sv)) {
991 case SVt_NULL:
992 break;
993 case SVt_PVAV:
60edcf09 994 av_undef(MUTABLE_AV(sv));
a0d0e21e
LW
995 break;
996 case SVt_PVHV:
60edcf09 997 hv_undef(MUTABLE_HV(sv));
a0d0e21e
LW
998 break;
999 case SVt_PVCV:
a2a5de95 1000 if (cv_const_sv((const CV *)sv))
714cd18f
BF
1001 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1002 "Constant subroutine %"SVf" undefined",
1003 SVfARG(CvANON((const CV *)sv)
1004 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
bdbfc51a
FC
1005 : sv_2mortal(newSVhek(
1006 CvNAMED(sv)
1007 ? CvNAME_HEK((CV *)sv)
1008 : GvENAME_HEK(CvGV((const CV *)sv))
1009 ))
1010 ));
5f66b61c 1011 /* FALLTHROUGH */
9607fc9c 1012 case SVt_PVFM:
6fc92669 1013 /* let user-undef'd sub keep its identity */
b7acb0a3 1014 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
a0d0e21e 1015 break;
8e07c86e 1016 case SVt_PVGV:
bc1df6c2
FC
1017 assert(isGV_with_GP(sv));
1018 assert(!SvFAKE(sv));
1019 {
20408e3c 1020 GP *gp;
dd69841b
BB
1021 HV *stash;
1022
dd69841b 1023 /* undef *Pkg::meth_name ... */
e530fb81
FC
1024 bool method_changed
1025 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1026 && HvENAME_get(stash);
1027 /* undef *Foo:: */
1028 if((stash = GvHV((const GV *)sv))) {
1029 if(HvENAME_get(stash))
1030 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1031 else stash = NULL;
1032 }
dd69841b 1033
795eb8c8 1034 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
159b6efe 1035 gp_free(MUTABLE_GV(sv));
a02a5408 1036 Newxz(gp, 1, GP);
c43ae56f 1037 GvGP_set(sv, gp_ref(gp));
2e3295e3 1038#ifndef PERL_DONT_CREATE_GVSV
561b68a9 1039 GvSV(sv) = newSV(0);
2e3295e3 1040#endif
57843af0 1041 GvLINE(sv) = CopLINE(PL_curcop);
159b6efe 1042 GvEGV(sv) = MUTABLE_GV(sv);
20408e3c 1043 GvMULTI_on(sv);
e530fb81
FC
1044
1045 if(stash)
afdbe55d 1046 mro_package_moved(NULL, stash, (const GV *)sv, 0);
e530fb81
FC
1047 stash = NULL;
1048 /* undef *Foo::ISA */
1049 if( strEQ(GvNAME((const GV *)sv), "ISA")
1050 && (stash = GvSTASH((const GV *)sv))
1051 && (method_changed || HvENAME(stash)) )
1052 mro_isa_changed_in(stash);
1053 else if(method_changed)
1054 mro_method_changed_in(
da9043f5 1055 GvSTASH((const GV *)sv)
e530fb81
FC
1056 );
1057
6e592b3a 1058 break;
20408e3c 1059 }
a0d0e21e 1060 default:
b15aece3 1061 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
8bd4d4c5 1062 SvPV_free(sv);
c445ea15 1063 SvPV_set(sv, NULL);
4633a7c4 1064 SvLEN_set(sv, 0);
a0d0e21e 1065 }
0c34ef67 1066 SvOK_off(sv);
4633a7c4 1067 SvSETMAGIC(sv);
79072805 1068 }
a0d0e21e 1069
821f14b0
FC
1070 SETs(&PL_sv_undef);
1071 return NORMAL;
79072805
LW
1072}
1073
b1c05ba5 1074
20e96431 1075/* common "slow" code for pp_postinc and pp_postdec */
b1c05ba5 1076
20e96431
DM
1077static OP *
1078S_postincdec_common(pTHX_ SV *sv, SV *targ)
a0d0e21e 1079{
20e96431 1080 dSP;
c22c99bc
FC
1081 const bool inc =
1082 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
20e96431
DM
1083
1084 if (SvROK(sv))
7dcb9b98 1085 TARG = sv_newmortal();
20e96431
DM
1086 sv_setsv(TARG, sv);
1087 if (inc)
1088 sv_inc_nomg(sv);
1089 else
1090 sv_dec_nomg(sv);
1091 SvSETMAGIC(sv);
1e54a23f 1092 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
c22c99bc 1093 if (inc && !SvOK(TARG))
a0d0e21e 1094 sv_setiv(TARG, 0);
e87de4ab 1095 SETTARG;
a0d0e21e
LW
1096 return NORMAL;
1097}
79072805 1098
20e96431
DM
1099
1100/* also used for: pp_i_postinc() */
1101
1102PP(pp_postinc)
1103{
1104 dSP; dTARGET;
1105 SV *sv = TOPs;
1106
1107 /* special-case sv being a simple integer */
1108 if (LIKELY(((sv->sv_flags &
1109 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1110 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1111 == SVf_IOK))
1112 && SvIVX(sv) != IV_MAX)
1113 {
1114 IV iv = SvIVX(sv);
1115 SvIV_set(sv, iv + 1);
1116 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1117 SETs(TARG);
1118 return NORMAL;
1119 }
1120
1121 return S_postincdec_common(aTHX_ sv, TARG);
1122}
1123
1124
1125/* also used for: pp_i_postdec() */
1126
1127PP(pp_postdec)
1128{
1129 dSP; dTARGET;
1130 SV *sv = TOPs;
1131
1132 /* special-case sv being a simple integer */
1133 if (LIKELY(((sv->sv_flags &
1134 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1135 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1136 == SVf_IOK))
1137 && SvIVX(sv) != IV_MIN)
1138 {
1139 IV iv = SvIVX(sv);
1140 SvIV_set(sv, iv - 1);
1141 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1142 SETs(TARG);
1143 return NORMAL;
1144 }
1145
1146 return S_postincdec_common(aTHX_ sv, TARG);
1147}
1148
1149
a0d0e21e
LW
1150/* Ordinary operators. */
1151
1152PP(pp_pow)
1153{
20b7effb 1154 dSP; dATARGET; SV *svl, *svr;
58d76dfd 1155#ifdef PERL_PRESERVE_IVUV
52a96ae6
HS
1156 bool is_int = 0;
1157#endif
6f1401dc
DM
1158 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1159 svr = TOPs;
1160 svl = TOPm1s;
52a96ae6
HS
1161#ifdef PERL_PRESERVE_IVUV
1162 /* For integer to integer power, we do the calculation by hand wherever
1163 we're sure it is safe; otherwise we call pow() and try to convert to
1164 integer afterwards. */
01f91bf2 1165 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
900658e3
PF
1166 UV power;
1167 bool baseuok;
1168 UV baseuv;
1169
800401ee
JH
1170 if (SvUOK(svr)) {
1171 power = SvUVX(svr);
900658e3 1172 } else {
800401ee 1173 const IV iv = SvIVX(svr);
900658e3
PF
1174 if (iv >= 0) {
1175 power = iv;
1176 } else {
1177 goto float_it; /* Can't do negative powers this way. */
1178 }
1179 }
1180
800401ee 1181 baseuok = SvUOK(svl);
900658e3 1182 if (baseuok) {
800401ee 1183 baseuv = SvUVX(svl);
900658e3 1184 } else {
800401ee 1185 const IV iv = SvIVX(svl);
900658e3
PF
1186 if (iv >= 0) {
1187 baseuv = iv;
1188 baseuok = TRUE; /* effectively it's a UV now */
1189 } else {
1190 baseuv = -iv; /* abs, baseuok == false records sign */
1191 }
1192 }
52a96ae6
HS
1193 /* now we have integer ** positive integer. */
1194 is_int = 1;
1195
1196 /* foo & (foo - 1) is zero only for a power of 2. */
58d76dfd 1197 if (!(baseuv & (baseuv - 1))) {
52a96ae6 1198 /* We are raising power-of-2 to a positive integer.
58d76dfd
JH
1199 The logic here will work for any base (even non-integer
1200 bases) but it can be less accurate than
1201 pow (base,power) or exp (power * log (base)) when the
1202 intermediate values start to spill out of the mantissa.
1203 With powers of 2 we know this can't happen.
1204 And powers of 2 are the favourite thing for perl
1205 programmers to notice ** not doing what they mean. */
1206 NV result = 1.0;
1207 NV base = baseuok ? baseuv : -(NV)baseuv;
900658e3
PF
1208
1209 if (power & 1) {
1210 result *= base;
1211 }
1212 while (power >>= 1) {
1213 base *= base;
1214 if (power & 1) {
1215 result *= base;
1216 }
1217 }
58d76dfd
JH
1218 SP--;
1219 SETn( result );
6f1401dc 1220 SvIV_please_nomg(svr);
58d76dfd 1221 RETURN;
52a96ae6 1222 } else {
eb578fdb
KW
1223 unsigned int highbit = 8 * sizeof(UV);
1224 unsigned int diff = 8 * sizeof(UV);
900658e3
PF
1225 while (diff >>= 1) {
1226 highbit -= diff;
1227 if (baseuv >> highbit) {
1228 highbit += diff;
1229 }
52a96ae6
HS
1230 }
1231 /* we now have baseuv < 2 ** highbit */
1232 if (power * highbit <= 8 * sizeof(UV)) {
1233 /* result will definitely fit in UV, so use UV math
1234 on same algorithm as above */
eb578fdb
KW
1235 UV result = 1;
1236 UV base = baseuv;
f2338a2e 1237 const bool odd_power = cBOOL(power & 1);
900658e3
PF
1238 if (odd_power) {
1239 result *= base;
1240 }
1241 while (power >>= 1) {
1242 base *= base;
1243 if (power & 1) {
52a96ae6 1244 result *= base;
52a96ae6
HS
1245 }
1246 }
1247 SP--;
0615a994 1248 if (baseuok || !odd_power)
52a96ae6
HS
1249 /* answer is positive */
1250 SETu( result );
1251 else if (result <= (UV)IV_MAX)
1252 /* answer negative, fits in IV */
1253 SETi( -(IV)result );
1254 else if (result == (UV)IV_MIN)
1255 /* 2's complement assumption: special case IV_MIN */
1256 SETi( IV_MIN );
1257 else
1258 /* answer negative, doesn't fit */
1259 SETn( -(NV)result );
1260 RETURN;
1261 }
1262 }
58d76dfd 1263 }
52a96ae6 1264 float_it:
58d76dfd 1265#endif
a0d0e21e 1266 {
6f1401dc
DM
1267 NV right = SvNV_nomg(svr);
1268 NV left = SvNV_nomg(svl);
4efa5a16 1269 (void)POPs;
3aaeb624
JA
1270
1271#if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1272 /*
1273 We are building perl with long double support and are on an AIX OS
1274 afflicted with a powl() function that wrongly returns NaNQ for any
1275 negative base. This was reported to IBM as PMR #23047-379 on
1276 03/06/2006. The problem exists in at least the following versions
1277 of AIX and the libm fileset, and no doubt others as well:
1278
1279 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1280 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1281 AIX 5.2.0 bos.adt.libm 5.2.0.85
1282
1283 So, until IBM fixes powl(), we provide the following workaround to
1284 handle the problem ourselves. Our logic is as follows: for
1285 negative bases (left), we use fmod(right, 2) to check if the
1286 exponent is an odd or even integer:
1287
1288 - if odd, powl(left, right) == -powl(-left, right)
1289 - if even, powl(left, right) == powl(-left, right)
1290
1291 If the exponent is not an integer, the result is rightly NaNQ, so
1292 we just return that (as NV_NAN).
1293 */
1294
1295 if (left < 0.0) {
1296 NV mod2 = Perl_fmod( right, 2.0 );
1297 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1298 SETn( -Perl_pow( -left, right) );
1299 } else if (mod2 == 0.0) { /* even integer */
1300 SETn( Perl_pow( -left, right) );
1301 } else { /* fractional power */
1302 SETn( NV_NAN );
1303 }
1304 } else {
1305 SETn( Perl_pow( left, right) );
1306 }
1307#else
52a96ae6 1308 SETn( Perl_pow( left, right) );
3aaeb624
JA
1309#endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1310
52a96ae6
HS
1311#ifdef PERL_PRESERVE_IVUV
1312 if (is_int)
6f1401dc 1313 SvIV_please_nomg(svr);
52a96ae6
HS
1314#endif
1315 RETURN;
93a17b20 1316 }
a0d0e21e
LW
1317}
1318
1319PP(pp_multiply)
1320{
20b7effb 1321 dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM
1322 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1323 svr = TOPs;
1324 svl = TOPm1s;
230ee21f 1325
28e5dec8 1326#ifdef PERL_PRESERVE_IVUV
230ee21f
DM
1327
1328 /* special-case some simple common cases */
1329 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1330 IV il, ir;
1331 U32 flags = (svl->sv_flags & svr->sv_flags);
1332 if (flags & SVf_IOK) {
1333 /* both args are simple IVs */
1334 UV topl, topr;
1335 il = SvIVX(svl);
1336 ir = SvIVX(svr);
1337 do_iv:
1338 topl = ((UV)il) >> (UVSIZE * 4 - 1);
1339 topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1340
1341 /* if both are in a range that can't under/overflow, do a
1342 * simple integer multiply: if the top halves(*) of both numbers
1343 * are 00...00 or 11...11, then it's safe.
1344 * (*) for 32-bits, the "top half" is the top 17 bits,
1345 * for 64-bits, its 33 bits */
1346 if (!(
1347 ((topl+1) | (topr+1))
1348 & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1349 )) {
1350 SP--;
1351 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1352 SETs(TARG);
1353 RETURN;
1354 }
1355 goto generic;
1356 }
1357 else if (flags & SVf_NOK) {
1358 /* both args are NVs */
1359 NV nl = SvNVX(svl);
1360 NV nr = SvNVX(svr);
1361 NV result;
1362
1363 il = (IV)nl;
1364 ir = (IV)nr;
1365 if (nl == (NV)il && nr == (NV)ir)
1366 /* nothing was lost by converting to IVs */
1367 goto do_iv;
1368 SP--;
1369 result = nl * nr;
1370# if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN && NVSIZE == 16
1371 if (Perl_isinf(result)) {
1372 Zero((U8*)&result + 8, 8, U8);
1373 }
1374# endif
1375 TARGn(result, 0); /* args not GMG, so can't be tainted */
1376 SETs(TARG);
1377 RETURN;
1378 }
1379 }
1380
1381 generic:
1382
01f91bf2 1383 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
1384 /* Unless the left argument is integer in range we are going to have to
1385 use NV maths. Hence only attempt to coerce the right argument if
1386 we know the left is integer. */
1387 /* Left operand is defined, so is it IV? */
01f91bf2 1388 if (SvIV_please_nomg(svl)) {
800401ee
JH
1389 bool auvok = SvUOK(svl);
1390 bool buvok = SvUOK(svr);
28e5dec8
JH
1391 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1392 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1393 UV alow;
1394 UV ahigh;
1395 UV blow;
1396 UV bhigh;
1397
1398 if (auvok) {
800401ee 1399 alow = SvUVX(svl);
28e5dec8 1400 } else {
800401ee 1401 const IV aiv = SvIVX(svl);
28e5dec8
JH
1402 if (aiv >= 0) {
1403 alow = aiv;
1404 auvok = TRUE; /* effectively it's a UV now */
1405 } else {
53e2bfb7
DM
1406 /* abs, auvok == false records sign */
1407 alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
28e5dec8
JH
1408 }
1409 }
1410 if (buvok) {
800401ee 1411 blow = SvUVX(svr);
28e5dec8 1412 } else {
800401ee 1413 const IV biv = SvIVX(svr);
28e5dec8
JH
1414 if (biv >= 0) {
1415 blow = biv;
1416 buvok = TRUE; /* effectively it's a UV now */
1417 } else {
53e2bfb7
DM
1418 /* abs, buvok == false records sign */
1419 blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
28e5dec8
JH
1420 }
1421 }
1422
1423 /* If this does sign extension on unsigned it's time for plan B */
1424 ahigh = alow >> (4 * sizeof (UV));
1425 alow &= botmask;
1426 bhigh = blow >> (4 * sizeof (UV));
1427 blow &= botmask;
1428 if (ahigh && bhigh) {
6f207bd3 1429 NOOP;
28e5dec8
JH
1430 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1431 which is overflow. Drop to NVs below. */
1432 } else if (!ahigh && !bhigh) {
1433 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1434 so the unsigned multiply cannot overflow. */
c445ea15 1435 const UV product = alow * blow;
28e5dec8
JH
1436 if (auvok == buvok) {
1437 /* -ve * -ve or +ve * +ve gives a +ve result. */
1438 SP--;
1439 SETu( product );
1440 RETURN;
1441 } else if (product <= (UV)IV_MIN) {
1442 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1443 /* -ve result, which could overflow an IV */
1444 SP--;
02b08bbc
DM
1445 /* can't negate IV_MIN, but there are aren't two
1446 * integers such that !ahigh && !bhigh, where the
1447 * product equals 0x800....000 */
1448 assert(product != (UV)IV_MIN);
25716404 1449 SETi( -(IV)product );
28e5dec8
JH
1450 RETURN;
1451 } /* else drop to NVs below. */
1452 } else {
1453 /* One operand is large, 1 small */
1454 UV product_middle;
1455 if (bhigh) {
1456 /* swap the operands */
1457 ahigh = bhigh;
1458 bhigh = blow; /* bhigh now the temp var for the swap */
1459 blow = alow;
1460 alow = bhigh;
1461 }
1462 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1463 multiplies can't overflow. shift can, add can, -ve can. */
1464 product_middle = ahigh * blow;
1465 if (!(product_middle & topmask)) {
1466 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1467 UV product_low;
1468 product_middle <<= (4 * sizeof (UV));
1469 product_low = alow * blow;
1470
1471 /* as for pp_add, UV + something mustn't get smaller.
1472 IIRC ANSI mandates this wrapping *behaviour* for
1473 unsigned whatever the actual representation*/
1474 product_low += product_middle;
1475 if (product_low >= product_middle) {
1476 /* didn't overflow */
1477 if (auvok == buvok) {
1478 /* -ve * -ve or +ve * +ve gives a +ve result. */
1479 SP--;
1480 SETu( product_low );
1481 RETURN;
1482 } else if (product_low <= (UV)IV_MIN) {
1483 /* 2s complement assumption again */
1484 /* -ve result, which could overflow an IV */
1485 SP--;
53e2bfb7
DM
1486 SETi(product_low == (UV)IV_MIN
1487 ? IV_MIN : -(IV)product_low);
28e5dec8
JH
1488 RETURN;
1489 } /* else drop to NVs below. */
1490 }
1491 } /* product_middle too large */
1492 } /* ahigh && bhigh */
800401ee
JH
1493 } /* SvIOK(svl) */
1494 } /* SvIOK(svr) */
28e5dec8 1495#endif
a0d0e21e 1496 {
6f1401dc
DM
1497 NV right = SvNV_nomg(svr);
1498 NV left = SvNV_nomg(svl);
230ee21f
DM
1499 NV result = left * right;
1500
4efa5a16 1501 (void)POPs;
3ec400f5 1502#if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN && NVSIZE == 16
230ee21f
DM
1503 if (Perl_isinf(result)) {
1504 Zero((U8*)&result + 8, 8, U8);
3ec400f5 1505 }
3ec400f5 1506#endif
230ee21f 1507 SETn(result);
a0d0e21e 1508 RETURN;
79072805 1509 }
a0d0e21e
LW
1510}
1511
1512PP(pp_divide)
1513{
20b7effb 1514 dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM
1515 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1516 svr = TOPs;
1517 svl = TOPm1s;
5479d192 1518 /* Only try to do UV divide first
68795e93 1519 if ((SLOPPYDIVIDE is true) or
5479d192
NC
1520 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1521 to preserve))
1522 The assumption is that it is better to use floating point divide
1523 whenever possible, only doing integer divide first if we can't be sure.
1524 If NV_PRESERVES_UV is true then we know at compile time that no UV
1525 can be too large to preserve, so don't need to compile the code to
1526 test the size of UVs. */
1527
a0d0e21e 1528#ifdef SLOPPYDIVIDE
5479d192
NC
1529# define PERL_TRY_UV_DIVIDE
1530 /* ensure that 20./5. == 4. */
a0d0e21e 1531#else
5479d192
NC
1532# ifdef PERL_PRESERVE_IVUV
1533# ifndef NV_PRESERVES_UV
1534# define PERL_TRY_UV_DIVIDE
1535# endif
1536# endif
a0d0e21e 1537#endif
5479d192
NC
1538
1539#ifdef PERL_TRY_UV_DIVIDE
01f91bf2 1540 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
800401ee
JH
1541 bool left_non_neg = SvUOK(svl);
1542 bool right_non_neg = SvUOK(svr);
5479d192
NC
1543 UV left;
1544 UV right;
1545
1546 if (right_non_neg) {
800401ee 1547 right = SvUVX(svr);
5479d192
NC
1548 }
1549 else {
800401ee 1550 const IV biv = SvIVX(svr);
5479d192
NC
1551 if (biv >= 0) {
1552 right = biv;
1553 right_non_neg = TRUE; /* effectively it's a UV now */
1554 }
1555 else {
02b08bbc 1556 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
5479d192
NC
1557 }
1558 }
1559 /* historically undef()/0 gives a "Use of uninitialized value"
1560 warning before dieing, hence this test goes here.
1561 If it were immediately before the second SvIV_please, then
1562 DIE() would be invoked before left was even inspected, so
486ec47a 1563 no inspection would give no warning. */
5479d192
NC
1564 if (right == 0)
1565 DIE(aTHX_ "Illegal division by zero");
1566
1567 if (left_non_neg) {
800401ee 1568 left = SvUVX(svl);
5479d192
NC
1569 }
1570 else {
800401ee 1571 const IV aiv = SvIVX(svl);
5479d192
NC
1572 if (aiv >= 0) {
1573 left = aiv;
1574 left_non_neg = TRUE; /* effectively it's a UV now */
1575 }
1576 else {
02b08bbc 1577 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
5479d192
NC
1578 }
1579 }
1580
1581 if (left >= right
1582#ifdef SLOPPYDIVIDE
1583 /* For sloppy divide we always attempt integer division. */
1584#else
1585 /* Otherwise we only attempt it if either or both operands
1586 would not be preserved by an NV. If both fit in NVs
0c2ee62a
NC
1587 we fall through to the NV divide code below. However,
1588 as left >= right to ensure integer result here, we know that
1589 we can skip the test on the right operand - right big
1590 enough not to be preserved can't get here unless left is
1591 also too big. */
1592
1593 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
5479d192
NC
1594#endif
1595 ) {
1596 /* Integer division can't overflow, but it can be imprecise. */
1b6737cc 1597 const UV result = left / right;
5479d192
NC
1598 if (result * right == left) {
1599 SP--; /* result is valid */
1600 if (left_non_neg == right_non_neg) {
1601 /* signs identical, result is positive. */
1602 SETu( result );
1603 RETURN;
1604 }
1605 /* 2s complement assumption */
1606 if (result <= (UV)IV_MIN)
02b08bbc 1607 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
5479d192
NC
1608 else {
1609 /* It's exact but too negative for IV. */
1610 SETn( -(NV)result );
1611 }
1612 RETURN;
1613 } /* tried integer divide but it was not an integer result */
32fdb065 1614 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
01f91bf2 1615 } /* one operand wasn't SvIOK */
5479d192
NC
1616#endif /* PERL_TRY_UV_DIVIDE */
1617 {
6f1401dc
DM
1618 NV right = SvNV_nomg(svr);
1619 NV left = SvNV_nomg(svl);
4efa5a16 1620 (void)POPs;(void)POPs;
ebc6a117
PD
1621#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1622 if (! Perl_isnan(right) && right == 0.0)
1623#else
659c4b96 1624 if (right == 0.0)
ebc6a117 1625#endif
5479d192
NC
1626 DIE(aTHX_ "Illegal division by zero");
1627 PUSHn( left / right );
1628 RETURN;
79072805 1629 }
a0d0e21e
LW
1630}
1631
1632PP(pp_modulo)
1633{
20b7effb 1634 dSP; dATARGET;
6f1401dc 1635 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
a0d0e21e 1636 {
9c5ffd7c
JH
1637 UV left = 0;
1638 UV right = 0;
dc656993
JH
1639 bool left_neg = FALSE;
1640 bool right_neg = FALSE;
e2c88acc
NC
1641 bool use_double = FALSE;
1642 bool dright_valid = FALSE;
9c5ffd7c
JH
1643 NV dright = 0.0;
1644 NV dleft = 0.0;
6f1401dc
DM
1645 SV * const svr = TOPs;
1646 SV * const svl = TOPm1s;
01f91bf2 1647 if (SvIV_please_nomg(svr)) {
800401ee 1648 right_neg = !SvUOK(svr);
e2c88acc 1649 if (!right_neg) {
800401ee 1650 right = SvUVX(svr);
e2c88acc 1651 } else {
800401ee 1652 const IV biv = SvIVX(svr);
e2c88acc
NC
1653 if (biv >= 0) {
1654 right = biv;
1655 right_neg = FALSE; /* effectively it's a UV now */
1656 } else {
02b08bbc 1657 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
e2c88acc
NC
1658 }
1659 }
1660 }
1661 else {
6f1401dc 1662 dright = SvNV_nomg(svr);
787eafbd
IZ
1663 right_neg = dright < 0;
1664 if (right_neg)
1665 dright = -dright;
e2c88acc
NC
1666 if (dright < UV_MAX_P1) {
1667 right = U_V(dright);
1668 dright_valid = TRUE; /* In case we need to use double below. */
1669 } else {
1670 use_double = TRUE;
1671 }
787eafbd 1672 }
a0d0e21e 1673
e2c88acc
NC
1674 /* At this point use_double is only true if right is out of range for
1675 a UV. In range NV has been rounded down to nearest UV and
1676 use_double false. */
01f91bf2 1677 if (!use_double && SvIV_please_nomg(svl)) {
800401ee 1678 left_neg = !SvUOK(svl);
e2c88acc 1679 if (!left_neg) {
800401ee 1680 left = SvUVX(svl);
e2c88acc 1681 } else {
800401ee 1682 const IV aiv = SvIVX(svl);
e2c88acc
NC
1683 if (aiv >= 0) {
1684 left = aiv;
1685 left_neg = FALSE; /* effectively it's a UV now */
1686 } else {
02b08bbc 1687 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
e2c88acc
NC
1688 }
1689 }
e2c88acc 1690 }
787eafbd 1691 else {
6f1401dc 1692 dleft = SvNV_nomg(svl);
787eafbd
IZ
1693 left_neg = dleft < 0;
1694 if (left_neg)
1695 dleft = -dleft;
68dc0745 1696
e2c88acc
NC
1697 /* This should be exactly the 5.6 behaviour - if left and right are
1698 both in range for UV then use U_V() rather than floor. */
1699 if (!use_double) {
1700 if (dleft < UV_MAX_P1) {
1701 /* right was in range, so is dleft, so use UVs not double.
1702 */
1703 left = U_V(dleft);
1704 }
1705 /* left is out of range for UV, right was in range, so promote
1706 right (back) to double. */
1707 else {
1708 /* The +0.5 is used in 5.6 even though it is not strictly
1709 consistent with the implicit +0 floor in the U_V()
1710 inside the #if 1. */
1711 dleft = Perl_floor(dleft + 0.5);
1712 use_double = TRUE;
1713 if (dright_valid)
1714 dright = Perl_floor(dright + 0.5);
1715 else
1716 dright = right;
1717 }
1718 }
1719 }
6f1401dc 1720 sp -= 2;
787eafbd 1721 if (use_double) {
65202027 1722 NV dans;
787eafbd 1723
659c4b96 1724 if (!dright)
cea2e8a9 1725 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1726
65202027 1727 dans = Perl_fmod(dleft, dright);
659c4b96 1728 if ((left_neg != right_neg) && dans)
787eafbd
IZ
1729 dans = dright - dans;
1730 if (right_neg)
1731 dans = -dans;
1732 sv_setnv(TARG, dans);
1733 }
1734 else {
1735 UV ans;
1736
787eafbd 1737 if (!right)
cea2e8a9 1738 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ
1739
1740 ans = left % right;
1741 if ((left_neg != right_neg) && ans)
1742 ans = right - ans;
1743 if (right_neg) {
1744 /* XXX may warn: unary minus operator applied to unsigned type */
1745 /* could change -foo to be (~foo)+1 instead */
1746 if (ans <= ~((UV)IV_MAX)+1)
1747 sv_setiv(TARG, ~ans+1);
1748 else
65202027 1749 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ
1750 }
1751 else
1752 sv_setuv(TARG, ans);
1753 }
1754 PUSHTARG;
1755 RETURN;
79072805 1756 }
a0d0e21e 1757}
79072805 1758
a0d0e21e
LW
1759PP(pp_repeat)
1760{
20b7effb 1761 dSP; dATARGET;
eb578fdb 1762 IV count;
6f1401dc 1763 SV *sv;
02a7a248 1764 bool infnan = FALSE;
6f1401dc 1765
82334630 1766 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
6f1401dc
DM
1767 /* TODO: think of some way of doing list-repeat overloading ??? */
1768 sv = POPs;
1769 SvGETMAGIC(sv);
1770 }
1771 else {
3a100dab
FC
1772 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1773 /* The parser saw this as a list repeat, and there
1774 are probably several items on the stack. But we're
1775 in scalar/void context, and there's no pp_list to save us
1776 now. So drop the rest of the items -- robin@kitsite.com
1777 */
1778 dMARK;
1779 if (MARK + 1 < SP) {
1780 MARK[1] = TOPm1s;
1781 MARK[2] = TOPs;
1782 }
1783 else {
1784 dTOPss;
1785 ASSUME(MARK + 1 == SP);
1786 XPUSHs(sv);
1787 MARK[1] = &PL_sv_undef;
1788 }
1789 SP = MARK + 2;
1790 }
6f1401dc
DM
1791 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1792 sv = POPs;
1793 }
1794
2b573ace
JH
1795 if (SvIOKp(sv)) {
1796 if (SvUOK(sv)) {
6f1401dc 1797 const UV uv = SvUV_nomg(sv);
2b573ace
JH
1798 if (uv > IV_MAX)
1799 count = IV_MAX; /* The best we can do? */
1800 else
1801 count = uv;
1802 } else {
b3211734 1803 count = SvIV_nomg(sv);
2b573ace
JH
1804 }
1805 }
1806 else if (SvNOKp(sv)) {
02a7a248
JH
1807 const NV nv = SvNV_nomg(sv);
1808 infnan = Perl_isinfnan(nv);
1809 if (UNLIKELY(infnan)) {
1810 count = 0;
1811 } else {
1812 if (nv < 0.0)
1813 count = -1; /* An arbitrary negative integer */
1814 else
1815 count = (IV)nv;
1816 }
2b573ace
JH
1817 }
1818 else
02a7a248 1819 count = SvIV_nomg(sv);
6f1401dc 1820
02a7a248
JH
1821 if (infnan) {
1822 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1823 "Non-finite repeat count does nothing");
1824 } else if (count < 0) {
b3211734
KW
1825 count = 0;
1826 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
02a7a248 1827 "Negative repeat count does nothing");
b3211734
KW
1828 }
1829
82334630 1830 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e 1831 dMARK;
052a7c76 1832 const SSize_t items = SP - MARK;
da9e430b 1833 const U8 mod = PL_op->op_flags & OPf_MOD;
79072805 1834
a0d0e21e 1835 if (count > 1) {
052a7c76 1836 SSize_t max;
b3b27d01 1837
052a7c76
DM
1838 if ( items > SSize_t_MAX / count /* max would overflow */
1839 /* repeatcpy would overflow */
1840 || items > I32_MAX / (I32)sizeof(SV *)
b3b27d01
DM
1841 )
1842 Perl_croak(aTHX_ "%s","Out of memory during list extend");
1843 max = items * count;
1844 MEXTEND(MARK, max);
1845
a0d0e21e 1846 while (SP > MARK) {
60779a30
DM
1847 if (*SP) {
1848 if (mod && SvPADTMP(*SP)) {
da9e430b 1849 *SP = sv_mortalcopy(*SP);
60779a30 1850 }
976c8a39 1851 SvTEMP_off((*SP));
da9e430b 1852 }
a0d0e21e 1853 SP--;
79072805 1854 }
a0d0e21e
LW
1855 MARK++;
1856 repeatcpy((char*)(MARK + items), (char*)MARK,
ad64d0ec 1857 items * sizeof(const SV *), count - 1);
a0d0e21e 1858 SP += max;
79072805 1859 }
a0d0e21e 1860 else if (count <= 0)
052a7c76 1861 SP = MARK;
79072805 1862 }
a0d0e21e 1863 else { /* Note: mark already snarfed by pp_list */
0bd48802 1864 SV * const tmpstr = POPs;
a0d0e21e 1865 STRLEN len;
9b877dbb 1866 bool isutf;
a0d0e21e 1867
6f1401dc
DM
1868 if (TARG != tmpstr)
1869 sv_setsv_nomg(TARG, tmpstr);
1870 SvPV_force_nomg(TARG, len);
9b877dbb 1871 isutf = DO_UTF8(TARG);
8ebc5c01
PP
1872 if (count != 1) {
1873 if (count < 1)
1874 SvCUR_set(TARG, 0);
1875 else {
b3b27d01
DM
1876 STRLEN max;
1877
1878 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1879 || len > (U32)I32_MAX /* repeatcpy would overflow */
1880 )
1881 Perl_croak(aTHX_ "%s",
1882 "Out of memory during string extend");
1883 max = (UV)count * len + 1;
1884 SvGROW(TARG, max);
1885
a0d0e21e 1886 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
b162af07 1887 SvCUR_set(TARG, SvCUR(TARG) * count);
7a4c00b4 1888 }
a0d0e21e 1889 *SvEND(TARG) = '\0';
a0d0e21e 1890 }
dfcb284a
GS
1891 if (isutf)
1892 (void)SvPOK_only_UTF8(TARG);
1893 else
1894 (void)SvPOK_only(TARG);
b80b6069 1895
a0d0e21e 1896 PUSHTARG;
79072805 1897 }
a0d0e21e
LW
1898 RETURN;
1899}
79072805 1900
a0d0e21e
LW
1901PP(pp_subtract)
1902{
20b7effb 1903 dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
1904 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1905 svr = TOPs;
1906 svl = TOPm1s;
230ee21f 1907
28e5dec8 1908#ifdef PERL_PRESERVE_IVUV
230ee21f
DM
1909
1910 /* special-case some simple common cases */
1911 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1912 IV il, ir;
1913 U32 flags = (svl->sv_flags & svr->sv_flags);
1914 if (flags & SVf_IOK) {
1915 /* both args are simple IVs */
1916 UV topl, topr;
1917 il = SvIVX(svl);
1918 ir = SvIVX(svr);
1919 do_iv:
1920 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1921 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1922
1923 /* if both are in a range that can't under/overflow, do a
1924 * simple integer subtract: if the top of both numbers
1925 * are 00 or 11, then it's safe */
1926 if (!( ((topl+1) | (topr+1)) & 2)) {
1927 SP--;
1928 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1929 SETs(TARG);
1930 RETURN;
1931 }
1932 goto generic;
1933 }
1934 else if (flags & SVf_NOK) {
1935 /* both args are NVs */
1936 NV nl = SvNVX(svl);
1937 NV nr = SvNVX(svr);
1938
1939 il = (IV)nl;
1940 ir = (IV)nr;
1941 if (nl == (NV)il && nr == (NV)ir)
1942 /* nothing was lost by converting to IVs */
1943 goto do_iv;
1944 SP--;
1945 TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1946 SETs(TARG);
1947 RETURN;
1948 }
1949 }
1950
1951 generic:
1952
1953 useleft = USE_LEFT(svl);
7dca457a
NC
1954 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1955 "bad things" happen if you rely on signed integers wrapping. */
01f91bf2 1956 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
1957 /* Unless the left argument is integer in range we are going to have to
1958 use NV maths. Hence only attempt to coerce the right argument if
1959 we know the left is integer. */
eb578fdb 1960 UV auv = 0;
9c5ffd7c 1961 bool auvok = FALSE;
7dca457a
NC
1962 bool a_valid = 0;
1963
28e5dec8 1964 if (!useleft) {
7dca457a
NC
1965 auv = 0;
1966 a_valid = auvok = 1;
1967 /* left operand is undef, treat as zero. */
28e5dec8
JH
1968 } else {
1969 /* Left operand is defined, so is it IV? */
01f91bf2 1970 if (SvIV_please_nomg(svl)) {
800401ee
JH
1971 if ((auvok = SvUOK(svl)))
1972 auv = SvUVX(svl);
7dca457a 1973 else {
eb578fdb 1974 const IV aiv = SvIVX(svl);
7dca457a
NC
1975 if (aiv >= 0) {
1976 auv = aiv;
1977 auvok = 1; /* Now acting as a sign flag. */
1978 } else { /* 2s complement assumption for IV_MIN */
53e2bfb7 1979 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
28e5dec8 1980 }
7dca457a
NC
1981 }
1982 a_valid = 1;
1983 }
1984 }
1985 if (a_valid) {
1986 bool result_good = 0;
1987 UV result;
eb578fdb 1988 UV buv;
800401ee 1989 bool buvok = SvUOK(svr);
9041c2e3 1990
7dca457a 1991 if (buvok)
800401ee 1992 buv = SvUVX(svr);
7dca457a 1993 else {
eb578fdb 1994 const IV biv = SvIVX(svr);
7dca457a
NC
1995 if (biv >= 0) {
1996 buv = biv;
1997 buvok = 1;
1998 } else
53e2bfb7 1999 buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
7dca457a
NC
2000 }
2001 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 2002 else "IV" now, independent of how it came in.
7dca457a
NC
2003 if a, b represents positive, A, B negative, a maps to -A etc
2004 a - b => (a - b)
2005 A - b => -(a + b)
2006 a - B => (a + b)
2007 A - B => -(a - b)
2008 all UV maths. negate result if A negative.
2009 subtract if signs same, add if signs differ. */
2010
2011 if (auvok ^ buvok) {
2012 /* Signs differ. */
2013 result = auv + buv;
2014 if (result >= auv)
2015 result_good = 1;
2016 } else {
2017 /* Signs same */
2018 if (auv >= buv) {
2019 result = auv - buv;
2020 /* Must get smaller */
2021 if (result <= auv)
2022 result_good = 1;
2023 } else {
2024 result = buv - auv;
2025 if (result <= buv) {
2026 /* result really should be -(auv-buv). as its negation
2027 of true value, need to swap our result flag */
2028 auvok = !auvok;
2029 result_good = 1;
28e5dec8 2030 }
28e5dec8
JH
2031 }
2032 }
7dca457a
NC
2033 if (result_good) {
2034 SP--;
2035 if (auvok)
2036 SETu( result );
2037 else {
2038 /* Negate result */
2039 if (result <= (UV)IV_MIN)
53e2bfb7
DM
2040 SETi(result == (UV)IV_MIN
2041 ? IV_MIN : -(IV)result);
7dca457a
NC
2042 else {
2043 /* result valid, but out of range for IV. */
2044 SETn( -(NV)result );
2045 }
2046 }
2047 RETURN;
2048 } /* Overflow, drop through to NVs. */
28e5dec8
JH
2049 }
2050 }
230ee21f
DM
2051#else
2052 useleft = USE_LEFT(svl);
28e5dec8 2053#endif
a0d0e21e 2054 {
6f1401dc 2055 NV value = SvNV_nomg(svr);
4efa5a16
RD
2056 (void)POPs;
2057
28e5dec8
JH
2058 if (!useleft) {
2059 /* left operand is undef, treat as zero - value */
2060 SETn(-value);
2061 RETURN;
2062 }
6f1401dc 2063 SETn( SvNV_nomg(svl) - value );
28e5dec8 2064 RETURN;
79072805 2065 }
a0d0e21e 2066}
79072805 2067
b3498293
JH
2068#define IV_BITS (IVSIZE * 8)
2069
2070static UV S_uv_shift(UV uv, int shift, bool left)
2071{
2072 if (shift < 0) {
2073 shift = -shift;
2074 left = !left;
2075 }
2076 if (shift >= IV_BITS) {
2077 return 0;
2078 }
2079 return left ? uv << shift : uv >> shift;
2080}
2081
2082static IV S_iv_shift(IV iv, int shift, bool left)
2083{
2084 if (shift < 0) {
2085 shift = -shift;
2086 left = !left;
2087 }
2088 if (shift >= IV_BITS) {
b69687e7 2089 return iv < 0 && !left ? -1 : 0;
b3498293
JH
2090 }
2091 return left ? iv << shift : iv >> shift;
2092}
2093
2094#define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2095#define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2096#define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2097#define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2098
a0d0e21e
LW
2099PP(pp_left_shift)
2100{
20b7effb 2101 dSP; dATARGET; SV *svl, *svr;
a42d0242 2102 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
2103 svr = POPs;
2104 svl = TOPs;
a0d0e21e 2105 {
6f1401dc 2106 const IV shift = SvIV_nomg(svr);
d0ba1bd2 2107 if (PL_op->op_private & HINT_INTEGER) {
b3498293 2108 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
d0ba1bd2
JH
2109 }
2110 else {
b3498293 2111 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
d0ba1bd2 2112 }
55497cff 2113 RETURN;
79072805 2114 }
a0d0e21e 2115}
79072805 2116
a0d0e21e
LW
2117PP(pp_right_shift)
2118{
20b7effb 2119 dSP; dATARGET; SV *svl, *svr;
a42d0242 2120 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
2121 svr = POPs;
2122 svl = TOPs;
a0d0e21e 2123 {
6f1401dc 2124 const IV shift = SvIV_nomg(svr);
d0ba1bd2 2125 if (PL_op->op_private & HINT_INTEGER) {
b3498293 2126 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
d0ba1bd2
JH
2127 }
2128 else {
b3498293 2129 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
d0ba1bd2 2130 }
a0d0e21e 2131 RETURN;
93a17b20 2132 }
79072805
LW
2133}
2134
a0d0e21e 2135PP(pp_lt)
79072805 2136{
20b7effb 2137 dSP;
33efebe6
DM
2138 SV *left, *right;
2139
a42d0242 2140 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
2141 right = POPs;
2142 left = TOPs;
2143 SETs(boolSV(
2144 (SvIOK_notUV(left) && SvIOK_notUV(right))
2145 ? (SvIVX(left) < SvIVX(right))
2146 : (do_ncmp(left, right) == -1)
2147 ));
2148 RETURN;
a0d0e21e 2149}
79072805 2150
a0d0e21e
LW
2151PP(pp_gt)
2152{
20b7effb 2153 dSP;
33efebe6 2154 SV *left, *right;
1b6737cc 2155
33efebe6
DM
2156 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2157 right = POPs;
2158 left = TOPs;
2159 SETs(boolSV(
2160 (SvIOK_notUV(left) && SvIOK_notUV(right))
2161 ? (SvIVX(left) > SvIVX(right))
2162 : (do_ncmp(left, right) == 1)
2163 ));
2164 RETURN;
a0d0e21e
LW
2165}
2166
2167PP(pp_le)
2168{
20b7effb 2169 dSP;
33efebe6 2170 SV *left, *right;
1b6737cc 2171
33efebe6
DM
2172 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2173 right = POPs;
2174 left = TOPs;
2175 SETs(boolSV(
2176 (SvIOK_notUV(left) && SvIOK_notUV(right))
2177 ? (SvIVX(left) <= SvIVX(right))
2178 : (do_ncmp(left, right) <= 0)
2179 ));
2180 RETURN;
a0d0e21e
LW
2181}
2182
2183PP(pp_ge)
2184{
20b7effb 2185 dSP;
33efebe6
DM
2186 SV *left, *right;
2187
2188 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2189 right = POPs;
2190 left = TOPs;
2191 SETs(boolSV(
2192 (SvIOK_notUV(left) && SvIOK_notUV(right))
2193 ? (SvIVX(left) >= SvIVX(right))
2194 : ( (do_ncmp(left, right) & 2) == 0)
2195 ));
2196 RETURN;
2197}
1b6737cc 2198
33efebe6
DM
2199PP(pp_ne)
2200{
20b7effb 2201 dSP;
33efebe6
DM
2202 SV *left, *right;
2203
2204 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2205 right = POPs;
2206 left = TOPs;
2207 SETs(boolSV(
2208 (SvIOK_notUV(left) && SvIOK_notUV(right))
2209 ? (SvIVX(left) != SvIVX(right))
2210 : (do_ncmp(left, right) != 0)
2211 ));
2212 RETURN;
2213}
1b6737cc 2214
33efebe6
DM
2215/* compare left and right SVs. Returns:
2216 * -1: <
2217 * 0: ==
2218 * 1: >
2219 * 2: left or right was a NaN
2220 */
2221I32
2222Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2223{
33efebe6
DM
2224 PERL_ARGS_ASSERT_DO_NCMP;
2225#ifdef PERL_PRESERVE_IVUV
33efebe6 2226 /* Fortunately it seems NaN isn't IOK */
01f91bf2 2227 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
33efebe6
DM
2228 if (!SvUOK(left)) {
2229 const IV leftiv = SvIVX(left);
2230 if (!SvUOK(right)) {
2231 /* ## IV <=> IV ## */
2232 const IV rightiv = SvIVX(right);
2233 return (leftiv > rightiv) - (leftiv < rightiv);
28e5dec8 2234 }
33efebe6
DM
2235 /* ## IV <=> UV ## */
2236 if (leftiv < 0)
2237 /* As (b) is a UV, it's >=0, so it must be < */
2238 return -1;
2239 {
2240 const UV rightuv = SvUVX(right);
2241 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
28e5dec8 2242 }
28e5dec8 2243 }
79072805 2244
33efebe6
DM
2245 if (SvUOK(right)) {
2246 /* ## UV <=> UV ## */
2247 const UV leftuv = SvUVX(left);
2248 const UV rightuv = SvUVX(right);
2249 return (leftuv > rightuv) - (leftuv < rightuv);
28e5dec8 2250 }
33efebe6
DM
2251 /* ## UV <=> IV ## */
2252 {
2253 const IV rightiv = SvIVX(right);
2254 if (rightiv < 0)
2255 /* As (a) is a UV, it's >=0, so it cannot be < */
2256 return 1;
2257 {
2258 const UV leftuv = SvUVX(left);
2259 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
28e5dec8 2260 }
28e5dec8 2261 }
e5964223 2262 NOT_REACHED; /* NOTREACHED */
28e5dec8
JH
2263 }
2264#endif
a0d0e21e 2265 {
33efebe6
DM
2266 NV const rnv = SvNV_nomg(right);
2267 NV const lnv = SvNV_nomg(left);
2268
cab190d4 2269#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
33efebe6
DM
2270 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2271 return 2;
2272 }
2273 return (lnv > rnv) - (lnv < rnv);
cab190d4 2274#else
33efebe6
DM
2275 if (lnv < rnv)
2276 return -1;
2277 if (lnv > rnv)
2278 return 1;
659c4b96 2279 if (lnv == rnv)
33efebe6
DM
2280 return 0;
2281 return 2;
cab190d4 2282#endif
a0d0e21e 2283 }
79072805
LW
2284}
2285
33efebe6 2286
a0d0e21e 2287PP(pp_ncmp)
79072805 2288{
20b7effb 2289 dSP;
33efebe6
DM
2290 SV *left, *right;
2291 I32 value;
a42d0242 2292 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
33efebe6
DM
2293 right = POPs;
2294 left = TOPs;
2295 value = do_ncmp(left, right);
2296 if (value == 2) {
3280af22 2297 SETs(&PL_sv_undef);
79072805 2298 }
33efebe6
DM
2299 else {
2300 dTARGET;
2301 SETi(value);
2302 }
2303 RETURN;
a0d0e21e 2304}
79072805 2305
b1c05ba5
DM
2306
2307/* also used for: pp_sge() pp_sgt() pp_slt() */
2308
afd9910b 2309PP(pp_sle)
a0d0e21e 2310{
20b7effb 2311 dSP;
79072805 2312
afd9910b
NC
2313 int amg_type = sle_amg;
2314 int multiplier = 1;
2315 int rhs = 1;
79072805 2316
afd9910b
NC
2317 switch (PL_op->op_type) {
2318 case OP_SLT:
2319 amg_type = slt_amg;
2320 /* cmp < 0 */
2321 rhs = 0;
2322 break;
2323 case OP_SGT:
2324 amg_type = sgt_amg;
2325 /* cmp > 0 */
2326 multiplier = -1;
2327 rhs = 0;
2328 break;
2329 case OP_SGE:
2330 amg_type = sge_amg;
2331 /* cmp >= 0 */
2332 multiplier = -1;
2333 break;
79072805 2334 }
79072805 2335
6f1401dc 2336 tryAMAGICbin_MG(amg_type, AMGf_set);
a0d0e21e
LW
2337 {
2338 dPOPTOPssrl;
130c5df3 2339 const int cmp =
5778acb6 2340#ifdef USE_LOCALE_COLLATE
130c5df3
KW
2341 (IN_LC_RUNTIME(LC_COLLATE))
2342 ? sv_cmp_locale_flags(left, right, 0)
2343 :
2344#endif
2345 sv_cmp_flags(left, right, 0);
afd9910b 2346 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW
2347 RETURN;
2348 }
2349}
79072805 2350
36477c24
PP
2351PP(pp_seq)
2352{
20b7effb 2353 dSP;
6f1401dc 2354 tryAMAGICbin_MG(seq_amg, AMGf_set);
36477c24
PP
2355 {
2356 dPOPTOPssrl;
078504b2 2357 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW
2358 RETURN;
2359 }
2360}
79072805 2361
a0d0e21e 2362PP(pp_sne)
79072805 2363{
20b7effb 2364 dSP;
6f1401dc 2365 tryAMAGICbin_MG(sne_amg, AMGf_set);
a0d0e21e
LW
2366 {
2367 dPOPTOPssrl;
078504b2 2368 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2369 RETURN;
463ee0b2 2370 }
79072805
LW
2371}
2372
a0d0e21e 2373PP(pp_scmp)
79072805 2374{
20b7effb 2375 dSP; dTARGET;
6f1401dc 2376 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW
2377 {
2378 dPOPTOPssrl;
130c5df3 2379 const int cmp =
5778acb6 2380#ifdef USE_LOCALE_COLLATE
130c5df3
KW
2381 (IN_LC_RUNTIME(LC_COLLATE))
2382 ? sv_cmp_locale_flags(left, right, 0)
2383 :
2384#endif
2385 sv_cmp_flags(left, right, 0);
bbce6d69 2386 SETi( cmp );
a0d0e21e
LW
2387 RETURN;
2388 }
2389}
79072805 2390
55497cff
PP
2391PP(pp_bit_and)
2392{
20b7effb 2393 dSP; dATARGET;
6f1401dc 2394 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW
2395 {
2396 dPOPTOPssrl;
4633a7c4 2397 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2398 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2399 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2400 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2401 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2402 SETi(i);
d0ba1bd2
JH
2403 }
2404 else {
1b6737cc 2405 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2406 SETu(u);
d0ba1bd2 2407 }
5ee80e13 2408 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2409 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2410 }
2411 else {
533c011a 2412 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2413 SETTARG;
2414 }
2415 RETURN;
2416 }
2417}
79072805 2418
5d01050a
FC
2419PP(pp_nbit_and)
2420{
2421 dSP;
636ac8fc 2422 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
5d01050a
FC
2423 {
2424 dATARGET; dPOPTOPssrl;
2425 if (PL_op->op_private & HINT_INTEGER) {
2426 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2427 SETi(i);
2428 }
2429 else {
2430 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2431 SETu(u);
2432 }
2433 }
2434 RETURN;
2435}
2436
2437PP(pp_sbit_and)
2438{
2439 dSP;
2440 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2441 {
2442 dATARGET; dPOPTOPssrl;
2443 do_vop(OP_BIT_AND, TARG, left, right);
2444 RETSETTARG;
2445 }
2446}
b1c05ba5
DM
2447
2448/* also used for: pp_bit_xor() */
2449
a0d0e21e
LW
2450PP(pp_bit_or)
2451{
20b7effb 2452 dSP; dATARGET;
3658c1f1
NC
2453 const int op_type = PL_op->op_type;
2454
6f1401dc 2455 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW
2456 {
2457 dPOPTOPssrl;
4633a7c4 2458 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2459 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2460 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2461 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC
2462 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2463 const IV r = SvIV_nomg(right);
2464 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2465 SETi(result);
d0ba1bd2
JH
2466 }
2467 else {
3658c1f1
NC
2468 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2469 const UV r = SvUV_nomg(right);
2470 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2471 SETu(result);
d0ba1bd2 2472 }
5ee80e13 2473 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2474 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2475 }
2476 else {
3658c1f1 2477 do_vop(op_type, TARG, left, right);
a0d0e21e
LW
2478 SETTARG;
2479 }
2480 RETURN;
79072805 2481 }
a0d0e21e 2482}
79072805 2483
5d01050a
FC
2484/* also used for: pp_nbit_xor() */
2485
2486PP(pp_nbit_or)
2487{
2488 dSP;
2489 const int op_type = PL_op->op_type;
2490
2491 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
636ac8fc 2492 AMGf_assign|AMGf_numarg);
5d01050a
FC
2493 {
2494 dATARGET; dPOPTOPssrl;
2495 if (PL_op->op_private & HINT_INTEGER) {
2496 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2497 const IV r = SvIV_nomg(right);
2498 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2499 SETi(result);
2500 }
2501 else {
2502 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2503 const UV r = SvUV_nomg(right);
2504 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2505 SETu(result);
2506 }
2507 }
2508 RETURN;
2509}
2510
2511/* also used for: pp_sbit_xor() */
2512
2513PP(pp_sbit_or)
2514{
2515 dSP;
2516 const int op_type = PL_op->op_type;
2517
2518 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2519 AMGf_assign);
2520 {
2521 dATARGET; dPOPTOPssrl;
2522 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2523 right);
2524 RETSETTARG;
2525 }
2526}
2527
1c2b3fd6
FC
2528PERL_STATIC_INLINE bool
2529S_negate_string(pTHX)
2530{
2531 dTARGET; dSP;
2532 STRLEN len;
2533 const char *s;
2534 SV * const sv = TOPs;
2535 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2536 return FALSE;
2537 s = SvPV_nomg_const(sv, len);
2538 if (isIDFIRST(*s)) {
2539 sv_setpvs(TARG, "-");
2540 sv_catsv(TARG, sv);
2541 }
2542 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2543 sv_setsv_nomg(TARG, sv);
2544 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2545 }
2546 else return FALSE;
245d035e 2547 SETTARG;
1c2b3fd6
FC
2548 return TRUE;
2549}
2550
a0d0e21e
LW
2551PP(pp_negate)
2552{
20b7effb 2553 dSP; dTARGET;
6f1401dc 2554 tryAMAGICun_MG(neg_amg, AMGf_numeric);
1c2b3fd6 2555 if (S_negate_string(aTHX)) return NORMAL;
a0d0e21e 2556 {
6f1401dc 2557 SV * const sv = TOPs;
a5b92898 2558
d96ab1b5 2559 if (SvIOK(sv)) {
7dbe3150 2560 /* It's publicly an integer */
28e5dec8 2561 oops_its_an_int:
9b0e499b
GS
2562 if (SvIsUV(sv)) {
2563 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2564 /* 2s complement assumption. */
d14578b8
KW
2565 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2566 IV_MIN */
245d035e 2567 return NORMAL;
9b0e499b
GS
2568 }
2569 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2570 SETi(-SvIVX(sv));
245d035e 2571 return NORMAL;
9b0e499b
GS
2572 }
2573 }
2574 else if (SvIVX(sv) != IV_MIN) {
2575 SETi(-SvIVX(sv));
245d035e 2576 return NORMAL;
9b0e499b 2577 }
28e5dec8
JH
2578#ifdef PERL_PRESERVE_IVUV
2579 else {
2580 SETu((UV)IV_MIN);
245d035e 2581 return NORMAL;
28e5dec8
JH
2582 }
2583#endif
9b0e499b 2584 }
8a5decd8 2585 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
6f1401dc 2586 SETn(-SvNV_nomg(sv));
1c2b3fd6 2587 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
8eb28a70 2588 goto oops_its_an_int;
4633a7c4 2589 else
6f1401dc 2590 SETn(-SvNV_nomg(sv));
79072805 2591 }
245d035e 2592 return NORMAL;
79072805
LW
2593}
2594
a0d0e21e 2595PP(pp_not)
79072805 2596{
20b7effb 2597 dSP;
6f1401dc 2598 tryAMAGICun_MG(not_amg, AMGf_set);
06c841cf 2599 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
a0d0e21e 2600 return NORMAL;
79072805
LW
2601}
2602
5d01050a
FC
2603static void
2604S_scomplement(pTHX_ SV *targ, SV *sv)
79072805 2605{
eb578fdb
KW
2606 U8 *tmps;
2607 I32 anum;
a0d0e21e
LW
2608 STRLEN len;
2609
85b0ee6e
FC
2610 sv_copypv_nomg(TARG, sv);
2611 tmps = (U8*)SvPV_nomg(TARG, len);
a0d0e21e 2612 anum = len;
1d68d6cd 2613 if (SvUTF8(TARG)) {
a1ca4561 2614 /* Calculate exact length, let's not estimate. */
1d68d6cd 2615 STRLEN targlen = 0;
ba210ebe 2616 STRLEN l;
a1ca4561
YST
2617 UV nchar = 0;
2618 UV nwide = 0;
01f6e806 2619 U8 * const send = tmps + len;
74d49cd0
ST
2620 U8 * const origtmps = tmps;
2621 const UV utf8flags = UTF8_ALLOW_ANYUV;
1d68d6cd 2622
1d68d6cd 2623 while (tmps < send) {
74d49cd0
ST
2624 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2625 tmps += l;
5f560d8a 2626 targlen += UVCHR_SKIP(~c);
a1ca4561
YST
2627 nchar++;
2628 if (c > 0xff)
2629 nwide++;
1d68d6cd
SC
2630 }
2631
2632 /* Now rewind strings and write them. */
74d49cd0 2633 tmps = origtmps;
a1ca4561
YST
2634
2635 if (nwide) {
01f6e806
AL
2636 U8 *result;
2637 U8 *p;
2638
74d49cd0 2639 Newx(result, targlen + 1, U8);
01f6e806 2640 p = result;
a1ca4561 2641 while (tmps < send) {
74d49cd0
ST
2642 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2643 tmps += l;
01f6e806 2644 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
a1ca4561 2645 }
01f6e806 2646 *p = '\0';
c1c21316
NC
2647 sv_usepvn_flags(TARG, (char*)result, targlen,
2648 SV_HAS_TRAILING_NUL);
a1ca4561
YST
2649 SvUTF8_on(TARG);
2650 }
2651 else {
01f6e806
AL
2652 U8 *result;
2653 U8 *p;
2654
74d49cd0 2655 Newx(result, nchar + 1, U8);
01f6e806 2656 p = result;
a1ca4561 2657 while (tmps < send) {
74d49cd0
ST
2658 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2659 tmps += l;
01f6e806 2660 *p++ = ~c;
a1ca4561 2661 }
01f6e806 2662 *p = '\0';
c1c21316 2663 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
d0a21e00 2664 SvUTF8_off(TARG);
1d68d6cd 2665 }
5d01050a 2666 return;
1d68d6cd 2667 }
a0d0e21e 2668#ifdef LIBERAL
51723571 2669 {
eb578fdb 2670 long *tmpl;
51723571
JH
2671 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2672 *tmps = ~*tmps;
2673 tmpl = (long*)tmps;
bb7a0f54 2674 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH
2675 *tmpl = ~*tmpl;
2676 tmps = (U8*)tmpl;
2677 }
a0d0e21e
LW
2678#endif
2679 for ( ; anum > 0; anum--, tmps++)
2680 *tmps = ~*tmps;
5d01050a
FC
2681}
2682
2683PP(pp_complement)
2684{
2685 dSP; dTARGET;
2686 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2687 {
2688 dTOPss;
2689 if (SvNIOKp(sv)) {
2690 if (PL_op->op_private & HINT_INTEGER) {
2691 const IV i = ~SvIV_nomg(sv);
2692 SETi(i);
2693 }
2694 else {
2695 const UV u = ~SvUV_nomg(sv);
2696 SETu(u);
2697 }
2698 }
2699 else {
2700 S_scomplement(aTHX_ TARG, sv);
ec93b65f 2701 SETTARG;
a0d0e21e 2702 }
24840750 2703 return NORMAL;
5d01050a
FC
2704 }
2705}
2706
2707PP(pp_ncomplement)
2708{
2709 dSP;
636ac8fc 2710 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
5d01050a
FC
2711 {
2712 dTARGET; dTOPss;
2713 if (PL_op->op_private & HINT_INTEGER) {
2714 const IV i = ~SvIV_nomg(sv);
2715 SETi(i);
2716 }
2717 else {
2718 const UV u = ~SvUV_nomg(sv);
2719 SETu(u);
2720 }
2721 }
2722 return NORMAL;
2723}
2724
2725PP(pp_scomplement)
2726{
2727 dSP;
2728 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2729 {
2730 dTARGET; dTOPss;
2731 S_scomplement(aTHX_ TARG, sv);
2732 SETTARG;
2733 return NORMAL;
a0d0e21e 2734 }
79072805
LW
2735}
2736
a0d0e21e
LW
2737/* integer versions of some of the above */
2738
a0d0e21e 2739PP(pp_i_multiply)
79072805 2740{
20b7effb 2741 dSP; dATARGET;
6f1401dc 2742 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2743 {
6f1401dc 2744 dPOPTOPiirl_nomg;
a0d0e21e
LW
2745 SETi( left * right );
2746 RETURN;
2747 }
79072805
LW
2748}
2749
a0d0e21e 2750PP(pp_i_divide)
79072805 2751{
85935d8e 2752 IV num;
20b7effb 2753 dSP; dATARGET;
6f1401dc 2754 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2755 {
6f1401dc 2756 dPOPTOPssrl;
85935d8e 2757 IV value = SvIV_nomg(right);
a0d0e21e 2758 if (value == 0)
ece1bcef 2759 DIE(aTHX_ "Illegal division by zero");
85935d8e 2760 num = SvIV_nomg(left);
a0cec769
YST
2761
2762 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2763 if (value == -1)
2764 value = - num;
2765 else
2766 value = num / value;
6f1401dc 2767 SETi(value);
a0d0e21e
LW
2768 RETURN;
2769 }
79072805
LW
2770}
2771
bf3d06aa
JC
2772#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2773 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
224ec323
JH
2774STATIC
2775PP(pp_i_modulo_0)
befad5d1
NC
2776#else
2777PP(pp_i_modulo)
2778#endif
224ec323
JH
2779{
2780 /* This is the vanilla old i_modulo. */
20b7effb 2781 dSP; dATARGET;
6f1401dc 2782 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2783 {
6f1401dc 2784 dPOPTOPiirl_nomg;
224ec323
JH
2785 if (!right)
2786 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2787 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2788 if (right == -1)
2789 SETi( 0 );
2790 else
2791 SETi( left % right );
224ec323
JH
2792 RETURN;
2793 }
2794}
2795
bf3d06aa
JC
2796#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2797 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
224ec323
JH
2798STATIC
2799PP(pp_i_modulo_1)
befad5d1 2800
224ec323 2801{
224ec323 2802 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2803 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2804 * See below for pp_i_modulo. */
20b7effb 2805 dSP; dATARGET;
6f1401dc 2806 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2807 {
6f1401dc 2808 dPOPTOPiirl_nomg;
224ec323
JH
2809 if (!right)
2810 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2811 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2812 if (right == -1)
2813 SETi( 0 );
2814 else
2815 SETi( left % PERL_ABS(right) );
224ec323
JH
2816 RETURN;
2817 }
224ec323
JH
2818}
2819
a0d0e21e 2820PP(pp_i_modulo)
79072805 2821{
6f1401dc
DM
2822 dVAR; dSP; dATARGET;
2823 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2824 {
6f1401dc 2825 dPOPTOPiirl_nomg;
224ec323
JH
2826 if (!right)
2827 DIE(aTHX_ "Illegal modulus zero");
2828 /* The assumption is to use hereafter the old vanilla version... */
2829 PL_op->op_ppaddr =
2830 PL_ppaddr[OP_I_MODULO] =
1c127fab 2831 Perl_pp_i_modulo_0;
224ec323 2832 /* .. but if we have glibc, we might have a buggy _moddi3
bf3d06aa 2833 * (at least glibc 2.2.5 is known to have this bug), in other
224ec323
JH
2834 * words our integer modulus with negative quad as the second
2835 * argument might be broken. Test for this and re-patch the
2836 * opcode dispatch table if that is the case, remembering to
2837 * also apply the workaround so that this first round works
2838 * right, too. See [perl #9402] for more information. */
224ec323
JH
2839 {
2840 IV l = 3;
2841 IV r = -10;
2842 /* Cannot do this check with inlined IV constants since
2843 * that seems to work correctly even with the buggy glibc. */
2844 if (l % r == -3) {
2845 /* Yikes, we have the bug.
2846 * Patch in the workaround version. */
2847 PL_op->op_ppaddr =
2848 PL_ppaddr[OP_I_MODULO] =
2849 &Perl_pp_i_modulo_1;
2850 /* Make certain we work right this time, too. */
32fdb065 2851 right = PERL_ABS(right);
224ec323
JH
2852 }
2853 }
a0cec769
YST
2854 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2855 if (right == -1)
2856 SETi( 0 );
2857 else
2858 SETi( left % right );
224ec323
JH
2859 RETURN;
2860 }
79072805 2861}
befad5d1 2862#endif
79072805 2863
a0d0e21e 2864PP(pp_i_add)
79072805 2865{
20b7effb 2866 dSP; dATARGET;
6f1401dc 2867 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2868 {
6f1401dc 2869 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2870 SETi( left + right );
2871 RETURN;
79072805 2872 }
79072805
LW
2873}
2874
a0d0e21e 2875PP(pp_i_subtract)
79072805 2876{
20b7effb 2877 dSP; dATARGET;
6f1401dc 2878 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2879 {
6f1401dc 2880 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2881 SETi( left - right );
2882 RETURN;
79072805 2883 }
79072805
LW
2884}
2885
a0d0e21e 2886PP(pp_i_lt)
79072805 2887{
20b7effb 2888 dSP;
6f1401dc 2889 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2890 {
96b6b87f 2891 dPOPTOPiirl_nomg;
54310121 2892 SETs(boolSV(left < right));
a0d0e21e
LW
2893 RETURN;
2894 }
79072805
LW
2895}
2896
a0d0e21e 2897PP(pp_i_gt)
79072805 2898{
20b7effb 2899 dSP;
6f1401dc 2900 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2901 {
96b6b87f 2902 dPOPTOPiirl_nomg;
54310121 2903 SETs(boolSV(left > right));
a0d0e21e
LW
2904 RETURN;
2905 }
79072805
LW
2906}
2907
a0d0e21e 2908PP(pp_i_le)
79072805 2909{
20b7effb 2910 dSP;
6f1401dc 2911 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 2912 {
96b6b87f 2913 dPOPTOPiirl_nomg;
54310121 2914 SETs(boolSV(left <= right));
a0d0e21e 2915 RETURN;
85e6fe83 2916 }
79072805
LW
2917}
2918
a0d0e21e 2919PP(pp_i_ge)
79072805 2920{
20b7effb 2921 dSP;
6f1401dc 2922 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 2923 {
96b6b87f 2924 dPOPTOPiirl_nomg;
54310121 2925 SETs(boolSV(left >= right));
a0d0e21e
LW
2926 RETURN;
2927 }
79072805
LW
2928}
2929
a0d0e21e 2930PP(pp_i_eq)
79072805 2931{
20b7effb 2932 dSP;
6f1401dc 2933 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 2934 {
96b6b87f 2935 dPOPTOPiirl_nomg;
54310121 2936 SETs(boolSV(left == right));
a0d0e21e
LW
2937 RETURN;
2938 }
79072805
LW
2939}
2940
a0d0e21e 2941PP(pp_i_ne)
79072805 2942{
20b7effb 2943 dSP;
6f1401dc 2944 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 2945 {
96b6b87f 2946 dPOPTOPiirl_nomg;
54310121 2947 SETs(boolSV(left != right));
a0d0e21e
LW
2948 RETURN;
2949 }
79072805
LW
2950}
2951
a0d0e21e 2952PP(pp_i_ncmp)
79072805 2953{
20b7effb 2954 dSP; dTARGET;
6f1401dc 2955 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2956 {
96b6b87f 2957 dPOPTOPiirl_nomg;
a0d0e21e 2958 I32 value;
79072805 2959
a0d0e21e 2960 if (left > right)
79072805 2961 value = 1;
a0d0e21e 2962 else if (left < right)
79072805 2963 value = -1;
a0d0e21e 2964 else
79072805 2965 value = 0;
a0d0e21e
LW
2966 SETi(value);
2967 RETURN;
79072805 2968 }
85e6fe83
LW
2969}
2970
2971PP(pp_i_negate)
2972{
20b7effb 2973 dSP; dTARGET;
6f1401dc 2974 tryAMAGICun_MG(neg_amg, 0);
1c2b3fd6 2975 if (S_negate_string(aTHX)) return NORMAL;
6f1401dc
DM
2976 {
2977 SV * const sv = TOPs;
2978 IV const i = SvIV_nomg(sv);
2979 SETi(-i);
ae642386 2980 return NORMAL;
6f1401dc 2981 }
85e6fe83
LW
2982}
2983
79072805
LW
2984/* High falutin' math. */
2985
2986PP(pp_atan2)
2987{
20b7effb 2988 dSP; dTARGET;
6f1401dc 2989 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2990 {
096c060c 2991 dPOPTOPnnrl_nomg;
a1021d57 2992 SETn(Perl_atan2(left, right));
a0d0e21e
LW
2993 RETURN;
2994 }
79072805
LW
2995}
2996
b1c05ba5
DM
2997
2998/* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2999
79072805
LW
3000PP(pp_sin)
3001{
20b7effb 3002 dSP; dTARGET;
af71714e 3003 int amg_type = fallback_amg;
71302fe3 3004 const char *neg_report = NULL;
71302fe3
NC
3005 const int op_type = PL_op->op_type;
3006
3007 switch (op_type) {
af71714e
JH
3008 case OP_SIN: amg_type = sin_amg; break;
3009 case OP_COS: amg_type = cos_amg; break;
3010 case OP_EXP: amg_type = exp_amg; break;
3011 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
3012 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
a0d0e21e 3013 }
79072805 3014
af71714e 3015 assert(amg_type != fallback_amg);
6f1401dc
DM
3016
3017 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 3018 {
8c78ed36 3019 SV * const arg = TOPs;
6f1401dc 3020 const NV value = SvNV_nomg(arg);
f256868e 3021 NV result = NV_NAN;
af71714e 3022 if (neg_report) { /* log or sqrt */
a3463d96
DD
3023 if (
3024#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3025 ! Perl_isnan(value) &&
3026#endif
3027 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
71302fe3 3028 SET_NUMERIC_STANDARD();
dcbac5bb 3029 /* diag_listed_as: Can't take log of %g */
71302fe3
NC
3030 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
3031 }
3032 }
af71714e 3033 switch (op_type) {
f256868e 3034 default:
af71714e
JH
3035 case OP_SIN: result = Perl_sin(value); break;
3036 case OP_COS: result = Perl_cos(value); break;
3037 case OP_EXP: result = Perl_exp(value); break;
3038 case OP_LOG: result = Perl_log(value); break;
3039 case OP_SQRT: result = Perl_sqrt(value); break;
3040 }
8c78ed36
FC
3041 SETn(result);
3042 return NORMAL;
a0d0e21e 3043 }
79072805
LW
3044}
3045
56cb0a1c
AD
3046/* Support Configure command-line overrides for rand() functions.
3047 After 5.005, perhaps we should replace this by Configure support
3048 for drand48(), random(), or rand(). For 5.005, though, maintain
3049 compatibility by calling rand() but allow the user to override it.
3050 See INSTALL for details. --Andy Dougherty 15 July 1998
3051*/
85ab1d1d
JH
3052/* Now it's after 5.005, and Configure supports drand48() and random(),
3053 in addition to rand(). So the overrides should not be needed any more.
3054 --Jarkko Hietaniemi 27 September 1998
3055 */
3056
79072805
LW
3057PP(pp_rand)
3058{
80252599 3059 if (!PL_srand_called) {
85ab1d1d 3060 (void)seedDrand01((Rand_seed_t)seed());
80252599 3061 PL_srand_called = TRUE;
93dc8474 3062 }
fdf4dddd
DD
3063 {
3064 dSP;
3065 NV value;
fdf4dddd
DD
3066
3067 if (MAXARG < 1)
7e9044f9
FC
3068 {
3069 EXTEND(SP, 1);
fdf4dddd 3070 value = 1.0;
7e9044f9 3071 }
fdf4dddd
DD
3072 else {
3073 SV * const sv = POPs;
3074 if(!sv)
3075 value = 1.0;
3076 else
3077 value = SvNV(sv);
3078 }
3079 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
a3463d96
DD
3080#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3081 if (! Perl_isnan(value) && value == 0.0)
3082#else
659c4b96 3083 if (value == 0.0)
a3463d96 3084#endif
fdf4dddd
DD
3085 value = 1.0;
3086 {
3087 dTARGET;
3088 PUSHs(TARG);
3089 PUTBACK;
3090 value *= Drand01();
3091 sv_setnv_mg(TARG, value);
3092 }
3093 }
3094 return NORMAL;
79072805
LW
3095}
3096
3097PP(pp_srand)
3098{
20b7effb 3099 dSP; dTARGET;
f914a682
JL
3100 UV anum;
3101
0a5f3363 3102 if (MAXARG >= 1 && (TOPs || POPs)) {
f914a682
JL
3103 SV *top;
3104 char *pv;
3105 STRLEN len;
3106 int flags;
3107
3108 top = POPs;
3109 pv = SvPV(top, len);
3110 flags = grok_number(pv, len, &anum);
3111
3112 if (!(flags & IS_NUMBER_IN_UV)) {
3113 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
3114 "Integer overflow in srand");
3115 anum = UV_MAX;
3116 }
3117 }
3118 else {
3119 anum = seed();
3120 }
3121
85ab1d1d 3122 (void)seedDrand01((Rand_seed_t)anum);
80252599 3123 PL_srand_called = TRUE;
da1010ec
NC
3124 if (anum)
3125 XPUSHu(anum);
3126 else {
3127 /* Historically srand always returned true. We can avoid breaking
3128 that like this: */
3129 sv_setpvs(TARG, "0 but true");
3130 XPUSHTARG;
3131 }
83832992 3132 RETURN;
79072805
LW
3133}
3134
79072805
LW
3135PP(pp_int)
3136{
20b7effb 3137 dSP; dTARGET;
6f1401dc 3138 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 3139 {
6f1401dc
DM
3140 SV * const sv = TOPs;
3141 const IV iv = SvIV_nomg(sv);
28e5dec8
JH
3142 /* XXX it's arguable that compiler casting to IV might be subtly
3143 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3144 else preferring IV has introduced a subtle behaviour change bug. OTOH
3145 relying on floating point to be accurate is a bug. */
3146
c781a409 3147 if (!SvOK(sv)) {
922c4365 3148 SETu(0);
c781a409
RD
3149 }
3150 else if (SvIOK(sv)) {
3151 if (SvIsUV(sv))
6f1401dc 3152 SETu(SvUV_nomg(sv));
c781a409 3153 else
28e5dec8 3154 SETi(iv);
c781a409 3155 }
c781a409 3156 else {
6f1401dc 3157 const NV value = SvNV_nomg(sv);
b9d05018
FC
3158 if (UNLIKELY(Perl_isinfnan(value)))
3159 SETn(value);
5bf8b78e 3160 else if (value >= 0.0) {
28e5dec8
JH
3161 if (value < (NV)UV_MAX + 0.5) {
3162 SETu(U_V(value));
3163 } else {
059a1014 3164 SETn(Perl_floor(value));
28e5dec8 3165 }
1048ea30 3166 }
28e5dec8
JH
3167 else {
3168 if (value > (NV)IV_MIN - 0.5) {
3169 SETi(I_V(value));
3170 } else {
1bbae031 3171 SETn(Perl_ceil(value));
28e5dec8
JH
3172 }
3173 }
774d564b 3174 }
79072805 3175 }
699e9491 3176 return NORMAL;
79072805
LW
3177}
3178
463ee0b2
LW
3179PP(pp_abs)
3180{
20b7effb 3181 dSP; dTARGET;
6f1401dc 3182 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 3183 {
6f1401dc 3184 SV * const sv = TOPs;
28e5dec8 3185 /* This will cache the NV value if string isn't actually integer */
6f1401dc 3186 const IV iv = SvIV_nomg(sv);
a227d84d 3187
800401ee 3188 if (!SvOK(sv)) {
922c4365 3189 SETu(0);
800401ee
JH
3190 }
3191 else if (SvIOK(sv)) {
28e5dec8 3192 /* IVX is precise */
800401ee 3193 if (SvIsUV(sv)) {
6f1401dc 3194 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH
3195 } else {
3196 if (iv >= 0) {
3197 SETi(iv);
3198 } else {
3199 if (iv != IV_MIN) {
3200 SETi(-iv);
3201 } else {
3202 /* 2s complement assumption. Also, not really needed as
3203 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3204 SETu(IV_MIN);
3205 }
a227d84d 3206 }
28e5dec8
JH
3207 }
3208 } else{
6f1401dc 3209 const NV value = SvNV_nomg(sv);
774d564b 3210 if (value < 0.0)
1b6737cc 3211 SETn(-value);
a4474c9e
DD
3212 else
3213 SETn(value);
774d564b 3214 }
a0d0e21e 3215 }
067b7929 3216 return NORMAL;
463ee0b2
LW
3217}
3218
b1c05ba5
DM
3219
3220/* also used for: pp_hex() */
3221
79072805
LW
3222PP(pp_oct)
3223{
20b7effb 3224 dSP; dTARGET;
5c144d81 3225 const char *tmps;
53305cf1 3226 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 3227 STRLEN len;
53305cf1
NC
3228 NV result_nv;
3229 UV result_uv;
4e51bcca 3230 SV* const sv = TOPs;
79072805 3231
349d4f2f 3232 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS
3233 if (DO_UTF8(sv)) {
3234 /* If Unicode, try to downgrade
3235 * If not possible, croak. */
1b6737cc 3236 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS
3237
3238 SvUTF8_on(tsv);
3239 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3240 tmps = SvPV_const(tsv, len);
2bc69dc4 3241 }
daa2adfd
NC
3242 if (PL_op->op_type == OP_HEX)
3243 goto hex;
3244
6f894ead 3245 while (*tmps && len && isSPACE(*tmps))
53305cf1 3246 tmps++, len--;
9e24b6e2 3247 if (*tmps == '0')
53305cf1 3248 tmps++, len--;
305b8651 3249 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
daa2adfd 3250 hex:
53305cf1 3251 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 3252 }
305b8651 3253 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
53305cf1 3254 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 3255 else
53305cf1
NC
3256 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3257
3258 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
4e51bcca 3259 SETn(result_nv);
53305cf1
NC
3260 }
3261 else {
4e51bcca 3262 SETu(result_uv);
53305cf1 3263 }
4e51bcca 3264 return NORMAL;
79072805
LW
3265}
3266
3267/* String stuff. */
3268
3269PP(pp_length)
3270{
20b7effb 3271 dSP; dTARGET;
0bd48802 3272 SV * const sv = TOPs;
a0ed51b3 3273
7776003e
DD
3274 U32 in_bytes = IN_BYTES;
3275 /* simplest case shortcut */
3276 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3277 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
6d59e610 3278 STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
7776003e
DD
3279 SETs(TARG);
3280
3281 if(LIKELY(svflags == SVf_POK))
3282 goto simple_pv;
3283 if(svflags & SVs_GMG)
3284 mg_get(sv);
0f43fd57 3285 if (SvOK(sv)) {
7776003e
DD
3286 if (!IN_BYTES) /* reread to avoid using an C auto/register */
3287 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
9f621bb0 3288 else
0f43fd57
FC
3289 {
3290 STRLEN len;
7776003e
DD
3291 /* unrolled SvPV_nomg_const(sv,len) */
3292 if(SvPOK_nog(sv)){
3293 simple_pv:
3294 len = SvCUR(sv);
3295 } else {
3296 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3297 }
3298 sv_setiv(TARG, (IV)(len));
0f43fd57 3299 }
656266fc 3300 } else {
9407f9c1
DL
3301 if (!SvPADTMP(TARG)) {
3302 sv_setsv_nomg(TARG, &PL_sv_undef);
7776003e
DD
3303 } else { /* TARG is on stack at this point and is overwriten by SETs.
3304 This branch is the odd one out, so put TARG by default on
3305 stack earlier to let local SP go out of liveness sooner */
3306 SETs(&PL_sv_undef);
3307 goto no_set_magic;
3308 }
92331800 3309 }
7776003e
DD
3310 SvSETMAGIC(TARG);
3311 no_set_magic:
3312 return NORMAL; /* no putback, SP didn't move in this opcode */
79072805
LW
3313}
3314
83f78d1a
FC
3315/* Returns false if substring is completely outside original string.
3316 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3317 always be true for an explicit 0.
3318*/
3319bool
ddeaf645
DD
3320Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3321 bool pos1_is_uv, IV len_iv,
3322 bool len_is_uv, STRLEN *posp,
3323 STRLEN *lenp)
83f78d1a
FC
3324{
3325 IV pos2_iv;
3326 int pos2_is_uv;
3327
3328 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3329
3330 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3331 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3332 pos1_iv += curlen;
3333 }
3334 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3335 return FALSE;
3336
3337 if (len_iv || len_is_uv) {
3338 if (!len_is_uv && len_iv < 0) {
3339 pos2_iv = curlen + len_iv;
3340 if (curlen)
3341 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3342 else
3343 pos2_is_uv = 0;
3344 } else { /* len_iv >= 0 */
3345 if (!pos1_is_uv && pos1_iv < 0) {
3346 pos2_iv = pos1_iv + len_iv;
3347 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3348 } else {
3349 if ((UV)len_iv > curlen-(UV)pos1_iv)
3350 pos2_iv = curlen;
3351 else
3352 pos2_iv = pos1_iv+len_iv;
3353 pos2_is_uv = 1;
3354 }
3355 }
3356 }
3357 else {
3358 pos2_iv = curlen;
3359 pos2_is_uv = 1;
3360 }
3361
3362 if (!pos2_is_uv && pos2_iv < 0) {
3363 if (!pos1_is_uv && pos1_iv < 0)
3364 return FALSE;
3365 pos2_iv = 0;
3366 }
3367 else if (!pos1_is_uv && pos1_iv < 0)
3368 pos1_iv = 0;
3369
3370 if ((UV)pos2_iv < (UV)pos1_iv)
3371 pos2_iv = pos1_iv;
3372 if ((UV)pos2_iv > curlen)
3373 pos2_iv = curlen;
3374
3375 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3376 *posp = (STRLEN)( (UV)pos1_iv );
3377 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3378
3379 return TRUE;
3380}
3381
79072805
LW
3382PP(pp_substr)
3383{
20b7effb 3384 dSP; dTARGET;
79072805 3385 SV *sv;
463ee0b2 3386 STRLEN curlen;
9402d6ed 3387 STRLEN utf8_curlen;
777f7c56
EB
3388 SV * pos_sv;
3389 IV pos1_iv;
3390 int pos1_is_uv;
777f7c56
EB
3391 SV * len_sv;
3392 IV len_iv = 0;
83f78d1a 3393 int len_is_uv = 0;
24fcb59f 3394 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 3395 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 3396 const char *tmps;
9402d6ed 3397 SV *repl_sv = NULL;
cbbf8932 3398 const char *repl = NULL;
7b8d334a 3399 STRLEN repl_len;
7bc95ae1 3400 int num_args = PL_op->op_private & 7;
13e30c65 3401 bool repl_need_utf8_upgrade = FALSE;
79072805 3402
78f9721b
SM
3403 if (num_args > 2) {
3404 if (num_args > 3) {
24fcb59f 3405 if(!(repl_sv = POPs)) num_args--;
7bc95ae1
FC
3406 }
3407 if ((len_sv = POPs)) {
3408 len_iv = SvIV(len_sv);
83f78d1a 3409 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
7b8d334a 3410 }
7bc95ae1 3411 else num_args--;
5d82c453 3412 }
777f7c56
EB
3413 pos_sv = POPs;
3414 pos1_iv = SvIV(pos_sv);
3415 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3416 sv = POPs;
24fcb59f
FC
3417 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3418 assert(!repl_sv);
3419 repl_sv = POPs;
3420 }
6582db62 3421 if (lvalue && !repl_sv) {
83f78d1a
FC
3422 SV * ret;
3423 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3424 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3425 LvTYPE(ret) = 'x';
3426 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3427 LvTARGOFF(ret) =
3428 pos1_is_uv || pos1_iv >= 0
3429 ? (STRLEN)(UV)pos1_iv
3430 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3431 LvTARGLEN(ret) =
3432 len_is_uv || len_iv > 0
3433 ? (STRLEN)(UV)len_iv
3434 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3435
83f78d1a
FC
3436 PUSHs(ret); /* avoid SvSETMAGIC here */
3437 RETURN;
a74fb2cd 3438 }
6582db62
FC
3439 if (repl_sv) {
3440 repl = SvPV_const(repl_sv, repl_len);
3441 SvGETMAGIC(sv);
3442 if (SvROK(sv))
3443 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3444 "Attempt to use reference as lvalue in substr"
3445 );
3446 tmps = SvPV_force_nomg(sv, curlen);
3447 if (DO_UTF8(repl_sv) && repl_len) {
3448 if (!DO_UTF8(sv)) {
01680ee9 3449 sv_utf8_upgrade_nomg(sv);
6582db62
FC
3450 curlen = SvCUR(sv);
3451 }
3452 }
3453 else if (DO_UTF8(sv))
3454 repl_need_utf8_upgrade = TRUE;
3455 }
3456 else tmps = SvPV_const(sv, curlen);
7e2040f0 3457 if (DO_UTF8(sv)) {
0d788f38 3458 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
9402d6ed
JH
3459 if (utf8_curlen == curlen)
3460 utf8_curlen = 0;
a0ed51b3 3461 else
9402d6ed 3462 curlen = utf8_curlen;
a0ed51b3 3463 }
d1c2b58a 3464 else
9402d6ed 3465 utf8_curlen = 0;
a0ed51b3 3466
83f78d1a
FC
3467 {
3468 STRLEN pos, len, byte_len, byte_pos;
777f7c56 3469
83f78d1a
FC
3470 if (!translate_substr_offsets(
3471 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3472 )) goto bound_fail;
777f7c56 3473
83f78d1a
FC
3474 byte_len = len;
3475 byte_pos = utf8_curlen
0d788f38 3476 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
d931b1be 3477
2154eca7 3478 tmps += byte_pos;
bbddc9e0
CS
3479
3480 if (rvalue) {
3481 SvTAINTED_off(TARG); /* decontaminate */
3482 SvUTF8_off(TARG); /* decontaminate */
3483 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3484#ifdef USE_LOCALE_COLLATE
bbddc9e0 3485 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3486#endif
bbddc9e0
CS
3487 if (utf8_curlen)
3488 SvUTF8_on(TARG);
3489 }
2154eca7 3490
f7928d6c 3491 if (repl) {
13e30c65
JH
3492 SV* repl_sv_copy = NULL;
3493
3494 if (repl_need_utf8_upgrade) {
3495 repl_sv_copy = newSVsv(repl_sv);
3496 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3497 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65 3498 }
502d9230
VP
3499 if (!SvOK(sv))
3500 sv_setpvs(sv, "");
777f7c56 3501 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
ef8d46e8 3502 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3503 }
79072805 3504 }
6a9665b0
FC
3505 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3506 SP++;
3507 else if (rvalue) {
bbddc9e0
CS
3508 SvSETMAGIC(TARG);
3509 PUSHs(TARG);
3510 }
79072805 3511 RETURN;
777f7c56 3512
7b52d656 3513 bound_fail:
83f78d1a 3514 if (repl)
777f7c56
EB
3515 Perl_croak(aTHX_ "substr outside of string");
3516 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3517 RETPUSHUNDEF;
79072805
LW
3518}
3519
3520PP(pp_vec)
3521{
20b7effb 3522 dSP;
eb578fdb
KW
3523 const IV size = POPi;
3524 const IV offset = POPi;
3525 SV * const src = POPs;
1b6737cc 3526 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3527 SV * ret;
a0d0e21e 3528
81e118e0 3529 if (lvalue) { /* it's an lvalue! */
2154eca7
EB
3530 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3531 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3532 LvTYPE(ret) = 'v';
3533 LvTARG(ret) = SvREFCNT_inc_simple(src);
3534 LvTARGOFF(ret) = offset;
3535 LvTARGLEN(ret) = size;
3536 }
3537 else {
3538 dTARGET;
3539 SvTAINTED_off(TARG); /* decontaminate */
3540 ret = TARG;
79072805
LW
3541 }
3542
2154eca7 3543 sv_setuv(ret, do_vecget(src, offset, size));
f9e95907
FC
3544 if (!lvalue)
3545 SvSETMAGIC(ret);
2154eca7 3546 PUSHs(ret);
79072805
LW
3547 RETURN;
3548}
3549
b1c05ba5
DM
3550
3551/* also used for: pp_rindex() */
3552
79072805
LW
3553PP(pp_index)
3554{
20b7effb 3555 dSP; dTARGET;
79072805
LW
3556 SV *big;
3557 SV *little;
c445ea15 3558 SV *temp = NULL;
ad66a58c 3559 STRLEN biglen;
2723d216 3560 STRLEN llen = 0;
b464e2b7
TC
3561 SSize_t offset = 0;
3562 SSize_t retval;
73ee8be2
NC
3563 const char *big_p;
3564 const char *little_p;
2f040f7f
NC
3565 bool big_utf8;
3566 bool little_utf8;
2723d216 3567 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3568 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3569
e1dccc0d
Z
3570 if (threeargs)
3571 offset = POPi;
79072805
LW
3572 little = POPs;
3573 big = POPs;
73ee8be2
NC
3574 big_p = SvPV_const(big, biglen);
3575 little_p = SvPV_const(little, llen);
3576
e609e586
NC
3577 big_utf8 = DO_UTF8(big);
3578 little_utf8 = DO_UTF8(little);
3579 if (big_utf8 ^ little_utf8) {
3580 /* One needs to be upgraded. */
47e13f24 3581 if (little_utf8 && !IN_ENCODING) {
2f040f7f
NC
3582 /* Well, maybe instead we might be able to downgrade the small
3583 string? */
1eced8f8 3584 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC
3585 &little_utf8);
3586 if (little_utf8) {
3587 /* If the large string is ISO-8859-1, and it's not possible to
3588 convert the small string to ISO-8859-1, then there is no
3589 way that it could be found anywhere by index. */
3590 retval = -1;
3591 goto fail;
3592 }
e609e586 3593
2f040f7f
NC
3594 /* At this point, pv is a malloc()ed string. So donate it to temp
3595 to ensure it will get free()d */
3596 little = temp = newSV(0);
73ee8be2
NC
3597 sv_usepvn(temp, pv, llen);
3598 little_p = SvPVX(little);
e609e586 3599 } else {
73ee8be2
NC
3600 temp = little_utf8
3601 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f 3602
47e13f24 3603 if (IN_ENCODING) {
ad2de1b2 3604 sv_recode_to_utf8(temp, _get_encoding());
2f040f7f
NC
3605 } else {
3606 sv_utf8_upgrade(temp);
3607 }
3608 if (little_utf8) {
3609 big = temp;
3610 big_utf8 = TRUE;
73ee8be2 3611 big_p = SvPV_const(big, biglen);
2f040f7f
NC
3612 } else {
3613 little = temp;
73ee8be2 3614 little_p = SvPV_const(little, llen);
2f040f7f 3615 }
e609e586
NC
3616 }
3617 }
73ee8be2
NC
3618 if (SvGAMAGIC(big)) {
3619 /* Life just becomes a lot easier if I use a temporary here.
3620 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3621 will trigger magic and overloading again, as will fbm_instr()
3622 */
59cd0e26
NC
3623 big = newSVpvn_flags(big_p, biglen,
3624 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3625 big_p = SvPVX(big);
3626 }
e4e44778 3627 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC
3628 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3629 warn on undef, and we've already triggered a warning with the
3630 SvPV_const some lines above. We can't remove that, as we need to
3631 call some SvPV to trigger overloading early and find out if the
3632