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