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