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