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