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