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