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