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