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