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