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