This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove undefined behavior from IV shifting
[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
2001 * different from perl 6:
2002 *
2003 * $ perl6 -e 'say -2 +< 5'
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
DM
2064 SV *left, *right;
2065
0872de45 2066 tryAMAGICbin_MG(lt_amg, AMGf_numeric);
33efebe6
DM
2067 right = POPs;
2068 left = TOPs;
2069 SETs(boolSV(
2070 (SvIOK_notUV(left) && SvIOK_notUV(right))
2071 ? (SvIVX(left) < SvIVX(right))
2072 : (do_ncmp(left, right) == -1)
2073 ));
2074 RETURN;
a0d0e21e 2075}
79072805 2076
a0d0e21e
LW
2077PP(pp_gt)
2078{
20b7effb 2079 dSP;
33efebe6 2080 SV *left, *right;
1b6737cc 2081
0872de45 2082 tryAMAGICbin_MG(gt_amg, AMGf_numeric);
33efebe6
DM
2083 right = POPs;
2084 left = TOPs;
2085 SETs(boolSV(
2086 (SvIOK_notUV(left) && SvIOK_notUV(right))
2087 ? (SvIVX(left) > SvIVX(right))
2088 : (do_ncmp(left, right) == 1)
2089 ));
2090 RETURN;
a0d0e21e
LW
2091}
2092
2093PP(pp_le)
2094{
20b7effb 2095 dSP;
33efebe6 2096 SV *left, *right;
1b6737cc 2097
0872de45 2098 tryAMAGICbin_MG(le_amg, AMGf_numeric);
33efebe6
DM
2099 right = POPs;
2100 left = TOPs;
2101 SETs(boolSV(
2102 (SvIOK_notUV(left) && SvIOK_notUV(right))
2103 ? (SvIVX(left) <= SvIVX(right))
2104 : (do_ncmp(left, right) <= 0)
2105 ));
2106 RETURN;
a0d0e21e
LW
2107}
2108
2109PP(pp_ge)
2110{
20b7effb 2111 dSP;
33efebe6
DM
2112 SV *left, *right;
2113
0872de45 2114 tryAMAGICbin_MG(ge_amg, AMGf_numeric);
33efebe6
DM
2115 right = POPs;
2116 left = TOPs;
2117 SETs(boolSV(
2118 (SvIOK_notUV(left) && SvIOK_notUV(right))
2119 ? (SvIVX(left) >= SvIVX(right))
2120 : ( (do_ncmp(left, right) & 2) == 0)
2121 ));
2122 RETURN;
2123}
1b6737cc 2124
33efebe6
DM
2125PP(pp_ne)
2126{
20b7effb 2127 dSP;
33efebe6
DM
2128 SV *left, *right;
2129
0872de45 2130 tryAMAGICbin_MG(ne_amg, AMGf_numeric);
33efebe6
DM
2131 right = POPs;
2132 left = TOPs;
2133 SETs(boolSV(
2134 (SvIOK_notUV(left) && SvIOK_notUV(right))
2135 ? (SvIVX(left) != SvIVX(right))
2136 : (do_ncmp(left, right) != 0)
2137 ));
2138 RETURN;
2139}
1b6737cc 2140
33efebe6
DM
2141/* compare left and right SVs. Returns:
2142 * -1: <
2143 * 0: ==
2144 * 1: >
2145 * 2: left or right was a NaN
2146 */
2147I32
2148Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2149{
33efebe6
DM
2150 PERL_ARGS_ASSERT_DO_NCMP;
2151#ifdef PERL_PRESERVE_IVUV
33efebe6 2152 /* Fortunately it seems NaN isn't IOK */
01f91bf2 2153 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
33efebe6
DM
2154 if (!SvUOK(left)) {
2155 const IV leftiv = SvIVX(left);
2156 if (!SvUOK(right)) {
2157 /* ## IV <=> IV ## */
2158 const IV rightiv = SvIVX(right);
2159 return (leftiv > rightiv) - (leftiv < rightiv);
28e5dec8 2160 }
33efebe6
DM
2161 /* ## IV <=> UV ## */
2162 if (leftiv < 0)
2163 /* As (b) is a UV, it's >=0, so it must be < */
2164 return -1;
2165 {
2166 const UV rightuv = SvUVX(right);
2167 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
28e5dec8 2168 }
28e5dec8 2169 }
79072805 2170
33efebe6
DM
2171 if (SvUOK(right)) {
2172 /* ## UV <=> UV ## */
2173 const UV leftuv = SvUVX(left);
2174 const UV rightuv = SvUVX(right);
2175 return (leftuv > rightuv) - (leftuv < rightuv);
28e5dec8 2176 }
33efebe6
DM
2177 /* ## UV <=> IV ## */
2178 {
2179 const IV rightiv = SvIVX(right);
2180 if (rightiv < 0)
2181 /* As (a) is a UV, it's >=0, so it cannot be < */
2182 return 1;
2183 {
2184 const UV leftuv = SvUVX(left);
2185 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
28e5dec8 2186 }
28e5dec8 2187 }
e5964223 2188 NOT_REACHED; /* NOTREACHED */
28e5dec8
JH
2189 }
2190#endif
a0d0e21e 2191 {
33efebe6
DM
2192 NV const rnv = SvNV_nomg(right);
2193 NV const lnv = SvNV_nomg(left);
2194
cab190d4 2195#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
33efebe6
DM
2196 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2197 return 2;
2198 }
2199 return (lnv > rnv) - (lnv < rnv);
cab190d4 2200#else
33efebe6
DM
2201 if (lnv < rnv)
2202 return -1;
2203 if (lnv > rnv)
2204 return 1;
659c4b96 2205 if (lnv == rnv)
33efebe6
DM
2206 return 0;
2207 return 2;
cab190d4 2208#endif
a0d0e21e 2209 }
79072805
LW
2210}
2211
33efebe6 2212
a0d0e21e 2213PP(pp_ncmp)
79072805 2214{
20b7effb 2215 dSP;
33efebe6
DM
2216 SV *left, *right;
2217 I32 value;
a42d0242 2218 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
33efebe6
DM
2219 right = POPs;
2220 left = TOPs;
2221 value = do_ncmp(left, right);
2222 if (value == 2) {
3280af22 2223 SETs(&PL_sv_undef);
79072805 2224 }
33efebe6
DM
2225 else {
2226 dTARGET;
2227 SETi(value);
2228 }
2229 RETURN;
a0d0e21e 2230}
79072805 2231
b1c05ba5
DM
2232
2233/* also used for: pp_sge() pp_sgt() pp_slt() */
2234
afd9910b 2235PP(pp_sle)
a0d0e21e 2236{
20b7effb 2237 dSP;
79072805 2238
afd9910b
NC
2239 int amg_type = sle_amg;
2240 int multiplier = 1;
2241 int rhs = 1;
79072805 2242
afd9910b
NC
2243 switch (PL_op->op_type) {
2244 case OP_SLT:
2245 amg_type = slt_amg;
2246 /* cmp < 0 */
2247 rhs = 0;
2248 break;
2249 case OP_SGT:
2250 amg_type = sgt_amg;
2251 /* cmp > 0 */
2252 multiplier = -1;
2253 rhs = 0;
2254 break;
2255 case OP_SGE:
2256 amg_type = sge_amg;
2257 /* cmp >= 0 */
2258 multiplier = -1;
2259 break;
79072805 2260 }
79072805 2261
0872de45 2262 tryAMAGICbin_MG(amg_type, 0);
a0d0e21e
LW
2263 {
2264 dPOPTOPssrl;
130c5df3 2265 const int cmp =
5778acb6 2266#ifdef USE_LOCALE_COLLATE
130c5df3
KW
2267 (IN_LC_RUNTIME(LC_COLLATE))
2268 ? sv_cmp_locale_flags(left, right, 0)
2269 :
2270#endif
2271 sv_cmp_flags(left, right, 0);
afd9910b 2272 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW
2273 RETURN;
2274 }
2275}
79072805 2276
36477c24
PP
2277PP(pp_seq)
2278{
20b7effb 2279 dSP;
0872de45 2280 tryAMAGICbin_MG(seq_amg, 0);
36477c24
PP
2281 {
2282 dPOPTOPssrl;
078504b2 2283 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW
2284 RETURN;
2285 }
2286}
79072805 2287
a0d0e21e 2288PP(pp_sne)
79072805 2289{
20b7effb 2290 dSP;
0872de45 2291 tryAMAGICbin_MG(sne_amg, 0);
a0d0e21e
LW
2292 {
2293 dPOPTOPssrl;
078504b2 2294 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2295 RETURN;
463ee0b2 2296 }
79072805
LW
2297}
2298
a0d0e21e 2299PP(pp_scmp)
79072805 2300{
20b7effb 2301 dSP; dTARGET;
6f1401dc 2302 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW
2303 {
2304 dPOPTOPssrl;
130c5df3 2305 const int cmp =
5778acb6 2306#ifdef USE_LOCALE_COLLATE
130c5df3
KW
2307 (IN_LC_RUNTIME(LC_COLLATE))
2308 ? sv_cmp_locale_flags(left, right, 0)
2309 :
2310#endif
2311 sv_cmp_flags(left, right, 0);
bbce6d69 2312 SETi( cmp );
a0d0e21e
LW
2313 RETURN;
2314 }
2315}
79072805 2316
55497cff
PP
2317PP(pp_bit_and)
2318{
20b7effb 2319 dSP; dATARGET;
6f1401dc 2320 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW
2321 {
2322 dPOPTOPssrl;
4633a7c4 2323 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2324 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2325 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2326 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2327 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2328 SETi(i);
d0ba1bd2
JH
2329 }
2330 else {
1b6737cc 2331 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2332 SETu(u);
d0ba1bd2 2333 }
5ee80e13 2334 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2335 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2336 }
2337 else {
533c011a 2338 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2339 SETTARG;
2340 }
2341 RETURN;
2342 }
2343}
79072805 2344
5d01050a
FC
2345PP(pp_nbit_and)
2346{
2347 dSP;
636ac8fc 2348 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
5d01050a
FC
2349 {
2350 dATARGET; dPOPTOPssrl;
2351 if (PL_op->op_private & HINT_INTEGER) {
2352 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2353 SETi(i);
2354 }
2355 else {
2356 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2357 SETu(u);
2358 }
2359 }
2360 RETURN;
2361}
2362
2363PP(pp_sbit_and)
2364{
2365 dSP;
2366 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2367 {
2368 dATARGET; dPOPTOPssrl;
2369 do_vop(OP_BIT_AND, TARG, left, right);
2370 RETSETTARG;
2371 }
2372}
b1c05ba5
DM
2373
2374/* also used for: pp_bit_xor() */
2375
a0d0e21e
LW
2376PP(pp_bit_or)
2377{
20b7effb 2378 dSP; dATARGET;
3658c1f1
NC
2379 const int op_type = PL_op->op_type;
2380
6f1401dc 2381 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW
2382 {
2383 dPOPTOPssrl;
4633a7c4 2384 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2385 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2386 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2387 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC
2388 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2389 const IV r = SvIV_nomg(right);
2390 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2391 SETi(result);
d0ba1bd2
JH
2392 }
2393 else {
3658c1f1
NC
2394 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2395 const UV r = SvUV_nomg(right);
2396 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2397 SETu(result);
d0ba1bd2 2398 }
5ee80e13 2399 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2400 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2401 }
2402 else {
3658c1f1 2403 do_vop(op_type, TARG, left, right);
a0d0e21e
LW
2404 SETTARG;
2405 }
2406 RETURN;
79072805 2407 }
a0d0e21e 2408}
79072805 2409
5d01050a
FC
2410/* also used for: pp_nbit_xor() */
2411
2412PP(pp_nbit_or)
2413{
2414 dSP;
2415 const int op_type = PL_op->op_type;
2416
2417 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
636ac8fc 2418 AMGf_assign|AMGf_numarg);
5d01050a
FC
2419 {
2420 dATARGET; dPOPTOPssrl;
2421 if (PL_op->op_private & HINT_INTEGER) {
2422 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2423 const IV r = SvIV_nomg(right);
2424 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2425 SETi(result);
2426 }
2427 else {
2428 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2429 const UV r = SvUV_nomg(right);
2430 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2431 SETu(result);
2432 }
2433 }
2434 RETURN;
2435}
2436
2437/* also used for: pp_sbit_xor() */
2438
2439PP(pp_sbit_or)
2440{
2441 dSP;
2442 const int op_type = PL_op->op_type;
2443
2444 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2445 AMGf_assign);
2446 {
2447 dATARGET; dPOPTOPssrl;
2448 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2449 right);
2450 RETSETTARG;
2451 }
2452}
2453
1c2b3fd6
FC
2454PERL_STATIC_INLINE bool
2455S_negate_string(pTHX)
2456{
2457 dTARGET; dSP;
2458 STRLEN len;
2459 const char *s;
2460 SV * const sv = TOPs;
2461 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2462 return FALSE;
2463 s = SvPV_nomg_const(sv, len);
2464 if (isIDFIRST(*s)) {
2465 sv_setpvs(TARG, "-");
2466 sv_catsv(TARG, sv);
2467 }
2468 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2469 sv_setsv_nomg(TARG, sv);
2470 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2471 }
2472 else return FALSE;
245d035e 2473 SETTARG;
1c2b3fd6
FC
2474 return TRUE;
2475}
2476
a0d0e21e
LW
2477PP(pp_negate)
2478{
20b7effb 2479 dSP; dTARGET;
6f1401dc 2480 tryAMAGICun_MG(neg_amg, AMGf_numeric);
1c2b3fd6 2481 if (S_negate_string(aTHX)) return NORMAL;
a0d0e21e 2482 {
6f1401dc 2483 SV * const sv = TOPs;
a5b92898 2484
d96ab1b5 2485 if (SvIOK(sv)) {
7dbe3150 2486 /* It's publicly an integer */
28e5dec8 2487 oops_its_an_int:
9b0e499b
GS
2488 if (SvIsUV(sv)) {
2489 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2490 /* 2s complement assumption. */
d14578b8
KW
2491 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2492 IV_MIN */
245d035e 2493 return NORMAL;
9b0e499b
GS
2494 }
2495 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2496 SETi(-SvIVX(sv));
245d035e 2497 return NORMAL;
9b0e499b
GS
2498 }
2499 }
2500 else if (SvIVX(sv) != IV_MIN) {
2501 SETi(-SvIVX(sv));
245d035e 2502 return NORMAL;
9b0e499b 2503 }
28e5dec8
JH
2504#ifdef PERL_PRESERVE_IVUV
2505 else {
2506 SETu((UV)IV_MIN);
245d035e 2507 return NORMAL;
28e5dec8
JH
2508 }
2509#endif
9b0e499b 2510 }
8a5decd8 2511 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
6f1401dc 2512 SETn(-SvNV_nomg(sv));
1c2b3fd6 2513 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
8eb28a70 2514 goto oops_its_an_int;
4633a7c4 2515 else
6f1401dc 2516 SETn(-SvNV_nomg(sv));
79072805 2517 }
245d035e 2518 return NORMAL;
79072805
LW
2519}
2520
a0d0e21e 2521PP(pp_not)
79072805 2522{
20b7effb 2523 dSP;
f4c975aa
DM
2524 SV *sv;
2525
0872de45 2526 tryAMAGICun_MG(not_amg, 0);
f4c975aa
DM
2527 sv = *PL_stack_sp;
2528 *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
a0d0e21e 2529 return NORMAL;
79072805
LW
2530}
2531
5d01050a
FC
2532static void
2533S_scomplement(pTHX_ SV *targ, SV *sv)
79072805 2534{
eb578fdb
KW
2535 U8 *tmps;
2536 I32 anum;
a0d0e21e
LW
2537 STRLEN len;
2538
85b0ee6e
FC
2539 sv_copypv_nomg(TARG, sv);
2540 tmps = (U8*)SvPV_nomg(TARG, len);
08b6664b 2541
1d68d6cd 2542 if (SvUTF8(TARG)) {
08b6664b 2543 if (len && ! utf8_to_bytes(tmps, &len)) {
814eedc8 2544 Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]);
08b6664b
KW
2545 }
2546 SvCUR(TARG) = len;
2547 SvUTF8_off(TARG);
2548 }
2549
2550 anum = len;
1d68d6cd 2551
a0d0e21e 2552#ifdef LIBERAL
51723571 2553 {
eb578fdb 2554 long *tmpl;
51723571
JH
2555 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2556 *tmps = ~*tmps;
2557 tmpl = (long*)tmps;
bb7a0f54 2558 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH
2559 *tmpl = ~*tmpl;
2560 tmps = (U8*)tmpl;
2561 }
a0d0e21e
LW
2562#endif
2563 for ( ; anum > 0; anum--, tmps++)
2564 *tmps = ~*tmps;
5d01050a
FC
2565}
2566
2567PP(pp_complement)
2568{
2569 dSP; dTARGET;
2570 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2571 {
2572 dTOPss;
2573 if (SvNIOKp(sv)) {
2574 if (PL_op->op_private & HINT_INTEGER) {
2575 const IV i = ~SvIV_nomg(sv);
2576 SETi(i);
2577 }
2578 else {
2579 const UV u = ~SvUV_nomg(sv);
2580 SETu(u);
2581 }
2582 }
2583 else {
2584 S_scomplement(aTHX_ TARG, sv);
ec93b65f 2585 SETTARG;
a0d0e21e 2586 }
24840750 2587 return NORMAL;
5d01050a
FC
2588 }
2589}
2590
2591PP(pp_ncomplement)
2592{
2593 dSP;
636ac8fc 2594 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
5d01050a
FC
2595 {
2596 dTARGET; dTOPss;
2597 if (PL_op->op_private & HINT_INTEGER) {
2598 const IV i = ~SvIV_nomg(sv);
2599 SETi(i);
2600 }
2601 else {
2602 const UV u = ~SvUV_nomg(sv);
2603 SETu(u);
2604 }
2605 }
2606 return NORMAL;
2607}
2608
2609PP(pp_scomplement)
2610{
2611 dSP;
2612 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2613 {
2614 dTARGET; dTOPss;
2615 S_scomplement(aTHX_ TARG, sv);
2616 SETTARG;
2617 return NORMAL;
a0d0e21e 2618 }
79072805
LW
2619}
2620
a0d0e21e
LW
2621/* integer versions of some of the above */
2622
a0d0e21e 2623PP(pp_i_multiply)
79072805 2624{
20b7effb 2625 dSP; dATARGET;
6f1401dc 2626 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2627 {
6f1401dc 2628 dPOPTOPiirl_nomg;
a0d0e21e
LW
2629 SETi( left * right );
2630 RETURN;
2631 }
79072805
LW
2632}
2633
a0d0e21e 2634PP(pp_i_divide)
79072805 2635{
85935d8e 2636 IV num;
20b7effb 2637 dSP; dATARGET;
6f1401dc 2638 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2639 {
6f1401dc 2640 dPOPTOPssrl;
85935d8e 2641 IV value = SvIV_nomg(right);
a0d0e21e 2642 if (value == 0)
ece1bcef 2643 DIE(aTHX_ "Illegal division by zero");
85935d8e 2644 num = SvIV_nomg(left);
a0cec769
YST
2645
2646 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2647 if (value == -1)
2648 value = - num;
2649 else
2650 value = num / value;
6f1401dc 2651 SETi(value);
a0d0e21e
LW
2652 RETURN;
2653 }
79072805
LW
2654}
2655
befad5d1 2656PP(pp_i_modulo)
224ec323
JH
2657{
2658 /* This is the vanilla old i_modulo. */
20b7effb 2659 dSP; dATARGET;
6f1401dc 2660 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2661 {
6f1401dc 2662 dPOPTOPiirl_nomg;
224ec323
JH
2663 if (!right)
2664 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2665 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2666 if (right == -1)
2667 SETi( 0 );
2668 else
2669 SETi( left % right );
224ec323
JH
2670 RETURN;
2671 }
2672}
2673
0927ade0 2674#if defined(__GLIBC__) && IVSIZE == 8 \
bf3d06aa 2675 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
befad5d1 2676
0927ade0 2677PP(pp_i_modulo_glibc_bugfix)
224ec323 2678{
224ec323 2679 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2680 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2681 * See below for pp_i_modulo. */
20b7effb 2682 dSP; dATARGET;
6f1401dc 2683 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2684 {
6f1401dc 2685 dPOPTOPiirl_nomg;
224ec323
JH
2686 if (!right)
2687 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2688 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2689 if (right == -1)
2690 SETi( 0 );
2691 else
2692 SETi( left % PERL_ABS(right) );
224ec323
JH
2693 RETURN;
2694 }
224ec323 2695}
befad5d1 2696#endif
79072805 2697
a0d0e21e 2698PP(pp_i_add)
79072805 2699{
20b7effb 2700 dSP; dATARGET;
6f1401dc 2701 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2702 {
6f1401dc 2703 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2704 SETi( left + right );
2705 RETURN;
79072805 2706 }
79072805
LW
2707}
2708
a0d0e21e 2709PP(pp_i_subtract)
79072805 2710{
20b7effb 2711 dSP; dATARGET;
6f1401dc 2712 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2713 {
6f1401dc 2714 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2715 SETi( left - right );
2716 RETURN;
79072805 2717 }
79072805
LW
2718}
2719
a0d0e21e 2720PP(pp_i_lt)
79072805 2721{
20b7effb 2722 dSP;
0872de45 2723 tryAMAGICbin_MG(lt_amg, 0);
a0d0e21e 2724 {
96b6b87f 2725 dPOPTOPiirl_nomg;
54310121 2726 SETs(boolSV(left < right));
a0d0e21e
LW
2727 RETURN;
2728 }
79072805
LW
2729}
2730
a0d0e21e 2731PP(pp_i_gt)
79072805 2732{
20b7effb 2733 dSP;
0872de45 2734 tryAMAGICbin_MG(gt_amg, 0);
a0d0e21e 2735 {
96b6b87f 2736 dPOPTOPiirl_nomg;
54310121 2737 SETs(boolSV(left > right));
a0d0e21e
LW
2738 RETURN;
2739 }
79072805
LW
2740}
2741
a0d0e21e 2742PP(pp_i_le)
79072805 2743{
20b7effb 2744 dSP;
0872de45 2745 tryAMAGICbin_MG(le_amg, 0);
a0d0e21e 2746 {
96b6b87f 2747 dPOPTOPiirl_nomg;
54310121 2748 SETs(boolSV(left <= right));
a0d0e21e 2749 RETURN;
85e6fe83 2750 }
79072805
LW
2751}
2752
a0d0e21e 2753PP(pp_i_ge)
79072805 2754{
20b7effb 2755 dSP;
0872de45 2756 tryAMAGICbin_MG(ge_amg, 0);
a0d0e21e 2757 {
96b6b87f 2758 dPOPTOPiirl_nomg;
54310121 2759 SETs(boolSV(left >= right));
a0d0e21e
LW
2760 RETURN;
2761 }
79072805
LW
2762}
2763
a0d0e21e 2764PP(pp_i_eq)
79072805 2765{
20b7effb 2766 dSP;
0872de45 2767 tryAMAGICbin_MG(eq_amg, 0);
a0d0e21e 2768 {
96b6b87f 2769 dPOPTOPiirl_nomg;
54310121 2770 SETs(boolSV(left == right));
a0d0e21e
LW
2771 RETURN;
2772 }
79072805
LW
2773}
2774
a0d0e21e 2775PP(pp_i_ne)
79072805 2776{
20b7effb 2777 dSP;
0872de45 2778 tryAMAGICbin_MG(ne_amg, 0);
a0d0e21e 2779 {
96b6b87f 2780 dPOPTOPiirl_nomg;
54310121 2781 SETs(boolSV(left != right));
a0d0e21e
LW
2782 RETURN;
2783 }
79072805
LW
2784}
2785
a0d0e21e 2786PP(pp_i_ncmp)
79072805 2787{
20b7effb 2788 dSP; dTARGET;
6f1401dc 2789 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2790 {
96b6b87f 2791 dPOPTOPiirl_nomg;
a0d0e21e 2792 I32 value;
79072805 2793
a0d0e21e 2794 if (left > right)
79072805 2795 value = 1;
a0d0e21e 2796 else if (left < right)
79072805 2797 value = -1;
a0d0e21e 2798 else
79072805 2799 value = 0;
a0d0e21e
LW
2800 SETi(value);
2801 RETURN;
79072805 2802 }
85e6fe83
LW
2803}
2804
2805PP(pp_i_negate)
2806{
20b7effb 2807 dSP; dTARGET;
6f1401dc 2808 tryAMAGICun_MG(neg_amg, 0);
1c2b3fd6 2809 if (S_negate_string(aTHX)) return NORMAL;
6f1401dc
DM
2810 {
2811 SV * const sv = TOPs;
2812 IV const i = SvIV_nomg(sv);
2813 SETi(-i);
ae642386 2814 return NORMAL;
6f1401dc 2815 }
85e6fe83
LW
2816}
2817
79072805
LW
2818/* High falutin' math. */
2819
2820PP(pp_atan2)
2821{
20b7effb 2822 dSP; dTARGET;
6f1401dc 2823 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2824 {
096c060c 2825 dPOPTOPnnrl_nomg;
a1021d57 2826 SETn(Perl_atan2(left, right));
a0d0e21e
LW
2827 RETURN;
2828 }
79072805
LW
2829}
2830
b1c05ba5
DM
2831
2832/* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2833
79072805
LW
2834PP(pp_sin)
2835{
20b7effb 2836 dSP; dTARGET;
af71714e 2837 int amg_type = fallback_amg;
71302fe3 2838 const char *neg_report = NULL;
71302fe3
NC
2839 const int op_type = PL_op->op_type;
2840
2841 switch (op_type) {
af71714e
JH
2842 case OP_SIN: amg_type = sin_amg; break;
2843 case OP_COS: amg_type = cos_amg; break;
2844 case OP_EXP: amg_type = exp_amg; break;
2845 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2846 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
a0d0e21e 2847 }
79072805 2848
af71714e 2849 assert(amg_type != fallback_amg);
6f1401dc
DM
2850
2851 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 2852 {
8c78ed36 2853 SV * const arg = TOPs;
6f1401dc 2854 const NV value = SvNV_nomg(arg);
a5dc2484 2855#ifdef NV_NAN
f256868e 2856 NV result = NV_NAN;
a5dc2484
JH
2857#else
2858 NV result = 0.0;
2859#endif
af71714e 2860 if (neg_report) { /* log or sqrt */
a3463d96
DD
2861 if (
2862#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2863 ! Perl_isnan(value) &&
2864#endif
2865 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
71302fe3 2866 SET_NUMERIC_STANDARD();
dcbac5bb 2867 /* diag_listed_as: Can't take log of %g */
147e3846 2868 DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
71302fe3
NC
2869 }
2870 }
af71714e 2871 switch (op_type) {
f256868e 2872 default:
af71714e
JH
2873 case OP_SIN: result = Perl_sin(value); break;
2874 case OP_COS: result = Perl_cos(value); break;
2875 case OP_EXP: result = Perl_exp(value); break;
2876 case OP_LOG: result = Perl_log(value); break;
2877 case OP_SQRT: result = Perl_sqrt(value); break;
2878 }
8c78ed36
FC
2879 SETn(result);
2880 return NORMAL;
a0d0e21e 2881 }
79072805
LW
2882}
2883
56cb0a1c
AD
2884/* Support Configure command-line overrides for rand() functions.
2885 After 5.005, perhaps we should replace this by Configure support
2886 for drand48(), random(), or rand(). For 5.005, though, maintain
2887 compatibility by calling rand() but allow the user to override it.
2888 See INSTALL for details. --Andy Dougherty 15 July 1998
2889*/
85ab1d1d
JH
2890/* Now it's after 5.005, and Configure supports drand48() and random(),
2891 in addition to rand(). So the overrides should not be needed any more.
2892 --Jarkko Hietaniemi 27 September 1998
2893 */
2894
79072805
LW
2895PP(pp_rand)
2896{
80252599 2897 if (!PL_srand_called) {
85ab1d1d 2898 (void)seedDrand01((Rand_seed_t)seed());
80252599 2899 PL_srand_called = TRUE;
93dc8474 2900 }
fdf4dddd
DD
2901 {
2902 dSP;
2903 NV value;
a8e41ef4 2904
fdf4dddd 2905 if (MAXARG < 1)
7e9044f9
FC
2906 {
2907 EXTEND(SP, 1);
fdf4dddd 2908 value = 1.0;
7e9044f9 2909 }
fdf4dddd
DD
2910 else {
2911 SV * const sv = POPs;
2912 if(!sv)
2913 value = 1.0;
2914 else
2915 value = SvNV(sv);
2916 }
2917 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
a3463d96
DD
2918#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2919 if (! Perl_isnan(value) && value == 0.0)
2920#else
659c4b96 2921 if (value == 0.0)
a3463d96 2922#endif
fdf4dddd
DD
2923 value = 1.0;
2924 {
2925 dTARGET;
2926 PUSHs(TARG);
2927 PUTBACK;
2928 value *= Drand01();
2929 sv_setnv_mg(TARG, value);
2930 }
2931 }
2932 return NORMAL;
79072805
LW
2933}
2934
2935PP(pp_srand)
2936{
20b7effb 2937 dSP; dTARGET;
f914a682
JL
2938 UV anum;
2939
0a5f3363 2940 if (MAXARG >= 1 && (TOPs || POPs)) {
f914a682
JL
2941 SV *top;
2942 char *pv;
2943 STRLEN len;
2944 int flags;
2945
2946 top = POPs;
2947 pv = SvPV(top, len);
2948 flags = grok_number(pv, len, &anum);
2949
2950 if (!(flags & IS_NUMBER_IN_UV)) {
2951 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2952 "Integer overflow in srand");
2953 anum = UV_MAX;
2954 }
2955 }
2956 else {
2957 anum = seed();
2958 }
2959
85ab1d1d 2960 (void)seedDrand01((Rand_seed_t)anum);
80252599 2961 PL_srand_called = TRUE;
da1010ec
NC
2962 if (anum)
2963 XPUSHu(anum);
2964 else {
2965 /* Historically srand always returned true. We can avoid breaking
2966 that like this: */
2967 sv_setpvs(TARG, "0 but true");
2968 XPUSHTARG;
2969 }
83832992 2970 RETURN;
79072805
LW
2971}
2972
79072805
LW
2973PP(pp_int)
2974{
20b7effb 2975 dSP; dTARGET;
6f1401dc 2976 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 2977 {
6f1401dc
DM
2978 SV * const sv = TOPs;
2979 const IV iv = SvIV_nomg(sv);
28e5dec8
JH
2980 /* XXX it's arguable that compiler casting to IV might be subtly
2981 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2982 else preferring IV has introduced a subtle behaviour change bug. OTOH
2983 relying on floating point to be accurate is a bug. */
2984
c781a409 2985 if (!SvOK(sv)) {
922c4365 2986 SETu(0);
c781a409
RD
2987 }
2988 else if (SvIOK(sv)) {
2989 if (SvIsUV(sv))
6f1401dc 2990 SETu(SvUV_nomg(sv));
c781a409 2991 else
28e5dec8 2992 SETi(iv);
c781a409 2993 }
c781a409 2994 else {
6f1401dc 2995 const NV value = SvNV_nomg(sv);
b9d05018
FC
2996 if (UNLIKELY(Perl_isinfnan(value)))
2997 SETn(value);
5bf8b78e 2998 else if (value >= 0.0) {
28e5dec8
JH
2999 if (value < (NV)UV_MAX + 0.5) {
3000 SETu(U_V(value));
3001 } else {
059a1014 3002 SETn(Perl_floor(value));
28e5dec8 3003 }
1048ea30 3004 }
28e5dec8
JH
3005 else {
3006 if (value > (NV)IV_MIN - 0.5) {
3007 SETi(I_V(value));
3008 } else {
1bbae031 3009 SETn(Perl_ceil(value));
28e5dec8
JH
3010 }
3011 }
774d564b 3012 }
79072805 3013 }
699e9491 3014 return NORMAL;
79072805
LW
3015}
3016
463ee0b2
LW
3017PP(pp_abs)
3018{
20b7effb 3019 dSP; dTARGET;
6f1401dc 3020 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 3021 {
6f1401dc 3022 SV * const sv = TOPs;
28e5dec8 3023 /* This will cache the NV value if string isn't actually integer */
6f1401dc 3024 const IV iv = SvIV_nomg(sv);
a227d84d 3025
800401ee 3026 if (!SvOK(sv)) {
922c4365 3027 SETu(0);
800401ee
JH
3028 }
3029 else if (SvIOK(sv)) {
28e5dec8 3030 /* IVX is precise */
800401ee 3031 if (SvIsUV(sv)) {
6f1401dc 3032 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH
3033 } else {
3034 if (iv >= 0) {
3035 SETi(iv);
3036 } else {
3037 if (iv != IV_MIN) {
3038 SETi(-iv);
3039 } else {
3040 /* 2s complement assumption. Also, not really needed as
3041 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
b396d0d8 3042 SETu((UV)IV_MIN);
28e5dec8 3043 }
a227d84d 3044 }
28e5dec8
JH
3045 }
3046 } else{
6f1401dc 3047 const NV value = SvNV_nomg(sv);
774d564b 3048 if (value < 0.0)
1b6737cc 3049 SETn(-value);
a4474c9e
DD
3050 else
3051 SETn(value);
774d564b 3052 }
a0d0e21e 3053 }
067b7929 3054 return NORMAL;
463ee0b2
LW
3055}
3056
b1c05ba5
DM
3057
3058/* also used for: pp_hex() */
3059
79072805
LW
3060PP(pp_oct)
3061{
20b7effb 3062 dSP; dTARGET;
5c144d81 3063 const char *tmps;
53305cf1 3064 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 3065 STRLEN len;
53305cf1
NC
3066 NV result_nv;
3067 UV result_uv;
4e51bcca 3068 SV* const sv = TOPs;
79072805 3069
349d4f2f 3070 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS
3071 if (DO_UTF8(sv)) {
3072 /* If Unicode, try to downgrade
3073 * If not possible, croak. */
1b6737cc 3074 SV* const tsv = sv_2mortal(newSVsv(sv));
a8e41ef4 3075
2bc69dc4
NIS
3076 SvUTF8_on(tsv);
3077 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3078 tmps = SvPV_const(tsv, len);
2bc69dc4 3079 }
daa2adfd
NC
3080 if (PL_op->op_type == OP_HEX)
3081 goto hex;
3082
6f894ead 3083 while (*tmps && len && isSPACE(*tmps))
53305cf1 3084 tmps++, len--;
9e24b6e2 3085 if (*tmps == '0')
53305cf1 3086 tmps++, len--;
305b8651 3087 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
daa2adfd 3088 hex:
53305cf1 3089 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 3090 }
305b8651 3091 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
53305cf1 3092 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 3093 else
53305cf1
NC
3094 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3095
3096 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
4e51bcca 3097 SETn(result_nv);
53305cf1
NC
3098 }
3099 else {
4e51bcca 3100 SETu(result_uv);
53305cf1 3101 }
4e51bcca 3102 return NORMAL;
79072805
LW
3103}
3104
3105/* String stuff. */
3106
5febd2ff 3107
79072805
LW
3108PP(pp_length)
3109{
20b7effb 3110 dSP; dTARGET;
0bd48802 3111 SV * const sv = TOPs;
a0ed51b3 3112
7776003e 3113 U32 in_bytes = IN_BYTES;
5febd2ff
DM
3114 /* Simplest case shortcut:
3115 * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3116 * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3117 * set)
3118 */
7776003e 3119 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
5febd2ff
DM
3120
3121 STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
7776003e
DD
3122 SETs(TARG);
3123
5febd2ff 3124 if (LIKELY(svflags == SVf_POK))
7776003e 3125 goto simple_pv;
5febd2ff
DM
3126
3127 if (svflags & SVs_GMG)
7776003e 3128 mg_get(sv);
5febd2ff 3129
0f43fd57 3130 if (SvOK(sv)) {
5b750817 3131 STRLEN len;
f446eca7
DM
3132 if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3133 if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3134 goto simple_pv;
7b394f12
DM
3135 if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3136 /* no need to convert from bytes to chars */
3137 len = SvCUR(sv);
3138 goto return_bool;
3139 }
5b750817 3140 len = sv_len_utf8_nomg(sv);
f446eca7 3141 }
5febd2ff 3142 else {
7776003e 3143 /* unrolled SvPV_nomg_const(sv,len) */
5febd2ff
DM
3144 if (SvPOK_nog(sv)) {
3145 simple_pv:
7776003e 3146 len = SvCUR(sv);
7b394f12
DM
3147 if (PL_op->op_private & OPpTRUEBOOL) {
3148 return_bool:
3149 SETs(len ? &PL_sv_yes : &PL_sv_zero);
3150 return NORMAL;
3151 }
5febd2ff
DM
3152 }
3153 else {
7776003e
DD
3154 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3155 }
0f43fd57 3156 }
5b750817 3157 TARGi((IV)(len), 1);
5febd2ff
DM
3158 }
3159 else {
9407f9c1 3160 if (!SvPADTMP(TARG)) {
5febd2ff 3161 /* OPpTARGET_MY: targ is var in '$lex = length()' */
e03e82a0 3162 sv_set_undef(TARG);
5b750817 3163 SvSETMAGIC(TARG);
5febd2ff
DM
3164 }
3165 else
3166 /* TARG is on stack at this point and is overwriten by SETs.
3167 * This branch is the odd one out, so put TARG by default on
3168 * stack earlier to let local SP go out of liveness sooner */
7776003e 3169 SETs(&PL_sv_undef);
92331800 3170 }
7776003e 3171 return NORMAL; /* no putback, SP didn't move in this opcode */
79072805
LW
3172}
3173
5febd2ff 3174
83f78d1a
FC
3175/* Returns false if substring is completely outside original string.
3176 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3177 always be true for an explicit 0.
3178*/
3179bool
ddeaf645
DD
3180Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3181 bool pos1_is_uv, IV len_iv,
3182 bool len_is_uv, STRLEN *posp,
3183 STRLEN *lenp)
83f78d1a
FC
3184{
3185 IV pos2_iv;
3186 int pos2_is_uv;
3187
3188 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3189
3190 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3191 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3192 pos1_iv += curlen;
3193 }
3194 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3195 return FALSE;
3196
3197 if (len_iv || len_is_uv) {
3198 if (!len_is_uv && len_iv < 0) {
3199 pos2_iv = curlen + len_iv;
3200 if (curlen)
3201 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3202 else
3203 pos2_is_uv = 0;
3204 } else { /* len_iv >= 0 */
3205 if (!pos1_is_uv && pos1_iv < 0) {
3206 pos2_iv = pos1_iv + len_iv;
3207 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3208 } else {
3209 if ((UV)len_iv > curlen-(UV)pos1_iv)
3210 pos2_iv = curlen;
3211 else
3212 pos2_iv = pos1_iv+len_iv;
3213 pos2_is_uv = 1;
3214 }
3215 }
3216 }
3217 else {
3218 pos2_iv = curlen;
3219 pos2_is_uv = 1;
3220 }
3221
3222 if (!pos2_is_uv && pos2_iv < 0) {
3223 if (!pos1_is_uv && pos1_iv < 0)
3224 return FALSE;
3225 pos2_iv = 0;
3226 }
3227 else if (!pos1_is_uv && pos1_iv < 0)
3228 pos1_iv = 0;
3229
3230 if ((UV)pos2_iv < (UV)pos1_iv)
3231 pos2_iv = pos1_iv;
3232 if ((UV)pos2_iv > curlen)
3233 pos2_iv = curlen;
3234
3235 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3236 *posp = (STRLEN)( (UV)pos1_iv );
3237 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3238
3239 return TRUE;
3240}
3241
79072805
LW
3242PP(pp_substr)
3243{
20b7effb 3244 dSP; dTARGET;
79072805 3245 SV *sv;
463ee0b2 3246 STRLEN curlen;
9402d6ed 3247 STRLEN utf8_curlen;
777f7c56
EB
3248 SV * pos_sv;
3249 IV pos1_iv;
3250 int pos1_is_uv;
777f7c56
EB
3251 SV * len_sv;
3252 IV len_iv = 0;
83f78d1a 3253 int len_is_uv = 0;
24fcb59f 3254 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 3255 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 3256 const char *tmps;
9402d6ed 3257 SV *repl_sv = NULL;
cbbf8932 3258 const char *repl = NULL;
7b8d334a 3259 STRLEN repl_len;
7bc95ae1 3260 int num_args = PL_op->op_private & 7;
13e30c65 3261 bool repl_need_utf8_upgrade = FALSE;
79072805 3262
78f9721b
SM
3263 if (num_args > 2) {
3264 if (num_args > 3) {
24fcb59f 3265 if(!(repl_sv = POPs)) num_args--;
7bc95ae1
FC
3266 }
3267 if ((len_sv = POPs)) {
3268 len_iv = SvIV(len_sv);
83f78d1a 3269 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
7b8d334a 3270 }
7bc95ae1 3271 else num_args--;
5d82c453 3272 }
777f7c56
EB
3273 pos_sv = POPs;
3274 pos1_iv = SvIV(pos_sv);
3275 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3276 sv = POPs;
24fcb59f
FC
3277 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3278 assert(!repl_sv);
3279 repl_sv = POPs;
3280 }
6582db62 3281 if (lvalue && !repl_sv) {
83f78d1a
FC
3282 SV * ret;
3283 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3284 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3285 LvTYPE(ret) = 'x';
3286 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3287 LvTARGOFF(ret) =
3288 pos1_is_uv || pos1_iv >= 0
3289 ? (STRLEN)(UV)pos1_iv
b063b0a8 3290 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
83f78d1a
FC
3291 LvTARGLEN(ret) =
3292 len_is_uv || len_iv > 0
3293 ? (STRLEN)(UV)len_iv
b063b0a8 3294 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
83f78d1a 3295
83f78d1a
FC
3296 PUSHs(ret); /* avoid SvSETMAGIC here */
3297 RETURN;
a74fb2cd 3298 }
6582db62
FC
3299 if (repl_sv) {
3300 repl = SvPV_const(repl_sv, repl_len);
3301 SvGETMAGIC(sv);
3302 if (SvROK(sv))
3303 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3304 "Attempt to use reference as lvalue in substr"
3305 );
3306 tmps = SvPV_force_nomg(sv, curlen);
3307 if (DO_UTF8(repl_sv) && repl_len) {
3308 if (!DO_UTF8(sv)) {
41b1e858
AC
3309 /* Upgrade the dest, and recalculate tmps in case the buffer
3310 * got reallocated; curlen may also have been changed */
01680ee9 3311 sv_utf8_upgrade_nomg(sv);
41b1e858 3312 tmps = SvPV_nomg(sv, curlen);
6582db62
FC
3313 }
3314 }
3315 else if (DO_UTF8(sv))
3316 repl_need_utf8_upgrade = TRUE;
3317 }
3318 else tmps = SvPV_const(sv, curlen);
7e2040f0 3319 if (DO_UTF8(sv)) {
0d788f38 3320 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
9402d6ed
JH
3321 if (utf8_curlen == curlen)
3322 utf8_curlen = 0;
a0ed51b3 3323 else
9402d6ed 3324 curlen = utf8_curlen;
a0ed51b3 3325 }
d1c2b58a 3326 else
9402d6ed 3327 utf8_curlen = 0;
a0ed51b3 3328
83f78d1a
FC
3329 {
3330 STRLEN pos, len, byte_len, byte_pos;
777f7c56 3331
83f78d1a
FC
3332 if (!translate_substr_offsets(
3333 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3334 )) goto bound_fail;
777f7c56 3335
83f78d1a
FC
3336 byte_len = len;
3337 byte_pos = utf8_curlen
0d788f38 3338 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
d931b1be 3339
2154eca7 3340 tmps += byte_pos;
bbddc9e0
CS
3341
3342 if (rvalue) {
3343 SvTAINTED_off(TARG); /* decontaminate */
3344 SvUTF8_off(TARG); /* decontaminate */
3345 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3346#ifdef USE_LOCALE_COLLATE
bbddc9e0 3347 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3348#endif
bbddc9e0
CS
3349 if (utf8_curlen)
3350 SvUTF8_on(TARG);
3351 }
2154eca7 3352
f7928d6c 3353 if (repl) {
13e30c65
JH
3354 SV* repl_sv_copy = NULL;
3355
3356 if (repl_need_utf8_upgrade) {
3357 repl_sv_copy = newSVsv(repl_sv);
3358 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3359 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65 3360 }
502d9230 3361 if (!SvOK(sv))
500f3e18 3362 SvPVCLEAR(sv);
777f7c56 3363 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
ef8d46e8 3364 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3365 }
79072805 3366 }
6a9665b0
FC
3367 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3368 SP++;
3369 else if (rvalue) {
bbddc9e0
CS
3370 SvSETMAGIC(TARG);
3371 PUSHs(TARG);
3372 }
79072805 3373 RETURN;
777f7c56 3374
7b52d656 3375 bound_fail:
83f78d1a 3376 if (repl)
777f7c56
EB
3377 Perl_croak(aTHX_ "substr outside of string");
3378 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3379 RETPUSHUNDEF;
79072805
LW
3380}
3381
3382PP(pp_vec)
3383{
20b7effb 3384 dSP;
eb578fdb 3385 const IV size = POPi;
d69c4304 3386 SV* offsetsv = POPs;
eb578fdb 3387 SV * const src = POPs;
1b6737cc 3388 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3389 SV * ret;
1b92e694
DM
3390 UV retuv;
3391 STRLEN offset = 0;
3392 char errflags = 0;
d69c4304
DM
3393
3394 /* extract a STRLEN-ranged integer value from offsetsv into offset,
1b92e694 3395 * or flag that its out of range */
d69c4304
DM
3396 {
3397 IV iv = SvIV(offsetsv);
3398
3399 /* avoid a large UV being wrapped to a negative value */
1b92e694 3400 if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
b063b0a8 3401 errflags = LVf_OUT_OF_RANGE;
1b92e694 3402 else if (iv < 0)
b063b0a8 3403 errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
d69c4304 3404#if PTRSIZE < IVSIZE
1b92e694 3405 else if (iv > Size_t_MAX)
b063b0a8 3406 errflags = LVf_OUT_OF_RANGE;
d69c4304 3407#endif
1b92e694
DM
3408 else
3409 offset = (STRLEN)iv;
d69c4304
DM
3410 }
3411
1b92e694 3412 retuv = errflags ? 0 : do_vecget(src, offset, size);
a0d0e21e 3413
81e118e0 3414 if (lvalue) { /* it's an lvalue! */
2154eca7
EB
3415 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3416 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3417 LvTYPE(ret) = 'v';
3418 LvTARG(ret) = SvREFCNT_inc_simple(src);
3419 LvTARGOFF(ret) = offset;
3420 LvTARGLEN(ret) = size;
1b92e694 3421 LvFLAGS(ret) = errflags;
2154eca7
EB
3422 }
3423 else {
3424 dTARGET;
3425 SvTAINTED_off(TARG); /* decontaminate */
3426 ret = TARG;
79072805
LW
3427 }
3428
d69c4304 3429 sv_setuv(ret, retuv);
f9e95907
FC
3430 if (!lvalue)
3431 SvSETMAGIC(ret);
2154eca7 3432 PUSHs(ret);
79072805
LW
3433 RETURN;
3434}
3435
b1c05ba5
DM
3436
3437/* also used for: pp_rindex() */
3438
79072805
LW
3439PP(pp_index)
3440{
20b7effb 3441 dSP; dTARGET;
79072805
LW
3442 SV *big;
3443 SV *little;
c445ea15 3444 SV *temp = NULL;
ad66a58c 3445 STRLEN biglen;
2723d216 3446 STRLEN llen = 0;
b464e2b7
TC
3447 SSize_t offset = 0;
3448 SSize_t retval;
73ee8be2
NC
3449 const char *big_p;
3450 const char *little_p;
2f040f7f
NC
3451 bool big_utf8;
3452 bool little_utf8;
2723d216 3453 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3454 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3455
e1dccc0d
Z
3456 if (threeargs)
3457 offset = POPi;
79072805
LW
3458 little = POPs;
3459 big = POPs;
73ee8be2
NC
3460 big_p = SvPV_const(big, biglen);
3461 little_p = SvPV_const(little, llen);
3462
e609e586
NC
3463 big_utf8 = DO_UTF8(big);
3464 little_utf8 = DO_UTF8(little);
3465 if (big_utf8 ^ little_utf8) {
3466 /* One needs to be upgraded. */
8df0e7a2 3467 if (little_utf8) {
2f040f7f
NC
3468 /* Well, maybe instead we might be able to downgrade the small
3469 string? */
1eced8f8 3470 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC
3471 &little_utf8);
3472 if (little_utf8) {
3473 /* If the large string is ISO-8859-1, and it's not possible to
3474 convert the small string to ISO-8859-1, then there is no
3475 way that it could be found anywhere by index. */
3476 retval = -1;
7e8d786b 3477 goto push_result;
2f040f7f 3478 }
e609e586 3479
2f040f7f
NC
3480 /* At this point, pv is a malloc()ed string. So donate it to temp
3481 to ensure it will get free()d */
3482 little = temp = newSV(0);
73ee8be2
NC
3483 sv_usepvn(temp, pv, llen);
3484 little_p = SvPVX(little);
e609e586 3485 } else {
20e67ba1 3486 temp = newSVpvn(little_p, llen);
2f040f7f 3487
8df0e7a2 3488 sv_utf8_upgrade(temp);
20e67ba1
FC
3489 little = temp;
3490 little_p = SvPV_const(little, llen);
e609e586
NC
3491 }
3492 }
73ee8be2
NC
3493 if (SvGAMAGIC(big)) {
3494 /* Life just becomes a lot easier if I use a temporary here.
3495 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3496 will trigger magic and overloading again, as will fbm_instr()
3497 */
59cd0e26
NC
3498 big = newSVpvn_flags(big_p, biglen,
3499 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3500 big_p = SvPVX(big);
3501 }
e4e44778 3502 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC
3503 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3504 warn on undef, and we've already triggered a warning with the
3505 SvPV_const some lines above. We can't remove that, as we need to
3506 call some SvPV to trigger overloading early and find out if the
3507 string is UTF-8.
8bd97c0c 3508 This is all getting too messy. The API isn't quite clean enough,
73ee8be2
NC
3509 because data access has side effects.
3510 */
59cd0e26
NC
3511 little = newSVpvn_flags(little_p, llen,
3512 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3513 little_p = SvPVX(little);
3514 }
e609e586 3515
d3e26383 3516 if (!threeargs)
2723d216 3517 offset = is_index ? 0 : biglen;
a0ed51b3 3518 else {
ad66a58c 3519 if (big_utf8 && offset > 0)
b464e2b7 3520 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
73ee8be2
NC
3521 if (!is_index)
3522 offset += llen;
a0ed51b3 3523 }
79072805
LW
3524 if (offset < 0)
3525 offset = 0;
b464e2b7 3526 else if (offset > (SSize_t)biglen)
ad66a58c 3527 offset = biglen;
73ee8be2
NC
3528 if (!(little_p = is_index
3529 ? fbm_instr((unsigned char*)big_p + offset,
3530 (unsigned char*)big_p + biglen, little, 0)
3531 : rninstr(big_p, big_p + offset,
3532 little_p, little_p + llen)))
a0ed51b3 3533 retval = -1;
ad66a58c 3534 else {
73ee8be2 3535 retval = little_p - big_p;
15c41403 3536 if (retval > 1 && big_utf8)
b464e2b7 3537 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
ad66a58c 3538 }
ef8d46e8 3539 SvREFCNT_dec(temp);
7e8d786b
DM
3540
3541 push_result:
3542 /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3543 if (PL_op->op_private & OPpTRUEBOOL) {
3544 PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3545 ? &PL_sv_yes : &PL_sv_no);
3546 if (PL_op->op_private & OPpTARGET_MY)
3547 /* $lex = (index() == -1) */
3548 sv_setsv(TARG, TOPs);
3549 }
a8e41ef4 3550 else
7e8d786b 3551 PUSHi(retval);
79072805
LW
3552 RETURN;
3553}
3554
3555PP(pp_sprintf)
3556{
20b7effb 3557 dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3558 SvTAINTED_off(TARG);
79072805 3559 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3560 TAINT_IF(SvTAINTED(TARG));
79072805
LW
3561 SP = ORIGMARK;
3562 PUSHTARG;
3563 RETURN;
3564}
3565
79072805
LW
3566PP(pp_ord)
3567{
20b7effb 3568 dSP; dTARGET;
1eced8f8 3569
6ba92227 3570 SV *argsv = TOPs;
ba210ebe 3571 STRLEN len;
349d4f2f 3572 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3573
6ba92227 3574 SETu(DO_UTF8(argsv)
aee9b917 3575 ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
f3943cf2 3576 : (UV)(*s));
68795e93 3577
6ba92227 3578 return NORMAL;
79072805
LW
3579}
3580
463ee0b2
LW
3581PP(pp_chr)
3582{
20b7effb 3583 dSP; dTARGET;
463ee0b2 3584 char *tmps;
8a064bd6 3585 UV value;
d3261b99 3586 SV *top = TOPs;
8a064bd6 3587
71739502 3588 SvGETMAGIC(top);
9911fc4e
FC
3589 if (UNLIKELY(SvAMAGIC(top)))
3590 top = sv_2num(top);
99f450cc 3591 if (UNLIKELY(isinfnansv(top)))
147e3846 3592 Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
1cd88304
JH
3593 else {
3594 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3595 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3596 ||
3597 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
2cc2a5a0
KW
3598 && SvNV_nomg(top) < 0.0)))
3599 {
b3fe8680
FC
3600 if (ckWARN(WARN_UTF8)) {
3601 if (SvGMAGICAL(top)) {
3602 SV *top2 = sv_newmortal();
3603 sv_setsv_nomg(top2, top);
3604 top = top2;
3605 }
1cd88304 3606 Perl_warner(aTHX_ packWARN(WARN_UTF8),
147e3846