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