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