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