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