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