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