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