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