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