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