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