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