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