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