This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make SETi/u/n, (X)PUSHi/u/n more efficient
[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;
28e5dec8 1279#ifdef PERL_PRESERVE_IVUV
01f91bf2 1280 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
1281 /* Unless the left argument is integer in range we are going to have to
1282 use NV maths. Hence only attempt to coerce the right argument if
1283 we know the left is integer. */
1284 /* Left operand is defined, so is it IV? */
01f91bf2 1285 if (SvIV_please_nomg(svl)) {
800401ee
JH
1286 bool auvok = SvUOK(svl);
1287 bool buvok = SvUOK(svr);
28e5dec8
JH
1288 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1289 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1290 UV alow;
1291 UV ahigh;
1292 UV blow;
1293 UV bhigh;
1294
1295 if (auvok) {
800401ee 1296 alow = SvUVX(svl);
28e5dec8 1297 } else {
800401ee 1298 const IV aiv = SvIVX(svl);
28e5dec8
JH
1299 if (aiv >= 0) {
1300 alow = aiv;
1301 auvok = TRUE; /* effectively it's a UV now */
1302 } else {
53e2bfb7
DM
1303 /* abs, auvok == false records sign */
1304 alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
28e5dec8
JH
1305 }
1306 }
1307 if (buvok) {
800401ee 1308 blow = SvUVX(svr);
28e5dec8 1309 } else {
800401ee 1310 const IV biv = SvIVX(svr);
28e5dec8
JH
1311 if (biv >= 0) {
1312 blow = biv;
1313 buvok = TRUE; /* effectively it's a UV now */
1314 } else {
53e2bfb7
DM
1315 /* abs, buvok == false records sign */
1316 blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
28e5dec8
JH
1317 }
1318 }
1319
1320 /* If this does sign extension on unsigned it's time for plan B */
1321 ahigh = alow >> (4 * sizeof (UV));
1322 alow &= botmask;
1323 bhigh = blow >> (4 * sizeof (UV));
1324 blow &= botmask;
1325 if (ahigh && bhigh) {
6f207bd3 1326 NOOP;
28e5dec8
JH
1327 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1328 which is overflow. Drop to NVs below. */
1329 } else if (!ahigh && !bhigh) {
1330 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1331 so the unsigned multiply cannot overflow. */
c445ea15 1332 const UV product = alow * blow;
28e5dec8
JH
1333 if (auvok == buvok) {
1334 /* -ve * -ve or +ve * +ve gives a +ve result. */
1335 SP--;
1336 SETu( product );
1337 RETURN;
1338 } else if (product <= (UV)IV_MIN) {
1339 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1340 /* -ve result, which could overflow an IV */
1341 SP--;
02b08bbc
DM
1342 /* can't negate IV_MIN, but there are aren't two
1343 * integers such that !ahigh && !bhigh, where the
1344 * product equals 0x800....000 */
1345 assert(product != (UV)IV_MIN);
25716404 1346 SETi( -(IV)product );
28e5dec8
JH
1347 RETURN;
1348 } /* else drop to NVs below. */
1349 } else {
1350 /* One operand is large, 1 small */
1351 UV product_middle;
1352 if (bhigh) {
1353 /* swap the operands */
1354 ahigh = bhigh;
1355 bhigh = blow; /* bhigh now the temp var for the swap */
1356 blow = alow;
1357 alow = bhigh;
1358 }
1359 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1360 multiplies can't overflow. shift can, add can, -ve can. */
1361 product_middle = ahigh * blow;
1362 if (!(product_middle & topmask)) {
1363 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1364 UV product_low;
1365 product_middle <<= (4 * sizeof (UV));
1366 product_low = alow * blow;
1367
1368 /* as for pp_add, UV + something mustn't get smaller.
1369 IIRC ANSI mandates this wrapping *behaviour* for
1370 unsigned whatever the actual representation*/
1371 product_low += product_middle;
1372 if (product_low >= product_middle) {
1373 /* didn't overflow */
1374 if (auvok == buvok) {
1375 /* -ve * -ve or +ve * +ve gives a +ve result. */
1376 SP--;
1377 SETu( product_low );
1378 RETURN;
1379 } else if (product_low <= (UV)IV_MIN) {
1380 /* 2s complement assumption again */
1381 /* -ve result, which could overflow an IV */
1382 SP--;
53e2bfb7
DM
1383 SETi(product_low == (UV)IV_MIN
1384 ? IV_MIN : -(IV)product_low);
28e5dec8
JH
1385 RETURN;
1386 } /* else drop to NVs below. */
1387 }
1388 } /* product_middle too large */
1389 } /* ahigh && bhigh */
800401ee
JH
1390 } /* SvIOK(svl) */
1391 } /* SvIOK(svr) */
28e5dec8 1392#endif
a0d0e21e 1393 {
6f1401dc
DM
1394 NV right = SvNV_nomg(svr);
1395 NV left = SvNV_nomg(svl);
4efa5a16 1396 (void)POPs;
3ec400f5
JH
1397#if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN && NVSIZE == 16
1398 {
1399 NV result = left * right;
1400 if (Perl_isinf(result)) {
1401 Zero((U8*)&result + 8, 8, U8);
1402 }
1403 SETn( result );
1404 }
1405#else
a0d0e21e 1406 SETn( left * right );
3ec400f5 1407#endif
a0d0e21e 1408 RETURN;
79072805 1409 }
a0d0e21e
LW
1410}
1411
1412PP(pp_divide)
1413{
20b7effb 1414 dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM
1415 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1416 svr = TOPs;
1417 svl = TOPm1s;
5479d192 1418 /* Only try to do UV divide first
68795e93 1419 if ((SLOPPYDIVIDE is true) or
5479d192
NC
1420 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1421 to preserve))
1422 The assumption is that it is better to use floating point divide
1423 whenever possible, only doing integer divide first if we can't be sure.
1424 If NV_PRESERVES_UV is true then we know at compile time that no UV
1425 can be too large to preserve, so don't need to compile the code to
1426 test the size of UVs. */
1427
a0d0e21e 1428#ifdef SLOPPYDIVIDE
5479d192
NC
1429# define PERL_TRY_UV_DIVIDE
1430 /* ensure that 20./5. == 4. */
a0d0e21e 1431#else
5479d192
NC
1432# ifdef PERL_PRESERVE_IVUV
1433# ifndef NV_PRESERVES_UV
1434# define PERL_TRY_UV_DIVIDE
1435# endif
1436# endif
a0d0e21e 1437#endif
5479d192
NC
1438
1439#ifdef PERL_TRY_UV_DIVIDE
01f91bf2 1440 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
800401ee
JH
1441 bool left_non_neg = SvUOK(svl);
1442 bool right_non_neg = SvUOK(svr);
5479d192
NC
1443 UV left;
1444 UV right;
1445
1446 if (right_non_neg) {
800401ee 1447 right = SvUVX(svr);
5479d192
NC
1448 }
1449 else {
800401ee 1450 const IV biv = SvIVX(svr);
5479d192
NC
1451 if (biv >= 0) {
1452 right = biv;
1453 right_non_neg = TRUE; /* effectively it's a UV now */
1454 }
1455 else {
02b08bbc 1456 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
5479d192
NC
1457 }
1458 }
1459 /* historically undef()/0 gives a "Use of uninitialized value"
1460 warning before dieing, hence this test goes here.
1461 If it were immediately before the second SvIV_please, then
1462 DIE() would be invoked before left was even inspected, so
486ec47a 1463 no inspection would give no warning. */
5479d192
NC
1464 if (right == 0)
1465 DIE(aTHX_ "Illegal division by zero");
1466
1467 if (left_non_neg) {
800401ee 1468 left = SvUVX(svl);
5479d192
NC
1469 }
1470 else {
800401ee 1471 const IV aiv = SvIVX(svl);
5479d192
NC
1472 if (aiv >= 0) {
1473 left = aiv;
1474 left_non_neg = TRUE; /* effectively it's a UV now */
1475 }
1476 else {
02b08bbc 1477 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
5479d192
NC
1478 }
1479 }
1480
1481 if (left >= right
1482#ifdef SLOPPYDIVIDE
1483 /* For sloppy divide we always attempt integer division. */
1484#else
1485 /* Otherwise we only attempt it if either or both operands
1486 would not be preserved by an NV. If both fit in NVs
0c2ee62a
NC
1487 we fall through to the NV divide code below. However,
1488 as left >= right to ensure integer result here, we know that
1489 we can skip the test on the right operand - right big
1490 enough not to be preserved can't get here unless left is
1491 also too big. */
1492
1493 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
5479d192
NC
1494#endif
1495 ) {
1496 /* Integer division can't overflow, but it can be imprecise. */
1b6737cc 1497 const UV result = left / right;
5479d192
NC
1498 if (result * right == left) {
1499 SP--; /* result is valid */
1500 if (left_non_neg == right_non_neg) {
1501 /* signs identical, result is positive. */
1502 SETu( result );
1503 RETURN;
1504 }
1505 /* 2s complement assumption */
1506 if (result <= (UV)IV_MIN)
02b08bbc 1507 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
5479d192
NC
1508 else {
1509 /* It's exact but too negative for IV. */
1510 SETn( -(NV)result );
1511 }
1512 RETURN;
1513 } /* tried integer divide but it was not an integer result */
32fdb065 1514 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
01f91bf2 1515 } /* one operand wasn't SvIOK */
5479d192
NC
1516#endif /* PERL_TRY_UV_DIVIDE */
1517 {
6f1401dc
DM
1518 NV right = SvNV_nomg(svr);
1519 NV left = SvNV_nomg(svl);
4efa5a16 1520 (void)POPs;(void)POPs;
ebc6a117
PD
1521#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1522 if (! Perl_isnan(right) && right == 0.0)
1523#else
659c4b96 1524 if (right == 0.0)
ebc6a117 1525#endif
5479d192
NC
1526 DIE(aTHX_ "Illegal division by zero");
1527 PUSHn( left / right );
1528 RETURN;
79072805 1529 }
a0d0e21e
LW
1530}
1531
1532PP(pp_modulo)
1533{
20b7effb 1534 dSP; dATARGET;
6f1401dc 1535 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
a0d0e21e 1536 {
9c5ffd7c
JH
1537 UV left = 0;
1538 UV right = 0;
dc656993
JH
1539 bool left_neg = FALSE;
1540 bool right_neg = FALSE;
e2c88acc
NC
1541 bool use_double = FALSE;
1542 bool dright_valid = FALSE;
9c5ffd7c
JH
1543 NV dright = 0.0;
1544 NV dleft = 0.0;
6f1401dc
DM
1545 SV * const svr = TOPs;
1546 SV * const svl = TOPm1s;
01f91bf2 1547 if (SvIV_please_nomg(svr)) {
800401ee 1548 right_neg = !SvUOK(svr);
e2c88acc 1549 if (!right_neg) {
800401ee 1550 right = SvUVX(svr);
e2c88acc 1551 } else {
800401ee 1552 const IV biv = SvIVX(svr);
e2c88acc
NC
1553 if (biv >= 0) {
1554 right = biv;
1555 right_neg = FALSE; /* effectively it's a UV now */
1556 } else {
02b08bbc 1557 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
e2c88acc
NC
1558 }
1559 }
1560 }
1561 else {
6f1401dc 1562 dright = SvNV_nomg(svr);
787eafbd
IZ
1563 right_neg = dright < 0;
1564 if (right_neg)
1565 dright = -dright;
e2c88acc
NC
1566 if (dright < UV_MAX_P1) {
1567 right = U_V(dright);
1568 dright_valid = TRUE; /* In case we need to use double below. */
1569 } else {
1570 use_double = TRUE;
1571 }
787eafbd 1572 }
a0d0e21e 1573
e2c88acc
NC
1574 /* At this point use_double is only true if right is out of range for
1575 a UV. In range NV has been rounded down to nearest UV and
1576 use_double false. */
01f91bf2 1577 if (!use_double && SvIV_please_nomg(svl)) {
800401ee 1578 left_neg = !SvUOK(svl);
e2c88acc 1579 if (!left_neg) {
800401ee 1580 left = SvUVX(svl);
e2c88acc 1581 } else {
800401ee 1582 const IV aiv = SvIVX(svl);
e2c88acc
NC
1583 if (aiv >= 0) {
1584 left = aiv;
1585 left_neg = FALSE; /* effectively it's a UV now */
1586 } else {
02b08bbc 1587 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
e2c88acc
NC
1588 }
1589 }
e2c88acc 1590 }
787eafbd 1591 else {
6f1401dc 1592 dleft = SvNV_nomg(svl);
787eafbd
IZ
1593 left_neg = dleft < 0;
1594 if (left_neg)
1595 dleft = -dleft;
68dc0745 1596
e2c88acc
NC
1597 /* This should be exactly the 5.6 behaviour - if left and right are
1598 both in range for UV then use U_V() rather than floor. */
1599 if (!use_double) {
1600 if (dleft < UV_MAX_P1) {
1601 /* right was in range, so is dleft, so use UVs not double.
1602 */
1603 left = U_V(dleft);
1604 }
1605 /* left is out of range for UV, right was in range, so promote
1606 right (back) to double. */
1607 else {
1608 /* The +0.5 is used in 5.6 even though it is not strictly
1609 consistent with the implicit +0 floor in the U_V()
1610 inside the #if 1. */
1611 dleft = Perl_floor(dleft + 0.5);
1612 use_double = TRUE;
1613 if (dright_valid)
1614 dright = Perl_floor(dright + 0.5);
1615 else
1616 dright = right;
1617 }
1618 }
1619 }
6f1401dc 1620 sp -= 2;
787eafbd 1621 if (use_double) {
65202027 1622 NV dans;
787eafbd 1623
659c4b96 1624 if (!dright)
cea2e8a9 1625 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1626
65202027 1627 dans = Perl_fmod(dleft, dright);
659c4b96 1628 if ((left_neg != right_neg) && dans)
787eafbd
IZ
1629 dans = dright - dans;
1630 if (right_neg)
1631 dans = -dans;
1632 sv_setnv(TARG, dans);
1633 }
1634 else {
1635 UV ans;
1636
787eafbd 1637 if (!right)
cea2e8a9 1638 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ
1639
1640 ans = left % right;
1641 if ((left_neg != right_neg) && ans)
1642 ans = right - ans;
1643 if (right_neg) {
1644 /* XXX may warn: unary minus operator applied to unsigned type */
1645 /* could change -foo to be (~foo)+1 instead */
1646 if (ans <= ~((UV)IV_MAX)+1)
1647 sv_setiv(TARG, ~ans+1);
1648 else
65202027 1649 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ
1650 }
1651 else
1652 sv_setuv(TARG, ans);
1653 }
1654 PUSHTARG;
1655 RETURN;
79072805 1656 }
a0d0e21e 1657}
79072805 1658
a0d0e21e
LW
1659PP(pp_repeat)
1660{
20b7effb 1661 dSP; dATARGET;
eb578fdb 1662 IV count;
6f1401dc 1663 SV *sv;
02a7a248 1664 bool infnan = FALSE;
6f1401dc 1665
82334630 1666 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
6f1401dc
DM
1667 /* TODO: think of some way of doing list-repeat overloading ??? */
1668 sv = POPs;
1669 SvGETMAGIC(sv);
1670 }
1671 else {
3a100dab
FC
1672 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1673 /* The parser saw this as a list repeat, and there
1674 are probably several items on the stack. But we're
1675 in scalar/void context, and there's no pp_list to save us
1676 now. So drop the rest of the items -- robin@kitsite.com
1677 */
1678 dMARK;
1679 if (MARK + 1 < SP) {
1680 MARK[1] = TOPm1s;
1681 MARK[2] = TOPs;
1682 }
1683 else {
1684 dTOPss;
1685 ASSUME(MARK + 1 == SP);
1686 XPUSHs(sv);
1687 MARK[1] = &PL_sv_undef;
1688 }
1689 SP = MARK + 2;
1690 }
6f1401dc
DM
1691 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1692 sv = POPs;
1693 }
1694
2b573ace
JH
1695 if (SvIOKp(sv)) {
1696 if (SvUOK(sv)) {
6f1401dc 1697 const UV uv = SvUV_nomg(sv);
2b573ace
JH
1698 if (uv > IV_MAX)
1699 count = IV_MAX; /* The best we can do? */
1700 else
1701 count = uv;
1702 } else {
b3211734 1703 count = SvIV_nomg(sv);
2b573ace
JH
1704 }
1705 }
1706 else if (SvNOKp(sv)) {
02a7a248
JH
1707 const NV nv = SvNV_nomg(sv);
1708 infnan = Perl_isinfnan(nv);
1709 if (UNLIKELY(infnan)) {
1710 count = 0;
1711 } else {
1712 if (nv < 0.0)
1713 count = -1; /* An arbitrary negative integer */
1714 else
1715 count = (IV)nv;
1716 }
2b573ace
JH
1717 }
1718 else
02a7a248 1719 count = SvIV_nomg(sv);
6f1401dc 1720
02a7a248
JH
1721 if (infnan) {
1722 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1723 "Non-finite repeat count does nothing");
1724 } else if (count < 0) {
b3211734
KW
1725 count = 0;
1726 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
02a7a248 1727 "Negative repeat count does nothing");
b3211734
KW
1728 }
1729
82334630 1730 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e 1731 dMARK;
052a7c76 1732 const SSize_t items = SP - MARK;
da9e430b 1733 const U8 mod = PL_op->op_flags & OPf_MOD;
79072805 1734
a0d0e21e 1735 if (count > 1) {
052a7c76 1736 SSize_t max;
b3b27d01 1737
052a7c76
DM
1738 if ( items > SSize_t_MAX / count /* max would overflow */
1739 /* repeatcpy would overflow */
1740 || items > I32_MAX / (I32)sizeof(SV *)
b3b27d01
DM
1741 )
1742 Perl_croak(aTHX_ "%s","Out of memory during list extend");
1743 max = items * count;
1744 MEXTEND(MARK, max);
1745
a0d0e21e 1746 while (SP > MARK) {
60779a30
DM
1747 if (*SP) {
1748 if (mod && SvPADTMP(*SP)) {
da9e430b 1749 *SP = sv_mortalcopy(*SP);
60779a30 1750 }
976c8a39 1751 SvTEMP_off((*SP));
da9e430b 1752 }
a0d0e21e 1753 SP--;
79072805 1754 }
a0d0e21e
LW
1755 MARK++;
1756 repeatcpy((char*)(MARK + items), (char*)MARK,
ad64d0ec 1757 items * sizeof(const SV *), count - 1);
a0d0e21e 1758 SP += max;
79072805 1759 }
a0d0e21e 1760 else if (count <= 0)
052a7c76 1761 SP = MARK;
79072805 1762 }
a0d0e21e 1763 else { /* Note: mark already snarfed by pp_list */
0bd48802 1764 SV * const tmpstr = POPs;
a0d0e21e 1765 STRLEN len;
9b877dbb 1766 bool isutf;
a0d0e21e 1767
6f1401dc
DM
1768 if (TARG != tmpstr)
1769 sv_setsv_nomg(TARG, tmpstr);
1770 SvPV_force_nomg(TARG, len);
9b877dbb 1771 isutf = DO_UTF8(TARG);
8ebc5c01
PP
1772 if (count != 1) {
1773 if (count < 1)
1774 SvCUR_set(TARG, 0);
1775 else {
b3b27d01
DM
1776 STRLEN max;
1777
1778 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1779 || len > (U32)I32_MAX /* repeatcpy would overflow */
1780 )
1781 Perl_croak(aTHX_ "%s",
1782 "Out of memory during string extend");
1783 max = (UV)count * len + 1;
1784 SvGROW(TARG, max);
1785
a0d0e21e 1786 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
b162af07 1787 SvCUR_set(TARG, SvCUR(TARG) * count);
7a4c00b4 1788 }
a0d0e21e 1789 *SvEND(TARG) = '\0';
a0d0e21e 1790 }
dfcb284a
GS
1791 if (isutf)
1792 (void)SvPOK_only_UTF8(TARG);
1793 else
1794 (void)SvPOK_only(TARG);
b80b6069 1795
a0d0e21e 1796 PUSHTARG;
79072805 1797 }
a0d0e21e
LW
1798 RETURN;
1799}
79072805 1800
a0d0e21e
LW
1801PP(pp_subtract)
1802{
20b7effb 1803 dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
1804 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1805 svr = TOPs;
1806 svl = TOPm1s;
800401ee 1807 useleft = USE_LEFT(svl);
28e5dec8 1808#ifdef PERL_PRESERVE_IVUV
7dca457a
NC
1809 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1810 "bad things" happen if you rely on signed integers wrapping. */
01f91bf2 1811 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
1812 /* Unless the left argument is integer in range we are going to have to
1813 use NV maths. Hence only attempt to coerce the right argument if
1814 we know the left is integer. */
eb578fdb 1815 UV auv = 0;
9c5ffd7c 1816 bool auvok = FALSE;
7dca457a
NC
1817 bool a_valid = 0;
1818
28e5dec8 1819 if (!useleft) {
7dca457a
NC
1820 auv = 0;
1821 a_valid = auvok = 1;
1822 /* left operand is undef, treat as zero. */
28e5dec8
JH
1823 } else {
1824 /* Left operand is defined, so is it IV? */
01f91bf2 1825 if (SvIV_please_nomg(svl)) {
800401ee
JH
1826 if ((auvok = SvUOK(svl)))
1827 auv = SvUVX(svl);
7dca457a 1828 else {
eb578fdb 1829 const IV aiv = SvIVX(svl);
7dca457a
NC
1830 if (aiv >= 0) {
1831 auv = aiv;
1832 auvok = 1; /* Now acting as a sign flag. */
1833 } else { /* 2s complement assumption for IV_MIN */
53e2bfb7 1834 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
28e5dec8 1835 }
7dca457a
NC
1836 }
1837 a_valid = 1;
1838 }
1839 }
1840 if (a_valid) {
1841 bool result_good = 0;
1842 UV result;
eb578fdb 1843 UV buv;
800401ee 1844 bool buvok = SvUOK(svr);
9041c2e3 1845
7dca457a 1846 if (buvok)
800401ee 1847 buv = SvUVX(svr);
7dca457a 1848 else {
eb578fdb 1849 const IV biv = SvIVX(svr);
7dca457a
NC
1850 if (biv >= 0) {
1851 buv = biv;
1852 buvok = 1;
1853 } else
53e2bfb7 1854 buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
7dca457a
NC
1855 }
1856 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1857 else "IV" now, independent of how it came in.
7dca457a
NC
1858 if a, b represents positive, A, B negative, a maps to -A etc
1859 a - b => (a - b)
1860 A - b => -(a + b)
1861 a - B => (a + b)
1862 A - B => -(a - b)
1863 all UV maths. negate result if A negative.
1864 subtract if signs same, add if signs differ. */
1865
1866 if (auvok ^ buvok) {
1867 /* Signs differ. */
1868 result = auv + buv;
1869 if (result >= auv)
1870 result_good = 1;
1871 } else {
1872 /* Signs same */
1873 if (auv >= buv) {
1874 result = auv - buv;
1875 /* Must get smaller */
1876 if (result <= auv)
1877 result_good = 1;
1878 } else {
1879 result = buv - auv;
1880 if (result <= buv) {
1881 /* result really should be -(auv-buv). as its negation
1882 of true value, need to swap our result flag */
1883 auvok = !auvok;
1884 result_good = 1;
28e5dec8 1885 }
28e5dec8
JH
1886 }
1887 }
7dca457a
NC
1888 if (result_good) {
1889 SP--;
1890 if (auvok)
1891 SETu( result );
1892 else {
1893 /* Negate result */
1894 if (result <= (UV)IV_MIN)
53e2bfb7
DM
1895 SETi(result == (UV)IV_MIN
1896 ? IV_MIN : -(IV)result);
7dca457a
NC
1897 else {
1898 /* result valid, but out of range for IV. */
1899 SETn( -(NV)result );
1900 }
1901 }
1902 RETURN;
1903 } /* Overflow, drop through to NVs. */
28e5dec8
JH
1904 }
1905 }
1906#endif
a0d0e21e 1907 {
6f1401dc 1908 NV value = SvNV_nomg(svr);
4efa5a16
RD
1909 (void)POPs;
1910
28e5dec8
JH
1911 if (!useleft) {
1912 /* left operand is undef, treat as zero - value */
1913 SETn(-value);
1914 RETURN;
1915 }
6f1401dc 1916 SETn( SvNV_nomg(svl) - value );
28e5dec8 1917 RETURN;
79072805 1918 }
a0d0e21e 1919}
79072805 1920
b3498293
JH
1921#define IV_BITS (IVSIZE * 8)
1922
1923static UV S_uv_shift(UV uv, int shift, bool left)
1924{
1925 if (shift < 0) {
1926 shift = -shift;
1927 left = !left;
1928 }
1929 if (shift >= IV_BITS) {
1930 return 0;
1931 }
1932 return left ? uv << shift : uv >> shift;
1933}
1934
1935static IV S_iv_shift(IV iv, int shift, bool left)
1936{
1937 if (shift < 0) {
1938 shift = -shift;
1939 left = !left;
1940 }
1941 if (shift >= IV_BITS) {
b69687e7 1942 return iv < 0 && !left ? -1 : 0;
b3498293
JH
1943 }
1944 return left ? iv << shift : iv >> shift;
1945}
1946
1947#define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
1948#define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
1949#define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
1950#define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
1951
a0d0e21e
LW
1952PP(pp_left_shift)
1953{
20b7effb 1954 dSP; dATARGET; SV *svl, *svr;
a42d0242 1955 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
1956 svr = POPs;
1957 svl = TOPs;
a0d0e21e 1958 {
6f1401dc 1959 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1960 if (PL_op->op_private & HINT_INTEGER) {
b3498293 1961 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
d0ba1bd2
JH
1962 }
1963 else {
b3498293 1964 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
d0ba1bd2 1965 }
55497cff 1966 RETURN;
79072805 1967 }
a0d0e21e 1968}
79072805 1969
a0d0e21e
LW
1970PP(pp_right_shift)
1971{
20b7effb 1972 dSP; dATARGET; SV *svl, *svr;
a42d0242 1973 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
1974 svr = POPs;
1975 svl = TOPs;
a0d0e21e 1976 {
6f1401dc 1977 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1978 if (PL_op->op_private & HINT_INTEGER) {
b3498293 1979 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
d0ba1bd2
JH
1980 }
1981 else {
b3498293 1982 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
d0ba1bd2 1983 }
a0d0e21e 1984 RETURN;
93a17b20 1985 }
79072805
LW
1986}
1987
a0d0e21e 1988PP(pp_lt)
79072805 1989{
20b7effb 1990 dSP;
33efebe6
DM
1991 SV *left, *right;
1992
a42d0242 1993 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
1994 right = POPs;
1995 left = TOPs;
1996 SETs(boolSV(
1997 (SvIOK_notUV(left) && SvIOK_notUV(right))
1998 ? (SvIVX(left) < SvIVX(right))
1999 : (do_ncmp(left, right) == -1)
2000 ));
2001 RETURN;
a0d0e21e 2002}
79072805 2003
a0d0e21e
LW
2004PP(pp_gt)
2005{
20b7effb 2006 dSP;
33efebe6 2007 SV *left, *right;
1b6737cc 2008
33efebe6
DM
2009 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2010 right = POPs;
2011 left = TOPs;
2012 SETs(boolSV(
2013 (SvIOK_notUV(left) && SvIOK_notUV(right))
2014 ? (SvIVX(left) > SvIVX(right))
2015 : (do_ncmp(left, right) == 1)
2016 ));
2017 RETURN;
a0d0e21e
LW
2018}
2019
2020PP(pp_le)
2021{
20b7effb 2022 dSP;
33efebe6 2023 SV *left, *right;
1b6737cc 2024
33efebe6
DM
2025 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2026 right = POPs;
2027 left = TOPs;
2028 SETs(boolSV(
2029 (SvIOK_notUV(left) && SvIOK_notUV(right))
2030 ? (SvIVX(left) <= SvIVX(right))
2031 : (do_ncmp(left, right) <= 0)
2032 ));
2033 RETURN;
a0d0e21e
LW
2034}
2035
2036PP(pp_ge)
2037{
20b7effb 2038 dSP;
33efebe6
DM
2039 SV *left, *right;
2040
2041 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2042 right = POPs;
2043 left = TOPs;
2044 SETs(boolSV(
2045 (SvIOK_notUV(left) && SvIOK_notUV(right))
2046 ? (SvIVX(left) >= SvIVX(right))
2047 : ( (do_ncmp(left, right) & 2) == 0)
2048 ));
2049 RETURN;
2050}
1b6737cc 2051
33efebe6
DM
2052PP(pp_ne)
2053{
20b7effb 2054 dSP;
33efebe6
DM
2055 SV *left, *right;
2056
2057 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2058 right = POPs;
2059 left = TOPs;
2060 SETs(boolSV(
2061 (SvIOK_notUV(left) && SvIOK_notUV(right))
2062 ? (SvIVX(left) != SvIVX(right))
2063 : (do_ncmp(left, right) != 0)
2064 ));
2065 RETURN;
2066}
1b6737cc 2067
33efebe6
DM
2068/* compare left and right SVs. Returns:
2069 * -1: <
2070 * 0: ==
2071 * 1: >
2072 * 2: left or right was a NaN
2073 */
2074I32
2075Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2076{
33efebe6
DM
2077 PERL_ARGS_ASSERT_DO_NCMP;
2078#ifdef PERL_PRESERVE_IVUV
33efebe6 2079 /* Fortunately it seems NaN isn't IOK */
01f91bf2 2080 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
33efebe6
DM
2081 if (!SvUOK(left)) {
2082 const IV leftiv = SvIVX(left);
2083 if (!SvUOK(right)) {
2084 /* ## IV <=> IV ## */
2085 const IV rightiv = SvIVX(right);
2086 return (leftiv > rightiv) - (leftiv < rightiv);
28e5dec8 2087 }
33efebe6
DM
2088 /* ## IV <=> UV ## */
2089 if (leftiv < 0)
2090 /* As (b) is a UV, it's >=0, so it must be < */
2091 return -1;
2092 {
2093 const UV rightuv = SvUVX(right);
2094 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
28e5dec8 2095 }
28e5dec8 2096 }
79072805 2097
33efebe6
DM
2098 if (SvUOK(right)) {
2099 /* ## UV <=> UV ## */
2100 const UV leftuv = SvUVX(left);
2101 const UV rightuv = SvUVX(right);
2102 return (leftuv > rightuv) - (leftuv < rightuv);
28e5dec8 2103 }
33efebe6
DM
2104 /* ## UV <=> IV ## */
2105 {
2106 const IV rightiv = SvIVX(right);
2107 if (rightiv < 0)
2108 /* As (a) is a UV, it's >=0, so it cannot be < */
2109 return 1;
2110 {
2111 const UV leftuv = SvUVX(left);
2112 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
28e5dec8 2113 }
28e5dec8 2114 }
e5964223 2115 NOT_REACHED; /* NOTREACHED */
28e5dec8
JH
2116 }
2117#endif
a0d0e21e 2118 {
33efebe6
DM
2119 NV const rnv = SvNV_nomg(right);
2120 NV const lnv = SvNV_nomg(left);
2121
cab190d4 2122#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
33efebe6
DM
2123 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2124 return 2;
2125 }
2126 return (lnv > rnv) - (lnv < rnv);
cab190d4 2127#else
33efebe6
DM
2128 if (lnv < rnv)
2129 return -1;
2130 if (lnv > rnv)
2131 return 1;
659c4b96 2132 if (lnv == rnv)
33efebe6
DM
2133 return 0;
2134 return 2;
cab190d4 2135#endif
a0d0e21e 2136 }
79072805
LW
2137}
2138
33efebe6 2139
a0d0e21e 2140PP(pp_ncmp)
79072805 2141{
20b7effb 2142 dSP;
33efebe6
DM
2143 SV *left, *right;
2144 I32 value;
a42d0242 2145 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
33efebe6
DM
2146 right = POPs;
2147 left = TOPs;
2148 value = do_ncmp(left, right);
2149 if (value == 2) {
3280af22 2150 SETs(&PL_sv_undef);
79072805 2151 }
33efebe6
DM
2152 else {
2153 dTARGET;
2154 SETi(value);
2155 }
2156 RETURN;
a0d0e21e 2157}
79072805 2158
b1c05ba5
DM
2159
2160/* also used for: pp_sge() pp_sgt() pp_slt() */
2161
afd9910b 2162PP(pp_sle)
a0d0e21e 2163{
20b7effb 2164 dSP;
79072805 2165
afd9910b
NC
2166 int amg_type = sle_amg;
2167 int multiplier = 1;
2168 int rhs = 1;
79072805 2169
afd9910b
NC
2170 switch (PL_op->op_type) {
2171 case OP_SLT:
2172 amg_type = slt_amg;
2173 /* cmp < 0 */
2174 rhs = 0;
2175 break;
2176 case OP_SGT:
2177 amg_type = sgt_amg;
2178 /* cmp > 0 */
2179 multiplier = -1;
2180 rhs = 0;
2181 break;
2182 case OP_SGE:
2183 amg_type = sge_amg;
2184 /* cmp >= 0 */
2185 multiplier = -1;
2186 break;
79072805 2187 }
79072805 2188
6f1401dc 2189 tryAMAGICbin_MG(amg_type, AMGf_set);
a0d0e21e
LW
2190 {
2191 dPOPTOPssrl;
130c5df3 2192 const int cmp =
5778acb6 2193#ifdef USE_LOCALE_COLLATE
130c5df3
KW
2194 (IN_LC_RUNTIME(LC_COLLATE))
2195 ? sv_cmp_locale_flags(left, right, 0)
2196 :
2197#endif
2198 sv_cmp_flags(left, right, 0);
afd9910b 2199 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW
2200 RETURN;
2201 }
2202}
79072805 2203
36477c24
PP
2204PP(pp_seq)
2205{
20b7effb 2206 dSP;
6f1401dc 2207 tryAMAGICbin_MG(seq_amg, AMGf_set);
36477c24
PP
2208 {
2209 dPOPTOPssrl;
078504b2 2210 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW
2211 RETURN;
2212 }
2213}
79072805 2214
a0d0e21e 2215PP(pp_sne)
79072805 2216{
20b7effb 2217 dSP;
6f1401dc 2218 tryAMAGICbin_MG(sne_amg, AMGf_set);
a0d0e21e
LW
2219 {
2220 dPOPTOPssrl;
078504b2 2221 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2222 RETURN;
463ee0b2 2223 }
79072805
LW
2224}
2225
a0d0e21e 2226PP(pp_scmp)
79072805 2227{
20b7effb 2228 dSP; dTARGET;
6f1401dc 2229 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW
2230 {
2231 dPOPTOPssrl;
130c5df3 2232 const int cmp =
5778acb6 2233#ifdef USE_LOCALE_COLLATE
130c5df3
KW
2234 (IN_LC_RUNTIME(LC_COLLATE))
2235 ? sv_cmp_locale_flags(left, right, 0)
2236 :
2237#endif
2238 sv_cmp_flags(left, right, 0);
bbce6d69 2239 SETi( cmp );
a0d0e21e
LW
2240 RETURN;
2241 }
2242}
79072805 2243
55497cff
PP
2244PP(pp_bit_and)
2245{
20b7effb 2246 dSP; dATARGET;
6f1401dc 2247 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW
2248 {
2249 dPOPTOPssrl;
4633a7c4 2250 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2251 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2252 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2253 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2254 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2255 SETi(i);
d0ba1bd2
JH
2256 }
2257 else {
1b6737cc 2258 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2259 SETu(u);
d0ba1bd2 2260 }
5ee80e13 2261 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2262 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2263 }
2264 else {
533c011a 2265 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2266 SETTARG;
2267 }
2268 RETURN;
2269 }
2270}
79072805 2271
5d01050a
FC
2272PP(pp_nbit_and)
2273{
2274 dSP;
636ac8fc 2275 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
5d01050a
FC
2276 {
2277 dATARGET; dPOPTOPssrl;
2278 if (PL_op->op_private & HINT_INTEGER) {
2279 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2280 SETi(i);
2281 }
2282 else {
2283 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2284 SETu(u);
2285 }
2286 }
2287 RETURN;
2288}
2289
2290PP(pp_sbit_and)
2291{
2292 dSP;
2293 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2294 {
2295 dATARGET; dPOPTOPssrl;
2296 do_vop(OP_BIT_AND, TARG, left, right);
2297 RETSETTARG;
2298 }
2299}
b1c05ba5
DM
2300
2301/* also used for: pp_bit_xor() */
2302
a0d0e21e
LW
2303PP(pp_bit_or)
2304{
20b7effb 2305 dSP; dATARGET;
3658c1f1
NC
2306 const int op_type = PL_op->op_type;
2307
6f1401dc 2308 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW
2309 {
2310 dPOPTOPssrl;
4633a7c4 2311 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2312 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2313 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2314 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC
2315 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2316 const IV r = SvIV_nomg(right);
2317 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2318 SETi(result);
d0ba1bd2
JH
2319 }
2320 else {
3658c1f1
NC
2321 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2322 const UV r = SvUV_nomg(right);
2323 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2324 SETu(result);
d0ba1bd2 2325 }
5ee80e13 2326 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2327 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2328 }
2329 else {
3658c1f1 2330 do_vop(op_type, TARG, left, right);
a0d0e21e
LW
2331 SETTARG;
2332 }
2333 RETURN;
79072805 2334 }
a0d0e21e 2335}
79072805 2336
5d01050a
FC
2337/* also used for: pp_nbit_xor() */
2338
2339PP(pp_nbit_or)
2340{
2341 dSP;
2342 const int op_type = PL_op->op_type;
2343
2344 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
636ac8fc 2345 AMGf_assign|AMGf_numarg);
5d01050a
FC
2346 {
2347 dATARGET; dPOPTOPssrl;
2348 if (PL_op->op_private & HINT_INTEGER) {
2349 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2350 const IV r = SvIV_nomg(right);
2351 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2352 SETi(result);
2353 }
2354 else {
2355 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2356 const UV r = SvUV_nomg(right);
2357 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2358 SETu(result);
2359 }
2360 }
2361 RETURN;
2362}
2363
2364/* also used for: pp_sbit_xor() */
2365
2366PP(pp_sbit_or)
2367{
2368 dSP;
2369 const int op_type = PL_op->op_type;
2370
2371 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2372 AMGf_assign);
2373 {
2374 dATARGET; dPOPTOPssrl;
2375 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2376 right);
2377 RETSETTARG;
2378 }
2379}
2380
1c2b3fd6
FC
2381PERL_STATIC_INLINE bool
2382S_negate_string(pTHX)
2383{
2384 dTARGET; dSP;
2385 STRLEN len;
2386 const char *s;
2387 SV * const sv = TOPs;
2388 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2389 return FALSE;
2390 s = SvPV_nomg_const(sv, len);
2391 if (isIDFIRST(*s)) {
2392 sv_setpvs(TARG, "-");
2393 sv_catsv(TARG, sv);
2394 }
2395 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2396 sv_setsv_nomg(TARG, sv);
2397 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2398 }
2399 else return FALSE;
245d035e 2400 SETTARG;
1c2b3fd6
FC
2401 return TRUE;
2402}
2403
a0d0e21e
LW
2404PP(pp_negate)
2405{
20b7effb 2406 dSP; dTARGET;
6f1401dc 2407 tryAMAGICun_MG(neg_amg, AMGf_numeric);
1c2b3fd6 2408 if (S_negate_string(aTHX)) return NORMAL;
a0d0e21e 2409 {
6f1401dc 2410 SV * const sv = TOPs;
a5b92898 2411
d96ab1b5 2412 if (SvIOK(sv)) {
7dbe3150 2413 /* It's publicly an integer */
28e5dec8 2414 oops_its_an_int:
9b0e499b
GS
2415 if (SvIsUV(sv)) {
2416 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2417 /* 2s complement assumption. */
d14578b8
KW
2418 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2419 IV_MIN */
245d035e 2420 return NORMAL;
9b0e499b
GS
2421 }
2422 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2423 SETi(-SvIVX(sv));
245d035e 2424 return NORMAL;
9b0e499b
GS
2425 }
2426 }
2427 else if (SvIVX(sv) != IV_MIN) {
2428 SETi(-SvIVX(sv));
245d035e 2429 return NORMAL;
9b0e499b 2430 }
28e5dec8
JH
2431#ifdef PERL_PRESERVE_IVUV
2432 else {
2433 SETu((UV)IV_MIN);
245d035e 2434 return NORMAL;
28e5dec8
JH
2435 }
2436#endif
9b0e499b 2437 }
8a5decd8 2438 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
6f1401dc 2439 SETn(-SvNV_nomg(sv));
1c2b3fd6 2440 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
8eb28a70 2441 goto oops_its_an_int;
4633a7c4 2442 else
6f1401dc 2443 SETn(-SvNV_nomg(sv));
79072805 2444 }
245d035e 2445 return NORMAL;
79072805
LW
2446}
2447
a0d0e21e 2448PP(pp_not)
79072805 2449{
20b7effb 2450 dSP;
6f1401dc 2451 tryAMAGICun_MG(not_amg, AMGf_set);
06c841cf 2452 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
a0d0e21e 2453 return NORMAL;
79072805
LW
2454}
2455
5d01050a
FC
2456static void
2457S_scomplement(pTHX_ SV *targ, SV *sv)
79072805 2458{
eb578fdb
KW
2459 U8 *tmps;
2460 I32 anum;
a0d0e21e
LW
2461 STRLEN len;
2462
85b0ee6e
FC
2463 sv_copypv_nomg(TARG, sv);
2464 tmps = (U8*)SvPV_nomg(TARG, len);
a0d0e21e 2465 anum = len;
1d68d6cd 2466 if (SvUTF8(TARG)) {
a1ca4561 2467 /* Calculate exact length, let's not estimate. */
1d68d6cd 2468 STRLEN targlen = 0;
ba210ebe 2469 STRLEN l;
a1ca4561
YST
2470 UV nchar = 0;
2471 UV nwide = 0;
01f6e806 2472 U8 * const send = tmps + len;
74d49cd0
ST
2473 U8 * const origtmps = tmps;
2474 const UV utf8flags = UTF8_ALLOW_ANYUV;
1d68d6cd 2475
1d68d6cd 2476 while (tmps < send) {
74d49cd0
ST
2477 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2478 tmps += l;
5f560d8a 2479 targlen += UVCHR_SKIP(~c);
a1ca4561
YST
2480 nchar++;
2481 if (c > 0xff)
2482 nwide++;
1d68d6cd
SC
2483 }
2484
2485 /* Now rewind strings and write them. */
74d49cd0 2486 tmps = origtmps;
a1ca4561
YST
2487
2488 if (nwide) {
01f6e806
AL
2489 U8 *result;
2490 U8 *p;
2491
74d49cd0 2492 Newx(result, targlen + 1, U8);
01f6e806 2493 p = result;
a1ca4561 2494 while (tmps < send) {
74d49cd0
ST
2495 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2496 tmps += l;
01f6e806 2497 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
a1ca4561 2498 }
01f6e806 2499 *p = '\0';
c1c21316
NC
2500 sv_usepvn_flags(TARG, (char*)result, targlen,
2501 SV_HAS_TRAILING_NUL);
a1ca4561
YST
2502 SvUTF8_on(TARG);
2503 }
2504 else {
01f6e806
AL
2505 U8 *result;
2506 U8 *p;
2507
74d49cd0 2508 Newx(result, nchar + 1, U8);
01f6e806 2509 p = result;
a1ca4561 2510 while (tmps < send) {
74d49cd0
ST
2511 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2512 tmps += l;
01f6e806 2513 *p++ = ~c;
a1ca4561 2514 }
01f6e806 2515 *p = '\0';
c1c21316 2516 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
d0a21e00 2517 SvUTF8_off(TARG);
1d68d6cd 2518 }
5d01050a 2519 return;
1d68d6cd 2520 }
a0d0e21e 2521#ifdef LIBERAL
51723571 2522 {
eb578fdb 2523 long *tmpl;
51723571
JH
2524 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2525 *tmps = ~*tmps;
2526 tmpl = (long*)tmps;
bb7a0f54 2527 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH
2528 *tmpl = ~*tmpl;
2529 tmps = (U8*)tmpl;
2530 }
a0d0e21e
LW
2531#endif
2532 for ( ; anum > 0; anum--, tmps++)
2533 *tmps = ~*tmps;
5d01050a
FC
2534}
2535
2536PP(pp_complement)
2537{
2538 dSP; dTARGET;
2539 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2540 {
2541 dTOPss;
2542 if (SvNIOKp(sv)) {
2543 if (PL_op->op_private & HINT_INTEGER) {
2544 const IV i = ~SvIV_nomg(sv);
2545 SETi(i);
2546 }
2547 else {
2548 const UV u = ~SvUV_nomg(sv);
2549 SETu(u);
2550 }
2551 }
2552 else {
2553 S_scomplement(aTHX_ TARG, sv);
ec93b65f 2554 SETTARG;
a0d0e21e 2555 }
24840750 2556 return NORMAL;
5d01050a
FC
2557 }
2558}
2559
2560PP(pp_ncomplement)
2561{
2562 dSP;
636ac8fc 2563 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
5d01050a
FC
2564 {
2565 dTARGET; dTOPss;
2566 if (PL_op->op_private & HINT_INTEGER) {
2567 const IV i = ~SvIV_nomg(sv);
2568 SETi(i);
2569 }
2570 else {
2571 const UV u = ~SvUV_nomg(sv);
2572 SETu(u);
2573 }
2574 }
2575 return NORMAL;
2576}
2577
2578PP(pp_scomplement)
2579{
2580 dSP;
2581 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2582 {
2583 dTARGET; dTOPss;
2584 S_scomplement(aTHX_ TARG, sv);
2585 SETTARG;
2586 return NORMAL;
a0d0e21e 2587 }
79072805
LW
2588}
2589
a0d0e21e
LW
2590/* integer versions of some of the above */
2591
a0d0e21e 2592PP(pp_i_multiply)
79072805 2593{
20b7effb 2594 dSP; dATARGET;
6f1401dc 2595 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2596 {
6f1401dc 2597 dPOPTOPiirl_nomg;
a0d0e21e
LW
2598 SETi( left * right );
2599 RETURN;
2600 }
79072805
LW
2601}
2602
a0d0e21e 2603PP(pp_i_divide)
79072805 2604{
85935d8e 2605 IV num;
20b7effb 2606 dSP; dATARGET;
6f1401dc 2607 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2608 {
6f1401dc 2609 dPOPTOPssrl;
85935d8e 2610 IV value = SvIV_nomg(right);
a0d0e21e 2611 if (value == 0)
ece1bcef 2612 DIE(aTHX_ "Illegal division by zero");
85935d8e 2613 num = SvIV_nomg(left);
a0cec769
YST
2614
2615 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2616 if (value == -1)
2617 value = - num;
2618 else
2619 value = num / value;
6f1401dc 2620 SETi(value);
a0d0e21e
LW
2621 RETURN;
2622 }
79072805
LW
2623}
2624
bf3d06aa
JC
2625#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2626 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
224ec323
JH
2627STATIC
2628PP(pp_i_modulo_0)
befad5d1
NC
2629#else
2630PP(pp_i_modulo)
2631#endif
224ec323
JH
2632{
2633 /* This is the vanilla old i_modulo. */
20b7effb 2634 dSP; dATARGET;
6f1401dc 2635 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2636 {
6f1401dc 2637 dPOPTOPiirl_nomg;
224ec323
JH
2638 if (!right)
2639 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2640 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2641 if (right == -1)
2642 SETi( 0 );
2643 else
2644 SETi( left % right );
224ec323
JH
2645 RETURN;
2646 }
2647}
2648
bf3d06aa
JC
2649#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2650 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
224ec323
JH
2651STATIC
2652PP(pp_i_modulo_1)
befad5d1 2653
224ec323 2654{
224ec323 2655 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2656 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2657 * See below for pp_i_modulo. */
20b7effb 2658 dSP; dATARGET;
6f1401dc 2659 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2660 {
6f1401dc 2661 dPOPTOPiirl_nomg;
224ec323
JH
2662 if (!right)
2663 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2664 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2665 if (right == -1)
2666 SETi( 0 );
2667 else
2668 SETi( left % PERL_ABS(right) );
224ec323
JH
2669 RETURN;
2670 }
224ec323
JH
2671}
2672
a0d0e21e 2673PP(pp_i_modulo)
79072805 2674{
6f1401dc
DM
2675 dVAR; dSP; dATARGET;
2676 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2677 {
6f1401dc 2678 dPOPTOPiirl_nomg;
224ec323
JH
2679 if (!right)
2680 DIE(aTHX_ "Illegal modulus zero");
2681 /* The assumption is to use hereafter the old vanilla version... */
2682 PL_op->op_ppaddr =
2683 PL_ppaddr[OP_I_MODULO] =
1c127fab 2684 Perl_pp_i_modulo_0;
224ec323 2685 /* .. but if we have glibc, we might have a buggy _moddi3
bf3d06aa 2686 * (at least glibc 2.2.5 is known to have this bug), in other
224ec323
JH
2687 * words our integer modulus with negative quad as the second
2688 * argument might be broken. Test for this and re-patch the
2689 * opcode dispatch table if that is the case, remembering to
2690 * also apply the workaround so that this first round works
2691 * right, too. See [perl #9402] for more information. */
224ec323
JH
2692 {
2693 IV l = 3;
2694 IV r = -10;
2695 /* Cannot do this check with inlined IV constants since
2696 * that seems to work correctly even with the buggy glibc. */
2697 if (l % r == -3) {
2698 /* Yikes, we have the bug.
2699 * Patch in the workaround version. */
2700 PL_op->op_ppaddr =
2701 PL_ppaddr[OP_I_MODULO] =
2702 &Perl_pp_i_modulo_1;
2703 /* Make certain we work right this time, too. */
32fdb065 2704 right = PERL_ABS(right);
224ec323
JH
2705 }
2706 }
a0cec769
YST
2707 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2708 if (right == -1)
2709 SETi( 0 );
2710 else
2711 SETi( left % right );
224ec323
JH
2712 RETURN;
2713 }
79072805 2714}
befad5d1 2715#endif
79072805 2716
a0d0e21e 2717PP(pp_i_add)
79072805 2718{
20b7effb 2719 dSP; dATARGET;
6f1401dc 2720 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2721 {
6f1401dc 2722 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2723 SETi( left + right );
2724 RETURN;
79072805 2725 }
79072805
LW
2726}
2727
a0d0e21e 2728PP(pp_i_subtract)
79072805 2729{
20b7effb 2730 dSP; dATARGET;
6f1401dc 2731 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2732 {
6f1401dc 2733 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2734 SETi( left - right );
2735 RETURN;
79072805 2736 }
79072805
LW
2737}
2738
a0d0e21e 2739PP(pp_i_lt)
79072805 2740{
20b7effb 2741 dSP;
6f1401dc 2742 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2743 {
96b6b87f 2744 dPOPTOPiirl_nomg;
54310121 2745 SETs(boolSV(left < right));
a0d0e21e
LW
2746 RETURN;
2747 }
79072805
LW
2748}
2749
a0d0e21e 2750PP(pp_i_gt)
79072805 2751{
20b7effb 2752 dSP;
6f1401dc 2753 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2754 {
96b6b87f 2755 dPOPTOPiirl_nomg;
54310121 2756 SETs(boolSV(left > right));
a0d0e21e
LW
2757 RETURN;
2758 }
79072805
LW
2759}
2760
a0d0e21e 2761PP(pp_i_le)
79072805 2762{
20b7effb 2763 dSP;
6f1401dc 2764 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 2765 {
96b6b87f 2766 dPOPTOPiirl_nomg;
54310121 2767 SETs(boolSV(left <= right));
a0d0e21e 2768 RETURN;
85e6fe83 2769 }
79072805
LW
2770}
2771
a0d0e21e 2772PP(pp_i_ge)
79072805 2773{
20b7effb 2774 dSP;
6f1401dc 2775 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 2776 {
96b6b87f 2777 dPOPTOPiirl_nomg;
54310121 2778 SETs(boolSV(left >= right));
a0d0e21e
LW
2779 RETURN;
2780 }
79072805
LW
2781}
2782
a0d0e21e 2783PP(pp_i_eq)
79072805 2784{
20b7effb 2785 dSP;
6f1401dc 2786 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 2787 {
96b6b87f 2788 dPOPTOPiirl_nomg;
54310121 2789 SETs(boolSV(left == right));
a0d0e21e
LW
2790 RETURN;
2791 }
79072805
LW
2792}
2793
a0d0e21e 2794PP(pp_i_ne)
79072805 2795{
20b7effb 2796 dSP;
6f1401dc 2797 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 2798 {
96b6b87f 2799 dPOPTOPiirl_nomg;
54310121 2800 SETs(boolSV(left != right));
a0d0e21e
LW
2801 RETURN;
2802 }
79072805
LW
2803}
2804
a0d0e21e 2805PP(pp_i_ncmp)
79072805 2806{
20b7effb 2807 dSP; dTARGET;
6f1401dc 2808 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2809 {
96b6b87f 2810 dPOPTOPiirl_nomg;
a0d0e21e 2811 I32 value;
79072805 2812
a0d0e21e 2813 if (left > right)
79072805 2814 value = 1;
a0d0e21e 2815 else if (left < right)
79072805 2816 value = -1;
a0d0e21e 2817 else
79072805 2818 value = 0;
a0d0e21e
LW
2819 SETi(value);
2820 RETURN;
79072805 2821 }
85e6fe83
LW
2822}
2823
2824PP(pp_i_negate)
2825{
20b7effb 2826 dSP; dTARGET;
6f1401dc 2827 tryAMAGICun_MG(neg_amg, 0);
1c2b3fd6 2828 if (S_negate_string(aTHX)) return NORMAL;
6f1401dc
DM
2829 {
2830 SV * const sv = TOPs;
2831 IV const i = SvIV_nomg(sv);
2832 SETi(-i);
ae642386 2833 return NORMAL;
6f1401dc 2834 }
85e6fe83
LW
2835}
2836
79072805
LW
2837/* High falutin' math. */
2838
2839PP(pp_atan2)
2840{
20b7effb 2841 dSP; dTARGET;
6f1401dc 2842 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2843 {
096c060c 2844 dPOPTOPnnrl_nomg;
a1021d57 2845 SETn(Perl_atan2(left, right));
a0d0e21e
LW
2846 RETURN;
2847 }
79072805
LW
2848}
2849
b1c05ba5
DM
2850
2851/* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2852
79072805
LW
2853PP(pp_sin)
2854{
20b7effb 2855 dSP; dTARGET;
af71714e 2856 int amg_type = fallback_amg;
71302fe3 2857 const char *neg_report = NULL;
71302fe3
NC
2858 const int op_type = PL_op->op_type;
2859
2860 switch (op_type) {
af71714e
JH
2861 case OP_SIN: amg_type = sin_amg; break;
2862 case OP_COS: amg_type = cos_amg; break;
2863 case OP_EXP: amg_type = exp_amg; break;
2864 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2865 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
a0d0e21e 2866 }
79072805 2867
af71714e 2868 assert(amg_type != fallback_amg);
6f1401dc
DM
2869
2870 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 2871 {
8c78ed36 2872 SV * const arg = TOPs;
6f1401dc 2873 const NV value = SvNV_nomg(arg);
f256868e 2874 NV result = NV_NAN;
af71714e 2875 if (neg_report) { /* log or sqrt */
a3463d96
DD
2876 if (
2877#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2878 ! Perl_isnan(value) &&
2879#endif
2880 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
71302fe3 2881 SET_NUMERIC_STANDARD();
dcbac5bb 2882 /* diag_listed_as: Can't take log of %g */
71302fe3
NC
2883 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2884 }
2885 }
af71714e 2886 switch (op_type) {
f256868e 2887 default:
af71714e
JH
2888 case OP_SIN: result = Perl_sin(value); break;
2889 case OP_COS: result = Perl_cos(value); break;
2890 case OP_EXP: result = Perl_exp(value); break;
2891 case OP_LOG: result = Perl_log(value); break;
2892 case OP_SQRT: result = Perl_sqrt(value); break;
2893 }
8c78ed36
FC
2894 SETn(result);
2895 return NORMAL;
a0d0e21e 2896 }
79072805
LW
2897}
2898
56cb0a1c
AD
2899/* Support Configure command-line overrides for rand() functions.
2900 After 5.005, perhaps we should replace this by Configure support
2901 for drand48(), random(), or rand(). For 5.005, though, maintain
2902 compatibility by calling rand() but allow the user to override it.
2903 See INSTALL for details. --Andy Dougherty 15 July 1998
2904*/
85ab1d1d
JH
2905/* Now it's after 5.005, and Configure supports drand48() and random(),
2906 in addition to rand(). So the overrides should not be needed any more.
2907 --Jarkko Hietaniemi 27 September 1998
2908 */
2909
79072805
LW
2910PP(pp_rand)
2911{
80252599 2912 if (!PL_srand_called) {
85ab1d1d 2913 (void)seedDrand01((Rand_seed_t)seed());
80252599 2914 PL_srand_called = TRUE;
93dc8474 2915 }
fdf4dddd
DD
2916 {
2917 dSP;
2918 NV value;
fdf4dddd
DD
2919
2920 if (MAXARG < 1)
7e9044f9
FC
2921 {
2922 EXTEND(SP, 1);
fdf4dddd 2923 value = 1.0;
7e9044f9 2924 }
fdf4dddd
DD
2925 else {
2926 SV * const sv = POPs;
2927 if(!sv)
2928 value = 1.0;
2929 else
2930 value = SvNV(sv);
2931 }
2932 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
a3463d96
DD
2933#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2934 if (! Perl_isnan(value) && value == 0.0)
2935#else
659c4b96 2936 if (value == 0.0)
a3463d96 2937#endif
fdf4dddd
DD
2938 value = 1.0;
2939 {
2940 dTARGET;
2941 PUSHs(TARG);
2942 PUTBACK;
2943 value *= Drand01();
2944 sv_setnv_mg(TARG, value);
2945 }
2946 }
2947 return NORMAL;
79072805
LW
2948}
2949
2950PP(pp_srand)
2951{
20b7effb 2952 dSP; dTARGET;
f914a682
JL
2953 UV anum;
2954
0a5f3363 2955 if (MAXARG >= 1 && (TOPs || POPs)) {
f914a682
JL
2956 SV *top;
2957 char *pv;
2958 STRLEN len;
2959 int flags;
2960
2961 top = POPs;
2962 pv = SvPV(top, len);
2963 flags = grok_number(pv, len, &anum);
2964
2965 if (!(flags & IS_NUMBER_IN_UV)) {
2966 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2967 "Integer overflow in srand");
2968 anum = UV_MAX;
2969 }
2970 }
2971 else {
2972 anum = seed();
2973 }
2974
85ab1d1d 2975 (void)seedDrand01((Rand_seed_t)anum);
80252599 2976 PL_srand_called = TRUE;
da1010ec
NC
2977 if (anum)
2978 XPUSHu(anum);
2979 else {
2980 /* Historically srand always returned true. We can avoid breaking
2981 that like this: */
2982 sv_setpvs(TARG, "0 but true");
2983 XPUSHTARG;
2984 }
83832992 2985 RETURN;
79072805
LW
2986}
2987
79072805
LW
2988PP(pp_int)
2989{
20b7effb 2990 dSP; dTARGET;
6f1401dc 2991 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 2992 {
6f1401dc
DM
2993 SV * const sv = TOPs;
2994 const IV iv = SvIV_nomg(sv);
28e5dec8
JH
2995 /* XXX it's arguable that compiler casting to IV might be subtly
2996 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2997 else preferring IV has introduced a subtle behaviour change bug. OTOH
2998 relying on floating point to be accurate is a bug. */
2999
c781a409 3000 if (!SvOK(sv)) {
922c4365 3001 SETu(0);
c781a409
RD
3002 }
3003 else if (SvIOK(sv)) {
3004 if (SvIsUV(sv))
6f1401dc 3005 SETu(SvUV_nomg(sv));
c781a409 3006 else
28e5dec8 3007 SETi(iv);
c781a409 3008 }
c781a409 3009 else {
6f1401dc 3010 const NV value = SvNV_nomg(sv);
b9d05018
FC
3011 if (UNLIKELY(Perl_isinfnan(value)))
3012 SETn(value);
5bf8b78e 3013 else if (value >= 0.0) {
28e5dec8
JH
3014 if (value < (NV)UV_MAX + 0.5) {
3015 SETu(U_V(value));
3016 } else {
059a1014 3017 SETn(Perl_floor(value));
28e5dec8 3018 }
1048ea30 3019 }
28e5dec8
JH
3020 else {
3021 if (value > (NV)IV_MIN - 0.5) {
3022 SETi(I_V(value));
3023 } else {
1bbae031 3024 SETn(Perl_ceil(value));
28e5dec8
JH
3025 }
3026 }
774d564b 3027 }
79072805 3028 }
699e9491 3029 return NORMAL;
79072805
LW
3030}
3031
463ee0b2
LW
3032PP(pp_abs)
3033{
20b7effb 3034 dSP; dTARGET;
6f1401dc 3035 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 3036 {
6f1401dc 3037 SV * const sv = TOPs;
28e5dec8 3038 /* This will cache the NV value if string isn't actually integer */
6f1401dc 3039 const IV iv = SvIV_nomg(sv);
a227d84d 3040
800401ee 3041 if (!SvOK(sv)) {
922c4365 3042 SETu(0);
800401ee
JH
3043 }
3044 else if (SvIOK(sv)) {
28e5dec8 3045 /* IVX is precise */
800401ee 3046 if (SvIsUV(sv)) {
6f1401dc 3047 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH
3048 } else {
3049 if (iv >= 0) {
3050 SETi(iv);
3051 } else {
3052 if (iv != IV_MIN) {
3053 SETi(-iv);
3054 } else {
3055 /* 2s complement assumption. Also, not really needed as
3056 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3057 SETu(IV_MIN);
3058 }
a227d84d 3059 }
28e5dec8
JH
3060 }
3061 } else{
6f1401dc 3062 const NV value = SvNV_nomg(sv);
774d564b 3063 if (value < 0.0)
1b6737cc 3064 SETn(-value);
a4474c9e
DD
3065 else
3066 SETn(value);
774d564b 3067 }
a0d0e21e 3068 }
067b7929 3069 return NORMAL;
463ee0b2
LW
3070}
3071
b1c05ba5
DM
3072
3073/* also used for: pp_hex() */
3074
79072805
LW
3075PP(pp_oct)
3076{
20b7effb 3077 dSP; dTARGET;
5c144d81 3078 const char *tmps;
53305cf1 3079 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 3080 STRLEN len;
53305cf1
NC
3081 NV result_nv;
3082 UV result_uv;
4e51bcca 3083 SV* const sv = TOPs;
79072805 3084
349d4f2f 3085 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS
3086 if (DO_UTF8(sv)) {
3087 /* If Unicode, try to downgrade
3088 * If not possible, croak. */
1b6737cc 3089 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS
3090
3091 SvUTF8_on(tsv);
3092 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3093 tmps = SvPV_const(tsv, len);
2bc69dc4 3094 }
daa2adfd
NC
3095 if (PL_op->op_type == OP_HEX)
3096 goto hex;
3097
6f894ead 3098 while (*tmps && len && isSPACE(*tmps))
53305cf1 3099 tmps++, len--;
9e24b6e2 3100 if (*tmps == '0')
53305cf1 3101 tmps++, len--;
305b8651 3102 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
daa2adfd 3103 hex:
53305cf1 3104 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 3105 }
305b8651 3106 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
53305cf1 3107 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 3108 else
53305cf1
NC
3109 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3110
3111 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
4e51bcca 3112 SETn(result_nv);
53305cf1
NC
3113 }
3114 else {
4e51bcca 3115 SETu(result_uv);
53305cf1 3116 }
4e51bcca 3117 return NORMAL;
79072805
LW
3118}
3119
3120/* String stuff. */
3121
3122PP(pp_length)
3123{
20b7effb 3124 dSP; dTARGET;
0bd48802 3125 SV * const sv = TOPs;
a0ed51b3 3126
7776003e
DD
3127 U32 in_bytes = IN_BYTES;
3128 /* simplest case shortcut */
3129 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3130 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
6d59e610 3131 STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
7776003e
DD
3132 SETs(TARG);
3133
3134 if(LIKELY(svflags == SVf_POK))
3135 goto simple_pv;
3136 if(svflags & SVs_GMG)
3137 mg_get(sv);
0f43fd57 3138 if (SvOK(sv)) {
7776003e
DD
3139 if (!IN_BYTES) /* reread to avoid using an C auto/register */
3140 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
9f621bb0 3141 else
0f43fd57
FC
3142 {
3143 STRLEN len;
7776003e
DD
3144 /* unrolled SvPV_nomg_const(sv,len) */
3145 if(SvPOK_nog(sv)){
3146 simple_pv:
3147 len = SvCUR(sv);
3148 } else {
3149 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3150 }
3151 sv_setiv(TARG, (IV)(len));
0f43fd57 3152 }
656266fc 3153 } else {
9407f9c1
DL
3154 if (!SvPADTMP(TARG)) {
3155 sv_setsv_nomg(TARG, &PL_sv_undef);
7776003e
DD
3156 } else { /* TARG is on stack at this point and is overwriten by SETs.
3157 This branch is the odd one out, so put TARG by default on
3158 stack earlier to let local SP go out of liveness sooner */
3159 SETs(&PL_sv_undef);
3160 goto no_set_magic;
3161 }
92331800 3162 }
7776003e
DD
3163 SvSETMAGIC(TARG);
3164 no_set_magic:
3165 return NORMAL; /* no putback, SP didn't move in this opcode */
79072805
LW
3166}
3167
83f78d1a
FC
3168/* Returns false if substring is completely outside original string.
3169 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3170 always be true for an explicit 0.
3171*/
3172bool
ddeaf645
DD
3173Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3174 bool pos1_is_uv, IV len_iv,
3175 bool len_is_uv, STRLEN *posp,
3176 STRLEN *lenp)
83f78d1a
FC
3177{
3178 IV pos2_iv;
3179 int pos2_is_uv;
3180
3181 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3182
3183 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3184 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3185 pos1_iv += curlen;
3186 }
3187 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3188 return FALSE;
3189
3190 if (len_iv || len_is_uv) {
3191 if (!len_is_uv && len_iv < 0) {
3192 pos2_iv = curlen + len_iv;
3193 if (curlen)
3194 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3195 else
3196 pos2_is_uv = 0;
3197 } else { /* len_iv >= 0 */
3198 if (!pos1_is_uv && pos1_iv < 0) {
3199 pos2_iv = pos1_iv + len_iv;
3200 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3201 } else {
3202 if ((UV)len_iv > curlen-(UV)pos1_iv)
3203 pos2_iv = curlen;
3204 else
3205 pos2_iv = pos1_iv+len_iv;
3206 pos2_is_uv = 1;
3207 }
3208 }
3209 }
3210 else {
3211 pos2_iv = curlen;
3212 pos2_is_uv = 1;
3213 }
3214
3215 if (!pos2_is_uv && pos2_iv < 0) {
3216 if (!pos1_is_uv && pos1_iv < 0)
3217 return FALSE;
3218 pos2_iv = 0;
3219 }
3220 else if (!pos1_is_uv && pos1_iv < 0)
3221 pos1_iv = 0;
3222
3223 if ((UV)pos2_iv < (UV)pos1_iv)
3224 pos2_iv = pos1_iv;
3225 if ((UV)pos2_iv > curlen)
3226 pos2_iv = curlen;
3227
3228 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3229 *posp = (STRLEN)( (UV)pos1_iv );
3230 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3231
3232 return TRUE;
3233}
3234
79072805
LW
3235PP(pp_substr)
3236{
20b7effb 3237 dSP; dTARGET;
79072805 3238 SV *sv;
463ee0b2 3239 STRLEN curlen;
9402d6ed 3240 STRLEN utf8_curlen;
777f7c56
EB
3241 SV * pos_sv;
3242 IV pos1_iv;
3243 int pos1_is_uv;
777f7c56
EB
3244 SV * len_sv;
3245 IV len_iv = 0;
83f78d1a 3246 int len_is_uv = 0;
24fcb59f 3247 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 3248 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 3249 const char *tmps;
9402d6ed 3250 SV *repl_sv = NULL;
cbbf8932 3251 const char *repl = NULL;
7b8d334a 3252 STRLEN repl_len;
7bc95ae1 3253 int num_args = PL_op->op_private & 7;
13e30c65 3254 bool repl_need_utf8_upgrade = FALSE;
79072805 3255
78f9721b
SM
3256 if (num_args > 2) {
3257 if (num_args > 3) {
24fcb59f 3258 if(!(repl_sv = POPs)) num_args--;
7bc95ae1
FC
3259 }
3260 if ((len_sv = POPs)) {
3261 len_iv = SvIV(len_sv);
83f78d1a 3262 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
7b8d334a 3263 }
7bc95ae1 3264 else num_args--;
5d82c453 3265 }
777f7c56
EB
3266 pos_sv = POPs;
3267 pos1_iv = SvIV(pos_sv);
3268 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3269 sv = POPs;
24fcb59f
FC
3270 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3271 assert(!repl_sv);
3272 repl_sv = POPs;
3273 }
6582db62 3274 if (lvalue && !repl_sv) {
83f78d1a
FC
3275 SV * ret;
3276 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3277 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3278 LvTYPE(ret) = 'x';
3279 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3280 LvTARGOFF(ret) =
3281 pos1_is_uv || pos1_iv >= 0
3282 ? (STRLEN)(UV)pos1_iv
3283 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3284 LvTARGLEN(ret) =
3285 len_is_uv || len_iv > 0
3286 ? (STRLEN)(UV)len_iv
3287 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3288
83f78d1a
FC
3289 PUSHs(ret); /* avoid SvSETMAGIC here */
3290 RETURN;
a74fb2cd 3291 }
6582db62
FC
3292 if (repl_sv) {
3293 repl = SvPV_const(repl_sv, repl_len);
3294 SvGETMAGIC(sv);
3295 if (SvROK(sv))
3296 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3297 "Attempt to use reference as lvalue in substr"
3298 );
3299 tmps = SvPV_force_nomg(sv, curlen);
3300 if (DO_UTF8(repl_sv) && repl_len) {
3301 if (!DO_UTF8(sv)) {
01680ee9 3302 sv_utf8_upgrade_nomg(sv);
6582db62
FC
3303 curlen = SvCUR(sv);
3304 }
3305 }
3306 else if (DO_UTF8(sv))
3307 repl_need_utf8_upgrade = TRUE;
3308 }
3309 else tmps = SvPV_const(sv, curlen);
7e2040f0 3310 if (DO_UTF8(sv)) {
0d788f38 3311 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
9402d6ed
JH
3312 if (utf8_curlen == curlen)
3313 utf8_curlen = 0;
a0ed51b3 3314 else
9402d6ed 3315 curlen = utf8_curlen;
a0ed51b3 3316 }
d1c2b58a 3317 else
9402d6ed 3318 utf8_curlen = 0;
a0ed51b3 3319
83f78d1a
FC
3320 {
3321 STRLEN pos, len, byte_len, byte_pos;
777f7c56 3322
83f78d1a
FC
3323 if (!translate_substr_offsets(
3324 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3325 )) goto bound_fail;
777f7c56 3326
83f78d1a
FC
3327 byte_len = len;
3328 byte_pos = utf8_curlen
0d788f38 3329 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
d931b1be 3330
2154eca7 3331 tmps += byte_pos;
bbddc9e0
CS
3332
3333 if (rvalue) {
3334 SvTAINTED_off(TARG); /* decontaminate */
3335 SvUTF8_off(TARG); /* decontaminate */
3336 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3337#ifdef USE_LOCALE_COLLATE
bbddc9e0 3338 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3339#endif
bbddc9e0
CS
3340 if (utf8_curlen)
3341 SvUTF8_on(TARG);
3342 }
2154eca7 3343
f7928d6c 3344 if (repl) {
13e30c65
JH
3345 SV* repl_sv_copy = NULL;
3346
3347 if (repl_need_utf8_upgrade) {
3348 repl_sv_copy = newSVsv(repl_sv);
3349 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3350 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65 3351 }
502d9230
VP
3352 if (!SvOK(sv))
3353 sv_setpvs(sv, "");
777f7c56 3354 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
ef8d46e8 3355 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3356 }
79072805 3357 }
6a9665b0
FC
3358 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3359 SP++;
3360 else if (rvalue) {
bbddc9e0
CS
3361 SvSETMAGIC(TARG);
3362 PUSHs(TARG);
3363 }
79072805 3364 RETURN;
777f7c56 3365
7b52d656 3366 bound_fail:
83f78d1a 3367 if (repl)
777f7c56
EB
3368 Perl_croak(aTHX_ "substr outside of string");
3369 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3370 RETPUSHUNDEF;
79072805
LW
3371}
3372
3373PP(pp_vec)
3374{
20b7effb 3375 dSP;
eb578fdb
KW
3376 const IV size = POPi;
3377 const IV offset = POPi;
3378 SV * const src = POPs;
1b6737cc 3379 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3380 SV * ret;
a0d0e21e 3381
81e118e0 3382 if (lvalue) { /* it's an lvalue! */
2154eca7
EB
3383 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3384 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3385 LvTYPE(ret) = 'v';
3386 LvTARG(ret) = SvREFCNT_inc_simple(src);
3387 LvTARGOFF(ret) = offset;
3388 LvTARGLEN(ret) = size;
3389 }
3390 else {
3391 dTARGET;
3392 SvTAINTED_off(TARG); /* decontaminate */
3393 ret = TARG;
79072805
LW
3394 }
3395
2154eca7 3396 sv_setuv(ret, do_vecget(src, offset, size));
f9e95907
FC
3397 if (!lvalue)
3398 SvSETMAGIC(ret);
2154eca7 3399 PUSHs(ret);
79072805
LW
3400 RETURN;
3401}
3402
b1c05ba5
DM
3403
3404/* also used for: pp_rindex() */
3405
79072805
LW
3406PP(pp_index)
3407{
20b7effb 3408 dSP; dTARGET;
79072805
LW
3409 SV *big;
3410 SV *little;
c445ea15 3411 SV *temp = NULL;
ad66a58c 3412 STRLEN biglen;
2723d216 3413 STRLEN llen = 0;
b464e2b7
TC
3414 SSize_t offset = 0;
3415 SSize_t retval;
73ee8be2
NC
3416 const char *big_p;
3417 const char *little_p;
2f040f7f
NC
3418 bool big_utf8;
3419 bool little_utf8;
2723d216 3420 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3421 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3422
e1dccc0d
Z
3423 if (threeargs)
3424 offset = POPi;
79072805
LW
3425 little = POPs;
3426 big = POPs;
73ee8be2
NC
3427 big_p = SvPV_const(big, biglen);
3428 little_p = SvPV_const(little, llen);
3429
e609e586
NC
3430 big_utf8 = DO_UTF8(big);
3431 little_utf8 = DO_UTF8(little);
3432 if (big_utf8 ^ little_utf8) {
3433 /* One needs to be upgraded. */
47e13f24 3434 if (little_utf8 && !IN_ENCODING) {
2f040f7f
NC
3435 /* Well, maybe instead we might be able to downgrade the small
3436 string? */
1eced8f8 3437 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC
3438 &little_utf8);
3439 if (little_utf8) {
3440 /* If the large string is ISO-8859-1, and it's not possible to
3441 convert the small string to ISO-8859-1, then there is no
3442 way that it could be found anywhere by index. */
3443 retval = -1;
3444 goto fail;
3445 }
e609e586 3446
2f040f7f
NC
3447 /* At this point, pv is a malloc()ed string. So donate it to temp
3448 to ensure it will get free()d */
3449 little = temp = newSV(0);
73ee8be2
NC
3450 sv_usepvn(temp, pv, llen);
3451 little_p = SvPVX(little);
e609e586 3452 } else {
73ee8be2
NC
3453 temp = little_utf8
3454 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f 3455
47e13f24 3456 if (IN_ENCODING) {
ad2de1b2 3457 sv_recode_to_utf8(temp, _get_encoding());
2f040f7f
NC
3458 } else {
3459 sv_utf8_upgrade(temp);
3460 }
3461 if (little_utf8) {
3462 big = temp;
3463 big_utf8 = TRUE;
73ee8be2 3464 big_p = SvPV_const(big, biglen);
2f040f7f
NC
3465 } else {
3466 little = temp;
73ee8be2 3467 little_p = SvPV_const(little, llen);
2f040f7f 3468 }
e609e586
NC
3469 }
3470 }
73ee8be2
NC
3471 if (SvGAMAGIC(big)) {
3472 /* Life just becomes a lot easier if I use a temporary here.
3473 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3474 will trigger magic and overloading again, as will fbm_instr()
3475 */
59cd0e26
NC
3476 big = newSVpvn_flags(big_p, biglen,
3477 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3478 big_p = SvPVX(big);
3479 }
e4e44778 3480 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC
3481 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3482 warn on undef, and we've already triggered a warning with the
3483 SvPV_const some lines above. We can't remove that, as we need to
3484 call some SvPV to trigger overloading early and find out if the
3485 string is UTF-8.
8bd97c0c 3486 This is all getting too messy. The API isn't quite clean enough,
73ee8be2
NC
3487 because data access has side effects.
3488 */
59cd0e26
NC
3489 little = newSVpvn_flags(little_p, llen,
3490 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3491 little_p = SvPVX(little);
3492 }
e609e586 3493
d3e26383 3494 if (!threeargs)
2723d216 3495 offset = is_index ? 0 : biglen;
a0ed51b3 3496 else {
ad66a58c 3497 if (big_utf8 && offset > 0)
b464e2b7 3498 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
73ee8be2
NC
3499 if (!is_index)
3500 offset += llen;
a0ed51b3 3501 }
79072805
LW
3502 if (offset < 0)
3503 offset = 0;
b464e2b7 3504 else if (offset > (SSize_t)biglen)
ad66a58c 3505 offset = biglen;
73ee8be2
NC
3506 if (!(little_p = is_index
3507 ? fbm_instr((unsigned char*)big_p + offset,
3508 (unsigned char*)big_p + biglen, little, 0)
3509 : rninstr(big_p, big_p + offset,
3510 little_p, little_p + llen)))
a0ed51b3 3511 retval = -1;
ad66a58c 3512 else {
73ee8be2 3513 retval = little_p - big_p;
15c41403 3514 if (retval > 1 && big_utf8)
b464e2b7 3515 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
ad66a58c 3516 }
ef8d46e8 3517 SvREFCNT_dec(temp);
2723d216 3518 fail:
e1dccc0d 3519 PUSHi(retval);
79072805
LW
3520 RETURN;
3521}
3522
3523PP(pp_sprintf)
3524{
20b7effb 3525 dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3526 SvTAINTED_off(TARG);
79072805 3527 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3528 TAINT_IF(SvTAINTED(TARG));
79072805
LW
3529 SP = ORIGMARK;
3530 PUSHTARG;
3531 RETURN;
3532}
3533
79072805
LW
3534PP(pp_ord)
3535{
20b7effb 3536 dSP; dTARGET;
1eced8f8 3537
6ba92227 3538 SV *argsv = TOPs;
ba210ebe 3539 STRLEN len;
349d4f2f 3540 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3541
47e13f24 3542 if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3543 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
ad2de1b2 3544 s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
4f6386b6 3545 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
121910a4
JH
3546 argsv = tmpsv;
3547 }
79072805 3548
6ba92227 3549 SETu(DO_UTF8(argsv)
4f6386b6 3550 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
f3943cf2 3551 : (UV)(*s));
68795e93 3552
6ba92227 3553 return NORMAL;
79072805
LW
3554}
3555
463ee0b2
LW
3556PP(pp_chr)
3557{
20b7effb 3558 dSP; dTARGET;
463ee0b2 3559 char *tmps;
8a064bd6 3560 UV value;
d3261b99 3561 SV *top = TOPs;
8a064bd6 3562
71739502 3563 SvGETMAGIC(top);
9911fc4e
FC
3564 if (UNLIKELY(SvAMAGIC(top)))
3565 top = sv_2num(top);
99f450cc 3566 if (UNLIKELY(isinfnansv(top)))
0c7df902 3567 Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
1cd88304
JH
3568 else {
3569 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3570 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3571 ||
3572 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
2cc2a5a0
KW
3573 && SvNV_nomg(top) < 0.0)))
3574 {
b3fe8680
FC
3575 if (ckWARN(WARN_UTF8)) {
3576 if (SvGMAGICAL(top)) {
3577 SV *top2 = sv_newmortal();
3578 sv_setsv_nomg(top2, top);
3579 top = top2;
3580 }
1cd88304
JH
3581 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3582 "Invalid negative number (%"SVf") in chr", SVfARG(top));