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