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