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