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