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