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