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