This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #87708] $tied / $tied under use integer
[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{
6f1401dc
DM
2849 dVAR; dSP; dATARGET;
2850 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2851 {
6f1401dc 2852 dPOPTOPssrl;
76422f81
FC
2853 IV num = SvIV_nomg(left);
2854 IV value = left==right ? SvIV(right) : SvIV_nomg(right);
a0d0e21e 2855 if (value == 0)
ece1bcef 2856 DIE(aTHX_ "Illegal division by zero");
a0cec769
YST
2857
2858 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2859 if (value == -1)
2860 value = - num;
2861 else
2862 value = num / value;
6f1401dc 2863 SETi(value);
a0d0e21e
LW
2864 RETURN;
2865 }
79072805
LW
2866}
2867
befad5d1 2868#if defined(__GLIBC__) && IVSIZE == 8
224ec323
JH
2869STATIC
2870PP(pp_i_modulo_0)
befad5d1
NC
2871#else
2872PP(pp_i_modulo)
2873#endif
224ec323
JH
2874{
2875 /* This is the vanilla old i_modulo. */
6f1401dc
DM
2876 dVAR; dSP; dATARGET;
2877 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2878 {
6f1401dc 2879 dPOPTOPiirl_nomg;
224ec323
JH
2880 if (!right)
2881 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2882 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2883 if (right == -1)
2884 SETi( 0 );
2885 else
2886 SETi( left % right );
224ec323
JH
2887 RETURN;
2888 }
2889}
2890
11010fa3 2891#if defined(__GLIBC__) && IVSIZE == 8
224ec323
JH
2892STATIC
2893PP(pp_i_modulo_1)
befad5d1 2894
224ec323 2895{
224ec323 2896 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2897 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2898 * See below for pp_i_modulo. */
6f1401dc
DM
2899 dVAR; dSP; dATARGET;
2900 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2901 {
6f1401dc 2902 dPOPTOPiirl_nomg;
224ec323
JH
2903 if (!right)
2904 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2905 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2906 if (right == -1)
2907 SETi( 0 );
2908 else
2909 SETi( left % PERL_ABS(right) );
224ec323
JH
2910 RETURN;
2911 }
224ec323
JH
2912}
2913
a0d0e21e 2914PP(pp_i_modulo)
79072805 2915{
6f1401dc
DM
2916 dVAR; dSP; dATARGET;
2917 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2918 {
6f1401dc 2919 dPOPTOPiirl_nomg;
224ec323
JH
2920 if (!right)
2921 DIE(aTHX_ "Illegal modulus zero");
2922 /* The assumption is to use hereafter the old vanilla version... */
2923 PL_op->op_ppaddr =
2924 PL_ppaddr[OP_I_MODULO] =
1c127fab 2925 Perl_pp_i_modulo_0;
224ec323
JH
2926 /* .. but if we have glibc, we might have a buggy _moddi3
2927 * (at least glicb 2.2.5 is known to have this bug), in other
2928 * words our integer modulus with negative quad as the second
2929 * argument might be broken. Test for this and re-patch the
2930 * opcode dispatch table if that is the case, remembering to
2931 * also apply the workaround so that this first round works
2932 * right, too. See [perl #9402] for more information. */
224ec323
JH
2933 {
2934 IV l = 3;
2935 IV r = -10;
2936 /* Cannot do this check with inlined IV constants since
2937 * that seems to work correctly even with the buggy glibc. */
2938 if (l % r == -3) {
2939 /* Yikes, we have the bug.
2940 * Patch in the workaround version. */
2941 PL_op->op_ppaddr =
2942 PL_ppaddr[OP_I_MODULO] =
2943 &Perl_pp_i_modulo_1;
2944 /* Make certain we work right this time, too. */
32fdb065 2945 right = PERL_ABS(right);
224ec323
JH
2946 }
2947 }
a0cec769
YST
2948 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2949 if (right == -1)
2950 SETi( 0 );
2951 else
2952 SETi( left % right );
224ec323
JH
2953 RETURN;
2954 }
79072805 2955}
befad5d1 2956#endif
79072805 2957
a0d0e21e 2958PP(pp_i_add)
79072805 2959{
6f1401dc
DM
2960 dVAR; dSP; dATARGET;
2961 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2962 {
6f1401dc 2963 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2964 SETi( left + right );
2965 RETURN;
79072805 2966 }
79072805
LW
2967}
2968
a0d0e21e 2969PP(pp_i_subtract)
79072805 2970{
6f1401dc
DM
2971 dVAR; dSP; dATARGET;
2972 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2973 {
6f1401dc 2974 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2975 SETi( left - right );
2976 RETURN;
79072805 2977 }
79072805
LW
2978}
2979
a0d0e21e 2980PP(pp_i_lt)
79072805 2981{
6f1401dc
DM
2982 dVAR; dSP;
2983 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2984 {
96b6b87f 2985 dPOPTOPiirl_nomg;
54310121 2986 SETs(boolSV(left < right));
a0d0e21e
LW
2987 RETURN;
2988 }
79072805
LW
2989}
2990
a0d0e21e 2991PP(pp_i_gt)
79072805 2992{
6f1401dc
DM
2993 dVAR; dSP;
2994 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2995 {
96b6b87f 2996 dPOPTOPiirl_nomg;
54310121 2997 SETs(boolSV(left > right));
a0d0e21e
LW
2998 RETURN;
2999 }
79072805
LW
3000}
3001
a0d0e21e 3002PP(pp_i_le)
79072805 3003{
6f1401dc
DM
3004 dVAR; dSP;
3005 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 3006 {
96b6b87f 3007 dPOPTOPiirl_nomg;
54310121 3008 SETs(boolSV(left <= right));
a0d0e21e 3009 RETURN;
85e6fe83 3010 }
79072805
LW
3011}
3012
a0d0e21e 3013PP(pp_i_ge)
79072805 3014{
6f1401dc
DM
3015 dVAR; dSP;
3016 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 3017 {
96b6b87f 3018 dPOPTOPiirl_nomg;
54310121 3019 SETs(boolSV(left >= right));
a0d0e21e
LW
3020 RETURN;
3021 }
79072805
LW
3022}
3023
a0d0e21e 3024PP(pp_i_eq)
79072805 3025{
6f1401dc
DM
3026 dVAR; dSP;
3027 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 3028 {
96b6b87f 3029 dPOPTOPiirl_nomg;
54310121 3030 SETs(boolSV(left == right));
a0d0e21e
LW
3031 RETURN;
3032 }
79072805
LW
3033}
3034
a0d0e21e 3035PP(pp_i_ne)
79072805 3036{
6f1401dc
DM
3037 dVAR; dSP;
3038 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 3039 {
96b6b87f 3040 dPOPTOPiirl_nomg;
54310121 3041 SETs(boolSV(left != right));
a0d0e21e
LW
3042 RETURN;
3043 }
79072805
LW
3044}
3045
a0d0e21e 3046PP(pp_i_ncmp)
79072805 3047{
6f1401dc
DM
3048 dVAR; dSP; dTARGET;
3049 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 3050 {
96b6b87f 3051 dPOPTOPiirl_nomg;
a0d0e21e 3052 I32 value;
79072805 3053
a0d0e21e 3054 if (left > right)
79072805 3055 value = 1;
a0d0e21e 3056 else if (left < right)
79072805 3057 value = -1;
a0d0e21e 3058 else
79072805 3059 value = 0;
a0d0e21e
LW
3060 SETi(value);
3061 RETURN;
79072805 3062 }
85e6fe83
LW
3063}
3064
3065PP(pp_i_negate)
3066{
6f1401dc
DM
3067 dVAR; dSP; dTARGET;
3068 tryAMAGICun_MG(neg_amg, 0);
3069 {
3070 SV * const sv = TOPs;
3071 IV const i = SvIV_nomg(sv);
3072 SETi(-i);
3073 RETURN;
3074 }
85e6fe83
LW
3075}
3076
79072805
LW
3077/* High falutin' math. */
3078
3079PP(pp_atan2)
3080{
6f1401dc
DM
3081 dVAR; dSP; dTARGET;
3082 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 3083 {
c31c2913 3084 dPOPTOPnnrl_halfmg;
a1021d57 3085 SETn(Perl_atan2(left, right));
a0d0e21e
LW
3086 RETURN;
3087 }
79072805
LW
3088}
3089
3090PP(pp_sin)
3091{
71302fe3
NC
3092 dVAR; dSP; dTARGET;
3093 int amg_type = sin_amg;
3094 const char *neg_report = NULL;
bc81784a 3095 NV (*func)(NV) = Perl_sin;
71302fe3
NC
3096 const int op_type = PL_op->op_type;
3097
3098 switch (op_type) {
3099 case OP_COS:
3100 amg_type = cos_amg;
bc81784a 3101 func = Perl_cos;
71302fe3
NC
3102 break;
3103 case OP_EXP:
3104 amg_type = exp_amg;
bc81784a 3105 func = Perl_exp;
71302fe3
NC
3106 break;
3107 case OP_LOG:
3108 amg_type = log_amg;
bc81784a 3109 func = Perl_log;
71302fe3
NC
3110 neg_report = "log";
3111 break;
3112 case OP_SQRT:
3113 amg_type = sqrt_amg;
bc81784a 3114 func = Perl_sqrt;
71302fe3
NC
3115 neg_report = "sqrt";
3116 break;
a0d0e21e 3117 }
79072805 3118
6f1401dc
DM
3119
3120 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 3121 {
6f1401dc
DM
3122 SV * const arg = POPs;
3123 const NV value = SvNV_nomg(arg);
71302fe3
NC
3124 if (neg_report) {
3125 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
3126 SET_NUMERIC_STANDARD();
3127 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
3128 }
3129 }
3130 XPUSHn(func(value));
a0d0e21e
LW
3131 RETURN;
3132 }
79072805
LW
3133}
3134
56cb0a1c
AD
3135/* Support Configure command-line overrides for rand() functions.
3136 After 5.005, perhaps we should replace this by Configure support
3137 for drand48(), random(), or rand(). For 5.005, though, maintain
3138 compatibility by calling rand() but allow the user to override it.
3139 See INSTALL for details. --Andy Dougherty 15 July 1998
3140*/
85ab1d1d
JH
3141/* Now it's after 5.005, and Configure supports drand48() and random(),
3142 in addition to rand(). So the overrides should not be needed any more.
3143 --Jarkko Hietaniemi 27 September 1998
3144 */
3145
3146#ifndef HAS_DRAND48_PROTO
20ce7b12 3147extern double drand48 (void);
56cb0a1c
AD
3148#endif
3149
79072805
LW
3150PP(pp_rand)
3151{
97aff369 3152 dVAR; dSP; dTARGET;
65202027 3153 NV value;
79072805
LW
3154 if (MAXARG < 1)
3155 value = 1.0;
3156 else
3157 value = POPn;
3158 if (value == 0.0)
3159 value = 1.0;
80252599 3160 if (!PL_srand_called) {
85ab1d1d 3161 (void)seedDrand01((Rand_seed_t)seed());
80252599 3162 PL_srand_called = TRUE;
93dc8474 3163 }
85ab1d1d 3164 value *= Drand01();
79072805
LW
3165 XPUSHn(value);
3166 RETURN;
3167}
3168
3169PP(pp_srand)
3170{
83832992 3171 dVAR; dSP; dTARGET;
0bd48802 3172 const UV anum = (MAXARG < 1) ? seed() : POPu;
85ab1d1d 3173 (void)seedDrand01((Rand_seed_t)anum);
80252599 3174 PL_srand_called = TRUE;
da1010ec
NC
3175 if (anum)
3176 XPUSHu(anum);
3177 else {
3178 /* Historically srand always returned true. We can avoid breaking
3179 that like this: */
3180 sv_setpvs(TARG, "0 but true");
3181 XPUSHTARG;
3182 }
83832992 3183 RETURN;
79072805
LW
3184}
3185
79072805
LW
3186PP(pp_int)
3187{
6f1401dc
DM
3188 dVAR; dSP; dTARGET;
3189 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 3190 {
6f1401dc
DM
3191 SV * const sv = TOPs;
3192 const IV iv = SvIV_nomg(sv);
28e5dec8
JH
3193 /* XXX it's arguable that compiler casting to IV might be subtly
3194 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3195 else preferring IV has introduced a subtle behaviour change bug. OTOH
3196 relying on floating point to be accurate is a bug. */
3197
c781a409 3198 if (!SvOK(sv)) {
922c4365 3199 SETu(0);
c781a409
RD
3200 }
3201 else if (SvIOK(sv)) {
3202 if (SvIsUV(sv))
6f1401dc 3203 SETu(SvUV_nomg(sv));
c781a409 3204 else
28e5dec8 3205 SETi(iv);
c781a409 3206 }
c781a409 3207 else {
6f1401dc 3208 const NV value = SvNV_nomg(sv);
1048ea30 3209 if (value >= 0.0) {
28e5dec8
JH
3210 if (value < (NV)UV_MAX + 0.5) {
3211 SETu(U_V(value));
3212 } else {
059a1014 3213 SETn(Perl_floor(value));
28e5dec8 3214 }
1048ea30 3215 }
28e5dec8
JH
3216 else {
3217 if (value > (NV)IV_MIN - 0.5) {
3218 SETi(I_V(value));
3219 } else {
1bbae031 3220 SETn(Perl_ceil(value));
28e5dec8
JH
3221 }
3222 }
774d564b 3223 }
79072805 3224 }
79072805
LW
3225 RETURN;
3226}
3227
463ee0b2
LW
3228PP(pp_abs)
3229{
6f1401dc
DM
3230 dVAR; dSP; dTARGET;
3231 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 3232 {
6f1401dc 3233 SV * const sv = TOPs;
28e5dec8 3234 /* This will cache the NV value if string isn't actually integer */
6f1401dc 3235 const IV iv = SvIV_nomg(sv);
a227d84d 3236
800401ee 3237 if (!SvOK(sv)) {
922c4365 3238 SETu(0);
800401ee
JH
3239 }
3240 else if (SvIOK(sv)) {
28e5dec8 3241 /* IVX is precise */
800401ee 3242 if (SvIsUV(sv)) {
6f1401dc 3243 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH
3244 } else {
3245 if (iv >= 0) {
3246 SETi(iv);
3247 } else {
3248 if (iv != IV_MIN) {
3249 SETi(-iv);
3250 } else {
3251 /* 2s complement assumption. Also, not really needed as
3252 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3253 SETu(IV_MIN);
3254 }
a227d84d 3255 }
28e5dec8
JH
3256 }
3257 } else{
6f1401dc 3258 const NV value = SvNV_nomg(sv);
774d564b 3259 if (value < 0.0)
1b6737cc 3260 SETn(-value);
a4474c9e
DD
3261 else
3262 SETn(value);
774d564b 3263 }
a0d0e21e 3264 }
774d564b 3265 RETURN;
463ee0b2
LW
3266}
3267
79072805
LW
3268PP(pp_oct)
3269{
97aff369 3270 dVAR; dSP; dTARGET;
5c144d81 3271 const char *tmps;
53305cf1 3272 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 3273 STRLEN len;
53305cf1
NC
3274 NV result_nv;
3275 UV result_uv;
1b6737cc 3276 SV* const sv = POPs;
79072805 3277
349d4f2f 3278 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS
3279 if (DO_UTF8(sv)) {
3280 /* If Unicode, try to downgrade
3281 * If not possible, croak. */
1b6737cc 3282 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS
3283
3284 SvUTF8_on(tsv);
3285 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3286 tmps = SvPV_const(tsv, len);
2bc69dc4 3287 }
daa2adfd
NC
3288 if (PL_op->op_type == OP_HEX)
3289 goto hex;
3290
6f894ead 3291 while (*tmps && len && isSPACE(*tmps))
53305cf1 3292 tmps++, len--;
9e24b6e2 3293 if (*tmps == '0')
53305cf1 3294 tmps++, len--;
a674e8db 3295 if (*tmps == 'x' || *tmps == 'X') {
daa2adfd 3296 hex:
53305cf1 3297 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 3298 }
a674e8db 3299 else if (*tmps == 'b' || *tmps == 'B')
53305cf1 3300 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 3301 else
53305cf1
NC
3302 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3303
3304 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3305 XPUSHn(result_nv);
3306 }
3307 else {
3308 XPUSHu(result_uv);
3309 }
79072805
LW
3310 RETURN;
3311}
3312
3313/* String stuff. */
3314
3315PP(pp_length)
3316{
97aff369 3317 dVAR; dSP; dTARGET;
0bd48802 3318 SV * const sv = TOPs;
a0ed51b3 3319
656266fc 3320 if (SvGAMAGIC(sv)) {
9f621bb0
NC
3321 /* For an overloaded or magic scalar, we can't know in advance if
3322 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3323 it likes to cache the length. Maybe that should be a documented
3324 feature of it.
92331800
NC
3325 */
3326 STRLEN len;
9f621bb0
NC
3327 const char *const p
3328 = sv_2pv_flags(sv, &len,
3329 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
92331800 3330
d88e091f 3331 if (!p) {
9407f9c1
DL
3332 if (!SvPADTMP(TARG)) {
3333 sv_setsv(TARG, &PL_sv_undef);
3334 SETTARG;
3335 }
3336 SETs(&PL_sv_undef);
d88e091f 3337 }
9f621bb0 3338 else if (DO_UTF8(sv)) {
899be101 3339 SETi(utf8_length((U8*)p, (U8*)p + len));
92331800
NC
3340 }
3341 else
3342 SETi(len);
656266fc 3343 } else if (SvOK(sv)) {
9f621bb0
NC
3344 /* Neither magic nor overloaded. */
3345 if (DO_UTF8(sv))
3346 SETi(sv_len_utf8(sv));
3347 else
3348 SETi(sv_len(sv));
656266fc 3349 } else {
9407f9c1
DL
3350 if (!SvPADTMP(TARG)) {
3351 sv_setsv_nomg(TARG, &PL_sv_undef);
3352 SETTARG;
3353 }
3354 SETs(&PL_sv_undef);
92331800 3355 }
79072805
LW
3356 RETURN;
3357}
3358
3359PP(pp_substr)
3360{
97aff369 3361 dVAR; dSP; dTARGET;
79072805 3362 SV *sv;
463ee0b2 3363 STRLEN curlen;
9402d6ed 3364 STRLEN utf8_curlen;
777f7c56
EB
3365 SV * pos_sv;
3366 IV pos1_iv;
3367 int pos1_is_uv;
3368 IV pos2_iv;
3369 int pos2_is_uv;
3370 SV * len_sv;
3371 IV len_iv = 0;
3372 int len_is_uv = 1;
050e6362 3373 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
e1ec3a88 3374 const char *tmps;
777f7c56 3375 const IV arybase = CopARYBASE_get(PL_curcop);
9402d6ed 3376 SV *repl_sv = NULL;
cbbf8932 3377 const char *repl = NULL;
7b8d334a 3378 STRLEN repl_len;
050e6362 3379 const int num_args = PL_op->op_private & 7;
13e30c65 3380 bool repl_need_utf8_upgrade = FALSE;
9402d6ed 3381 bool repl_is_utf8 = FALSE;
79072805 3382
78f9721b
SM
3383 if (num_args > 2) {
3384 if (num_args > 3) {
9402d6ed 3385 repl_sv = POPs;
83003860 3386 repl = SvPV_const(repl_sv, repl_len);
9402d6ed 3387 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
7b8d334a 3388 }
777f7c56
EB
3389 len_sv = POPs;
3390 len_iv = SvIV(len_sv);
3391 len_is_uv = SvIOK_UV(len_sv);
5d82c453 3392 }
777f7c56
EB
3393 pos_sv = POPs;
3394 pos1_iv = SvIV(pos_sv);
3395 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3396 sv = POPs;
849ca7ee 3397 PUTBACK;
9402d6ed
JH
3398 if (repl_sv) {
3399 if (repl_is_utf8) {
3400 if (!DO_UTF8(sv))
3401 sv_utf8_upgrade(sv);
3402 }
13e30c65
JH
3403 else if (DO_UTF8(sv))
3404 repl_need_utf8_upgrade = TRUE;
9402d6ed 3405 }
5c144d81 3406 tmps = SvPV_const(sv, curlen);
7e2040f0 3407 if (DO_UTF8(sv)) {
9402d6ed
JH
3408 utf8_curlen = sv_len_utf8(sv);
3409 if (utf8_curlen == curlen)
3410 utf8_curlen = 0;
a0ed51b3 3411 else
9402d6ed 3412 curlen = utf8_curlen;
a0ed51b3 3413 }
d1c2b58a 3414 else
9402d6ed 3415 utf8_curlen = 0;
a0ed51b3 3416
777f7c56
EB
3417 if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3418 UV pos1_uv = pos1_iv-arybase;
3419 /* Overflow can occur when $[ < 0 */
3420 if (arybase < 0 && pos1_uv < (UV)pos1_iv)
1c900557 3421 goto bound_fail;
777f7c56
EB
3422 pos1_iv = pos1_uv;
3423 pos1_is_uv = 1;
3424 }
3425 else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
1c900557 3426 goto bound_fail; /* $[=3; substr($_,2,...) */
777f7c56
EB
3427 }
3428 else { /* pos < $[ */
3429 if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3430 pos1_iv = curlen;
3431 pos1_is_uv = 1;
3432 } else {
3433 if (curlen) {
3434 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3435 pos1_iv += curlen;
3436 }
5d82c453 3437 }
68dc0745 3438 }
777f7c56
EB
3439 if (pos1_is_uv || pos1_iv > 0) {
3440 if ((UV)pos1_iv > curlen)
1c900557 3441 goto bound_fail;
777f7c56
EB
3442 }
3443
3444 if (num_args > 2) {
3445 if (!len_is_uv && len_iv < 0) {
3446 pos2_iv = curlen + len_iv;
3447 if (curlen)
3448 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3449 else
3450 pos2_is_uv = 0;
3451 } else { /* len_iv >= 0 */
3452 if (!pos1_is_uv && pos1_iv < 0) {
3453 pos2_iv = pos1_iv + len_iv;
3454 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3455 } else {
3456 if ((UV)len_iv > curlen-(UV)pos1_iv)
3457 pos2_iv = curlen;
3458 else
3459 pos2_iv = pos1_iv+len_iv;
3460 pos2_is_uv = 1;
3461 }
5d82c453 3462 }
2304df62 3463 }
79072805 3464 else {
777f7c56
EB
3465 pos2_iv = curlen;
3466 pos2_is_uv = 1;
3467 }
3468
3469 if (!pos2_is_uv && pos2_iv < 0) {
3470 if (!pos1_is_uv && pos1_iv < 0)
1c900557 3471 goto bound_fail;
777f7c56
EB
3472 pos2_iv = 0;
3473 }
3474 else if (!pos1_is_uv && pos1_iv < 0)
3475 pos1_iv = 0;
3476
3477 if ((UV)pos2_iv < (UV)pos1_iv)
3478 pos2_iv = pos1_iv;
3479 if ((UV)pos2_iv > curlen)
3480 pos2_iv = curlen;
3481
3482 {
3483 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3484 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3485 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
777f7c56 3486 STRLEN byte_len = len;
d931b1be
NC
3487 STRLEN byte_pos = utf8_curlen
3488 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3489
2154eca7
EB
3490 if (lvalue && !repl) {
3491 SV * ret;
3492
3493 if (!SvGMAGICAL(sv)) {
3494 if (SvROK(sv)) {
3495 SvPV_force_nolen(sv);
3496 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3497 "Attempt to use reference as lvalue in substr");
3498 }
3499 if (isGV_with_GP(sv))
3500 SvPV_force_nolen(sv);
3501 else if (SvOK(sv)) /* is it defined ? */
3502 (void)SvPOK_only_UTF8(sv);
3503 else
3504 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
781e7547 3505 }
2154eca7
EB
3506
3507 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3508 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3509 LvTYPE(ret) = 'x';
3510 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3511 LvTARGOFF(ret) = pos;
3512 LvTARGLEN(ret) = len;
3513
3514 SPAGAIN;
3515 PUSHs(ret); /* avoid SvSETMAGIC here */
3516 RETURN;
781e7547
DM
3517 }
3518
2154eca7
EB
3519 SvTAINTED_off(TARG); /* decontaminate */
3520 SvUTF8_off(TARG); /* decontaminate */
3521
3522 tmps += byte_pos;
777f7c56 3523 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3524#ifdef USE_LOCALE_COLLATE
14befaf4 3525 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3526#endif
9402d6ed 3527 if (utf8_curlen)
7f66633b 3528 SvUTF8_on(TARG);
2154eca7 3529
f7928d6c 3530 if (repl) {
13e30c65
JH
3531 SV* repl_sv_copy = NULL;
3532
3533 if (repl_need_utf8_upgrade) {
3534 repl_sv_copy = newSVsv(repl_sv);
3535 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3536 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65
JH
3537 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3538 }
502d9230
VP
3539 if (!SvOK(sv))
3540 sv_setpvs(sv, "");
777f7c56 3541 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
9402d6ed 3542 if (repl_is_utf8)
f7928d6c 3543 SvUTF8_on(sv);
ef8d46e8 3544 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3545 }
79072805 3546 }
849ca7ee 3547 SPAGAIN;
e27c778f
FC
3548 SvSETMAGIC(TARG);
3549 PUSHs(TARG);
79072805 3550 RETURN;
777f7c56 3551
1c900557 3552bound_fail:
777f7c56
EB
3553 if (lvalue || repl)
3554 Perl_croak(aTHX_ "substr outside of string");
3555 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3556 RETPUSHUNDEF;
79072805
LW
3557}
3558
3559PP(pp_vec)
3560{
2154eca7 3561 dVAR; dSP;
1b6737cc
AL
3562 register const IV size = POPi;
3563 register const IV offset = POPi;
3564 register SV * const src = POPs;
3565 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3566 SV * ret;
a0d0e21e 3567
81e118e0 3568 if (lvalue) { /* it's an lvalue! */
2154eca7
EB
3569 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3570 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3571 LvTYPE(ret) = 'v';
3572 LvTARG(ret) = SvREFCNT_inc_simple(src);
3573 LvTARGOFF(ret) = offset;
3574 LvTARGLEN(ret) = size;
3575 }
3576 else {
3577 dTARGET;
3578 SvTAINTED_off(TARG); /* decontaminate */
3579 ret = TARG;
79072805
LW
3580 }
3581
2154eca7
EB
3582 sv_setuv(ret, do_vecget(src, offset, size));
3583 PUSHs(ret);
79072805
LW
3584 RETURN;
3585}
3586
3587PP(pp_index)
3588{
97aff369 3589 dVAR; dSP; dTARGET;
79072805
LW
3590 SV *big;
3591 SV *little;
c445ea15 3592 SV *temp = NULL;
ad66a58c 3593 STRLEN biglen;
2723d216 3594 STRLEN llen = 0;
79072805
LW
3595 I32 offset;
3596 I32 retval;
73ee8be2
NC
3597 const char *big_p;
3598 const char *little_p;
fc15ae8f 3599 const I32 arybase = CopARYBASE_get(PL_curcop);
2f040f7f
NC
3600 bool big_utf8;
3601 bool little_utf8;
2723d216 3602 const bool is_index = PL_op->op_type == OP_INDEX;
79072805 3603
2723d216
NC
3604 if (MAXARG >= 3) {
3605 /* arybase is in characters, like offset, so combine prior to the
3606 UTF-8 to bytes calculation. */
79072805 3607 offset = POPi - arybase;
2723d216 3608 }
79072805
LW
3609 little = POPs;
3610 big = POPs;
73ee8be2
NC
3611 big_p = SvPV_const(big, biglen);
3612 little_p = SvPV_const(little, llen);
3613
e609e586
NC
3614 big_utf8 = DO_UTF8(big);
3615 little_utf8 = DO_UTF8(little);
3616 if (big_utf8 ^ little_utf8) {
3617 /* One needs to be upgraded. */
2f040f7f
NC
3618 if (little_utf8 && !PL_encoding) {
3619 /* Well, maybe instead we might be able to downgrade the small
3620 string? */
1eced8f8 3621 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC
3622 &little_utf8);
3623 if (little_utf8) {
3624 /* If the large string is ISO-8859-1, and it's not possible to
3625 convert the small string to ISO-8859-1, then there is no
3626 way that it could be found anywhere by index. */
3627 retval = -1;
3628 goto fail;
3629 }
e609e586 3630
2f040f7f
NC
3631 /* At this point, pv is a malloc()ed string. So donate it to temp
3632 to ensure it will get free()d */
3633 little = temp = newSV(0);
73ee8be2
NC
3634 sv_usepvn(temp, pv, llen);
3635 little_p = SvPVX(little);
e609e586 3636 } else {
73ee8be2
NC
3637 temp = little_utf8
3638 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f
NC
3639
3640 if (PL_encoding) {
3641 sv_recode_to_utf8(temp, PL_encoding);
3642 } else {
3643 sv_utf8_upgrade(temp);
3644 }
3645 if (little_utf8) {
3646 big = temp;
3647 big_utf8 = TRUE;
73ee8be2 3648 big_p = SvPV_const(big, biglen);
2f040f7f
NC
3649 } else {
3650 little = temp;
73ee8be2 3651 little_p = SvPV_const(little, llen);
2f040f7f