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