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