This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: stringification of v-string references
[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 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 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 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 303 if (SvTYPE(TARG) < SVt_PVLV) {
304 sv_upgrade(TARG, SVt_PVLV);
14befaf4 305 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
5f05dabc 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 357PP(pp_prototype)
358{
39644a26 359 dSP;
c07a80fd 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 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 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 462{
463 SV* rv;
464
465 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
466 if (LvTARGLEN(sv))
68dc0745 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 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 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 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 596 if (sv)
597 sv_2mortal(sv);
598 else
3280af22 599 sv = &PL_sv_undef;
fb73857a 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 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 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 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 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 2082 else if (left > right)
2083 value = 1;
2084 else {
3280af22 2085 SETs(&PL_sv_undef);
44a8e56a 2086 RETURN;
2087 }
1ad04cfd 2088#endif
a0d0e21e
LW
2089 SETi(value);
2090 RETURN;
79072805 2091 }
a0d0e21e 2092}
79072805 2093
afd9910b 2094PP(pp_sle)
a0d0e21e 2095{
afd9910b 2096 dSP;
79072805 2097
afd9910b
NC
2098 int amg_type = sle_amg;
2099 int multiplier = 1;
2100 int rhs = 1;
79072805 2101
afd9910b
NC
2102 switch (PL_op->op_type) {
2103 case OP_SLT:
2104 amg_type = slt_amg;
2105 /* cmp < 0 */
2106 rhs = 0;
2107 break;
2108 case OP_SGT:
2109 amg_type = sgt_amg;
2110 /* cmp > 0 */
2111 multiplier = -1;
2112 rhs = 0;
2113 break;
2114 case OP_SGE:
2115 amg_type = sge_amg;
2116 /* cmp >= 0 */
2117 multiplier = -1;
2118 break;
79072805 2119 }
79072805 2120
afd9910b 2121 tryAMAGICbinSET_var(amg_type,0);
a0d0e21e
LW
2122 {
2123 dPOPTOPssrl;
1b6737cc 2124 const int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2125 ? sv_cmp_locale(left, right)
2126 : sv_cmp(left, right));
afd9910b 2127 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW
2128 RETURN;
2129 }
2130}
79072805 2131
36477c24 2132PP(pp_seq)
2133{
39644a26 2134 dSP; tryAMAGICbinSET(seq,0);
36477c24 2135 {
2136 dPOPTOPssrl;
54310121 2137 SETs(boolSV(sv_eq(left, right)));
a0d0e21e
LW
2138 RETURN;
2139 }
2140}
79072805 2141
a0d0e21e 2142PP(pp_sne)
79072805 2143{
39644a26 2144 dSP; tryAMAGICbinSET(sne,0);
a0d0e21e
LW
2145 {
2146 dPOPTOPssrl;
54310121 2147 SETs(boolSV(!sv_eq(left, right)));
a0d0e21e 2148 RETURN;
463ee0b2 2149 }
79072805
LW
2150}
2151
a0d0e21e 2152PP(pp_scmp)
79072805 2153{
39644a26 2154 dSP; dTARGET; tryAMAGICbin(scmp,0);
a0d0e21e
LW
2155 {
2156 dPOPTOPssrl;
1b6737cc 2157 const int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2158 ? sv_cmp_locale(left, right)
2159 : sv_cmp(left, right));
2160 SETi( cmp );
a0d0e21e
LW
2161 RETURN;
2162 }
2163}
79072805 2164
55497cff 2165PP(pp_bit_and)
2166{
39644a26 2167 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
a0d0e21e
LW
2168 {
2169 dPOPTOPssrl;
5b295bef
RD
2170 SvGETMAGIC(left);
2171 SvGETMAGIC(right);
4633a7c4 2172 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2173 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2174 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2175 SETi(i);
d0ba1bd2
JH
2176 }
2177 else {
1b6737cc 2178 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2179 SETu(u);
d0ba1bd2 2180 }
a0d0e21e
LW
2181 }
2182 else {
533c011a 2183 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2184 SETTARG;
2185 }
2186 RETURN;
2187 }
2188}
79072805 2189
a0d0e21e
LW
2190PP(pp_bit_xor)
2191{
39644a26 2192 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
a0d0e21e
LW
2193 {
2194 dPOPTOPssrl;
5b295bef
RD
2195 SvGETMAGIC(left);
2196 SvGETMAGIC(right);
4633a7c4 2197 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2198 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2199 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
972b05a9 2200 SETi(i);
d0ba1bd2
JH
2201 }
2202 else {
1b6737cc 2203 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
972b05a9 2204 SETu(u);
d0ba1bd2 2205 }
a0d0e21e
LW
2206 }
2207 else {
533c011a 2208 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2209 SETTARG;
2210 }
2211 RETURN;
2212 }
2213}
79072805 2214
a0d0e21e
LW
2215PP(pp_bit_or)
2216{
39644a26 2217 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
a0d0e21e
LW
2218 {
2219 dPOPTOPssrl;
5b295bef
RD
2220 SvGETMAGIC(left);
2221 SvGETMAGIC(right);
4633a7c4 2222 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2223 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2224 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
972b05a9 2225 SETi(i);
d0ba1bd2
JH
2226 }
2227 else {
1b6737cc 2228 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
972b05a9 2229 SETu(u);
d0ba1bd2 2230 }
a0d0e21e
LW
2231 }
2232 else {
533c011a 2233 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2234 SETTARG;
2235 }
2236 RETURN;
79072805 2237 }
a0d0e21e 2238}
79072805 2239
a0d0e21e
LW
2240PP(pp_negate)
2241{
39644a26 2242 dSP; dTARGET; tryAMAGICun(neg);
a0d0e21e
LW
2243 {
2244 dTOPss;
1b6737cc 2245 const int flags = SvFLAGS(sv);
5b295bef 2246 SvGETMAGIC(sv);
28e5dec8
JH
2247 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2248 /* It's publicly an integer, or privately an integer-not-float */
2249 oops_its_an_int:
9b0e499b
GS
2250 if (SvIsUV(sv)) {
2251 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2252 /* 2s complement assumption. */
9b0e499b
GS
2253 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2254 RETURN;
2255 }
2256 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2257 SETi(-SvIVX(sv));
9b0e499b
GS
2258 RETURN;
2259 }
2260 }
2261 else if (SvIVX(sv) != IV_MIN) {
2262 SETi(-SvIVX(sv));
2263 RETURN;
2264 }
28e5dec8
JH
2265#ifdef PERL_PRESERVE_IVUV
2266 else {
2267 SETu((UV)IV_MIN);
2268 RETURN;
2269 }
2270#endif
9b0e499b
GS
2271 }
2272 if (SvNIOKp(sv))
a0d0e21e 2273 SETn(-SvNV(sv));
4633a7c4 2274 else if (SvPOKp(sv)) {
a0d0e21e 2275 STRLEN len;
6f46942a 2276 const char *s = SvPV_const(sv, len);
bbce6d69 2277 if (isIDFIRST(*s)) {
a0d0e21e
LW
2278 sv_setpvn(TARG, "-", 1);
2279 sv_catsv(TARG, sv);
79072805 2280 }
a0d0e21e
LW
2281 else if (*s == '+' || *s == '-') {
2282 sv_setsv(TARG, sv);
2283 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805 2284 }
8eb28a70
JH
2285 else if (DO_UTF8(sv)) {
2286 SvIV_please(sv);
2287 if (SvIOK(sv))
2288 goto oops_its_an_int;
2289 if (SvNOK(sv))
2290 sv_setnv(TARG, -SvNV(sv));
2291 else {
2292 sv_setpvn(TARG, "-", 1);
2293 sv_catsv(TARG, sv);
2294 }
834a4ddd 2295 }
28e5dec8 2296 else {
8eb28a70
JH
2297 SvIV_please(sv);
2298 if (SvIOK(sv))
2299 goto oops_its_an_int;
2300 sv_setnv(TARG, -SvNV(sv));
28e5dec8 2301 }
a0d0e21e 2302 SETTARG;
79072805 2303 }
4633a7c4
LW
2304 else
2305 SETn(-SvNV(sv));
79072805 2306 }
a0d0e21e 2307 RETURN;
79072805
LW
2308}
2309
a0d0e21e 2310PP(pp_not)
79072805 2311{
39644a26 2312 dSP; tryAMAGICunSET(not);
3280af22 2313 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
a0d0e21e 2314 return NORMAL;
79072805
LW
2315}
2316
a0d0e21e 2317PP(pp_complement)
79072805 2318{
39644a26 2319 dSP; dTARGET; tryAMAGICun(compl);
a0d0e21e
LW
2320 {
2321 dTOPss;
5b295bef 2322 SvGETMAGIC(sv);
4633a7c4 2323 if (SvNIOKp(sv)) {
d0ba1bd2 2324 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2325 const IV i = ~SvIV_nomg(sv);
972b05a9 2326 SETi(i);
d0ba1bd2
JH
2327 }
2328 else {
1b6737cc 2329 const UV u = ~SvUV_nomg(sv);
972b05a9 2330 SETu(u);
d0ba1bd2 2331 }
a0d0e21e
LW
2332 }
2333 else {
51723571 2334 register U8 *tmps;
55497cff 2335 register I32 anum;
a0d0e21e
LW
2336 STRLEN len;
2337
10516c54 2338 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
891f9566 2339 sv_setsv_nomg(TARG, sv);
51723571 2340 tmps = (U8*)SvPV_force(TARG, len);
a0d0e21e 2341 anum = len;
1d68d6cd 2342 if (SvUTF8(TARG)) {
a1ca4561 2343 /* Calculate exact length, let's not estimate. */
1d68d6cd
SC
2344 STRLEN targlen = 0;
2345 U8 *result;
51723571 2346 U8 *send;
ba210ebe 2347 STRLEN l;
a1ca4561
YST
2348 UV nchar = 0;
2349 UV nwide = 0;
1d68d6cd
SC
2350
2351 send = tmps + len;
2352 while (tmps < send) {
1b6737cc 2353 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1d68d6cd 2354 tmps += UTF8SKIP(tmps);
5bbb0b5a 2355 targlen += UNISKIP(~c);
a1ca4561
YST
2356 nchar++;
2357 if (c > 0xff)
2358 nwide++;
1d68d6cd
SC
2359 }
2360
2361 /* Now rewind strings and write them. */
2362 tmps -= len;
a1ca4561
YST
2363
2364 if (nwide) {
a02a5408 2365 Newxz(result, targlen + 1, U8);
a1ca4561 2366 while (tmps < send) {
1b6737cc 2367 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
a1ca4561 2368 tmps += UTF8SKIP(tmps);
b851fbc1 2369 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
a1ca4561
YST
2370 }
2371 *result = '\0';
2372 result -= targlen;
2373 sv_setpvn(TARG, (char*)result, targlen);
2374 SvUTF8_on(TARG);
2375 }
2376 else {
a02a5408 2377 Newxz(result, nchar + 1, U8);
a1ca4561 2378 while (tmps < send) {
1b6737cc 2379 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
a1ca4561
YST
2380 tmps += UTF8SKIP(tmps);
2381 *result++ = ~c;
2382 }
2383 *result = '\0';
2384 result -= nchar;
2385 sv_setpvn(TARG, (char*)result, nchar);
d0a21e00 2386 SvUTF8_off(TARG);
1d68d6cd 2387 }
1d68d6cd
SC
2388 Safefree(result);
2389 SETs(TARG);
2390 RETURN;
2391 }
a0d0e21e 2392#ifdef LIBERAL
51723571
JH
2393 {
2394 register long *tmpl;
2395 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2396 *tmps = ~*tmps;
2397 tmpl = (long*)tmps;
2398 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2399 *tmpl = ~*tmpl;
2400 tmps = (U8*)tmpl;
2401 }
a0d0e21e
LW
2402#endif
2403 for ( ; anum > 0; anum--, tmps++)
2404 *tmps = ~*tmps;
2405
2406 SETs(TARG);
2407 }
2408 RETURN;
2409 }
79072805
LW
2410}
2411
a0d0e21e
LW
2412/* integer versions of some of the above */
2413
a0d0e21e 2414PP(pp_i_multiply)
79072805 2415{
39644a26 2416 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW
2417 {
2418 dPOPTOPiirl;
2419 SETi( left * right );
2420 RETURN;
2421 }
79072805
LW
2422}
2423
a0d0e21e 2424PP(pp_i_divide)
79072805 2425{
39644a26 2426 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e
LW
2427 {
2428 dPOPiv;
2429 if (value == 0)
cea2e8a9 2430 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW
2431 value = POPi / value;
2432 PUSHi( value );
2433 RETURN;
2434 }
79072805
LW
2435}
2436
224ec323
JH
2437STATIC
2438PP(pp_i_modulo_0)
2439{
2440 /* This is the vanilla old i_modulo. */
27da23d5 2441 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
224ec323
JH
2442 {
2443 dPOPTOPiirl;
2444 if (!right)
2445 DIE(aTHX_ "Illegal modulus zero");
2446 SETi( left % right );
2447 RETURN;
2448 }
2449}
2450
11010fa3 2451#if defined(__GLIBC__) && IVSIZE == 8
224ec323
JH
2452STATIC
2453PP(pp_i_modulo_1)
2454{
224ec323 2455 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2456 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2457 * See below for pp_i_modulo. */
27da23d5 2458 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
224ec323
JH
2459 {
2460 dPOPTOPiirl;
2461 if (!right)
2462 DIE(aTHX_ "Illegal modulus zero");
32fdb065 2463 SETi( left % PERL_ABS(right) );
224ec323
JH
2464 RETURN;
2465 }
224ec323 2466}
fce2b89e 2467#endif
224ec323 2468
a0d0e21e 2469PP(pp_i_modulo)
79072805 2470{
27da23d5 2471 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
224ec323
JH
2472 {
2473 dPOPTOPiirl;
2474 if (!right)
2475 DIE(aTHX_ "Illegal modulus zero");
2476 /* The assumption is to use hereafter the old vanilla version... */
2477 PL_op->op_ppaddr =
2478 PL_ppaddr[OP_I_MODULO] =
1c127fab 2479 Perl_pp_i_modulo_0;
224ec323
JH
2480 /* .. but if we have glibc, we might have a buggy _moddi3
2481 * (at least glicb 2.2.5 is known to have this bug), in other
2482 * words our integer modulus with negative quad as the second
2483 * argument might be broken. Test for this and re-patch the
2484 * opcode dispatch table if that is the case, remembering to
2485 * also apply the workaround so that this first round works
2486 * right, too. See [perl #9402] for more information. */
2487#if defined(__GLIBC__) && IVSIZE == 8
2488 {
2489 IV l = 3;
2490 IV r = -10;
2491 /* Cannot do this check with inlined IV constants since
2492 * that seems to work correctly even with the buggy glibc. */
2493 if (l % r == -3) {
2494 /* Yikes, we have the bug.
2495 * Patch in the workaround version. */
2496 PL_op->op_ppaddr =
2497 PL_ppaddr[OP_I_MODULO] =
2498 &Perl_pp_i_modulo_1;
2499 /* Make certain we work right this time, too. */
32fdb065 2500 right = PERL_ABS(right);
224ec323
JH
2501 }
2502 }
2503#endif
2504 SETi( left % right );
2505 RETURN;
2506 }
79072805
LW
2507}
2508
a0d0e21e 2509PP(pp_i_add)
79072805 2510{
39644a26 2511 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
a0d0e21e 2512 {
5e66d4f1 2513 dPOPTOPiirl_ul;
a0d0e21e
LW
2514 SETi( left + right );
2515 RETURN;
79072805 2516 }
79072805
LW
2517}
2518
a0d0e21e 2519PP(pp_i_subtract)
79072805 2520{
39644a26 2521 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 2522 {
5e66d4f1 2523 dPOPTOPiirl_ul;
a0d0e21e
LW
2524 SETi( left - right );
2525 RETURN;
79072805 2526 }
79072805
LW
2527}
2528
a0d0e21e 2529PP(pp_i_lt)
79072805 2530{
39644a26 2531 dSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW
2532 {
2533 dPOPTOPiirl;
54310121 2534 SETs(boolSV(left < right));
a0d0e21e
LW
2535 RETURN;
2536 }
79072805
LW
2537}
2538
a0d0e21e 2539PP(pp_i_gt)
79072805 2540{
39644a26 2541 dSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW
2542 {
2543 dPOPTOPiirl;
54310121 2544 SETs(boolSV(left > right));
a0d0e21e
LW
2545 RETURN;
2546 }
79072805
LW
2547}
2548
a0d0e21e 2549PP(pp_i_le)
79072805 2550{
39644a26 2551 dSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW
2552 {
2553 dPOPTOPiirl;
54310121 2554 SETs(boolSV(left <= right));
a0d0e21e 2555 RETURN;
85e6fe83 2556 }
79072805
LW
2557}
2558
a0d0e21e 2559PP(pp_i_ge)
79072805 2560{
39644a26 2561 dSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW
2562 {
2563 dPOPTOPiirl;
54310121 2564 SETs(boolSV(left >= right));
a0d0e21e
LW
2565 RETURN;
2566 }
79072805
LW
2567}
2568
a0d0e21e 2569PP(pp_i_eq)
79072805 2570{
39644a26 2571 dSP; tryAMAGICbinSET(eq,0);
a0d0e21e
LW
2572 {
2573 dPOPTOPiirl;
54310121 2574 SETs(boolSV(left == right));
a0d0e21e
LW
2575 RETURN;
2576 }
79072805
LW
2577}
2578
a0d0e21e 2579PP(pp_i_ne)
79072805 2580{
39644a26 2581 dSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW
2582 {
2583 dPOPTOPiirl;
54310121 2584 SETs(boolSV(left != right));
a0d0e21e
LW
2585 RETURN;
2586 }
79072805
LW
2587}
2588
a0d0e21e 2589PP(pp_i_ncmp)
79072805 2590{
39644a26 2591 dSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW
2592 {
2593 dPOPTOPiirl;
2594 I32 value;
79072805 2595
a0d0e21e 2596 if (left > right)
79072805 2597 value = 1;
a0d0e21e 2598 else if (left < right)
79072805 2599 value = -1;
a0d0e21e 2600 else
79072805 2601 value = 0;
a0d0e21e
LW
2602 SETi(value);
2603 RETURN;
79072805 2604 }
85e6fe83
LW
2605}
2606
2607PP(pp_i_negate)
2608{
39644a26 2609 dSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW
2610 SETi(-TOPi);
2611 RETURN;
2612}
2613
79072805
LW
2614/* High falutin' math. */
2615
2616PP(pp_atan2)
2617{
39644a26 2618 dSP; dTARGET; tryAMAGICbin(atan2,0);
a0d0e21e
LW
2619 {
2620 dPOPTOPnnrl;
65202027 2621 SETn(Perl_atan2(left, right));
a0d0e21e
LW
2622 RETURN;
2623 }
79072805
LW
2624}
2625
2626PP(pp_sin)
2627{
39644a26 2628 dSP; dTARGET; tryAMAGICun(sin);
a0d0e21e 2629 {
1b6737cc
AL
2630 const NV value = POPn;
2631 XPUSHn(Perl_sin(value));
a0d0e21e
LW
2632 RETURN;
2633 }
79072805
LW
2634}
2635
2636PP(pp_cos)
2637{
39644a26 2638 dSP; dTARGET; tryAMAGICun(cos);
a0d0e21e 2639 {
1b6737cc
AL
2640 const NV value = POPn;
2641 XPUSHn(Perl_cos(value));
a0d0e21e
LW
2642 RETURN;
2643 }
79072805
LW
2644}
2645
56cb0a1c
AD
2646/* Support Configure command-line overrides for rand() functions.
2647 After 5.005, perhaps we should replace this by Configure support
2648 for drand48(), random(), or rand(). For 5.005, though, maintain
2649 compatibility by calling rand() but allow the user to override it.
2650 See INSTALL for details. --Andy Dougherty 15 July 1998
2651*/
85ab1d1d
JH
2652/* Now it's after 5.005, and Configure supports drand48() and random(),
2653 in addition to rand(). So the overrides should not be needed any more.
2654 --Jarkko Hietaniemi 27 September 1998
2655 */
2656
2657#ifndef HAS_DRAND48_PROTO
20ce7b12 2658extern double drand48 (void);
56cb0a1c
AD
2659#endif
2660
79072805
LW
2661PP(pp_rand)
2662{
39644a26 2663 dSP; dTARGET;
65202027 2664 NV value;
79072805
LW
2665 if (MAXARG < 1)
2666 value = 1.0;
2667 else
2668 value = POPn;
2669 if (value == 0.0)
2670 value = 1.0;
80252599 2671 if (!PL_srand_called) {
85ab1d1d 2672 (void)seedDrand01((Rand_seed_t)seed());
80252599 2673 PL_srand_called = TRUE;
93dc8474 2674 }
85ab1d1d 2675 value *= Drand01();
79072805
LW
2676 XPUSHn(value);
2677 RETURN;
2678}
2679
2680PP(pp_srand)
2681{
39644a26 2682 dSP;
93dc8474
CS
2683 UV anum;
2684 if (MAXARG < 1)
2685 anum = seed();
79072805 2686 else
93dc8474 2687 anum = POPu;
85ab1d1d 2688 (void)seedDrand01((Rand_seed_t)anum);
80252599 2689 PL_srand_called = TRUE;
79072805
LW
2690 EXTEND(SP, 1);
2691 RETPUSHYES;
2692}
2693
2694PP(pp_exp)
2695{
39644a26 2696 dSP; dTARGET; tryAMAGICun(exp);
a0d0e21e 2697 {
65202027 2698 NV value;
a0d0e21e 2699 value = POPn;
65202027 2700 value = Perl_exp(value);
a0d0e21e
LW
2701 XPUSHn(value);
2702 RETURN;
2703 }
79072805
LW
2704}
2705
2706PP(pp_log)
2707{
39644a26 2708 dSP; dTARGET; tryAMAGICun(log);
a0d0e21e 2709 {
1b6737cc 2710 const NV value = POPn;
bbce6d69 2711 if (value <= 0.0) {
f93f4e46 2712 SET_NUMERIC_STANDARD();
1779d84d 2713 DIE(aTHX_ "Can't take log of %"NVgf, value);
bbce6d69 2714 }
1b6737cc 2715 XPUSHn(Perl_log(value));
a0d0e21e
LW
2716 RETURN;
2717 }
79072805
LW
2718}
2719
2720PP(pp_sqrt)
2721{
39644a26 2722 dSP; dTARGET; tryAMAGICun(sqrt);
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 sqrt of %"NVgf, value);
bbce6d69 2728 }
1b6737cc 2729 XPUSHn(Perl_sqrt(value));
a0d0e21e
LW
2730 RETURN;
2731 }
79072805
LW
2732}
2733
2734PP(pp_int)
2735{
39644a26 2736 dSP; dTARGET; tryAMAGICun(int);
774d564b 2737 {
1b6737cc 2738 const IV iv = TOPi; /* attempt to convert to IV if possible. */
28e5dec8
JH
2739 /* XXX it's arguable that compiler casting to IV might be subtly
2740 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2741 else preferring IV has introduced a subtle behaviour change bug. OTOH
2742 relying on floating point to be accurate is a bug. */
2743
922c4365
MHM
2744 if (!SvOK(TOPs))
2745 SETu(0);
2746 else if (SvIOK(TOPs)) {
28e5dec8 2747 if (SvIsUV(TOPs)) {
1b6737cc 2748 const UV uv = TOPu;
28e5dec8
JH
2749 SETu(uv);
2750 } else
2751 SETi(iv);
2752 } else {
1b6737cc 2753 const NV value = TOPn;
1048ea30 2754 if (value >= 0.0) {
28e5dec8
JH
2755 if (value < (NV)UV_MAX + 0.5) {
2756 SETu(U_V(value));
2757 } else {
059a1014 2758 SETn(Perl_floor(value));
28e5dec8 2759 }
1048ea30 2760 }
28e5dec8
JH
2761 else {
2762 if (value > (NV)IV_MIN - 0.5) {
2763 SETi(I_V(value));
2764 } else {
1bbae031 2765 SETn(Perl_ceil(value));
28e5dec8
JH
2766 }
2767 }
774d564b 2768 }
79072805 2769 }
79072805
LW
2770 RETURN;
2771}
2772
463ee0b2
LW
2773PP(pp_abs)
2774{
39644a26 2775 dSP; dTARGET; tryAMAGICun(abs);
a0d0e21e 2776 {
28e5dec8 2777 /* This will cache the NV value if string isn't actually integer */
1b6737cc 2778 const IV iv = TOPi;
a227d84d 2779
922c4365
MHM
2780 if (!SvOK(TOPs))
2781 SETu(0);
2782 else if (SvIOK(TOPs)) {
28e5dec8
JH
2783 /* IVX is precise */
2784 if (SvIsUV(TOPs)) {
2785 SETu(TOPu); /* force it to be numeric only */
2786 } else {
2787 if (iv >= 0) {
2788 SETi(iv);
2789 } else {
2790 if (iv != IV_MIN) {
2791 SETi(-iv);
2792 } else {
2793 /* 2s complement assumption. Also, not really needed as
2794 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2795 SETu(IV_MIN);
2796 }
a227d84d 2797 }
28e5dec8
JH
2798 }
2799 } else{
1b6737cc 2800 const NV value = TOPn;
774d564b 2801 if (value < 0.0)
1b6737cc 2802 SETn(-value);
a4474c9e
DD
2803 else
2804 SETn(value);
774d564b 2805 }
a0d0e21e 2806 }
774d564b 2807 RETURN;
463ee0b2
LW
2808}
2809
53305cf1 2810
79072805
LW
2811PP(pp_hex)
2812{
39644a26 2813 dSP; dTARGET;
5c144d81 2814 const char *tmps;
53305cf1 2815 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2816 STRLEN len;
53305cf1
NC
2817 NV result_nv;
2818 UV result_uv;
1b6737cc 2819 SV* const sv = POPs;
79072805 2820
349d4f2f 2821 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS
2822 if (DO_UTF8(sv)) {
2823 /* If Unicode, try to downgrade
2824 * If not possible, croak. */
1b6737cc 2825 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS
2826
2827 SvUTF8_on(tsv);
2828 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2829 tmps = SvPV_const(tsv, len);
2bc69dc4 2830 }
53305cf1
NC
2831 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2832 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2833 XPUSHn(result_nv);
2834 }
2835 else {
2836 XPUSHu(result_uv);
2837 }
79072805
LW
2838 RETURN;
2839}
2840
2841PP(pp_oct)
2842{
39644a26 2843 dSP; dTARGET;
5c144d81 2844 const char *tmps;
53305cf1 2845 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2846 STRLEN len;
53305cf1
NC
2847 NV result_nv;
2848 UV result_uv;
1b6737cc 2849 SV* const sv = POPs;
79072805 2850
349d4f2f 2851 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS
2852 if (DO_UTF8(sv)) {
2853 /* If Unicode, try to downgrade
2854 * If not possible, croak. */
1b6737cc 2855 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS
2856
2857 SvUTF8_on(tsv);
2858 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2859 tmps = SvPV_const(tsv, len);
2bc69dc4 2860 }
6f894ead 2861 while (*tmps && len && isSPACE(*tmps))
53305cf1 2862 tmps++, len--;
9e24b6e2 2863 if (*tmps == '0')
53305cf1 2864 tmps++, len--;
9e24b6e2 2865 if (*tmps == 'x')
53305cf1 2866 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
9e24b6e2 2867 else if (*tmps == 'b')
53305cf1 2868 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2869 else
53305cf1
NC
2870 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2871
2872 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2873 XPUSHn(result_nv);
2874 }
2875 else {
2876 XPUSHu(result_uv);
2877 }
79072805
LW
2878 RETURN;
2879}
2880
2881/* String stuff. */
2882
2883PP(pp_length)
2884{
39644a26 2885 dSP; dTARGET;
7e2040f0 2886 SV *sv = TOPs;
a0ed51b3 2887
7e2040f0
GS
2888 if (DO_UTF8(sv))
2889 SETi(sv_len_utf8(sv));
2890 else
2891 SETi(sv_len(sv));
79072805
LW
2892 RETURN;
2893}
2894
2895PP(pp_substr)
2896{
39644a26 2897 dSP; dTARGET;
79072805 2898 SV *sv;
9c5ffd7c 2899 I32 len = 0;
463ee0b2 2900 STRLEN curlen;
9402d6ed 2901 STRLEN utf8_curlen;
79072805
LW
2902 I32 pos;
2903 I32 rem;
84902520 2904 I32 fail;
e1ec3a88
AL
2905 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2906 const char *tmps;
2907 const I32 arybase = PL_curcop->cop_arybase;
9402d6ed 2908 SV *repl_sv = NULL;
e1ec3a88 2909 const char *repl = 0;
7b8d334a 2910 STRLEN repl_len;
1b6737cc 2911 const int num_args = PL_op->op_private & 7;
13e30c65 2912 bool repl_need_utf8_upgrade = FALSE;
9402d6ed 2913 bool repl_is_utf8 = FALSE;
79072805 2914
20408e3c 2915 SvTAINTED_off(TARG); /* decontaminate */
7e2040f0 2916 SvUTF8_off(TARG); /* decontaminate */
78f9721b
SM
2917 if (num_args > 2) {
2918 if (num_args > 3) {
9402d6ed 2919 repl_sv = POPs;
83003860 2920 repl = SvPV_const(repl_sv, repl_len);
9402d6ed 2921 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
7b8d334a 2922 }
79072805 2923 len = POPi;
5d82c453 2924 }
84902520 2925 pos = POPi;
79072805 2926 sv = POPs;
849ca7ee 2927 PUTBACK;
9402d6ed
JH
2928 if (repl_sv) {
2929 if (repl_is_utf8) {
2930 if (!DO_UTF8(sv))
2931 sv_utf8_upgrade(sv);
2932 }
13e30c65
JH
2933 else if (DO_UTF8(sv))
2934 repl_need_utf8_upgrade = TRUE;
9402d6ed 2935 }
5c144d81 2936 tmps = SvPV_const(sv, curlen);
7e2040f0 2937 if (DO_UTF8(sv)) {
9402d6ed
JH
2938 utf8_curlen = sv_len_utf8(sv);
2939 if (utf8_curlen == curlen)
2940 utf8_curlen = 0;
a0ed51b3 2941 else
9402d6ed 2942 curlen = utf8_curlen;
a0ed51b3 2943 }
d1c2b58a 2944 else
9402d6ed 2945 utf8_curlen = 0;
a0ed51b3 2946
84902520
TB
2947 if (pos >= arybase) {
2948 pos -= arybase;
2949 rem = curlen-pos;
2950 fail = rem;
78f9721b 2951 if (num_args > 2) {
5d82c453
GA
2952 if (len < 0) {
2953 rem += len;
2954 if (rem < 0)
2955 rem = 0;
2956 }
2957 else if (rem > len)
2958 rem = len;
2959 }
68dc0745 2960 }
84902520 2961 else {
5d82c453 2962 pos += curlen;
78f9721b 2963 if (num_args < 3)
5d82c453
GA
2964 rem = curlen;
2965 else if (len >= 0) {
2966 rem = pos+len;
2967 if (rem > (I32)curlen)
2968 rem = curlen;
2969 }
2970 else {
2971 rem = curlen+len;
2972 if (rem < pos)
2973 rem = pos;
2974 }
2975 if (pos < 0)
2976 pos = 0;
2977 fail = rem;
2978 rem -= pos;
84902520
TB
2979 }
2980 if (fail < 0) {
e476b1b5
GS
2981 if (lvalue || repl)
2982 Perl_croak(aTHX_ "substr outside of string");
2983 if (ckWARN(WARN_SUBSTR))
9014280d 2984 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2304df62
AD
2985 RETPUSHUNDEF;
2986 }
79072805 2987 else {
1b6737cc
AL
2988 const I32 upos = pos;
2989 const I32 urem = rem;
9402d6ed 2990 if (utf8_curlen)
a0ed51b3 2991 sv_pos_u2b(sv, &pos, &rem);
79072805 2992 tmps += pos;
781e7547
DM
2993 /* we either return a PV or an LV. If the TARG hasn't been used
2994 * before, or is of that type, reuse it; otherwise use a mortal
2995 * instead. Note that LVs can have an extended lifetime, so also
2996 * dont reuse if refcount > 1 (bug #20933) */
2997 if (SvTYPE(TARG) > SVt_NULL) {
2998 if ( (SvTYPE(TARG) == SVt_PVLV)
2999 ? (!lvalue || SvREFCNT(TARG) > 1)
3000 : lvalue)
3001 {
3002 TARG = sv_newmortal();
3003 }
3004 }
3005
79072805 3006 sv_setpvn(TARG, tmps, rem);
12aa1545 3007#ifdef USE_LOCALE_COLLATE
14befaf4 3008 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3009#endif
9402d6ed 3010 if (utf8_curlen)
7f66633b 3011 SvUTF8_on(TARG);
f7928d6c 3012 if (repl) {
13e30c65
JH
3013 SV* repl_sv_copy = NULL;
3014
3015 if (repl_need_utf8_upgrade) {
3016 repl_sv_copy = newSVsv(repl_sv);
3017 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3018 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65
JH
3019 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3020 }
c8faf1c5 3021 sv_insert(sv, pos, rem, repl, repl_len);
9402d6ed 3022 if (repl_is_utf8)
f7928d6c 3023 SvUTF8_on(sv);
9402d6ed
JH
3024 if (repl_sv_copy)
3025 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3026 }
c8faf1c5 3027 else if (lvalue) { /* it's an lvalue! */
dedeecda 3028 if (!SvGMAGICAL(sv)) {
3029 if (SvROK(sv)) {
13c5b33c 3030 SvPV_force_nolen(sv);
599cee73 3031 if (ckWARN(WARN_SUBSTR))
9014280d 3032 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
599cee73 3033 "Attempt to use reference as lvalue in substr");
dedeecda 3034 }
3035 if (SvOK(sv)) /* is it defined ? */
7f66633b 3036 (void)SvPOK_only_UTF8(sv);
dedeecda 3037 else
3038 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3039 }
5f05dabc 3040
a0d0e21e
LW
3041 if (SvTYPE(TARG) < SVt_PVLV) {
3042 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3043 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
ed6116ce 3044 }
6214ab63 3045 else
0c34ef67 3046 SvOK_off(TARG);
a0d0e21e 3047
5f05dabc 3048 LvTYPE(TARG) = 'x';
6ff81951
GS
3049 if (LvTARG(TARG) != sv) {
3050 if (LvTARG(TARG))
3051 SvREFCNT_dec(LvTARG(TARG));
3052 LvTARG(TARG) = SvREFCNT_inc(sv);
3053 }
9aa983d2
JH
3054 LvTARGOFF(TARG) = upos;
3055 LvTARGLEN(TARG) = urem;
79072805
LW
3056 }
3057 }
849ca7ee 3058 SPAGAIN;
79072805
LW
3059 PUSHs(TARG); /* avoid SvSETMAGIC here */
3060 RETURN;
3061}
3062
3063PP(pp_vec)
3064{
39644a26 3065 dSP; dTARGET;
1b6737cc
AL
3066 register const IV size = POPi;
3067 register const IV offset = POPi;
3068 register SV * const src = POPs;
3069 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e 3070
81e118e0
JH
3071 SvTAINTED_off(TARG); /* decontaminate */
3072 if (lvalue) { /* it's an lvalue! */
24aef97f
HS
3073 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3074 TARG = sv_newmortal();
81e118e0
JH
3075 if (SvTYPE(TARG) < SVt_PVLV) {
3076 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3077 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
79072805 3078 }
81e118e0
JH
3079 LvTYPE(TARG) = 'v';
3080 if (LvTARG(TARG) != src) {
3081 if (LvTARG(TARG))
3082 SvREFCNT_dec(LvTARG(TARG));
3083 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 3084 }
81e118e0
JH
3085 LvTARGOFF(TARG) = offset;
3086 LvTARGLEN(TARG) = size;
79072805
LW
3087 }
3088
81e118e0 3089 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW
3090 PUSHs(TARG);
3091 RETURN;
3092}
3093
3094PP(pp_index)
3095{
39644a26 3096 dSP; dTARGET;
79072805
LW
3097 SV *big;
3098 SV *little;
e609e586 3099 SV *temp = Nullsv;
79072805
LW
3100 I32 offset;
3101 I32 retval;
10516c54
NC
3102 const char *tmps;
3103 const char *tmps2;
463ee0b2 3104 STRLEN biglen;
1b6737cc 3105 const I32 arybase = PL_curcop->cop_arybase;
e609e586
NC
3106 int big_utf8;
3107 int little_utf8;
79072805
LW
3108
3109 if (MAXARG < 3)
3110 offset = 0;
3111 else
3112 offset = POPi - arybase;
3113 little = POPs;
3114 big = POPs;
e609e586
NC
3115 big_utf8 = DO_UTF8(big);
3116 little_utf8 = DO_UTF8(little);
3117 if (big_utf8 ^ little_utf8) {
3118 /* One needs to be upgraded. */
1b6737cc 3119 SV * const bytes = little_utf8 ? big : little;
e609e586 3120 STRLEN len;
1b6737cc 3121 const char * const p = SvPV_const(bytes, len);
e609e586
NC
3122
3123 temp = newSVpvn(p, len);
3124
3125 if (PL_encoding) {
3126 sv_recode_to_utf8(temp, PL_encoding);
3127 } else {
3128 sv_utf8_upgrade(temp);
3129 }
3130 if (little_utf8) {
3131 big = temp;
3132 big_utf8 = TRUE;
3133 } else {
3134 little = temp;
3135 }
3136 }
3137 if (big_utf8 && offset > 0)
a0ed51b3 3138 sv_pos_u2b(big, &offset, 0);
10516c54 3139 tmps = SvPV_const(big, biglen);
79072805
LW
3140 if (offset < 0)
3141 offset = 0;
eb160463 3142 else if (offset > (I32)biglen)
93a17b20 3143 offset = biglen;
79072805 3144 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 3145 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 3146 retval = -1;
79072805 3147 else
a0ed51b3 3148 retval = tmps2 - tmps;
e609e586 3149 if (retval > 0 && big_utf8)
a0ed51b3 3150 sv_pos_b2u(big, &retval);
e609e586
NC
3151 if (temp)
3152 SvREFCNT_dec(temp);
a0ed51b3 3153 PUSHi(retval + arybase);
79072805
LW
3154 RETURN;
3155}
3156
3157PP(pp_rindex)
3158{
39644a26 3159 dSP; dTARGET;
79072805
LW
3160 SV *big;
3161 SV *little;
e609e586 3162 SV *temp = Nullsv;
463ee0b2
LW
3163 STRLEN blen;
3164 STRLEN llen;
79072805
LW
3165 I32 offset;
3166 I32 retval;
10516c54
NC
3167 const char *tmps;
3168 const char *tmps2;
1b6737cc 3169 const I32 arybase = PL_curcop->cop_arybase;
e609e586
NC
3170 int big_utf8;
3171 int little_utf8;
79072805 3172
a0d0e21e 3173 if (MAXARG >= 3)
a0ed51b3 3174 offset = POPi;
79072805
LW
3175 little = POPs;
3176 big = POPs;
e609e586
NC
3177 big_utf8 = DO_UTF8(big);
3178 little_utf8 = DO_UTF8(little);
3179 if (big_utf8 ^ little_utf8) {
3180 /* One needs to be upgraded. */
1b6737cc 3181 SV * const bytes = little_utf8 ? big : little;
e609e586 3182 STRLEN len;
83003860 3183 const char *p = SvPV_const(bytes, len);
e609e586
NC
3184
3185 temp = newSVpvn(p, len);
3186
3187 if (PL_encoding) {
3188 sv_recode_to_utf8(temp, PL_encoding);
3189 } else {
3190 sv_utf8_upgrade(temp);
3191 }
3192 if (little_utf8) {
3193 big = temp;
3194 big_utf8 = TRUE;
3195 } else {
3196 little = temp;
3197 }
3198 }
10516c54
NC
3199 tmps2 = SvPV_const(little, llen);
3200 tmps = SvPV_const(big, blen);
e609e586 3201
79072805 3202 if (MAXARG < 3)
463ee0b2 3203 offset = blen;
a0ed51b3 3204 else {
e609e586 3205 if (offset > 0 && big_utf8)
a0ed51b3
LW
3206 sv_pos_u2b(big, &offset, 0);
3207 offset = offset - arybase + llen;
3208 }
79072805
LW
3209 if (offset < 0)
3210 offset = 0;
eb160463 3211 else if (offset > (I32)blen)
463ee0b2 3212 offset = blen;
79072805 3213 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 3214 tmps2, tmps2 + llen)))
a0ed51b3 3215 retval = -1;
79072805 3216 else
a0ed51b3 3217 retval = tmps2 - tmps;
e609e586 3218 if (retval > 0 && big_utf8)
a0ed51b3 3219 sv_pos_b2u(big, &retval);
e609e586
NC
3220 if (temp)
3221 SvREFCNT_dec(temp);
a0ed51b3 3222 PUSHi(retval + arybase);
79072805
LW
3223 RETURN;
3224}
3225
3226PP(pp_sprintf)
3227{
39644a26 3228 dSP; dMARK; dORIGMARK; dTARGET;
79072805 3229 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3230 TAINT_IF(SvTAINTED(TARG));
79072805
LW
3231 SP = ORIGMARK;
3232 PUSHTARG;
3233 RETURN;
3234}
3235
79072805
LW
3236PP(pp_ord)
3237{
39644a26 3238 dSP; dTARGET;
7df053ec 3239 SV *argsv = POPs;
ba210ebe 3240 STRLEN len;
349d4f2f 3241 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4
JH
3242 SV *tmpsv;
3243
799ef3cb 3244 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
121910a4 3245 tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3246 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
121910a4
JH
3247 argsv = tmpsv;
3248 }
79072805 3249
872c91ae 3250 XPUSHu(DO_UTF8(argsv) ?
89ebb4a3 3251 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
872c91ae 3252 (*s & 0xff));
68795e93 3253
79072805
LW
3254 RETURN;
3255}
3256
463ee0b2
LW
3257PP(pp_chr)
3258{
39644a26 3259 dSP; dTARGET;
463ee0b2 3260 char *tmps;
8a064bd6
JH
3261 UV value;
3262
3263 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3264 ||
3265 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3266 if (IN_BYTES) {
3267 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3268 } else {
3269 (void) POPs; /* Ignore the argument value. */
3270 value = UNICODE_REPLACEMENT;
3271 }
3272 } else {
3273 value = POPu;
3274 }
463ee0b2 3275
862a34c6 3276 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3277
0064a8a9 3278 if (value > 255 && !IN_BYTES) {
eb160463 3279 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3280 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3281 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW
3282 *tmps = '\0';
3283 (void)SvPOK_only(TARG);
aa6ffa16 3284 SvUTF8_on(TARG);
a0ed51b3
LW
3285 XPUSHs(TARG);
3286 RETURN;
3287 }
3288
748a9306 3289 SvGROW(TARG,2);
463ee0b2
LW
3290 SvCUR_set(TARG, 1);
3291 tmps = SvPVX(TARG);
eb160463 3292 *tmps++ = (char)value;
748a9306 3293 *tmps = '\0';
a0d0e21e 3294 (void)SvPOK_only(TARG);
88632417 3295 if (PL_encoding && !IN_BYTES) {
799ef3cb 3296 sv_recode_to_utf8(TARG, PL_encoding);
88632417
JH
3297 tmps = SvPVX(TARG);
3298 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3299 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
d5a15ac2
JH
3300 SvGROW(TARG, 3);
3301 tmps = SvPVX(TARG);
88632417
JH
3302 SvCUR_set(TARG, 2);
3303 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3304 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3305 *tmps = '\0';
3306 SvUTF8_on(TARG);
3307 }
3308 }
463ee0b2
LW
3309 XPUSHs(TARG);
3310 RETURN;
3311}
3312
79072805
LW
3313PP(pp_crypt)
3314{
79072805 3315#ifdef HAS_CRYPT
27da23d5 3316 dSP; dTARGET;
5f74f29c 3317 dPOPTOPssrl;
85c16d83 3318 STRLEN len;
10516c54 3319 const char *tmps = SvPV_const(left, len);
2bc69dc4 3320
85c16d83 3321 if (DO_UTF8(left)) {
2bc69dc4 3322 /* If Unicode, try to downgrade.
f2791508
JH
3323 * If not possible, croak.
3324 * Yes, we made this up. */
1b6737cc 3325 SV* const tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3326
f2791508 3327 SvUTF8_on(tsv);
2bc69dc4 3328 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3329 tmps = SvPV_const(tsv, len);
85c16d83 3330 }
05404ffe
JH
3331# ifdef USE_ITHREADS
3332# ifdef HAS_CRYPT_R
3333 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3334 /* This should be threadsafe because in ithreads there is only
3335 * one thread per interpreter. If this would not be true,
3336 * we would need a mutex to protect this malloc. */
3337 PL_reentrant_buffer->_crypt_struct_buffer =
3338 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3339#if defined(__GLIBC__) || defined(__EMX__)
3340 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3341 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3342 /* work around glibc-2.2.5 bug */
3343 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3344 }
05404ffe 3345#endif
6ab58e4d 3346 }
05404ffe
JH
3347# endif /* HAS_CRYPT_R */
3348# endif /* USE_ITHREADS */
5f74f29c 3349# ifdef FCRYPT
83003860 3350 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3351# else
83003860 3352 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3353# endif
4808266b
JH
3354 SETs(TARG);
3355 RETURN;
79072805 3356#else
b13b2135 3357 DIE(aTHX_
79072805
LW
3358 "The crypt() function is unimplemented due to excessive paranoia.");
3359#endif
79072805
LW
3360}
3361
3362PP(pp_ucfirst)
3363{
39644a26 3364 dSP;
79072805 3365 SV *sv = TOPs;
83003860 3366 const U8 *s;
a0ed51b3 3367 STRLEN slen;
12e9c124 3368 const int op_type = PL_op->op_type;
a0ed51b3 3369
d104a74c 3370 SvGETMAGIC(sv);
3a2263fe 3371 if (DO_UTF8(sv) &&
83003860 3372 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3a2263fe 3373 UTF8_IS_START(*s)) {
89ebb4a3 3374 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
44bc797b
JH
3375 STRLEN ulen;
3376 STRLEN tculen;
a0ed51b3 3377
44bc797b 3378 utf8_to_uvchr(s, &ulen);
12e9c124
NC
3379 if (op_type == OP_UCFIRST) {
3380 toTITLE_utf8(s, tmpbuf, &tculen);
3381 } else {
3382 toLOWER_utf8(s, tmpbuf, &tculen);
3383 }
44bc797b 3384
6f9b16a7 3385 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
a0ed51b3 3386 dTARGET;
3a2263fe
RGS
3387 /* slen is the byte length of the whole SV.
3388 * ulen is the byte length of the original Unicode character
3389 * stored as UTF-8 at s.
12e9c124
NC
3390 * tculen is the byte length of the freshly titlecased (or
3391 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3392 * We first set the result to be the titlecased (/lowercased)
3393 * character, and then append the rest of the SV data. */
44bc797b 3394 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3a2263fe
RGS
3395 if (slen > ulen)
3396 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3397 SvUTF8_on(TARG);
a0ed51b3
LW
3398 SETs(TARG);
3399 }
3400 else {
d104a74c 3401 s = (U8*)SvPV_force_nomg(sv, slen);
44bc797b 3402 Copy(tmpbuf, s, tculen, U8);
a0ed51b3 3403 }
a0ed51b3 3404 }
626727d5 3405 else {
83003860 3406 U8 *s1;
014822e4 3407 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3408 dTARGET;
7e2040f0 3409 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3410 sv_setsv_nomg(TARG, sv);
31351b04
JS
3411 sv = TARG;
3412 SETs(sv);
3413 }
83003860
NC
3414 s1 = (U8*)SvPV_force_nomg(sv, slen);
3415 if (*s1) {
2de3dbcc 3416 if (IN_LOCALE_RUNTIME) {
31351b04
JS
3417 TAINT;
3418 SvTAINTED_on(sv);
12e9c124
NC
3419 *s1 = (op_type == OP_UCFIRST)
3420 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
31351b04
JS
3421 }
3422 else
12e9c124 3423 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
bbce6d69 3424 }
bbce6d69 3425 }
d104a74c 3426 SvSETMAGIC(sv);
79072805
LW
3427 RETURN;
3428}
3429
3430PP(pp_uc)
3431{
39644a26 3432 dSP;
79072805 3433 SV *sv = TOPs;
463ee0b2 3434 STRLEN len;
79072805 3435
d104a74c 3436 SvGETMAGIC(sv);
7e2040f0 3437 if (DO_UTF8(sv)) {
a0ed51b3 3438 dTARGET;
ba210ebe 3439 STRLEN ulen;
a0ed51b3 3440 register U8 *d;
10516c54
NC
3441 const U8 *s;
3442 const U8 *send;
89ebb4a3 3443 U8 tmpbuf[UTF8_MAXBYTES+1];
a0ed51b3 3444
10516c54 3445 s = (const U8*)SvPV_nomg_const(sv,len);
a5a20234 3446 if (!len) {
7e2040f0 3447 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW
3448 sv_setpvn(TARG, "", 0);
3449 SETs(TARG);
a0ed51b3
LW
3450 }
3451 else {
128c9517
JH
3452 STRLEN min = len + 1;
3453
862a34c6 3454 SvUPGRADE(TARG, SVt_PV);
128c9517 3455 SvGROW(TARG, min);
31351b04
JS
3456 (void)SvPOK_only(TARG);
3457 d = (U8*)SvPVX(TARG);
3458 send = s + len;
a2a2844f 3459 while (s < send) {
89ebb4a3
JH
3460 STRLEN u = UTF8SKIP(s);
3461
6fdb5f96 3462 toUPPER_utf8(s, tmpbuf, &ulen);
128c9517
JH
3463 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3464 /* If the eventually required minimum size outgrows
3465 * the available space, we need to grow. */
349d4f2f 3466 UV o = d - (U8*)SvPVX_const(TARG);
89ebb4a3
JH
3467
3468 /* If someone uppercases one million U+03B0s we
3469 * SvGROW() one million times. Or we could try
32c480af
JH
3470 * guessing how much to allocate without allocating
3471 * too much. Such is life. */
128c9517 3472 SvGROW(TARG, min);
89ebb4a3
JH
3473 d = (U8*)SvPVX(TARG) + o;
3474 }
a2a2844f
JH
3475 Copy(tmpbuf, d, ulen, U8);
3476 d += ulen;
89ebb4a3 3477 s += u;
a0ed51b3 3478 }
31351b04 3479 *d = '\0';
7e2040f0 3480 SvUTF8_on(TARG);
349d4f2f 3481 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
31351b04 3482 SETs(TARG);
a0ed51b3 3483 }
a0ed51b3 3484 }
626727d5 3485 else {
10516c54 3486 U8 *s;
014822e4 3487 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3488 dTARGET;
7e2040f0 3489 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3490 sv_setsv_nomg(TARG, sv);
31351b04
JS
3491 sv = TARG;
3492 SETs(sv);
3493 }
d104a74c 3494 s = (U8*)SvPV_force_nomg(sv, len);
31351b04 3495 if (len) {
0d46e09a 3496 register const U8 *send = s + len;
31351b04 3497
2de3dbcc 3498 if (IN_LOCALE_RUNTIME) {
31351b04
JS
3499 TAINT;
3500 SvTAINTED_on(sv);
3501 for (; s < send; s++)
3502 *s = toUPPER_LC(*s);
3503 }
3504 else {
3505 for (; s < send; s++)
3506 *s = toUPPER(*s);
3507 }
bbce6d69 3508 }
79072805 3509 }
d104a74c 3510 SvSETMAGIC(sv);
79072805
LW
3511 RETURN;
3512}
3513
3514PP(pp_lc)
3515{
39644a26 3516 dSP;
79072805 3517 SV *sv = TOPs;
463ee0b2 3518 STRLEN len;
79072805 3519
d104a74c 3520 SvGETMAGIC(sv);
7e2040f0 3521 if (DO_UTF8(sv)) {
a0ed51b3 3522 dTARGET;
10516c54 3523 const U8 *s;
ba210ebe 3524 STRLEN ulen;
a0ed51b3 3525 register U8 *d;
10516c54 3526 const U8 *send;
89ebb4a3 3527 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
a0ed51b3 3528
10516c54 3529 s = (const U8*)SvPV_nomg_const(sv,len);
a5a20234 3530 if (!len) {
7e2040f0 3531 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW
3532 sv_setpvn(TARG, "", 0);
3533 SETs(TARG);
a0ed51b3
LW
3534 }
3535 else {
128c9517
JH
3536 STRLEN min = len + 1;
3537
862a34c6 3538 SvUPGRADE(TARG, SVt_PV);
128c9517 3539 SvGROW(TARG, min);
31351b04
JS
3540 (void)SvPOK_only(TARG);
3541 d = (U8*)SvPVX(TARG);
3542 send = s + len;
a2a2844f 3543 while (s < send) {
1b6737cc
AL
3544 const STRLEN u = UTF8SKIP(s);
3545 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
89ebb4a3
JH
3546
3547#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
6fdb5f96
JH
3548 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3549 /*
3550 * Now if the sigma is NOT followed by
3551 * /$ignorable_sequence$cased_letter/;
3552 * and it IS preceded by
3553 * /$cased_letter$ignorable_sequence/;
3554 * where $ignorable_sequence is
3555 * [\x{2010}\x{AD}\p{Mn}]*
3556 * and $cased_letter is
3557 * [\p{Ll}\p{Lo}\p{Lt}]
3558 * then it should be mapped to 0x03C2,
3559 * (GREEK SMALL LETTER FINAL SIGMA),
3560 * instead of staying 0x03A3.
89ebb4a3
JH
3561 * "should be": in other words,
3562 * this is not implemented yet.
3563 * See lib/unicore/SpecialCasing.txt.
6fdb5f96
JH
3564 */
3565 }
128c9517
JH
3566 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3567 /* If the eventually required minimum size outgrows
3568 * the available space, we need to grow. */
349d4f2f 3569 UV o = d - (U8*)SvPVX_const(TARG);
89ebb4a3
JH
3570
3571 /* If someone lowercases one million U+0130s we
3572 * SvGROW() one million times. Or we could try
32c480af
JH
3573 * guessing how much to allocate without allocating.
3574 * too much. Such is life. */
128c9517 3575 SvGROW(TARG, min);
89ebb4a3
JH
3576 d = (U8*)SvPVX(TARG) + o;
3577 }
a2a2844f
JH
3578 Copy(tmpbuf, d, ulen, U8);
3579 d += ulen;
89ebb4a3 3580 s += u;
a0ed51b3 3581 }
31351b04 3582 *d = '\0';
7e2040f0 3583 SvUTF8_on(TARG);
349d4f2f 3584 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
31351b04 3585 SETs(TARG);
a0ed51b3 3586 }
79072805 3587 }
626727d5 3588 else {
10516c54 3589 U8 *s;
014822e4 3590 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3591 dTARGET;
7e2040f0 3592 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3593 sv_setsv_nomg(TARG, sv);
31351b04
JS
3594 sv = TARG;
3595 SETs(sv);
a0ed51b3 3596 }
bbce6d69 3597
d104a74c 3598 s = (U8*)SvPV_force_nomg(sv, len);
31351b04 3599 if (len) {
1b6737cc 3600 register const U8 * const send = s + len;
bbce6d69 3601
2de3dbcc 3602 if (IN_LOCALE_RUNTIME) {
31351b04
JS
3603 TAINT;
3604 SvTAINTED_on(sv);
3605 for (; s < send; s++)
3606 *s = toLOWER_LC(*s);
3607 }
3608 else {
3609 for (; s < send; s++)
3610 *s = toLOWER(*s);
3611 }
bbce6d69 3612 }
79072805 3613 }
d104a74c 3614 SvSETMAGIC(sv);
79072805
LW
3615 RETURN;
3616}
3617
a0d0e21e 3618PP(pp_quotemeta)
79072805 3619{
39644a26 3620 dSP; dTARGET;
1b6737cc 3621 SV * const sv = TOPs;
a0d0e21e 3622 STRLEN len;
0d46e09a 3623 register const char *s = SvPV_const(sv,len);
79072805 3624
7e2040f0 3625 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 3626 if (len) {
1b6737cc 3627 register char *d;
862a34c6 3628 SvUPGRADE(TARG, SVt_PV);
c07a80fd 3629 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 3630 d = SvPVX(TARG);
7e2040f0 3631 if (DO_UTF8(sv)) {
0dd2cdef 3632 while (len) {
fd400ab9 3633 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW
3634 STRLEN ulen = UTF8SKIP(s);
3635 if (ulen > len)
3636 ulen = len;
3637 len -= ulen;
3638 while (ulen--)
3639 *d++ = *s++;
3640 }
3641 else {
3642 if (!isALNUM(*s))
3643 *d++ = '\\';
3644 *d++ = *s++;
3645 len--;
3646 }
3647 }
7e2040f0 3648 SvUTF8_on(TARG);
0dd2cdef
LW
3649 }
3650 else {
3651 while (len--) {
3652 if (!isALNUM(*s))
3653 *d++ = '\\';
3654 *d++ = *s++;
3655 }
79072805 3656 }
a0d0e21e