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