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