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