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