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