This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #121337] fix issues with op/utf8cache.t
[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;
6ffceeb7 755 else if (ARGTARG)
59f00321 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();
3baa0581 1083 if (SvROK(TOPs))
7dcb9b98 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 1098 sv_setiv(TARG, 0);
e87de4ab 1099 SETTARG;
a0d0e21e
LW
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 {
3a100dab
FC
1653 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1654 /* The parser saw this as a list repeat, and there
1655 are probably several items on the stack. But we're
1656 in scalar/void context, and there's no pp_list to save us
1657 now. So drop the rest of the items -- robin@kitsite.com
1658 */
1659 dMARK;
1660 if (MARK + 1 < SP) {
1661 MARK[1] = TOPm1s;
1662 MARK[2] = TOPs;
1663 }
1664 else {
1665 dTOPss;
1666 ASSUME(MARK + 1 == SP);
1667 XPUSHs(sv);
1668 MARK[1] = &PL_sv_undef;
1669 }
1670 SP = MARK + 2;
1671 }
6f1401dc
DM
1672 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1673 sv = POPs;
1674 }
1675
2b573ace
JH
1676 if (SvIOKp(sv)) {
1677 if (SvUOK(sv)) {
6f1401dc 1678 const UV uv = SvUV_nomg(sv);
2b573ace
JH
1679 if (uv > IV_MAX)
1680 count = IV_MAX; /* The best we can do? */
1681 else
1682 count = uv;
1683 } else {
b3211734 1684 count = SvIV_nomg(sv);
2b573ace
JH
1685 }
1686 }
1687 else if (SvNOKp(sv)) {
6f1401dc 1688 const NV nv = SvNV_nomg(sv);
2b573ace 1689 if (nv < 0.0)
b3211734 1690 count = -1; /* An arbitrary negative integer */
2b573ace
JH
1691 else
1692 count = (IV)nv;
1693 }
1694 else
6f1401dc
DM
1695 count = SvIV_nomg(sv);
1696
b3211734
KW
1697 if (count < 0) {
1698 count = 0;
1699 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1700 "Negative repeat count does nothing");
1701 }
1702
533c011a 1703 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e 1704 dMARK;
a1894d81 1705 static const char* const oom_list_extend = "Out of memory during list extend";
0bd48802
AL
1706 const I32 items = SP - MARK;
1707 const I32 max = items * count;
da9e430b 1708 const U8 mod = PL_op->op_flags & OPf_MOD;
79072805 1709
2b573ace
JH
1710 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1711 /* Did the max computation overflow? */
27d5b266 1712 if (items > 0 && max > 0 && (max < items || max < count))
0157ef98 1713 Perl_croak(aTHX_ "%s", oom_list_extend);
a0d0e21e
LW
1714 MEXTEND(MARK, max);
1715 if (count > 1) {
1716 while (SP > MARK) {
60779a30
DM
1717 if (*SP) {
1718 if (mod && SvPADTMP(*SP)) {
da9e430b 1719 *SP = sv_mortalcopy(*SP);
60779a30 1720 }
976c8a39 1721 SvTEMP_off((*SP));
da9e430b 1722 }
a0d0e21e 1723 SP--;
79072805 1724 }
a0d0e21e
LW
1725 MARK++;
1726 repeatcpy((char*)(MARK + items), (char*)MARK,
ad64d0ec 1727 items * sizeof(const SV *), count - 1);
a0d0e21e 1728 SP += max;
79072805 1729 }
a0d0e21e
LW
1730 else if (count <= 0)
1731 SP -= items;
79072805 1732 }
a0d0e21e 1733 else { /* Note: mark already snarfed by pp_list */
0bd48802 1734 SV * const tmpstr = POPs;
a0d0e21e 1735 STRLEN len;
9b877dbb 1736 bool isutf;
a1894d81 1737 static const char* const oom_string_extend =
2b573ace 1738 "Out of memory during string extend";
a0d0e21e 1739
6f1401dc
DM
1740 if (TARG != tmpstr)
1741 sv_setsv_nomg(TARG, tmpstr);
1742 SvPV_force_nomg(TARG, len);
9b877dbb 1743 isutf = DO_UTF8(TARG);
8ebc5c01
PP
1744 if (count != 1) {
1745 if (count < 1)
1746 SvCUR_set(TARG, 0);
1747 else {
c445ea15 1748 const STRLEN max = (UV)count * len;
19a94d75 1749 if (len > MEM_SIZE_MAX / count)
0157ef98 1750 Perl_croak(aTHX_ "%s", oom_string_extend);
2b573ace 1751 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
8569b9dc 1752 SvGROW(TARG, max + 1);
a0d0e21e 1753 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
b162af07 1754 SvCUR_set(TARG, SvCUR(TARG) * count);
7a4c00b4 1755 }
a0d0e21e 1756 *SvEND(TARG) = '\0';
a0d0e21e 1757 }
dfcb284a
GS
1758 if (isutf)
1759 (void)SvPOK_only_UTF8(TARG);
1760 else
1761 (void)SvPOK_only(TARG);
b80b6069 1762
a0d0e21e 1763 PUSHTARG;
79072805 1764 }
a0d0e21e
LW
1765 RETURN;
1766}
79072805 1767
a0d0e21e
LW
1768PP(pp_subtract)
1769{
20b7effb 1770 dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
1771 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1772 svr = TOPs;
1773 svl = TOPm1s;
800401ee 1774 useleft = USE_LEFT(svl);
28e5dec8 1775#ifdef PERL_PRESERVE_IVUV
7dca457a
NC
1776 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1777 "bad things" happen if you rely on signed integers wrapping. */
01f91bf2 1778 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
1779 /* Unless the left argument is integer in range we are going to have to
1780 use NV maths. Hence only attempt to coerce the right argument if
1781 we know the left is integer. */
eb578fdb 1782 UV auv = 0;
9c5ffd7c 1783 bool auvok = FALSE;
7dca457a
NC
1784 bool a_valid = 0;
1785
28e5dec8 1786 if (!useleft) {
7dca457a
NC
1787 auv = 0;
1788 a_valid = auvok = 1;
1789 /* left operand is undef, treat as zero. */
28e5dec8
JH
1790 } else {
1791 /* Left operand is defined, so is it IV? */
01f91bf2 1792 if (SvIV_please_nomg(svl)) {
800401ee
JH
1793 if ((auvok = SvUOK(svl)))
1794 auv = SvUVX(svl);
7dca457a 1795 else {
eb578fdb 1796 const IV aiv = SvIVX(svl);
7dca457a
NC
1797 if (aiv >= 0) {
1798 auv = aiv;
1799 auvok = 1; /* Now acting as a sign flag. */
1800 } else { /* 2s complement assumption for IV_MIN */
1801 auv = (UV)-aiv;
28e5dec8 1802 }
7dca457a
NC
1803 }
1804 a_valid = 1;
1805 }
1806 }
1807 if (a_valid) {
1808 bool result_good = 0;
1809 UV result;
eb578fdb 1810 UV buv;
800401ee 1811 bool buvok = SvUOK(svr);
9041c2e3 1812
7dca457a 1813 if (buvok)
800401ee 1814 buv = SvUVX(svr);
7dca457a 1815 else {
eb578fdb 1816 const IV biv = SvIVX(svr);
7dca457a
NC
1817 if (biv >= 0) {
1818 buv = biv;
1819 buvok = 1;
1820 } else
1821 buv = (UV)-biv;
1822 }
1823 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1824 else "IV" now, independent of how it came in.
7dca457a
NC
1825 if a, b represents positive, A, B negative, a maps to -A etc
1826 a - b => (a - b)
1827 A - b => -(a + b)
1828 a - B => (a + b)
1829 A - B => -(a - b)
1830 all UV maths. negate result if A negative.
1831 subtract if signs same, add if signs differ. */
1832
1833 if (auvok ^ buvok) {
1834 /* Signs differ. */
1835 result = auv + buv;
1836 if (result >= auv)
1837 result_good = 1;
1838 } else {
1839 /* Signs same */
1840 if (auv >= buv) {
1841 result = auv - buv;
1842 /* Must get smaller */
1843 if (result <= auv)
1844 result_good = 1;
1845 } else {
1846 result = buv - auv;
1847 if (result <= buv) {
1848 /* result really should be -(auv-buv). as its negation
1849 of true value, need to swap our result flag */
1850 auvok = !auvok;
1851 result_good = 1;
28e5dec8 1852 }
28e5dec8
JH
1853 }
1854 }
7dca457a
NC
1855 if (result_good) {
1856 SP--;
1857 if (auvok)
1858 SETu( result );
1859 else {
1860 /* Negate result */
1861 if (result <= (UV)IV_MIN)
1862 SETi( -(IV)result );
1863 else {
1864 /* result valid, but out of range for IV. */
1865 SETn( -(NV)result );
1866 }
1867 }
1868 RETURN;
1869 } /* Overflow, drop through to NVs. */
28e5dec8
JH
1870 }
1871 }
1872#endif
a0d0e21e 1873 {
6f1401dc 1874 NV value = SvNV_nomg(svr);
4efa5a16
RD
1875 (void)POPs;
1876
28e5dec8
JH
1877 if (!useleft) {
1878 /* left operand is undef, treat as zero - value */
1879 SETn(-value);
1880 RETURN;
1881 }
6f1401dc 1882 SETn( SvNV_nomg(svl) - value );
28e5dec8 1883 RETURN;
79072805 1884 }
a0d0e21e 1885}
79072805 1886
a0d0e21e
LW
1887PP(pp_left_shift)
1888{
20b7effb 1889 dSP; dATARGET; SV *svl, *svr;
a42d0242 1890 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
1891 svr = POPs;
1892 svl = TOPs;
a0d0e21e 1893 {
6f1401dc 1894 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1895 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1896 const IV i = SvIV_nomg(svl);
972b05a9 1897 SETi(i << shift);
d0ba1bd2
JH
1898 }
1899 else {
6f1401dc 1900 const UV u = SvUV_nomg(svl);
972b05a9 1901 SETu(u << shift);
d0ba1bd2 1902 }
55497cff 1903 RETURN;
79072805 1904 }
a0d0e21e 1905}
79072805 1906
a0d0e21e
LW
1907PP(pp_right_shift)
1908{
20b7effb 1909 dSP; dATARGET; SV *svl, *svr;
a42d0242 1910 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
1911 svr = POPs;
1912 svl = TOPs;
a0d0e21e 1913 {
6f1401dc 1914 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1915 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1916 const IV i = SvIV_nomg(svl);
972b05a9 1917 SETi(i >> shift);
d0ba1bd2
JH
1918 }
1919 else {
6f1401dc 1920 const UV u = SvUV_nomg(svl);
972b05a9 1921 SETu(u >> shift);
d0ba1bd2 1922 }
a0d0e21e 1923 RETURN;
93a17b20 1924 }
79072805
LW
1925}
1926
a0d0e21e 1927PP(pp_lt)
79072805 1928{
20b7effb 1929 dSP;
33efebe6
DM
1930 SV *left, *right;
1931
a42d0242 1932 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
1933 right = POPs;
1934 left = TOPs;
1935 SETs(boolSV(
1936 (SvIOK_notUV(left) && SvIOK_notUV(right))
1937 ? (SvIVX(left) < SvIVX(right))
1938 : (do_ncmp(left, right) == -1)
1939 ));
1940 RETURN;
a0d0e21e 1941}
79072805 1942
a0d0e21e
LW
1943PP(pp_gt)
1944{
20b7effb 1945 dSP;
33efebe6 1946 SV *left, *right;
1b6737cc 1947
33efebe6
DM
1948 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1949 right = POPs;
1950 left = TOPs;
1951 SETs(boolSV(
1952 (SvIOK_notUV(left) && SvIOK_notUV(right))
1953 ? (SvIVX(left) > SvIVX(right))
1954 : (do_ncmp(left, right) == 1)
1955 ));
1956 RETURN;
a0d0e21e
LW
1957}
1958
1959PP(pp_le)
1960{
20b7effb 1961 dSP;
33efebe6 1962 SV *left, *right;
1b6737cc 1963
33efebe6
DM
1964 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1965 right = POPs;
1966 left = TOPs;
1967 SETs(boolSV(
1968 (SvIOK_notUV(left) && SvIOK_notUV(right))
1969 ? (SvIVX(left) <= SvIVX(right))
1970 : (do_ncmp(left, right) <= 0)
1971 ));
1972 RETURN;
a0d0e21e
LW
1973}
1974
1975PP(pp_ge)
1976{
20b7effb 1977 dSP;
33efebe6
DM
1978 SV *left, *right;
1979
1980 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1981 right = POPs;
1982 left = TOPs;
1983 SETs(boolSV(
1984 (SvIOK_notUV(left) && SvIOK_notUV(right))
1985 ? (SvIVX(left) >= SvIVX(right))
1986 : ( (do_ncmp(left, right) & 2) == 0)
1987 ));
1988 RETURN;
1989}
1b6737cc 1990
33efebe6
DM
1991PP(pp_ne)
1992{
20b7effb 1993 dSP;
33efebe6
DM
1994 SV *left, *right;
1995
1996 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1997 right = POPs;
1998 left = TOPs;
1999 SETs(boolSV(
2000 (SvIOK_notUV(left) && SvIOK_notUV(right))
2001 ? (SvIVX(left) != SvIVX(right))
2002 : (do_ncmp(left, right) != 0)
2003 ));
2004 RETURN;
2005}
1b6737cc 2006
33efebe6
DM
2007/* compare left and right SVs. Returns:
2008 * -1: <
2009 * 0: ==
2010 * 1: >
2011 * 2: left or right was a NaN
2012 */
2013I32
2014Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2015{
33efebe6
DM
2016 PERL_ARGS_ASSERT_DO_NCMP;
2017#ifdef PERL_PRESERVE_IVUV
33efebe6 2018 /* Fortunately it seems NaN isn't IOK */
01f91bf2 2019 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
33efebe6
DM
2020 if (!SvUOK(left)) {
2021 const IV leftiv = SvIVX(left);
2022 if (!SvUOK(right)) {
2023 /* ## IV <=> IV ## */
2024 const IV rightiv = SvIVX(right);
2025 return (leftiv > rightiv) - (leftiv < rightiv);
28e5dec8 2026 }
33efebe6
DM
2027 /* ## IV <=> UV ## */
2028 if (leftiv < 0)
2029 /* As (b) is a UV, it's >=0, so it must be < */
2030 return -1;
2031 {
2032 const UV rightuv = SvUVX(right);
2033 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
28e5dec8 2034 }
28e5dec8 2035 }
79072805 2036
33efebe6
DM
2037 if (SvUOK(right)) {
2038 /* ## UV <=> UV ## */
2039 const UV leftuv = SvUVX(left);
2040 const UV rightuv = SvUVX(right);
2041 return (leftuv > rightuv) - (leftuv < rightuv);
28e5dec8 2042 }
33efebe6
DM
2043 /* ## UV <=> IV ## */
2044 {
2045 const IV rightiv = SvIVX(right);
2046 if (rightiv < 0)
2047 /* As (a) is a UV, it's >=0, so it cannot be < */
2048 return 1;
2049 {
2050 const UV leftuv = SvUVX(left);
2051 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
28e5dec8 2052 }
28e5dec8 2053 }
a25b5927 2054 assert(0); /* NOTREACHED */
28e5dec8
JH
2055 }
2056#endif
a0d0e21e 2057 {
33efebe6
DM
2058 NV const rnv = SvNV_nomg(right);
2059 NV const lnv = SvNV_nomg(left);
2060
cab190d4 2061#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
33efebe6
DM
2062 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2063 return 2;
2064 }
2065 return (lnv > rnv) - (lnv < rnv);
cab190d4 2066#else
33efebe6
DM
2067 if (lnv < rnv)
2068 return -1;
2069 if (lnv > rnv)
2070 return 1;
659c4b96 2071 if (lnv == rnv)
33efebe6
DM
2072 return 0;
2073 return 2;
cab190d4 2074#endif
a0d0e21e 2075 }
79072805
LW
2076}
2077
33efebe6 2078
a0d0e21e 2079PP(pp_ncmp)
79072805 2080{
20b7effb 2081 dSP;
33efebe6
DM
2082 SV *left, *right;
2083 I32 value;
a42d0242 2084 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
33efebe6
DM
2085 right = POPs;
2086 left = TOPs;
2087 value = do_ncmp(left, right);
2088 if (value == 2) {
3280af22 2089 SETs(&PL_sv_undef);
79072805 2090 }
33efebe6
DM
2091 else {
2092 dTARGET;
2093 SETi(value);
2094 }
2095 RETURN;
a0d0e21e 2096}
79072805 2097
b1c05ba5
DM
2098
2099/* also used for: pp_sge() pp_sgt() pp_slt() */
2100
afd9910b 2101PP(pp_sle)
a0d0e21e 2102{
20b7effb 2103 dSP;
79072805 2104
afd9910b
NC
2105 int amg_type = sle_amg;
2106 int multiplier = 1;
2107 int rhs = 1;
79072805 2108
afd9910b
NC
2109 switch (PL_op->op_type) {
2110 case OP_SLT:
2111 amg_type = slt_amg;
2112 /* cmp < 0 */
2113 rhs = 0;
2114 break;
2115 case OP_SGT:
2116 amg_type = sgt_amg;
2117 /* cmp > 0 */
2118 multiplier = -1;
2119 rhs = 0;
2120 break;
2121 case OP_SGE:
2122 amg_type = sge_amg;
2123 /* cmp >= 0 */
2124 multiplier = -1;
2125 break;
79072805 2126 }
79072805 2127
6f1401dc 2128 tryAMAGICbin_MG(amg_type, AMGf_set);
a0d0e21e
LW
2129 {
2130 dPOPTOPssrl;
130c5df3 2131 const int cmp =
5778acb6 2132#ifdef USE_LOCALE_COLLATE
130c5df3
KW
2133 (IN_LC_RUNTIME(LC_COLLATE))
2134 ? sv_cmp_locale_flags(left, right, 0)
2135 :
2136#endif
2137 sv_cmp_flags(left, right, 0);
afd9910b 2138 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW
2139 RETURN;
2140 }
2141}
79072805 2142
36477c24
PP
2143PP(pp_seq)
2144{
20b7effb 2145 dSP;
6f1401dc 2146 tryAMAGICbin_MG(seq_amg, AMGf_set);
36477c24
PP
2147 {
2148 dPOPTOPssrl;
078504b2 2149 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW
2150 RETURN;
2151 }
2152}
79072805 2153
a0d0e21e 2154PP(pp_sne)
79072805 2155{
20b7effb 2156 dSP;
6f1401dc 2157 tryAMAGICbin_MG(sne_amg, AMGf_set);
a0d0e21e
LW
2158 {
2159 dPOPTOPssrl;
078504b2 2160 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2161 RETURN;
463ee0b2 2162 }
79072805
LW
2163}
2164
a0d0e21e 2165PP(pp_scmp)
79072805 2166{
20b7effb 2167 dSP; dTARGET;
6f1401dc 2168 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW
2169 {
2170 dPOPTOPssrl;
130c5df3 2171 const int cmp =
5778acb6 2172#ifdef USE_LOCALE_COLLATE
130c5df3
KW
2173 (IN_LC_RUNTIME(LC_COLLATE))
2174 ? sv_cmp_locale_flags(left, right, 0)
2175 :
2176#endif
2177 sv_cmp_flags(left, right, 0);
bbce6d69 2178 SETi( cmp );
a0d0e21e
LW
2179 RETURN;
2180 }
2181}
79072805 2182
55497cff
PP
2183PP(pp_bit_and)
2184{
20b7effb 2185 dSP; dATARGET;
6f1401dc 2186 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW
2187 {
2188 dPOPTOPssrl;
4633a7c4 2189 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2190 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2191 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2192 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2193 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2194 SETi(i);
d0ba1bd2
JH
2195 }
2196 else {
1b6737cc 2197 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2198 SETu(u);
d0ba1bd2 2199 }
5ee80e13 2200 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2201 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2202 }
2203 else {
533c011a 2204 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2205 SETTARG;
2206 }
2207 RETURN;
2208 }
2209}
79072805 2210
b1c05ba5
DM
2211
2212/* also used for: pp_bit_xor() */
2213
a0d0e21e
LW
2214PP(pp_bit_or)
2215{
20b7effb 2216 dSP; dATARGET;
3658c1f1
NC
2217 const int op_type = PL_op->op_type;
2218
6f1401dc 2219 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW
2220 {
2221 dPOPTOPssrl;
4633a7c4 2222 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2223 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2224 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2225 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC
2226 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2227 const IV r = SvIV_nomg(right);
2228 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2229 SETi(result);
d0ba1bd2
JH
2230 }
2231 else {
3658c1f1
NC
2232 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2233 const UV r = SvUV_nomg(right);
2234 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2235 SETu(result);
d0ba1bd2 2236 }
5ee80e13 2237 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2238 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2239 }
2240 else {
3658c1f1 2241 do_vop(op_type, TARG, left, right);
a0d0e21e
LW
2242 SETTARG;
2243 }
2244 RETURN;
79072805 2245 }
a0d0e21e 2246}
79072805 2247
1c2b3fd6
FC
2248PERL_STATIC_INLINE bool
2249S_negate_string(pTHX)
2250{
2251 dTARGET; dSP;
2252 STRLEN len;
2253 const char *s;
2254 SV * const sv = TOPs;
2255 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2256 return FALSE;
2257 s = SvPV_nomg_const(sv, len);
2258 if (isIDFIRST(*s)) {
2259 sv_setpvs(TARG, "-");
2260 sv_catsv(TARG, sv);
2261 }
2262 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2263 sv_setsv_nomg(TARG, sv);
2264 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2265 }
2266 else return FALSE;
2267 SETTARG; PUTBACK;
2268 return TRUE;
2269}
2270
a0d0e21e
LW
2271PP(pp_negate)
2272{
20b7effb 2273 dSP; dTARGET;
6f1401dc 2274 tryAMAGICun_MG(neg_amg, AMGf_numeric);
1c2b3fd6 2275 if (S_negate_string(aTHX)) return NORMAL;
a0d0e21e 2276 {
6f1401dc 2277 SV * const sv = TOPs;
a5b92898 2278
d96ab1b5 2279 if (SvIOK(sv)) {
7dbe3150 2280 /* It's publicly an integer */
28e5dec8 2281 oops_its_an_int:
9b0e499b
GS
2282 if (SvIsUV(sv)) {
2283 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2284 /* 2s complement assumption. */
d14578b8
KW
2285 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2286 IV_MIN */
9b0e499b
GS
2287 RETURN;
2288 }
2289 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2290 SETi(-SvIVX(sv));
9b0e499b
GS
2291 RETURN;
2292 }
2293 }
2294 else if (SvIVX(sv) != IV_MIN) {
2295 SETi(-SvIVX(sv));
2296 RETURN;
2297 }
28e5dec8
JH
2298#ifdef PERL_PRESERVE_IVUV
2299 else {
2300 SETu((UV)IV_MIN);
2301 RETURN;
2302 }
2303#endif
9b0e499b 2304 }
8a5decd8 2305 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
6f1401dc 2306 SETn(-SvNV_nomg(sv));
1c2b3fd6 2307 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
8eb28a70 2308 goto oops_its_an_int;
4633a7c4 2309 else
6f1401dc 2310 SETn(-SvNV_nomg(sv));
79072805 2311 }
a0d0e21e 2312 RETURN;
79072805
LW
2313}
2314
a0d0e21e 2315PP(pp_not)
79072805 2316{
20b7effb 2317 dSP;
6f1401dc 2318 tryAMAGICun_MG(not_amg, AMGf_set);
06c841cf 2319 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
a0d0e21e 2320 return NORMAL;
79072805
LW
2321}
2322
a0d0e21e 2323PP(pp_complement)
79072805 2324{
20b7effb 2325 dSP; dTARGET;
a42d0242 2326 tryAMAGICun_MG(compl_amg, AMGf_numeric);
a0d0e21e
LW
2327 {
2328 dTOPss;
4633a7c4 2329 if (SvNIOKp(sv)) {
d0ba1bd2 2330 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2331 const IV i = ~SvIV_nomg(sv);
972b05a9 2332 SETi(i);
d0ba1bd2
JH
2333 }
2334 else {
1b6737cc 2335 const UV u = ~SvUV_nomg(sv);
972b05a9 2336 SETu(u);
d0ba1bd2 2337 }
a0d0e21e
LW
2338 }
2339 else {
eb578fdb
KW
2340 U8 *tmps;
2341 I32 anum;
a0d0e21e
LW
2342 STRLEN len;
2343
85b0ee6e
FC
2344 sv_copypv_nomg(TARG, sv);
2345 tmps = (U8*)SvPV_nomg(TARG, len);
a0d0e21e 2346 anum = len;
1d68d6cd 2347 if (SvUTF8(TARG)) {
a1ca4561 2348 /* Calculate exact length, let's not estimate. */
1d68d6cd 2349 STRLEN targlen = 0;
ba210ebe 2350 STRLEN l;
a1ca4561
YST
2351 UV nchar = 0;
2352 UV nwide = 0;
01f6e806 2353 U8 * const send = tmps + len;
74d49cd0
ST
2354 U8 * const origtmps = tmps;
2355 const UV utf8flags = UTF8_ALLOW_ANYUV;
1d68d6cd 2356
1d68d6cd 2357 while (tmps < send) {
74d49cd0
ST
2358 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2359 tmps += l;
5bbb0b5a 2360 targlen += UNISKIP(~c);
a1ca4561
YST
2361 nchar++;
2362 if (c > 0xff)
2363 nwide++;
1d68d6cd
SC
2364 }
2365
2366 /* Now rewind strings and write them. */
74d49cd0 2367 tmps = origtmps;
a1ca4561
YST
2368
2369 if (nwide) {
01f6e806
AL
2370 U8 *result;
2371 U8 *p;
2372
74d49cd0 2373 Newx(result, targlen + 1, U8);
01f6e806 2374 p = result;
a1ca4561 2375 while (tmps < send) {
74d49cd0
ST
2376 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2377 tmps += l;
01f6e806 2378 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
a1ca4561 2379 }
01f6e806 2380 *p = '\0';
c1c21316
NC
2381 sv_usepvn_flags(TARG, (char*)result, targlen,
2382 SV_HAS_TRAILING_NUL);
a1ca4561
YST
2383 SvUTF8_on(TARG);
2384 }
2385 else {
01f6e806
AL
2386 U8 *result;
2387 U8 *p;
2388
74d49cd0 2389 Newx(result, nchar + 1, U8);
01f6e806 2390 p = result;
a1ca4561 2391 while (tmps < send) {
74d49cd0
ST
2392 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2393 tmps += l;
01f6e806 2394 *p++ = ~c;
a1ca4561 2395 }
01f6e806 2396 *p = '\0';
c1c21316 2397 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
d0a21e00 2398 SvUTF8_off(TARG);
1d68d6cd 2399 }
ec93b65f 2400 SETTARG;
1d68d6cd
SC
2401 RETURN;
2402 }
a0d0e21e 2403#ifdef LIBERAL
51723571 2404 {
eb578fdb 2405 long *tmpl;
51723571
JH
2406 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2407 *tmps = ~*tmps;
2408 tmpl = (long*)tmps;
bb7a0f54 2409 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH
2410 *tmpl = ~*tmpl;
2411 tmps = (U8*)tmpl;
2412 }
a0d0e21e
LW
2413#endif
2414 for ( ; anum > 0; anum--, tmps++)
2415 *tmps = ~*tmps;
ec93b65f 2416 SETTARG;
a0d0e21e
LW
2417 }
2418 RETURN;
2419 }
79072805
LW
2420}
2421
a0d0e21e
LW
2422/* integer versions of some of the above */
2423
a0d0e21e 2424PP(pp_i_multiply)
79072805 2425{
20b7effb 2426 dSP; dATARGET;
6f1401dc 2427 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2428 {
6f1401dc 2429 dPOPTOPiirl_nomg;
a0d0e21e
LW
2430 SETi( left * right );
2431 RETURN;
2432 }
79072805
LW
2433}
2434
a0d0e21e 2435PP(pp_i_divide)
79072805 2436{
85935d8e 2437 IV num;
20b7effb 2438 dSP; dATARGET;
6f1401dc 2439 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2440 {
6f1401dc 2441 dPOPTOPssrl;
85935d8e 2442 IV value = SvIV_nomg(right);
a0d0e21e 2443 if (value == 0)
ece1bcef 2444 DIE(aTHX_ "Illegal division by zero");
85935d8e 2445 num = SvIV_nomg(left);
a0cec769
YST
2446
2447 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2448 if (value == -1)
2449 value = - num;
2450 else
2451 value = num / value;
6f1401dc 2452 SETi(value);
a0d0e21e
LW
2453 RETURN;
2454 }
79072805
LW
2455}
2456
a5bd31f4 2457#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
224ec323
JH
2458STATIC
2459PP(pp_i_modulo_0)
befad5d1
NC
2460#else
2461PP(pp_i_modulo)
2462#endif
224ec323
JH
2463{
2464 /* This is the vanilla old i_modulo. */
20b7effb 2465 dSP; dATARGET;
6f1401dc 2466 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2467 {
6f1401dc 2468 dPOPTOPiirl_nomg;
224ec323
JH
2469 if (!right)
2470 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2471 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2472 if (right == -1)
2473 SETi( 0 );
2474 else
2475 SETi( left % right );
224ec323
JH
2476 RETURN;
2477 }
2478}
2479
a5bd31f4 2480#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
224ec323
JH
2481STATIC
2482PP(pp_i_modulo_1)
befad5d1 2483
224ec323 2484{
224ec323 2485 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2486 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2487 * See below for pp_i_modulo. */
20b7effb 2488 dSP; dATARGET;
6f1401dc 2489 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2490 {
6f1401dc 2491 dPOPTOPiirl_nomg;
224ec323
JH
2492 if (!right)
2493 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2494 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2495 if (right == -1)
2496 SETi( 0 );
2497 else
2498 SETi( left % PERL_ABS(right) );
224ec323
JH
2499 RETURN;
2500 }
224ec323
JH
2501}
2502
a0d0e21e 2503PP(pp_i_modulo)
79072805 2504{
6f1401dc
DM
2505 dVAR; dSP; dATARGET;
2506 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2507 {
6f1401dc 2508 dPOPTOPiirl_nomg;
224ec323
JH
2509 if (!right)
2510 DIE(aTHX_ "Illegal modulus zero");
2511 /* The assumption is to use hereafter the old vanilla version... */
2512 PL_op->op_ppaddr =
2513 PL_ppaddr[OP_I_MODULO] =
1c127fab 2514 Perl_pp_i_modulo_0;
224ec323
JH
2515 /* .. but if we have glibc, we might have a buggy _moddi3
2516 * (at least glicb 2.2.5 is known to have this bug), in other
2517 * words our integer modulus with negative quad as the second
2518 * argument might be broken. Test for this and re-patch the
2519 * opcode dispatch table if that is the case, remembering to
2520 * also apply the workaround so that this first round works
2521 * right, too. See [perl #9402] for more information. */
224ec323
JH
2522 {
2523 IV l = 3;
2524 IV r = -10;
2525 /* Cannot do this check with inlined IV constants since
2526 * that seems to work correctly even with the buggy glibc. */
2527 if (l % r == -3) {
2528 /* Yikes, we have the bug.
2529 * Patch in the workaround version. */
2530 PL_op->op_ppaddr =
2531 PL_ppaddr[OP_I_MODULO] =
2532 &Perl_pp_i_modulo_1;
2533 /* Make certain we work right this time, too. */
32fdb065 2534 right = PERL_ABS(right);
224ec323
JH
2535 }
2536 }
a0cec769
YST
2537 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2538 if (right == -1)
2539 SETi( 0 );
2540 else
2541 SETi( left % right );
224ec323
JH
2542 RETURN;
2543 }
79072805 2544}
befad5d1 2545#endif
79072805 2546
a0d0e21e 2547PP(pp_i_add)
79072805 2548{
20b7effb 2549 dSP; dATARGET;
6f1401dc 2550 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2551 {
6f1401dc 2552 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2553 SETi( left + right );
2554 RETURN;
79072805 2555 }
79072805
LW
2556}
2557
a0d0e21e 2558PP(pp_i_subtract)
79072805 2559{
20b7effb 2560 dSP; dATARGET;
6f1401dc 2561 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2562 {
6f1401dc 2563 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2564 SETi( left - right );
2565 RETURN;
79072805 2566 }
79072805
LW
2567}
2568
a0d0e21e 2569PP(pp_i_lt)
79072805 2570{
20b7effb 2571 dSP;
6f1401dc 2572 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2573 {
96b6b87f 2574 dPOPTOPiirl_nomg;
54310121 2575 SETs(boolSV(left < right));
a0d0e21e
LW
2576 RETURN;
2577 }
79072805
LW
2578}
2579
a0d0e21e 2580PP(pp_i_gt)
79072805 2581{
20b7effb 2582 dSP;
6f1401dc 2583 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2584 {
96b6b87f 2585 dPOPTOPiirl_nomg;
54310121 2586 SETs(boolSV(left > right));
a0d0e21e
LW
2587 RETURN;
2588 }
79072805
LW
2589}
2590
a0d0e21e 2591PP(pp_i_le)
79072805 2592{
20b7effb 2593 dSP;
6f1401dc 2594 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 2595 {
96b6b87f 2596 dPOPTOPiirl_nomg;
54310121 2597 SETs(boolSV(left <= right));
a0d0e21e 2598 RETURN;
85e6fe83 2599 }
79072805
LW
2600}
2601
a0d0e21e 2602PP(pp_i_ge)
79072805 2603{
20b7effb 2604 dSP;
6f1401dc 2605 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 2606 {
96b6b87f 2607 dPOPTOPiirl_nomg;
54310121 2608 SETs(boolSV(left >= right));
a0d0e21e
LW
2609 RETURN;
2610 }
79072805
LW
2611}
2612
a0d0e21e 2613PP(pp_i_eq)
79072805 2614{
20b7effb 2615 dSP;
6f1401dc 2616 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 2617 {
96b6b87f 2618 dPOPTOPiirl_nomg;
54310121 2619 SETs(boolSV(left == right));
a0d0e21e
LW
2620 RETURN;
2621 }
79072805
LW
2622}
2623
a0d0e21e 2624PP(pp_i_ne)
79072805 2625{
20b7effb 2626 dSP;
6f1401dc 2627 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 2628 {
96b6b87f 2629 dPOPTOPiirl_nomg;
54310121 2630 SETs(boolSV(left != right));
a0d0e21e
LW
2631 RETURN;
2632 }
79072805
LW
2633}
2634
a0d0e21e 2635PP(pp_i_ncmp)
79072805 2636{
20b7effb 2637 dSP; dTARGET;
6f1401dc 2638 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2639 {
96b6b87f 2640 dPOPTOPiirl_nomg;
a0d0e21e 2641 I32 value;
79072805 2642
a0d0e21e 2643 if (left > right)
79072805 2644 value = 1;
a0d0e21e 2645 else if (left < right)
79072805 2646 value = -1;
a0d0e21e 2647 else
79072805 2648 value = 0;
a0d0e21e
LW
2649 SETi(value);
2650 RETURN;
79072805 2651 }
85e6fe83
LW
2652}
2653
2654PP(pp_i_negate)
2655{
20b7effb 2656 dSP; dTARGET;
6f1401dc 2657 tryAMAGICun_MG(neg_amg, 0);
1c2b3fd6 2658 if (S_negate_string(aTHX)) return NORMAL;
6f1401dc
DM
2659 {
2660 SV * const sv = TOPs;
2661 IV const i = SvIV_nomg(sv);
2662 SETi(-i);
2663 RETURN;
2664 }
85e6fe83
LW
2665}
2666
79072805
LW
2667/* High falutin' math. */
2668
2669PP(pp_atan2)
2670{
20b7effb 2671 dSP; dTARGET;
6f1401dc 2672 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2673 {
096c060c 2674 dPOPTOPnnrl_nomg;
a1021d57 2675 SETn(Perl_atan2(left, right));
a0d0e21e
LW
2676 RETURN;
2677 }
79072805
LW
2678}
2679
b1c05ba5
DM
2680
2681/* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2682
79072805
LW
2683PP(pp_sin)
2684{
20b7effb 2685 dSP; dTARGET;
af71714e 2686 int amg_type = fallback_amg;
71302fe3 2687 const char *neg_report = NULL;
71302fe3
NC
2688 const int op_type = PL_op->op_type;
2689
2690 switch (op_type) {
af71714e
JH
2691 case OP_SIN: amg_type = sin_amg; break;
2692 case OP_COS: amg_type = cos_amg; break;
2693 case OP_EXP: amg_type = exp_amg; break;
2694 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2695 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
a0d0e21e 2696 }
79072805 2697
af71714e 2698 assert(amg_type != fallback_amg);
6f1401dc
DM
2699
2700 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 2701 {
6f1401dc
DM
2702 SV * const arg = POPs;
2703 const NV value = SvNV_nomg(arg);
f256868e 2704 NV result = NV_NAN;
af71714e 2705 if (neg_report) { /* log or sqrt */
a3463d96
DD
2706 if (
2707#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2708 ! Perl_isnan(value) &&
2709#endif
2710 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
71302fe3 2711 SET_NUMERIC_STANDARD();
dcbac5bb 2712 /* diag_listed_as: Can't take log of %g */
71302fe3
NC
2713 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2714 }
2715 }
af71714e 2716 switch (op_type) {
f256868e 2717 default:
af71714e
JH
2718 case OP_SIN: result = Perl_sin(value); break;
2719 case OP_COS: result = Perl_cos(value); break;
2720 case OP_EXP: result = Perl_exp(value); break;
2721 case OP_LOG: result = Perl_log(value); break;
2722 case OP_SQRT: result = Perl_sqrt(value); break;
2723 }
2724 XPUSHn(result);
a0d0e21e
LW
2725 RETURN;
2726 }
79072805
LW
2727}
2728
56cb0a1c
AD
2729/* Support Configure command-line overrides for rand() functions.
2730 After 5.005, perhaps we should replace this by Configure support
2731 for drand48(), random(), or rand(). For 5.005, though, maintain
2732 compatibility by calling rand() but allow the user to override it.
2733 See INSTALL for details. --Andy Dougherty 15 July 1998
2734*/
85ab1d1d
JH
2735/* Now it's after 5.005, and Configure supports drand48() and random(),
2736 in addition to rand(). So the overrides should not be needed any more.
2737 --Jarkko Hietaniemi 27 September 1998
2738 */
2739
79072805
LW
2740PP(pp_rand)
2741{
80252599 2742 if (!PL_srand_called) {
85ab1d1d 2743 (void)seedDrand01((Rand_seed_t)seed());
80252599 2744 PL_srand_called = TRUE;
93dc8474 2745 }
fdf4dddd
DD
2746 {
2747 dSP;
2748 NV value;
2749 EXTEND(SP, 1);
2750
2751 if (MAXARG < 1)
2752 value = 1.0;
2753 else {
2754 SV * const sv = POPs;
2755 if(!sv)
2756 value = 1.0;
2757 else
2758 value = SvNV(sv);
2759 }
2760 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
a3463d96
DD
2761#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2762 if (! Perl_isnan(value) && value == 0.0)
2763#else
659c4b96 2764 if (value == 0.0)
a3463d96 2765#endif
fdf4dddd
DD
2766 value = 1.0;
2767 {
2768 dTARGET;
2769 PUSHs(TARG);
2770 PUTBACK;
2771 value *= Drand01();
2772 sv_setnv_mg(TARG, value);
2773 }
2774 }
2775 return NORMAL;
79072805
LW
2776}
2777
2778PP(pp_srand)
2779{
20b7effb 2780 dSP; dTARGET;
f914a682
JL
2781 UV anum;
2782
0a5f3363 2783 if (MAXARG >= 1 && (TOPs || POPs)) {
f914a682
JL
2784 SV *top;
2785 char *pv;
2786 STRLEN len;
2787 int flags;
2788
2789 top = POPs;
2790 pv = SvPV(top, len);
2791 flags = grok_number(pv, len, &anum);
2792
2793 if (!(flags & IS_NUMBER_IN_UV)) {
2794 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2795 "Integer overflow in srand");
2796 anum = UV_MAX;
2797 }
2798 }
2799 else {
2800 anum = seed();
2801 }
2802
85ab1d1d 2803 (void)seedDrand01((Rand_seed_t)anum);
80252599 2804 PL_srand_called = TRUE;
da1010ec
NC
2805 if (anum)
2806 XPUSHu(anum);
2807 else {
2808 /* Historically srand always returned true. We can avoid breaking
2809 that like this: */
2810 sv_setpvs(TARG, "0 but true");
2811 XPUSHTARG;
2812 }
83832992 2813 RETURN;
79072805
LW
2814}
2815
79072805
LW
2816PP(pp_int)
2817{
20b7effb 2818 dSP; dTARGET;
6f1401dc 2819 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 2820 {
6f1401dc
DM
2821 SV * const sv = TOPs;
2822 const IV iv = SvIV_nomg(sv);
28e5dec8
JH
2823 /* XXX it's arguable that compiler casting to IV might be subtly
2824 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2825 else preferring IV has introduced a subtle behaviour change bug. OTOH
2826 relying on floating point to be accurate is a bug. */
2827
c781a409 2828 if (!SvOK(sv)) {
922c4365 2829 SETu(0);
c781a409
RD
2830 }
2831 else if (SvIOK(sv)) {
2832 if (SvIsUV(sv))
6f1401dc 2833 SETu(SvUV_nomg(sv));
c781a409 2834 else
28e5dec8 2835 SETi(iv);
c781a409 2836 }
c781a409 2837 else {
6f1401dc 2838 const NV value = SvNV_nomg(sv);
a83034fc 2839 if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNV(sv))))
5bf8b78e
JH
2840 SETn(SvNV(sv));
2841 else if (value >= 0.0) {
28e5dec8
JH
2842 if (value < (NV)UV_MAX + 0.5) {
2843 SETu(U_V(value));
2844 } else {
059a1014 2845 SETn(Perl_floor(value));
28e5dec8 2846 }
1048ea30 2847 }
28e5dec8
JH
2848 else {
2849 if (value > (NV)IV_MIN - 0.5) {
2850 SETi(I_V(value));
2851 } else {
1bbae031 2852 SETn(Perl_ceil(value));
28e5dec8
JH
2853 }
2854 }
774d564b 2855 }
79072805 2856 }
79072805
LW
2857 RETURN;
2858}
2859
463ee0b2
LW
2860PP(pp_abs)
2861{
20b7effb 2862 dSP; dTARGET;
6f1401dc 2863 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 2864 {
6f1401dc 2865 SV * const sv = TOPs;
28e5dec8 2866 /* This will cache the NV value if string isn't actually integer */
6f1401dc 2867 const IV iv = SvIV_nomg(sv);
a227d84d 2868
800401ee 2869 if (!SvOK(sv)) {
922c4365 2870 SETu(0);
800401ee
JH
2871 }
2872 else if (SvIOK(sv)) {
28e5dec8 2873 /* IVX is precise */
800401ee 2874 if (SvIsUV(sv)) {
6f1401dc 2875 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH
2876 } else {
2877 if (iv >= 0) {
2878 SETi(iv);
2879 } else {
2880 if (iv != IV_MIN) {
2881 SETi(-iv);
2882 } else {
2883 /* 2s complement assumption. Also, not really needed as
2884 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2885 SETu(IV_MIN);
2886 }
a227d84d 2887 }
28e5dec8
JH
2888 }
2889 } else{
6f1401dc 2890 const NV value = SvNV_nomg(sv);
774d564b 2891 if (value < 0.0)
1b6737cc 2892 SETn(-value);
a4474c9e
DD
2893 else
2894 SETn(value);
774d564b 2895 }
a0d0e21e 2896 }
774d564b 2897 RETURN;
463ee0b2
LW
2898}
2899
b1c05ba5
DM
2900
2901/* also used for: pp_hex() */
2902
79072805
LW
2903PP(pp_oct)
2904{
20b7effb 2905 dSP; dTARGET;
5c144d81 2906 const char *tmps;
53305cf1 2907 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2908 STRLEN len;
53305cf1
NC
2909 NV result_nv;
2910 UV result_uv;
1b6737cc 2911 SV* const sv = POPs;
79072805 2912
349d4f2f 2913 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS
2914 if (DO_UTF8(sv)) {
2915 /* If Unicode, try to downgrade
2916 * If not possible, croak. */
1b6737cc 2917 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS
2918
2919 SvUTF8_on(tsv);
2920 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2921 tmps = SvPV_const(tsv, len);
2bc69dc4 2922 }
daa2adfd
NC
2923 if (PL_op->op_type == OP_HEX)
2924 goto hex;
2925
6f894ead 2926 while (*tmps && len && isSPACE(*tmps))
53305cf1 2927 tmps++, len--;
9e24b6e2 2928 if (*tmps == '0')
53305cf1 2929 tmps++, len--;
305b8651 2930 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
daa2adfd 2931 hex:
53305cf1 2932 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 2933 }
305b8651 2934 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
53305cf1 2935 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2936 else
53305cf1
NC
2937 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2938
2939 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2940 XPUSHn(result_nv);
2941 }
2942 else {
2943 XPUSHu(result_uv);
2944 }
79072805
LW
2945 RETURN;
2946}
2947
2948/* String stuff. */
2949
2950PP(pp_length)
2951{
20b7effb 2952 dSP; dTARGET;
0bd48802 2953 SV * const sv = TOPs;
a0ed51b3 2954
7776003e
DD
2955 U32 in_bytes = IN_BYTES;
2956 /* simplest case shortcut */
2957 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
2958 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
2959 assert(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
2960 SETs(TARG);
2961
2962 if(LIKELY(svflags == SVf_POK))
2963 goto simple_pv;
2964 if(svflags & SVs_GMG)
2965 mg_get(sv);
0f43fd57 2966 if (SvOK(sv)) {
7776003e
DD
2967 if (!IN_BYTES) /* reread to avoid using an C auto/register */
2968 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
9f621bb0 2969 else
0f43fd57
FC
2970 {
2971 STRLEN len;
7776003e
DD
2972 /* unrolled SvPV_nomg_const(sv,len) */
2973 if(SvPOK_nog(sv)){
2974 simple_pv:
2975 len = SvCUR(sv);
2976 } else {
2977 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
2978 }
2979 sv_setiv(TARG, (IV)(len));
0f43fd57 2980 }
656266fc 2981 } else {
9407f9c1
DL
2982 if (!SvPADTMP(TARG)) {
2983 sv_setsv_nomg(TARG, &PL_sv_undef);
7776003e
DD
2984 } else { /* TARG is on stack at this point and is overwriten by SETs.
2985 This branch is the odd one out, so put TARG by default on
2986 stack earlier to let local SP go out of liveness sooner */
2987 SETs(&PL_sv_undef);
2988 goto no_set_magic;
2989 }
92331800 2990 }
7776003e
DD
2991 SvSETMAGIC(TARG);
2992 no_set_magic:
2993 return NORMAL; /* no putback, SP didn't move in this opcode */
79072805
LW
2994}
2995
83f78d1a
FC
2996/* Returns false if substring is completely outside original string.
2997 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2998 always be true for an explicit 0.
2999*/
3000bool
ddeaf645
DD
3001Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3002 bool pos1_is_uv, IV len_iv,
3003 bool len_is_uv, STRLEN *posp,
3004 STRLEN *lenp)
83f78d1a
FC
3005{
3006 IV pos2_iv;
3007 int pos2_is_uv;
3008
3009 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3010
3011 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3012 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3013 pos1_iv += curlen;
3014 }
3015 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3016 return FALSE;
3017
3018 if (len_iv || len_is_uv) {
3019 if (!len_is_uv && len_iv < 0) {
3020 pos2_iv = curlen + len_iv;
3021 if (curlen)
3022 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3023 else
3024 pos2_is_uv = 0;
3025 } else { /* len_iv >= 0 */
3026 if (!pos1_is_uv && pos1_iv < 0) {
3027 pos2_iv = pos1_iv + len_iv;
3028 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3029 } else {
3030 if ((UV)len_iv > curlen-(UV)pos1_iv)
3031 pos2_iv = curlen;
3032 else
3033 pos2_iv = pos1_iv+len_iv;
3034 pos2_is_uv = 1;
3035 }
3036 }
3037 }
3038 else {
3039 pos2_iv = curlen;
3040 pos2_is_uv = 1;
3041 }
3042
3043 if (!pos2_is_uv && pos2_iv < 0) {
3044 if (!pos1_is_uv && pos1_iv < 0)
3045 return FALSE;
3046 pos2_iv = 0;
3047 }
3048 else if (!pos1_is_uv && pos1_iv < 0)
3049 pos1_iv = 0;
3050
3051 if ((UV)pos2_iv < (UV)pos1_iv)
3052 pos2_iv = pos1_iv;
3053 if ((UV)pos2_iv > curlen)
3054 pos2_iv = curlen;
3055
3056 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3057 *posp = (STRLEN)( (UV)pos1_iv );
3058 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3059
3060 return TRUE;
3061}
3062
79072805
LW
3063PP(pp_substr)
3064{
20b7effb 3065 dSP; dTARGET;
79072805 3066 SV *sv;
463ee0b2 3067 STRLEN curlen;
9402d6ed 3068 STRLEN utf8_curlen;
777f7c56
EB
3069 SV * pos_sv;
3070 IV pos1_iv;
3071 int pos1_is_uv;
777f7c56
EB
3072 SV * len_sv;
3073 IV len_iv = 0;
83f78d1a 3074 int len_is_uv = 0;
24fcb59f 3075 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 3076 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 3077 const char *tmps;
9402d6ed 3078 SV *repl_sv = NULL;
cbbf8932 3079 const char *repl = NULL;
7b8d334a 3080 STRLEN repl_len;
7bc95ae1 3081 int num_args = PL_op->op_private & 7;
13e30c65 3082 bool repl_need_utf8_upgrade = FALSE;
79072805 3083
78f9721b
SM
3084 if (num_args > 2) {
3085 if (num_args > 3) {
24fcb59f 3086 if(!(repl_sv = POPs)) num_args--;
7bc95ae1
FC
3087 }
3088 if ((len_sv = POPs)) {
3089 len_iv = SvIV(len_sv);
83f78d1a 3090 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
7b8d334a 3091 }
7bc95ae1 3092 else num_args--;
5d82c453 3093 }
777f7c56
EB
3094 pos_sv = POPs;
3095 pos1_iv = SvIV(pos_sv);
3096 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3097 sv = POPs;
24fcb59f
FC
3098 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3099 assert(!repl_sv);
3100 repl_sv = POPs;
3101 }
849ca7ee 3102 PUTBACK;
6582db62 3103 if (lvalue && !repl_sv) {
83f78d1a
FC
3104 SV * ret;
3105 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3106 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3107 LvTYPE(ret) = 'x';
3108 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3109 LvTARGOFF(ret) =
3110 pos1_is_uv || pos1_iv >= 0
3111 ? (STRLEN)(UV)pos1_iv
3112 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3113 LvTARGLEN(ret) =
3114 len_is_uv || len_iv > 0
3115 ? (STRLEN)(UV)len_iv
3116 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3117
3118 SPAGAIN;
3119 PUSHs(ret); /* avoid SvSETMAGIC here */
3120 RETURN;
a74fb2cd 3121 }
6582db62
FC
3122 if (repl_sv) {
3123 repl = SvPV_const(repl_sv, repl_len);
3124 SvGETMAGIC(sv);
3125 if (SvROK(sv))
3126 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3127 "Attempt to use reference as lvalue in substr"
3128 );
3129 tmps = SvPV_force_nomg(sv, curlen);
3130 if (DO_UTF8(repl_sv) && repl_len) {
3131 if (!DO_UTF8(sv)) {
01680ee9 3132 sv_utf8_upgrade_nomg(sv);
6582db62
FC
3133 curlen = SvCUR(sv);
3134 }
3135 }
3136 else if (DO_UTF8(sv))
3137 repl_need_utf8_upgrade = TRUE;
3138 }
3139 else tmps = SvPV_const(sv, curlen);
7e2040f0 3140 if (DO_UTF8(sv)) {
0d788f38 3141 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
9402d6ed
JH
3142 if (utf8_curlen == curlen)
3143 utf8_curlen = 0;
a0ed51b3 3144 else
9402d6ed 3145 curlen = utf8_curlen;
a0ed51b3 3146 }
d1c2b58a 3147 else
9402d6ed 3148 utf8_curlen = 0;
a0ed51b3 3149
83f78d1a
FC
3150 {
3151 STRLEN pos, len, byte_len, byte_pos;
777f7c56 3152
83f78d1a
FC
3153 if (!translate_substr_offsets(
3154 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3155 )) goto bound_fail;
777f7c56 3156
83f78d1a
FC
3157 byte_len = len;
3158 byte_pos = utf8_curlen
0d788f38 3159 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
d931b1be 3160
2154eca7 3161 tmps += byte_pos;
bbddc9e0
CS
3162
3163 if (rvalue) {
3164 SvTAINTED_off(TARG); /* decontaminate */
3165 SvUTF8_off(TARG); /* decontaminate */
3166 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3167#ifdef USE_LOCALE_COLLATE
bbddc9e0 3168 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3169#endif
bbddc9e0
CS
3170 if (utf8_curlen)
3171 SvUTF8_on(TARG);
3172 }
2154eca7 3173
f7928d6c 3174 if (repl) {
13e30c65
JH
3175 SV* repl_sv_copy = NULL;
3176
3177 if (repl_need_utf8_upgrade) {
3178 repl_sv_copy = newSVsv(repl_sv);
3179 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3180 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65 3181 }
502d9230
VP
3182 if (!SvOK(sv))
3183 sv_setpvs(sv, "");
777f7c56 3184 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
ef8d46e8 3185 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3186 }
79072805 3187 }
849ca7ee 3188 SPAGAIN;
6a9665b0
FC
3189 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3190 SP++;
3191 else if (rvalue) {
bbddc9e0
CS
3192 SvSETMAGIC(TARG);
3193 PUSHs(TARG);
3194 }
79072805 3195 RETURN;
777f7c56 3196
1c900557 3197bound_fail:
83f78d1a 3198 if (repl)
777f7c56
EB
3199 Perl_croak(aTHX_ "substr outside of string");
3200 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3201 RETPUSHUNDEF;
79072805
LW
3202}
3203
3204PP(pp_vec)
3205{
20b7effb 3206 dSP;
eb578fdb
KW
3207 const IV size = POPi;
3208 const IV offset = POPi;
3209 SV * const src = POPs;
1b6737cc 3210 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3211 SV * ret;
a0d0e21e 3212
81e118e0 3213 if (lvalue) { /* it's an lvalue! */
2154eca7
EB
3214 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3215 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3216 LvTYPE(ret) = 'v';
3217 LvTARG(ret) = SvREFCNT_inc_simple(src);
3218 LvTARGOFF(ret) = offset;
3219 LvTARGLEN(ret) = size;
3220 }
3221 else {
3222 dTARGET;
3223 SvTAINTED_off(TARG); /* decontaminate */
3224 ret = TARG;
79072805
LW
3225 }
3226
2154eca7
EB
3227 sv_setuv(ret, do_vecget(src, offset, size));
3228 PUSHs(ret);
79072805
LW
3229 RETURN;
3230}
3231
b1c05ba5
DM
3232
3233/* also used for: pp_rindex() */
3234
79072805
LW
3235PP(pp_index)
3236{
20b7effb 3237 dSP; dTARGET;
79072805
LW
3238 SV *big;
3239 SV *little;
c445ea15 3240 SV *temp = NULL;
ad66a58c 3241 STRLEN biglen;
2723d216 3242 STRLEN llen = 0;
b464e2b7
TC
3243 SSize_t offset = 0;
3244 SSize_t retval;
73ee8be2
NC
3245 const char *big_p;
3246 const char *little_p;
2f040f7f
NC
3247 bool big_utf8;
3248 bool little_utf8;
2723d216 3249 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3250 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3251
e1dccc0d
Z
3252 if (threeargs)
3253 offset = POPi;
79072805
LW
3254 little = POPs;
3255 big = POPs;
73ee8be2
NC
3256 big_p = SvPV_const(big, biglen);
3257 little_p = SvPV_const(little, llen);
3258
e609e586
NC
3259 big_utf8 = DO_UTF8(big);
3260 little_utf8 = DO_UTF8(little);
3261 if (big_utf8 ^ little_utf8) {
3262 /* One needs to be upgraded. */
2f040f7f
NC
3263 if (little_utf8 && !PL_encoding) {
3264 /* Well, maybe instead we might be able to downgrade the small
3265 string? */
1eced8f8 3266 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC
3267 &little_utf8);
3268 if (little_utf8) {
3269 /* If the large string is ISO-8859-1, and it's not possible to
3270 convert the small string to ISO-8859-1, then there is no
3271 way that it could be found anywhere by index. */
3272 retval = -1;
3273 goto fail;
3274 }
e609e586 3275
2f040f7f
NC
3276 /* At this point, pv is a malloc()ed string. So donate it to temp
3277 to ensure it will get free()d */
3278 little = temp = newSV(0);
73ee8be2
NC
3279 sv_usepvn(temp, pv, llen);
3280 little_p = SvPVX(little);
e609e586 3281 } else {
73ee8be2
NC
3282 temp = little_utf8
3283 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f
NC
3284
3285 if (PL_encoding) {
3286 sv_recode_to_utf8(temp, PL_encoding);
3287 } else {
3288 sv_utf8_upgrade(temp);
3289 }
3290 if (little_utf8) {
3291 big = temp;
3292 big_utf8 = TRUE;
73ee8be2 3293 big_p = SvPV_const(big, biglen);
2f040f7f
NC
3294 } else {
3295 little = temp;
73ee8be2 3296 little_p = SvPV_const(little, llen);
2f040f7f 3297 }
e609e586
NC
3298 }
3299 }
73ee8be2
NC
3300 if (SvGAMAGIC(big)) {
3301 /* Life just becomes a lot easier if I use a temporary here.
3302 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3303 will trigger magic and overloading again, as will fbm_instr()
3304 */
59cd0e26
NC
3305 big = newSVpvn_flags(big_p, biglen,
3306 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3307 big_p = SvPVX(big);
3308 }
e4e44778 3309 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC
3310 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3311 warn on undef, and we've already triggered a warning with the
3312 SvPV_const some lines above. We can't remove that, as we need to
3313 call some SvPV to trigger overloading early and find out if the
3314 string is UTF-8.
3315 This is all getting to messy. The API isn't quite clean enough,
3316 because data access has side effects.
3317 */
59cd0e26
NC
3318 little = newSVpvn_flags(little_p, llen,
3319 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3320 little_p = SvPVX(little);
3321 }
e609e586 3322
d3e26383 3323 if (!threeargs)
2723d216 3324 offset = is_index ? 0 : biglen;
a0ed51b3 3325 else {
ad66a58c 3326 if (big_utf8 && offset > 0)
b464e2b7 3327 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
73ee8be2
NC
3328 if (!is_index)
3329 offset += llen;
a0ed51b3 3330 }
79072805
LW
3331 if (offset < 0)
3332 offset = 0;
b464e2b7 3333 else if (offset > (SSize_t)biglen)
ad66a58c 3334 offset = biglen;
73ee8be2
NC
3335 if (!(little_p = is_index
3336 ? fbm_instr((unsigned char*)big_p + offset,
3337 (unsigned char*)big_p + biglen, little, 0)
3338 : rninstr(big_p, big_p + offset,
3339 little_p, little_p + llen)))
a0ed51b3 3340 retval = -1;
ad66a58c 3341 else {
73ee8be2 3342 retval = little_p - big_p;
ad66a58c 3343 if (retval > 0 && big_utf8)
b464e2b7 3344 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
ad66a58c 3345 }
ef8d46e8 3346 SvREFCNT_dec(temp);
2723d216 3347 fail:
e1dccc0d 3348 PUSHi(retval);
79072805
LW
3349 RETURN;
3350}
3351
3352PP(pp_sprintf)
3353{
20b7effb 3354 dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3355 SvTAINTED_off(TARG);
79072805 3356 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3357 TAINT_IF(SvTAINTED(TARG));
79072805
LW
3358 SP = ORIGMARK;
3359 PUSHTARG;
3360 RETURN;
3361}
3362
79072805
LW
3363PP(pp_ord)
3364{
20b7effb 3365 dSP; dTARGET;
1eced8f8 3366
7df053ec 3367 SV *argsv = POPs;
ba210ebe 3368 STRLEN len;
349d4f2f 3369 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3370
799ef3cb 3371 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3372 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3373 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
4f6386b6 3374 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
121910a4
JH
3375 argsv = tmpsv;
3376 }
79072805 3377
d8f42585 3378 XPUSHu(DO_UTF8(argsv)
4f6386b6 3379 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
f3943cf2 3380 : (UV)(*s));
68795e93 3381
79072805
LW
3382 RETURN;
3383}
3384
463ee0b2
LW
3385PP(pp_chr)
3386{
20b7effb 3387 dSP; dTARGET;
463ee0b2 3388 char *tmps;
8a064bd6 3389 UV value;
71739502 3390 SV *top = POPs;
8a064bd6 3391
71739502 3392 SvGETMAGIC(top);
99f450cc 3393 if (UNLIKELY(isinfnansv(top)))
0c7df902 3394 Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
1cd88304
JH
3395 else {
3396 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3397 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3398 ||
3399 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3400 && SvNV_nomg(top) < 0.0))) {
b3fe8680
FC
3401 if (ckWARN(WARN_UTF8)) {
3402 if (SvGMAGICAL(top)) {
3403 SV *top2 = sv_newmortal();
3404 sv_setsv_nomg(top2, top);
3405 top = top2;
3406 }
1cd88304
JH
3407 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3408 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3409 }
3410 value = UNICODE_REPLACEMENT;
3411 } else {
3412 value = SvUV_nomg(top);
3413 }
8a064bd6 3414 }
463ee0b2 3415
862a34c6 3416 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3417
0064a8a9 3418 if (value > 255 && !IN_BYTES) {
eb160463 3419 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3420 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3421 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW
3422 *tmps = '\0';
3423 (void)SvPOK_only(TARG);
aa6ffa16 3424 SvUTF8_on(TARG);
a0ed51b3
LW
3425 XPUSHs(TARG);
3426 RETURN;
3427 }
3428
748a9306 3429 SvGROW(TARG,2);
463ee0b2
LW
3430 SvCUR_set(TARG, 1);
3431 tmps = SvPVX(TARG);
eb160463 3432 *tmps++ = (char)value;
748a9306 3433 *tmps = '\0';
a0d0e21e 3434 (void)SvPOK_only(TARG);
4c5ed6e2 3435
88632417 3436 if (PL_encoding && !IN_BYTES) {
799ef3cb 3437 sv_recode_to_utf8(TARG, PL_encoding);
88632417 3438 tmps = SvPVX(TARG);
28936164
KW
3439 if (SvCUR(TARG) == 0
3440 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3441 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3442 {
4c5ed6e2 3443 SvGROW(TARG, 2);
d5a15ac2 3444 tmps = SvPVX(TARG);
4c5ed6e2
ST
3445 SvCUR_set(TARG, 1);
3446 *tmps++ = (char)value;
88632417 3447 *tmps = '\0';
4c5ed6e2 3448 SvUTF8_off(TARG);
88632417
JH
3449 }
3450 }
4c5ed6e2 3451
463ee0b2
LW
3452 XPUSHs(TARG);
3453 RETURN;
3454}
3455
79072805
LW
3456PP(pp_crypt)
3457{
79072805 3458#ifdef HAS_CRYPT
20b7effb 3459 dSP; dTARGET;
5f74f29c 3460 dPOPTOPssrl;
85c16d83 3461 STRLEN len;
10516c54 3462 const char *tmps = SvPV_const(left, len);
2bc69dc4 3463
85c16d83 3464 if (DO_UTF8(left)) {
2bc69dc4 3465 /* If Unicode, try to downgrade.
f2791508
JH
3466 * If not possible, croak.
3467 * Yes, we made this up. */
1b6737cc 3468 SV* const tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3469
f2791508 3470 SvUTF8_on(tsv);
2bc69dc4 3471 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3472 tmps = SvPV_const(tsv, len);
85c16d83 3473 }
05404ffe
JH
3474# ifdef USE_ITHREADS
3475# ifdef HAS_CRYPT_R
3476 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3477 /* This should be threadsafe because in ithreads there is only
3478 * one thread per interpreter. If this would not be true,
3479 * we would need a mutex to protect this malloc. */
3480 PL_reentrant_buffer->_crypt_struct_buffer =
3481 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3482#if defined(__GLIBC__) || defined(__EMX__)
3483 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3484 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3485 /* work around glibc-2.2.5 bug */
3486 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3487 }
05404ffe 3488#endif
6ab58e4d 3489 }
05404ffe
JH
3490# endif /* HAS_CRYPT_R */
3491# endif /* USE_ITHREADS */
5f74f29c 3492# ifdef FCRYPT
83003860 3493 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3494# else
83003860 3495 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3496# endif
ec93b65f 3497 SETTARG;
4808266b 3498 RETURN;
79072805 3499#else
b13b2135 3500 DIE(aTHX_
79072805
LW
3501 "The crypt() function is unimplemented due to excessive paranoia.");
3502#endif
79072805
LW
3503}
3504
00f254e2
KW
3505/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3506 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3507
b1c05ba5
DM
3508
3509/* also used for: pp_lcfirst() */
3510
79072805
LW
3511PP(pp_ucfirst)
3512{
00f254e2
KW
3513 /* Actually is both lcfirst() and ucfirst(). Only the first character
3514 * changes. This means that possibly we can change in-place, ie., just
3515 * take the source and change that one character and store it back, but not
3516 * if read-only etc, or if the length changes */
3517
39644a26 3518 dSP;
d54190f6 3519 SV *source = TOPs;
00f254e2 3520 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC
3521 STRLEN need;
3522 SV *dest;
00f254e2
KW
3523 bool inplace; /* ? Convert first char only, in-place */
3524 bool doing_utf8 = FALSE; /* ? using utf8 */
3525 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3526 const int op_type = PL_op->op_type;
d54190f6
NC
3527 const U8 *s;
3528 U8 *d;
3529 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW
3530 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3531 * stored as UTF-8 at s. */
3532 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3533 * lowercased) character stored in tmpbuf. May be either
3534 * UTF-8 or not, but in either case is the number of bytes */
d54190f6 3535
841a5e18 3536 s = (const U8*)SvPV_const(source, slen);
a0ed51b3 3537
00f254e2
KW
3538 /* We may be able to get away with changing only the first character, in
3539 * place, but not if read-only, etc. Later we may discover more reasons to
3540 * not convert in-place. */
5cd5e2d6
FC
3541 inplace = !SvREADONLY(source)
3542 && ( SvPADTMP(source)
3543 || ( SvTEMP(source) && !SvSMAGICAL(source)
3544 && SvREFCNT(source) == 1));
00f254e2
KW
3545
3546 /* First calculate what the changed first character should be. This affects
3547 * whether we can just swap it out, leaving the rest of the string unchanged,
3548 * or even if have to convert the dest to UTF-8 when the source isn't */
3549
3550 if (! slen) { /* If empty */
3551 need = 1; /* still need a trailing NUL */
b7576bcb 3552 ulen = 0;
00f254e2
KW
3553 }
3554 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3555 doing_utf8 = TRUE;
17e95c9d 3556 ulen = UTF8SKIP(s);
094a2f8c 3557 if (op_type == OP_UCFIRST) {
130c5df3 3558#ifdef USE_LOCALE_CTYPE
5a6bb681 3559 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3560#else
5a6bb681 3561 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
130c5df3 3562#endif
094a2f8c
KW
3563 }
3564 else {
130c5df3 3565#ifdef USE_LOCALE_CTYPE
5a6bb681 3566 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3567#else
5a6bb681 3568 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
130c5df3 3569#endif
094a2f8c 3570 }
00f254e2 3571
17e95c9d
KW
3572 /* we can't do in-place if the length changes. */
3573 if (ulen != tculen) inplace = FALSE;
3574 need = slen + 1 - ulen + tculen;
d54190f6 3575 }
00f254e2
KW
3576 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3577 * latin1 is treated as caseless. Note that a locale takes
3578 * precedence */
167d19f2 3579 ulen = 1; /* Original character is 1 byte */
00f254e2
KW
3580 tculen = 1; /* Most characters will require one byte, but this will
3581 * need to be overridden for the tricky ones */
3582 need = slen + 1;
3583
3584 if (op_type == OP_LCFIRST) {
d54190f6 3585
00f254e2 3586 /* lower case the first letter: no trickiness for any character */
130c5df3
KW
3587 *tmpbuf =
3588#ifdef USE_LOCALE_CTYPE
3589 (IN_LC_RUNTIME(LC_CTYPE))
86a1f7fd 3590 ? toLOWER_LC(*s)
130c5df3
KW
3591 :
3592#endif
3593 (IN_UNI_8_BIT)
86a1f7fd
KW
3594 ? toLOWER_LATIN1(*s)
3595 : toLOWER(*s);