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