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