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