This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
optimise save/restore of PL_delaymagic.
[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 */
052a7c76 91 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
85e6fe83 92 EXTEND(SP, maxarg);
93965878 93 if (SvMAGICAL(TARG)) {
052a7c76 94 SSize_t i;
c70927a6 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 {
052a7c76
DM
101 SSize_t i;
102 for (i=0; i < maxarg; i++) {
428ccf1e
FC
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 {
bcb10b84
VP
765 I32 i = do_trans(sv);
766 mPUSHi(i);
5bbe7184 767 }
a0d0e21e 768 RETURN;
79072805
LW
769}
770
a0d0e21e 771/* Lvalue operators. */
79072805 772
f595e19f 773static size_t
81745e4e
NC
774S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
775{
81745e4e
NC
776 STRLEN len;
777 char *s;
f595e19f 778 size_t count = 0;
81745e4e
NC
779
780 PERL_ARGS_ASSERT_DO_CHOMP;
781
782 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
f595e19f 783 return 0;
81745e4e
NC
784 if (SvTYPE(sv) == SVt_PVAV) {
785 I32 i;
786 AV *const av = MUTABLE_AV(sv);
787 const I32 max = AvFILL(av);
788
789 for (i = 0; i <= max; i++) {
790 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
791 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
f595e19f 792 count += do_chomp(retval, sv, chomping);
81745e4e 793 }
f595e19f 794 return count;
81745e4e
NC
795 }
796 else if (SvTYPE(sv) == SVt_PVHV) {
797 HV* const hv = MUTABLE_HV(sv);
798 HE* entry;
799 (void)hv_iterinit(hv);
800 while ((entry = hv_iternext(hv)))
f595e19f
FC
801 count += do_chomp(retval, hv_iterval(hv,entry), chomping);
802 return count;
81745e4e
NC
803 }
804 else if (SvREADONLY(sv)) {
cb077ed2 805 Perl_croak_no_modify();
81745e4e
NC
806 }
807
47e13f24 808 if (IN_ENCODING) {
81745e4e
NC
809 if (!SvUTF8(sv)) {
810 /* XXX, here sv is utf8-ized as a side-effect!
811 If encoding.pm is used properly, almost string-generating
812 operations, including literal strings, chr(), input data, etc.
813 should have been utf8-ized already, right?
814 */
ad2de1b2 815 sv_recode_to_utf8(sv, _get_encoding());
81745e4e
NC
816 }
817 }
818
819 s = SvPV(sv, len);
820 if (chomping) {
81745e4e 821 if (s && len) {
997c424a
DD
822 char *temp_buffer = NULL;
823 SV *svrecode = NULL;
81745e4e
NC
824 s += --len;
825 if (RsPARA(PL_rs)) {
826 if (*s != '\n')
997c424a 827 goto nope_free_nothing;
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) {
997c424a
DD
851 /* Cannot downgrade, therefore cannot possibly match.
852 At this point, temp_buffer is not alloced, and
853 is the buffer inside PL_rs, so dont free it.
81745e4e
NC
854 */
855 assert (temp_buffer == rsptr);
997c424a 856 goto nope_free_sv;
81745e4e
NC
857 }
858 rsptr = temp_buffer;
859 }
47e13f24 860 else if (IN_ENCODING) {
81745e4e
NC
861 /* RS is 8 bit, encoding.pm is used.
862 * Do not recode PL_rs as a side-effect. */
863 svrecode = newSVpvn(rsptr, rslen);
ad2de1b2 864 sv_recode_to_utf8(svrecode, _get_encoding());
81745e4e
NC
865 rsptr = SvPV_const(svrecode, rslen);
866 rs_charlen = sv_len_utf8(svrecode);
867 }
868 else {
869 /* RS is 8 bit, scalar is utf8. */
870 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
871 rsptr = temp_buffer;
872 }
873 }
874 if (rslen == 1) {
875 if (*s != *rsptr)
997c424a 876 goto nope_free_all;
f595e19f 877 ++count;
81745e4e
NC
878 }
879 else {
880 if (len < rslen - 1)
997c424a 881 goto nope_free_all;
81745e4e
NC
882 len -= rslen - 1;
883 s -= rslen - 1;
884 if (memNE(s, rsptr, rslen))
997c424a 885 goto nope_free_all;
f595e19f 886 count += rs_charlen;
81745e4e
NC
887 }
888 }
3b7ded39 889 SvPV_force_nomg_nolen(sv);
81745e4e
NC
890 SvCUR_set(sv, len);
891 *SvEND(sv) = '\0';
892 SvNIOK_off(sv);
893 SvSETMAGIC(sv);
81745e4e 894
997c424a
DD
895 nope_free_all:
896 Safefree(temp_buffer);
897 nope_free_sv:
898 SvREFCNT_dec(svrecode);
899 nope_free_nothing: ;
900 }
81745e4e 901 } else {
f8c80a8e 902 if (len && (!SvPOK(sv) || SvIsCOW(sv)))
81745e4e
NC
903 s = SvPV_force_nomg(sv, len);
904 if (DO_UTF8(sv)) {
905 if (s && len) {
906 char * const send = s + len;
907 char * const start = s;
908 s = send - 1;
909 while (s > start && UTF8_IS_CONTINUATION(*s))
910 s--;
911 if (is_utf8_string((U8*)s, send - s)) {
912 sv_setpvn(retval, s, send - s);
913 *s = '\0';
914 SvCUR_set(sv, s - start);
915 SvNIOK_off(sv);
916 SvUTF8_on(retval);
917 }
918 }
919 else
920 sv_setpvs(retval, "");
921 }
922 else if (s && len) {
923 s += --len;
924 sv_setpvn(retval, s, 1);
925 *s = '\0';
926 SvCUR_set(sv, len);
927 SvUTF8_off(sv);
928 SvNIOK_off(sv);
929 }
930 else
931 sv_setpvs(retval, "");
932 SvSETMAGIC(sv);
933 }
f595e19f 934 return count;
81745e4e
NC
935}
936
b1c05ba5
DM
937
938/* also used for: pp_schomp() */
939
a0d0e21e
LW
940PP(pp_schop)
941{
20b7effb 942 dSP; dTARGET;
fa54efae
NC
943 const bool chomping = PL_op->op_type == OP_SCHOMP;
944
f595e19f 945 const size_t count = do_chomp(TARG, TOPs, chomping);
fa54efae 946 if (chomping)
f595e19f 947 sv_setiv(TARG, count);
a0d0e21e 948 SETTARG;
ee41d8c7 949 return NORMAL;
79072805
LW
950}
951
b1c05ba5
DM
952
953/* also used for: pp_chomp() */
954
a0d0e21e 955PP(pp_chop)
79072805 956{
20b7effb 957 dSP; dMARK; dTARGET; dORIGMARK;
fa54efae 958 const bool chomping = PL_op->op_type == OP_CHOMP;
f595e19f 959 size_t count = 0;
8ec5e241 960
20cf1f79 961 while (MARK < SP)
f595e19f
FC
962 count += do_chomp(TARG, *++MARK, chomping);
963 if (chomping)
964 sv_setiv(TARG, count);
20cf1f79
NC
965 SP = ORIGMARK;
966 XPUSHTARG;
a0d0e21e 967 RETURN;
79072805
LW
968}
969
a0d0e21e
LW
970PP(pp_undef)
971{
20b7effb 972 dSP;
a0d0e21e
LW
973 SV *sv;
974
533c011a 975 if (!PL_op->op_private) {
774d564b 976 EXTEND(SP, 1);
a0d0e21e 977 RETPUSHUNDEF;
774d564b 978 }
79072805 979
821f14b0 980 sv = TOPs;
a0d0e21e 981 if (!sv)
821f14b0
FC
982 {
983 SETs(&PL_sv_undef);
984 return NORMAL;
985 }
85e6fe83 986
4dda930b
FC
987 if (SvTHINKFIRST(sv))
988 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
85e6fe83 989
a0d0e21e
LW
990 switch (SvTYPE(sv)) {
991 case SVt_NULL:
992 break;
993 case SVt_PVAV:
60edcf09 994 av_undef(MUTABLE_AV(sv));
a0d0e21e
LW
995 break;
996 case SVt_PVHV:
60edcf09 997 hv_undef(MUTABLE_HV(sv));
a0d0e21e
LW
998 break;
999 case SVt_PVCV:
a2a5de95 1000 if (cv_const_sv((const CV *)sv))
714cd18f
BF
1001 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1002 "Constant subroutine %"SVf" undefined",
1003 SVfARG(CvANON((const CV *)sv)
1004 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
bdbfc51a
FC
1005 : sv_2mortal(newSVhek(
1006 CvNAMED(sv)
1007 ? CvNAME_HEK((CV *)sv)
1008 : GvENAME_HEK(CvGV((const CV *)sv))
1009 ))
1010 ));
5f66b61c 1011 /* FALLTHROUGH */
9607fc9c 1012 case SVt_PVFM:
6fc92669 1013 /* let user-undef'd sub keep its identity */
b7acb0a3 1014 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
a0d0e21e 1015 break;
8e07c86e 1016 case SVt_PVGV:
bc1df6c2
FC
1017 assert(isGV_with_GP(sv));
1018 assert(!SvFAKE(sv));
1019 {
20408e3c 1020 GP *gp;
dd69841b
BB
1021 HV *stash;
1022
dd69841b 1023 /* undef *Pkg::meth_name ... */
e530fb81
FC
1024 bool method_changed
1025 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1026 && HvENAME_get(stash);
1027 /* undef *Foo:: */
1028 if((stash = GvHV((const GV *)sv))) {
1029 if(HvENAME_get(stash))
1030 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1031 else stash = NULL;
1032 }
dd69841b 1033
795eb8c8 1034 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
159b6efe 1035 gp_free(MUTABLE_GV(sv));
a02a5408 1036 Newxz(gp, 1, GP);
c43ae56f 1037 GvGP_set(sv, gp_ref(gp));
2e3295e3 1038#ifndef PERL_DONT_CREATE_GVSV
561b68a9 1039 GvSV(sv) = newSV(0);
2e3295e3 1040#endif
57843af0 1041 GvLINE(sv) = CopLINE(PL_curcop);
159b6efe 1042 GvEGV(sv) = MUTABLE_GV(sv);
20408e3c 1043 GvMULTI_on(sv);
e530fb81
FC
1044
1045 if(stash)
afdbe55d 1046 mro_package_moved(NULL, stash, (const GV *)sv, 0);
e530fb81
FC
1047 stash = NULL;
1048 /* undef *Foo::ISA */
1049 if( strEQ(GvNAME((const GV *)sv), "ISA")
1050 && (stash = GvSTASH((const GV *)sv))
1051 && (method_changed || HvENAME(stash)) )
1052 mro_isa_changed_in(stash);
1053 else if(method_changed)
1054 mro_method_changed_in(
da9043f5 1055 GvSTASH((const GV *)sv)
e530fb81
FC
1056 );
1057
6e592b3a 1058 break;
20408e3c 1059 }
a0d0e21e 1060 default:
b15aece3 1061 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
8bd4d4c5 1062 SvPV_free(sv);
c445ea15 1063 SvPV_set(sv, NULL);
4633a7c4 1064 SvLEN_set(sv, 0);
a0d0e21e 1065 }
0c34ef67 1066 SvOK_off(sv);
4633a7c4 1067 SvSETMAGIC(sv);
79072805 1068 }
a0d0e21e 1069
821f14b0
FC
1070 SETs(&PL_sv_undef);
1071 return NORMAL;
79072805
LW
1072}
1073
b1c05ba5
DM
1074
1075/* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */
1076
a0d0e21e
LW
1077PP(pp_postinc)
1078{
20b7effb 1079 dSP; dTARGET;
c22c99bc
FC
1080 const bool inc =
1081 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
60092ce4 1082 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
cb077ed2 1083 Perl_croak_no_modify();
3baa0581 1084 if (SvROK(TOPs))
7dcb9b98 1085 TARG = sv_newmortal();
a0d0e21e 1086 sv_setsv(TARG, TOPs);
4bac9ae4 1087 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
c22c99bc 1088 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
55497cff 1089 {
c22c99bc 1090 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
55497cff 1091 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306 1092 }
c22c99bc 1093 else if (inc)
6f1401dc 1094 sv_inc_nomg(TOPs);
c22c99bc 1095 else sv_dec_nomg(TOPs);
a0d0e21e 1096 SvSETMAGIC(TOPs);
1e54a23f 1097 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
c22c99bc 1098 if (inc && !SvOK(TARG))
a0d0e21e 1099 sv_setiv(TARG, 0);
e87de4ab 1100 SETTARG;
a0d0e21e
LW
1101 return NORMAL;
1102}
79072805 1103
a0d0e21e
LW
1104/* Ordinary operators. */
1105
1106PP(pp_pow)
1107{
20b7effb 1108 dSP; dATARGET; SV *svl, *svr;
58d76dfd 1109#ifdef PERL_PRESERVE_IVUV
52a96ae6
HS
1110 bool is_int = 0;
1111#endif
6f1401dc
DM
1112 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1113 svr = TOPs;
1114 svl = TOPm1s;
52a96ae6
HS
1115#ifdef PERL_PRESERVE_IVUV
1116 /* For integer to integer power, we do the calculation by hand wherever
1117 we're sure it is safe; otherwise we call pow() and try to convert to
1118 integer afterwards. */
01f91bf2 1119 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
900658e3
PF
1120 UV power;
1121 bool baseuok;
1122 UV baseuv;
1123
800401ee
JH
1124 if (SvUOK(svr)) {
1125 power = SvUVX(svr);
900658e3 1126 } else {
800401ee 1127 const IV iv = SvIVX(svr);
900658e3
PF
1128 if (iv >= 0) {
1129 power = iv;
1130 } else {
1131 goto float_it; /* Can't do negative powers this way. */
1132 }
1133 }
1134
800401ee 1135 baseuok = SvUOK(svl);
900658e3 1136 if (baseuok) {
800401ee 1137 baseuv = SvUVX(svl);
900658e3 1138 } else {
800401ee 1139 const IV iv = SvIVX(svl);
900658e3
PF
1140 if (iv >= 0) {
1141 baseuv = iv;
1142 baseuok = TRUE; /* effectively it's a UV now */
1143 } else {
1144 baseuv = -iv; /* abs, baseuok == false records sign */
1145 }
1146 }
52a96ae6
HS
1147 /* now we have integer ** positive integer. */
1148 is_int = 1;
1149
1150 /* foo & (foo - 1) is zero only for a power of 2. */
58d76dfd 1151 if (!(baseuv & (baseuv - 1))) {
52a96ae6 1152 /* We are raising power-of-2 to a positive integer.
58d76dfd
JH
1153 The logic here will work for any base (even non-integer
1154 bases) but it can be less accurate than
1155 pow (base,power) or exp (power * log (base)) when the
1156 intermediate values start to spill out of the mantissa.
1157 With powers of 2 we know this can't happen.
1158 And powers of 2 are the favourite thing for perl
1159 programmers to notice ** not doing what they mean. */
1160 NV result = 1.0;
1161 NV base = baseuok ? baseuv : -(NV)baseuv;
900658e3
PF
1162
1163 if (power & 1) {
1164 result *= base;
1165 }
1166 while (power >>= 1) {
1167 base *= base;
1168 if (power & 1) {
1169 result *= base;
1170 }
1171 }
58d76dfd
JH
1172 SP--;
1173 SETn( result );
6f1401dc 1174 SvIV_please_nomg(svr);
58d76dfd 1175 RETURN;
52a96ae6 1176 } else {
eb578fdb
KW
1177 unsigned int highbit = 8 * sizeof(UV);
1178 unsigned int diff = 8 * sizeof(UV);
900658e3
PF
1179 while (diff >>= 1) {
1180 highbit -= diff;
1181 if (baseuv >> highbit) {
1182 highbit += diff;
1183 }
52a96ae6
HS
1184 }
1185 /* we now have baseuv < 2 ** highbit */
1186 if (power * highbit <= 8 * sizeof(UV)) {
1187 /* result will definitely fit in UV, so use UV math
1188 on same algorithm as above */
eb578fdb
KW
1189 UV result = 1;
1190 UV base = baseuv;
f2338a2e 1191 const bool odd_power = cBOOL(power & 1);
900658e3
PF
1192 if (odd_power) {
1193 result *= base;
1194 }
1195 while (power >>= 1) {
1196 base *= base;
1197 if (power & 1) {
52a96ae6 1198 result *= base;
52a96ae6
HS
1199 }
1200 }
1201 SP--;
0615a994 1202 if (baseuok || !odd_power)
52a96ae6
HS
1203 /* answer is positive */
1204 SETu( result );
1205 else if (result <= (UV)IV_MAX)
1206 /* answer negative, fits in IV */
1207 SETi( -(IV)result );
1208 else if (result == (UV)IV_MIN)
1209 /* 2's complement assumption: special case IV_MIN */
1210 SETi( IV_MIN );
1211 else
1212 /* answer negative, doesn't fit */
1213 SETn( -(NV)result );
1214 RETURN;
1215 }
1216 }
58d76dfd 1217 }
52a96ae6 1218 float_it:
58d76dfd 1219#endif
a0d0e21e 1220 {
6f1401dc
DM
1221 NV right = SvNV_nomg(svr);
1222 NV left = SvNV_nomg(svl);
4efa5a16 1223 (void)POPs;
3aaeb624
JA
1224
1225#if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1226 /*
1227 We are building perl with long double support and are on an AIX OS
1228 afflicted with a powl() function that wrongly returns NaNQ for any
1229 negative base. This was reported to IBM as PMR #23047-379 on
1230 03/06/2006. The problem exists in at least the following versions
1231 of AIX and the libm fileset, and no doubt others as well:
1232
1233 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1234 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1235 AIX 5.2.0 bos.adt.libm 5.2.0.85
1236
1237 So, until IBM fixes powl(), we provide the following workaround to
1238 handle the problem ourselves. Our logic is as follows: for
1239 negative bases (left), we use fmod(right, 2) to check if the
1240 exponent is an odd or even integer:
1241
1242 - if odd, powl(left, right) == -powl(-left, right)
1243 - if even, powl(left, right) == powl(-left, right)
1244
1245 If the exponent is not an integer, the result is rightly NaNQ, so
1246 we just return that (as NV_NAN).
1247 */
1248
1249 if (left < 0.0) {
1250 NV mod2 = Perl_fmod( right, 2.0 );
1251 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1252 SETn( -Perl_pow( -left, right) );
1253 } else if (mod2 == 0.0) { /* even integer */
1254 SETn( Perl_pow( -left, right) );
1255 } else { /* fractional power */
1256 SETn( NV_NAN );
1257 }
1258 } else {
1259 SETn( Perl_pow( left, right) );
1260 }
1261#else
52a96ae6 1262 SETn( Perl_pow( left, right) );
3aaeb624
JA
1263#endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1264
52a96ae6
HS
1265#ifdef PERL_PRESERVE_IVUV
1266 if (is_int)
6f1401dc 1267 SvIV_please_nomg(svr);
52a96ae6
HS
1268#endif
1269 RETURN;
93a17b20 1270 }
a0d0e21e
LW
1271}
1272
1273PP(pp_multiply)
1274{
20b7effb 1275 dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM
1276 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1277 svr = TOPs;
1278 svl = TOPm1s;
28e5dec8 1279#ifdef PERL_PRESERVE_IVUV
01f91bf2 1280 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
1281 /* Unless the left argument is integer in range we are going to have to
1282 use NV maths. Hence only attempt to coerce the right argument if
1283 we know the left is integer. */
1284 /* Left operand is defined, so is it IV? */
01f91bf2 1285 if (SvIV_please_nomg(svl)) {
800401ee
JH
1286 bool auvok = SvUOK(svl);
1287 bool buvok = SvUOK(svr);
28e5dec8
JH
1288 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1289 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1290 UV alow;
1291 UV ahigh;
1292 UV blow;
1293 UV bhigh;
1294
1295 if (auvok) {
800401ee 1296 alow = SvUVX(svl);
28e5dec8 1297 } else {
800401ee 1298 const IV aiv = SvIVX(svl);
28e5dec8
JH
1299 if (aiv >= 0) {
1300 alow = aiv;
1301 auvok = TRUE; /* effectively it's a UV now */
1302 } else {
53e2bfb7
DM
1303 /* abs, auvok == false records sign */
1304 alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
28e5dec8
JH
1305 }
1306 }
1307 if (buvok) {
800401ee 1308 blow = SvUVX(svr);
28e5dec8 1309 } else {
800401ee 1310 const IV biv = SvIVX(svr);
28e5dec8
JH
1311 if (biv >= 0) {
1312 blow = biv;
1313 buvok = TRUE; /* effectively it's a UV now */
1314 } else {
53e2bfb7
DM
1315 /* abs, buvok == false records sign */
1316 blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
28e5dec8
JH
1317 }
1318 }
1319
1320 /* If this does sign extension on unsigned it's time for plan B */
1321 ahigh = alow >> (4 * sizeof (UV));
1322 alow &= botmask;
1323 bhigh = blow >> (4 * sizeof (UV));
1324 blow &= botmask;
1325 if (ahigh && bhigh) {
6f207bd3 1326 NOOP;
28e5dec8
JH
1327 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1328 which is overflow. Drop to NVs below. */
1329 } else if (!ahigh && !bhigh) {
1330 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1331 so the unsigned multiply cannot overflow. */
c445ea15 1332 const UV product = alow * blow;
28e5dec8
JH
1333 if (auvok == buvok) {
1334 /* -ve * -ve or +ve * +ve gives a +ve result. */
1335 SP--;
1336 SETu( product );
1337 RETURN;
1338 } else if (product <= (UV)IV_MIN) {
1339 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1340 /* -ve result, which could overflow an IV */
1341 SP--;
02b08bbc
DM
1342 /* can't negate IV_MIN, but there are aren't two
1343 * integers such that !ahigh && !bhigh, where the
1344 * product equals 0x800....000 */
1345 assert(product != (UV)IV_MIN);
25716404 1346 SETi( -(IV)product );
28e5dec8
JH
1347 RETURN;
1348 } /* else drop to NVs below. */
1349 } else {
1350 /* One operand is large, 1 small */
1351 UV product_middle;
1352 if (bhigh) {
1353 /* swap the operands */
1354 ahigh = bhigh;
1355 bhigh = blow; /* bhigh now the temp var for the swap */
1356 blow = alow;
1357 alow = bhigh;
1358 }
1359 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1360 multiplies can't overflow. shift can, add can, -ve can. */
1361 product_middle = ahigh * blow;
1362 if (!(product_middle & topmask)) {
1363 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1364 UV product_low;
1365 product_middle <<= (4 * sizeof (UV));
1366 product_low = alow * blow;
1367
1368 /* as for pp_add, UV + something mustn't get smaller.
1369 IIRC ANSI mandates this wrapping *behaviour* for
1370 unsigned whatever the actual representation*/
1371 product_low += product_middle;
1372 if (product_low >= product_middle) {
1373 /* didn't overflow */
1374 if (auvok == buvok) {
1375 /* -ve * -ve or +ve * +ve gives a +ve result. */
1376 SP--;
1377 SETu( product_low );
1378 RETURN;
1379 } else if (product_low <= (UV)IV_MIN) {
1380 /* 2s complement assumption again */
1381 /* -ve result, which could overflow an IV */
1382 SP--;
53e2bfb7
DM
1383 SETi(product_low == (UV)IV_MIN
1384 ? IV_MIN : -(IV)product_low);
28e5dec8
JH
1385 RETURN;
1386 } /* else drop to NVs below. */
1387 }
1388 } /* product_middle too large */
1389 } /* ahigh && bhigh */
800401ee
JH
1390 } /* SvIOK(svl) */
1391 } /* SvIOK(svr) */
28e5dec8 1392#endif
a0d0e21e 1393 {
6f1401dc
DM
1394 NV right = SvNV_nomg(svr);
1395 NV left = SvNV_nomg(svl);
4efa5a16 1396 (void)POPs;
a0d0e21e
LW
1397 SETn( left * right );
1398 RETURN;
79072805 1399 }
a0d0e21e
LW
1400}
1401
1402PP(pp_divide)
1403{
20b7effb 1404 dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM
1405 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1406 svr = TOPs;
1407 svl = TOPm1s;
5479d192 1408 /* Only try to do UV divide first
68795e93 1409 if ((SLOPPYDIVIDE is true) or
5479d192
NC
1410 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1411 to preserve))
1412 The assumption is that it is better to use floating point divide
1413 whenever possible, only doing integer divide first if we can't be sure.
1414 If NV_PRESERVES_UV is true then we know at compile time that no UV
1415 can be too large to preserve, so don't need to compile the code to
1416 test the size of UVs. */
1417
a0d0e21e 1418#ifdef SLOPPYDIVIDE
5479d192
NC
1419# define PERL_TRY_UV_DIVIDE
1420 /* ensure that 20./5. == 4. */
a0d0e21e 1421#else
5479d192
NC
1422# ifdef PERL_PRESERVE_IVUV
1423# ifndef NV_PRESERVES_UV
1424# define PERL_TRY_UV_DIVIDE
1425# endif
1426# endif
a0d0e21e 1427#endif
5479d192
NC
1428
1429#ifdef PERL_TRY_UV_DIVIDE
01f91bf2 1430 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
800401ee
JH
1431 bool left_non_neg = SvUOK(svl);
1432 bool right_non_neg = SvUOK(svr);
5479d192
NC
1433 UV left;
1434 UV right;
1435
1436 if (right_non_neg) {
800401ee 1437 right = SvUVX(svr);
5479d192
NC
1438 }
1439 else {
800401ee 1440 const IV biv = SvIVX(svr);
5479d192
NC
1441 if (biv >= 0) {
1442 right = biv;
1443 right_non_neg = TRUE; /* effectively it's a UV now */
1444 }
1445 else {
02b08bbc 1446 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
5479d192
NC
1447 }
1448 }
1449 /* historically undef()/0 gives a "Use of uninitialized value"
1450 warning before dieing, hence this test goes here.
1451 If it were immediately before the second SvIV_please, then
1452 DIE() would be invoked before left was even inspected, so
486ec47a 1453 no inspection would give no warning. */
5479d192
NC
1454 if (right == 0)
1455 DIE(aTHX_ "Illegal division by zero");
1456
1457 if (left_non_neg) {
800401ee 1458 left = SvUVX(svl);
5479d192
NC
1459 }
1460 else {
800401ee 1461 const IV aiv = SvIVX(svl);
5479d192
NC
1462 if (aiv >= 0) {
1463 left = aiv;
1464 left_non_neg = TRUE; /* effectively it's a UV now */
1465 }
1466 else {
02b08bbc 1467 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
5479d192
NC
1468 }
1469 }
1470
1471 if (left >= right
1472#ifdef SLOPPYDIVIDE
1473 /* For sloppy divide we always attempt integer division. */
1474#else
1475 /* Otherwise we only attempt it if either or both operands
1476 would not be preserved by an NV. If both fit in NVs
0c2ee62a
NC
1477 we fall through to the NV divide code below. However,
1478 as left >= right to ensure integer result here, we know that
1479 we can skip the test on the right operand - right big
1480 enough not to be preserved can't get here unless left is
1481 also too big. */
1482
1483 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
5479d192
NC
1484#endif
1485 ) {
1486 /* Integer division can't overflow, but it can be imprecise. */
1b6737cc 1487 const UV result = left / right;
5479d192
NC
1488 if (result * right == left) {
1489 SP--; /* result is valid */
1490 if (left_non_neg == right_non_neg) {
1491 /* signs identical, result is positive. */
1492 SETu( result );
1493 RETURN;
1494 }
1495 /* 2s complement assumption */
1496 if (result <= (UV)IV_MIN)
02b08bbc 1497 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
5479d192
NC
1498 else {
1499 /* It's exact but too negative for IV. */
1500 SETn( -(NV)result );
1501 }
1502 RETURN;
1503 } /* tried integer divide but it was not an integer result */
32fdb065 1504 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
01f91bf2 1505 } /* one operand wasn't SvIOK */
5479d192
NC
1506#endif /* PERL_TRY_UV_DIVIDE */
1507 {
6f1401dc
DM
1508 NV right = SvNV_nomg(svr);
1509 NV left = SvNV_nomg(svl);
4efa5a16 1510 (void)POPs;(void)POPs;
ebc6a117
PD
1511#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1512 if (! Perl_isnan(right) && right == 0.0)
1513#else
659c4b96 1514 if (right == 0.0)
ebc6a117 1515#endif
5479d192
NC
1516 DIE(aTHX_ "Illegal division by zero");
1517 PUSHn( left / right );
1518 RETURN;
79072805 1519 }
a0d0e21e
LW
1520}
1521
1522PP(pp_modulo)
1523{
20b7effb 1524 dSP; dATARGET;
6f1401dc 1525 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
a0d0e21e 1526 {
9c5ffd7c
JH
1527 UV left = 0;
1528 UV right = 0;
dc656993
JH
1529 bool left_neg = FALSE;
1530 bool right_neg = FALSE;
e2c88acc
NC
1531 bool use_double = FALSE;
1532 bool dright_valid = FALSE;
9c5ffd7c
JH
1533 NV dright = 0.0;
1534 NV dleft = 0.0;
6f1401dc
DM
1535 SV * const svr = TOPs;
1536 SV * const svl = TOPm1s;
01f91bf2 1537 if (SvIV_please_nomg(svr)) {
800401ee 1538 right_neg = !SvUOK(svr);
e2c88acc 1539 if (!right_neg) {
800401ee 1540 right = SvUVX(svr);
e2c88acc 1541 } else {
800401ee 1542 const IV biv = SvIVX(svr);
e2c88acc
NC
1543 if (biv >= 0) {
1544 right = biv;
1545 right_neg = FALSE; /* effectively it's a UV now */
1546 } else {
02b08bbc 1547 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
e2c88acc
NC
1548 }
1549 }
1550 }
1551 else {
6f1401dc 1552 dright = SvNV_nomg(svr);
787eafbd
IZ
1553 right_neg = dright < 0;
1554 if (right_neg)
1555 dright = -dright;
e2c88acc
NC
1556 if (dright < UV_MAX_P1) {
1557 right = U_V(dright);
1558 dright_valid = TRUE; /* In case we need to use double below. */
1559 } else {
1560 use_double = TRUE;
1561 }
787eafbd 1562 }
a0d0e21e 1563
e2c88acc
NC
1564 /* At this point use_double is only true if right is out of range for
1565 a UV. In range NV has been rounded down to nearest UV and
1566 use_double false. */
01f91bf2 1567 if (!use_double && SvIV_please_nomg(svl)) {
800401ee 1568 left_neg = !SvUOK(svl);
e2c88acc 1569 if (!left_neg) {
800401ee 1570 left = SvUVX(svl);
e2c88acc 1571 } else {
800401ee 1572 const IV aiv = SvIVX(svl);
e2c88acc
NC
1573 if (aiv >= 0) {
1574 left = aiv;
1575 left_neg = FALSE; /* effectively it's a UV now */
1576 } else {
02b08bbc 1577 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
e2c88acc
NC
1578 }
1579 }
e2c88acc 1580 }
787eafbd 1581 else {
6f1401dc 1582 dleft = SvNV_nomg(svl);
787eafbd
IZ
1583 left_neg = dleft < 0;
1584 if (left_neg)
1585 dleft = -dleft;
68dc0745 1586
e2c88acc
NC
1587 /* This should be exactly the 5.6 behaviour - if left and right are
1588 both in range for UV then use U_V() rather than floor. */
1589 if (!use_double) {
1590 if (dleft < UV_MAX_P1) {
1591 /* right was in range, so is dleft, so use UVs not double.
1592 */
1593 left = U_V(dleft);
1594 }
1595 /* left is out of range for UV, right was in range, so promote
1596 right (back) to double. */
1597 else {
1598 /* The +0.5 is used in 5.6 even though it is not strictly
1599 consistent with the implicit +0 floor in the U_V()
1600 inside the #if 1. */
1601 dleft = Perl_floor(dleft + 0.5);
1602 use_double = TRUE;
1603 if (dright_valid)
1604 dright = Perl_floor(dright + 0.5);
1605 else
1606 dright = right;
1607 }
1608 }
1609 }
6f1401dc 1610 sp -= 2;
787eafbd 1611 if (use_double) {
65202027 1612 NV dans;
787eafbd 1613
659c4b96 1614 if (!dright)
cea2e8a9 1615 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1616
65202027 1617 dans = Perl_fmod(dleft, dright);
659c4b96 1618 if ((left_neg != right_neg) && dans)
787eafbd
IZ
1619 dans = dright - dans;
1620 if (right_neg)
1621 dans = -dans;
1622 sv_setnv(TARG, dans);
1623 }
1624 else {
1625 UV ans;
1626
787eafbd 1627 if (!right)
cea2e8a9 1628 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ
1629
1630 ans = left % right;
1631 if ((left_neg != right_neg) && ans)
1632 ans = right - ans;
1633 if (right_neg) {
1634 /* XXX may warn: unary minus operator applied to unsigned type */
1635 /* could change -foo to be (~foo)+1 instead */
1636 if (ans <= ~((UV)IV_MAX)+1)
1637 sv_setiv(TARG, ~ans+1);
1638 else
65202027 1639 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ
1640 }
1641 else
1642 sv_setuv(TARG, ans);
1643 }
1644 PUSHTARG;
1645 RETURN;
79072805 1646 }
a0d0e21e 1647}
79072805 1648
a0d0e21e
LW
1649PP(pp_repeat)
1650{
20b7effb 1651 dSP; dATARGET;
eb578fdb 1652 IV count;
6f1401dc 1653 SV *sv;
02a7a248 1654 bool infnan = FALSE;
6f1401dc 1655
82334630 1656 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
6f1401dc
DM
1657 /* TODO: think of some way of doing list-repeat overloading ??? */
1658 sv = POPs;
1659 SvGETMAGIC(sv);
1660 }
1661 else {
3a100dab
FC
1662 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1663 /* The parser saw this as a list repeat, and there
1664 are probably several items on the stack. But we're
1665 in scalar/void context, and there's no pp_list to save us
1666 now. So drop the rest of the items -- robin@kitsite.com
1667 */
1668 dMARK;
1669 if (MARK + 1 < SP) {
1670 MARK[1] = TOPm1s;
1671 MARK[2] = TOPs;
1672 }
1673 else {
1674 dTOPss;
1675 ASSUME(MARK + 1 == SP);
1676 XPUSHs(sv);
1677 MARK[1] = &PL_sv_undef;
1678 }
1679 SP = MARK + 2;
1680 }
6f1401dc
DM
1681 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1682 sv = POPs;
1683 }
1684
2b573ace
JH
1685 if (SvIOKp(sv)) {
1686 if (SvUOK(sv)) {
6f1401dc 1687 const UV uv = SvUV_nomg(sv);
2b573ace
JH
1688 if (uv > IV_MAX)
1689 count = IV_MAX; /* The best we can do? */
1690 else
1691 count = uv;
1692 } else {
b3211734 1693 count = SvIV_nomg(sv);
2b573ace
JH
1694 }
1695 }
1696 else if (SvNOKp(sv)) {
02a7a248
JH
1697 const NV nv = SvNV_nomg(sv);
1698 infnan = Perl_isinfnan(nv);
1699 if (UNLIKELY(infnan)) {
1700 count = 0;
1701 } else {
1702 if (nv < 0.0)
1703 count = -1; /* An arbitrary negative integer */
1704 else
1705 count = (IV)nv;
1706 }
2b573ace
JH
1707 }
1708 else
02a7a248 1709 count = SvIV_nomg(sv);
6f1401dc 1710
02a7a248
JH
1711 if (infnan) {
1712 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1713 "Non-finite repeat count does nothing");
1714 } else if (count < 0) {
b3211734
KW
1715 count = 0;
1716 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
02a7a248 1717 "Negative repeat count does nothing");
b3211734
KW
1718 }
1719
82334630 1720 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e 1721 dMARK;
052a7c76 1722 const SSize_t items = SP - MARK;
da9e430b 1723 const U8 mod = PL_op->op_flags & OPf_MOD;
79072805 1724
a0d0e21e 1725 if (count > 1) {
052a7c76 1726 SSize_t max;
b3b27d01 1727
052a7c76
DM
1728 if ( items > SSize_t_MAX / count /* max would overflow */
1729 /* repeatcpy would overflow */
1730 || items > I32_MAX / (I32)sizeof(SV *)
b3b27d01
DM
1731 )
1732 Perl_croak(aTHX_ "%s","Out of memory during list extend");
1733 max = items * count;
1734 MEXTEND(MARK, max);
1735
a0d0e21e 1736 while (SP > MARK) {
60779a30
DM
1737 if (*SP) {
1738 if (mod && SvPADTMP(*SP)) {
da9e430b 1739 *SP = sv_mortalcopy(*SP);
60779a30 1740 }
976c8a39 1741 SvTEMP_off((*SP));
da9e430b 1742 }
a0d0e21e 1743 SP--;
79072805 1744 }
a0d0e21e
LW
1745 MARK++;
1746 repeatcpy((char*)(MARK + items), (char*)MARK,
ad64d0ec 1747 items * sizeof(const SV *), count - 1);
a0d0e21e 1748 SP += max;
79072805 1749 }
a0d0e21e 1750 else if (count <= 0)
052a7c76 1751 SP = MARK;
79072805 1752 }
a0d0e21e 1753 else { /* Note: mark already snarfed by pp_list */
0bd48802 1754 SV * const tmpstr = POPs;
a0d0e21e 1755 STRLEN len;
9b877dbb 1756 bool isutf;
a0d0e21e 1757
6f1401dc
DM
1758 if (TARG != tmpstr)
1759 sv_setsv_nomg(TARG, tmpstr);
1760 SvPV_force_nomg(TARG, len);
9b877dbb 1761 isutf = DO_UTF8(TARG);
8ebc5c01
PP
1762 if (count != 1) {
1763 if (count < 1)
1764 SvCUR_set(TARG, 0);
1765 else {
b3b27d01
DM
1766 STRLEN max;
1767
1768 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1769 || len > (U32)I32_MAX /* repeatcpy would overflow */
1770 )
1771 Perl_croak(aTHX_ "%s",
1772 "Out of memory during string extend");
1773 max = (UV)count * len + 1;
1774 SvGROW(TARG, max);
1775
a0d0e21e 1776 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
b162af07 1777 SvCUR_set(TARG, SvCUR(TARG) * count);
7a4c00b4 1778 }
a0d0e21e 1779 *SvEND(TARG) = '\0';
a0d0e21e 1780 }
dfcb284a
GS
1781 if (isutf)
1782 (void)SvPOK_only_UTF8(TARG);
1783 else
1784 (void)SvPOK_only(TARG);
b80b6069 1785
a0d0e21e 1786 PUSHTARG;
79072805 1787 }
a0d0e21e
LW
1788 RETURN;
1789}
79072805 1790
a0d0e21e
LW
1791PP(pp_subtract)
1792{
20b7effb 1793 dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
1794 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1795 svr = TOPs;
1796 svl = TOPm1s;
800401ee 1797 useleft = USE_LEFT(svl);
28e5dec8 1798#ifdef PERL_PRESERVE_IVUV
7dca457a
NC
1799 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1800 "bad things" happen if you rely on signed integers wrapping. */
01f91bf2 1801 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
1802 /* Unless the left argument is integer in range we are going to have to
1803 use NV maths. Hence only attempt to coerce the right argument if
1804 we know the left is integer. */
eb578fdb 1805 UV auv = 0;
9c5ffd7c 1806 bool auvok = FALSE;
7dca457a
NC
1807 bool a_valid = 0;
1808
28e5dec8 1809 if (!useleft) {
7dca457a
NC
1810 auv = 0;
1811 a_valid = auvok = 1;
1812 /* left operand is undef, treat as zero. */
28e5dec8
JH
1813 } else {
1814 /* Left operand is defined, so is it IV? */
01f91bf2 1815 if (SvIV_please_nomg(svl)) {
800401ee
JH
1816 if ((auvok = SvUOK(svl)))
1817 auv = SvUVX(svl);
7dca457a 1818 else {
eb578fdb 1819 const IV aiv = SvIVX(svl);
7dca457a
NC
1820 if (aiv >= 0) {
1821 auv = aiv;
1822 auvok = 1; /* Now acting as a sign flag. */
1823 } else { /* 2s complement assumption for IV_MIN */
53e2bfb7 1824 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
28e5dec8 1825 }
7dca457a
NC
1826 }
1827 a_valid = 1;
1828 }
1829 }
1830 if (a_valid) {
1831 bool result_good = 0;
1832 UV result;
eb578fdb 1833 UV buv;
800401ee 1834 bool buvok = SvUOK(svr);
9041c2e3 1835
7dca457a 1836 if (buvok)
800401ee 1837 buv = SvUVX(svr);
7dca457a 1838 else {
eb578fdb 1839 const IV biv = SvIVX(svr);
7dca457a
NC
1840 if (biv >= 0) {
1841 buv = biv;
1842 buvok = 1;
1843 } else
53e2bfb7 1844 buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
7dca457a
NC
1845 }
1846 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1847 else "IV" now, independent of how it came in.
7dca457a
NC
1848 if a, b represents positive, A, B negative, a maps to -A etc
1849 a - b => (a - b)
1850 A - b => -(a + b)
1851 a - B => (a + b)
1852 A - B => -(a - b)
1853 all UV maths. negate result if A negative.
1854 subtract if signs same, add if signs differ. */
1855
1856 if (auvok ^ buvok) {
1857 /* Signs differ. */
1858 result = auv + buv;
1859 if (result >= auv)
1860 result_good = 1;
1861 } else {
1862 /* Signs same */
1863 if (auv >= buv) {
1864 result = auv - buv;
1865 /* Must get smaller */
1866 if (result <= auv)
1867 result_good = 1;
1868 } else {
1869 result = buv - auv;
1870 if (result <= buv) {
1871 /* result really should be -(auv-buv). as its negation
1872 of true value, need to swap our result flag */
1873 auvok = !auvok;
1874 result_good = 1;
28e5dec8 1875 }
28e5dec8
JH
1876 }
1877 }
7dca457a
NC
1878 if (result_good) {
1879 SP--;
1880 if (auvok)
1881 SETu( result );
1882 else {
1883 /* Negate result */
1884 if (result <= (UV)IV_MIN)
53e2bfb7
DM
1885 SETi(result == (UV)IV_MIN
1886 ? IV_MIN : -(IV)result);
7dca457a
NC
1887 else {
1888 /* result valid, but out of range for IV. */
1889 SETn( -(NV)result );
1890 }
1891 }
1892 RETURN;
1893 } /* Overflow, drop through to NVs. */
28e5dec8
JH
1894 }
1895 }
1896#endif
a0d0e21e 1897 {
6f1401dc 1898 NV value = SvNV_nomg(svr);
4efa5a16
RD
1899 (void)POPs;
1900
28e5dec8
JH
1901 if (!useleft) {
1902 /* left operand is undef, treat as zero - value */
1903 SETn(-value);
1904 RETURN;
1905 }
6f1401dc 1906 SETn( SvNV_nomg(svl) - value );
28e5dec8 1907 RETURN;
79072805 1908 }
a0d0e21e 1909}
79072805 1910
b3498293
JH
1911#define IV_BITS (IVSIZE * 8)
1912
1913static UV S_uv_shift(UV uv, int shift, bool left)
1914{
1915 if (shift < 0) {
1916 shift = -shift;
1917 left = !left;
1918 }
1919 if (shift >= IV_BITS) {
1920 return 0;
1921 }
1922 return left ? uv << shift : uv >> shift;
1923}
1924
1925static IV S_iv_shift(IV iv, int shift, bool left)
1926{
1927 if (shift < 0) {
1928 shift = -shift;
1929 left = !left;
1930 }
1931 if (shift >= IV_BITS) {
b69687e7 1932 return iv < 0 && !left ? -1 : 0;
b3498293
JH
1933 }
1934 return left ? iv << shift : iv >> shift;
1935}
1936
1937#define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
1938#define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
1939#define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
1940#define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
1941
a0d0e21e
LW
1942PP(pp_left_shift)
1943{
20b7effb 1944 dSP; dATARGET; SV *svl, *svr;
a42d0242 1945 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
1946 svr = POPs;
1947 svl = TOPs;
a0d0e21e 1948 {
6f1401dc 1949 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1950 if (PL_op->op_private & HINT_INTEGER) {
b3498293 1951 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
d0ba1bd2
JH
1952 }
1953 else {
b3498293 1954 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
d0ba1bd2 1955 }
55497cff 1956 RETURN;
79072805 1957 }
a0d0e21e 1958}
79072805 1959
a0d0e21e
LW
1960PP(pp_right_shift)
1961{
20b7effb 1962 dSP; dATARGET; SV *svl, *svr;
a42d0242 1963 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
1964 svr = POPs;
1965 svl = TOPs;
a0d0e21e 1966 {
6f1401dc 1967 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1968 if (PL_op->op_private & HINT_INTEGER) {
b3498293 1969 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
d0ba1bd2
JH
1970 }
1971 else {
b3498293 1972 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
d0ba1bd2 1973 }
a0d0e21e 1974 RETURN;
93a17b20 1975 }
79072805
LW
1976}
1977
a0d0e21e 1978PP(pp_lt)
79072805 1979{
20b7effb 1980 dSP;
33efebe6
DM
1981 SV *left, *right;
1982
a42d0242 1983 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
1984 right = POPs;
1985 left = TOPs;
1986 SETs(boolSV(
1987 (SvIOK_notUV(left) && SvIOK_notUV(right))
1988 ? (SvIVX(left) < SvIVX(right))
1989 : (do_ncmp(left, right) == -1)
1990 ));
1991 RETURN;
a0d0e21e 1992}
79072805 1993
a0d0e21e
LW
1994PP(pp_gt)
1995{
20b7effb 1996 dSP;
33efebe6 1997 SV *left, *right;
1b6737cc 1998
33efebe6
DM
1999 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2000 right = POPs;
2001 left = TOPs;
2002 SETs(boolSV(
2003 (SvIOK_notUV(left) && SvIOK_notUV(right))
2004 ? (SvIVX(left) > SvIVX(right))
2005 : (do_ncmp(left, right) == 1)
2006 ));
2007 RETURN;
a0d0e21e
LW
2008}
2009
2010PP(pp_le)
2011{
20b7effb 2012 dSP;
33efebe6 2013 SV *left, *right;
1b6737cc 2014
33efebe6
DM
2015 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2016 right = POPs;
2017 left = TOPs;
2018 SETs(boolSV(
2019 (SvIOK_notUV(left) && SvIOK_notUV(right))
2020 ? (SvIVX(left) <= SvIVX(right))
2021 : (do_ncmp(left, right) <= 0)
2022 ));
2023 RETURN;
a0d0e21e
LW
2024}
2025
2026PP(pp_ge)
2027{
20b7effb 2028 dSP;
33efebe6
DM
2029 SV *left, *right;
2030
2031 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2032 right = POPs;
2033 left = TOPs;
2034 SETs(boolSV(
2035 (SvIOK_notUV(left) && SvIOK_notUV(right))
2036 ? (SvIVX(left) >= SvIVX(right))
2037 : ( (do_ncmp(left, right) & 2) == 0)
2038 ));
2039 RETURN;
2040}
1b6737cc 2041
33efebe6
DM
2042PP(pp_ne)
2043{
20b7effb 2044 dSP;
33efebe6
DM
2045 SV *left, *right;
2046
2047 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2048 right = POPs;
2049 left = TOPs;
2050 SETs(boolSV(
2051 (SvIOK_notUV(left) && SvIOK_notUV(right))
2052 ? (SvIVX(left) != SvIVX(right))
2053 : (do_ncmp(left, right) != 0)
2054 ));
2055 RETURN;
2056}
1b6737cc 2057
33efebe6
DM
2058/* compare left and right SVs. Returns:
2059 * -1: <
2060 * 0: ==
2061 * 1: >
2062 * 2: left or right was a NaN
2063 */
2064I32
2065Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2066{
33efebe6
DM
2067 PERL_ARGS_ASSERT_DO_NCMP;
2068#ifdef PERL_PRESERVE_IVUV
33efebe6 2069 /* Fortunately it seems NaN isn't IOK */
01f91bf2 2070 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
33efebe6
DM
2071 if (!SvUOK(left)) {
2072 const IV leftiv = SvIVX(left);
2073 if (!SvUOK(right)) {
2074 /* ## IV <=> IV ## */
2075 const IV rightiv = SvIVX(right);
2076 return (leftiv > rightiv) - (leftiv < rightiv);
28e5dec8 2077 }
33efebe6
DM
2078 /* ## IV <=> UV ## */
2079 if (leftiv < 0)
2080 /* As (b) is a UV, it's >=0, so it must be < */
2081 return -1;
2082 {
2083 const UV rightuv = SvUVX(right);
2084 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
28e5dec8 2085 }
28e5dec8 2086 }
79072805 2087
33efebe6
DM
2088 if (SvUOK(right)) {
2089 /* ## UV <=> UV ## */
2090 const UV leftuv = SvUVX(left);
2091 const UV rightuv = SvUVX(right);
2092 return (leftuv > rightuv) - (leftuv < rightuv);
28e5dec8 2093 }
33efebe6
DM
2094 /* ## UV <=> IV ## */
2095 {
2096 const IV rightiv = SvIVX(right);
2097 if (rightiv < 0)
2098 /* As (a) is a UV, it's >=0, so it cannot be < */
2099 return 1;
2100 {
2101 const UV leftuv = SvUVX(left);
2102 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
28e5dec8 2103 }
28e5dec8 2104 }
e5964223 2105 NOT_REACHED; /* NOTREACHED */
28e5dec8
JH
2106 }
2107#endif
a0d0e21e 2108 {
33efebe6
DM
2109 NV const rnv = SvNV_nomg(right);
2110 NV const lnv = SvNV_nomg(left);
2111
cab190d4 2112#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
33efebe6
DM
2113 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2114 return 2;
2115 }
2116 return (lnv > rnv) - (lnv < rnv);
cab190d4 2117#else
33efebe6
DM
2118 if (lnv < rnv)
2119 return -1;
2120 if (lnv > rnv)
2121 return 1;
659c4b96 2122 if (lnv == rnv)
33efebe6
DM
2123 return 0;
2124 return 2;
cab190d4 2125#endif
a0d0e21e 2126 }
79072805
LW
2127}
2128
33efebe6 2129
a0d0e21e 2130PP(pp_ncmp)
79072805 2131{
20b7effb 2132 dSP;
33efebe6
DM
2133 SV *left, *right;
2134 I32 value;
a42d0242 2135 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
33efebe6
DM
2136 right = POPs;
2137 left = TOPs;
2138 value = do_ncmp(left, right);
2139 if (value == 2) {
3280af22 2140 SETs(&PL_sv_undef);
79072805 2141 }
33efebe6
DM
2142 else {
2143 dTARGET;
2144 SETi(value);
2145 }
2146 RETURN;
a0d0e21e 2147}
79072805 2148
b1c05ba5
DM
2149
2150/* also used for: pp_sge() pp_sgt() pp_slt() */
2151
afd9910b 2152PP(pp_sle)
a0d0e21e 2153{
20b7effb 2154 dSP;
79072805 2155
afd9910b
NC
2156 int amg_type = sle_amg;
2157 int multiplier = 1;
2158 int rhs = 1;
79072805 2159
afd9910b
NC
2160 switch (PL_op->op_type) {
2161 case OP_SLT:
2162 amg_type = slt_amg;
2163 /* cmp < 0 */
2164 rhs = 0;
2165 break;
2166 case OP_SGT:
2167 amg_type = sgt_amg;
2168 /* cmp > 0 */
2169 multiplier = -1;
2170 rhs = 0;
2171 break;
2172 case OP_SGE:
2173 amg_type = sge_amg;
2174 /* cmp >= 0 */
2175 multiplier = -1;
2176 break;
79072805 2177 }
79072805 2178
6f1401dc 2179 tryAMAGICbin_MG(amg_type, AMGf_set);
a0d0e21e
LW
2180 {
2181 dPOPTOPssrl;
130c5df3 2182 const int cmp =
5778acb6 2183#ifdef USE_LOCALE_COLLATE
130c5df3
KW
2184 (IN_LC_RUNTIME(LC_COLLATE))
2185 ? sv_cmp_locale_flags(left, right, 0)
2186 :
2187#endif
2188 sv_cmp_flags(left, right, 0);
afd9910b 2189 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW
2190 RETURN;
2191 }
2192}
79072805 2193
36477c24
PP
2194PP(pp_seq)
2195{
20b7effb 2196 dSP;
6f1401dc 2197 tryAMAGICbin_MG(seq_amg, AMGf_set);
36477c24
PP
2198 {
2199 dPOPTOPssrl;
078504b2 2200 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW
2201 RETURN;
2202 }
2203}
79072805 2204
a0d0e21e 2205PP(pp_sne)
79072805 2206{
20b7effb 2207 dSP;
6f1401dc 2208 tryAMAGICbin_MG(sne_amg, AMGf_set);
a0d0e21e
LW
2209 {
2210 dPOPTOPssrl;
078504b2 2211 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2212 RETURN;
463ee0b2 2213 }
79072805
LW
2214}
2215
a0d0e21e 2216PP(pp_scmp)
79072805 2217{
20b7effb 2218 dSP; dTARGET;
6f1401dc 2219 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW
2220 {
2221 dPOPTOPssrl;
130c5df3 2222 const int cmp =
5778acb6 2223#ifdef USE_LOCALE_COLLATE
130c5df3
KW
2224 (IN_LC_RUNTIME(LC_COLLATE))
2225 ? sv_cmp_locale_flags(left, right, 0)
2226 :
2227#endif
2228 sv_cmp_flags(left, right, 0);
bbce6d69 2229 SETi( cmp );
a0d0e21e
LW
2230 RETURN;
2231 }
2232}
79072805 2233
55497cff
PP
2234PP(pp_bit_and)
2235{
20b7effb 2236 dSP; dATARGET;
6f1401dc 2237 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW
2238 {
2239 dPOPTOPssrl;
4633a7c4 2240 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2241 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2242 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2243 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2244 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2245 SETi(i);
d0ba1bd2
JH
2246 }
2247 else {
1b6737cc 2248 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2249 SETu(u);
d0ba1bd2 2250 }
5ee80e13 2251 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2252 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2253 }
2254 else {
533c011a 2255 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2256 SETTARG;
2257 }
2258 RETURN;
2259 }
2260}
79072805 2261
5d01050a
FC
2262PP(pp_nbit_and)
2263{
2264 dSP;
636ac8fc 2265 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
5d01050a
FC
2266 {
2267 dATARGET; dPOPTOPssrl;
2268 if (PL_op->op_private & HINT_INTEGER) {
2269 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2270 SETi(i);
2271 }
2272 else {
2273 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2274 SETu(u);
2275 }
2276 }
2277 RETURN;
2278}
2279
2280PP(pp_sbit_and)
2281{
2282 dSP;
2283 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2284 {
2285 dATARGET; dPOPTOPssrl;
2286 do_vop(OP_BIT_AND, TARG, left, right);
2287 RETSETTARG;
2288 }
2289}
b1c05ba5
DM
2290
2291/* also used for: pp_bit_xor() */
2292
a0d0e21e
LW
2293PP(pp_bit_or)
2294{
20b7effb 2295 dSP; dATARGET;
3658c1f1
NC
2296 const int op_type = PL_op->op_type;
2297
6f1401dc 2298 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW
2299 {
2300 dPOPTOPssrl;
4633a7c4 2301 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2302 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2303 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2304 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC
2305 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2306 const IV r = SvIV_nomg(right);
2307 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2308 SETi(result);
d0ba1bd2
JH
2309 }
2310 else {
3658c1f1
NC
2311 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2312 const UV r = SvUV_nomg(right);
2313 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2314 SETu(result);
d0ba1bd2 2315 }
5ee80e13 2316 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2317 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2318 }
2319 else {
3658c1f1 2320 do_vop(op_type, TARG, left, right);
a0d0e21e
LW
2321 SETTARG;
2322 }
2323 RETURN;
79072805 2324 }
a0d0e21e 2325}
79072805 2326
5d01050a
FC
2327/* also used for: pp_nbit_xor() */
2328
2329PP(pp_nbit_or)
2330{
2331 dSP;
2332 const int op_type = PL_op->op_type;
2333
2334 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
636ac8fc 2335 AMGf_assign|AMGf_numarg);
5d01050a
FC
2336 {
2337 dATARGET; dPOPTOPssrl;
2338 if (PL_op->op_private & HINT_INTEGER) {
2339 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2340 const IV r = SvIV_nomg(right);
2341 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2342 SETi(result);
2343 }
2344 else {
2345 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2346 const UV r = SvUV_nomg(right);
2347 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2348 SETu(result);
2349 }
2350 }
2351 RETURN;
2352}
2353
2354/* also used for: pp_sbit_xor() */
2355
2356PP(pp_sbit_or)
2357{
2358 dSP;
2359 const int op_type = PL_op->op_type;
2360
2361 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2362 AMGf_assign);
2363 {
2364 dATARGET; dPOPTOPssrl;
2365 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2366 right);
2367 RETSETTARG;
2368 }
2369}
2370
1c2b3fd6
FC
2371PERL_STATIC_INLINE bool
2372S_negate_string(pTHX)
2373{
2374 dTARGET; dSP;
2375 STRLEN len;
2376 const char *s;
2377 SV * const sv = TOPs;
2378 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2379 return FALSE;
2380 s = SvPV_nomg_const(sv, len);
2381 if (isIDFIRST(*s)) {
2382 sv_setpvs(TARG, "-");
2383 sv_catsv(TARG, sv);
2384 }
2385 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2386 sv_setsv_nomg(TARG, sv);
2387 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2388 }
2389 else return FALSE;
245d035e 2390 SETTARG;
1c2b3fd6
FC
2391 return TRUE;
2392}
2393
a0d0e21e
LW
2394PP(pp_negate)
2395{
20b7effb 2396 dSP; dTARGET;
6f1401dc 2397 tryAMAGICun_MG(neg_amg, AMGf_numeric);
1c2b3fd6 2398 if (S_negate_string(aTHX)) return NORMAL;
a0d0e21e 2399 {
6f1401dc 2400 SV * const sv = TOPs;
a5b92898 2401
d96ab1b5 2402 if (SvIOK(sv)) {
7dbe3150 2403 /* It's publicly an integer */
28e5dec8 2404 oops_its_an_int:
9b0e499b
GS
2405 if (SvIsUV(sv)) {
2406 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2407 /* 2s complement assumption. */
d14578b8
KW
2408 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2409 IV_MIN */
245d035e 2410 return NORMAL;
9b0e499b
GS
2411 }
2412 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2413 SETi(-SvIVX(sv));
245d035e 2414 return NORMAL;
9b0e499b
GS
2415 }
2416 }
2417 else if (SvIVX(sv) != IV_MIN) {
2418 SETi(-SvIVX(sv));
245d035e 2419 return NORMAL;
9b0e499b 2420 }
28e5dec8
JH
2421#ifdef PERL_PRESERVE_IVUV
2422 else {
2423 SETu((UV)IV_MIN);
245d035e 2424 return NORMAL;
28e5dec8
JH
2425 }
2426#endif
9b0e499b 2427 }
8a5decd8 2428 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
6f1401dc 2429 SETn(-SvNV_nomg(sv));
1c2b3fd6 2430 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
8eb28a70 2431 goto oops_its_an_int;
4633a7c4 2432 else
6f1401dc 2433 SETn(-SvNV_nomg(sv));
79072805 2434 }
245d035e 2435 return NORMAL;
79072805
LW
2436}
2437
a0d0e21e 2438PP(pp_not)
79072805 2439{
20b7effb 2440 dSP;
6f1401dc 2441 tryAMAGICun_MG(not_amg, AMGf_set);
06c841cf 2442 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
a0d0e21e 2443 return NORMAL;
79072805
LW
2444}
2445
5d01050a
FC
2446static void
2447S_scomplement(pTHX_ SV *targ, SV *sv)
79072805 2448{
eb578fdb
KW
2449 U8 *tmps;
2450 I32 anum;
a0d0e21e
LW
2451 STRLEN len;
2452
85b0ee6e
FC
2453 sv_copypv_nomg(TARG, sv);
2454 tmps = (U8*)SvPV_nomg(TARG, len);
a0d0e21e 2455 anum = len;
1d68d6cd 2456 if (SvUTF8(TARG)) {
a1ca4561 2457 /* Calculate exact length, let's not estimate. */
1d68d6cd 2458 STRLEN targlen = 0;
ba210ebe 2459 STRLEN l;
a1ca4561
YST
2460 UV nchar = 0;
2461 UV nwide = 0;
01f6e806 2462 U8 * const send = tmps + len;
74d49cd0
ST
2463 U8 * const origtmps = tmps;
2464 const UV utf8flags = UTF8_ALLOW_ANYUV;
1d68d6cd 2465
1d68d6cd 2466 while (tmps < send) {
74d49cd0
ST
2467 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2468 tmps += l;
5f560d8a 2469 targlen += UVCHR_SKIP(~c);
a1ca4561
YST
2470 nchar++;
2471 if (c > 0xff)
2472 nwide++;
1d68d6cd
SC
2473 }
2474
2475 /* Now rewind strings and write them. */
74d49cd0 2476 tmps = origtmps;
a1ca4561
YST
2477
2478 if (nwide) {
01f6e806
AL
2479 U8 *result;
2480 U8 *p;
2481
74d49cd0 2482 Newx(result, targlen + 1, U8);
01f6e806 2483 p = result;
a1ca4561 2484 while (tmps < send) {
74d49cd0
ST
2485 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2486 tmps += l;
01f6e806 2487 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
a1ca4561 2488 }
01f6e806 2489 *p = '\0';
c1c21316
NC
2490 sv_usepvn_flags(TARG, (char*)result, targlen,
2491 SV_HAS_TRAILING_NUL);
a1ca4561
YST
2492 SvUTF8_on(TARG);
2493 }
2494 else {
01f6e806
AL
2495 U8 *result;
2496 U8 *p;
2497
74d49cd0 2498 Newx(result, nchar + 1, U8);
01f6e806 2499 p = result;
a1ca4561 2500 while (tmps < send) {
74d49cd0
ST
2501 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2502 tmps += l;
01f6e806 2503 *p++ = ~c;
a1ca4561 2504 }
01f6e806 2505 *p = '\0';
c1c21316 2506 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
d0a21e00 2507 SvUTF8_off(TARG);
1d68d6cd 2508 }
5d01050a 2509 return;
1d68d6cd 2510 }
a0d0e21e 2511#ifdef LIBERAL
51723571 2512 {
eb578fdb 2513 long *tmpl;
51723571
JH
2514 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2515 *tmps = ~*tmps;
2516 tmpl = (long*)tmps;
bb7a0f54 2517 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH
2518 *tmpl = ~*tmpl;
2519 tmps = (U8*)tmpl;
2520 }
a0d0e21e
LW
2521#endif
2522 for ( ; anum > 0; anum--, tmps++)
2523 *tmps = ~*tmps;
5d01050a
FC
2524}
2525
2526PP(pp_complement)
2527{
2528 dSP; dTARGET;
2529 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2530 {
2531 dTOPss;
2532 if (SvNIOKp(sv)) {
2533 if (PL_op->op_private & HINT_INTEGER) {
2534 const IV i = ~SvIV_nomg(sv);
2535 SETi(i);
2536 }
2537 else {
2538 const UV u = ~SvUV_nomg(sv);
2539 SETu(u);
2540 }
2541 }
2542 else {
2543 S_scomplement(aTHX_ TARG, sv);
ec93b65f 2544 SETTARG;
a0d0e21e 2545 }
24840750 2546 return NORMAL;
5d01050a
FC
2547 }
2548}
2549
2550PP(pp_ncomplement)
2551{
2552 dSP;
636ac8fc 2553 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
5d01050a
FC
2554 {
2555 dTARGET; dTOPss;
2556 if (PL_op->op_private & HINT_INTEGER) {
2557 const IV i = ~SvIV_nomg(sv);
2558 SETi(i);
2559 }
2560 else {
2561 const UV u = ~SvUV_nomg(sv);
2562 SETu(u);
2563 }
2564 }
2565 return NORMAL;
2566}
2567
2568PP(pp_scomplement)
2569{
2570 dSP;
2571 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2572 {
2573 dTARGET; dTOPss;
2574 S_scomplement(aTHX_ TARG, sv);
2575 SETTARG;
2576 return NORMAL;
a0d0e21e 2577 }
79072805
LW
2578}
2579
a0d0e21e
LW
2580/* integer versions of some of the above */
2581
a0d0e21e 2582PP(pp_i_multiply)
79072805 2583{
20b7effb 2584 dSP; dATARGET;
6f1401dc 2585 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2586 {
6f1401dc 2587 dPOPTOPiirl_nomg;
a0d0e21e
LW
2588 SETi( left * right );
2589 RETURN;
2590 }
79072805
LW
2591}
2592
a0d0e21e 2593PP(pp_i_divide)
79072805 2594{
85935d8e 2595 IV num;
20b7effb 2596 dSP; dATARGET;
6f1401dc 2597 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2598 {
6f1401dc 2599 dPOPTOPssrl;
85935d8e 2600 IV value = SvIV_nomg(right);
a0d0e21e 2601 if (value == 0)
ece1bcef 2602 DIE(aTHX_ "Illegal division by zero");
85935d8e 2603 num = SvIV_nomg(left);
a0cec769
YST
2604
2605 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2606 if (value == -1)
2607 value = - num;
2608 else
2609 value = num / value;
6f1401dc 2610 SETi(value);
a0d0e21e
LW
2611 RETURN;
2612 }
79072805
LW
2613}
2614
bf3d06aa
JC
2615#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2616 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
224ec323
JH
2617STATIC
2618PP(pp_i_modulo_0)
befad5d1
NC
2619#else
2620PP(pp_i_modulo)
2621#endif
224ec323
JH
2622{
2623 /* This is the vanilla old i_modulo. */
20b7effb 2624 dSP; dATARGET;
6f1401dc 2625 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2626 {
6f1401dc 2627 dPOPTOPiirl_nomg;
224ec323
JH
2628 if (!right)
2629 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2630 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2631 if (right == -1)
2632 SETi( 0 );
2633 else
2634 SETi( left % right );
224ec323
JH
2635 RETURN;
2636 }
2637}
2638
bf3d06aa
JC
2639#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2640 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
224ec323
JH
2641STATIC
2642PP(pp_i_modulo_1)
befad5d1 2643
224ec323 2644{
224ec323 2645 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2646 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2647 * See below for pp_i_modulo. */
20b7effb 2648 dSP; dATARGET;
6f1401dc 2649 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2650 {
6f1401dc 2651 dPOPTOPiirl_nomg;
224ec323
JH
2652 if (!right)
2653 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2654 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2655 if (right == -1)
2656 SETi( 0 );
2657 else
2658 SETi( left % PERL_ABS(right) );
224ec323
JH
2659 RETURN;
2660 }
224ec323
JH
2661}
2662
a0d0e21e 2663PP(pp_i_modulo)
79072805 2664{
6f1401dc
DM
2665 dVAR; dSP; dATARGET;
2666 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2667 {
6f1401dc 2668 dPOPTOPiirl_nomg;
224ec323
JH
2669 if (!right)
2670 DIE(aTHX_ "Illegal modulus zero");
2671 /* The assumption is to use hereafter the old vanilla version... */
2672 PL_op->op_ppaddr =
2673 PL_ppaddr[OP_I_MODULO] =
1c127fab 2674 Perl_pp_i_modulo_0;
224ec323 2675 /* .. but if we have glibc, we might have a buggy _moddi3
bf3d06aa 2676 * (at least glibc 2.2.5 is known to have this bug), in other
224ec323
JH
2677 * words our integer modulus with negative quad as the second
2678 * argument might be broken. Test for this and re-patch the
2679 * opcode dispatch table if that is the case, remembering to
2680 * also apply the workaround so that this first round works
2681 * right, too. See [perl #9402] for more information. */
224ec323
JH
2682 {
2683 IV l = 3;
2684 IV r = -10;
2685 /* Cannot do this check with inlined IV constants since
2686 * that seems to work correctly even with the buggy glibc. */
2687 if (l % r == -3) {
2688 /* Yikes, we have the bug.
2689 * Patch in the workaround version. */
2690 PL_op->op_ppaddr =
2691 PL_ppaddr[OP_I_MODULO] =
2692 &Perl_pp_i_modulo_1;
2693 /* Make certain we work right this time, too. */
32fdb065 2694 right = PERL_ABS(right);
224ec323
JH
2695 }
2696 }
a0cec769
YST
2697 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2698 if (right == -1)
2699 SETi( 0 );
2700 else
2701 SETi( left % right );
224ec323
JH
2702 RETURN;
2703 }
79072805 2704}
befad5d1 2705#endif
79072805 2706
a0d0e21e 2707PP(pp_i_add)
79072805 2708{
20b7effb 2709 dSP; dATARGET;
6f1401dc 2710 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2711 {
6f1401dc 2712 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2713 SETi( left + right );
2714 RETURN;
79072805 2715 }
79072805
LW
2716}
2717
a0d0e21e 2718PP(pp_i_subtract)
79072805 2719{
20b7effb 2720 dSP; dATARGET;
6f1401dc 2721 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2722 {
6f1401dc 2723 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2724 SETi( left - right );
2725 RETURN;
79072805 2726 }
79072805
LW
2727}
2728
a0d0e21e 2729PP(pp_i_lt)
79072805 2730{
20b7effb 2731 dSP;
6f1401dc 2732 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2733 {
96b6b87f 2734 dPOPTOPiirl_nomg;
54310121 2735 SETs(boolSV(left < right));
a0d0e21e
LW
2736 RETURN;
2737 }
79072805
LW
2738}
2739
a0d0e21e 2740PP(pp_i_gt)
79072805 2741{
20b7effb 2742 dSP;
6f1401dc 2743 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2744 {
96b6b87f 2745 dPOPTOPiirl_nomg;
54310121 2746 SETs(boolSV(left > right));
a0d0e21e
LW
2747 RETURN;
2748 }
79072805
LW
2749}
2750
a0d0e21e 2751PP(pp_i_le)
79072805 2752{
20b7effb 2753 dSP;
6f1401dc 2754 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 2755 {
96b6b87f 2756 dPOPTOPiirl_nomg;
54310121 2757 SETs(boolSV(left <= right));
a0d0e21e 2758 RETURN;
85e6fe83 2759 }
79072805
LW
2760}
2761
a0d0e21e 2762PP(pp_i_ge)
79072805 2763{
20b7effb 2764 dSP;
6f1401dc 2765 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 2766 {
96b6b87f 2767 dPOPTOPiirl_nomg;
54310121 2768 SETs(boolSV(left >= right));
a0d0e21e
LW
2769 RETURN;
2770 }
79072805
LW
2771}
2772
a0d0e21e 2773PP(pp_i_eq)
79072805 2774{
20b7effb 2775 dSP;
6f1401dc 2776 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 2777 {
96b6b87f 2778 dPOPTOPiirl_nomg;
54310121 2779 SETs(boolSV(left == right));
a0d0e21e
LW
2780 RETURN;
2781 }
79072805
LW
2782}
2783
a0d0e21e 2784PP(pp_i_ne)
79072805 2785{
20b7effb 2786 dSP;
6f1401dc 2787 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 2788 {
96b6b87f 2789 dPOPTOPiirl_nomg;
54310121 2790 SETs(boolSV(left != right));
a0d0e21e
LW
2791 RETURN;
2792 }
79072805
LW
2793}
2794
a0d0e21e 2795PP(pp_i_ncmp)
79072805 2796{
20b7effb 2797 dSP; dTARGET;
6f1401dc 2798 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2799 {
96b6b87f 2800 dPOPTOPiirl_nomg;
a0d0e21e 2801 I32 value;
79072805 2802
a0d0e21e 2803 if (left > right)
79072805 2804 value = 1;
a0d0e21e 2805 else if (left < right)
79072805 2806 value = -1;
a0d0e21e 2807 else
79072805 2808 value = 0;
a0d0e21e
LW
2809 SETi(value);
2810 RETURN;
79072805 2811 }
85e6fe83
LW
2812}
2813
2814PP(pp_i_negate)
2815{
20b7effb 2816 dSP; dTARGET;
6f1401dc 2817 tryAMAGICun_MG(neg_amg, 0);
1c2b3fd6 2818 if (S_negate_string(aTHX)) return NORMAL;
6f1401dc
DM
2819 {
2820 SV * const sv = TOPs;
2821 IV const i = SvIV_nomg(sv);
2822 SETi(-i);
ae642386 2823 return NORMAL;
6f1401dc 2824 }
85e6fe83
LW
2825}
2826
79072805
LW
2827/* High falutin' math. */
2828
2829PP(pp_atan2)
2830{
20b7effb 2831 dSP; dTARGET;
6f1401dc 2832 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2833 {
096c060c 2834 dPOPTOPnnrl_nomg;
a1021d57 2835 SETn(Perl_atan2(left, right));
a0d0e21e
LW
2836 RETURN;
2837 }
79072805
LW
2838}
2839
b1c05ba5
DM
2840
2841/* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2842
79072805
LW
2843PP(pp_sin)
2844{
20b7effb 2845 dSP; dTARGET;
af71714e 2846 int amg_type = fallback_amg;
71302fe3 2847 const char *neg_report = NULL;
71302fe3
NC
2848 const int op_type = PL_op->op_type;
2849
2850 switch (op_type) {
af71714e
JH
2851 case OP_SIN: amg_type = sin_amg; break;
2852 case OP_COS: amg_type = cos_amg; break;
2853 case OP_EXP: amg_type = exp_amg; break;
2854 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2855 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
a0d0e21e 2856 }
79072805 2857
af71714e 2858 assert(amg_type != fallback_amg);
6f1401dc
DM
2859
2860 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 2861 {
8c78ed36 2862 SV * const arg = TOPs;
6f1401dc 2863 const NV value = SvNV_nomg(arg);
f256868e 2864 NV result = NV_NAN;
af71714e 2865 if (neg_report) { /* log or sqrt */
a3463d96
DD
2866 if (
2867#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2868 ! Perl_isnan(value) &&
2869#endif
2870 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
71302fe3 2871 SET_NUMERIC_STANDARD();
dcbac5bb 2872 /* diag_listed_as: Can't take log of %g */
71302fe3
NC
2873 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2874 }
2875 }
af71714e 2876 switch (op_type) {
f256868e 2877 default:
af71714e
JH
2878 case OP_SIN: result = Perl_sin(value); break;
2879 case OP_COS: result = Perl_cos(value); break;
2880 case OP_EXP: result = Perl_exp(value); break;
2881 case OP_LOG: result = Perl_log(value); break;
2882 case OP_SQRT: result = Perl_sqrt(value); break;
2883 }
8c78ed36
FC
2884 SETn(result);
2885 return NORMAL;
a0d0e21e 2886 }
79072805
LW
2887}
2888
56cb0a1c
AD
2889/* Support Configure command-line overrides for rand() functions.
2890 After 5.005, perhaps we should replace this by Configure support
2891 for drand48(), random(), or rand(). For 5.005, though, maintain
2892 compatibility by calling rand() but allow the user to override it.
2893 See INSTALL for details. --Andy Dougherty 15 July 1998
2894*/
85ab1d1d
JH
2895/* Now it's after 5.005, and Configure supports drand48() and random(),
2896 in addition to rand(). So the overrides should not be needed any more.
2897 --Jarkko Hietaniemi 27 September 1998
2898 */
2899
79072805
LW
2900PP(pp_rand)
2901{
80252599 2902 if (!PL_srand_called) {
85ab1d1d 2903 (void)seedDrand01((Rand_seed_t)seed());
80252599 2904 PL_srand_called = TRUE;
93dc8474 2905 }
fdf4dddd
DD
2906 {
2907 dSP;
2908 NV value;
fdf4dddd
DD
2909
2910 if (MAXARG < 1)
7e9044f9
FC
2911 {
2912 EXTEND(SP, 1);
fdf4dddd 2913 value = 1.0;
7e9044f9 2914 }
fdf4dddd
DD
2915 else {
2916 SV * const sv = POPs;
2917 if(!sv)
2918 value = 1.0;
2919 else
2920 value = SvNV(sv);
2921 }
2922 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
a3463d96
DD
2923#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2924 if (! Perl_isnan(value) && value == 0.0)
2925#else
659c4b96 2926 if (value == 0.0)
a3463d96 2927#endif
fdf4dddd
DD
2928 value = 1.0;
2929 {
2930 dTARGET;
2931 PUSHs(TARG);
2932 PUTBACK;
2933 value *= Drand01();
2934 sv_setnv_mg(TARG, value);
2935 }
2936 }
2937 return NORMAL;
79072805
LW
2938}
2939
2940PP(pp_srand)
2941{
20b7effb 2942 dSP; dTARGET;
f914a682
JL
2943 UV anum;
2944
0a5f3363 2945 if (MAXARG >= 1 && (TOPs || POPs)) {
f914a682
JL
2946 SV *top;
2947 char *pv;
2948 STRLEN len;
2949 int flags;
2950
2951 top = POPs;
2952 pv = SvPV(top, len);
2953 flags = grok_number(pv, len, &anum);
2954
2955 if (!(flags & IS_NUMBER_IN_UV)) {
2956 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2957 "Integer overflow in srand");
2958 anum = UV_MAX;
2959 }
2960 }
2961 else {
2962 anum = seed();
2963 }
2964
85ab1d1d 2965 (void)seedDrand01((Rand_seed_t)anum);
80252599 2966 PL_srand_called = TRUE;
da1010ec
NC
2967 if (anum)
2968 XPUSHu(anum);
2969 else {
2970 /* Historically srand always returned true. We can avoid breaking
2971 that like this: */
2972 sv_setpvs(TARG, "0 but true");
2973 XPUSHTARG;
2974 }
83832992 2975 RETURN;
79072805
LW
2976}
2977
79072805
LW
2978PP(pp_int)
2979{
20b7effb 2980 dSP; dTARGET;
6f1401dc 2981 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 2982 {
6f1401dc
DM
2983 SV * const sv = TOPs;
2984 const IV iv = SvIV_nomg(sv);
28e5dec8
JH
2985 /* XXX it's arguable that compiler casting to IV might be subtly
2986 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2987 else preferring IV has introduced a subtle behaviour change bug. OTOH
2988 relying on floating point to be accurate is a bug. */
2989
c781a409 2990 if (!SvOK(sv)) {
922c4365 2991 SETu(0);
c781a409
RD
2992 }
2993 else if (SvIOK(sv)) {
2994 if (SvIsUV(sv))
6f1401dc 2995 SETu(SvUV_nomg(sv));
c781a409 2996 else
28e5dec8 2997 SETi(iv);
c781a409 2998 }
c781a409 2999 else {
6f1401dc 3000 const NV value = SvNV_nomg(sv);
b9d05018
FC
3001 if (UNLIKELY(Perl_isinfnan(value)))
3002 SETn(value);
5bf8b78e 3003 else if (value >= 0.0) {
28e5dec8
JH
3004 if (value < (NV)UV_MAX + 0.5) {
3005 SETu(U_V(value));
3006 } else {
059a1014 3007 SETn(Perl_floor(value));
28e5dec8 3008 }
1048ea30 3009 }
28e5dec8
JH
3010 else {
3011 if (value > (NV)IV_MIN - 0.5) {
3012 SETi(I_V(value));
3013 } else {
1bbae031 3014 SETn(Perl_ceil(value));
28e5dec8
JH
3015 }
3016 }
774d564b 3017 }
79072805 3018 }
699e9491 3019 return NORMAL;
79072805
LW
3020}
3021
463ee0b2
LW
3022PP(pp_abs)
3023{
20b7effb 3024 dSP; dTARGET;
6f1401dc 3025 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 3026 {
6f1401dc 3027 SV * const sv = TOPs;
28e5dec8 3028 /* This will cache the NV value if string isn't actually integer */
6f1401dc 3029 const IV iv = SvIV_nomg(sv);
a227d84d 3030
800401ee 3031 if (!SvOK(sv)) {
922c4365 3032 SETu(0);
800401ee
JH
3033 }
3034 else if (SvIOK(sv)) {
28e5dec8 3035 /* IVX is precise */
800401ee 3036 if (SvIsUV(sv)) {
6f1401dc 3037 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH
3038 } else {
3039 if (iv >= 0) {
3040 SETi(iv);
3041 } else {
3042 if (iv != IV_MIN) {
3043 SETi(-iv);
3044 } else {
3045 /* 2s complement assumption. Also, not really needed as
3046 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3047 SETu(IV_MIN);
3048 }
a227d84d 3049 }
28e5dec8
JH
3050 }
3051 } else{
6f1401dc 3052 const NV value = SvNV_nomg(sv);
774d564b 3053 if (value < 0.0)
1b6737cc 3054 SETn(-value);
a4474c9e
DD
3055 else
3056 SETn(value);
774d564b 3057 }
a0d0e21e 3058 }
067b7929 3059 return NORMAL;
463ee0b2
LW
3060}
3061
b1c05ba5
DM
3062
3063/* also used for: pp_hex() */
3064
79072805
LW
3065PP(pp_oct)
3066{
20b7effb 3067 dSP; dTARGET;
5c144d81 3068 const char *tmps;
53305cf1 3069 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 3070 STRLEN len;
53305cf1
NC
3071 NV result_nv;
3072 UV result_uv;
4e51bcca 3073 SV* const sv = TOPs;
79072805 3074
349d4f2f 3075 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS
3076 if (DO_UTF8(sv)) {
3077 /* If Unicode, try to downgrade
3078 * If not possible, croak. */
1b6737cc 3079 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS
3080
3081 SvUTF8_on(tsv);
3082 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3083 tmps = SvPV_const(tsv, len);
2bc69dc4 3084 }
daa2adfd
NC
3085 if (PL_op->op_type == OP_HEX)
3086 goto hex;
3087
6f894ead 3088 while (*tmps && len && isSPACE(*tmps))
53305cf1 3089 tmps++, len--;
9e24b6e2 3090 if (*tmps == '0')
53305cf1 3091 tmps++, len--;
305b8651 3092 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
daa2adfd 3093 hex:
53305cf1 3094 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 3095 }
305b8651 3096 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
53305cf1 3097 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 3098 else
53305cf1
NC
3099 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3100
3101 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
4e51bcca 3102 SETn(result_nv);
53305cf1
NC
3103 }
3104 else {
4e51bcca 3105 SETu(result_uv);
53305cf1 3106 }
4e51bcca 3107 return NORMAL;
79072805
LW
3108}
3109
3110/* String stuff. */
3111
3112PP(pp_length)
3113{
20b7effb 3114 dSP; dTARGET;
0bd48802 3115 SV * const sv = TOPs;
a0ed51b3 3116
7776003e
DD
3117 U32 in_bytes = IN_BYTES;
3118 /* simplest case shortcut */
3119 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3120 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
6d59e610 3121 STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
7776003e
DD
3122 SETs(TARG);
3123
3124 if(LIKELY(svflags == SVf_POK))
3125 goto simple_pv;
3126 if(svflags & SVs_GMG)
3127 mg_get(sv);
0f43fd57 3128 if (SvOK(sv)) {
7776003e
DD
3129 if (!IN_BYTES) /* reread to avoid using an C auto/register */
3130 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
9f621bb0 3131 else
0f43fd57
FC
3132 {
3133 STRLEN len;
7776003e
DD
3134 /* unrolled SvPV_nomg_const(sv,len) */
3135 if(SvPOK_nog(sv)){
3136 simple_pv:
3137 len = SvCUR(sv);
3138 } else {
3139 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3140 }
3141 sv_setiv(TARG, (IV)(len));
0f43fd57 3142 }
656266fc 3143 } else {
9407f9c1
DL
3144 if (!SvPADTMP(TARG)) {
3145 sv_setsv_nomg(TARG, &PL_sv_undef);
7776003e
DD
3146 } else { /* TARG is on stack at this point and is overwriten by SETs.
3147 This branch is the odd one out, so put TARG by default on
3148 stack earlier to let local SP go out of liveness sooner */
3149 SETs(&PL_sv_undef);
3150 goto no_set_magic;
3151 }
92331800 3152 }
7776003e
DD
3153 SvSETMAGIC(TARG);
3154 no_set_magic:
3155 return NORMAL; /* no putback, SP didn't move in this opcode */
79072805
LW
3156}
3157
83f78d1a
FC
3158/* Returns false if substring is completely outside original string.
3159 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3160 always be true for an explicit 0.
3161*/
3162bool
ddeaf645
DD
3163Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3164 bool pos1_is_uv, IV len_iv,
3165 bool len_is_uv, STRLEN *posp,
3166 STRLEN *lenp)
83f78d1a
FC
3167{
3168 IV pos2_iv;
3169 int pos2_is_uv;
3170
3171 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3172
3173 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3174 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3175 pos1_iv += curlen;
3176 }
3177 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3178 return FALSE;
3179
3180 if (len_iv || len_is_uv) {
3181 if (!len_is_uv && len_iv < 0) {
3182 pos2_iv = curlen + len_iv;
3183 if (curlen)
3184 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3185 else
3186 pos2_is_uv = 0;
3187 } else { /* len_iv >= 0 */
3188 if (!pos1_is_uv && pos1_iv < 0) {
3189 pos2_iv = pos1_iv + len_iv;
3190 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3191 } else {
3192 if ((UV)len_iv > curlen-(UV)pos1_iv)
3193 pos2_iv = curlen;
3194 else
3195 pos2_iv = pos1_iv+len_iv;
3196 pos2_is_uv = 1;
3197 }
3198 }
3199 }
3200 else {
3201 pos2_iv = curlen;
3202 pos2_is_uv = 1;
3203 }
3204
3205 if (!pos2_is_uv && pos2_iv < 0) {
3206 if (!pos1_is_uv && pos1_iv < 0)
3207 return FALSE;
3208 pos2_iv = 0;
3209 }
3210 else if (!pos1_is_uv && pos1_iv < 0)
3211 pos1_iv = 0;
3212
3213 if ((UV)pos2_iv < (UV)pos1_iv)
3214 pos2_iv = pos1_iv;
3215 if ((UV)pos2_iv > curlen)
3216 pos2_iv = curlen;
3217
3218 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3219 *posp = (STRLEN)( (UV)pos1_iv );
3220 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3221
3222 return TRUE;
3223}
3224
79072805
LW
3225PP(pp_substr)
3226{
20b7effb 3227 dSP; dTARGET;
79072805 3228 SV *sv;
463ee0b2 3229 STRLEN curlen;
9402d6ed 3230 STRLEN utf8_curlen;
777f7c56
EB
3231 SV * pos_sv;
3232 IV pos1_iv;
3233 int pos1_is_uv;
777f7c56
EB
3234 SV * len_sv;
3235 IV len_iv = 0;
83f78d1a 3236 int len_is_uv = 0;
24fcb59f 3237 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 3238 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 3239 const char *tmps;
9402d6ed 3240 SV *repl_sv = NULL;
cbbf8932 3241 const char *repl = NULL;
7b8d334a 3242 STRLEN repl_len;
7bc95ae1 3243 int num_args = PL_op->op_private & 7;
13e30c65 3244 bool repl_need_utf8_upgrade = FALSE;
79072805 3245
78f9721b
SM
3246 if (num_args > 2) {
3247 if (num_args > 3) {
24fcb59f 3248 if(!(repl_sv = POPs)) num_args--;
7bc95ae1
FC
3249 }
3250 if ((len_sv = POPs)) {
3251 len_iv = SvIV(len_sv);
83f78d1a 3252 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
7b8d334a 3253 }
7bc95ae1 3254 else num_args--;
5d82c453 3255 }
777f7c56
EB
3256 pos_sv = POPs;
3257 pos1_iv = SvIV(pos_sv);
3258 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3259 sv = POPs;
24fcb59f
FC
3260 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3261 assert(!repl_sv);
3262 repl_sv = POPs;
3263 }
6582db62 3264 if (lvalue && !repl_sv) {
83f78d1a
FC
3265 SV * ret;
3266 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3267 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3268 LvTYPE(ret) = 'x';
3269 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3270 LvTARGOFF(ret) =
3271 pos1_is_uv || pos1_iv >= 0
3272 ? (STRLEN)(UV)pos1_iv
3273 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3274 LvTARGLEN(ret) =
3275 len_is_uv || len_iv > 0
3276 ? (STRLEN)(UV)len_iv
3277 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3278
83f78d1a
FC
3279 PUSHs(ret); /* avoid SvSETMAGIC here */
3280 RETURN;
a74fb2cd 3281 }
6582db62
FC
3282 if (repl_sv) {
3283 repl = SvPV_const(repl_sv, repl_len);
3284 SvGETMAGIC(sv);
3285 if (SvROK(sv))
3286 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3287 "Attempt to use reference as lvalue in substr"
3288 );
3289 tmps = SvPV_force_nomg(sv, curlen);
3290 if (DO_UTF8(repl_sv) && repl_len) {
3291 if (!DO_UTF8(sv)) {
01680ee9 3292 sv_utf8_upgrade_nomg(sv);
6582db62
FC
3293 curlen = SvCUR(sv);
3294 }
3295 }
3296 else if (DO_UTF8(sv))
3297 repl_need_utf8_upgrade = TRUE;
3298 }
3299 else tmps = SvPV_const(sv, curlen);
7e2040f0 3300 if (DO_UTF8(sv)) {
0d788f38 3301 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
9402d6ed
JH
3302 if (utf8_curlen == curlen)
3303 utf8_curlen = 0;
a0ed51b3 3304 else
9402d6ed 3305 curlen = utf8_curlen;
a0ed51b3 3306 }
d1c2b58a 3307 else
9402d6ed 3308 utf8_curlen = 0;
a0ed51b3 3309
83f78d1a
FC
3310 {
3311 STRLEN pos, len, byte_len, byte_pos;
777f7c56 3312
83f78d1a
FC
3313 if (!translate_substr_offsets(
3314 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3315 )) goto bound_fail;
777f7c56 3316
83f78d1a
FC
3317 byte_len = len;
3318 byte_pos = utf8_curlen
0d788f38 3319 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
d931b1be 3320
2154eca7 3321 tmps += byte_pos;
bbddc9e0
CS
3322
3323 if (rvalue) {
3324 SvTAINTED_off(TARG); /* decontaminate */
3325 SvUTF8_off(TARG); /* decontaminate */
3326 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3327#ifdef USE_LOCALE_COLLATE
bbddc9e0 3328 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3329#endif
bbddc9e0
CS
3330 if (utf8_curlen)
3331 SvUTF8_on(TARG);
3332 }
2154eca7 3333
f7928d6c 3334 if (repl) {
13e30c65
JH
3335 SV* repl_sv_copy = NULL;
3336
3337 if (repl_need_utf8_upgrade) {
3338 repl_sv_copy = newSVsv(repl_sv);
3339 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3340 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65 3341 }
502d9230
VP
3342 if (!SvOK(sv))
3343 sv_setpvs(sv, "");
777f7c56 3344 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
ef8d46e8 3345 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3346 }
79072805 3347 }
6a9665b0
FC
3348 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3349 SP++;
3350 else if (rvalue) {
bbddc9e0
CS
3351 SvSETMAGIC(TARG);
3352 PUSHs(TARG);
3353 }
79072805 3354 RETURN;
777f7c56 3355
7b52d656 3356 bound_fail:
83f78d1a 3357 if (repl)
777f7c56
EB
3358 Perl_croak(aTHX_ "substr outside of string");
3359 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3360 RETPUSHUNDEF;
79072805
LW
3361}
3362
3363PP(pp_vec)
3364{
20b7effb 3365 dSP;
eb578fdb
KW
3366 const IV size = POPi;
3367 const IV offset = POPi;
3368 SV * const src = POPs;
1b6737cc 3369 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3370 SV * ret;
a0d0e21e 3371
81e118e0 3372 if (lvalue) { /* it's an lvalue! */
2154eca7
EB
3373 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3374 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3375 LvTYPE(ret) = 'v';
3376 LvTARG(ret) = SvREFCNT_inc_simple(src);
3377 LvTARGOFF(ret) = offset;
3378 LvTARGLEN(ret) = size;
3379 }
3380 else {
3381 dTARGET;
3382 SvTAINTED_off(TARG); /* decontaminate */
3383 ret = TARG;
79072805
LW
3384 }
3385
2154eca7 3386 sv_setuv(ret, do_vecget(src, offset, size));
f9e95907
FC
3387 if (!lvalue)
3388 SvSETMAGIC(ret);
2154eca7 3389 PUSHs(ret);
79072805
LW
3390 RETURN;
3391}
3392
b1c05ba5
DM
3393
3394/* also used for: pp_rindex() */
3395
79072805
LW
3396PP(pp_index)
3397{
20b7effb 3398 dSP; dTARGET;
79072805
LW
3399 SV *big;
3400 SV *little;
c445ea15 3401 SV *temp = NULL;
ad66a58c 3402 STRLEN biglen;
2723d216 3403 STRLEN llen = 0;
b464e2b7
TC
3404 SSize_t offset = 0;
3405 SSize_t retval;
73ee8be2
NC
3406 const char *big_p;
3407 const char *little_p;
2f040f7f
NC
3408 bool big_utf8;
3409 bool little_utf8;
2723d216 3410 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3411 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3412
e1dccc0d
Z
3413 if (threeargs)
3414 offset = POPi;
79072805
LW
3415 little = POPs;
3416 big = POPs;
73ee8be2
NC
3417 big_p = SvPV_const(big, biglen);
3418 little_p = SvPV_const(little, llen);
3419
e609e586
NC
3420 big_utf8 = DO_UTF8(big);
3421 little_utf8 = DO_UTF8(little);
3422 if (big_utf8 ^ little_utf8) {
3423 /* One needs to be upgraded. */
47e13f24 3424 if (little_utf8 && !IN_ENCODING) {
2f040f7f
NC
3425 /* Well, maybe instead we might be able to downgrade the small
3426 string? */
1eced8f8 3427 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC
3428 &little_utf8);
3429 if (little_utf8) {
3430 /* If the large string is ISO-8859-1, and it's not possible to
3431 convert the small string to ISO-8859-1, then there is no
3432 way that it could be found anywhere by index. */
3433 retval = -1;
3434 goto fail;
3435 }
e609e586 3436
2f040f7f
NC
3437 /* At this point, pv is a malloc()ed string. So donate it to temp
3438 to ensure it will get free()d */
3439 little = temp = newSV(0);
73ee8be2
NC
3440 sv_usepvn(temp, pv, llen);
3441 little_p = SvPVX(little);
e609e586 3442 } else {
73ee8be2
NC
3443 temp = little_utf8
3444 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f 3445
47e13f24 3446 if (IN_ENCODING) {
ad2de1b2 3447 sv_recode_to_utf8(temp, _get_encoding());
2f040f7f
NC
3448 } else {
3449 sv_utf8_upgrade(temp);
3450 }
3451 if (little_utf8) {
3452 big = temp;
3453 big_utf8 = TRUE;
73ee8be2 3454 big_p = SvPV_const(big, biglen);
2f040f7f
NC
3455 } else {
3456 little = temp;
73ee8be2 3457 little_p = SvPV_const(little, llen);
2f040f7f 3458 }
e609e586
NC
3459 }
3460 }
73ee8be2
NC
3461 if (SvGAMAGIC(big)) {
3462 /* Life just becomes a lot easier if I use a temporary here.
3463 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3464 will trigger magic and overloading again, as will fbm_instr()
3465 */
59cd0e26
NC
3466 big = newSVpvn_flags(big_p, biglen,
3467 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3468 big_p = SvPVX(big);
3469 }
e4e44778 3470 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC
3471 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3472 warn on undef, and we've already triggered a warning with the
3473 SvPV_const some lines above. We can't remove that, as we need to
3474 call some SvPV to trigger overloading early and find out if the
3475 string is UTF-8.
8bd97c0c 3476 This is all getting too messy. The API isn't quite clean enough,
73ee8be2
NC
3477 because data access has side effects.
3478 */
59cd0e26
NC
3479 little = newSVpvn_flags(little_p, llen,
3480 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3481 little_p = SvPVX(little);
3482 }
e609e586 3483
d3e26383 3484 if (!threeargs)
2723d216 3485 offset = is_index ? 0 : biglen;
a0ed51b3 3486 else {
ad66a58c 3487 if (big_utf8 && offset > 0)
b464e2b7 3488 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
73ee8be2
NC
3489 if (!is_index)
3490 offset += llen;
a0ed51b3 3491 }
79072805
LW
3492 if (offset < 0)
3493 offset = 0;
b464e2b7 3494 else if (offset > (SSize_t)biglen)
ad66a58c 3495 offset = biglen;
73ee8be2
NC
3496 if (!(little_p = is_index
3497 ? fbm_instr((unsigned char*)big_p + offset,
3498 (unsigned char*)big_p + biglen, little, 0)
3499 : rninstr(big_p, big_p + offset,
3500 little_p, little_p + llen)))
a0ed51b3 3501 retval = -1;
ad66a58c 3502 else {
73ee8be2 3503 retval = little_p - big_p;
15c41403 3504 if (retval > 1 && big_utf8)
b464e2b7 3505 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
ad66a58c 3506 }
ef8d46e8 3507 SvREFCNT_dec(temp);
2723d216 3508 fail:
e1dccc0d 3509 PUSHi(retval);
79072805
LW
3510 RETURN;
3511}
3512
3513PP(pp_sprintf)
3514{
20b7effb 3515 dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3516 SvTAINTED_off(TARG);
79072805 3517 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3518 TAINT_IF(SvTAINTED(TARG));
79072805
LW
3519 SP = ORIGMARK;
3520 PUSHTARG;
3521 RETURN;
3522}
3523
79072805
LW
3524PP(pp_ord)
3525{
20b7effb 3526 dSP; dTARGET;
1eced8f8 3527
6ba92227 3528 SV *argsv = TOPs;
ba210ebe 3529 STRLEN len;
349d4f2f 3530 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3531
47e13f24 3532 if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3533 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
ad2de1b2 3534 s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
4f6386b6 3535 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
121910a4
JH
3536 argsv = tmpsv;
3537 }
79072805 3538
6ba92227 3539 SETu(DO_UTF8(argsv)
4f6386b6 3540 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
f3943cf2 3541 : (UV)(*s));
68795e93 3542
6ba92227 3543 return NORMAL;
79072805
LW
3544}
3545
463ee0b2
LW
3546PP(pp_chr)
3547{
20b7effb 3548 dSP; dTARGET;
463ee0b2 3549 char *tmps;
8a064bd6 3550 UV value;
d3261b99 3551 SV *top = TOPs;
8a064bd6 3552
71739502 3553 SvGETMAGIC(top);
9911fc4e
FC
3554 if (UNLIKELY(SvAMAGIC(top)))
3555 top = sv_2num(top);
99f450cc 3556 if (UNLIKELY(isinfnansv(top)))
0c7df902 3557 Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
1cd88304
JH
3558 else {
3559 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3560 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3561 ||
3562 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
2cc2a5a0
KW
3563 && SvNV_nomg(top) < 0.0)))
3564 {
b3fe8680
FC
3565 if (ckWARN(WARN_UTF8)) {
3566 if (SvGMAGICAL(top)) {
3567 SV *top2 = sv_newmortal();
3568 sv_setsv_nomg(top2, top);
3569 top = top2;
3570 }
1cd88304
JH
3571 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3572 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3573 }
3574 value = UNICODE_REPLACEMENT;
3575 } else {
3576 value = SvUV_nomg(top);
3577 }
8a064bd6 3578 }
463ee0b2 3579
862a34c6 3580 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3581
0064a8a9