This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
perlpodspec: Corrections/adds to detecting =encoding
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
1129b882
NC		 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805 5 *
a0d0e21e
LW		 6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
79072805 8 *
a0d0e21e
LW		 9 */
10
11/*
4ac71550
TC		 12 * 'It's a big house this, and very peculiar. Always a bit more
13 * to discover, and no knowing what you'll find round a corner.
14 * And Elves, sir!' --Samwise Gamgee
15 *
16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
a0d0e21e 17 */
79072805 18
166f8a29
DM		 19/* This file contains general pp ("push/pop") functions that execute the
20 * opcodes that make up a perl program. A typical pp function expects to
21 * find its arguments on the stack, and usually pushes its results onto
22 * the stack, hence the 'pp' terminology. Each OP structure contains
23 * a pointer to the relevant pp_foo() function.
24 */
25
79072805 26#include "EXTERN.h"
864dbfa3 27#define PERL_IN_PP_C
79072805 28#include "perl.h"
77bc9082 29#include "keywords.h"
79072805 30
a4af207c 31#include "reentr.h"
685289b5 32#include "regcharclass.h"
a4af207c 33
dfe9444c
AD		 34/* XXX I can't imagine anyone who doesn't have this actually _needs_
35 it, since pid_t is an integral type.
36 --AD 2/20/1998
37*/
38#ifdef NEED_GETPID_PROTO
39extern Pid_t getpid (void);
8ac85365
NIS		 40#endif
41
0630166f
SP		 42/*
43 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44 * This switches them over to IEEE.
45 */
46#if defined(LIBM_LIB_VERSION)
47 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
48#endif
49
a78bc3c6
KW		 50static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
51static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
52
13017935
SM		 53/* variations on pp_null */
54
93a17b20
LW		 55PP(pp_stub)
56{
39644a26 57 dSP;
54310121 58 if (GIMME_V == G_SCALAR)
3280af22 59 XPUSHs(&PL_sv_undef);
93a17b20
LW		 60 RETURN;
61}
62
79072805
LW		 63/* Pushy stuff. */
64
bdaf10a5 65/* This is also called directly by pp_lvavref. */
93a17b20
LW		 66PP(pp_padav)
67{
20b7effb 68 dSP; dTARGET;
13017935 69 I32 gimme;
e190e9b4 70 assert(SvTYPE(TARG) == SVt_PVAV);
3dbcc5e0
S		 71 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
72 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
a5911867 73 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
85e6fe83 74 EXTEND(SP, 1);
533c011a 75 if (PL_op->op_flags & OPf_REF) {
85e6fe83 76 PUSHs(TARG);
93a17b20 77 RETURN;
40c94d11
FC		 78 } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
79 const I32 flags = is_lvalue_sub();
80 if (flags && !(flags & OPpENTERSUB_INARGS)) {
82334630 81 if (GIMME_V == G_SCALAR)
a84828f3 82 /* diag_listed_as: Can't return %s to lvalue scalar context */
78f9721b
SM		 83 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
84 PUSHs(TARG);
85 RETURN;
40c94d11 86 }
85e6fe83 87 }
13017935
SM		 88 gimme = GIMME_V;
89 if (gimme == G_ARRAY) {
d5524600 90 /* XXX see also S_pushav in pp_hot.c */
c70927a6 91 const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
85e6fe83 92 EXTEND(SP, maxarg);
93965878 93 if (SvMAGICAL(TARG)) {
c70927a6
FC		 94 Size_t i;
95 for (i=0; i < maxarg; i++) {
502c6561 96 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
3280af22 97 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878
NIS		 98 }
99 }
100 else {
428ccf1e
FC		 101 PADOFFSET i;
102 for (i=0; i < (PADOFFSET)maxarg; i++) {
103 SV * const sv = AvARRAY((const AV *)TARG)[i];
104 SP[i+1] = sv ? sv : &PL_sv_undef;
105 }
93965878 106 }
85e6fe83
LW		 107 SP += maxarg;
108 }
13017935 109 else if (gimme == G_SCALAR) {
1b6737cc 110 SV* const sv = sv_newmortal();
c70927a6 111 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
85e6fe83
LW		 112 sv_setiv(sv, maxarg);
113 PUSHs(sv);
114 }
115 RETURN;
93a17b20
LW		 116}
117
118PP(pp_padhv)
119{
20b7effb 120 dSP; dTARGET;
54310121 121 I32 gimme;
122
e190e9b4 123 assert(SvTYPE(TARG) == SVt_PVHV);
93a17b20 124 XPUSHs(TARG);
3dbcc5e0
S		 125 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
126 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
a5911867 127 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
533c011a 128 if (PL_op->op_flags & OPf_REF)
93a17b20 129 RETURN;
40c94d11
FC		 130 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
131 const I32 flags = is_lvalue_sub();
132 if (flags && !(flags & OPpENTERSUB_INARGS)) {
82334630 133 if (GIMME_V == G_SCALAR)
a84828f3 134 /* diag_listed_as: Can't return %s to lvalue scalar context */
78f9721b
SM		 135 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
136 RETURN;
40c94d11 137 }
78f9721b 138 }
54310121 139 gimme = GIMME_V;
140 if (gimme == G_ARRAY) {
981b7185 141 RETURNOP(Perl_do_kv(aTHX));
85e6fe83 142 }
c8fe3bdf 143 else if ((PL_op->op_private & OPpTRUEBOOL
adc42c31 144 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
c8fe3bdf
FC		 145 && block_gimme() == G_VOID ))
146 && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
147 SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
54310121 148 else if (gimme == G_SCALAR) {
85fbaab2 149 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
85e6fe83 150 SETs(sv);
85e6fe83 151 }
54310121 152 RETURN;
93a17b20
LW		 153}
154
ac217057
FC		 155PP(pp_padcv)
156{
20b7effb 157 dSP; dTARGET;
97b03d64
FC		 158 assert(SvTYPE(TARG) == SVt_PVCV);
159 XPUSHs(TARG);
160 RETURN;
ac217057
FC		 161}
162
ecf9c8b7
FC		 163PP(pp_introcv)
164{
20b7effb 165 dTARGET;
6d5c2147
FC		 166 SvPADSTALE_off(TARG);
167 return NORMAL;
ecf9c8b7
FC		 168}
169
13f89586
FC		 170PP(pp_clonecv)
171{
20b7effb 172 dTARGET;
0f94cb1f
FC		 173 CV * const protocv = PadnamePROTOCV(
174 PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
175 );
6d5c2147 176 assert(SvTYPE(TARG) == SVt_PVCV);
0f94cb1f
FC		 177 assert(protocv);
178 if (CvISXSUB(protocv)) { /* constant */
6d5c2147 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);
0f94cb1f 183 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
6d5c2147
FC		 184 }
185 else {
0f94cb1f
FC		 186 if (CvROOT(protocv)) {
187 assert(CvCLONE(protocv));
188 assert(!CvCLONED(protocv));
6d5c2147 189 }
0f94cb1f 190 cv_clone_into(protocv,(CV *)TARG);
6d5c2147
FC		 191 SAVECLEARSV(PAD_SVl(ARGTARG));
192 }
193 return NORMAL;
13f89586
FC		 194}
195
79072805
LW		 196/* Translations. */
197
6f7909da
FC		 198/* In some cases this function inspects PL_op. If this function is called
199 for new op types, more bool parameters may need to be added in place of
200 the checks.
201
202 When noinit is true, the absence of a gv will cause a retval of undef.
203 This is unrelated to the cv-to-gv assignment case.
6f7909da
FC		 204*/
205
206static SV *
207S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
208 const bool noinit)
209{
f64c9ac5 210 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
ed6116ce 211 if (SvROK(sv)) {
93d7320b
DM		 212 if (SvAMAGIC(sv)) {
213 sv = amagic_deref_call(sv, to_gv_amg);
93d7320b 214 }
e4a1664f 215 wasref:
ed6116ce 216 sv = SvRV(sv);
b1dadf13 217 if (SvTYPE(sv) == SVt_PVIO) {
159b6efe 218 GV * const gv = MUTABLE_GV(sv_newmortal());
885f468a 219 gv_init(gv, 0, "__ANONIO__", 10, 0);
a45c7426 220 GvIOp(gv) = MUTABLE_IO(sv);
b37c2d43 221 SvREFCNT_inc_void_NN(sv);
ad64d0ec 222 sv = MUTABLE_SV(gv);
ef54e1a4 223 }
81d52ecd
JH		 224 else if (!isGV_with_GP(sv)) {
225 Perl_die(aTHX_ "Not a GLOB reference");
226 }
79072805
LW		 227 }
228 else {
6e592b3a 229 if (!isGV_with_GP(sv)) {
f132ae69 230 if (!SvOK(sv)) {
b13b2135 231 /* If this is a 'my' scalar and flag is set then vivify
853846ea 232 * NI-S 1999/05/07
b13b2135 233 */
f132ae69 234 if (vivify_sv && sv != &PL_sv_undef) {
2c8ac474 235 GV *gv;
ce74145d 236 if (SvREADONLY(sv))
cb077ed2 237 Perl_croak_no_modify();
2c8ac474 238 if (cUNOP->op_targ) {
0bd48802 239 SV * const namesv = PAD_SV(cUNOP->op_targ);
94e7eb6f
FC		 240 HV *stash = CopSTASH(PL_curcop);
241 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
159b6efe 242 gv = MUTABLE_GV(newSV(0));
94e7eb6f 243 gv_init_sv(gv, stash, namesv, 0);
2c8ac474
GS		 244 }
245 else {
0bd48802 246 const char * const name = CopSTASHPV(PL_curcop);
6b10071b 247 gv = newGVgen_flags(name,
d14578b8 248 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
7bdb4ff0 249 SvREFCNT_inc_simple_void_NN(gv);
1d8d4d2a 250 }
43230e26 251 prepare_SV_for_RV(sv);
ad64d0ec 252 SvRV_set(sv, MUTABLE_SV(gv));
853846ea 253 SvROK_on(sv);
1d8d4d2a 254 SvSETMAGIC(sv);
853846ea 255 goto wasref;
2c8ac474 256 }
81d52ecd
JH		 257 if (PL_op->op_flags & OPf_REF || strict) {
258 Perl_die(aTHX_ PL_no_usym, "a symbol");
259 }
599cee73 260 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 261 report_uninit(sv);
6f7909da 262 return &PL_sv_undef;
a0d0e21e 263 }
6f7909da 264 if (noinit)
35cd451c 265 {
77cb3b01
FC		 266 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
267 sv, GV_ADDMG, SVt_PVGV
23496c6e 268 ))))
6f7909da 269 return &PL_sv_undef;
35cd451c
GS		 270 }
271 else {
81d52ecd
JH		 272 if (strict) {
273 Perl_die(aTHX_
fedf30e1 274 PL_no_symref_sv,
81d52ecd
JH		 275 sv,
276 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
277 "a symbol"
278 );
279 }
e26df76a
NC		 280 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
281 == OPpDONT_INIT_GV) {
282 /* We are the target of a coderef assignment. Return
283 the scalar unchanged, and let pp_sasssign deal with
284 things. */
6f7909da 285 return sv;
e26df76a 286 }
77cb3b01 287 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
35cd451c 288 }
2acc3314 289 /* FAKE globs in the symbol table cause weird bugs (#77810) */
96293f45 290 SvFAKE_off(sv);
93a17b20 291 }
79072805 292 }
8dc99089 293 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
2acc3314 294 SV *newsv = sv_newmortal();
5cf4b255 295 sv_setsv_flags(newsv, sv, 0);
2acc3314 296 SvFAKE_off(newsv);
d8906c05 297 sv = newsv;
2acc3314 298 }
6f7909da
FC		 299 return sv;
300}
301
302PP(pp_rv2gv)
303{
20b7effb 304 dSP; dTOPss;
6f7909da
FC		 305
306 sv = S_rv2gv(aTHX_
307 sv, PL_op->op_private & OPpDEREF,
308 PL_op->op_private & HINT_STRICT_REFS,
309 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
310 || PL_op->op_type == OP_READLINE
311 );
d8906c05
FC		 312 if (PL_op->op_private & OPpLVAL_INTRO)
313 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
314 SETs(sv);
79072805
LW		 315 RETURN;
316}
317
dc3c76f8
NC		 318/* Helper function for pp_rv2sv and pp_rv2av */
319GV *
fe9845cc
RB		 320Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
321 const svtype type, SV ***spp)
dc3c76f8 322{
dc3c76f8
NC		 323 GV *gv;
324
7918f24d
NC		 325 PERL_ARGS_ASSERT_SOFTREF2XV;
326
dc3c76f8
NC		 327 if (PL_op->op_private & HINT_STRICT_REFS) {
328 if (SvOK(sv))
fedf30e1 329 Perl_die(aTHX_ PL_no_symref_sv, sv,
bf3d870f 330 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
dc3c76f8
NC		 331 else
332 Perl_die(aTHX_ PL_no_usym, what);
333 }
334 if (!SvOK(sv)) {
fd1d9b5c 335 if (
c8fe3bdf 336 PL_op->op_flags & OPf_REF
fd1d9b5c 337 )
dc3c76f8
NC		 338 Perl_die(aTHX_ PL_no_usym, what);
339 if (ckWARN(WARN_UNINITIALIZED))
340 report_uninit(sv);
341 if (type != SVt_PV && GIMME_V == G_ARRAY) {
342 (*spp)--;
343 return NULL;
344 }
345 **spp = &PL_sv_undef;
346 return NULL;
347 }
348 if ((PL_op->op_flags & OPf_SPECIAL) &&
349 !(PL_op->op_flags & OPf_MOD))
350 {
77cb3b01 351 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
dc3c76f8
NC		 352 {
353 **spp = &PL_sv_undef;
354 return NULL;
355 }
356 }
357 else {
77cb3b01 358 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
dc3c76f8
NC		 359 }
360 return gv;
361}
362
79072805
LW		 363PP(pp_rv2sv)
364{
20b7effb 365 dSP; dTOPss;
c445ea15 366 GV *gv = NULL;
79072805 367
9026059d 368 SvGETMAGIC(sv);
ed6116ce 369 if (SvROK(sv)) {
93d7320b
DM		 370 if (SvAMAGIC(sv)) {
371 sv = amagic_deref_call(sv, to_sv_amg);
93d7320b 372 }
f5284f61 373
ed6116ce 374 sv = SvRV(sv);
69f00f67 375 if (SvTYPE(sv) >= SVt_PVAV)
cea2e8a9 376 DIE(aTHX_ "Not a SCALAR reference");
79072805
LW		 377 }
378 else {
159b6efe 379 gv = MUTABLE_GV(sv);
748a9306 380
6e592b3a 381 if (!isGV_with_GP(gv)) {
dc3c76f8
NC		 382 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
383 if (!gv)
384 RETURN;
463ee0b2 385 }
29c711a3 386 sv = GvSVn(gv);
a0d0e21e 387 }
533c011a 388 if (PL_op->op_flags & OPf_MOD) {
82d03984
RGS		 389 if (PL_op->op_private & OPpLVAL_INTRO) {
390 if (cUNOP->op_first->op_type == OP_NULL)
159b6efe 391 sv = save_scalar(MUTABLE_GV(TOPs));
82d03984
RGS		 392 else if (gv)
393 sv = save_scalar(gv);
394 else
f1f66076 395 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
82d03984 396 }
533c011a 397 else if (PL_op->op_private & OPpDEREF)
9026059d 398 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
79072805 399 }
a0d0e21e 400 SETs(sv);
79072805
LW		 401 RETURN;
402}
403
404PP(pp_av2arylen)
405{
20b7effb 406 dSP;
502c6561 407 AV * const av = MUTABLE_AV(TOPs);
02d85cc3
EB		 408 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
409 if (lvalue) {
8160c8f5
DM		 410 SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
411 if (!*svp) {
412 *svp = newSV_type(SVt_PVMG);
413 sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
02d85cc3 414 }
8160c8f5 415 SETs(*svp);
02d85cc3 416 } else {
e1dccc0d 417 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
79072805 418 }
79072805
LW		 419 RETURN;
420}
421
a0d0e21e
LW		 422PP(pp_pos)
423{
27a8dde8 424 dSP; dTOPss;
8ec5e241 425
78f9721b 426 if (PL_op->op_flags & OPf_MOD || LVRET) {
d14578b8 427 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
16eb5365
FC		 428 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
429 LvTYPE(ret) = '.';
430 LvTARG(ret) = SvREFCNT_inc_simple(sv);
27a8dde8 431 SETs(ret); /* no SvSETMAGIC */
a0d0e21e
LW		 432 }
433 else {
96c2a8ff 434 const MAGIC * const mg = mg_find_mglob(sv);
6174b39a 435 if (mg && mg->mg_len != -1) {
2154eca7 436 dTARGET;
6174b39a 437 STRLEN i = mg->mg_len;
25fdce4a 438 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
6174b39a 439 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
27a8dde8
FC		 440 SETu(i);
441 return NORMAL;
a0d0e21e 442 }
27a8dde8 443 SETs(&PL_sv_undef);
a0d0e21e 444 }
27a8dde8 445 return NORMAL;
a0d0e21e
LW		 446}
447
79072805
LW		 448PP(pp_rv2cv)
449{
20b7effb 450 dSP;
79072805 451 GV *gv;
1eced8f8 452 HV *stash_unused;
c445ea15 453 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
9da346da 454 ? GV_ADDMG
d14578b8
KW		 455 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
456 == OPpMAY_RETURN_CONSTANT)
c445ea15
AL		 457 ? GV_ADD|GV_NOEXPAND
458 : GV_ADD;
4633a7c4
LW		 459 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
460 /* (But not in defined().) */
e26df76a 461
1eced8f8 462 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
5a20ba3d 463 if (cv) NOOP;
e26df76a 464 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
2eaf799e
FC		 465 cv = SvTYPE(SvRV(gv)) == SVt_PVCV
466 ? MUTABLE_CV(SvRV(gv))
467 : MUTABLE_CV(gv);
e26df76a 468 }
07055b4c 469 else
ea726b52 470 cv = MUTABLE_CV(&PL_sv_undef);
ad64d0ec 471 SETs(MUTABLE_SV(cv));
3d79e3ee 472 return NORMAL;
79072805
LW		 473}
474
c07a80fd 475PP(pp_prototype)
476{
20b7effb 477 dSP;
c07a80fd 478 CV *cv;
479 HV *stash;
480 GV *gv;
fabdb6c0 481 SV *ret = &PL_sv_undef;
c07a80fd 482
6954f42f 483 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
b6c543e3 484 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
e3f73d4e 485 const char * s = SvPVX_const(TOPs);
b6c543e3 486 if (strnEQ(s, "CORE::", 6)) {
be1b855b 487 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
a96df643 488 if (!code)
b17a0679
FC		 489 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
490 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
4e338c21 491 {
b66130dd
FC		 492 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
493 if (sv) ret = sv;
494 }
b8c38f0a 495 goto set;
b6c543e3
IZ		 496 }
497 }
f2c0649b 498 cv = sv_2cv(TOPs, &stash, &gv, 0);
5f05dabc 499 if (cv && SvPOK(cv))
8fa6a409
FC		 500 ret = newSVpvn_flags(
501 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
502 );
b6c543e3 503 set:
c07a80fd 504 SETs(ret);
505 RETURN;
506}
507
a0d0e21e
LW		 508PP(pp_anoncode)
509{
20b7effb 510 dSP;
ea726b52 511 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
a5f75d66 512 if (CvCLONE(cv))
ad64d0ec 513 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
5f05dabc 514 EXTEND(SP,1);
ad64d0ec 515 PUSHs(MUTABLE_SV(cv));
a0d0e21e
LW		 516 RETURN;
517}
518
519PP(pp_srefgen)
79072805 520{
20b7effb 521 dSP;
71be2cbc 522 *SP = refto(*SP);
3ed34c76 523 return NORMAL;
8ec5e241 524}
a0d0e21e
LW		 525
526PP(pp_refgen)
527{
20b7effb 528 dSP; dMARK;
82334630 529 if (GIMME_V != G_ARRAY) {
5f0b1d4e
GS		 530 if (++MARK <= SP)
531 *MARK = *SP;
532 else
1d51ab6c
FC		 533 {
534 MEXTEND(SP, 1);
3280af22 535 *MARK = &PL_sv_undef;
1d51ab6c 536 }
5f0b1d4e
GS		 537 *MARK = refto(*MARK);
538 SP = MARK;
539 RETURN;
a0d0e21e 540 }
bbce6d69 541 EXTEND_MORTAL(SP - MARK);
71be2cbc 542 while (++MARK <= SP)
543 *MARK = refto(*MARK);
a0d0e21e 544 RETURN;
79072805
LW		 545}
546
76e3520e 547STATIC SV*
cea2e8a9 548S_refto(pTHX_ SV *sv)
71be2cbc 549{
550 SV* rv;
551
7918f24d
NC		 552 PERL_ARGS_ASSERT_REFTO;
553
71be2cbc 554 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
555 if (LvTARGLEN(sv))
68dc0745 556 vivify_defelem(sv);
557 if (!(sv = LvTARG(sv)))
3280af22 558 sv = &PL_sv_undef;
0dd88869 559 else
b37c2d43 560 SvREFCNT_inc_void_NN(sv);
71be2cbc 561 }
d8b46c1b 562 else if (SvTYPE(sv) == SVt_PVAV) {
502c6561
NC		 563 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
564 av_reify(MUTABLE_AV(sv));
d8b46c1b 565 SvTEMP_off(sv);
b37c2d43 566 SvREFCNT_inc_void_NN(sv);
d8b46c1b 567 }
60779a30 568 else if (SvPADTMP(sv)) {
f2933f5f 569 sv = newSVsv(sv);
60779a30 570 }
71be2cbc 571 else {
572 SvTEMP_off(sv);
b37c2d43 573 SvREFCNT_inc_void_NN(sv);
71be2cbc 574 }
575 rv = sv_newmortal();
4df7f6af 576 sv_upgrade(rv, SVt_IV);
b162af07 577 SvRV_set(rv, sv);
71be2cbc 578 SvROK_on(rv);
579 return rv;
580}
581
79072805
LW		 582PP(pp_ref)
583{
3c1e67ac
DD		 584 dSP;
585 SV * const sv = TOPs;
f12c7020 586
511ddbdf
FC		 587 SvGETMAGIC(sv);
588 if (!SvROK(sv))
3c1e67ac
DD		 589 SETs(&PL_sv_no);
590 else {
591 dTARGET;
592 SETs(TARG);
593 /* use the return value that is in a register, its the same as TARG */
594 TARG = sv_ref(TARG,SvRV(sv),TRUE);
595 SvSETMAGIC(TARG);
596 }
79072805 597
3c1e67ac 598 return NORMAL;
79072805
LW		 599}
600
601PP(pp_bless)
602{
20b7effb 603 dSP;
463ee0b2 604 HV *stash;
79072805 605
463ee0b2 606 if (MAXARG == 1)
dcdfe746 607 {
c2f922f1 608 curstash:
11faa288 609 stash = CopSTASH(PL_curcop);
dcdfe746
FC		 610 if (SvTYPE(stash) != SVt_PVHV)
611 Perl_croak(aTHX_ "Attempt to bless into a freed package");
612 }
7b8d334a 613 else {
1b6737cc 614 SV * const ssv = POPs;
7b8d334a 615 STRLEN len;
e1ec3a88 616 const char *ptr;
81689caa 617
c2f922f1 618 if (!ssv) goto curstash;
8d9dd4b9 619 SvGETMAGIC(ssv);
c7ea825d
FC		 620 if (SvROK(ssv)) {
621 if (!SvAMAGIC(ssv)) {
622 frog:
81689caa 623 Perl_croak(aTHX_ "Attempt to bless into a reference");
c7ea825d
FC		 624 }
625 /* SvAMAGIC is on here, but it only means potentially overloaded,
626 so after stringification: */
627 ptr = SvPV_nomg_const(ssv,len);
628 /* We need to check the flag again: */
629 if (!SvAMAGIC(ssv)) goto frog;
630 }
631 else ptr = SvPV_nomg_const(ssv,len);
a2a5de95
NC		 632 if (len == 0)
633 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
634 "Explicit blessing to '' (assuming package main)");
e69c50fe 635 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
7b8d334a 636 }
a0d0e21e 637
5d3fdfeb 638 (void)sv_bless(TOPs, stash);
79072805
LW		 639 RETURN;
640}
641
fb73857a 642PP(pp_gelem)
643{
20b7effb 644 dSP;
b13b2135 645
1b6737cc 646 SV *sv = POPs;
a180b31a
BF		 647 STRLEN len;
648 const char * const elem = SvPV_const(sv, len);
5695161e 649 GV * const gv = MUTABLE_GV(TOPs);
c445ea15 650 SV * tmpRef = NULL;
1b6737cc 651
c445ea15 652 sv = NULL;
c4ba80c3
NC		 653 if (elem) {
654 /* elem will always be NUL terminated. */
1b6737cc 655 const char * const second_letter = elem + 1;
c4ba80c3
NC		 656 switch (*elem) {
657 case 'A':
a180b31a 658 if (len == 5 && strEQ(second_letter, "RRAY"))
e14698d8 659 {
ad64d0ec 660 tmpRef = MUTABLE_SV(GvAV(gv));
e14698d8
FC		 661 if (tmpRef && !AvREAL((const AV *)tmpRef)
662 && AvREIFY((const AV *)tmpRef))
663 av_reify(MUTABLE_AV(tmpRef));
664 }
c4ba80c3
NC		 665 break;
666 case 'C':
a180b31a 667 if (len == 4 && strEQ(second_letter, "ODE"))
ad64d0ec 668 tmpRef = MUTABLE_SV(GvCVu(gv));
c4ba80c3
NC		 669 break;
670 case 'F':
a180b31a 671 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
c4ba80c3
NC		 672 /* finally deprecated in 5.8.0 */
673 deprecate("*glob{FILEHANDLE}");
ad64d0ec 674 tmpRef = MUTABLE_SV(GvIOp(gv));
c4ba80c3
NC		 675 }
676 else
a180b31a 677 if (len == 6 && strEQ(second_letter, "ORMAT"))
ad64d0ec 678 tmpRef = MUTABLE_SV(GvFORM(gv));
c4ba80c3
NC		 679 break;
680 case 'G':
a180b31a 681 if (len == 4 && strEQ(second_letter, "LOB"))
ad64d0ec 682 tmpRef = MUTABLE_SV(gv);
c4ba80c3
NC		 683 break;
684 case 'H':
a180b31a 685 if (len == 4 && strEQ(second_letter, "ASH"))
ad64d0ec 686 tmpRef = MUTABLE_SV(GvHV(gv));
c4ba80c3
NC		 687 break;
688 case 'I':
a180b31a 689 if (*second_letter == 'O' && !elem[2] && len == 2)
ad64d0ec 690 tmpRef = MUTABLE_SV(GvIOp(gv));
c4ba80c3
NC		 691 break;
692 case 'N':
a180b31a 693 if (len == 4 && strEQ(second_letter, "AME"))
a663657d 694 sv = newSVhek(GvNAME_HEK(gv));
c4ba80c3
NC		 695 break;
696 case 'P':
a180b31a 697 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
7fa3a4ab
NC		 698 const HV * const stash = GvSTASH(gv);
699 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
396482e1 700 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
c4ba80c3
NC		 701 }
702 break;
703 case 'S':
a180b31a 704 if (len == 6 && strEQ(second_letter, "CALAR"))
f9d52e31 705 tmpRef = GvSVn(gv);
c4ba80c3 706 break;
39b99f21 707 }
fb73857a 708 }
76e3520e
GS		 709 if (tmpRef)
710 sv = newRV(tmpRef);
fb73857a 711 if (sv)
712 sv_2mortal(sv);
713 else
3280af22 714 sv = &PL_sv_undef;
5695161e 715 SETs(sv);
fb73857a 716 RETURN;
717}
718
a0d0e21e 719/* Pattern matching */
79072805 720
a0d0e21e 721PP(pp_study)
79072805 722{
add3e777 723 dSP; dTOPss;
a0d0e21e
LW		 724 STRLEN len;
725
1fa930f2 726 (void)SvPV(sv, len);
bc9a5256 727 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
32f0ea87 728 /* Historically, study was skipped in these cases. */
add3e777
FC		 729 SETs(&PL_sv_no);
730 return NORMAL;
a4f4e906
NC		 731 }
732
a58a85fa 733 /* Make study a no-op. It's no longer useful and its existence
32f0ea87 734 complicates matters elsewhere. */
add3e777
FC		 735 SETs(&PL_sv_yes);
736 return NORMAL;
79072805
LW		 737}
738
b1c05ba5
DM		 739
740/* also used for: pp_transr() */
741
a0d0e21e 742PP(pp_trans)
79072805 743{
6442877a 744 dSP;
a0d0e21e
LW		 745 SV *sv;
746
533c011a 747 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 748 sv = POPs;
79072805 749 else {
a0d0e21e 750 EXTEND(SP,1);
f605e527 751 if (ARGTARG)
6442877a 752 sv = PAD_SV(ARGTARG);
f605e527
FC		 753 else {
754 sv = DEFSV;
755 }
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 764 else {
6442877a 765 mPUSHi(do_trans(sv));
5bbe7184 766 }
a0d0e21e 767 RETURN;
79072805
LW		 768}
769
a0d0e21e 770/* Lvalue operators. */
79072805 771
f595e19f 772static size_t
81745e4e
NC		 773S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
774{
81745e4e
NC		 775 STRLEN len;
776 char *s;
f595e19f 777 size_t count = 0;
81745e4e
NC		 778
779 PERL_ARGS_ASSERT_DO_CHOMP;
780
781 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
f595e19f 782 return 0;
81745e4e
NC		 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))
f595e19f 791 count += do_chomp(retval, sv, chomping);
81745e4e 792 }
f595e19f 793 return count;
81745e4e
NC		 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)))
f595e19f
FC		 800 count += do_chomp(retval, hv_iterval(hv,entry), chomping);
801 return count;
81745e4e
NC		 802 }
803 else if (SvREADONLY(sv)) {
cb077ed2 804 Perl_croak_no_modify();
81745e4e
NC		 805 }
806
47e13f24 807 if (IN_ENCODING) {
81745e4e
NC		 808 if (!SvUTF8(sv)) {
809 /* XXX, here sv is utf8-ized as a side-effect!
810 If encoding.pm is used properly, almost string-generating
811 operations, including literal strings, chr(), input data, etc.
812 should have been utf8-ized already, right?
813 */
ad2de1b2 814 sv_recode_to_utf8(sv, _get_encoding());
81745e4e
NC		 815 }
816 }
817
818 s = SvPV(sv, len);
819 if (chomping) {
820 char *temp_buffer = NULL;
821 SV *svrecode = NULL;
822
823 if (s && len) {
824 s += --len;
825 if (RsPARA(PL_rs)) {
826 if (*s != '\n')
827 goto nope;
f595e19f 828 ++count;
81745e4e
NC		 829 while (len && s[-1] == '\n') {
830 --len;
831 --s;
f595e19f 832 ++count;
81745e4e
NC		 833 }
834 }
835 else {
836 STRLEN rslen, rs_charlen;
837 const char *rsptr = SvPV_const(PL_rs, rslen);
838
839 rs_charlen = SvUTF8(PL_rs)
840 ? sv_len_utf8(PL_rs)
841 : rslen;
842
843 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
844 /* Assumption is that rs is shorter than the scalar. */
845 if (SvUTF8(PL_rs)) {
846 /* RS is utf8, scalar is 8 bit. */
847 bool is_utf8 = TRUE;
848 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
849 &rslen, &is_utf8);
850 if (is_utf8) {
851 /* Cannot downgrade, therefore cannot possibly match
852 */
853 assert (temp_buffer == rsptr);
854 temp_buffer = NULL;
855 goto nope;
856 }
857 rsptr = temp_buffer;
858 }
47e13f24 859 else if (IN_ENCODING) {
81745e4e
NC		 860 /* RS is 8 bit, encoding.pm is used.
861 * Do not recode PL_rs as a side-effect. */
862 svrecode = newSVpvn(rsptr, rslen);
ad2de1b2 863 sv_recode_to_utf8(svrecode, _get_encoding());
81745e4e
NC		 864 rsptr = SvPV_const(svrecode, rslen);
865 rs_charlen = sv_len_utf8(svrecode);
866 }
867 else {
868 /* RS is 8 bit, scalar is utf8. */
869 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
870 rsptr = temp_buffer;
871 }
872 }
873 if (rslen == 1) {
874 if (*s != *rsptr)
875 goto nope;
f595e19f 876 ++count;
81745e4e
NC		 877 }
878 else {
879 if (len < rslen - 1)
880 goto nope;
881 len -= rslen - 1;
882 s -= rslen - 1;
883 if (memNE(s, rsptr, rslen))
884 goto nope;
f595e19f 885 count += rs_charlen;
81745e4e
NC		 886 }
887 }
3b7ded39 888 SvPV_force_nomg_nolen(sv);
81745e4e
NC		 889 SvCUR_set(sv, len);
890 *SvEND(sv) = '\0';
891 SvNIOK_off(sv);
892 SvSETMAGIC(sv);
893 }
894 nope:
895
896 SvREFCNT_dec(svrecode);
897
898 Safefree(temp_buffer);
899 } else {
f8c80a8e 900 if (len && (!SvPOK(sv) || SvIsCOW(sv)))
81745e4e
NC		 901 s = SvPV_force_nomg(sv, len);
902 if (DO_UTF8(sv)) {
903 if (s && len) {
904 char * const send = s + len;
905 char * const start = s;
906 s = send - 1;
907 while (s > start && UTF8_IS_CONTINUATION(*s))
908 s--;
909 if (is_utf8_string((U8*)s, send - s)) {
910 sv_setpvn(retval, s, send - s);
911 *s = '\0';
912 SvCUR_set(sv, s - start);
913 SvNIOK_off(sv);
914 SvUTF8_on(retval);
915 }
916 }
917 else
918 sv_setpvs(retval, "");
919 }
920 else if (s && len) {
921 s += --len;
922 sv_setpvn(retval, s, 1);
923 *s = '\0';
924 SvCUR_set(sv, len);
925 SvUTF8_off(sv);
926 SvNIOK_off(sv);
927 }
928 else
929 sv_setpvs(retval, "");
930 SvSETMAGIC(sv);
931 }
f595e19f 932 return count;
81745e4e
NC		 933}
934
b1c05ba5
DM		 935
936/* also used for: pp_schomp() */
937
a0d0e21e
LW		 938PP(pp_schop)
939{
20b7effb 940 dSP; dTARGET;
fa54efae
NC		 941 const bool chomping = PL_op->op_type == OP_SCHOMP;
942
f595e19f 943 const size_t count = do_chomp(TARG, TOPs, chomping);
fa54efae 944 if (chomping)
f595e19f 945 sv_setiv(TARG, count);
a0d0e21e 946 SETTARG;
ee41d8c7 947 return NORMAL;
79072805
LW		 948}
949
b1c05ba5
DM		 950
951/* also used for: pp_chomp() */
952
a0d0e21e 953PP(pp_chop)
79072805 954{
20b7effb 955 dSP; dMARK; dTARGET; dORIGMARK;
fa54efae 956 const bool chomping = PL_op->op_type == OP_CHOMP;
f595e19f 957 size_t count = 0;
8ec5e241 958
20cf1f79 959 while (MARK < SP)
f595e19f
FC		 960 count += do_chomp(TARG, *++MARK, chomping);
961 if (chomping)
962 sv_setiv(TARG, count);
20cf1f79
NC		 963 SP = ORIGMARK;
964 XPUSHTARG;
a0d0e21e 965 RETURN;
79072805
LW		 966}
967
a0d0e21e
LW		 968PP(pp_undef)
969{
20b7effb 970 dSP;
a0d0e21e
LW		 971 SV *sv;
972
533c011a 973 if (!PL_op->op_private) {
774d564b 974 EXTEND(SP, 1);
a0d0e21e 975 RETPUSHUNDEF;
774d564b 976 }
79072805 977
821f14b0 978 sv = TOPs;
a0d0e21e 979 if (!sv)
821f14b0
FC		 980 {
981 SETs(&PL_sv_undef);
982 return NORMAL;
983 }
85e6fe83 984
4dda930b
FC		 985 if (SvTHINKFIRST(sv))
986 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
85e6fe83 987
a0d0e21e
LW		 988 switch (SvTYPE(sv)) {
989 case SVt_NULL:
990 break;
991 case SVt_PVAV:
60edcf09 992 av_undef(MUTABLE_AV(sv));
a0d0e21e
LW		 993 break;
994 case SVt_PVHV:
60edcf09 995 hv_undef(MUTABLE_HV(sv));
a0d0e21e
LW		 996 break;
997 case SVt_PVCV:
a2a5de95 998 if (cv_const_sv((const CV *)sv))
714cd18f
BF		 999 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1000 "Constant subroutine %"SVf" undefined",
1001 SVfARG(CvANON((const CV *)sv)
1002 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
bdbfc51a
FC		 1003 : sv_2mortal(newSVhek(
1004 CvNAMED(sv)
1005 ? CvNAME_HEK((CV *)sv)
1006 : GvENAME_HEK(CvGV((const CV *)sv))
1007 ))
1008 ));
5f66b61c 1009 /* FALLTHROUGH */
9607fc9c 1010 case SVt_PVFM:
6fc92669 1011 /* let user-undef'd sub keep its identity */
b7acb0a3 1012 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
a0d0e21e 1013 break;
8e07c86e 1014 case SVt_PVGV:
bc1df6c2
FC		 1015 assert(isGV_with_GP(sv));
1016 assert(!SvFAKE(sv));
1017 {
20408e3c 1018 GP *gp;
dd69841b
BB		 1019 HV *stash;
1020
dd69841b 1021 /* undef *Pkg::meth_name ... */
e530fb81
FC		 1022 bool method_changed
1023 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1024 && HvENAME_get(stash);
1025 /* undef *Foo:: */
1026 if((stash = GvHV((const GV *)sv))) {
1027 if(HvENAME_get(stash))
1028 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1029 else stash = NULL;
1030 }
dd69841b 1031
795eb8c8 1032 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
159b6efe 1033 gp_free(MUTABLE_GV(sv));
a02a5408 1034 Newxz(gp, 1, GP);
c43ae56f 1035 GvGP_set(sv, gp_ref(gp));
2e3295e3 1036#ifndef PERL_DONT_CREATE_GVSV
561b68a9 1037 GvSV(sv) = newSV(0);
2e3295e3 1038#endif
57843af0 1039 GvLINE(sv) = CopLINE(PL_curcop);
159b6efe 1040 GvEGV(sv) = MUTABLE_GV(sv);
20408e3c 1041 GvMULTI_on(sv);
e530fb81
FC		 1042
1043 if(stash)
afdbe55d 1044 mro_package_moved(NULL, stash, (const GV *)sv, 0);
e530fb81
FC		 1045 stash = NULL;
1046 /* undef *Foo::ISA */
1047 if( strEQ(GvNAME((const GV *)sv), "ISA")
1048 && (stash = GvSTASH((const GV *)sv))
1049 && (method_changed || HvENAME(stash)) )
1050 mro_isa_changed_in(stash);
1051 else if(method_changed)
1052 mro_method_changed_in(
da9043f5 1053 GvSTASH((const GV *)sv)
e530fb81
FC		 1054 );
1055
6e592b3a 1056 break;
20408e3c 1057 }
a0d0e21e 1058 default:
b15aece3 1059 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
8bd4d4c5 1060 SvPV_free(sv);
c445ea15 1061 SvPV_set(sv, NULL);
4633a7c4 1062 SvLEN_set(sv, 0);
a0d0e21e 1063 }
0c34ef67 1064 SvOK_off(sv);
4633a7c4 1065 SvSETMAGIC(sv);
79072805 1066 }
a0d0e21e 1067
821f14b0
FC		 1068 SETs(&PL_sv_undef);
1069 return NORMAL;
79072805
LW		 1070}
1071
b1c05ba5
DM		 1072
1073/* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */
1074
a0d0e21e
LW		 1075PP(pp_postinc)
1076{
20b7effb 1077 dSP; dTARGET;
c22c99bc
FC		 1078 const bool inc =
1079 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
60092ce4 1080 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
cb077ed2 1081 Perl_croak_no_modify();
3baa0581 1082 if (SvROK(TOPs))
7dcb9b98 1083 TARG = sv_newmortal();
a0d0e21e 1084 sv_setsv(TARG, TOPs);
4bac9ae4 1085 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
c22c99bc 1086 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
55497cff 1087 {
c22c99bc 1088 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
55497cff 1089 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306 1090 }
c22c99bc 1091 else if (inc)
6f1401dc 1092 sv_inc_nomg(TOPs);
c22c99bc 1093 else sv_dec_nomg(TOPs);
a0d0e21e 1094 SvSETMAGIC(TOPs);
1e54a23f 1095 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
c22c99bc 1096 if (inc && !SvOK(TARG))
a0d0e21e 1097 sv_setiv(TARG, 0);
e87de4ab 1098 SETTARG;
a0d0e21e
LW		 1099 return NORMAL;
1100}
79072805 1101
a0d0e21e
LW		 1102/* Ordinary operators. */
1103
1104PP(pp_pow)
1105{
20b7effb 1106 dSP; dATARGET; SV *svl, *svr;
58d76dfd 1107#ifdef PERL_PRESERVE_IVUV
52a96ae6
HS		 1108 bool is_int = 0;
1109#endif
6f1401dc
DM		 1110 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1111 svr = TOPs;
1112 svl = TOPm1s;
52a96ae6
HS		 1113#ifdef PERL_PRESERVE_IVUV
1114 /* For integer to integer power, we do the calculation by hand wherever
1115 we're sure it is safe; otherwise we call pow() and try to convert to
1116 integer afterwards. */
01f91bf2 1117 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
900658e3
PF		 1118 UV power;
1119 bool baseuok;
1120 UV baseuv;
1121
800401ee
JH		 1122 if (SvUOK(svr)) {
1123 power = SvUVX(svr);
900658e3 1124 } else {
800401ee 1125 const IV iv = SvIVX(svr);
900658e3
PF		 1126 if (iv >= 0) {
1127 power = iv;
1128 } else {
1129 goto float_it; /* Can't do negative powers this way. */
1130 }
1131 }
1132
800401ee 1133 baseuok = SvUOK(svl);
900658e3 1134 if (baseuok) {
800401ee 1135 baseuv = SvUVX(svl);
900658e3 1136 } else {
800401ee 1137 const IV iv = SvIVX(svl);
900658e3
PF		 1138 if (iv >= 0) {
1139 baseuv = iv;
1140 baseuok = TRUE; /* effectively it's a UV now */
1141 } else {
1142 baseuv = -iv; /* abs, baseuok == false records sign */
1143 }
1144 }
52a96ae6
HS		 1145 /* now we have integer ** positive integer. */
1146 is_int = 1;
1147
1148 /* foo & (foo - 1) is zero only for a power of 2. */
58d76dfd 1149 if (!(baseuv & (baseuv - 1))) {
52a96ae6 1150 /* We are raising power-of-2 to a positive integer.
58d76dfd
JH		 1151 The logic here will work for any base (even non-integer
1152 bases) but it can be less accurate than
1153 pow (base,power) or exp (power * log (base)) when the
1154 intermediate values start to spill out of the mantissa.
1155 With powers of 2 we know this can't happen.
1156 And powers of 2 are the favourite thing for perl
1157 programmers to notice ** not doing what they mean. */
1158 NV result = 1.0;
1159 NV base = baseuok ? baseuv : -(NV)baseuv;
900658e3
PF		 1160
1161 if (power & 1) {
1162 result *= base;
1163 }
1164 while (power >>= 1) {
1165 base *= base;
1166 if (power & 1) {
1167 result *= base;
1168 }
1169 }
58d76dfd
JH		 1170 SP--;
1171 SETn( result );
6f1401dc 1172 SvIV_please_nomg(svr);
58d76dfd 1173 RETURN;
52a96ae6 1174 } else {
eb578fdb
KW		 1175 unsigned int highbit = 8 * sizeof(UV);
1176 unsigned int diff = 8 * sizeof(UV);
900658e3
PF		 1177 while (diff >>= 1) {
1178 highbit -= diff;
1179 if (baseuv >> highbit) {
1180 highbit += diff;
1181 }
52a96ae6
HS		 1182 }
1183 /* we now have baseuv < 2 ** highbit */
1184 if (power * highbit <= 8 * sizeof(UV)) {
1185 /* result will definitely fit in UV, so use UV math
1186 on same algorithm as above */
eb578fdb
KW		 1187 UV result = 1;
1188 UV base = baseuv;
f2338a2e 1189 const bool odd_power = cBOOL(power & 1);
900658e3
PF		 1190 if (odd_power) {
1191 result *= base;
1192 }
1193 while (power >>= 1) {
1194 base *= base;
1195 if (power & 1) {
52a96ae6 1196 result *= base;
52a96ae6
HS		 1197 }
1198 }
1199 SP--;
0615a994 1200 if (baseuok || !odd_power)
52a96ae6
HS		 1201 /* answer is positive */
1202 SETu( result );
1203 else if (result <= (UV)IV_MAX)
1204 /* answer negative, fits in IV */
1205 SETi( -(IV)result );
1206 else if (result == (UV)IV_MIN)
1207 /* 2's complement assumption: special case IV_MIN */
1208 SETi( IV_MIN );
1209 else
1210 /* answer negative, doesn't fit */
1211 SETn( -(NV)result );
1212 RETURN;
1213 }
1214 }
58d76dfd 1215 }
52a96ae6 1216 float_it:
58d76dfd 1217#endif
a0d0e21e 1218 {
6f1401dc
DM		 1219 NV right = SvNV_nomg(svr);
1220 NV left = SvNV_nomg(svl);
4efa5a16 1221 (void)POPs;
3aaeb624
JA		 1222
1223#if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1224 /*
1225 We are building perl with long double support and are on an AIX OS
1226 afflicted with a powl() function that wrongly returns NaNQ for any
1227 negative base. This was reported to IBM as PMR #23047-379 on
1228 03/06/2006. The problem exists in at least the following versions
1229 of AIX and the libm fileset, and no doubt others as well:
1230
1231 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1232 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1233 AIX 5.2.0 bos.adt.libm 5.2.0.85
1234
1235 So, until IBM fixes powl(), we provide the following workaround to
1236 handle the problem ourselves. Our logic is as follows: for
1237 negative bases (left), we use fmod(right, 2) to check if the
1238 exponent is an odd or even integer:
1239
1240 - if odd, powl(left, right) == -powl(-left, right)
1241 - if even, powl(left, right) == powl(-left, right)
1242
1243 If the exponent is not an integer, the result is rightly NaNQ, so
1244 we just return that (as NV_NAN).
1245 */
1246
1247 if (left < 0.0) {
1248 NV mod2 = Perl_fmod( right, 2.0 );
1249 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1250 SETn( -Perl_pow( -left, right) );
1251 } else if (mod2 == 0.0) { /* even integer */
1252 SETn( Perl_pow( -left, right) );
1253 } else { /* fractional power */
1254 SETn( NV_NAN );
1255 }
1256 } else {
1257 SETn( Perl_pow( left, right) );
1258 }
1259#else
52a96ae6 1260 SETn( Perl_pow( left, right) );
3aaeb624
JA		 1261#endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1262
52a96ae6
HS		 1263#ifdef PERL_PRESERVE_IVUV
1264 if (is_int)
6f1401dc 1265 SvIV_please_nomg(svr);
52a96ae6
HS		 1266#endif
1267 RETURN;
93a17b20 1268 }
a0d0e21e
LW		 1269}
1270
1271PP(pp_multiply)
1272{
20b7effb 1273 dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM		 1274 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1275 svr = TOPs;
1276 svl = TOPm1s;
28e5dec8 1277#ifdef PERL_PRESERVE_IVUV
01f91bf2 1278 if (SvIV_please_nomg(svr)) {
28e5dec8
JH		 1279 /* Unless the left argument is integer in range we are going to have to
1280 use NV maths. Hence only attempt to coerce the right argument if
1281 we know the left is integer. */
1282 /* Left operand is defined, so is it IV? */
01f91bf2 1283 if (SvIV_please_nomg(svl)) {
800401ee
JH		 1284 bool auvok = SvUOK(svl);
1285 bool buvok = SvUOK(svr);
28e5dec8
JH		 1286 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1287 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1288 UV alow;
1289 UV ahigh;
1290 UV blow;
1291 UV bhigh;
1292
1293 if (auvok) {
800401ee 1294 alow = SvUVX(svl);
28e5dec8 1295 } else {
800401ee 1296 const IV aiv = SvIVX(svl);
28e5dec8
JH		 1297 if (aiv >= 0) {
1298 alow = aiv;
1299 auvok = TRUE; /* effectively it's a UV now */
1300 } else {
53e2bfb7
DM		 1301 /* abs, auvok == false records sign */
1302 alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
28e5dec8
JH		 1303 }
1304 }
1305 if (buvok) {
800401ee 1306 blow = SvUVX(svr);
28e5dec8 1307 } else {
800401ee 1308 const IV biv = SvIVX(svr);
28e5dec8
JH		 1309 if (biv >= 0) {
1310 blow = biv;
1311 buvok = TRUE; /* effectively it's a UV now */
1312 } else {
53e2bfb7
DM		 1313 /* abs, buvok == false records sign */
1314 blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
28e5dec8
JH		 1315 }
1316 }
1317
1318 /* If this does sign extension on unsigned it's time for plan B */
1319 ahigh = alow >> (4 * sizeof (UV));
1320 alow &= botmask;
1321 bhigh = blow >> (4 * sizeof (UV));
1322 blow &= botmask;
1323 if (ahigh && bhigh) {
6f207bd3 1324 NOOP;
28e5dec8
JH		 1325 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1326 which is overflow. Drop to NVs below. */
1327 } else if (!ahigh && !bhigh) {
1328 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1329 so the unsigned multiply cannot overflow. */
c445ea15 1330 const UV product = alow * blow;
28e5dec8
JH		 1331 if (auvok == buvok) {
1332 /* -ve * -ve or +ve * +ve gives a +ve result. */
1333 SP--;
1334 SETu( product );
1335 RETURN;
1336 } else if (product <= (UV)IV_MIN) {
1337 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1338 /* -ve result, which could overflow an IV */
1339 SP--;
02b08bbc
DM		 1340 /* can't negate IV_MIN, but there are aren't two
1341 * integers such that !ahigh && !bhigh, where the
1342 * product equals 0x800....000 */
1343 assert(product != (UV)IV_MIN);
25716404 1344 SETi( -(IV)product );
28e5dec8
JH		 1345 RETURN;
1346 } /* else drop to NVs below. */
1347 } else {
1348 /* One operand is large, 1 small */
1349 UV product_middle;
1350 if (bhigh) {
1351 /* swap the operands */
1352 ahigh = bhigh;
1353 bhigh = blow; /* bhigh now the temp var for the swap */
1354 blow = alow;
1355 alow = bhigh;
1356 }
1357 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1358 multiplies can't overflow. shift can, add can, -ve can. */
1359 product_middle = ahigh * blow;
1360 if (!(product_middle & topmask)) {
1361 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1362 UV product_low;
1363 product_middle <<= (4 * sizeof (UV));
1364 product_low = alow * blow;
1365
1366 /* as for pp_add, UV + something mustn't get smaller.
1367 IIRC ANSI mandates this wrapping *behaviour* for
1368 unsigned whatever the actual representation*/
1369 product_low += product_middle;
1370 if (product_low >= product_middle) {
1371 /* didn't overflow */
1372 if (auvok == buvok) {
1373 /* -ve * -ve or +ve * +ve gives a +ve result. */
1374 SP--;
1375 SETu( product_low );
1376 RETURN;
1377 } else if (product_low <= (UV)IV_MIN) {
1378 /* 2s complement assumption again */
1379 /* -ve result, which could overflow an IV */
1380 SP--;
53e2bfb7
DM		 1381 SETi(product_low == (UV)IV_MIN
1382 ? IV_MIN : -(IV)product_low);
28e5dec8
JH		 1383 RETURN;
1384 } /* else drop to NVs below. */
1385 }
1386 } /* product_middle too large */
1387 } /* ahigh && bhigh */
800401ee
JH		 1388 } /* SvIOK(svl) */
1389 } /* SvIOK(svr) */
28e5dec8 1390#endif
a0d0e21e 1391 {
6f1401dc
DM		 1392 NV right = SvNV_nomg(svr);
1393 NV left = SvNV_nomg(svl);
4efa5a16 1394 (void)POPs;
a0d0e21e
LW		 1395 SETn( left * right );
1396 RETURN;
79072805 1397 }
a0d0e21e
LW		 1398}
1399
1400PP(pp_divide)
1401{
20b7effb 1402 dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM		 1403 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1404 svr = TOPs;
1405 svl = TOPm1s;
5479d192 1406 /* Only try to do UV divide first
68795e93 1407 if ((SLOPPYDIVIDE is true) or
5479d192
NC		 1408 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1409 to preserve))
1410 The assumption is that it is better to use floating point divide
1411 whenever possible, only doing integer divide first if we can't be sure.
1412 If NV_PRESERVES_UV is true then we know at compile time that no UV
1413 can be too large to preserve, so don't need to compile the code to
1414 test the size of UVs. */
1415
a0d0e21e 1416#ifdef SLOPPYDIVIDE
5479d192
NC		 1417# define PERL_TRY_UV_DIVIDE
1418 /* ensure that 20./5. == 4. */
a0d0e21e 1419#else
5479d192
NC		 1420# ifdef PERL_PRESERVE_IVUV
1421# ifndef NV_PRESERVES_UV
1422# define PERL_TRY_UV_DIVIDE
1423# endif
1424# endif
a0d0e21e 1425#endif
5479d192
NC		 1426
1427#ifdef PERL_TRY_UV_DIVIDE
01f91bf2 1428 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
800401ee
JH		 1429 bool left_non_neg = SvUOK(svl);
1430 bool right_non_neg = SvUOK(svr);
5479d192
NC		 1431 UV left;
1432 UV right;
1433
1434 if (right_non_neg) {
800401ee 1435 right = SvUVX(svr);
5479d192
NC		 1436 }
1437 else {
800401ee 1438 const IV biv = SvIVX(svr);
5479d192
NC		 1439 if (biv >= 0) {
1440 right = biv;
1441 right_non_neg = TRUE; /* effectively it's a UV now */
1442 }
1443 else {
02b08bbc 1444 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
5479d192
NC		 1445 }
1446 }
1447 /* historically undef()/0 gives a "Use of uninitialized value"
1448 warning before dieing, hence this test goes here.
1449 If it were immediately before the second SvIV_please, then
1450 DIE() would be invoked before left was even inspected, so
486ec47a 1451 no inspection would give no warning. */
5479d192
NC		 1452 if (right == 0)
1453 DIE(aTHX_ "Illegal division by zero");
1454
1455 if (left_non_neg) {
800401ee 1456 left = SvUVX(svl);
5479d192
NC		 1457 }
1458 else {
800401ee 1459 const IV aiv = SvIVX(svl);
5479d192
NC		 1460 if (aiv >= 0) {
1461 left = aiv;
1462 left_non_neg = TRUE; /* effectively it's a UV now */
1463 }
1464 else {
02b08bbc 1465 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
5479d192
NC		 1466 }
1467 }
1468
1469 if (left >= right
1470#ifdef SLOPPYDIVIDE
1471 /* For sloppy divide we always attempt integer division. */
1472#else
1473 /* Otherwise we only attempt it if either or both operands
1474 would not be preserved by an NV. If both fit in NVs
0c2ee62a
NC		 1475 we fall through to the NV divide code below. However,
1476 as left >= right to ensure integer result here, we know that
1477 we can skip the test on the right operand - right big
1478 enough not to be preserved can't get here unless left is
1479 also too big. */
1480
1481 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
5479d192
NC		 1482#endif
1483 ) {
1484 /* Integer division can't overflow, but it can be imprecise. */
1b6737cc 1485 const UV result = left / right;
5479d192
NC		 1486 if (result * right == left) {
1487 SP--; /* result is valid */
1488 if (left_non_neg == right_non_neg) {
1489 /* signs identical, result is positive. */
1490 SETu( result );
1491 RETURN;
1492 }
1493 /* 2s complement assumption */
1494 if (result <= (UV)IV_MIN)
02b08bbc 1495 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
5479d192
NC		 1496 else {
1497 /* It's exact but too negative for IV. */
1498 SETn( -(NV)result );
1499 }
1500 RETURN;
1501 } /* tried integer divide but it was not an integer result */
32fdb065 1502 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
01f91bf2 1503 } /* one operand wasn't SvIOK */
5479d192
NC		 1504#endif /* PERL_TRY_UV_DIVIDE */
1505 {
6f1401dc
DM		 1506 NV right = SvNV_nomg(svr);
1507 NV left = SvNV_nomg(svl);
4efa5a16 1508 (void)POPs;(void)POPs;
ebc6a117
PD		 1509#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1510 if (! Perl_isnan(right) && right == 0.0)
1511#else
659c4b96 1512 if (right == 0.0)
ebc6a117 1513#endif
5479d192
NC		 1514 DIE(aTHX_ "Illegal division by zero");
1515 PUSHn( left / right );
1516 RETURN;
79072805 1517 }
a0d0e21e
LW		 1518}
1519
1520PP(pp_modulo)
1521{
20b7effb 1522 dSP; dATARGET;
6f1401dc 1523 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
a0d0e21e 1524 {
9c5ffd7c
JH		 1525 UV left = 0;
1526 UV right = 0;
dc656993
JH		 1527 bool left_neg = FALSE;
1528 bool right_neg = FALSE;
e2c88acc
NC		 1529 bool use_double = FALSE;
1530 bool dright_valid = FALSE;
9c5ffd7c
JH		 1531 NV dright = 0.0;
1532 NV dleft = 0.0;
6f1401dc
DM		 1533 SV * const svr = TOPs;
1534 SV * const svl = TOPm1s;
01f91bf2 1535 if (SvIV_please_nomg(svr)) {
800401ee 1536 right_neg = !SvUOK(svr);
e2c88acc 1537 if (!right_neg) {
800401ee 1538 right = SvUVX(svr);
e2c88acc 1539 } else {
800401ee 1540 const IV biv = SvIVX(svr);
e2c88acc
NC		 1541 if (biv >= 0) {
1542 right = biv;
1543 right_neg = FALSE; /* effectively it's a UV now */
1544 } else {
02b08bbc 1545 right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
e2c88acc
NC		 1546 }
1547 }
1548 }
1549 else {
6f1401dc 1550 dright = SvNV_nomg(svr);
787eafbd
IZ		 1551 right_neg = dright < 0;
1552 if (right_neg)
1553 dright = -dright;
e2c88acc
NC		 1554 if (dright < UV_MAX_P1) {
1555 right = U_V(dright);
1556 dright_valid = TRUE; /* In case we need to use double below. */
1557 } else {
1558 use_double = TRUE;
1559 }
787eafbd 1560 }
a0d0e21e 1561
e2c88acc
NC		 1562 /* At this point use_double is only true if right is out of range for
1563 a UV. In range NV has been rounded down to nearest UV and
1564 use_double false. */
01f91bf2 1565 if (!use_double && SvIV_please_nomg(svl)) {
800401ee 1566 left_neg = !SvUOK(svl);
e2c88acc 1567 if (!left_neg) {
800401ee 1568 left = SvUVX(svl);
e2c88acc 1569 } else {
800401ee 1570 const IV aiv = SvIVX(svl);
e2c88acc
NC		 1571 if (aiv >= 0) {
1572 left = aiv;
1573 left_neg = FALSE; /* effectively it's a UV now */
1574 } else {
02b08bbc 1575 left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
e2c88acc
NC		 1576 }
1577 }
e2c88acc 1578 }
787eafbd 1579 else {
6f1401dc 1580 dleft = SvNV_nomg(svl);
787eafbd
IZ		 1581 left_neg = dleft < 0;
1582 if (left_neg)
1583 dleft = -dleft;
68dc0745 1584
e2c88acc
NC		 1585 /* This should be exactly the 5.6 behaviour - if left and right are
1586 both in range for UV then use U_V() rather than floor. */
1587 if (!use_double) {
1588 if (dleft < UV_MAX_P1) {
1589 /* right was in range, so is dleft, so use UVs not double.
1590 */
1591 left = U_V(dleft);
1592 }
1593 /* left is out of range for UV, right was in range, so promote
1594 right (back) to double. */
1595 else {
1596 /* The +0.5 is used in 5.6 even though it is not strictly
1597 consistent with the implicit +0 floor in the U_V()
1598 inside the #if 1. */
1599 dleft = Perl_floor(dleft + 0.5);
1600 use_double = TRUE;
1601 if (dright_valid)
1602 dright = Perl_floor(dright + 0.5);
1603 else
1604 dright = right;
1605 }
1606 }
1607 }
6f1401dc 1608 sp -= 2;
787eafbd 1609 if (use_double) {
65202027 1610 NV dans;
787eafbd 1611
659c4b96 1612 if (!dright)
cea2e8a9 1613 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1614
65202027 1615 dans = Perl_fmod(dleft, dright);
659c4b96 1616 if ((left_neg != right_neg) && dans)
787eafbd
IZ		 1617 dans = dright - dans;
1618 if (right_neg)
1619 dans = -dans;
1620 sv_setnv(TARG, dans);
1621 }
1622 else {
1623 UV ans;
1624
787eafbd 1625 if (!right)
cea2e8a9 1626 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ		 1627
1628 ans = left % right;
1629 if ((left_neg != right_neg) && ans)
1630 ans = right - ans;
1631 if (right_neg) {
1632 /* XXX may warn: unary minus operator applied to unsigned type */
1633 /* could change -foo to be (~foo)+1 instead */
1634 if (ans <= ~((UV)IV_MAX)+1)
1635 sv_setiv(TARG, ~ans+1);
1636 else
65202027 1637 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ		 1638 }
1639 else
1640 sv_setuv(TARG, ans);
1641 }
1642 PUSHTARG;
1643 RETURN;
79072805 1644 }
a0d0e21e 1645}
79072805 1646
a0d0e21e
LW		 1647PP(pp_repeat)
1648{
20b7effb 1649 dSP; dATARGET;
eb578fdb 1650 IV count;
6f1401dc
DM		 1651 SV *sv;
1652
82334630 1653 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
6f1401dc
DM		 1654 /* TODO: think of some way of doing list-repeat overloading ??? */
1655 sv = POPs;
1656 SvGETMAGIC(sv);
1657 }
1658 else {
3a100dab
FC		 1659 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1660 /* The parser saw this as a list repeat, and there
1661 are probably several items on the stack. But we're
1662 in scalar/void context, and there's no pp_list to save us
1663 now. So drop the rest of the items -- robin@kitsite.com
1664 */
1665 dMARK;
1666 if (MARK + 1 < SP) {
1667 MARK[1] = TOPm1s;
1668 MARK[2] = TOPs;
1669 }
1670 else {
1671 dTOPss;
1672 ASSUME(MARK + 1 == SP);
1673 XPUSHs(sv);
1674 MARK[1] = &PL_sv_undef;
1675 }
1676 SP = MARK + 2;
1677 }
6f1401dc
DM		 1678 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1679 sv = POPs;
1680 }
1681
2b573ace
JH		 1682 if (SvIOKp(sv)) {
1683 if (SvUOK(sv)) {
6f1401dc 1684 const UV uv = SvUV_nomg(sv);
2b573ace
JH		 1685 if (uv > IV_MAX)
1686 count = IV_MAX; /* The best we can do? */
1687 else
1688 count = uv;
1689 } else {
b3211734 1690 count = SvIV_nomg(sv);
2b573ace
JH		 1691 }
1692 }
1693 else if (SvNOKp(sv)) {
6f1401dc 1694 const NV nv = SvNV_nomg(sv);
2b573ace 1695 if (nv < 0.0)
b3211734 1696 count = -1; /* An arbitrary negative integer */
2b573ace
JH		 1697 else
1698 count = (IV)nv;
1699 }
1700 else
6f1401dc
DM		 1701 count = SvIV_nomg(sv);
1702
b3211734
KW		 1703 if (count < 0) {
1704 count = 0;
1705 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1706 "Negative repeat count does nothing");
1707 }
1708
82334630 1709 if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e 1710 dMARK;
a1894d81 1711 static const char* const oom_list_extend = "Out of memory during list extend";
0bd48802
AL		 1712 const I32 items = SP - MARK;
1713 const I32 max = items * count;
da9e430b 1714 const U8 mod = PL_op->op_flags & OPf_MOD;
79072805 1715
2b573ace
JH		 1716 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1717 /* Did the max computation overflow? */
27d5b266 1718 if (items > 0 && max > 0 && (max < items || max < count))
0157ef98 1719 Perl_croak(aTHX_ "%s", oom_list_extend);
a0d0e21e
LW		 1720 MEXTEND(MARK, max);
1721 if (count > 1) {
1722 while (SP > MARK) {
60779a30
DM		 1723 if (*SP) {
1724 if (mod && SvPADTMP(*SP)) {
da9e430b 1725 *SP = sv_mortalcopy(*SP);
60779a30 1726 }
976c8a39 1727 SvTEMP_off((*SP));
da9e430b 1728 }
a0d0e21e 1729 SP--;
79072805 1730 }
a0d0e21e
LW		 1731 MARK++;
1732 repeatcpy((char*)(MARK + items), (char*)MARK,
ad64d0ec 1733 items * sizeof(const SV *), count - 1);
a0d0e21e 1734 SP += max;
79072805 1735 }
a0d0e21e
LW		 1736 else if (count <= 0)
1737 SP -= items;
79072805 1738 }
a0d0e21e 1739 else { /* Note: mark already snarfed by pp_list */
0bd48802 1740 SV * const tmpstr = POPs;
a0d0e21e 1741 STRLEN len;
9b877dbb 1742 bool isutf;
a1894d81 1743 static const char* const oom_string_extend =
2b573ace 1744 "Out of memory during string extend";
a0d0e21e 1745
6f1401dc
DM		 1746 if (TARG != tmpstr)
1747 sv_setsv_nomg(TARG, tmpstr);
1748 SvPV_force_nomg(TARG, len);
9b877dbb 1749 isutf = DO_UTF8(TARG);
8ebc5c01 1750 if (count != 1) {
1751 if (count < 1)
1752 SvCUR_set(TARG, 0);
1753 else {
c445ea15 1754 const STRLEN max = (UV)count * len;
19a94d75 1755 if (len > MEM_SIZE_MAX / count)
0157ef98 1756 Perl_croak(aTHX_ "%s", oom_string_extend);
2b573ace 1757 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
8569b9dc 1758 SvGROW(TARG, max + 1);
a0d0e21e 1759 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
b162af07 1760 SvCUR_set(TARG, SvCUR(TARG) * count);
7a4c00b4 1761 }
a0d0e21e 1762 *SvEND(TARG) = '\0';
a0d0e21e 1763 }
dfcb284a
GS		 1764 if (isutf)
1765 (void)SvPOK_only_UTF8(TARG);
1766 else
1767 (void)SvPOK_only(TARG);
b80b6069 1768
a0d0e21e 1769 PUSHTARG;
79072805 1770 }
a0d0e21e
LW		 1771 RETURN;
1772}
79072805 1773
a0d0e21e
LW		 1774PP(pp_subtract)
1775{
20b7effb 1776 dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM		 1777 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1778 svr = TOPs;
1779 svl = TOPm1s;
800401ee 1780 useleft = USE_LEFT(svl);
28e5dec8 1781#ifdef PERL_PRESERVE_IVUV
7dca457a
NC		 1782 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1783 "bad things" happen if you rely on signed integers wrapping. */
01f91bf2 1784 if (SvIV_please_nomg(svr)) {
28e5dec8
JH		 1785 /* Unless the left argument is integer in range we are going to have to
1786 use NV maths. Hence only attempt to coerce the right argument if
1787 we know the left is integer. */
eb578fdb 1788 UV auv = 0;
9c5ffd7c 1789 bool auvok = FALSE;
7dca457a
NC		 1790 bool a_valid = 0;
1791
28e5dec8 1792 if (!useleft) {
7dca457a
NC		 1793 auv = 0;
1794 a_valid = auvok = 1;
1795 /* left operand is undef, treat as zero. */
28e5dec8
JH		 1796 } else {
1797 /* Left operand is defined, so is it IV? */
01f91bf2 1798 if (SvIV_please_nomg(svl)) {
800401ee
JH		 1799 if ((auvok = SvUOK(svl)))
1800 auv = SvUVX(svl);
7dca457a 1801 else {
eb578fdb 1802 const IV aiv = SvIVX(svl);
7dca457a
NC		 1803 if (aiv >= 0) {
1804 auv = aiv;
1805 auvok = 1; /* Now acting as a sign flag. */
1806 } else { /* 2s complement assumption for IV_MIN */
53e2bfb7 1807 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
28e5dec8 1808 }
7dca457a
NC		 1809 }
1810 a_valid = 1;
1811 }
1812 }
1813 if (a_valid) {
1814 bool result_good = 0;
1815 UV result;
eb578fdb 1816 UV buv;
800401ee 1817 bool buvok = SvUOK(svr);
9041c2e3 1818
7dca457a 1819 if (buvok)
800401ee 1820 buv = SvUVX(svr);
7dca457a 1821 else {
eb578fdb 1822 const IV biv = SvIVX(svr);
7dca457a
NC		 1823 if (biv >= 0) {
1824 buv = biv;
1825 buvok = 1;
1826 } else
53e2bfb7 1827 buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
7dca457a
NC		 1828 }
1829 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1830 else "IV" now, independent of how it came in.
7dca457a
NC		 1831 if a, b represents positive, A, B negative, a maps to -A etc
1832 a - b => (a - b)
1833 A - b => -(a + b)
1834 a - B => (a + b)
1835 A - B => -(a - b)
1836 all UV maths. negate result if A negative.
1837 subtract if signs same, add if signs differ. */
1838
1839 if (auvok ^ buvok) {
1840 /* Signs differ. */
1841 result = auv + buv;
1842 if (result >= auv)
1843 result_good = 1;
1844 } else {
1845 /* Signs same */
1846 if (auv >= buv) {
1847 result = auv - buv;
1848 /* Must get smaller */
1849 if (result <= auv)
1850 result_good = 1;
1851 } else {
1852 result = buv - auv;
1853 if (result <= buv) {
1854 /* result really should be -(auv-buv). as its negation
1855 of true value, need to swap our result flag */
1856 auvok = !auvok;
1857 result_good = 1;
28e5dec8 1858 }
28e5dec8
JH		 1859 }
1860 }
7dca457a
NC		 1861 if (result_good) {
1862 SP--;
1863 if (auvok)
1864 SETu( result );
1865 else {
1866 /* Negate result */
1867 if (result <= (UV)IV_MIN)
53e2bfb7
DM		 1868 SETi(result == (UV)IV_MIN
1869 ? IV_MIN : -(IV)result);
7dca457a
NC		 1870 else {
1871 /* result valid, but out of range for IV. */
1872 SETn( -(NV)result );
1873 }
1874 }
1875 RETURN;
1876 } /* Overflow, drop through to NVs. */
28e5dec8
JH		 1877 }
1878 }
1879#endif
a0d0e21e 1880 {
6f1401dc 1881 NV value = SvNV_nomg(svr);
4efa5a16
RD		 1882 (void)POPs;
1883
28e5dec8
JH		 1884 if (!useleft) {
1885 /* left operand is undef, treat as zero - value */
1886 SETn(-value);
1887 RETURN;
1888 }
6f1401dc 1889 SETn( SvNV_nomg(svl) - value );
28e5dec8 1890 RETURN;
79072805 1891 }
a0d0e21e 1892}
79072805 1893
a0d0e21e
LW		 1894PP(pp_left_shift)
1895{
20b7effb 1896 dSP; dATARGET; SV *svl, *svr;
a42d0242 1897 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM		 1898 svr = POPs;
1899 svl = TOPs;
a0d0e21e 1900 {
6f1401dc 1901 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1902 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1903 const IV i = SvIV_nomg(svl);
972b05a9 1904 SETi(i << shift);
d0ba1bd2
JH		 1905 }
1906 else {
6f1401dc 1907 const UV u = SvUV_nomg(svl);
972b05a9 1908 SETu(u << shift);
d0ba1bd2 1909 }
55497cff 1910 RETURN;
79072805 1911 }
a0d0e21e 1912}
79072805 1913
a0d0e21e
LW		 1914PP(pp_right_shift)
1915{
20b7effb 1916 dSP; dATARGET; SV *svl, *svr;
a42d0242 1917 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM		 1918 svr = POPs;
1919 svl = TOPs;
a0d0e21e 1920 {
6f1401dc 1921 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1922 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1923 const IV i = SvIV_nomg(svl);
972b05a9 1924 SETi(i >> shift);
d0ba1bd2
JH		 1925 }
1926 else {
6f1401dc 1927 const UV u = SvUV_nomg(svl);
972b05a9 1928 SETu(u >> shift);
d0ba1bd2 1929 }
a0d0e21e 1930 RETURN;
93a17b20 1931 }
79072805
LW		 1932}
1933
a0d0e21e 1934PP(pp_lt)
79072805 1935{
20b7effb 1936 dSP;
33efebe6
DM		 1937 SV *left, *right;
1938
a42d0242 1939 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
33efebe6
DM		 1940 right = POPs;
1941 left = TOPs;
1942 SETs(boolSV(
1943 (SvIOK_notUV(left) && SvIOK_notUV(right))
1944 ? (SvIVX(left) < SvIVX(right))
1945 : (do_ncmp(left, right) == -1)
1946 ));
1947 RETURN;
a0d0e21e 1948}
79072805 1949
a0d0e21e
LW		 1950PP(pp_gt)
1951{
20b7effb 1952 dSP;
33efebe6 1953 SV *left, *right;
1b6737cc 1954
33efebe6
DM		 1955 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1956 right = POPs;
1957 left = TOPs;
1958 SETs(boolSV(
1959 (SvIOK_notUV(left) && SvIOK_notUV(right))
1960 ? (SvIVX(left) > SvIVX(right))
1961 : (do_ncmp(left, right) == 1)
1962 ));
1963 RETURN;
a0d0e21e
LW		 1964}
1965
1966PP(pp_le)
1967{
20b7effb 1968 dSP;
33efebe6 1969 SV *left, *right;
1b6737cc 1970
33efebe6
DM		 1971 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1972 right = POPs;
1973 left = TOPs;
1974 SETs(boolSV(
1975 (SvIOK_notUV(left) && SvIOK_notUV(right))
1976 ? (SvIVX(left) <= SvIVX(right))
1977 : (do_ncmp(left, right) <= 0)
1978 ));
1979 RETURN;
a0d0e21e
LW		 1980}
1981
1982PP(pp_ge)
1983{
20b7effb 1984 dSP;
33efebe6
DM		 1985 SV *left, *right;
1986
1987 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1988 right = POPs;
1989 left = TOPs;
1990 SETs(boolSV(
1991 (SvIOK_notUV(left) && SvIOK_notUV(right))
1992 ? (SvIVX(left) >= SvIVX(right))
1993 : ( (do_ncmp(left, right) & 2) == 0)
1994 ));
1995 RETURN;
1996}
1b6737cc 1997
33efebe6
DM		 1998PP(pp_ne)
1999{
20b7effb 2000 dSP;
33efebe6
DM		 2001 SV *left, *right;
2002
2003 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2004 right = POPs;
2005 left = TOPs;
2006 SETs(boolSV(
2007 (SvIOK_notUV(left) && SvIOK_notUV(right))
2008 ? (SvIVX(left) != SvIVX(right))
2009 : (do_ncmp(left, right) != 0)
2010 ));
2011 RETURN;
2012}
1b6737cc 2013
33efebe6
DM		 2014/* compare left and right SVs. Returns:
2015 * -1: <
2016 * 0: ==
2017 * 1: >
2018 * 2: left or right was a NaN
2019 */
2020I32
2021Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2022{
33efebe6
DM		 2023 PERL_ARGS_ASSERT_DO_NCMP;
2024#ifdef PERL_PRESERVE_IVUV
33efebe6 2025 /* Fortunately it seems NaN isn't IOK */
01f91bf2 2026 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
33efebe6
DM		 2027 if (!SvUOK(left)) {
2028 const IV leftiv = SvIVX(left);
2029 if (!SvUOK(right)) {
2030 /* ## IV <=> IV ## */
2031 const IV rightiv = SvIVX(right);
2032 return (leftiv > rightiv) - (leftiv < rightiv);
28e5dec8 2033 }
33efebe6
DM		 2034 /* ## IV <=> UV ## */
2035 if (leftiv < 0)
2036 /* As (b) is a UV, it's >=0, so it must be < */
2037 return -1;
2038 {
2039 const UV rightuv = SvUVX(right);
2040 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
28e5dec8 2041 }
28e5dec8 2042 }
79072805 2043
33efebe6
DM		 2044 if (SvUOK(right)) {
2045 /* ## UV <=> UV ## */
2046 const UV leftuv = SvUVX(left);
2047 const UV rightuv = SvUVX(right);
2048 return (leftuv > rightuv) - (leftuv < rightuv);
28e5dec8 2049 }
33efebe6
DM		 2050 /* ## UV <=> IV ## */
2051 {
2052 const IV rightiv = SvIVX(right);
2053 if (rightiv < 0)
2054 /* As (a) is a UV, it's >=0, so it cannot be < */
2055 return 1;
2056 {
2057 const UV leftuv = SvUVX(left);
2058 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
28e5dec8 2059 }
28e5dec8 2060 }
e5964223 2061 NOT_REACHED; /* NOTREACHED */
28e5dec8
JH		 2062 }
2063#endif
a0d0e21e 2064 {
33efebe6
DM		 2065 NV const rnv = SvNV_nomg(right);
2066 NV const lnv = SvNV_nomg(left);
2067
cab190d4 2068#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
33efebe6
DM		 2069 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2070 return 2;
2071 }
2072 return (lnv > rnv) - (lnv < rnv);
cab190d4 2073#else
33efebe6
DM		 2074 if (lnv < rnv)
2075 return -1;
2076 if (lnv > rnv)
2077 return 1;
659c4b96 2078 if (lnv == rnv)
33efebe6
DM		 2079 return 0;
2080 return 2;
cab190d4 2081#endif
a0d0e21e 2082 }
79072805
LW		 2083}
2084
33efebe6 2085
a0d0e21e 2086PP(pp_ncmp)
79072805 2087{
20b7effb 2088 dSP;
33efebe6
DM		 2089 SV *left, *right;
2090 I32 value;
a42d0242 2091 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
33efebe6
DM		 2092 right = POPs;
2093 left = TOPs;
2094 value = do_ncmp(left, right);
2095 if (value == 2) {
3280af22 2096 SETs(&PL_sv_undef);
79072805 2097 }
33efebe6
DM		 2098 else {
2099 dTARGET;
2100 SETi(value);
2101 }
2102 RETURN;
a0d0e21e 2103}
79072805 2104
b1c05ba5
DM		 2105
2106/* also used for: pp_sge() pp_sgt() pp_slt() */
2107
afd9910b 2108PP(pp_sle)
a0d0e21e 2109{
20b7effb 2110 dSP;
79072805 2111
afd9910b
NC		 2112 int amg_type = sle_amg;
2113 int multiplier = 1;
2114 int rhs = 1;
79072805 2115
afd9910b
NC		 2116 switch (PL_op->op_type) {
2117 case OP_SLT:
2118 amg_type = slt_amg;
2119 /* cmp < 0 */
2120 rhs = 0;
2121 break;
2122 case OP_SGT:
2123 amg_type = sgt_amg;
2124 /* cmp > 0 */
2125 multiplier = -1;
2126 rhs = 0;
2127 break;
2128 case OP_SGE:
2129 amg_type = sge_amg;
2130 /* cmp >= 0 */
2131 multiplier = -1;
2132 break;
79072805 2133 }
79072805 2134
6f1401dc 2135 tryAMAGICbin_MG(amg_type, AMGf_set);
a0d0e21e
LW		 2136 {
2137 dPOPTOPssrl;
130c5df3 2138 const int cmp =
5778acb6 2139#ifdef USE_LOCALE_COLLATE
130c5df3
KW		 2140 (IN_LC_RUNTIME(LC_COLLATE))
2141 ? sv_cmp_locale_flags(left, right, 0)
2142 :
2143#endif
2144 sv_cmp_flags(left, right, 0);
afd9910b 2145 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW		 2146 RETURN;
2147 }
2148}
79072805 2149
36477c24 2150PP(pp_seq)
2151{
20b7effb 2152 dSP;
6f1401dc 2153 tryAMAGICbin_MG(seq_amg, AMGf_set);
36477c24 2154 {
2155 dPOPTOPssrl;
078504b2 2156 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW		 2157 RETURN;
2158 }
2159}
79072805 2160
a0d0e21e 2161PP(pp_sne)
79072805 2162{
20b7effb 2163 dSP;
6f1401dc 2164 tryAMAGICbin_MG(sne_amg, AMGf_set);
a0d0e21e
LW		 2165 {
2166 dPOPTOPssrl;
078504b2 2167 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2168 RETURN;
463ee0b2 2169 }
79072805
LW		 2170}
2171
a0d0e21e 2172PP(pp_scmp)
79072805 2173{
20b7effb 2174 dSP; dTARGET;
6f1401dc 2175 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW		 2176 {
2177 dPOPTOPssrl;
130c5df3 2178 const int cmp =
5778acb6 2179#ifdef USE_LOCALE_COLLATE
130c5df3
KW		 2180 (IN_LC_RUNTIME(LC_COLLATE))
2181 ? sv_cmp_locale_flags(left, right, 0)
2182 :
2183#endif
2184 sv_cmp_flags(left, right, 0);
bbce6d69 2185 SETi( cmp );
a0d0e21e
LW		 2186 RETURN;
2187 }
2188}
79072805 2189
55497cff 2190PP(pp_bit_and)
2191{
20b7effb 2192 dSP; dATARGET;
6f1401dc 2193 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW		 2194 {
2195 dPOPTOPssrl;
4633a7c4 2196 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC		 2197 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2198 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2199 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2200 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2201 SETi(i);
d0ba1bd2
JH		 2202 }
2203 else {
1b6737cc 2204 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2205 SETu(u);
d0ba1bd2 2206 }
5ee80e13 2207 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2208 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW		 2209 }
2210 else {
533c011a 2211 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2212 SETTARG;
2213 }
2214 RETURN;
2215 }
2216}
79072805 2217
b1c05ba5
DM		 2218
2219/* also used for: pp_bit_xor() */
2220
a0d0e21e
LW		 2221PP(pp_bit_or)
2222{
20b7effb 2223 dSP; dATARGET;
3658c1f1
NC		 2224 const int op_type = PL_op->op_type;
2225
6f1401dc 2226 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW		 2227 {
2228 dPOPTOPssrl;
4633a7c4 2229 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC		 2230 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2231 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2232 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC		 2233 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2234 const IV r = SvIV_nomg(right);
2235 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2236 SETi(result);
d0ba1bd2
JH		 2237 }
2238 else {
3658c1f1
NC		 2239 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2240 const UV r = SvUV_nomg(right);
2241 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2242 SETu(result);
d0ba1bd2 2243 }
5ee80e13 2244 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2245 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW		 2246 }
2247 else {
3658c1f1 2248 do_vop(op_type, TARG, left, right);
a0d0e21e
LW		 2249 SETTARG;
2250 }
2251 RETURN;
79072805 2252 }
a0d0e21e 2253}
79072805 2254
1c2b3fd6
FC		 2255PERL_STATIC_INLINE bool
2256S_negate_string(pTHX)
2257{
2258 dTARGET; dSP;
2259 STRLEN len;
2260 const char *s;
2261 SV * const sv = TOPs;
2262 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2263 return FALSE;
2264 s = SvPV_nomg_const(sv, len);
2265 if (isIDFIRST(*s)) {
2266 sv_setpvs(TARG, "-");
2267 sv_catsv(TARG, sv);
2268 }
2269 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2270 sv_setsv_nomg(TARG, sv);
2271 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2272 }
2273 else return FALSE;
245d035e 2274 SETTARG;
1c2b3fd6
FC		 2275 return TRUE;
2276}
2277
a0d0e21e
LW		 2278PP(pp_negate)
2279{
20b7effb 2280 dSP; dTARGET;
6f1401dc 2281 tryAMAGICun_MG(neg_amg, AMGf_numeric);
1c2b3fd6 2282 if (S_negate_string(aTHX)) return NORMAL;
a0d0e21e 2283 {
6f1401dc 2284 SV * const sv = TOPs;
a5b92898 2285
d96ab1b5 2286 if (SvIOK(sv)) {
7dbe3150 2287 /* It's publicly an integer */
28e5dec8 2288 oops_its_an_int:
9b0e499b
GS		 2289 if (SvIsUV(sv)) {
2290 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2291 /* 2s complement assumption. */
d14578b8
KW		 2292 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2293 IV_MIN */
245d035e 2294 return NORMAL;
9b0e499b
GS		 2295 }
2296 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2297 SETi(-SvIVX(sv));
245d035e 2298 return NORMAL;
9b0e499b
GS		 2299 }
2300 }
2301 else if (SvIVX(sv) != IV_MIN) {
2302 SETi(-SvIVX(sv));
245d035e 2303 return NORMAL;
9b0e499b 2304 }
28e5dec8
JH		 2305#ifdef PERL_PRESERVE_IVUV
2306 else {
2307 SETu((UV)IV_MIN);
245d035e 2308 return NORMAL;
28e5dec8
JH		 2309 }
2310#endif
9b0e499b 2311 }
8a5decd8 2312 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
6f1401dc 2313 SETn(-SvNV_nomg(sv));
1c2b3fd6 2314 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
8eb28a70 2315 goto oops_its_an_int;
4633a7c4 2316 else
6f1401dc 2317 SETn(-SvNV_nomg(sv));
79072805 2318 }
245d035e 2319 return NORMAL;
79072805
LW		 2320}
2321
a0d0e21e 2322PP(pp_not)
79072805 2323{
20b7effb 2324 dSP;
6f1401dc 2325 tryAMAGICun_MG(not_amg, AMGf_set);
06c841cf 2326 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
a0d0e21e 2327 return NORMAL;
79072805
LW		 2328}
2329
a0d0e21e 2330PP(pp_complement)
79072805 2331{
20b7effb 2332 dSP; dTARGET;
a42d0242 2333 tryAMAGICun_MG(compl_amg, AMGf_numeric);
a0d0e21e
LW		 2334 {
2335 dTOPss;
4633a7c4 2336 if (SvNIOKp(sv)) {
d0ba1bd2 2337 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2338 const IV i = ~SvIV_nomg(sv);
972b05a9 2339 SETi(i);
d0ba1bd2
JH		 2340 }
2341 else {
1b6737cc 2342 const UV u = ~SvUV_nomg(sv);
972b05a9 2343 SETu(u);
d0ba1bd2 2344 }
a0d0e21e
LW		 2345 }
2346 else {
eb578fdb
KW		 2347 U8 *tmps;
2348 I32 anum;
a0d0e21e
LW		 2349 STRLEN len;
2350
85b0ee6e
FC		 2351 sv_copypv_nomg(TARG, sv);
2352 tmps = (U8*)SvPV_nomg(TARG, len);
a0d0e21e 2353 anum = len;
1d68d6cd 2354 if (SvUTF8(TARG)) {
a1ca4561 2355 /* Calculate exact length, let's not estimate. */
1d68d6cd 2356 STRLEN targlen = 0;
ba210ebe 2357 STRLEN l;
a1ca4561
YST		 2358 UV nchar = 0;
2359 UV nwide = 0;
01f6e806 2360 U8 * const send = tmps + len;
74d49cd0
TS		 2361 U8 * const origtmps = tmps;
2362 const UV utf8flags = UTF8_ALLOW_ANYUV;
1d68d6cd 2363
1d68d6cd 2364 while (tmps < send) {
74d49cd0
TS		 2365 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2366 tmps += l;
5bbb0b5a 2367 targlen += UNISKIP(~c);
a1ca4561
YST		 2368 nchar++;
2369 if (c > 0xff)
2370 nwide++;
1d68d6cd
SC		 2371 }
2372
2373 /* Now rewind strings and write them. */
74d49cd0 2374 tmps = origtmps;
a1ca4561
YST		 2375
2376 if (nwide) {
01f6e806
AL		 2377 U8 *result;
2378 U8 *p;
2379
74d49cd0 2380 Newx(result, targlen + 1, U8);
01f6e806 2381 p = result;
a1ca4561 2382 while (tmps < send) {
74d49cd0
TS		 2383 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2384 tmps += l;
01f6e806 2385 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
a1ca4561 2386 }
01f6e806 2387 *p = '\0';
c1c21316
NC		 2388 sv_usepvn_flags(TARG, (char*)result, targlen,
2389 SV_HAS_TRAILING_NUL);
a1ca4561
YST		 2390 SvUTF8_on(TARG);
2391 }
2392 else {
01f6e806
AL		 2393 U8 *result;
2394 U8 *p;
2395
74d49cd0 2396 Newx(result, nchar + 1, U8);
01f6e806 2397 p = result;
a1ca4561 2398 while (tmps < send) {
74d49cd0
TS		 2399 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2400 tmps += l;
01f6e806 2401 *p++ = ~c;
a1ca4561 2402 }
01f6e806 2403 *p = '\0';
c1c21316 2404 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
d0a21e00 2405 SvUTF8_off(TARG);
1d68d6cd 2406 }
ec93b65f 2407 SETTARG;
24840750 2408 return NORMAL;
1d68d6cd 2409 }
a0d0e21e 2410#ifdef LIBERAL
51723571 2411 {
eb578fdb 2412 long *tmpl;
51723571
JH		 2413 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2414 *tmps = ~*tmps;
2415 tmpl = (long*)tmps;
bb7a0f54 2416 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH		 2417 *tmpl = ~*tmpl;
2418 tmps = (U8*)tmpl;
2419 }
a0d0e21e
LW		 2420#endif
2421 for ( ; anum > 0; anum--, tmps++)
2422 *tmps = ~*tmps;
ec93b65f 2423 SETTARG;
a0d0e21e 2424 }
24840750 2425 return NORMAL;
a0d0e21e 2426 }
79072805
LW		 2427}
2428
a0d0e21e
LW		 2429/* integer versions of some of the above */
2430
a0d0e21e 2431PP(pp_i_multiply)
79072805 2432{
20b7effb 2433 dSP; dATARGET;
6f1401dc 2434 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2435 {
6f1401dc 2436 dPOPTOPiirl_nomg;
a0d0e21e
LW		 2437 SETi( left * right );
2438 RETURN;
2439 }
79072805
LW		 2440}
2441
a0d0e21e 2442PP(pp_i_divide)
79072805 2443{
85935d8e 2444 IV num;
20b7effb 2445 dSP; dATARGET;
6f1401dc 2446 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2447 {
6f1401dc 2448 dPOPTOPssrl;
85935d8e 2449 IV value = SvIV_nomg(right);
a0d0e21e 2450 if (value == 0)
ece1bcef 2451 DIE(aTHX_ "Illegal division by zero");
85935d8e 2452 num = SvIV_nomg(left);
a0cec769
YST		 2453
2454 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2455 if (value == -1)
2456 value = - num;
2457 else
2458 value = num / value;
6f1401dc 2459 SETi(value);
a0d0e21e
LW		 2460 RETURN;
2461 }
79072805
LW		 2462}
2463
bf3d06aa
JC		 2464#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2465 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
224ec323
JH		 2466STATIC
2467PP(pp_i_modulo_0)
befad5d1
NC		 2468#else
2469PP(pp_i_modulo)
2470#endif
224ec323
JH		 2471{
2472 /* This is the vanilla old i_modulo. */
20b7effb 2473 dSP; dATARGET;
6f1401dc 2474 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2475 {
6f1401dc 2476 dPOPTOPiirl_nomg;
224ec323
JH		 2477 if (!right)
2478 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST		 2479 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2480 if (right == -1)
2481 SETi( 0 );
2482 else
2483 SETi( left % right );
224ec323
JH		 2484 RETURN;
2485 }
2486}
2487
bf3d06aa
JC		 2488#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2489 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
224ec323
JH		 2490STATIC
2491PP(pp_i_modulo_1)
befad5d1 2492
224ec323 2493{
224ec323 2494 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2495 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2496 * See below for pp_i_modulo. */
20b7effb 2497 dSP; dATARGET;
6f1401dc 2498 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2499 {
6f1401dc 2500 dPOPTOPiirl_nomg;
224ec323
JH		 2501 if (!right)
2502 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST		 2503 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2504 if (right == -1)
2505 SETi( 0 );
2506 else
2507 SETi( left % PERL_ABS(right) );
224ec323
JH		 2508 RETURN;
2509 }
224ec323
JH		 2510}
2511
a0d0e21e 2512PP(pp_i_modulo)
79072805 2513{
6f1401dc
DM		 2514 dVAR; dSP; dATARGET;
2515 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2516 {
6f1401dc 2517 dPOPTOPiirl_nomg;
224ec323
JH		 2518 if (!right)
2519 DIE(aTHX_ "Illegal modulus zero");
2520 /* The assumption is to use hereafter the old vanilla version... */
2521 PL_op->op_ppaddr =
2522 PL_ppaddr[OP_I_MODULO] =
1c127fab 2523 Perl_pp_i_modulo_0;
224ec323 2524 /* .. but if we have glibc, we might have a buggy _moddi3
bf3d06aa 2525 * (at least glibc 2.2.5 is known to have this bug), in other
224ec323
JH		 2526 * words our integer modulus with negative quad as the second
2527 * argument might be broken. Test for this and re-patch the
2528 * opcode dispatch table if that is the case, remembering to
2529 * also apply the workaround so that this first round works
2530 * right, too. See [perl #9402] for more information. */
224ec323
JH		 2531 {
2532 IV l = 3;
2533 IV r = -10;
2534 /* Cannot do this check with inlined IV constants since
2535 * that seems to work correctly even with the buggy glibc. */
2536 if (l % r == -3) {
2537 /* Yikes, we have the bug.
2538 * Patch in the workaround version. */
2539 PL_op->op_ppaddr =
2540 PL_ppaddr[OP_I_MODULO] =
2541 &Perl_pp_i_modulo_1;
2542 /* Make certain we work right this time, too. */
32fdb065 2543 right = PERL_ABS(right);
224ec323
JH		 2544 }
2545 }
a0cec769
YST		 2546 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2547 if (right == -1)
2548 SETi( 0 );
2549 else
2550 SETi( left % right );
224ec323
JH		 2551 RETURN;
2552 }
79072805 2553}
befad5d1 2554#endif
79072805 2555
a0d0e21e 2556PP(pp_i_add)
79072805 2557{
20b7effb 2558 dSP; dATARGET;
6f1401dc 2559 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2560 {
6f1401dc 2561 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW		 2562 SETi( left + right );
2563 RETURN;
79072805 2564 }
79072805
LW		 2565}
2566
a0d0e21e 2567PP(pp_i_subtract)
79072805 2568{
20b7effb 2569 dSP; dATARGET;
6f1401dc 2570 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2571 {
6f1401dc 2572 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW		 2573 SETi( left - right );
2574 RETURN;
79072805 2575 }
79072805
LW		 2576}
2577
a0d0e21e 2578PP(pp_i_lt)
79072805 2579{
20b7effb 2580 dSP;
6f1401dc 2581 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2582 {
96b6b87f 2583 dPOPTOPiirl_nomg;
54310121 2584 SETs(boolSV(left < right));
a0d0e21e
LW		 2585 RETURN;
2586 }
79072805
LW		 2587}
2588
a0d0e21e 2589PP(pp_i_gt)
79072805 2590{
20b7effb 2591 dSP;
6f1401dc 2592 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2593 {
96b6b87f 2594 dPOPTOPiirl_nomg;
54310121 2595 SETs(boolSV(left > right));
a0d0e21e
LW		 2596 RETURN;
2597 }
79072805
LW		 2598}
2599
a0d0e21e 2600PP(pp_i_le)
79072805 2601{
20b7effb 2602 dSP;
6f1401dc 2603 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 2604 {
96b6b87f 2605 dPOPTOPiirl_nomg;
54310121 2606 SETs(boolSV(left <= right));
a0d0e21e 2607 RETURN;
85e6fe83 2608 }
79072805
LW		 2609}
2610
a0d0e21e 2611PP(pp_i_ge)
79072805 2612{
20b7effb 2613 dSP;
6f1401dc 2614 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 2615 {
96b6b87f 2616 dPOPTOPiirl_nomg;
54310121 2617 SETs(boolSV(left >= right));
a0d0e21e
LW		 2618 RETURN;
2619 }
79072805
LW		 2620}
2621
a0d0e21e 2622PP(pp_i_eq)
79072805 2623{
20b7effb 2624 dSP;
6f1401dc 2625 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 2626 {
96b6b87f 2627 dPOPTOPiirl_nomg;
54310121 2628 SETs(boolSV(left == right));
a0d0e21e
LW		 2629 RETURN;
2630 }
79072805
LW		 2631}
2632
a0d0e21e 2633PP(pp_i_ne)
79072805 2634{
20b7effb 2635 dSP;
6f1401dc 2636 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 2637 {
96b6b87f 2638 dPOPTOPiirl_nomg;
54310121 2639 SETs(boolSV(left != right));
a0d0e21e
LW		 2640 RETURN;
2641 }
79072805
LW		 2642}
2643
a0d0e21e 2644PP(pp_i_ncmp)
79072805 2645{
20b7effb 2646 dSP; dTARGET;
6f1401dc 2647 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2648 {
96b6b87f 2649 dPOPTOPiirl_nomg;
a0d0e21e 2650 I32 value;
79072805 2651
a0d0e21e 2652 if (left > right)
79072805 2653 value = 1;
a0d0e21e 2654 else if (left < right)
79072805 2655 value = -1;
a0d0e21e 2656 else
79072805 2657 value = 0;
a0d0e21e
LW		 2658 SETi(value);
2659 RETURN;
79072805 2660 }
85e6fe83
LW		 2661}
2662
2663PP(pp_i_negate)
2664{
20b7effb 2665 dSP; dTARGET;
6f1401dc 2666 tryAMAGICun_MG(neg_amg, 0);
1c2b3fd6 2667 if (S_negate_string(aTHX)) return NORMAL;
6f1401dc
DM		 2668 {
2669 SV * const sv = TOPs;
2670 IV const i = SvIV_nomg(sv);
2671 SETi(-i);
ae642386 2672 return NORMAL;
6f1401dc 2673 }
85e6fe83
LW		 2674}
2675
79072805
LW		 2676/* High falutin' math. */
2677
2678PP(pp_atan2)
2679{
20b7effb 2680 dSP; dTARGET;
6f1401dc 2681 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2682 {
096c060c 2683 dPOPTOPnnrl_nomg;
a1021d57 2684 SETn(Perl_atan2(left, right));
a0d0e21e
LW		 2685 RETURN;
2686 }
79072805
LW		 2687}
2688
b1c05ba5
DM		 2689
2690/* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2691
79072805
LW		 2692PP(pp_sin)
2693{
20b7effb 2694 dSP; dTARGET;
af71714e 2695 int amg_type = fallback_amg;
71302fe3 2696 const char *neg_report = NULL;
71302fe3
NC		 2697 const int op_type = PL_op->op_type;
2698
2699 switch (op_type) {
af71714e
JH		 2700 case OP_SIN: amg_type = sin_amg; break;
2701 case OP_COS: amg_type = cos_amg; break;
2702 case OP_EXP: amg_type = exp_amg; break;
2703 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2704 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
a0d0e21e 2705 }
79072805 2706
af71714e 2707 assert(amg_type != fallback_amg);
6f1401dc
DM		 2708
2709 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 2710 {
8c78ed36 2711 SV * const arg = TOPs;
6f1401dc 2712 const NV value = SvNV_nomg(arg);
f256868e 2713 NV result = NV_NAN;
af71714e 2714 if (neg_report) { /* log or sqrt */
a3463d96
DD		 2715 if (
2716#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2717 ! Perl_isnan(value) &&
2718#endif
2719 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
71302fe3 2720 SET_NUMERIC_STANDARD();
dcbac5bb 2721 /* diag_listed_as: Can't take log of %g */
71302fe3
NC		 2722 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2723 }
2724 }
af71714e 2725 switch (op_type) {
f256868e 2726 default:
af71714e
JH		 2727 case OP_SIN: result = Perl_sin(value); break;
2728 case OP_COS: result = Perl_cos(value); break;
2729 case OP_EXP: result = Perl_exp(value); break;
2730 case OP_LOG: result = Perl_log(value); break;
2731 case OP_SQRT: result = Perl_sqrt(value); break;
2732 }
8c78ed36
FC		 2733 SETn(result);
2734 return NORMAL;
a0d0e21e 2735 }
79072805
LW		 2736}
2737
56cb0a1c
AD		 2738/* Support Configure command-line overrides for rand() functions.
2739 After 5.005, perhaps we should replace this by Configure support
2740 for drand48(), random(), or rand(). For 5.005, though, maintain
2741 compatibility by calling rand() but allow the user to override it.
2742 See INSTALL for details. --Andy Dougherty 15 July 1998
2743*/
85ab1d1d
JH		 2744/* Now it's after 5.005, and Configure supports drand48() and random(),
2745 in addition to rand(). So the overrides should not be needed any more.
2746 --Jarkko Hietaniemi 27 September 1998
2747 */
2748
79072805
LW		 2749PP(pp_rand)
2750{
80252599 2751 if (!PL_srand_called) {
85ab1d1d 2752 (void)seedDrand01((Rand_seed_t)seed());
80252599 2753 PL_srand_called = TRUE;
93dc8474 2754 }
fdf4dddd
DD		 2755 {
2756 dSP;
2757 NV value;
fdf4dddd
DD		 2758
2759 if (MAXARG < 1)
7e9044f9
FC		 2760 {
2761 EXTEND(SP, 1);
fdf4dddd 2762 value = 1.0;
7e9044f9 2763 }
fdf4dddd
DD		 2764 else {
2765 SV * const sv = POPs;
2766 if(!sv)
2767 value = 1.0;
2768 else
2769 value = SvNV(sv);
2770 }
2771 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
a3463d96
DD		 2772#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2773 if (! Perl_isnan(value) && value == 0.0)
2774#else
659c4b96 2775 if (value == 0.0)
a3463d96 2776#endif
fdf4dddd
DD		 2777 value = 1.0;
2778 {
2779 dTARGET;
2780 PUSHs(TARG);
2781 PUTBACK;
2782 value *= Drand01();
2783 sv_setnv_mg(TARG, value);
2784 }
2785 }
2786 return NORMAL;
79072805
LW		 2787}
2788
2789PP(pp_srand)
2790{
20b7effb 2791 dSP; dTARGET;
f914a682
JL		 2792 UV anum;
2793
0a5f3363 2794 if (MAXARG >= 1 && (TOPs || POPs)) {
f914a682
JL		 2795 SV *top;
2796 char *pv;
2797 STRLEN len;
2798 int flags;
2799
2800 top = POPs;
2801 pv = SvPV(top, len);
2802 flags = grok_number(pv, len, &anum);
2803
2804 if (!(flags & IS_NUMBER_IN_UV)) {
2805 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2806 "Integer overflow in srand");
2807 anum = UV_MAX;
2808 }
2809 }
2810 else {
2811 anum = seed();
2812 }
2813
85ab1d1d 2814 (void)seedDrand01((Rand_seed_t)anum);
80252599 2815 PL_srand_called = TRUE;
da1010ec
NC		 2816 if (anum)
2817 XPUSHu(anum);
2818 else {
2819 /* Historically srand always returned true. We can avoid breaking
2820 that like this: */
2821 sv_setpvs(TARG, "0 but true");
2822 XPUSHTARG;
2823 }
83832992 2824 RETURN;
79072805
LW		 2825}
2826
79072805
LW		 2827PP(pp_int)
2828{
20b7effb 2829 dSP; dTARGET;
6f1401dc 2830 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 2831 {
6f1401dc
DM		 2832 SV * const sv = TOPs;
2833 const IV iv = SvIV_nomg(sv);
28e5dec8
JH		 2834 /* XXX it's arguable that compiler casting to IV might be subtly
2835 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2836 else preferring IV has introduced a subtle behaviour change bug. OTOH
2837 relying on floating point to be accurate is a bug. */
2838
c781a409 2839 if (!SvOK(sv)) {
922c4365 2840 SETu(0);
c781a409
RD		 2841 }
2842 else if (SvIOK(sv)) {
2843 if (SvIsUV(sv))
6f1401dc 2844 SETu(SvUV_nomg(sv));
c781a409 2845 else
28e5dec8 2846 SETi(iv);
c781a409 2847 }
c781a409 2848 else {
6f1401dc 2849 const NV value = SvNV_nomg(sv);
b9d05018
FC		 2850 if (UNLIKELY(Perl_isinfnan(value)))
2851 SETn(value);
5bf8b78e 2852 else if (value >= 0.0) {
28e5dec8
JH		 2853 if (value < (NV)UV_MAX + 0.5) {
2854 SETu(U_V(value));
2855 } else {
059a1014 2856 SETn(Perl_floor(value));
28e5dec8 2857 }
1048ea30 2858 }
28e5dec8
JH		 2859 else {
2860 if (value > (NV)IV_MIN - 0.5) {
2861 SETi(I_V(value));
2862 } else {
1bbae031 2863 SETn(Perl_ceil(value));
28e5dec8
JH		 2864 }
2865 }
774d564b 2866 }
79072805 2867 }
699e9491 2868 return NORMAL;
79072805
LW		 2869}
2870
463ee0b2
LW		 2871PP(pp_abs)
2872{
20b7effb 2873 dSP; dTARGET;
6f1401dc 2874 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 2875 {
6f1401dc 2876 SV * const sv = TOPs;
28e5dec8 2877 /* This will cache the NV value if string isn't actually integer */
6f1401dc 2878 const IV iv = SvIV_nomg(sv);
a227d84d 2879
800401ee 2880 if (!SvOK(sv)) {
922c4365 2881 SETu(0);
800401ee
JH		 2882 }
2883 else if (SvIOK(sv)) {
28e5dec8 2884 /* IVX is precise */
800401ee 2885 if (SvIsUV(sv)) {
6f1401dc 2886 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH		 2887 } else {
2888 if (iv >= 0) {
2889 SETi(iv);
2890 } else {
2891 if (iv != IV_MIN) {
2892 SETi(-iv);
2893 } else {
2894 /* 2s complement assumption. Also, not really needed as
2895 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2896 SETu(IV_MIN);
2897 }
a227d84d 2898 }
28e5dec8
JH		 2899 }
2900 } else{
6f1401dc 2901 const NV value = SvNV_nomg(sv);
774d564b 2902 if (value < 0.0)
1b6737cc 2903 SETn(-value);
a4474c9e
DD		 2904 else
2905 SETn(value);
774d564b 2906 }
a0d0e21e 2907 }
067b7929 2908 return NORMAL;
463ee0b2
LW		 2909}
2910
b1c05ba5
DM		 2911
2912/* also used for: pp_hex() */
2913
79072805
LW		 2914PP(pp_oct)
2915{
20b7effb 2916 dSP; dTARGET;
5c144d81 2917 const char *tmps;
53305cf1 2918 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2919 STRLEN len;
53305cf1
NC		 2920 NV result_nv;
2921 UV result_uv;
4e51bcca 2922 SV* const sv = TOPs;
79072805 2923
349d4f2f 2924 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS		 2925 if (DO_UTF8(sv)) {
2926 /* If Unicode, try to downgrade
2927 * If not possible, croak. */
1b6737cc 2928 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS		 2929
2930 SvUTF8_on(tsv);
2931 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2932 tmps = SvPV_const(tsv, len);
2bc69dc4 2933 }
daa2adfd
NC		 2934 if (PL_op->op_type == OP_HEX)
2935 goto hex;
2936
6f894ead 2937 while (*tmps && len && isSPACE(*tmps))
53305cf1 2938 tmps++, len--;
9e24b6e2 2939 if (*tmps == '0')
53305cf1 2940 tmps++, len--;
305b8651 2941 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
daa2adfd 2942 hex:
53305cf1 2943 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 2944 }
305b8651 2945 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
53305cf1 2946 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2947 else
53305cf1
NC		 2948 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2949
2950 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
4e51bcca 2951 SETn(result_nv);
53305cf1
NC		 2952 }
2953 else {
4e51bcca 2954 SETu(result_uv);
53305cf1 2955 }
4e51bcca 2956 return NORMAL;
79072805
LW		 2957}
2958
2959/* String stuff. */
2960
2961PP(pp_length)
2962{
20b7effb 2963 dSP; dTARGET;
0bd48802 2964 SV * const sv = TOPs;
a0ed51b3 2965
7776003e
DD		 2966 U32 in_bytes = IN_BYTES;
2967 /* simplest case shortcut */
2968 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
2969 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
6d59e610 2970 STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
7776003e
DD		 2971 SETs(TARG);
2972
2973 if(LIKELY(svflags == SVf_POK))
2974 goto simple_pv;
2975 if(svflags & SVs_GMG)
2976 mg_get(sv);
0f43fd57 2977 if (SvOK(sv)) {
7776003e
DD		 2978 if (!IN_BYTES) /* reread to avoid using an C auto/register */
2979 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
9f621bb0 2980 else
0f43fd57
FC		 2981 {
2982 STRLEN len;
7776003e
DD		 2983 /* unrolled SvPV_nomg_const(sv,len) */
2984 if(SvPOK_nog(sv)){
2985 simple_pv:
2986 len = SvCUR(sv);
2987 } else {
2988 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
2989 }
2990 sv_setiv(TARG, (IV)(len));
0f43fd57 2991 }
656266fc 2992 } else {
9407f9c1
DL		 2993 if (!SvPADTMP(TARG)) {
2994 sv_setsv_nomg(TARG, &PL_sv_undef);
7776003e
DD		 2995 } else { /* TARG is on stack at this point and is overwriten by SETs.
2996 This branch is the odd one out, so put TARG by default on
2997 stack earlier to let local SP go out of liveness sooner */
2998 SETs(&PL_sv_undef);
2999 goto no_set_magic;
3000 }
92331800 3001 }
7776003e
DD		 3002 SvSETMAGIC(TARG);
3003 no_set_magic:
3004 return NORMAL; /* no putback, SP didn't move in this opcode */
79072805
LW		 3005}
3006
83f78d1a
FC		 3007/* Returns false if substring is completely outside original string.
3008 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3009 always be true for an explicit 0.
3010*/
3011bool
ddeaf645
DD		 3012Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3013 bool pos1_is_uv, IV len_iv,
3014 bool len_is_uv, STRLEN *posp,
3015 STRLEN *lenp)
83f78d1a
FC		 3016{
3017 IV pos2_iv;
3018 int pos2_is_uv;
3019
3020 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3021
3022 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3023 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3024 pos1_iv += curlen;
3025 }
3026 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3027 return FALSE;
3028
3029 if (len_iv || len_is_uv) {
3030 if (!len_is_uv && len_iv < 0) {
3031 pos2_iv = curlen + len_iv;
3032 if (curlen)
3033 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3034 else
3035 pos2_is_uv = 0;
3036 } else { /* len_iv >= 0 */
3037 if (!pos1_is_uv && pos1_iv < 0) {
3038 pos2_iv = pos1_iv + len_iv;
3039 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3040 } else {
3041 if ((UV)len_iv > curlen-(UV)pos1_iv)
3042 pos2_iv = curlen;
3043 else
3044 pos2_iv = pos1_iv+len_iv;
3045 pos2_is_uv = 1;
3046 }
3047 }
3048 }
3049 else {
3050 pos2_iv = curlen;
3051 pos2_is_uv = 1;
3052 }
3053
3054 if (!pos2_is_uv && pos2_iv < 0) {
3055 if (!pos1_is_uv && pos1_iv < 0)
3056 return FALSE;
3057 pos2_iv = 0;
3058 }
3059 else if (!pos1_is_uv && pos1_iv < 0)
3060 pos1_iv = 0;
3061
3062 if ((UV)pos2_iv < (UV)pos1_iv)
3063 pos2_iv = pos1_iv;
3064 if ((UV)pos2_iv > curlen)
3065 pos2_iv = curlen;
3066
3067 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3068 *posp = (STRLEN)( (UV)pos1_iv );
3069 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3070
3071 return TRUE;
3072}
3073
79072805
LW		 3074PP(pp_substr)
3075{
20b7effb 3076 dSP; dTARGET;
79072805 3077 SV *sv;
463ee0b2 3078 STRLEN curlen;
9402d6ed 3079 STRLEN utf8_curlen;
777f7c56
EB		 3080 SV * pos_sv;
3081 IV pos1_iv;
3082 int pos1_is_uv;
777f7c56
EB		 3083 SV * len_sv;
3084 IV len_iv = 0;
83f78d1a 3085 int len_is_uv = 0;
24fcb59f 3086 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 3087 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 3088 const char *tmps;
9402d6ed 3089 SV *repl_sv = NULL;
cbbf8932 3090 const char *repl = NULL;
7b8d334a 3091 STRLEN repl_len;
7bc95ae1 3092 int num_args = PL_op->op_private & 7;
13e30c65 3093 bool repl_need_utf8_upgrade = FALSE;
79072805 3094
78f9721b
SM		 3095 if (num_args > 2) {
3096 if (num_args > 3) {
24fcb59f 3097 if(!(repl_sv = POPs)) num_args--;
7bc95ae1
FC		 3098 }
3099 if ((len_sv = POPs)) {
3100 len_iv = SvIV(len_sv);
83f78d1a 3101 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
7b8d334a 3102 }
7bc95ae1 3103 else num_args--;
5d82c453 3104 }
777f7c56
EB		 3105 pos_sv = POPs;
3106 pos1_iv = SvIV(pos_sv);
3107 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3108 sv = POPs;
24fcb59f
FC		 3109 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3110 assert(!repl_sv);
3111 repl_sv = POPs;
3112 }
6582db62 3113 if (lvalue && !repl_sv) {
83f78d1a
FC		 3114 SV * ret;
3115 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3116 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3117 LvTYPE(ret) = 'x';
3118 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3119 LvTARGOFF(ret) =
3120 pos1_is_uv || pos1_iv >= 0
3121 ? (STRLEN)(UV)pos1_iv
3122 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3123 LvTARGLEN(ret) =
3124 len_is_uv || len_iv > 0
3125 ? (STRLEN)(UV)len_iv
3126 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3127
83f78d1a
FC		 3128 PUSHs(ret); /* avoid SvSETMAGIC here */
3129 RETURN;
a74fb2cd 3130 }
6582db62
FC		 3131 if (repl_sv) {
3132 repl = SvPV_const(repl_sv, repl_len);
3133 SvGETMAGIC(sv);
3134 if (SvROK(sv))
3135 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3136 "Attempt to use reference as lvalue in substr"
3137 );
3138 tmps = SvPV_force_nomg(sv, curlen);
3139 if (DO_UTF8(repl_sv) && repl_len) {
3140 if (!DO_UTF8(sv)) {
01680ee9 3141 sv_utf8_upgrade_nomg(sv);
6582db62
FC		 3142 curlen = SvCUR(sv);
3143 }
3144 }
3145 else if (DO_UTF8(sv))
3146 repl_need_utf8_upgrade = TRUE;
3147 }
3148 else tmps = SvPV_const(sv, curlen);
7e2040f0 3149 if (DO_UTF8(sv)) {
0d788f38 3150 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
9402d6ed
JH		 3151 if (utf8_curlen == curlen)
3152 utf8_curlen = 0;
a0ed51b3 3153 else
9402d6ed 3154 curlen = utf8_curlen;
a0ed51b3 3155 }
d1c2b58a 3156 else
9402d6ed 3157 utf8_curlen = 0;
a0ed51b3 3158
83f78d1a
FC		 3159 {
3160 STRLEN pos, len, byte_len, byte_pos;
777f7c56 3161
83f78d1a
FC		 3162 if (!translate_substr_offsets(
3163 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3164 )) goto bound_fail;
777f7c56 3165
83f78d1a
FC		 3166 byte_len = len;
3167 byte_pos = utf8_curlen
0d788f38 3168 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
d931b1be 3169
2154eca7 3170 tmps += byte_pos;
bbddc9e0
CS		 3171
3172 if (rvalue) {
3173 SvTAINTED_off(TARG); /* decontaminate */
3174 SvUTF8_off(TARG); /* decontaminate */
3175 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3176#ifdef USE_LOCALE_COLLATE
bbddc9e0 3177 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3178#endif
bbddc9e0
CS		 3179 if (utf8_curlen)
3180 SvUTF8_on(TARG);
3181 }
2154eca7 3182
f7928d6c 3183 if (repl) {
13e30c65
JH		 3184 SV* repl_sv_copy = NULL;
3185
3186 if (repl_need_utf8_upgrade) {
3187 repl_sv_copy = newSVsv(repl_sv);
3188 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3189 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65 3190 }
502d9230
VP		 3191 if (!SvOK(sv))
3192 sv_setpvs(sv, "");
777f7c56 3193 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
ef8d46e8 3194 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3195 }
79072805 3196 }
6a9665b0
FC		 3197 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3198 SP++;
3199 else if (rvalue) {
bbddc9e0
CS		 3200 SvSETMAGIC(TARG);
3201 PUSHs(TARG);
3202 }
79072805 3203 RETURN;
777f7c56 3204
1c900557 3205bound_fail:
83f78d1a 3206 if (repl)
777f7c56
EB		 3207 Perl_croak(aTHX_ "substr outside of string");
3208 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3209 RETPUSHUNDEF;
79072805
LW		 3210}
3211
3212PP(pp_vec)
3213{
20b7effb 3214 dSP;
eb578fdb
KW		 3215 const IV size = POPi;
3216 const IV offset = POPi;
3217 SV * const src = POPs;
1b6737cc 3218 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3219 SV * ret;
a0d0e21e 3220
81e118e0 3221 if (lvalue) { /* it's an lvalue! */
2154eca7
EB		 3222 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3223 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3224 LvTYPE(ret) = 'v';
3225 LvTARG(ret) = SvREFCNT_inc_simple(src);
3226 LvTARGOFF(ret) = offset;
3227 LvTARGLEN(ret) = size;
3228 }
3229 else {
3230 dTARGET;
3231 SvTAINTED_off(TARG); /* decontaminate */
3232 ret = TARG;
79072805
LW		 3233 }
3234
2154eca7 3235 sv_setuv(ret, do_vecget(src, offset, size));
f9e95907
FC		 3236 if (!lvalue)
3237 SvSETMAGIC(ret);
2154eca7 3238 PUSHs(ret);
79072805
LW		 3239 RETURN;
3240}
3241
b1c05ba5
DM		 3242
3243/* also used for: pp_rindex() */
3244
79072805
LW		 3245PP(pp_index)
3246{
20b7effb 3247 dSP; dTARGET;
79072805
LW		 3248 SV *big;
3249 SV *little;
c445ea15 3250 SV *temp = NULL;
ad66a58c 3251 STRLEN biglen;
2723d216 3252 STRLEN llen = 0;
b464e2b7
TC		 3253 SSize_t offset = 0;
3254 SSize_t retval;
73ee8be2
NC		 3255 const char *big_p;
3256 const char *little_p;
2f040f7f
NC		 3257 bool big_utf8;
3258 bool little_utf8;
2723d216 3259 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3260 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3261
e1dccc0d
Z		 3262 if (threeargs)
3263 offset = POPi;
79072805
LW		 3264 little = POPs;
3265 big = POPs;
73ee8be2
NC		 3266 big_p = SvPV_const(big, biglen);
3267 little_p = SvPV_const(little, llen);
3268
e609e586
NC		 3269 big_utf8 = DO_UTF8(big);
3270 little_utf8 = DO_UTF8(little);
3271 if (big_utf8 ^ little_utf8) {
3272 /* One needs to be upgraded. */
47e13f24 3273 if (little_utf8 && !IN_ENCODING) {
2f040f7f
NC		 3274 /* Well, maybe instead we might be able to downgrade the small
3275 string? */
1eced8f8 3276 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC		 3277 &little_utf8);
3278 if (little_utf8) {
3279 /* If the large string is ISO-8859-1, and it's not possible to
3280 convert the small string to ISO-8859-1, then there is no
3281 way that it could be found anywhere by index. */
3282 retval = -1;
3283 goto fail;
3284 }
e609e586 3285
2f040f7f
NC		 3286 /* At this point, pv is a malloc()ed string. So donate it to temp
3287 to ensure it will get free()d */
3288 little = temp = newSV(0);
73ee8be2
NC		 3289 sv_usepvn(temp, pv, llen);
3290 little_p = SvPVX(little);
e609e586 3291 } else {
73ee8be2
NC		 3292 temp = little_utf8
3293 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f 3294
47e13f24 3295 if (IN_ENCODING) {
ad2de1b2 3296 sv_recode_to_utf8(temp, _get_encoding());
2f040f7f
NC		 3297 } else {
3298 sv_utf8_upgrade(temp);
3299 }
3300 if (little_utf8) {
3301 big = temp;
3302 big_utf8 = TRUE;
73ee8be2 3303 big_p = SvPV_const(big, biglen);
2f040f7f
NC		 3304 } else {
3305 little = temp;
73ee8be2 3306 little_p = SvPV_const(little, llen);
2f040f7f 3307 }
e609e586
NC		 3308 }
3309 }
73ee8be2
NC		 3310 if (SvGAMAGIC(big)) {
3311 /* Life just becomes a lot easier if I use a temporary here.
3312 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3313 will trigger magic and overloading again, as will fbm_instr()
3314 */
59cd0e26
NC		 3315 big = newSVpvn_flags(big_p, biglen,
3316 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC		 3317 big_p = SvPVX(big);
3318 }
e4e44778 3319 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC		 3320 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3321 warn on undef, and we've already triggered a warning with the
3322 SvPV_const some lines above. We can't remove that, as we need to
3323 call some SvPV to trigger overloading early and find out if the
3324 string is UTF-8.
3325 This is all getting to messy. The API isn't quite clean enough,
3326 because data access has side effects.
3327 */
59cd0e26
NC		 3328 little = newSVpvn_flags(little_p, llen,
3329 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC		 3330 little_p = SvPVX(little);
3331 }
e609e586 3332
d3e26383 3333 if (!threeargs)
2723d216 3334 offset = is_index ? 0 : biglen;
a0ed51b3 3335 else {
ad66a58c 3336 if (big_utf8 && offset > 0)
b464e2b7 3337 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
73ee8be2
NC		 3338 if (!is_index)
3339 offset += llen;
a0ed51b3 3340 }
79072805
LW		 3341 if (offset < 0)
3342 offset = 0;
b464e2b7 3343 else if (offset > (SSize_t)biglen)
ad66a58c 3344 offset = biglen;
73ee8be2
NC		 3345 if (!(little_p = is_index
3346 ? fbm_instr((unsigned char*)big_p + offset,
3347 (unsigned char*)big_p + biglen, little, 0)
3348 : rninstr(big_p, big_p + offset,
3349 little_p, little_p + llen)))
a0ed51b3 3350 retval = -1;
ad66a58c 3351 else {
73ee8be2 3352 retval = little_p - big_p;
15c41403 3353 if (retval > 1 && big_utf8)
b464e2b7 3354 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
ad66a58c 3355 }
ef8d46e8 3356 SvREFCNT_dec(temp);
2723d216 3357 fail:
e1dccc0d 3358 PUSHi(retval);
79072805
LW		 3359 RETURN;
3360}
3361
3362PP(pp_sprintf)
3363{
20b7effb 3364 dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3365 SvTAINTED_off(TARG);
79072805 3366 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3367 TAINT_IF(SvTAINTED(TARG));
79072805
LW		 3368 SP = ORIGMARK;
3369 PUSHTARG;
3370 RETURN;
3371}
3372
79072805
LW		 3373PP(pp_ord)
3374{
20b7effb 3375 dSP; dTARGET;
1eced8f8 3376
6ba92227 3377 SV *argsv = TOPs;
ba210ebe 3378 STRLEN len;
349d4f2f 3379 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3380
47e13f24 3381 if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3382 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
ad2de1b2 3383 s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
4f6386b6 3384 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
121910a4
JH		 3385 argsv = tmpsv;
3386 }
79072805 3387
6ba92227 3388 SETu(DO_UTF8(argsv)
4f6386b6 3389 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
f3943cf2 3390 : (UV)(*s));
68795e93 3391
6ba92227 3392 return NORMAL;
79072805
LW		 3393}
3394
463ee0b2
LW		 3395PP(pp_chr)
3396{
20b7effb 3397 dSP; dTARGET;
463ee0b2 3398 char *tmps;
8a064bd6 3399 UV value;
d3261b99 3400 SV *top = TOPs;
8a064bd6 3401
71739502 3402 SvGETMAGIC(top);
9911fc4e
FC		 3403 if (UNLIKELY(SvAMAGIC(top)))
3404 top = sv_2num(top);
99f450cc 3405 if (UNLIKELY(isinfnansv(top)))
0c7df902 3406 Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
1cd88304
JH		 3407 else {
3408 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3409 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3410 ||
3411 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3412 && SvNV_nomg(top) < 0.0))) {
b3fe8680
FC		 3413 if (ckWARN(WARN_UTF8)) {
3414 if (SvGMAGICAL(top)) {
3415 SV *top2 = sv_newmortal();
3416 sv_setsv_nomg(top2, top);
3417 top = top2;
3418 }
1cd88304
JH		 3419 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3420 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3421 }
3422 value = UNICODE_REPLACEMENT;
3423 } else {
3424 value = SvUV_nomg(top);
3425 }
8a064bd6 3426 }
463ee0b2 3427
862a34c6 3428 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3429
0064a8a9 3430 if (value > 255 && !IN_BYTES) {
eb160463 3431 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3432 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3433 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW		 3434 *tmps = '\0';
3435 (void)SvPOK_only(TARG);
aa6ffa16 3436 SvUTF8_on(TARG);
d3261b99
FC		 3437 SETTARG;
3438 return NORMAL;
a0ed51b3
LW		 3439 }
3440
748a9306 3441 SvGROW(TARG,2);
463ee0b2
LW		 3442 SvCUR_set(TARG, 1);
3443 tmps = SvPVX(TARG);
eb160463 3444 *tmps++ = (char)value;
748a9306 3445 *tmps = '\0';
a0d0e21e 3446 (void)SvPOK_only(TARG);
4c5ed6e2 3447
47e13f24 3448 if (IN_ENCODING && !IN_BYTES) {
ad2de1b2 3449 sv_recode_to_utf8(TARG, _get_encoding());
88632417 3450 tmps = SvPVX(TARG);
28936164
KW		 3451 if (SvCUR(TARG) == 0
3452 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3453 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3454 {
4c5ed6e2 3455 SvGROW(TARG, 2);
d5a15ac2 3456 tmps = SvPVX(TARG);
4c5ed6e2
TS		 3457 SvCUR_set(TARG, 1);
3458 *tmps++ = (char)value;
88632417 3459 *tmps = '\0';
4c5ed6e2 3460 SvUTF8_off(TARG);
88632417
JH		 3461 }
3462 }
4c5ed6e2 3463
d3261b99
FC		 3464 SETTARG;
3465 return NORMAL;
463ee0b2
LW		 3466}
3467
79072805
LW		 3468PP(pp_crypt)
3469{
79072805 3470#ifdef HAS_CRYPT
20b7effb 3471 dSP; dTARGET;
5f74f29c 3472 dPOPTOPssrl;
85c16d83 3473 STRLEN len;
10516c54 3474 const char *tmps = SvPV_const(left, len);
2bc69dc4 3475
85c16d83 3476 if (DO_UTF8(left)) {
2bc69dc4 3477 /* If Unicode, try to downgrade.
f2791508
JH		 3478 * If not possible, croak.
3479 * Yes, we made this up. */
659fbb76 3480 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
2bc69dc4 3481
2bc69dc4 3482 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3483 tmps = SvPV_const(tsv, len);
85c16d83 3484 }
05404ffe
JH		 3485# ifdef USE_ITHREADS
3486# ifdef HAS_CRYPT_R
3487 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3488 /* This should be threadsafe because in ithreads there is only
3489 * one thread per interpreter. If this would not be true,
3490 * we would need a mutex to protect this malloc. */
3491 PL_reentrant_buffer->_crypt_struct_buffer =
3492 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3493#if defined(__GLIBC__) || defined(__EMX__)
3494 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3495 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3496 /* work around glibc-2.2.5 bug */
3497 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3498 }
05404ffe 3499#endif
6ab58e4d 3500 }
05404ffe
JH		 3501# endif /* HAS_CRYPT_R */
3502# endif /* USE_ITHREADS */
5f74f29c 3503# ifdef FCRYPT
83003860 3504 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3505# else
83003860 3506 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3507# endif
fbc76eb3 3508 SvUTF8_off(TARG);
ec93b65f 3509 SETTARG;
4808266b 3510 RETURN;
79072805 3511#else
b13b2135 3512 DIE(aTHX_
79072805
LW		 3513 "The crypt() function is unimplemented due to excessive paranoia.");
3514#endif
79072805
LW		 3515}
3516
00f254e2
KW		 3517/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3518 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3519
b1c05ba5
DM		 3520
3521/* also used for: pp_lcfirst() */
3522
79072805
LW		 3523PP(pp_ucfirst)
3524{
00f254e2
KW		 3525 /* Actually is both lcfirst() and ucfirst(). Only the first character
3526 * changes. This means that possibly we can change in-place, ie., just
3527 * take the source and change that one character and store it back, but not
3528 * if read-only etc, or if the length changes */
3529
39644a26 3530 dSP;
d54190f6 3531 SV *source = TOPs;
00f254e2 3532 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC		 3533 STRLEN need;
3534 SV *dest;
00f254e2
KW		 3535 bool inplace; /* ? Convert first char only, in-place */
3536 bool doing_utf8 = FALSE; /* ? using utf8 */
3537 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3538 const int op_type = PL_op->op_type;
d54190f6
NC		 3539 const U8 *s;
3540 U8 *d;
3541 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW		 3542 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3543 * stored as UTF-8 at s. */
3544 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3545 * lowercased) character stored in tmpbuf. May be either
3546 * UTF-8 or not, but in either case is the number of bytes */
d54190f6 3547
841a5e18 3548 s = (const U8*)SvPV_const(source, slen);
a0ed51b3 3549
00f254e2
KW		 3550 /* We may be able to get away with changing only the first character, in
3551 * place, but not if read-only, etc. Later we may discover more reasons to
3552 * not convert in-place. */
5cd5e2d6
FC		 3553 inplace = !SvREADONLY(source)
3554 && ( SvPADTMP(source)
3555 || ( SvTEMP(source) && !SvSMAGICAL(source)
3556 && SvREFCNT(source) == 1));
00f254e2
KW		 3557
3558 /* First calculate what the changed first character should be. This affects
3559 * whether we can just swap it out, leaving the rest of the string unchanged,
3560 * or even if have to convert the dest to UTF-8 when the source isn't */
3561
3562 if (! slen) { /* If empty */
3563 need = 1; /* still need a trailing NUL */
b7576bcb 3564 ulen = 0;
00f254e2
KW		 3565 }
3566 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3567 doing_utf8 = TRUE;
17e95c9d 3568 ulen = UTF8SKIP(s);
094a2f8c 3569 if (op_type == OP_UCFIRST) {
130c5df3 3570#ifdef USE_LOCALE_CTYPE
5a6bb681 3571 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3572#else
5a6bb681 3573 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
130c5df3 3574#endif
094a2f8c
KW		 3575 }
3576 else {
130c5df3 3577#ifdef USE_LOCALE_CTYPE
5a6bb681 3578 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3579#else
5a6bb681 3580 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
130c5df3 3581#endif
094a2f8c 3582 }
00f254e2 3583
17e95c9d
KW		 3584 /* we can't do in-place if the length changes. */
3585 if (ulen != tculen) inplace = FALSE;
3586 need = slen + 1 - ulen + tculen;
d54190f6 3587 }
00f254e2
KW		 3588 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3589 * latin1 is treated as caseless. Note that a locale takes
3590 * precedence */
167d19f2 3591 ulen = 1; /* Original character is 1 byte */
00f254e2
KW		 3592 tculen = 1; /* Most characters will require one byte, but this will
3593 * need to be overridden for the tricky ones */
3594 need = slen + 1;
3595
3596 if (op_type == OP_LCFIRST) {
d54190f6 3597
00f254e2 3598 /* lower case the first letter: no trickiness for any character */
130c5df3 3599#ifdef USE_LOCALE_CTYPE
780fcc9f
KW		 3600 if (IN_LC_RUNTIME(LC_CTYPE)) {
3601 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3602 *tmpbuf = toLOWER_LC(*s);
3603 }
3604 else
130c5df3 3605#endif
780fcc9f
KW		 3606 {
3607 *tmpbuf = (IN_UNI_8_BIT)
3608 ? toLOWER_LATIN1(*s)
3609 : toLOWER(*s);
3610 }
00f254e2 3611 }
130c5df3 3612#ifdef USE_LOCALE_CTYPE
780fcc9f 3613 /* is ucfirst() */
d6ded950 3614 else if (IN_LC_RUNTIME(LC_CTYPE)) {
31f05a37
KW		 3615 if (IN_UTF8_CTYPE_LOCALE) {
3616 goto do_uni_rules;
3617 }
3618
780fcc9f 3619 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
31f05a37
KW		 3620 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3621 locales have upper and title case
3622 different */
00f254e2 3623 }
130c5df3 3624#endif
00f254e2
KW		 3625 else if (! IN_UNI_8_BIT) {
3626 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3627 * on EBCDIC machines whatever the
3628 * native function does */
3629 }
31f05a37
KW		 3630 else {
3631 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3632 * UTF-8, which we treat as not in locale), and cased latin1 */
3633 UV title_ord;
91191cf7 3634#ifdef USE_LOCALE_CTYPE
31f05a37 3635 do_uni_rules:
91191cf7 3636#endif
31f05a37
KW		 3637
3638 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
167d19f2
KW		 3639 if (tculen > 1) {
3640 assert(tculen == 2);
3641
3642 /* If the result is an upper Latin1-range character, it can
3643 * still be represented in one byte, which is its ordinal */
3644 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3645 *tmpbuf = (U8) title_ord;
3646 tculen = 1;
00f254e2
KW		 3647 }
3648 else {
167d19f2
KW		 3649 /* Otherwise it became more than one ASCII character (in
3650 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3651 * beyond Latin1, so the number of bytes changed, so can't
3652 * replace just the first character in place. */
3653 inplace = FALSE;
3654
d14578b8
KW		 3655 /* If the result won't fit in a byte, the entire result
3656 * will have to be in UTF-8. Assume worst case sizing in
3657 * conversion. (all latin1 characters occupy at most two
3658 * bytes in utf8) */
167d19f2
KW		 3659 if (title_ord > 255) {
3660 doing_utf8 = TRUE;
3661 convert_source_to_utf8 = TRUE;
3662 need = slen * 2 + 1;
3663
3664 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3665 * (both) characters whose title case is above 255 is
3666 * 2. */
3667 ulen = 2;
3668 }
3669 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3670 need = slen + 1 + 1;
3671 }
00f254e2 3672 }
167d19f2 3673 }
00f254e2
KW		 3674 } /* End of use Unicode (Latin1) semantics */
3675 } /* End of changing the case of the first character */
3676
3677 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3678 * generate the result */
3679 if (inplace) {
3680
3681 /* We can convert in place. This means we change just the first
3682 * character without disturbing the rest; no need to grow */
d54190f6
NC		 3683 dest = source;
3684 s = d = (U8*)SvPV_force_nomg(source, slen);
3685 } else {
3686 dTARGET;
3687
3688 dest = TARG;
3689
00f254e2
KW		 3690 /* Here, we can't convert in place; we earlier calculated how much
3691 * space we will need, so grow to accommodate that */
d54190f6 3692 SvUPGRADE(dest, SVt_PV);
3b416f41 3693 d = (U8*)SvGROW(dest, need);
d54190f6
NC		 3694 (void)SvPOK_only(dest);
3695
3696 SETs(dest);
d54190f6 3697 }
44bc797b 3698
d54190f6 3699 if (doing_utf8) {
00f254e2
KW		 3700 if (! inplace) {
3701 if (! convert_source_to_utf8) {
3702
3703 /* Here both source and dest are in UTF-8, but have to create
3704 * the entire output. We initialize the result to be the
3705 * title/lower cased first character, and then append the rest
3706 * of the string. */
3707 sv_setpvn(dest, (char*)tmpbuf, tculen);
3708 if (slen > ulen) {
3709 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3710 }
3711 }
3712 else {
3713 const U8 *const send = s + slen;
3714
3715 /* Here the dest needs to be in UTF-8, but the source isn't,
3716 * except we earlier UTF-8'd the first character of the source
3717 * into tmpbuf. First put that into dest, and then append the
3718 * rest of the source, converting it to UTF-8 as we go. */
3719
3720 /* Assert tculen is 2 here because the only two characters that
3721 * get to this part of the code have 2-byte UTF-8 equivalents */
3722 *d++ = *tmpbuf;
3723 *d++ = *(tmpbuf + 1);
3724 s++; /* We have just processed the 1st char */
3725
3726 for (; s < send; s++) {
3727 d = uvchr_to_utf8(d, *s);
3728 }
3729 *d = '\0';
3730 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3731 }
d54190f6 3732 SvUTF8_on(dest);
a0ed51b3 3733 }
00f254e2 3734 else { /* in-place UTF-8. Just overwrite the first character */
d54190f6
NC		 3735 Copy(tmpbuf, d, tculen, U8);
3736 SvCUR_set(dest, need - 1);
a0ed51b3 3737 }
094a2f8c 3738
a0ed51b3 3739 }
00f254e2
KW		 3740 else { /* Neither source nor dest are in or need to be UTF-8 */
3741 if (slen) {
00f254e2
KW		 3742 if (inplace) { /* in-place, only need to change the 1st char */
3743 *d = *tmpbuf;
3744 }
3745 else { /* Not in-place */
3746
3747 /* Copy the case-changed character(s) from tmpbuf */
3748 Copy(tmpbuf, d, tculen, U8);
3749 d += tculen - 1; /* Code below expects d to point to final
3750 * character stored */
3751 }
3752 }
3753 else { /* empty source */
3754 /* See bug #39028: Don't taint if empty */
d54190f6
NC		 3755 *d = *s;
3756 }
3757
00f254e2
KW		 3758 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3759 * the destination to retain that flag */
93e088e8 3760 if (SvUTF8(source) && ! IN_BYTES)
d54190f6
NC		 3761 SvUTF8_on(dest);
3762
00f254e2 3763 if (!inplace) { /* Finish the rest of the string, unchanged */
d54190f6
NC		 3764 /* This will copy the trailing NUL */
3765 Copy(s + 1, d + 1, slen, U8);
3766 SvCUR_set(dest, need - 1);
bbce6d69 3767 }
bbce6d69 3768 }
130c5df3 3769#ifdef USE_LOCALE_CTYPE
d6ded950 3770 if (IN_LC_RUNTIME(LC_CTYPE)) {
445bf929
KW		 3771 TAINT;
3772 SvTAINTED_on(dest);
3773 }
130c5df3 3774#endif
539689e7
FC		 3775 if (dest != source && SvTAINTED(source))
3776 SvTAINT(dest);
d54190f6 3777 SvSETMAGIC(dest);
3cb4e04f 3778 return NORMAL;
79072805
LW		 3779}
3780
67306194
NC		 3781/* There's so much setup/teardown code common between uc and lc, I wonder if
3782 it would be worth merging the two, and just having a switch outside each
00f254e2 3783 of the three tight loops. There is less and less commonality though */
79072805
LW		 3784PP(pp_uc)
3785{
39644a26 3786 dSP;
67306194 3787 SV *source = TOPs;
463ee0b2 3788 STRLEN len;
67306194
NC		 3789 STRLEN min;
3790 SV *dest;
3791 const U8 *s;
3792 U8 *d;
79072805 3793
67306194
NC		 3794 SvGETMAGIC(source);
3795
5cd5e2d6
FC		 3796 if ((SvPADTMP(source)
3797 ||
3798 (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
3799 && !SvREADONLY(source) && SvPOK(source)
3800 && !DO_UTF8(source)
130c5df3
KW		 3801 && (
3802#ifdef USE_LOCALE_CTYPE
3803 (IN_LC_RUNTIME(LC_CTYPE))
31f05a37 3804 ? ! IN_UTF8_CTYPE_LOCALE
130c5df3
KW		 3805 :
3806#endif
3807 ! IN_UNI_8_BIT))
31f05a37
KW		 3808 {
3809
3810 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3811 * make the loop tight, so we overwrite the source with the dest before
3812 * looking at it, and we need to look at the original source
3813 * afterwards. There would also need to be code added to handle
3814 * switching to not in-place in midstream if we run into characters
3815 * that change the length. Since being in locale overrides UNI_8_BIT,
3816 * that latter becomes irrelevant in the above test; instead for
3817 * locale, the size can't normally change, except if the locale is a
3818 * UTF-8 one */
67306194
NC		 3819 dest = source;
3820 s = d = (U8*)SvPV_force_nomg(source, len);
3821 min = len + 1;
3822 } else {
a0ed51b3 3823 dTARGET;
a0ed51b3 3824
67306194 3825 dest = TARG;
128c9517 3826
841a5e18 3827 s = (const U8*)SvPV_nomg_const(source, len);
67306194
NC		 3828 min = len + 1;
3829
3830 SvUPGRADE(dest, SVt_PV);
3b416f41 3831 d = (U8*)SvGROW(dest, min);
67306194
NC		 3832 (void)SvPOK_only(dest);
3833
3834 SETs(dest);
a0ed51b3 3835 }
31351b04 3836
67306194
NC		 3837 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3838 to check DO_UTF8 again here. */
3839
3840 if (DO_UTF8(source)) {
3841 const U8 *const send = s + len;
bfac13d4 3842 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
67306194 3843
4c8a458a
KW		 3844 /* All occurrences of these are to be moved to follow any other marks.
3845 * This is context-dependent. We may not be passed enough context to
3846 * move the iota subscript beyond all of them, but we do the best we can
3847 * with what we're given. The result is always better than if we
3848 * hadn't done this. And, the problem would only arise if we are
3849 * passed a character without all its combining marks, which would be
3850 * the caller's mistake. The information this is based on comes from a
3851 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3852 * itself) and so can't be checked properly to see if it ever gets
3853 * revised. But the likelihood of it changing is remote */
00f254e2 3854 bool in_iota_subscript = FALSE;
00f254e2 3855
67306194 3856 while (s < send) {
3e16b0e6
KW		 3857 STRLEN u;
3858 STRLEN ulen;
3859 UV uv;
7dbf68d2 3860 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3e16b0e6 3861
00f254e2 3862 /* A non-mark. Time to output the iota subscript */
a78bc3c6
KW		 3863 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3864 d += capital_iota_len;
00f254e2 3865 in_iota_subscript = FALSE;
8e058693 3866 }
00f254e2 3867
8e058693
KW		 3868 /* Then handle the current character. Get the changed case value
3869 * and copy it to the output buffer */
00f254e2 3870
8e058693 3871 u = UTF8SKIP(s);
130c5df3 3872#ifdef USE_LOCALE_CTYPE
5a6bb681 3873 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3874#else
5a6bb681 3875 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
130c5df3 3876#endif
a78bc3c6
KW		 3877#define GREEK_CAPITAL_LETTER_IOTA 0x0399
3878#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
8e058693 3879 if (uv == GREEK_CAPITAL_LETTER_IOTA
4b88fb76 3880 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
8e058693
KW		 3881 {
3882 in_iota_subscript = TRUE;
3883 }
3884 else {
3885 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3886 /* If the eventually required minimum size outgrows the
3887 * available space, we need to grow. */
3888 const UV o = d - (U8*)SvPVX_const(dest);
3889
3890 /* If someone uppercases one million U+03B0s we SvGROW()
3891 * one million times. Or we could try guessing how much to
3892 * allocate without allocating too much. Such is life.
3893 * See corresponding comment in lc code for another option
3894 * */
3895 SvGROW(dest, min);
3896 d = (U8*)SvPVX(dest) + o;
3897 }
3898 Copy(tmpbuf, d, ulen, U8);
3899 d += ulen;
3900 }
3901 s += u;
67306194 3902 }
4c8a458a 3903 if (in_iota_subscript) {
a78bc3c6
KW		 3904 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3905 d += capital_iota_len;
4c8a458a 3906 }
67306194
NC		 3907 SvUTF8_on(dest);
3908 *d = '\0';
094a2f8c 3909
67306194 3910 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4c8a458a
KW		 3911 }
3912 else { /* Not UTF-8 */
67306194
NC		 3913 if (len) {
3914 const U8 *const send = s + len;
00f254e2
KW		 3915
3916 /* Use locale casing if in locale; regular style if not treating
3917 * latin1 as having case; otherwise the latin1 casing. Do the
3918 * whole thing in a tight loop, for speed, */
130c5df3 3919#ifdef USE_LOCALE_CTYPE
d6ded950 3920 if (IN_LC_RUNTIME(LC_CTYPE)) {
31f05a37
KW		 3921 if (IN_UTF8_CTYPE_LOCALE) {
3922 goto do_uni_rules;
3923 }
780fcc9f 3924 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
67306194 3925 for (; s < send; d++, s++)
31f05a37 3926 *d = (U8) toUPPER_LC(*s);
31351b04 3927 }
130c5df3
KW		 3928 else
3929#endif
3930 if (! IN_UNI_8_BIT) {
00f254e2 3931 for (; s < send; d++, s++) {
67306194 3932 *d = toUPPER(*s);
00f254e2 3933 }
31351b04 3934 }
00f254e2 3935 else {
91191cf7 3936#ifdef USE_LOCALE_CTYPE
31f05a37 3937 do_uni_rules:
91191cf7 3938#endif
00f254e2
KW		 3939 for (; s < send; d++, s++) {
3940 *d = toUPPER_LATIN1_MOD(*s);
d14578b8
KW		 3941 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3942 continue;
3943 }
00f254e2
KW		 3944
3945 /* The mainstream case is the tight loop above. To avoid
3946 * extra tests in that, all three characters that require
3947 * special handling are mapped by the MOD to the one tested
3948 * just above.
3949 * Use the source to distinguish between the three cases */
3950
3951 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3952
3953 /* uc() of this requires 2 characters, but they are
3954 * ASCII. If not enough room, grow the string */
3955 if (SvLEN(dest) < ++min) {
3956 const UV o = d - (U8*)SvPVX_const(dest);
3957 SvGROW(dest, min);
3958 d = (U8*)SvPVX(dest) + o;
3959 }
3960 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3961 continue; /* Back to the tight loop; still in ASCII */
3962 }
3963
3964 /* The other two special handling characters have their
3965 * upper cases outside the latin1 range, hence need to be
3966 * in UTF-8, so the whole result needs to be in UTF-8. So,
3967 * here we are somewhere in the middle of processing a
3968 * non-UTF-8 string, and realize that we will have to convert
3969 * the whole thing to UTF-8. What to do? There are
3970 * several possibilities. The simplest to code is to
3971 * convert what we have so far, set a flag, and continue on
3972 * in the loop. The flag would be tested each time through
3973 * the loop, and if set, the next character would be
3974 * converted to UTF-8 and stored. But, I (khw) didn't want
3975 * to slow down the mainstream case at all for this fairly
3976 * rare case, so I didn't want to add a test that didn't
3977 * absolutely have to be there in the loop, besides the
3978 * possibility that it would get too complicated for
3979 * optimizers to deal with. Another possibility is to just
3980 * give up, convert the source to UTF-8, and restart the
3981 * function that way. Another possibility is to convert
3982 * both what has already been processed and what is yet to
3983 * come separately to UTF-8, then jump into the loop that
3984 * handles UTF-8. But the most efficient time-wise of the
3985 * ones I could think of is what follows, and turned out to
3986 * not require much extra code. */
3987
3988 /* Convert what we have so far into UTF-8, telling the
3989 * function that we know it should be converted, and to
3990 * allow extra space for what we haven't processed yet.
3991 * Assume the worst case space requirements for converting
3992 * what we haven't processed so far: that it will require
3993 * two bytes for each remaining source character, plus the
3994 * NUL at the end. This may cause the string pointer to
3995 * move, so re-find it. */
3996
3997 len = d - (U8*)SvPVX_const(dest);
3998 SvCUR_set(dest, len);
3999 len = sv_utf8_upgrade_flags_grow(dest,
4000 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4001 (send -s) * 2 + 1);
4002 d = (U8*)SvPVX(dest) + len;
4003
00f254e2
KW		 4004 /* Now process the remainder of the source, converting to
4005 * upper and UTF-8. If a resulting byte is invariant in
4006 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4007 * append it to the output. */
00f254e2 4008 for (; s < send; s++) {
0ecfbd28
KW		 4009 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4010 d += len;
00f254e2
KW		 4011 }
4012
4013 /* Here have processed the whole source; no need to continue
4014 * with the outer loop. Each character has been converted
4015 * to upper case and converted to UTF-8 */
4016
4017 break;
4018 } /* End of processing all latin1-style chars */
4019 } /* End of processing all chars */
4020 } /* End of source is not empty */
4021
67306194 4022 if (source != dest) {
00f254e2 4023 *d = '\0'; /* Here d points to 1 after last char, add NUL */
67306194
NC		 4024 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4025 }
00f254e2 4026 } /* End of isn't utf8 */
130c5df3 4027#ifdef USE_LOCALE_CTYPE
d6ded950 4028 if (IN_LC_RUNTIME(LC_CTYPE)) {
445bf929
KW		 4029 TAINT;
4030 SvTAINTED_on(dest);
4031 }
130c5df3 4032#endif
539689e7
FC		 4033 if (dest != source && SvTAINTED(source))
4034 SvTAINT(dest);
67306194 4035 SvSETMAGIC(dest);
3cb4e04f 4036 return NORMAL;
79072805
LW		 4037}
4038
4039PP(pp_lc)
4040{
39644a26 4041 dSP;
ec9af7d4 4042 SV *source = TOPs;
463ee0b2 4043 STRLEN len;
ec9af7d4
NC		 4044 STRLEN min;
4045 SV *dest;
4046 const U8 *s;
4047 U8 *d;
79072805 4048
ec9af7d4
NC		 4049 SvGETMAGIC(source);
4050
5cd5e2d6
FC		 4051 if ( ( SvPADTMP(source)
4052 || ( SvTEMP(source) && !SvSMAGICAL(source)
4053 && SvREFCNT(source) == 1 )
4054 )
4055 && !SvREADONLY(source) && SvPOK(source)
4056 && !DO_UTF8(source)) {
ec9af7d4 4057
00f254e2
KW		 4058 /* We can convert in place, as lowercasing anything in the latin1 range
4059 * (or else DO_UTF8 would have been on) doesn't lengthen it */
ec9af7d4
NC		 4060 dest = source;
4061 s = d = (U8*)SvPV_force_nomg(source, len);
4062 min = len + 1;
4063 } else {
a0ed51b3 4064 dTARGET;
a0ed51b3 4065
ec9af7d4
NC		 4066 dest = TARG;
4067
841a5e18 4068 s = (const U8*)SvPV_nomg_const(source, len);
ec9af7d4 4069 min = len + 1;
128c9517 4070
ec9af7d4 4071 SvUPGRADE(dest, SVt_PV);
3b416f41 4072 d = (U8*)SvGROW(dest, min);
ec9af7d4
NC		 4073 (void)SvPOK_only(dest);
4074
4075 SETs(dest);
4076 }
4077
4078 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4079 to check DO_UTF8 again here. */
4080
4081 if (DO_UTF8(source)) {
4082 const U8 *const send = s + len;
4083 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4084
4085 while (s < send) {
06b5486a
KW		 4086 const STRLEN u = UTF8SKIP(s);
4087 STRLEN ulen;
00f254e2 4088
130c5df3 4089#ifdef USE_LOCALE_CTYPE
5a6bb681 4090 _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 4091#else
5a6bb681 4092 _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
130c5df3 4093#endif
00f254e2 4094
06b5486a 4095 /* Here is where we would do context-sensitive actions. See the
6006ebd0 4096 * commit message for 86510fb15 for why there isn't any */
00f254e2 4097
06b5486a 4098 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
fdb34c52 4099
06b5486a
KW		 4100 /* If the eventually required minimum size outgrows the
4101 * available space, we need to grow. */
4102 const UV o = d - (U8*)SvPVX_const(dest);
fdb34c52 4103
06b5486a
KW		 4104 /* If someone lowercases one million U+0130s we SvGROW() one
4105 * million times. Or we could try guessing how much to
4106 * allocate without allocating too much. Such is life.
4107 * Another option would be to grow an extra byte or two more
4108 * each time we need to grow, which would cut down the million
4109 * to 500K, with little waste */
4110 SvGROW(dest, min);
4111 d = (U8*)SvPVX(dest) + o;
4112 }
86510fb1 4113
06b5486a
KW		 4114 /* Copy the newly lowercased letter to the output buffer we're
4115 * building */
4116 Copy(tmpbuf, d, ulen, U8);
4117 d += ulen;
4118 s += u;
00f254e2 4119 } /* End of looping through the source string */
ec9af7d4
NC		 4120 SvUTF8_on(dest);
4121 *d = '\0';
4122 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
00f254e2 4123 } else { /* Not utf8 */
31351b04 4124 if (len) {
ec9af7d4 4125 const U8 *const send = s + len;
00f254e2
KW		 4126
4127 /* Use locale casing if in locale; regular style if not treating
4128 * latin1 as having case; otherwise the latin1 casing. Do the
4129 * whole thing in a tight loop, for speed, */
130c5df3 4130#ifdef USE_LOCALE_CTYPE
d6ded950 4131 if (IN_LC_RUNTIME(LC_CTYPE)) {
780fcc9f 4132 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
ec9af7d4
NC		 4133 for (; s < send; d++, s++)
4134 *d = toLOWER_LC(*s);
445bf929 4135 }
130c5df3
KW		 4136 else
4137#endif
4138 if (! IN_UNI_8_BIT) {
00f254e2 4139 for (; s < send; d++, s++) {
ec9af7d4 4140 *d = toLOWER(*s);
00f254e2
KW		 4141 }
4142 }
4143 else {
4144 for (; s < send; d++, s++) {
4145 *d = toLOWER_LATIN1(*s);
4146 }
31351b04 4147 }
bbce6d69 4148 }
ec9af7d4
NC		 4149 if (source != dest) {
4150 *d = '\0';
4151 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4152 }
79072805 4153 }
130c5df3 4154#ifdef USE_LOCALE_CTYPE
d6ded950 4155 if (IN_LC_RUNTIME(LC_CTYPE)) {
445bf929
KW		 4156 TAINT;
4157 SvTAINTED_on(dest);
4158 }
130c5df3 4159#endif
539689e7
FC		 4160 if (dest != source && SvTAINTED(source))
4161 SvTAINT(dest);
ec9af7d4 4162 SvSETMAGIC(dest);
3cb4e04f 4163 return NORMAL;
79072805
LW		 4164}
4165
a0d0e21e 4166PP(pp_quotemeta)
79072805 4167{
20b7effb 4168 dSP; dTARGET;
1b6737cc 4169 SV * const sv = TOPs;
a0d0e21e 4170 STRLEN len;
eb578fdb 4171 const char *s = SvPV_const(sv,len);
79072805 4172
7e2040f0 4173 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4174 if (len) {
eb578fdb 4175 char *d;
862a34c6 4176 SvUPGRADE(TARG, SVt_PV);
c07a80fd 4177 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 4178 d = SvPVX(TARG);
7e2040f0 4179 if (DO_UTF8(sv)) {
0dd2cdef 4180 while (len) {
29050de5 4181 STRLEN ulen = UTF8SKIP(s);
2e2b2571
KW		 4182 bool to_quote = FALSE;
4183
4184 if (UTF8_IS_INVARIANT(*s)) {
4185 if (_isQUOTEMETA(*s)) {
4186 to_quote = TRUE;
4187 }
4188 }
4189 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3fea7d29 4190 if (
130c5df3 4191#ifdef USE_LOCALE_CTYPE
20adcf7c
KW		 4192 /* In locale, we quote all non-ASCII Latin1 chars.
4193 * Otherwise use the quoting rules */
3fea7d29
BF		 4194
4195 IN_LC_RUNTIME(LC_CTYPE)
4196 ||
4197#endif
4198 _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
2e2b2571
KW		 4199 {
4200 to_quote = TRUE;
4201 }
4202 }
685289b5 4203 else if (is_QUOTEMETA_high(s)) {
2e2b2571
KW		 4204 to_quote = TRUE;
4205 }
4206
4207 if (to_quote) {
4208 *d++ = '\\';
4209 }
29050de5
KW		 4210 if (ulen > len)
4211 ulen = len;
4212 len -= ulen;
4213 while (ulen--)
4214 *d++ = *s++;
0dd2cdef 4215 }
7e2040f0 4216 SvUTF8_on(TARG);
0dd2cdef 4217 }
2e2b2571
KW		 4218 else if (IN_UNI_8_BIT) {
4219 while (len--) {
4220 if (_isQUOTEMETA(*s))
4221 *d++ = '\\';
4222 *d++ = *s++;
4223 }
4224 }
0dd2cdef 4225 else {
2e2b2571
KW		 4226 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4227 * including everything above ASCII */
0dd2cdef 4228 while (len--) {
adfec831 4229 if (!isWORDCHAR_A(*s))
0dd2cdef
LW		 4230 *d++ = '\\';
4231 *d++ = *s++;
4232 }
79072805 4233 }
a0d0e21e 4234 *d = '\0';
349d4f2f 4235 SvCUR_set(TARG, d - SvPVX_const(TARG));
3aa33fe5 4236 (void)SvPOK_only_UTF8(TARG);
79072805 4237 }
a0d0e21e
LW		 4238 else
4239 sv_setpvn(TARG, s, len);
ec93b65f 4240 SETTARG;
cfe40115 4241 return NORMAL;
79072805
LW		 4242}
4243
838f2281
BF		 4244PP(pp_fc)
4245{
838f2281
BF		 4246 dTARGET;
4247 dSP;
4248 SV *source = TOPs;
4249 STRLEN len;
4250 STRLEN min;
4251 SV *dest;
4252 const U8 *s;
4253 const U8 *send;
4254 U8 *d;
bfac13d4 4255 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
a4b69695
KW		 4256 const bool full_folding = TRUE; /* This variable is here so we can easily
4257 move to more generality later */
838f2281 4258 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
130c5df3
KW		 4259#ifdef USE_LOCALE_CTYPE
4260 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4261#endif
4262 ;
838f2281
BF		 4263
4264 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4265 * You are welcome(?) -Hugmeir
4266 */
4267
4268 SvGETMAGIC(source);
4269
4270 dest = TARG;
4271
4272 if (SvOK(source)) {
4273 s = (const U8*)SvPV_nomg_const(source, len);
4274 } else {
4275 if (ckWARN(WARN_UNINITIALIZED))
4276 report_uninit(source);
4277 s = (const U8*)"";
4278 len = 0;
4279 }
4280
4281 min = len + 1;
4282
4283 SvUPGRADE(dest, SVt_PV);
4284 d = (U8*)SvGROW(dest, min);
4285 (void)SvPOK_only(dest);
4286
4287 SETs(dest);
4288
4289 send = s + len;
4290 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
838f2281
BF		 4291 while (s < send) {
4292 const STRLEN u = UTF8SKIP(s);
4293 STRLEN ulen;
4294
445bf929 4295 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
838f2281
BF		 4296
4297 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4298 const UV o = d - (U8*)SvPVX_const(dest);
4299 SvGROW(dest, min);
4300 d = (U8*)SvPVX(dest) + o;
4301 }
4302
4303 Copy(tmpbuf, d, ulen, U8);
4304 d += ulen;
4305 s += u;
4306 }
4307 SvUTF8_on(dest);
838f2281 4308 } /* Unflagged string */
0902dd32 4309 else if (len) {
130c5df3 4310#ifdef USE_LOCALE_CTYPE
d6ded950 4311 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
31f05a37
KW		 4312 if (IN_UTF8_CTYPE_LOCALE) {
4313 goto do_uni_folding;
4314 }
780fcc9f 4315 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
838f2281 4316 for (; s < send; d++, s++)
ea36a843 4317 *d = (U8) toFOLD_LC(*s);
838f2281 4318 }
130c5df3
KW		 4319 else
4320#endif
4321 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
838f2281 4322 for (; s < send; d++, s++)
d22b930b 4323 *d = toFOLD(*s);
838f2281
BF		 4324 }
4325 else {
91191cf7 4326#ifdef USE_LOCALE_CTYPE
31f05a37 4327 do_uni_folding:
91191cf7 4328#endif
d14578b8
KW		 4329 /* For ASCII and the Latin-1 range, there's only two troublesome
4330 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
22e255cb 4331 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
d14578b8
KW		 4332 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4333 * For the rest, the casefold is their lowercase. */
838f2281
BF		 4334 for (; s < send; d++, s++) {
4335 if (*s == MICRO_SIGN) {
d14578b8
KW		 4336 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4337 * which is outside of the latin-1 range. There's a couple
4338 * of ways to deal with this -- khw discusses them in
4339 * pp_lc/uc, so go there :) What we do here is upgrade what
4340 * we had already casefolded, then enter an inner loop that
4341 * appends the rest of the characters as UTF-8. */
838f2281
BF		 4342 len = d - (U8*)SvPVX_const(dest);
4343 SvCUR_set(dest, len);
4344 len = sv_utf8_upgrade_flags_grow(dest,
4345 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
ea4d335b
KW		 4346 /* The max expansion for latin1
4347 * chars is 1 byte becomes 2 */
4348 (send -s) * 2 + 1);
838f2281
BF		 4349 d = (U8*)SvPVX(dest) + len;
4350
a78bc3c6
KW		 4351 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4352 d += small_mu_len;
838f2281
BF		 4353 s++;
4354 for (; s < send; s++) {
4355 STRLEN ulen;
4356 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
6f2d5cbc 4357 if UVCHR_IS_INVARIANT(fc) {
d14578b8
KW		 4358 if (full_folding
4359 && *s == LATIN_SMALL_LETTER_SHARP_S)
4360 {
838f2281
BF		 4361 *d++ = 's';
4362 *d++ = 's';
4363 }
4364 else
4365 *d++ = (U8)fc;
4366 }
4367 else {
4368 Copy(tmpbuf, d, ulen, U8);
4369 d += ulen;
4370 }
4371 }
4372 break;
4373 }
4374 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
d14578b8
KW		 4375 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4376 * becomes "ss", which may require growing the SV. */
838f2281
BF		 4377 if (SvLEN(dest) < ++min) {
4378 const UV o = d - (U8*)SvPVX_const(dest);
4379 SvGROW(dest, min);
4380 d = (U8*)SvPVX(dest) + o;
4381 }
4382 *(d)++ = 's';
4383 *d = 's';
4384 }
d14578b8
KW		 4385 else { /* If it's not one of those two, the fold is their lower
4386 case */
838f2281
BF		 4387 *d = toLOWER_LATIN1(*s);
4388 }
4389 }
4390 }
4391 }
4392 *d = '\0';
4393 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4394
130c5df3 4395#ifdef USE_LOCALE_CTYPE
d6ded950 4396 if (IN_LC_RUNTIME(LC_CTYPE)) {
445bf929
KW		 4397 TAINT;
4398 SvTAINTED_on(dest);
4399 }
130c5df3 4400#endif
838f2281
BF		 4401 if (SvTAINTED(source))
4402 SvTAINT(dest);
4403 SvSETMAGIC(dest);
4404 RETURN;
4405}
4406
a0d0e21e 4407/* Arrays. */
79072805 4408
a0d0e21e 4409PP(pp_aslice)
79072805 4410{
20b7effb 4411 dSP; dMARK; dORIGMARK;
eb578fdb
KW		 4412 AV *const av = MUTABLE_AV(POPs);
4413 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
79072805 4414
a0d0e21e 4415 if (SvTYPE(av) == SVt_PVAV) {
4ad10a0b
VP		 4416 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4417 bool can_preserve = FALSE;
4418
4419 if (localizing) {
4420 MAGIC *mg;
4421 HV *stash;
4422
4423 can_preserve = SvCANEXISTDELETE(av);
4424 }
4425
4426 if (lval && localizing) {
eb578fdb 4427 SV **svp;
c70927a6 4428 SSize_t max = -1;
924508f0 4429 for (svp = MARK + 1; svp <= SP; svp++) {
c70927a6 4430 const SSize_t elem = SvIV(*svp);
748a9306
LW		 4431 if (elem > max)
4432 max = elem;
4433 }
4434 if (max > AvMAX(av))
4435 av_extend(av, max);
4436 }
4ad10a0b 4437
a0d0e21e 4438 while (++MARK <= SP) {
eb578fdb 4439 SV **svp;
c70927a6 4440 SSize_t elem = SvIV(*MARK);
4ad10a0b 4441 bool preeminent = TRUE;
a0d0e21e 4442
4ad10a0b
VP		 4443 if (localizing && can_preserve) {
4444 /* If we can determine whether the element exist,
4445 * Try to preserve the existenceness of a tied array
4446 * element by using EXISTS and DELETE if possible.
4447 * Fallback to FETCH and STORE otherwise. */
4448 preeminent = av_exists(av, elem);
4449 }
4450
a0d0e21e
LW		 4451 svp = av_fetch(av, elem, lval);
4452 if (lval) {
ce0d59fd 4453 if (!svp || !*svp)
cea2e8a9 4454 DIE(aTHX_ PL_no_aelem, elem);
4ad10a0b
VP		 4455 if (localizing) {
4456 if (preeminent)
4457 save_aelem(av, elem, svp);
4458 else
4459 SAVEADELETE(av, elem);
4460 }
79072805 4461 }
3280af22 4462 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 4463 }
4464 }
82334630 4465 if (GIMME_V != G_ARRAY) {
a0d0e21e 4466 MARK = ORIGMARK;
04ab2c87 4467 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e
LW		 4468 SP = MARK;
4469 }
79072805
LW		 4470 RETURN;
4471}
4472
6dd3e0f2
RZ		 4473PP(pp_kvaslice)
4474{
20b7effb 4475 dSP; dMARK;
6dd3e0f2
RZ		 4476 AV *const av = MUTABLE_AV(POPs);
4477 I32 lval = (PL_op->op_flags & OPf_MOD);
adad97db 4478 SSize_t items = SP - MARK;
6dd3e0f2
RZ		 4479
4480 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4481 const I32 flags = is_lvalue_sub();
4482 if (flags) {
4483 if (!(flags & OPpENTERSUB_INARGS))
7aae0299 4484 /* diag_listed_as: Can't modify %s in %s */
6dd3e0f2
RZ		 4485 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4486 lval = flags;
4487 }
4488 }
4489
4490 MEXTEND(SP,items);
4491 while (items > 1) {
4492 *(MARK+items*2-1) = *(MARK+items);
4493 items--;
4494 }
4495 items = SP-MARK;
4496 SP += items;
4497
4498 while (++MARK <= SP) {
4499 SV **svp;
4500
4501 svp = av_fetch(av, SvIV(*MARK), lval);
4502 if (lval) {
4503 if (!svp || !*svp || *svp == &PL_sv_undef) {
4504 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4505 }
4506 *MARK = sv_mortalcopy(*MARK);
4507 }
4508 *++MARK = svp ? *svp : &PL_sv_undef;
4509 }
82334630 4510 if (GIMME_V != G_ARRAY) {
6dd3e0f2
RZ		 4511 MARK = SP - items*2;
4512 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4513 SP = MARK;
4514 }
4515 RETURN;
4516}
4517
b1c05ba5 4518
cba5a3b0 4519/* Smart dereferencing for keys, values and each */
b1c05ba5
DM		 4520
4521/* also used for: pp_reach() pp_rvalues() */
4522
cba5a3b0
DG		 4523PP(pp_rkeys)
4524{
cba5a3b0
DG		 4525 dSP;
4526 dPOPss;
4527
7ac5715b
FC		 4528 SvGETMAGIC(sv);
4529
4530 if (
4531 !SvROK(sv)
4532 || (sv = SvRV(sv),
4533 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4534 || SvOBJECT(sv)
4535 )
4536 ) {
4537 DIE(aTHX_
4538 "Type of argument to %s must be unblessed hashref or arrayref",
4c540399 4539 PL_op_desc[PL_op->op_type] );
cba5a3b0
DG		 4540 }
4541
d8065907
FC		 4542 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4543 DIE(aTHX_
4544 "Can't modify %s in %s",
4545 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4546 );
4547
cba5a3b0
DG		 4548 /* Delegate to correct function for op type */
4549 PUSHs(sv);
4550 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4551 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4552 }
4553 else {
d14578b8
KW		 4554 return (SvTYPE(sv) == SVt_PVHV)
4555 ? Perl_pp_each(aTHX)
4556 : Perl_pp_aeach(aTHX);
cba5a3b0
DG		 4557 }
4558}
4559
878d132a
NC		 4560PP(pp_aeach)
4561{
878d132a 4562 dSP;
502c6561 4563 AV *array = MUTABLE_AV(POPs);
878d132a 4564 const I32 gimme = GIMME_V;
453d94a9 4565 IV *iterp = Perl_av_iter_p(aTHX_ array);
878d132a
NC		 4566 const IV current = (*iterp)++;
4567
b9f2b683 4568 if (current > av_tindex(array)) {
878d132a
NC		 4569 *iterp = 0;
4570 if (gimme == G_SCALAR)
4571 RETPUSHUNDEF;
4572 else
4573 RETURN;
4574 }
4575
4576 EXTEND(SP, 2);
e1dccc0d 4577 mPUSHi(current);
878d132a
NC		 4578 if (gimme == G_ARRAY) {
4579 SV **const element = av_fetch(array, current, 0);
4580 PUSHs(element ? *element : &PL_sv_undef);
4581 }
4582 RETURN;
4583}
4584
b1c05ba5 4585/* also used for: pp_avalues()*/
878d132a
NC		 4586PP(pp_akeys)
4587{
878d132a 4588 dSP;
502c6561 4589 AV *array = MUTABLE_AV(POPs);
878d132a
NC		 4590 const I32 gimme = GIMME_V;
4591
4592 *Perl_av_iter_p(aTHX_ array) = 0;
4593
4594 if (gimme == G_SCALAR) {
4595 dTARGET;
b9f2b683 4596 PUSHi(av_tindex(array) + 1);
878d132a
NC		 4597 }
4598 else if (gimme == G_ARRAY) {
4599 IV n = Perl_av_len(aTHX_ array);
e1dccc0d 4600 IV i;
878d132a
NC		 4601
4602 EXTEND(SP, n + 1);
4603
cba5a3b0 4604 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
e1dccc0d 4605 for (i = 0; i <= n; i++) {
878d132a
NC		 4606 mPUSHi(i);
4607 }
4608 }
4609 else {
4610 for (i = 0; i <= n; i++) {
4611 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4612 PUSHs(elem ? *elem : &PL_sv_undef);
4613 }
4614 }
4615 }
4616 RETURN;
4617}
4618
79072805
LW		 4619/* Associative arrays. */
4620
4621PP(pp_each)
4622{
39644a26 4623 dSP;
85fbaab2 4624 HV * hash = MUTABLE_HV(POPs);
c07a80fd 4625 HE *entry;
f54cb97a 4626 const I32 gimme = GIMME_V;
8ec5e241 4627
6d822dc4 4628 entry = hv_iternext(hash);
79072805 4629
79072805
LW		 4630 EXTEND(SP, 2);
4631 if (entry) {
1b6737cc 4632 SV* const sv = hv_iterkeysv(entry);
2b32fed8 4633 PUSHs(sv);
54310121 4634 if (gimme == G_ARRAY) {
59af0135 4635 SV *val;
6d822dc4 4636 val = hv_iterval(hash, entry);
59af0135 4637 PUSHs(val);
79072805 4638 }
79072805 4639 }
54310121 4640 else if (gimme == G_SCALAR)
79072805
LW		 4641 RETPUSHUNDEF;
4642
4643 RETURN;
4644}
4645
7332a6c4
VP		 4646STATIC OP *
4647S_do_delete_local(pTHX)
79072805 4648{
39644a26 4649 dSP;
f54cb97a 4650 const I32 gimme = GIMME_V;
7332a6c4
VP		 4651 const MAGIC *mg;
4652 HV *stash;
ca3f996a 4653 const bool sliced = !!(PL_op->op_private & OPpSLICE);
626040f7 4654 SV **unsliced_keysv = sliced ? NULL : sp--;
ca3f996a 4655 SV * const osv = POPs;
626040f7 4656 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
ca3f996a
FC		 4657 dORIGMARK;
4658 const bool tied = SvRMAGICAL(osv)
7332a6c4 4659 && mg_find((const SV *)osv, PERL_MAGIC_tied);
ca3f996a
FC		 4660 const bool can_preserve = SvCANEXISTDELETE(osv);
4661 const U32 type = SvTYPE(osv);
626040f7 4662 SV ** const end = sliced ? SP : unsliced_keysv;
ca3f996a
FC		 4663
4664 if (type == SVt_PVHV) { /* hash element */
7332a6c4 4665 HV * const hv = MUTABLE_HV(osv);
ca3f996a 4666 while (++MARK <= end) {
7332a6c4
VP		 4667 SV * const keysv = *MARK;
4668 SV *sv = NULL;
4669 bool preeminent = TRUE;
4670 if (can_preserve)
4671 preeminent = hv_exists_ent(hv, keysv, 0);
4672 if (tied) {
4673 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4674 if (he)
4675 sv = HeVAL(he);
4676 else
4677 preeminent = FALSE;
4678 }
4679 else {
4680 sv = hv_delete_ent(hv, keysv, 0, 0);
9332b95f
FC		 4681 if (preeminent)
4682 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
7332a6c4
VP		 4683 }
4684 if (preeminent) {
be6064fd 4685 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
7332a6c4
VP		 4686 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4687 if (tied) {
4688 *MARK = sv_mortalcopy(sv);
4689 mg_clear(sv);
4690 } else
4691 *MARK = sv;
4692 }
4693 else {
4694 SAVEHDELETE(hv, keysv);
4695 *MARK = &PL_sv_undef;
4696 }
4697 }
ca3f996a
FC		 4698 }
4699 else if (type == SVt_PVAV) { /* array element */
7332a6c4
VP		 4700 if (PL_op->op_flags & OPf_SPECIAL) {
4701 AV * const av = MUTABLE_AV(osv);
ca3f996a 4702 while (++MARK <= end) {
c70927a6 4703 SSize_t idx = SvIV(*MARK);
7332a6c4
VP		 4704 SV *sv = NULL;
4705 bool preeminent = TRUE;
4706 if (can_preserve)
4707 preeminent = av_exists(av, idx);
4708 if (tied) {
4709 SV **svp = av_fetch(av, idx, 1);
4710 if (svp)
4711 sv = *svp;
4712 else
4713 preeminent = FALSE;
4714 }
4715 else {
4716 sv = av_delete(av, idx, 0);
9332b95f
FC		 4717 if (preeminent)
4718 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
7332a6c4
VP		 4719 }
4720 if (preeminent) {
4721 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4722 if (tied) {
4723 *MARK = sv_mortalcopy(sv);
4724 mg_clear(sv);
4725 } else
4726 *MARK = sv;
4727 }
4728 else {
4729 SAVEADELETE(av, idx);
4730 *MARK = &PL_sv_undef;
4731 }
4732 }
4733 }
ca3f996a
FC		 4734 else
4735 DIE(aTHX_ "panic: avhv_delete no longer supported");
4736 }
4737 else
7332a6c4 4738 DIE(aTHX_ "Not a HASH reference");
ca3f996a 4739 if (sliced) {
7332a6c4
VP		 4740 if (gimme == G_VOID)
4741 SP = ORIGMARK;
4742 else if (gimme == G_SCALAR) {
4743 MARK = ORIGMARK;
4744 if (SP > MARK)
4745 *++MARK = *SP;
4746 else
4747 *++MARK = &PL_sv_undef;
4748 SP = MARK;
4749 }
4750 }
ca3f996a 4751 else if (gimme != G_VOID)
626040f7 4752 PUSHs(*unsliced_keysv);
7332a6c4
VP		 4753
4754 RETURN;
4755}
4756
4757PP(pp_delete)
4758{
7332a6c4
VP		 4759 dSP;
4760 I32 gimme;
4761 I32 discard;
4762
4763 if (PL_op->op_private & OPpLVAL_INTRO)
4764 return do_delete_local();
4765
4766 gimme = GIMME_V;
4767 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5f05dabc 4768
533c011a 4769 if (PL_op->op_private & OPpSLICE) {
5f05dabc 4770 dMARK; dORIGMARK;
85fbaab2 4771 HV * const hv = MUTABLE_HV(POPs);
1b6737cc 4772 const U32 hvtype = SvTYPE(hv);
01020589
GS		 4773 if (hvtype == SVt_PVHV) { /* hash element */
4774 while (++MARK <= SP) {
1b6737cc 4775 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 4776 *MARK = sv ? sv : &PL_sv_undef;
4777 }
5f05dabc 4778 }
6d822dc4
MS		 4779 else if (hvtype == SVt_PVAV) { /* array element */
4780 if (PL_op->op_flags & OPf_SPECIAL) {
4781 while (++MARK <= SP) {
502c6561 4782 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
6d822dc4
MS		 4783 *MARK = sv ? sv : &PL_sv_undef;
4784 }
4785 }
01020589
GS		 4786 }
4787 else
4788 DIE(aTHX_ "Not a HASH reference");
54310121 4789 if (discard)
4790 SP = ORIGMARK;
4791 else if (gimme == G_SCALAR) {
5f05dabc 4792 MARK = ORIGMARK;
9111c9c0
DM		 4793 if (SP > MARK)
4794 *++MARK = *SP;
4795 else
4796 *++MARK = &PL_sv_undef;
5f05dabc 4797 SP = MARK;
4798 }
4799 }
4800 else {
4801 SV *keysv = POPs;
85fbaab2 4802 HV * const hv = MUTABLE_HV(POPs);
295d248e 4803 SV *sv = NULL;
97fcbf96
MB		 4804 if (SvTYPE(hv) == SVt_PVHV)
4805 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 4806 else if (SvTYPE(hv) == SVt_PVAV) {
4807 if (PL_op->op_flags & OPf_SPECIAL)
502c6561 4808 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
af288a60
HS		 4809 else
4810 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 4811 }
97fcbf96 4812 else
cea2e8a9 4813 DIE(aTHX_ "Not a HASH reference");
5f05dabc 4814 if (!sv)
3280af22 4815 sv = &PL_sv_undef;
54310121 4816 if (!discard)
4817 PUSHs(sv);
79072805 4818 }
79072805
LW		 4819 RETURN;
4820}
4821
a0d0e21e 4822PP(pp_exists)
79072805 4823{
39644a26 4824 dSP;
afebc493
GS		 4825 SV *tmpsv;
4826 HV *hv;
4827
c7e88ff3 4828 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
afebc493 4829 GV *gv;
0bd48802 4830 SV * const sv = POPs;
f2c0649b 4831 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
afebc493
GS		 4832 if (cv)
4833 RETPUSHYES;
4834 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4835 RETPUSHYES;
4836 RETPUSHNO;
4837 }
4838 tmpsv = POPs;
85fbaab2 4839 hv = MUTABLE_HV(POPs);
c7e88ff3 4840 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
ae77835f 4841 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 4842 RETPUSHYES;
ef54e1a4
JH		 4843 }
4844 else if (SvTYPE(hv) == SVt_PVAV) {
01020589 4845 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
502c6561 4846 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
01020589
GS		 4847 RETPUSHYES;
4848 }
ef54e1a4
JH		 4849 }
4850 else {
cea2e8a9 4851 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 4852 }
a0d0e21e
LW		 4853 RETPUSHNO;
4854}
79072805 4855
a0d0e21e
LW		 4856PP(pp_hslice)
4857{
20b7effb 4858 dSP; dMARK; dORIGMARK;
eb578fdb
KW		 4859 HV * const hv = MUTABLE_HV(POPs);
4860 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
1b6737cc 4861 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 4862 bool can_preserve = FALSE;
79072805 4863
eb85dfd3
DM		 4864 if (localizing) {
4865 MAGIC *mg;
4866 HV *stash;
4867
2c5f48c2 4868 if (SvCANEXISTDELETE(hv))
d30e492c 4869 can_preserve = TRUE;
eb85dfd3
DM		 4870 }
4871
6d822dc4 4872 while (++MARK <= SP) {
1b6737cc 4873 SV * const keysv = *MARK;
6d822dc4
MS		 4874 SV **svp;
4875 HE *he;
d30e492c
VP		 4876 bool preeminent = TRUE;
4877
4878 if (localizing && can_preserve) {
4879 /* If we can determine whether the element exist,
4880 * try to preserve the existenceness of a tied hash
4881 * element by using EXISTS and DELETE if possible.
4882 * Fallback to FETCH and STORE otherwise. */
4883 preeminent = hv_exists_ent(hv, keysv, 0);
6d822dc4 4884 }
eb85dfd3 4885
6d822dc4 4886 he = hv_fetch_ent(hv, keysv, lval, 0);
fe5bfecd 4887 svp = he ? &HeVAL(he) : NULL;
eb85dfd3 4888
6d822dc4 4889 if (lval) {
746f6409 4890 if (!svp || !*svp || *svp == &PL_sv_undef) {
be2597df 4891 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6d822dc4
MS		 4892 }
4893 if (localizing) {
7a2e501a 4894 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 4895 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP		 4896 else if (preeminent)
4897 save_helem_flags(hv, keysv, svp,
4898 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4899 else
4900 SAVEHDELETE(hv, keysv);
6d822dc4
MS		 4901 }
4902 }
746f6409 4903 *MARK = svp && *svp ? *svp : &PL_sv_undef;
79072805 4904 }
82334630 4905 if (GIMME_V != G_ARRAY) {
a0d0e21e 4906 MARK = ORIGMARK;
04ab2c87 4907 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e 4908 SP = MARK;
79072805 4909 }
a0d0e21e
LW		 4910 RETURN;
4911}
4912
5cae3edb
RZ		 4913PP(pp_kvhslice)
4914{
20b7effb 4915 dSP; dMARK;
5cae3edb
RZ		 4916 HV * const hv = MUTABLE_HV(POPs);
4917 I32 lval = (PL_op->op_flags & OPf_MOD);
adad97db 4918 SSize_t items = SP - MARK;
5cae3edb
RZ		 4919
4920 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4921 const I32 flags = is_lvalue_sub();
4922 if (flags) {
4923 if (!(flags & OPpENTERSUB_INARGS))
7aae0299 4924 /* diag_listed_as: Can't modify %s in %s */
5cae3edb
RZ		 4925 Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
4926 lval = flags;
4927 }
4928 }
4929
4930 MEXTEND(SP,items);
4931 while (items > 1) {
4932 *(MARK+items*2-1) = *(MARK+items);
4933 items--;
4934 }
4935 items = SP-MARK;
4936 SP += items;
4937
4938 while (++MARK <= SP) {
4939 SV * const keysv = *MARK;
4940 SV **svp;
4941 HE *he;
4942
4943 he = hv_fetch_ent(hv, keysv, lval, 0);
4944 svp = he ? &HeVAL(he) : NULL;
4945
4946 if (lval) {
4947 if (!svp || !*svp || *svp == &PL_sv_undef) {
4948 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4949 }
4950 *MARK = sv_mortalcopy(*MARK);
4951 }
4952 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
4953 }
82334630 4954 if (GIMME_V != G_ARRAY) {
5cae3edb
RZ		 4955 MARK = SP - items*2;
4956 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4957 SP = MARK;
4958 }
4959 RETURN;
4960}
4961
a0d0e21e
LW		 4962/* List operators. */
4963
4964PP(pp_list)
4965{
4fa715fa 4966 I32 markidx = POPMARK;
82334630 4967 if (GIMME_V != G_ARRAY) {
4fa715fa
DD		 4968 SV **mark = PL_stack_base + markidx;
4969 dSP;
a0d0e21e
LW		 4970 if (++MARK <= SP)
4971 *MARK = *SP; /* unwanted list, return last item */
8990e307 4972 else
3280af22 4973 *MARK = &PL_sv_undef;
a0d0e21e 4974 SP = MARK;
4fa715fa 4975 PUTBACK;
79072805 4976 }
4fa715fa 4977 return NORMAL;
79072805
LW		 4978}
4979
a0d0e21e 4980PP(pp_lslice)
79072805 4981{
39644a26 4982 dSP;
1b6737cc
AL		 4983 SV ** const lastrelem = PL_stack_sp;
4984 SV ** const lastlelem = PL_stack_base + POPMARK;
4985 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
eb578fdb 4986 SV ** const firstrelem = lastlelem + 1;
706a6ebc 4987 const U8 mod = PL_op->op_flags & OPf_MOD;
1b6737cc 4988
eb578fdb
KW		 4989 const I32 max = lastrelem - lastlelem;
4990 SV **lelem;
a0d0e21e 4991
82334630 4992 if (GIMME_V != G_ARRAY) {
4ea561bc 4993 I32 ix = SvIV(*lastlelem);
748a9306
LW		 4994 if (ix < 0)
4995 ix += max;
a0d0e21e 4996 if (ix < 0 || ix >= max)
3280af22 4997 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 4998 else
4999 *firstlelem = firstrelem[ix];
5000 SP = firstlelem;
5001 RETURN;
5002 }
5003
5004 if (max == 0) {
5005 SP = firstlelem - 1;
5006 RETURN;
5007 }
5008
5009 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4ea561bc 5010 I32 ix = SvIV(*lelem);
c73bf8e3 5011 if (ix < 0)
a0d0e21e 5012 ix += max;
c73bf8e3
HS		 5013 if (ix < 0 || ix >= max)
5014 *lelem = &PL_sv_undef;
5015 else {
c73bf8e3 5016 if (!(*lelem = firstrelem[ix]))
3280af22 5017 *lelem = &PL_sv_undef;
60779a30 5018 else if (mod && SvPADTMP(*lelem)) {
706a6ebc 5019 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
60779a30 5020 }
748a9306 5021 }
79072805 5022 }
cbce292e 5023 SP = lastlelem;
79072805
LW		 5024 RETURN;
5025}
5026
a0d0e21e
LW		 5027PP(pp_anonlist)
5028{
20b7effb 5029 dSP; dMARK;
1b6737cc 5030 const I32 items = SP - MARK;
ad64d0ec 5031 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
31476221 5032 SP = MARK;
6e449a3a
MHM		 5033 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5034 ? newRV_noinc(av) : av);
a0d0e21e
LW		 5035 RETURN;
5036}
5037
5038PP(pp_anonhash)
79072805 5039{
20b7effb 5040 dSP; dMARK; dORIGMARK;
67e67fd7 5041 HV* const hv = newHV();
8d455b9f 5042 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
67e67fd7 5043 ? newRV_noinc(MUTABLE_SV(hv))
8d455b9f 5044 : MUTABLE_SV(hv) );
a0d0e21e
LW		 5045
5046 while (MARK < SP) {
3ed356df
FC		 5047 SV * const key =
5048 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5049 SV *val;
a0d0e21e 5050 if (MARK < SP)
3ed356df
FC		 5051 {
5052 MARK++;
5053 SvGETMAGIC(*MARK);
5054 val = newSV(0);
d187b712 5055 sv_setsv_nomg(val, *MARK);
3ed356df 5056 }
a2a5de95 5057 else
3ed356df 5058 {
a2a5de95 5059 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3ed356df
FC		 5060 val = newSV(0);
5061 }
f12c7020 5062 (void)hv_store_ent(hv,key,val,0);
79072805 5063 }
a0d0e21e 5064 SP = ORIGMARK;
8d455b9f 5065 XPUSHs(retval);
79072805
LW		 5066 RETURN;
5067}
5068
d4fc4415
FC		 5069static AV *
5070S_deref_plain_array(pTHX_ AV *ary)
5071{
5072 if (SvTYPE(ary) == SVt_PVAV) return ary;
d2d95e13 5073 SvGETMAGIC((SV *)ary);
d4fc4415
FC		 5074 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5075 Perl_die(aTHX_ "Not an ARRAY reference");
5076 else if (SvOBJECT(SvRV(ary)))
5077 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5078 return (AV *)SvRV(ary);
5079}
5080
5081#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5082# define DEREF_PLAIN_ARRAY(ary) \
5083 ({ \
5084 AV *aRrRay = ary; \
5085 SvTYPE(aRrRay) == SVt_PVAV \
5086 ? aRrRay \
5087 : S_deref_plain_array(aTHX_ aRrRay); \
5088 })
5089#else
5090# define DEREF_PLAIN_ARRAY(ary) \
5091 ( \
3b0f6d32 5092 PL_Sv = (SV *)(ary), \
d4fc4415
FC		 5093 SvTYPE(PL_Sv) == SVt_PVAV \
5094 ? (AV *)PL_Sv \
3b0f6d32 5095 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
d4fc4415
FC		 5096 )
5097#endif
5098
a0d0e21e 5099PP(pp_splice)
79072805 5100{
20b7effb 5101 dSP; dMARK; dORIGMARK;
5cd408a2 5102 int num_args = (SP - MARK);
eb578fdb
KW		 5103 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5104 SV **src;
5105 SV **dst;
c70927a6
FC		 5106 SSize_t i;
5107 SSize_t offset;
5108 SSize_t length;
5109 SSize_t newlen;
5110 SSize_t after;
5111 SSize_t diff;
ad64d0ec 5112 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 5113
1b6737cc 5114 if (mg) {
3e0cb5de 5115 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
af71faff
NC		 5116 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5117 sp - mark);
93965878 5118 }
79072805 5119
a0d0e21e 5120 SP++;
79072805 5121
a0d0e21e 5122 if (++MARK < SP) {
4ea561bc 5123 offset = i = SvIV(*MARK);
a0d0e21e 5124 if (offset < 0)
93965878 5125 offset += AvFILLp(ary) + 1;
84902520 5126 if (offset < 0)
cea2e8a9 5127 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 5128 if (++MARK < SP) {
5129 length = SvIVx(*MARK++);
48cdf507
GA		 5130 if (length < 0) {
5131 length += AvFILLp(ary) - offset + 1;
5132 if (length < 0)
5133 length = 0;
5134 }
79072805
LW		 5135 }
5136 else
a0d0e21e 5137 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 5138 }
a0d0e21e
LW		 5139 else {
5140 offset = 0;
5141 length = AvMAX(ary) + 1;
5142 }
8cbc2e3b 5143 if (offset > AvFILLp(ary) + 1) {
5cd408a2
EB		 5144 if (num_args > 2)
5145 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 5146 offset = AvFILLp(ary) + 1;
8cbc2e3b 5147 }
93965878 5148 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 5149 if (after < 0) { /* not that much array */
5150 length += after; /* offset+length now in array */
5151 after = 0;
5152 if (!AvALLOC(ary))
5153 av_extend(ary, 0);
5154 }
5155
5156 /* At this point, MARK .. SP-1 is our new LIST */
5157
5158 newlen = SP - MARK;
5159 diff = newlen - length;
13d7cbc1
GS		 5160 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5161 av_reify(ary);
a0d0e21e 5162
50528de0
WL		 5163 /* make new elements SVs now: avoid problems if they're from the array */
5164 for (dst = MARK, i = newlen; i; i--) {
1b6737cc 5165 SV * const h = *dst;
f2b990bf 5166 *dst++ = newSVsv(h);
50528de0
WL		 5167 }
5168
a0d0e21e 5169 if (diff < 0) { /* shrinking the area */
95b63a38 5170 SV **tmparyval = NULL;
a0d0e21e 5171 if (newlen) {
a02a5408 5172 Newx(tmparyval, newlen, SV*); /* so remember insertion */
a0d0e21e 5173 Copy(MARK, tmparyval, newlen, SV*);
79072805 5174 }
a0d0e21e
LW		 5175
5176 MARK = ORIGMARK + 1;
82334630 5177 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
31c61add 5178 const bool real = cBOOL(AvREAL(ary));
a0d0e21e 5179 MEXTEND(MARK, length);
31c61add 5180 if (real)
bbce6d69 5181 EXTEND_MORTAL(length);
31c61add
FC		 5182 for (i = 0, dst = MARK; i < length; i++) {
5183 if ((*dst = AvARRAY(ary)[i+offset])) {
5184 if (real)
486ec47a 5185 sv_2mortal(*dst); /* free them eventually */
36477c24 5186 }
31c61add
FC		 5187 else
5188 *dst = &PL_sv_undef;
5189 dst++;
a0d0e21e
LW		 5190 }
5191 MARK += length - 1;
79072805 5192 }
a0d0e21e
LW		 5193 else {
5194 *MARK = AvARRAY(ary)[offset+length-1];
5195 if (AvREAL(ary)) {
d689ffdd 5196 sv_2mortal(*MARK);
a0d0e21e
LW		 5197 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5198 SvREFCNT_dec(*dst++); /* free them now */
79072805 5199 }
a0d0e21e 5200 }
93965878 5201 AvFILLp(ary) += diff;
a0d0e21e
LW		 5202
5203 /* pull up or down? */
5204
5205 if (offset < after) { /* easier to pull up */
5206 if (offset) { /* esp. if nothing to pull */
5207 src = &AvARRAY(ary)[offset-1];
5208 dst = src - diff; /* diff is negative */
5209 for (i = offset; i > 0; i--) /* can't trust Copy */
5210 *dst-- = *src--;
79072805 5211 }
a0d0e21e 5212 dst = AvARRAY(ary);
9c6bc640 5213 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
a0d0e21e
LW		 5214 AvMAX(ary) += diff;
5215 }
5216 else {
5217 if (after) { /* anything to pull down? */
5218 src = AvARRAY(ary) + offset + length;
5219 dst = src + diff; /* diff is negative */
5220 Move(src, dst, after, SV*);
79072805 5221 }
93965878 5222 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 5223 /* avoid later double free */
5224 }
5225 i = -diff;
5226 while (i)
ce0d59fd 5227 dst[--i] = NULL;
a0d0e21e
LW		 5228
5229 if (newlen) {
50528de0 5230 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e
LW		 5231 Safefree(tmparyval);
5232 }
5233 }
5234 else { /* no, expanding (or same) */
d3961450 5235 SV** tmparyval = NULL;
a0d0e21e 5236 if (length) {
a02a5408 5237 Newx(tmparyval, length, SV*); /* so remember deletion */
a0d0e21e
LW		 5238 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5239 }
5240
5241 if (diff > 0) { /* expanding */
a0d0e21e 5242 /* push up or down? */
a0d0e21e
LW		 5243 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5244 if (offset) {
5245 src = AvARRAY(ary);
5246 dst = src - diff;
5247 Move(src, dst, offset, SV*);
79072805 5248 }
9c6bc640 5249 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
a0d0e21e 5250 AvMAX(ary) += diff;
93965878 5251 AvFILLp(ary) += diff;
79072805
LW		 5252 }
5253 else {
93965878
NIS		 5254 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5255 av_extend(ary, AvFILLp(ary) + diff);
5256 AvFILLp(ary) += diff;
a0d0e21e
LW		 5257
5258 if (after) {
93965878 5259 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 5260 src = dst - diff;
5261 for (i = after; i; i--) {
5262 *dst-- = *src--;
5263 }
79072805
LW		 5264 }
5265 }
a0d0e21e
LW		 5266 }
5267
50528de0
WL		 5268 if (newlen) {
5269 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e 5270 }
50528de0 5271
a0d0e21e 5272 MARK = ORIGMARK + 1;
82334630 5273 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
a0d0e21e 5274 if (length) {
31c61add
FC		 5275 const bool real = cBOOL(AvREAL(ary));
5276 if (real)
bbce6d69 5277 EXTEND_MORTAL(length);
31c61add
FC		 5278 for (i = 0, dst = MARK; i < length; i++) {
5279 if ((*dst = tmparyval[i])) {
5280 if (real)
486ec47a 5281 sv_2mortal(*dst); /* free them eventually */
36477c24 5282 }
31c61add
FC		 5283 else *dst = &PL_sv_undef;
5284 dst++;
79072805
LW		 5285 }
5286 }
a0d0e21e
LW		 5287 MARK += length - 1;
5288 }
5289 else if (length--) {
5290 *MARK = tmparyval[length];
5291 if (AvREAL(ary)) {
d689ffdd 5292 sv_2mortal(*MARK);
a0d0e21e
LW		 5293 while (length-- > 0)
5294 SvREFCNT_dec(tmparyval[length]);
79072805 5295 }
79072805 5296 }
a0d0e21e 5297 else
3280af22 5298 *MARK = &PL_sv_undef;
d3961450 5299 Safefree(tmparyval);
79072805 5300 }
474af990
FR		 5301
5302 if (SvMAGICAL(ary))
5303 mg_set(MUTABLE_SV(ary));
5304
a0d0e21e 5305 SP = MARK;
79072805
LW		 5306 RETURN;
5307}
5308
a0d0e21e 5309PP(pp_push)
79072805 5310{
20b7effb 5311 dSP; dMARK; dORIGMARK; dTARGET;
eb578fdb 5312 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5313 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
79072805 5314
1b6737cc 5315 if (mg) {
ad64d0ec 5316 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
93965878
NIS		 5317 PUSHMARK(MARK);
5318 PUTBACK;
d343c3ef 5319 ENTER_with_name("call_PUSH");
3e0cb5de 5320 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5321 LEAVE_with_name("call_PUSH");
93965878 5322 SPAGAIN;
93965878 5323 }
a60c0954 5324 else {
cb077ed2 5325 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
89c14e2e 5326 PL_delaymagic = DM_DELAY;
a60c0954 5327 for (++MARK; MARK <= SP; MARK++) {
3ed356df
FC		 5328 SV *sv;
5329 if (*MARK) SvGETMAGIC(*MARK);
5330 sv = newSV(0);
a60c0954 5331 if (*MARK)
3ed356df 5332 sv_setsv_nomg(sv, *MARK);
0a75904b 5333 av_store(ary, AvFILLp(ary)+1, sv);
a60c0954 5334 }
354b0578 5335 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 5336 mg_set(MUTABLE_SV(ary));
89c14e2e
BB		 5337
5338 PL_delaymagic = 0;
6eeabd23
VP		 5339 }
5340 SP = ORIGMARK;
5341 if (OP_GIMME(PL_op, 0) != G_VOID) {
5342 PUSHi( AvFILL(ary) + 1 );
79072805 5343 }
79072805
LW		 5344 RETURN;
5345}
5346
b1c05ba5 5347/* also used for: pp_pop()*/
a0d0e21e 5348PP(pp_shift)
79072805 5349{
39644a26 5350 dSP;
538f5756 5351 AV * const av = PL_op->op_flags & OPf_SPECIAL
d4fc4415 5352 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
789b4bc9 5353 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
79072805 5354 EXTEND(SP, 1);
c2b4a044 5355 assert (sv);
d689ffdd 5356 if (AvREAL(av))
a0d0e21e
LW		 5357 (void)sv_2mortal(sv);
5358 PUSHs(sv);
79072805 5359 RETURN;
79072805
LW		 5360}
5361
a0d0e21e 5362PP(pp_unshift)
79072805 5363{
20b7effb 5364 dSP; dMARK; dORIGMARK; dTARGET;
eb578fdb 5365 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5366 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 5367
1b6737cc 5368 if (mg) {
ad64d0ec 5369 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
7fd66d9d 5370 PUSHMARK(MARK);
93965878 5371 PUTBACK;
d343c3ef 5372 ENTER_with_name("call_UNSHIFT");
36925d9e 5373 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5374 LEAVE_with_name("call_UNSHIFT");
93965878 5375 SPAGAIN;
93965878 5376 }
a60c0954 5377 else {
c70927a6 5378 SSize_t i = 0;
a60c0954
NIS		 5379 av_unshift(ary, SP - MARK);
5380 while (MARK < SP) {
1b6737cc 5381 SV * const sv = newSVsv(*++MARK);
a60c0954
NIS		 5382 (void)av_store(ary, i++, sv);
5383 }
79072805 5384 }
a0d0e21e 5385 SP = ORIGMARK;
6eeabd23 5386 if (OP_GIMME(PL_op, 0) != G_VOID) {
5658d0a9
LR		 5387 PUSHi( AvFILL(ary) + 1 );
5388 }
79072805 5389 RETURN;
79072805
LW		 5390}
5391
a0d0e21e 5392PP(pp_reverse)
79072805 5393{
20b7effb 5394 dSP; dMARK;
79072805 5395
82334630 5396 if (GIMME_V == G_ARRAY) {
484c818f
VP		 5397 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5398 AV *av;
5399
5400 /* See pp_sort() */
5401 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5402 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5403 av = MUTABLE_AV((*SP));
5404 /* In-place reversing only happens in void context for the array
5405 * assignment. We don't need to push anything on the stack. */
5406 SP = MARK;
5407
5408 if (SvMAGICAL(av)) {
c70927a6 5409 SSize_t i, j;
eb578fdb 5410 SV *tmp = sv_newmortal();
484c818f
VP		 5411 /* For SvCANEXISTDELETE */
5412 HV *stash;
5413 const MAGIC *mg;
5414 bool can_preserve = SvCANEXISTDELETE(av);
5415
b9f2b683 5416 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
eb578fdb 5417 SV *begin, *end;
484c818f
VP		 5418
5419 if (can_preserve) {
5420 if (!av_exists(av, i)) {
5421 if (av_exists(av, j)) {
eb578fdb 5422 SV *sv = av_delete(av, j, 0);
484c818f
VP		 5423 begin = *av_fetch(av, i, TRUE);
5424 sv_setsv_mg(begin, sv);
5425 }
5426 continue;
5427 }
5428 else if (!av_exists(av, j)) {
eb578fdb 5429 SV *sv = av_delete(av, i, 0);
484c818f
VP		 5430 end = *av_fetch(av, j, TRUE);
5431 sv_setsv_mg(end, sv);
5432 continue;
5433 }
5434 }
5435
5436 begin = *av_fetch(av, i, TRUE);
5437 end = *av_fetch(av, j, TRUE);
5438 sv_setsv(tmp, begin);
5439 sv_setsv_mg(begin, end);
5440 sv_setsv_mg(end, tmp);
5441 }
5442 }
5443 else {
5444 SV **begin = AvARRAY(av);
484c818f 5445
95a26d8e
VP		 5446 if (begin) {
5447 SV **end = begin + AvFILLp(av);
5448
5449 while (begin < end) {
eb578fdb 5450 SV * const tmp = *begin;
95a26d8e
VP		 5451 *begin++ = *end;
5452 *end-- = tmp;
5453 }
484c818f
VP		 5454 }
5455 }
5456 }
5457 else {
5458 SV **oldsp = SP;
5459 MARK++;
5460 while (MARK < SP) {
eb578fdb 5461 SV * const tmp = *MARK;
484c818f
VP		 5462 *MARK++ = *SP;
5463 *SP-- = tmp;
5464 }
5465 /* safe as long as stack cannot get extended in the above */
5466 SP = oldsp;
a0d0e21e 5467 }
79072805
LW		 5468 }
5469 else {
eb578fdb
KW		 5470 char *up;
5471 char *down;
5472 I32 tmp;
a0d0e21e
LW		 5473 dTARGET;
5474 STRLEN len;
79072805 5475
7e2040f0 5476 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 5477 if (SP - MARK > 1)
3280af22 5478 do_join(TARG, &PL_sv_no, MARK, SP);
1e21d011 5479 else {
789bd863 5480 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
1e21d011
B		 5481 }
5482
a0d0e21e
LW		 5483 up = SvPV_force(TARG, len);
5484 if (len > 1) {
7e2040f0 5485 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55 5486 U8* s = (U8*)SvPVX(TARG);
349d4f2f 5487 const U8* send = (U8*)(s + len);
a0ed51b3 5488 while (s < send) {
d742c382 5489 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 5490 s++;
5491 continue;
5492 }
5493 else {
4b88fb76 5494 if (!utf8_to_uvchr_buf(s, send, 0))
a0dbb045 5495 break;
dfe13c55 5496 up = (char*)s;
a0ed51b3 5497 s += UTF8SKIP(s);
dfe13c55 5498 down = (char*)(s - 1);
a0dbb045 5499 /* reverse this character */
a0ed51b3
LW		 5500 while (down > up) {
5501 tmp = *up;
5502 *up++ = *down;
eb160463 5503 *down-- = (char)tmp;
a0ed51b3
LW		 5504 }
5505 }
5506 }
5507 up = SvPVX(TARG);
5508 }
a0d0e21e
LW		 5509 down = SvPVX(TARG) + len - 1;
5510 while (down > up) {
5511 tmp = *up;
5512 *up++ = *down;
eb160463 5513 *down-- = (char)tmp;
a0d0e21e 5514 }
3aa33fe5 5515 (void)SvPOK_only_UTF8(TARG);
79072805 5516 }
a0d0e21e
LW		 5517 SP = MARK + 1;
5518 SETTARG;
79072805 5519 }
a0d0e21e 5520 RETURN;
79072805
LW		 5521}
5522
a0d0e21e 5523PP(pp_split)
79072805 5524{
20b7effb 5525 dSP; dTARG;
ef7999f1 5526 AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
eb578fdb 5527 IV limit = POPi; /* note, negative is forever */
1b6737cc 5528 SV * const sv = POPs;
a0d0e21e 5529 STRLEN len;
eb578fdb 5530 const char *s = SvPV_const(sv, len);
1b6737cc 5531 const bool do_utf8 = DO_UTF8(sv);
727b7506 5532 const char *strend = s + len;
eb578fdb
KW		 5533 PMOP *pm;
5534 REGEXP *rx;
5535 SV *dstr;
5536 const char *m;
c70927a6 5537 SSize_t iters = 0;
d14578b8
KW		 5538 const STRLEN slen = do_utf8
5539 ? utf8_length((U8*)s, (U8*)strend)
5540 : (STRLEN)(strend - s);
c70927a6 5541 SSize_t maxiters = slen + 10;
c1a7495a 5542 I32 trailing_empty = 0;
727b7506 5543 const char *orig;
1b6737cc 5544 const I32 origlimit = limit;
a0d0e21e
LW		 5545 I32 realarray = 0;
5546 I32 base;
f54cb97a 5547 const I32 gimme = GIMME_V;
941446f6 5548 bool gimme_scalar;
f54cb97a 5549 const I32 oldsave = PL_savestack_ix;
437d3b4e 5550 U32 make_mortal = SVs_TEMP;
7fba1cd6 5551 bool multiline = 0;
b37c2d43 5552 MAGIC *mg = NULL;
79072805 5553
44a8e56a 5554#ifdef DEBUGGING
5555 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5556#else
5557 pm = (PMOP*)POPs;
5558#endif
b3941ae9 5559 if (!pm)
5637ef5b 5560 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
aaa362c4 5561 rx = PM_GETRE(pm);
bbce6d69 5562
a62b1201 5563 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
dbc200c5 5564 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
bbce6d69 5565
971a9dd3 5566#ifdef USE_ITHREADS
20e98b0f 5567 if (pm->op_pmreplrootu.op_pmtargetoff) {
159b6efe 5568 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
bf7d93ea 5569 goto have_av;
20e98b0f 5570 }
971a9dd3 5571#else
20e98b0f
NC		 5572 if (pm->op_pmreplrootu.op_pmtargetgv) {
5573 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
bf7d93ea 5574 goto have_av;
971a9dd3 5575 }
20e98b0f 5576#endif
ef7999f1
FC		 5577 else if (pm->op_targ)
5578 ary = (AV *)PAD_SVl(pm->op_targ);
bcea25a7 5579 if (ary) {
bf7d93ea 5580 have_av:
a0d0e21e 5581 realarray = 1;
8ec5e241 5582 PUTBACK;
a0d0e21e 5583 av_extend(ary,0);
821956c5 5584 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 5585 av_clear(ary);
8ec5e241 5586 SPAGAIN;
ad64d0ec 5587 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
8ec5e241 5588 PUSHMARK(SP);
ad64d0ec 5589 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
8ec5e241
NIS		 5590 }
5591 else {
1c0b011c 5592 if (!AvREAL(ary)) {
1b6737cc 5593 I32 i;
1c0b011c 5594 AvREAL_on(ary);
abff13bb 5595 AvREIFY_off(ary);
1c0b011c 5596 for (i = AvFILLp(ary); i >= 0; i--)
d14578b8 5597 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 5598 }
5599 /* temporarily switch stacks */
8b7059b1 5600 SAVESWITCHSTACK(PL_curstack, ary);
8ec5e241 5601 make_mortal = 0;
1c0b011c 5602 }
79072805 5603 }
3280af22 5604 base = SP - PL_stack_base;
a0d0e21e 5605 orig = s;
dbc200c5 5606 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
613f191e 5607 if (do_utf8) {
76a77b1b 5608 while (isSPACE_utf8(s))
613f191e
TS		 5609 s += UTF8SKIP(s);
5610 }
a62b1201 5611 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
bbce6d69 5612 while (isSPACE_LC(*s))
5613 s++;
5614 }
5615 else {
5616 while (isSPACE(*s))
5617 s++;
5618 }
a0d0e21e 5619 }
73134a2e 5620 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
7fba1cd6 5621 multiline = 1;
c07a80fd 5622 }
5623
941446f6
FC		 5624 gimme_scalar = gimme == G_SCALAR && !ary;
5625
a0d0e21e
LW		 5626 if (!limit)
5627 limit = maxiters + 2;
dbc200c5 5628 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
a0d0e21e 5629 while (--limit) {
bbce6d69 5630 m = s;
8727f688
YO		 5631 /* this one uses 'm' and is a negative test */
5632 if (do_utf8) {
76a77b1b 5633 while (m < strend && ! isSPACE_utf8(m) ) {
613f191e 5634 const int t = UTF8SKIP(m);
76a77b1b 5635 /* isSPACE_utf8 returns FALSE for malform utf8 */
613f191e
TS		 5636 if (strend - m < t)
5637 m = strend;
5638 else
5639 m += t;
5640 }
a62b1201 5641 }
d14578b8
KW		 5642 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5643 {
8727f688
YO		 5644 while (m < strend && !isSPACE_LC(*m))
5645 ++m;
5646 } else {
5647 while (m < strend && !isSPACE(*m))
5648 ++m;
5649 }
a0d0e21e
LW		 5650 if (m >= strend)
5651 break;
bbce6d69 5652
c1a7495a
BB		 5653 if (gimme_scalar) {
5654 iters++;
5655 if (m-s == 0)
5656 trailing_empty++;
5657 else
5658 trailing_empty = 0;
5659 } else {
5660 dstr = newSVpvn_flags(s, m-s,
5661 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5662 XPUSHs(dstr);
5663 }
bbce6d69 5664
613f191e
TS		 5665 /* skip the whitespace found last */
5666 if (do_utf8)
5667 s = m + UTF8SKIP(m);
5668 else
5669 s = m + 1;
5670
8727f688
YO		 5671 /* this one uses 's' and is a positive test */
5672 if (do_utf8) {
76a77b1b 5673 while (s < strend && isSPACE_utf8(s) )
8727f688 5674 s += UTF8SKIP(s);
a62b1201 5675 }
d14578b8
KW		 5676 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5677 {
8727f688
YO		 5678 while (s < strend && isSPACE_LC(*s))
5679 ++s;
5680 } else {
5681 while (s < strend && isSPACE(*s))
5682 ++s;
5683 }
79072805
LW		 5684 }
5685 }
07bc277f 5686 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
a0d0e21e 5687 while (--limit) {
a6e20a40
AL		 5688 for (m = s; m < strend && *m != '\n'; m++)
5689 ;
a0d0e21e
LW		 5690 m++;
5691 if (m >= strend)
5692 break;
c1a7495a
BB		 5693
5694 if (gimme_scalar) {
5695 iters++;
5696 if (m-s == 0)
5697 trailing_empty++;
5698 else
5699 trailing_empty = 0;
5700 } else {
5701 dstr = newSVpvn_flags(s, m-s,
5702 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5703 XPUSHs(dstr);
5704 }
a0d0e21e
LW		 5705 s = m;
5706 }
5707 }
07bc277f 5708 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
640f820d
AB		 5709 /*
5710 Pre-extend the stack, either the number of bytes or
5711 characters in the string or a limited amount, triggered by:
5712
5713 my ($x, $y) = split //, $str;
5714 or
5715 split //, $str, $i;
5716 */
c1a7495a
BB		 5717 if (!gimme_scalar) {
5718 const U32 items = limit - 1;
5719 if (items < slen)
5720 EXTEND(SP, items);
5721 else
5722 EXTEND(SP, slen);
5723 }
640f820d 5724
e9515b0f
AB		 5725 if (do_utf8) {
5726 while (--limit) {
5727 /* keep track of how many bytes we skip over */
5728 m = s;
640f820d 5729 s += UTF8SKIP(s);
c1a7495a
BB		 5730 if (gimme_scalar) {
5731 iters++;
5732 if (s-m == 0)
5733 trailing_empty++;
5734 else
5735 trailing_empty = 0;
5736 } else {
5737 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
640f820d 5738
c1a7495a
BB		 5739 PUSHs(dstr);
5740 }
640f820d 5741
e9515b0f
AB		 5742 if (s >= strend)
5743 break;
5744 }
5745 } else {
5746 while (--limit) {
c1a7495a
BB		 5747 if (gimme_scalar) {
5748 iters++;
5749 } else {
5750 dstr = newSVpvn(s, 1);
e9515b0f 5751
e9515b0f 5752
c1a7495a
BB		 5753 if (make_mortal)
5754 sv_2mortal(dstr);
640f820d 5755
c1a7495a
BB		 5756 PUSHs(dstr);
5757 }
5758
5759 s++;
e9515b0f
AB		 5760
5761 if (s >= strend)
5762 break;
5763 }
640f820d
AB		 5764 }
5765 }
3c8556c3 5766 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
07bc277f
NC		 5767 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5768 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
8e1490ee 5769 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
07bc277f 5770 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
f9f4320a 5771 SV * const csv = CALLREG_INTUIT_STRING(rx);
cf93c79d 5772
07bc277f 5773 len = RX_MINLENRET(rx);
3c8556c3 5774 if (len == 1 && !RX_UTF8(rx) && !tail) {
1b6737cc 5775 const char c = *SvPV_nolen_const(csv);
a0d0e21e 5776 while (--limit) {
a6e20a40
AL		 5777 for (m = s; m < strend && *m != c; m++)
5778 ;
a0d0e21e
LW		 5779 if (m >= strend)
5780 break;
c1a7495a
BB		 5781 if (gimme_scalar) {
5782 iters++;
5783 if (m-s == 0)
5784 trailing_empty++;
5785 else
5786 trailing_empty = 0;
5787 } else {
5788 dstr = newSVpvn_flags(s, m-s,
d14578b8 5789 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
c1a7495a
BB		 5790 XPUSHs(dstr);
5791 }
93f04dac
JH		 5792 /* The rx->minlen is in characters but we want to step
5793 * s ahead by bytes. */
1aa99e6b
IH		 5794 if (do_utf8)
5795 s = (char*)utf8_hop((U8*)m, len);
5796 else
5797 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 5798 }
5799 }
5800 else {
a0d0e21e 5801 while (s < strend && --limit &&
f722798b 5802 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
7fba1cd6 5803 csv, multiline ? FBMrf_MULTILINE : 0)) )
a0d0e21e 5804 {
c1a7495a
BB		 5805 if (gimme_scalar) {
5806 iters++;
5807 if (m-s == 0)
5808 trailing_empty++;
5809 else
5810 trailing_empty = 0;
5811 } else {
5812 dstr = newSVpvn_flags(s, m-s,
d14578b8 5813 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
c1a7495a
BB		 5814 XPUSHs(dstr);
5815 }
93f04dac
JH		 5816 /* The rx->minlen is in characters but we want to step
5817 * s ahead by bytes. */
1aa99e6b
IH		 5818 if (do_utf8)
5819 s = (char*)utf8_hop((U8*)m, len);
5820 else
5821 s = m + len; /* Fake \n at the end */
a0d0e21e 5822 }
463ee0b2 5823 }
463ee0b2 5824 }
a0d0e21e 5825 else {
07bc277f 5826 maxiters += slen * RX_NPARENS(rx);
080c2dec 5827 while (s < strend && --limit)
bbce6d69 5828 {
1b6737cc 5829 I32 rex_return;
080c2dec 5830 PUTBACK;
d14578b8 5831 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
c33e64f0 5832 sv, NULL, 0);
080c2dec 5833 SPAGAIN;
1b6737cc 5834 if (rex_return == 0)
080c2dec 5835 break;
d9f97599 5836 TAINT_IF(RX_MATCH_TAINTED(rx));
6502e081
DM		 5837 /* we never pass the REXEC_COPY_STR flag, so it should
5838 * never get copied */
5839 assert(!RX_MATCH_COPIED(rx));
07bc277f 5840 m = RX_OFFS(rx)[0].start + orig;
c1a7495a
BB		 5841
5842 if (gimme_scalar) {
5843 iters++;
5844 if (m-s == 0)
5845 trailing_empty++;
5846 else
5847 trailing_empty = 0;
5848 } else {
5849 dstr = newSVpvn_flags(s, m-s,
5850 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5851 XPUSHs(dstr);
5852 }
07bc277f 5853 if (RX_NPARENS(rx)) {
1b6737cc 5854 I32 i;
07bc277f
NC		 5855 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5856 s = RX_OFFS(rx)[i].start + orig;
5857 m = RX_OFFS(rx)[i].end + orig;
6de67870
JP		 5858
5859 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5860 parens that didn't match -- they should be set to
5861 undef, not the empty string */
c1a7495a
BB		 5862 if (gimme_scalar) {
5863 iters++;
5864 if (m-s == 0)
5865 trailing_empty++;
5866 else
5867 trailing_empty = 0;
5868 } else {
5869 if (m >= orig && s >= orig) {
5870 dstr = newSVpvn_flags(s, m-s,
5871 (do_utf8 ? SVf_UTF8 : 0)
5872 | make_mortal);
5873 }
5874 else
5875 dstr = &PL_sv_undef; /* undef, not "" */
5876 XPUSHs(dstr);
748a9306 5877 }
c1a7495a 5878
a0d0e21e
LW		 5879 }
5880 }
07bc277f 5881 s = RX_OFFS(rx)[0].end + orig;
a0d0e21e 5882 }
79072805 5883 }
8ec5e241 5884
c1a7495a
BB		 5885 if (!gimme_scalar) {
5886 iters = (SP - PL_stack_base) - base;
5887 }
a0d0e21e 5888 if (iters > maxiters)
cea2e8a9 5889 DIE(aTHX_ "Split loop");
8ec5e241 5890
a0d0e21e
LW		 5891 /* keep field after final delim? */
5892 if (s < strend || (iters && origlimit)) {
c1a7495a
BB		 5893 if (!gimme_scalar) {
5894 const STRLEN l = strend - s;
5895 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5896 XPUSHs(dstr);
5897 }
a0d0e21e 5898 iters++;
79072805 5899 }
a0d0e21e 5900 else if (!origlimit) {
c1a7495a
BB		 5901 if (gimme_scalar) {
5902 iters -= trailing_empty;
5903 } else {
5904 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5905 if (TOPs && !make_mortal)
5906 sv_2mortal(TOPs);
5907 *SP-- = &PL_sv_undef;
5908 iters--;
5909 }
89900bd3 5910 }
a0d0e21e 5911 }
8ec5e241 5912
8b7059b1
DM		 5913 PUTBACK;
5914 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5915 SPAGAIN;
a0d0e21e 5916 if (realarray) {
8ec5e241 5917 if (!mg) {
1c0b011c
NIS		 5918 if (SvSMAGICAL(ary)) {
5919 PUTBACK;
ad64d0ec 5920 mg_set(MUTABLE_SV(ary));
1c0b011c
NIS		 5921 SPAGAIN;
5922 }
5923 if (gimme == G_ARRAY) {
5924 EXTEND(SP, iters);
5925 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5926 SP += iters;
5927 RETURN;
5928 }
8ec5e241 5929 }
1c0b011c 5930 else {
fb73857a 5931 PUTBACK;
d343c3ef 5932 ENTER_with_name("call_PUSH");
36925d9e 5933 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5934 LEAVE_with_name("call_PUSH");
fb73857a 5935 SPAGAIN;
8ec5e241 5936 if (gimme == G_ARRAY) {
c70927a6 5937 SSize_t i;
8ec5e241
NIS		 5938 /* EXTEND should not be needed - we just popped them */
5939 EXTEND(SP, iters);
5940 for (i=0; i < iters; i++) {
5941 SV **svp = av_fetch(ary, i, FALSE);
3280af22 5942 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 5943 }
1c0b011c
NIS		 5944 RETURN;
5945 }
a0d0e21e
LW		 5946 }
5947 }
5948 else {
5949 if (gimme == G_ARRAY)
5950 RETURN;
5951 }
7f18b612
YST		 5952
5953 GETTARGET;
5954 PUSHi(iters);
5955 RETURN;
79072805 5956}
85e6fe83 5957
c5917253
NC		 5958PP(pp_once)
5959{
5960 dSP;
5961 SV *const sv = PAD_SVl(PL_op->op_targ);
5962
5963 if (SvPADSTALE(sv)) {
5964 /* First time. */
5965 SvPADSTALE_off(sv);
5966 RETURNOP(cLOGOP->op_other);
5967 }
5968 RETURNOP(cLOGOP->op_next);
5969}
5970
c0329465
MB		 5971PP(pp_lock)
5972{
39644a26 5973 dSP;
c0329465 5974 dTOPss;
e55aaa0e 5975 SV *retsv = sv;
68795e93 5976 SvLOCK(sv);
f79aa60b
FC		 5977 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5978 || SvTYPE(retsv) == SVt_PVCV) {
e55aaa0e
MB		 5979 retsv = refto(retsv);
5980 }
5981 SETs(retsv);
c0329465
MB		 5982 RETURN;
5983}
a863c7d1 5984
65bca31a 5985
b1c05ba5
DM		 5986/* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
5987 * that aren't implemented on a particular platform */
5988
65bca31a
NC		 5989PP(unimplemented_op)
5990{
361ed549
NC		 5991 const Optype op_type = PL_op->op_type;
5992 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5993 with out of range op numbers - it only "special" cases op_custom.
5994 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5995 if we get here for a custom op then that means that the custom op didn't
5996 have an implementation. Given that OP_NAME() looks up the custom op
5997 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5998 registers &PL_unimplemented_op as the address of their custom op.
5999 NULL doesn't generate a useful error message. "custom" does. */
6000 const char *const name = op_type >= OP_max
6001 ? "[out of range]" : PL_op_name[PL_op->op_type];
7627e6d0
NC		 6002 if(OP_IS_SOCKET(op_type))
6003 DIE(aTHX_ PL_no_sock_func, name);
361ed549 6004 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
65bca31a
NC		 6005}
6006
deb8a388
FC		 6007/* For sorting out arguments passed to a &CORE:: subroutine */
6008PP(pp_coreargs)
6009{
6010 dSP;
7fa5bd9b 6011 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
498a02d8 6012 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
7fa5bd9b 6013 AV * const at_ = GvAV(PL_defgv);
0e80230d
FC		 6014 SV **svp = at_ ? AvARRAY(at_) : NULL;
6015 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
7fa5bd9b 6016 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
46e00a91 6017 bool seen_question = 0;
7fa5bd9b 6018 const char *err = NULL;
3e6568b4 6019 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
7fa5bd9b 6020
46e00a91
FC		 6021 /* Count how many args there are first, to get some idea how far to
6022 extend the stack. */
7fa5bd9b 6023 while (oa) {
bf0571fd 6024 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
7fa5bd9b 6025 maxargs++;
46e00a91
FC		 6026 if (oa & OA_OPTIONAL) seen_question = 1;
6027 if (!seen_question) minargs++;
7fa5bd9b
FC		 6028 oa >>= 4;
6029 }
6030
6031 if(numargs < minargs) err = "Not enough";
6032 else if(numargs > maxargs) err = "Too many";
6033 if (err)
6034 /* diag_listed_as: Too many arguments for %s */
6035 Perl_croak(aTHX_
6036 "%s arguments for %s", err,
2a90c7c6 6037 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
7fa5bd9b
FC		 6038 );
6039
6040 /* Reset the stack pointer. Without this, we end up returning our own
6041 arguments in list context, in addition to the values we are supposed
6042 to return. nextstate usually does this on sub entry, but we need
e1fa07e3 6043 to run the next op with the caller's hints, so we cannot have a
7fa5bd9b
FC		 6044 nextstate. */
6045 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
6046
46e00a91
FC		 6047 if(!maxargs) RETURN;
6048
bf0571fd
FC		 6049 /* We do this here, rather than with a separate pushmark op, as it has
6050 to come in between two things this function does (stack reset and
6051 arg pushing). This seems the easiest way to do it. */
3e6568b4 6052 if (pushmark) {
bf0571fd
FC		 6053 PUTBACK;
6054 (void)Perl_pp_pushmark(aTHX);
6055 }
6056
6057 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
c931b036 6058 PUTBACK; /* The code below can die in various places. */
46e00a91
FC		 6059
6060 oa = PL_opargs[opnum] >> OASHIFT;
3e6568b4 6061 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
c931b036 6062 whicharg++;
46e00a91
FC		 6063 switch (oa & 7) {
6064 case OA_SCALAR:
1efec5ed 6065 try_defsv:
d6d78e19 6066 if (!numargs && defgv && whicharg == minargs + 1) {
d6d78e19 6067 PUSHs(find_rundefsv2(
db4cf31d 6068 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
b4b0692a 6069 cxstack[cxstack_ix].blk_oldcop->cop_seq
d6d78e19
FC		 6070 ));
6071 }
6072 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
46e00a91 6073 break;
bf0571fd
FC		 6074 case OA_LIST:
6075 while (numargs--) {
6076 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6077 svp++;
6078 }
6079 RETURN;
19c481f4
FC		 6080 case OA_HVREF:
6081 if (!svp || !*svp || !SvROK(*svp)
6082 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
6083 DIE(aTHX_
6084 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6085 "Type of arg %d to &CORE::%s must be hash reference",
6086 whicharg, OP_DESC(PL_op->op_next)
6087 );
6088 PUSHs(SvRV(*svp));
6089 break;
c931b036 6090 case OA_FILEREF:
30901a8a
FC		 6091 if (!numargs) PUSHs(NULL);
6092 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
c931b036
FC		 6093 /* no magic here, as the prototype will have added an extra
6094 refgen and we just want what was there before that */
6095 PUSHs(SvRV(*svp));
6096 else {
6097 const bool constr = PL_op->op_private & whicharg;
6098 PUSHs(S_rv2gv(aTHX_
6099 svp && *svp ? *svp : &PL_sv_undef,
b54f893d 6100 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
c931b036
FC		 6101 !constr
6102 ));
6103 }
6104 break;
c72a5629 6105 case OA_SCALARREF:
1efec5ed
FC		 6106 if (!numargs) goto try_defsv;
6107 else {
17008668
FC		 6108 const bool wantscalar =
6109 PL_op->op_private & OPpCOREARGS_SCALARMOD;
c72a5629 6110 if (!svp || !*svp || !SvROK(*svp)
17008668
FC		 6111 /* We have to permit globrefs even for the \$ proto, as
6112 *foo is indistinguishable from ${\*foo}, and the proto-
6113 type permits the latter. */
6114 || SvTYPE(SvRV(*svp)) > (
efe889ae 6115 wantscalar ? SVt_PVLV
46bef06f
FC		 6116 : opnum == OP_LOCK || opnum == OP_UNDEF
6117 ? SVt_PVCV
efe889ae 6118 : SVt_PVHV
17008668 6119 )
c72a5629
FC		 6120 )
6121 DIE(aTHX_
17008668 6122 "Type of arg %d to &CORE::%s must be %s",
46bef06f 6123 whicharg, PL_op_name[opnum],
17008668
FC		 6124 wantscalar
6125 ? "scalar reference"
46bef06f 6126 : opnum == OP_LOCK || opnum == OP_UNDEF
efe889ae
FC		 6127 ? "reference to one of [$@%&*]"
6128 : "reference to one of [$@%*]"
c72a5629
FC		 6129 );
6130 PUSHs(SvRV(*svp));
88bb468b
FC		 6131 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6132 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6133 /* Undo @_ localisation, so that sub exit does not undo
6134 part of our undeffing. */
6135 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6136 POP_SAVEARRAY();
6137 cx->cx_type &= ~ CXp_HASARGS;
6138 assert(!AvREAL(cx->blk_sub.argarray));
6139 }
17008668 6140 }
1efec5ed 6141 break;
46e00a91 6142 default:
46e00a91
FC		 6143 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6144 }
6145 oa = oa >> 4;
6146 }
6147
deb8a388
FC		 6148 RETURN;
6149}
6150
84ed0108
FC		 6151PP(pp_runcv)
6152{
6153 dSP;
6154 CV *cv;
6155 if (PL_op->op_private & OPpOFFBYONE) {
db4cf31d 6156 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
84ed0108
FC		 6157 }
6158 else cv = find_runcv(NULL);
e157a82b 6159 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
84ed0108
FC		 6160 RETURN;
6161}
6162
05a34802 6163static void
2331e434 6164S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
05a34802
FC		 6165 const bool can_preserve)
6166{
2331e434 6167 const SSize_t ix = SvIV(keysv);
05a34802
FC		 6168 if (can_preserve ? av_exists(av, ix) : TRUE) {
6169 SV ** const svp = av_fetch(av, ix, 1);
6170 if (!svp || !*svp)
6171 Perl_croak(aTHX_ PL_no_aelem, ix);
6172 save_aelem(av, ix, svp);
6173 }
6174 else
6175 SAVEADELETE(av, ix);
6176}
6177
5f94141d
FC		 6178static void
6179S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6180 const bool can_preserve)
6181{
6182 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6183 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6184 SV ** const svp = he ? &HeVAL(he) : NULL;
6185 if (!svp || !*svp)
6186 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6187 save_helem_flags(hv, keysv, svp, 0);
6188 }
6189 else
6190 SAVEHDELETE(hv, keysv);
6191}
6192
9782ce69
FC		 6193static void
6194S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6195{
6196 if (type == OPpLVREF_SV) {
6197 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6198 GvSV(gv) = 0;
6199 }
6200 else if (type == OPpLVREF_AV)
6201 /* XXX Inefficient, as it creates a new AV, which we are
6202 about to clobber. */
6203 save_ary(gv);
6204 else {
6205 assert(type == OPpLVREF_HV);
6206 /* XXX Likewise inefficient. */
6207 save_hash(gv);
6208 }
6209}
6210
6211
254da51f
FC		 6212PP(pp_refassign)
6213{
4fec8804 6214 dSP;
6102323a 6215 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
d8a875d9 6216 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
4fec8804 6217 dTOPss;
3f114923 6218 const char *bad = NULL;
ac0da85a 6219 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
4fec8804 6220 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
ac0da85a 6221 switch (type) {
3f114923
FC		 6222 case OPpLVREF_SV:
6223 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6224 bad = " SCALAR";
6225 break;
6226 case OPpLVREF_AV:
6227 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6228 bad = "n ARRAY";
6229 break;
6230 case OPpLVREF_HV:
6231 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6232 bad = " HASH";
6233 break;
6234 case OPpLVREF_CV:
6235 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6236 bad = " CODE";
6237 }
6238 if (bad)
1f8155a2 6239 /* diag_listed_as: Assigned value is not %s reference */
3f114923 6240 DIE(aTHX_ "Assigned value is not a%s reference", bad);
b943805e
JH		 6241 {
6242 MAGIC *mg;
6243 HV *stash;
d8a875d9
FC		 6244 switch (left ? SvTYPE(left) : 0) {
6245 case 0:
cf5d2d91
FC		 6246 {
6247 SV * const old = PAD_SV(ARGTARG);
d8a875d9 6248 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
cf5d2d91 6249 SvREFCNT_dec(old);
3ad7d304
FC		 6250 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6251 == OPpLVAL_INTRO)
fc048fcf 6252 SAVECLEARSV(PAD_SVl(ARGTARG));
d8a875d9 6253 break;
cf5d2d91 6254 }
d8a875d9 6255 case SVt_PVGV:
2a57afb1 6256 if (PL_op->op_private & OPpLVAL_INTRO) {
9782ce69 6257 S_localise_gv_slot(aTHX_ (GV *)left, type);
2a57afb1 6258 }
d8a875d9
FC		 6259 gv_setref(left, sv);
6260 SvSETMAGIC(left);
6102323a
FC		 6261 break;
6262 case SVt_PVAV:
40d2b828 6263 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
2331e434 6264 S_localise_aelem_lval(aTHX_ (AV *)left, key,
05a34802 6265 SvCANEXISTDELETE(left));
40d2b828 6266 }
6102323a
FC		 6267 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6268 break;
5f94141d
FC		 6269 case SVt_PVHV:
6270 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
6271 S_localise_helem_lval(aTHX_ (HV *)left, key,
6272 SvCANEXISTDELETE(left));
7fcb36d5 6273 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
d8a875d9 6274 }
4fec8804
FC		 6275 if (PL_op->op_flags & OPf_MOD)
6276 SETs(sv_2mortal(newSVsv(sv)));
6277 /* XXX else can weak references go stale before they are read, e.g.,
6278 in leavesub? */
6279 RETURN;
b943805e 6280 }
254da51f
FC		 6281}
6282
4c5bab50
FC		 6283PP(pp_lvref)
6284{
26a50d99
FC		 6285 dSP;
6286 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6102323a 6287 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
2a57afb1 6288 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
9782ce69
FC		 6289 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6290 &PL_vtbl_lvref, (char *)elem,
23270f96 6291 elem ? HEf_SVKEY : (I32)ARGTARG);
9782ce69 6292 mg->mg_private = PL_op->op_private;
d39c26a6
FC		 6293 if (PL_op->op_private & OPpLVREF_ITER)
6294 mg->mg_flags |= MGf_PERSIST;
9846cd95 6295 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
40d2b828
FC		 6296 if (elem) {
6297 MAGIC *mg;
6298 HV *stash;
5f94141d
FC		 6299 const bool can_preserve = SvCANEXISTDELETE(arg);
6300 if (SvTYPE(arg) == SVt_PVAV)
2331e434 6301 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
5f94141d
FC		 6302 else
6303 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
40d2b828
FC		 6304 }
6305 else if (arg) {
9782ce69
FC		 6306 S_localise_gv_slot(aTHX_ (GV *)arg,
6307 PL_op->op_private & OPpLVREF_TYPE);
2a57afb1 6308 }
3ad7d304 6309 else if (!(PL_op->op_private & OPpPAD_STATE))
c146a62a 6310 SAVECLEARSV(PAD_SVl(ARGTARG));
1199b01a 6311 }
c146a62a
FC		 6312 XPUSHs(ret);
6313 RETURN;
4c5bab50 6314}
84ed0108 6315
16b99412
FC		 6316PP(pp_lvrefslice)
6317{
a95dad8a 6318 dSP; dMARK;
0ca7b7f7
FC		 6319 AV * const av = (AV *)POPs;
6320 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6321 bool can_preserve = FALSE;
6322
9846cd95 6323 if (UNLIKELY(localizing)) {
0ca7b7f7
FC		 6324 MAGIC *mg;
6325 HV *stash;
6326 SV **svp;
6327
6328 can_preserve = SvCANEXISTDELETE(av);
6329
6330 if (SvTYPE(av) == SVt_PVAV) {
6331 SSize_t max = -1;
6332
6333 for (svp = MARK + 1; svp <= SP; svp++) {
6334 const SSize_t elem = SvIV(*svp);
6335 if (elem > max)
6336 max = elem;
6337 }
6338 if (max > AvMAX(av))
6339 av_extend(av, max);
6340 }
6341 }
6342
6343 while (++MARK <= SP) {
6344 SV * const elemsv = *MARK;
5f94141d 6345 if (SvTYPE(av) == SVt_PVAV)
2331e434 6346 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
5f94141d
FC		 6347 else
6348 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
0ca7b7f7
FC		 6349 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6350 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6351 }
6352 RETURN;
16b99412
FC		 6353}
6354
2882b3ff
FC		 6355PP(pp_lvavref)
6356{
bdaf10a5
FC		 6357 if (PL_op->op_flags & OPf_STACKED)
6358 Perl_pp_rv2av(aTHX);
6359 else
6360 Perl_pp_padav(aTHX);
6361 {
6362 dSP;
6363 dTOPss;
6364 SETs(0); /* special alias marker that aassign recognises */
6365 XPUSHs(sv);
6366 RETURN;
6367 }
2882b3ff
FC		 6368}
6369
e609e586
NC		 6370/*
6371 * Local variables:
6372 * c-indentation-style: bsd
6373 * c-basic-offset: 4
14d04a33 6374 * indent-tabs-mode: nil
e609e586
NC		 6375 * End:
6376 *
14d04a33 6377 * ex: set ts=8 sts=4 sw=4 et:
37442d52 6378 */
Unnamed repository; edit this file 'description' to name the repository.