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