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