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