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