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