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