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