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