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