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