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