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