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