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