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
Wrong (non-existent) Config var name.
[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;
59f00321
RGS		 755 else if (PL_op->op_private & OPpTARGET_MY)
756 sv = GETTARGET;
79072805 757 else {
54b9620d 758 sv = DEFSV;
a0d0e21e 759 EXTEND(SP,1);
79072805 760 }
bb16bae8 761 if(PL_op->op_type == OP_TRANSR) {
290797f7
FC		 762 STRLEN len;
763 const char * const pv = SvPV(sv,len);
764 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
bb16bae8 765 do_trans(newsv);
290797f7 766 PUSHs(newsv);
bb16bae8 767 }
5bbe7184
FC		 768 else {
769 TARG = sv_newmortal();
770 PUSHi(do_trans(sv));
771 }
a0d0e21e 772 RETURN;
79072805
LW		 773}
774
a0d0e21e 775/* Lvalue operators. */
79072805 776
81745e4e
NC		 777static void
778S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
779{
81745e4e
NC		 780 STRLEN len;
781 char *s;
782
783 PERL_ARGS_ASSERT_DO_CHOMP;
784
785 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
786 return;
787 if (SvTYPE(sv) == SVt_PVAV) {
788 I32 i;
789 AV *const av = MUTABLE_AV(sv);
790 const I32 max = AvFILL(av);
791
792 for (i = 0; i <= max; i++) {
793 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
794 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
795 do_chomp(retval, sv, chomping);
796 }
797 return;
798 }
799 else if (SvTYPE(sv) == SVt_PVHV) {
800 HV* const hv = MUTABLE_HV(sv);
801 HE* entry;
802 (void)hv_iterinit(hv);
803 while ((entry = hv_iternext(hv)))
804 do_chomp(retval, hv_iterval(hv,entry), chomping);
805 return;
806 }
807 else if (SvREADONLY(sv)) {
cb077ed2 808 Perl_croak_no_modify();
81745e4e 809 }
e3918bb7
FC		 810 else if (SvIsCOW(sv)) {
811 sv_force_normal_flags(sv, 0);
812 }
81745e4e
NC		 813
814 if (PL_encoding) {
815 if (!SvUTF8(sv)) {
816 /* XXX, here sv is utf8-ized as a side-effect!
817 If encoding.pm is used properly, almost string-generating
818 operations, including literal strings, chr(), input data, etc.
819 should have been utf8-ized already, right?
820 */
821 sv_recode_to_utf8(sv, PL_encoding);
822 }
823 }
824
825 s = SvPV(sv, len);
826 if (chomping) {
827 char *temp_buffer = NULL;
828 SV *svrecode = NULL;
829
830 if (s && len) {
831 s += --len;
832 if (RsPARA(PL_rs)) {
833 if (*s != '\n')
834 goto nope;
835 ++SvIVX(retval);
836 while (len && s[-1] == '\n') {
837 --len;
838 --s;
839 ++SvIVX(retval);
840 }
841 }
842 else {
843 STRLEN rslen, rs_charlen;
844 const char *rsptr = SvPV_const(PL_rs, rslen);
845
846 rs_charlen = SvUTF8(PL_rs)
847 ? sv_len_utf8(PL_rs)
848 : rslen;
849
850 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
851 /* Assumption is that rs is shorter than the scalar. */
852 if (SvUTF8(PL_rs)) {
853 /* RS is utf8, scalar is 8 bit. */
854 bool is_utf8 = TRUE;
855 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
856 &rslen, &is_utf8);
857 if (is_utf8) {
858 /* Cannot downgrade, therefore cannot possibly match
859 */
860 assert (temp_buffer == rsptr);
861 temp_buffer = NULL;
862 goto nope;
863 }
864 rsptr = temp_buffer;
865 }
866 else if (PL_encoding) {
867 /* RS is 8 bit, encoding.pm is used.
868 * Do not recode PL_rs as a side-effect. */
869 svrecode = newSVpvn(rsptr, rslen);
870 sv_recode_to_utf8(svrecode, PL_encoding);
871 rsptr = SvPV_const(svrecode, rslen);
872 rs_charlen = sv_len_utf8(svrecode);
873 }
874 else {
875 /* RS is 8 bit, scalar is utf8. */
876 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
877 rsptr = temp_buffer;
878 }
879 }
880 if (rslen == 1) {
881 if (*s != *rsptr)
882 goto nope;
883 ++SvIVX(retval);
884 }
885 else {
886 if (len < rslen - 1)
887 goto nope;
888 len -= rslen - 1;
889 s -= rslen - 1;
890 if (memNE(s, rsptr, rslen))
891 goto nope;
892 SvIVX(retval) += rs_charlen;
893 }
894 }
fbac7ddf 895 s = SvPV_force_nomg_nolen(sv);
81745e4e
NC		 896 SvCUR_set(sv, len);
897 *SvEND(sv) = '\0';
898 SvNIOK_off(sv);
899 SvSETMAGIC(sv);
900 }
901 nope:
902
903 SvREFCNT_dec(svrecode);
904
905 Safefree(temp_buffer);
906 } else {
907 if (len && !SvPOK(sv))
908 s = SvPV_force_nomg(sv, len);
909 if (DO_UTF8(sv)) {
910 if (s && len) {
911 char * const send = s + len;
912 char * const start = s;
913 s = send - 1;
914 while (s > start && UTF8_IS_CONTINUATION(*s))
915 s--;
916 if (is_utf8_string((U8*)s, send - s)) {
917 sv_setpvn(retval, s, send - s);
918 *s = '\0';
919 SvCUR_set(sv, s - start);
920 SvNIOK_off(sv);
921 SvUTF8_on(retval);
922 }
923 }
924 else
925 sv_setpvs(retval, "");
926 }
927 else if (s && len) {
928 s += --len;
929 sv_setpvn(retval, s, 1);
930 *s = '\0';
931 SvCUR_set(sv, len);
932 SvUTF8_off(sv);
933 SvNIOK_off(sv);
934 }
935 else
936 sv_setpvs(retval, "");
937 SvSETMAGIC(sv);
938 }
939}
940
b1c05ba5
DM		 941
942/* also used for: pp_schomp() */
943
a0d0e21e
LW		 944PP(pp_schop)
945{
20b7effb 946 dSP; dTARGET;
fa54efae
NC		 947 const bool chomping = PL_op->op_type == OP_SCHOMP;
948
949 if (chomping)
950 sv_setiv(TARG, 0);
951 do_chomp(TARG, TOPs, chomping);
a0d0e21e
LW		 952 SETTARG;
953 RETURN;
79072805
LW		 954}
955
b1c05ba5
DM		 956
957/* also used for: pp_chomp() */
958
a0d0e21e 959PP(pp_chop)
79072805 960{
20b7effb 961 dSP; dMARK; dTARGET; dORIGMARK;
fa54efae 962 const bool chomping = PL_op->op_type == OP_CHOMP;
8ec5e241 963
fa54efae
NC		 964 if (chomping)
965 sv_setiv(TARG, 0);
20cf1f79 966 while (MARK < SP)
fa54efae 967 do_chomp(TARG, *++MARK, chomping);
20cf1f79
NC		 968 SP = ORIGMARK;
969 XPUSHTARG;
a0d0e21e 970 RETURN;
79072805
LW		 971}
972
a0d0e21e
LW		 973PP(pp_undef)
974{
20b7effb 975 dSP;
a0d0e21e
LW		 976 SV *sv;
977
533c011a 978 if (!PL_op->op_private) {
774d564b 979 EXTEND(SP, 1);
a0d0e21e 980 RETPUSHUNDEF;
774d564b 981 }
79072805 982
a0d0e21e
LW		 983 sv = POPs;
984 if (!sv)
985 RETPUSHUNDEF;
85e6fe83 986
4dda930b
FC		 987 if (SvTHINKFIRST(sv))
988 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
85e6fe83 989
a0d0e21e
LW		 990 switch (SvTYPE(sv)) {
991 case SVt_NULL:
992 break;
993 case SVt_PVAV:
60edcf09 994 av_undef(MUTABLE_AV(sv));
a0d0e21e
LW		 995 break;
996 case SVt_PVHV:
60edcf09 997 hv_undef(MUTABLE_HV(sv));
a0d0e21e
LW		 998 break;
999 case SVt_PVCV:
a2a5de95 1000 if (cv_const_sv((const CV *)sv))
714cd18f
BF		 1001 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1002 "Constant subroutine %"SVf" undefined",
1003 SVfARG(CvANON((const CV *)sv)
1004 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
bdbfc51a
FC		 1005 : sv_2mortal(newSVhek(
1006 CvNAMED(sv)
1007 ? CvNAME_HEK((CV *)sv)
1008 : GvENAME_HEK(CvGV((const CV *)sv))
1009 ))
1010 ));
5f66b61c 1011 /* FALLTHROUGH */
9607fc9c 1012 case SVt_PVFM:
6fc92669 1013 /* let user-undef'd sub keep its identity */
b7acb0a3 1014 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
a0d0e21e 1015 break;
8e07c86e 1016 case SVt_PVGV:
bc1df6c2
FC		 1017 assert(isGV_with_GP(sv));
1018 assert(!SvFAKE(sv));
1019 {
20408e3c 1020 GP *gp;
dd69841b
BB		 1021 HV *stash;
1022
dd69841b 1023 /* undef *Pkg::meth_name ... */
e530fb81
FC		 1024 bool method_changed
1025 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1026 && HvENAME_get(stash);
1027 /* undef *Foo:: */
1028 if((stash = GvHV((const GV *)sv))) {
1029 if(HvENAME_get(stash))
1030 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1031 else stash = NULL;
1032 }
dd69841b 1033
795eb8c8 1034 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
159b6efe 1035 gp_free(MUTABLE_GV(sv));
a02a5408 1036 Newxz(gp, 1, GP);
c43ae56f 1037 GvGP_set(sv, gp_ref(gp));
2e3295e3 1038#ifndef PERL_DONT_CREATE_GVSV
561b68a9 1039 GvSV(sv) = newSV(0);
2e3295e3 1040#endif
57843af0 1041 GvLINE(sv) = CopLINE(PL_curcop);
159b6efe 1042 GvEGV(sv) = MUTABLE_GV(sv);
20408e3c 1043 GvMULTI_on(sv);
e530fb81
FC		 1044
1045 if(stash)
afdbe55d 1046 mro_package_moved(NULL, stash, (const GV *)sv, 0);
e530fb81
FC		 1047 stash = NULL;
1048 /* undef *Foo::ISA */
1049 if( strEQ(GvNAME((const GV *)sv), "ISA")
1050 && (stash = GvSTASH((const GV *)sv))
1051 && (method_changed || HvENAME(stash)) )
1052 mro_isa_changed_in(stash);
1053 else if(method_changed)
1054 mro_method_changed_in(
da9043f5 1055 GvSTASH((const GV *)sv)
e530fb81
FC		 1056 );
1057
6e592b3a 1058 break;
20408e3c 1059 }
a0d0e21e 1060 default:
b15aece3 1061 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
8bd4d4c5 1062 SvPV_free(sv);
c445ea15 1063 SvPV_set(sv, NULL);
4633a7c4 1064 SvLEN_set(sv, 0);
a0d0e21e 1065 }
0c34ef67 1066 SvOK_off(sv);
4633a7c4 1067 SvSETMAGIC(sv);
79072805 1068 }
a0d0e21e
LW		 1069
1070 RETPUSHUNDEF;
79072805
LW		 1071}
1072
b1c05ba5
DM		 1073
1074/* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */
1075
a0d0e21e
LW		 1076PP(pp_postinc)
1077{
20b7effb 1078 dSP; dTARGET;
c22c99bc
FC		 1079 const bool inc =
1080 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
60092ce4 1081 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
cb077ed2 1082 Perl_croak_no_modify();
7dcb9b98
DM		 1083 if (SvROK(TOPs))
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
LW		 1098 sv_setiv(TARG, 0);
1099 SETs(TARG);
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
EB		 3227 sv_setuv(ret, do_vecget(src, offset, size));
3228 PUSHs(ret);
79072805
LW		 3229 RETURN;
3230}
3231
b1c05ba5
DM		 3232
3233/* also used for: pp_rindex() */
3234
79072805
LW		 3235PP(pp_index)
3236{
20b7effb 3237 dSP; dTARGET;
79072805
LW		 3238 SV *big;
3239 SV *little;
c445ea15 3240 SV *temp = NULL;
ad66a58c 3241 STRLEN biglen;
2723d216 3242 STRLEN llen = 0;
b464e2b7
TC		 3243 SSize_t offset = 0;
3244 SSize_t retval;
73ee8be2
NC		 3245 const char *big_p;
3246 const char *little_p;
2f040f7f
NC		 3247 bool big_utf8;
3248 bool little_utf8;
2723d216 3249 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3250 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3251
e1dccc0d
Z		 3252 if (threeargs)
3253 offset = POPi;
79072805
LW		 3254 little = POPs;
3255 big = POPs;
73ee8be2
NC		 3256 big_p = SvPV_const(big, biglen);
3257 little_p = SvPV_const(little, llen);
3258
e609e586
NC		 3259 big_utf8 = DO_UTF8(big);
3260 little_utf8 = DO_UTF8(little);
3261 if (big_utf8 ^ little_utf8) {
3262 /* One needs to be upgraded. */
2f040f7f
NC		 3263 if (little_utf8 && !PL_encoding) {
3264 /* Well, maybe instead we might be able to downgrade the small
3265 string? */
1eced8f8 3266 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC		 3267 &little_utf8);
3268 if (little_utf8) {
3269 /* If the large string is ISO-8859-1, and it's not possible to
3270 convert the small string to ISO-8859-1, then there is no
3271 way that it could be found anywhere by index. */
3272 retval = -1;
3273 goto fail;
3274 }
e609e586 3275
2f040f7f
NC		 3276 /* At this point, pv is a malloc()ed string. So donate it to temp
3277 to ensure it will get free()d */
3278 little = temp = newSV(0);
73ee8be2
NC		 3279 sv_usepvn(temp, pv, llen);
3280 little_p = SvPVX(little);
e609e586 3281 } else {
73ee8be2
NC		 3282 temp = little_utf8
3283 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f
NC		 3284
3285 if (PL_encoding) {
3286 sv_recode_to_utf8(temp, PL_encoding);
3287 } else {
3288 sv_utf8_upgrade(temp);
3289 }
3290 if (little_utf8) {
3291 big = temp;
3292 big_utf8 = TRUE;
73ee8be2 3293 big_p = SvPV_const(big, biglen);
2f040f7f
NC		 3294 } else {
3295 little = temp;
73ee8be2 3296 little_p = SvPV_const(little, llen);
2f040f7f 3297 }
e609e586
NC		 3298 }
3299 }
73ee8be2
NC		 3300 if (SvGAMAGIC(big)) {
3301 /* Life just becomes a lot easier if I use a temporary here.
3302 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3303 will trigger magic and overloading again, as will fbm_instr()
3304 */
59cd0e26
NC		 3305 big = newSVpvn_flags(big_p, biglen,
3306 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC		 3307 big_p = SvPVX(big);
3308 }
e4e44778 3309 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC		 3310 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3311 warn on undef, and we've already triggered a warning with the
3312 SvPV_const some lines above. We can't remove that, as we need to
3313 call some SvPV to trigger overloading early and find out if the
3314 string is UTF-8.
3315 This is all getting to messy. The API isn't quite clean enough,
3316 because data access has side effects.
3317 */
59cd0e26
NC		 3318 little = newSVpvn_flags(little_p, llen,
3319 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC		 3320 little_p = SvPVX(little);
3321 }
e609e586 3322
d3e26383 3323 if (!threeargs)
2723d216 3324 offset = is_index ? 0 : biglen;
a0ed51b3 3325 else {
ad66a58c 3326 if (big_utf8 && offset > 0)
b464e2b7 3327 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
73ee8be2
NC		 3328 if (!is_index)
3329 offset += llen;
a0ed51b3 3330 }
79072805
LW		 3331 if (offset < 0)
3332 offset = 0;
b464e2b7 3333 else if (offset > (SSize_t)biglen)
ad66a58c 3334 offset = biglen;
73ee8be2
NC		 3335 if (!(little_p = is_index
3336 ? fbm_instr((unsigned char*)big_p + offset,
3337 (unsigned char*)big_p + biglen, little, 0)
3338 : rninstr(big_p, big_p + offset,
3339 little_p, little_p + llen)))
a0ed51b3 3340 retval = -1;
ad66a58c 3341 else {
73ee8be2 3342 retval = little_p - big_p;
ad66a58c 3343 if (retval > 0 && big_utf8)
b464e2b7 3344 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
ad66a58c 3345 }
ef8d46e8 3346 SvREFCNT_dec(temp);
2723d216 3347 fail:
e1dccc0d 3348 PUSHi(retval);
79072805
LW		 3349 RETURN;
3350}
3351
3352PP(pp_sprintf)
3353{
20b7effb 3354 dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3355 SvTAINTED_off(TARG);
79072805 3356 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3357 TAINT_IF(SvTAINTED(TARG));
79072805
LW		 3358 SP = ORIGMARK;
3359 PUSHTARG;
3360 RETURN;
3361}
3362
79072805
LW		 3363PP(pp_ord)
3364{
20b7effb 3365 dSP; dTARGET;
1eced8f8 3366
7df053ec 3367 SV *argsv = POPs;
ba210ebe 3368 STRLEN len;
349d4f2f 3369 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3370
799ef3cb 3371 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3372 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3373 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
4f6386b6 3374 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
121910a4
JH		 3375 argsv = tmpsv;
3376 }
79072805 3377
d8f42585 3378 XPUSHu(DO_UTF8(argsv)
4f6386b6 3379 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
f3943cf2 3380 : (UV)(*s));
68795e93 3381
79072805
LW		 3382 RETURN;
3383}
3384
463ee0b2
LW		 3385PP(pp_chr)
3386{
20b7effb 3387 dSP; dTARGET;
463ee0b2 3388 char *tmps;
8a064bd6 3389 UV value;
71739502 3390 SV *top = POPs;
8a064bd6 3391
71739502 3392 SvGETMAGIC(top);
99f450cc 3393 if (UNLIKELY(isinfnansv(top)))
0c7df902 3394 Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
1cd88304
JH		 3395 else {
3396 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3397 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3398 ||
3399 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3400 && SvNV_nomg(top) < 0.0))) {
b3fe8680
FC		 3401 if (ckWARN(WARN_UTF8)) {
3402 if (SvGMAGICAL(top)) {
3403 SV *top2 = sv_newmortal();
3404 sv_setsv_nomg(top2, top);
3405 top = top2;
3406 }
1cd88304
JH		 3407 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3408 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3409 }
3410 value = UNICODE_REPLACEMENT;
3411 } else {
3412 value = SvUV_nomg(top);
3413 }
8a064bd6 3414 }
463ee0b2 3415
862a34c6 3416 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3417
0064a8a9 3418 if (value > 255 && !IN_BYTES) {
eb160463 3419 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3420 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3421 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW		 3422 *tmps = '\0';
3423 (void)SvPOK_only(TARG);
aa6ffa16 3424 SvUTF8_on(TARG);
a0ed51b3
LW		 3425 XPUSHs(TARG);
3426 RETURN;
3427 }
3428
748a9306 3429 SvGROW(TARG,2);
463ee0b2
LW		 3430 SvCUR_set(TARG, 1);
3431 tmps = SvPVX(TARG);
eb160463 3432 *tmps++ = (char)value;
748a9306 3433 *tmps = '\0';
a0d0e21e 3434 (void)SvPOK_only(TARG);
4c5ed6e2 3435
88632417 3436 if (PL_encoding && !IN_BYTES) {
799ef3cb 3437 sv_recode_to_utf8(TARG, PL_encoding);
88632417 3438 tmps = SvPVX(TARG);
28936164
KW		 3439 if (SvCUR(TARG) == 0
3440 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3441 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3442 {
4c5ed6e2 3443 SvGROW(TARG, 2);
d5a15ac2 3444 tmps = SvPVX(TARG);
4c5ed6e2
TS		 3445 SvCUR_set(TARG, 1);
3446 *tmps++ = (char)value;
88632417 3447 *tmps = '\0';
4c5ed6e2 3448 SvUTF8_off(TARG);
88632417
JH		 3449 }
3450 }
4c5ed6e2 3451
463ee0b2
LW		 3452 XPUSHs(TARG);
3453 RETURN;
3454}
3455
79072805
LW		 3456PP(pp_crypt)
3457{
79072805 3458#ifdef HAS_CRYPT
20b7effb 3459 dSP; dTARGET;
5f74f29c 3460 dPOPTOPssrl;
85c16d83 3461 STRLEN len;
10516c54 3462 const char *tmps = SvPV_const(left, len);
2bc69dc4 3463
85c16d83 3464 if (DO_UTF8(left)) {
2bc69dc4 3465 /* If Unicode, try to downgrade.
f2791508
JH		 3466 * If not possible, croak.
3467 * Yes, we made this up. */
1b6737cc 3468 SV* const tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3469
f2791508 3470 SvUTF8_on(tsv);
2bc69dc4 3471 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3472 tmps = SvPV_const(tsv, len);
85c16d83 3473 }
05404ffe
JH		 3474# ifdef USE_ITHREADS
3475# ifdef HAS_CRYPT_R
3476 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3477 /* This should be threadsafe because in ithreads there is only
3478 * one thread per interpreter. If this would not be true,
3479 * we would need a mutex to protect this malloc. */
3480 PL_reentrant_buffer->_crypt_struct_buffer =
3481 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3482#if defined(__GLIBC__) || defined(__EMX__)
3483 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3484 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3485 /* work around glibc-2.2.5 bug */
3486 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3487 }
05404ffe 3488#endif
6ab58e4d 3489 }
05404ffe
JH		 3490# endif /* HAS_CRYPT_R */
3491# endif /* USE_ITHREADS */
5f74f29c 3492# ifdef FCRYPT
83003860 3493 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3494# else
83003860 3495 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3496# endif
ec93b65f 3497 SETTARG;
4808266b 3498 RETURN;
79072805 3499#else
b13b2135 3500 DIE(aTHX_
79072805
LW		 3501 "The crypt() function is unimplemented due to excessive paranoia.");
3502#endif
79072805
LW		 3503}
3504
00f254e2
KW		 3505/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3506 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3507
b1c05ba5
DM		 3508
3509/* also used for: pp_lcfirst() */
3510
79072805
LW		 3511PP(pp_ucfirst)
3512{
00f254e2
KW		 3513 /* Actually is both lcfirst() and ucfirst(). Only the first character
3514 * changes. This means that possibly we can change in-place, ie., just
3515 * take the source and change that one character and store it back, but not
3516 * if read-only etc, or if the length changes */
3517
39644a26 3518 dSP;
d54190f6 3519 SV *source = TOPs;
00f254e2 3520 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC		 3521 STRLEN need;
3522 SV *dest;
00f254e2
KW		 3523 bool inplace; /* ? Convert first char only, in-place */
3524 bool doing_utf8 = FALSE; /* ? using utf8 */
3525 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3526 const int op_type = PL_op->op_type;
d54190f6
NC		 3527 const U8 *s;
3528 U8 *d;
3529 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW		 3530 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3531 * stored as UTF-8 at s. */
3532 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3533 * lowercased) character stored in tmpbuf. May be either
3534 * UTF-8 or not, but in either case is the number of bytes */
d54190f6 3535
841a5e18 3536 s = (const U8*)SvPV_const(source, slen);
a0ed51b3 3537
00f254e2
KW		 3538 /* We may be able to get away with changing only the first character, in
3539 * place, but not if read-only, etc. Later we may discover more reasons to
3540 * not convert in-place. */
5cd5e2d6
FC		 3541 inplace = !SvREADONLY(source)
3542 && ( SvPADTMP(source)
3543 || ( SvTEMP(source) && !SvSMAGICAL(source)
3544 && SvREFCNT(source) == 1));
00f254e2
KW		 3545
3546 /* First calculate what the changed first character should be. This affects
3547 * whether we can just swap it out, leaving the rest of the string unchanged,
3548 * or even if have to convert the dest to UTF-8 when the source isn't */
3549
3550 if (! slen) { /* If empty */
3551 need = 1; /* still need a trailing NUL */
b7576bcb 3552 ulen = 0;
00f254e2
KW		 3553 }
3554 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3555 doing_utf8 = TRUE;
17e95c9d 3556 ulen = UTF8SKIP(s);
094a2f8c 3557 if (op_type == OP_UCFIRST) {
130c5df3 3558#ifdef USE_LOCALE_CTYPE
5a6bb681 3559 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3560#else
5a6bb681 3561 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
130c5df3 3562#endif
094a2f8c
KW		 3563 }
3564 else {
130c5df3 3565#ifdef USE_LOCALE_CTYPE
5a6bb681 3566 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3567#else
5a6bb681 3568 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
130c5df3 3569#endif
094a2f8c 3570 }
00f254e2 3571
17e95c9d
KW		 3572 /* we can't do in-place if the length changes. */
3573 if (ulen != tculen) inplace = FALSE;
3574 need = slen + 1 - ulen + tculen;
d54190f6 3575 }
00f254e2
KW		 3576 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3577 * latin1 is treated as caseless. Note that a locale takes
3578 * precedence */
167d19f2 3579 ulen = 1; /* Original character is 1 byte */
00f254e2
KW		 3580 tculen = 1; /* Most characters will require one byte, but this will
3581 * need to be overridden for the tricky ones */
3582 need = slen + 1;
3583
3584 if (op_type == OP_LCFIRST) {
d54190f6 3585
00f254e2 3586 /* lower case the first letter: no trickiness for any character */
130c5df3
KW		 3587 *tmpbuf =
3588#ifdef USE_LOCALE_CTYPE
3589 (IN_LC_RUNTIME(LC_CTYPE))
86a1f7fd 3590 ? toLOWER_LC(*s)
130c5df3
KW		 3591 :
3592#endif
3593 (IN_UNI_8_BIT)
86a1f7fd
KW		 3594 ? toLOWER_LATIN1(*s)
3595 : toLOWER(*s);
00f254e2
KW		 3596 }
3597 /* is ucfirst() */
130c5df3 3598#ifdef USE_LOCALE_CTYPE
d6ded950 3599 else if (IN_LC_RUNTIME(LC_CTYPE)) {
31f05a37
KW		 3600 if (IN_UTF8_CTYPE_LOCALE) {
3601 goto do_uni_rules;
3602 }
3603
3604 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3605 locales have upper and title case
3606 different */
00f254e2 3607 }
130c5df3 3608#endif
00f254e2
KW		 3609 else if (! IN_UNI_8_BIT) {
3610 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3611 * on EBCDIC machines whatever the
3612 * native function does */
3613 }
31f05a37
KW		 3614 else {
3615 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3616 * UTF-8, which we treat as not in locale), and cased latin1 */
3617 UV title_ord;
91191cf7 3618#ifdef USE_LOCALE_CTYPE
31f05a37 3619 do_uni_rules:
91191cf7 3620#endif
31f05a37
KW		 3621
3622 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
167d19f2
KW		 3623 if (tculen > 1) {
3624 assert(tculen == 2);
3625
3626 /* If the result is an upper Latin1-range character, it can
3627 * still be represented in one byte, which is its ordinal */
3628 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3629 *tmpbuf = (U8) title_ord;
3630 tculen = 1;
00f254e2
KW		 3631 }
3632 else {
167d19f2
KW		 3633 /* Otherwise it became more than one ASCII character (in
3634 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3635 * beyond Latin1, so the number of bytes changed, so can't
3636 * replace just the first character in place. */
3637 inplace = FALSE;
3638
d14578b8
KW		 3639 /* If the result won't fit in a byte, the entire result
3640 * will have to be in UTF-8. Assume worst case sizing in
3641 * conversion. (all latin1 characters occupy at most two
3642 * bytes in utf8) */
167d19f2
KW		 3643 if (title_ord > 255) {
3644 doing_utf8 = TRUE;
3645 convert_source_to_utf8 = TRUE;
3646 need = slen * 2 + 1;
3647
3648 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3649 * (both) characters whose title case is above 255 is
3650 * 2. */
3651 ulen = 2;
3652 }
3653 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3654 need = slen + 1 + 1;
3655 }
00f254e2 3656 }
167d19f2 3657 }
00f254e2
KW		 3658 } /* End of use Unicode (Latin1) semantics */
3659 } /* End of changing the case of the first character */
3660
3661 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3662 * generate the result */
3663 if (inplace) {
3664
3665 /* We can convert in place. This means we change just the first
3666 * character without disturbing the rest; no need to grow */
d54190f6
NC		 3667 dest = source;
3668 s = d = (U8*)SvPV_force_nomg(source, slen);
3669 } else {
3670 dTARGET;
3671
3672 dest = TARG;
3673
00f254e2
KW		 3674 /* Here, we can't convert in place; we earlier calculated how much
3675 * space we will need, so grow to accommodate that */
d54190f6 3676 SvUPGRADE(dest, SVt_PV);
3b416f41 3677 d = (U8*)SvGROW(dest, need);
d54190f6
NC		 3678 (void)SvPOK_only(dest);
3679
3680 SETs(dest);
d54190f6 3681 }
44bc797b 3682
d54190f6 3683 if (doing_utf8) {
00f254e2
KW		 3684 if (! inplace) {
3685 if (! convert_source_to_utf8) {
3686
3687 /* Here both source and dest are in UTF-8, but have to create
3688 * the entire output. We initialize the result to be the
3689 * title/lower cased first character, and then append the rest
3690 * of the string. */
3691 sv_setpvn(dest, (char*)tmpbuf, tculen);
3692 if (slen > ulen) {
3693 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3694 }
3695 }
3696 else {
3697 const U8 *const send = s + slen;
3698
3699 /* Here the dest needs to be in UTF-8, but the source isn't,
3700 * except we earlier UTF-8'd the first character of the source
3701 * into tmpbuf. First put that into dest, and then append the
3702 * rest of the source, converting it to UTF-8 as we go. */
3703
3704 /* Assert tculen is 2 here because the only two characters that
3705 * get to this part of the code have 2-byte UTF-8 equivalents */
3706 *d++ = *tmpbuf;
3707 *d++ = *(tmpbuf + 1);
3708 s++; /* We have just processed the 1st char */
3709
3710 for (; s < send; s++) {
3711 d = uvchr_to_utf8(d, *s);
3712 }
3713 *d = '\0';
3714 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3715 }
d54190f6 3716 SvUTF8_on(dest);
a0ed51b3 3717 }
00f254e2 3718 else { /* in-place UTF-8. Just overwrite the first character */
d54190f6
NC		 3719 Copy(tmpbuf, d, tculen, U8);
3720 SvCUR_set(dest, need - 1);
a0ed51b3 3721 }
094a2f8c 3722
a0ed51b3 3723 }
00f254e2
KW		 3724 else { /* Neither source nor dest are in or need to be UTF-8 */
3725 if (slen) {
00f254e2
KW		 3726 if (inplace) { /* in-place, only need to change the 1st char */
3727 *d = *tmpbuf;
3728 }
3729 else { /* Not in-place */
3730
3731 /* Copy the case-changed character(s) from tmpbuf */
3732 Copy(tmpbuf, d, tculen, U8);
3733 d += tculen - 1; /* Code below expects d to point to final
3734 * character stored */
3735 }
3736 }
3737 else { /* empty source */
3738 /* See bug #39028: Don't taint if empty */
d54190f6
NC		 3739 *d = *s;
3740 }
3741
00f254e2
KW		 3742 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3743 * the destination to retain that flag */
93e088e8 3744 if (SvUTF8(source) && ! IN_BYTES)
d54190f6
NC		 3745 SvUTF8_on(dest);
3746
00f254e2 3747 if (!inplace) { /* Finish the rest of the string, unchanged */
d54190f6
NC		 3748 /* This will copy the trailing NUL */
3749 Copy(s + 1, d + 1, slen, U8);
3750 SvCUR_set(dest, need - 1);
bbce6d69 3751 }
bbce6d69 3752 }
130c5df3 3753#ifdef USE_LOCALE_CTYPE
d6ded950 3754 if (IN_LC_RUNTIME(LC_CTYPE)) {
445bf929
KW		 3755 TAINT;
3756 SvTAINTED_on(dest);
3757 }
130c5df3 3758#endif
539689e7
FC		 3759 if (dest != source && SvTAINTED(source))
3760 SvTAINT(dest);
d54190f6 3761 SvSETMAGIC(dest);
79072805
LW		 3762 RETURN;
3763}
3764
67306194
NC		 3765/* There's so much setup/teardown code common between uc and lc, I wonder if
3766 it would be worth merging the two, and just having a switch outside each
00f254e2 3767 of the three tight loops. There is less and less commonality though */
79072805
LW		 3768PP(pp_uc)
3769{
39644a26 3770 dSP;
67306194 3771 SV *source = TOPs;
463ee0b2 3772 STRLEN len;
67306194
NC		 3773 STRLEN min;
3774 SV *dest;
3775 const U8 *s;
3776 U8 *d;
79072805 3777
67306194
NC		 3778 SvGETMAGIC(source);
3779
5cd5e2d6
FC		 3780 if ((SvPADTMP(source)
3781 ||
3782 (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
3783 && !SvREADONLY(source) && SvPOK(source)
3784 && !DO_UTF8(source)
130c5df3
KW		 3785 && (
3786#ifdef USE_LOCALE_CTYPE
3787 (IN_LC_RUNTIME(LC_CTYPE))
31f05a37 3788 ? ! IN_UTF8_CTYPE_LOCALE
130c5df3
KW		 3789 :
3790#endif
3791 ! IN_UNI_8_BIT))
31f05a37
KW		 3792 {
3793
3794 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3795 * make the loop tight, so we overwrite the source with the dest before
3796 * looking at it, and we need to look at the original source
3797 * afterwards. There would also need to be code added to handle
3798 * switching to not in-place in midstream if we run into characters
3799 * that change the length. Since being in locale overrides UNI_8_BIT,
3800 * that latter becomes irrelevant in the above test; instead for
3801 * locale, the size can't normally change, except if the locale is a
3802 * UTF-8 one */
67306194
NC		 3803 dest = source;
3804 s = d = (U8*)SvPV_force_nomg(source, len);
3805 min = len + 1;
3806 } else {
a0ed51b3 3807 dTARGET;
a0ed51b3 3808
67306194 3809 dest = TARG;
128c9517 3810
841a5e18 3811 s = (const U8*)SvPV_nomg_const(source, len);
67306194
NC		 3812 min = len + 1;
3813
3814 SvUPGRADE(dest, SVt_PV);
3b416f41 3815 d = (U8*)SvGROW(dest, min);
67306194
NC		 3816 (void)SvPOK_only(dest);
3817
3818 SETs(dest);
a0ed51b3 3819 }
31351b04 3820
67306194
NC		 3821 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3822 to check DO_UTF8 again here. */
3823
3824 if (DO_UTF8(source)) {
3825 const U8 *const send = s + len;
bfac13d4 3826 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
67306194 3827
4c8a458a
KW		 3828 /* All occurrences of these are to be moved to follow any other marks.
3829 * This is context-dependent. We may not be passed enough context to
3830 * move the iota subscript beyond all of them, but we do the best we can
3831 * with what we're given. The result is always better than if we
3832 * hadn't done this. And, the problem would only arise if we are
3833 * passed a character without all its combining marks, which would be
3834 * the caller's mistake. The information this is based on comes from a
3835 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3836 * itself) and so can't be checked properly to see if it ever gets
3837 * revised. But the likelihood of it changing is remote */
00f254e2 3838 bool in_iota_subscript = FALSE;
00f254e2 3839
67306194 3840 while (s < send) {
3e16b0e6
KW		 3841 STRLEN u;
3842 STRLEN ulen;
3843 UV uv;
7dbf68d2 3844 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3e16b0e6 3845
00f254e2 3846 /* A non-mark. Time to output the iota subscript */
a78bc3c6
KW		 3847 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3848 d += capital_iota_len;
00f254e2 3849 in_iota_subscript = FALSE;
8e058693 3850 }
00f254e2 3851
8e058693
KW		 3852 /* Then handle the current character. Get the changed case value
3853 * and copy it to the output buffer */
00f254e2 3854
8e058693 3855 u = UTF8SKIP(s);
130c5df3 3856#ifdef USE_LOCALE_CTYPE
5a6bb681 3857 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3858#else
5a6bb681 3859 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
130c5df3 3860#endif
a78bc3c6
KW		 3861#define GREEK_CAPITAL_LETTER_IOTA 0x0399
3862#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
8e058693 3863 if (uv == GREEK_CAPITAL_LETTER_IOTA
4b88fb76 3864 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
8e058693
KW		 3865 {
3866 in_iota_subscript = TRUE;
3867 }
3868 else {
3869 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3870 /* If the eventually required minimum size outgrows the
3871 * available space, we need to grow. */
3872 const UV o = d - (U8*)SvPVX_const(dest);
3873
3874 /* If someone uppercases one million U+03B0s we SvGROW()
3875 * one million times. Or we could try guessing how much to
3876 * allocate without allocating too much. Such is life.
3877 * See corresponding comment in lc code for another option
3878 * */
3879 SvGROW(dest, min);
3880 d = (U8*)SvPVX(dest) + o;
3881 }
3882 Copy(tmpbuf, d, ulen, U8);
3883 d += ulen;
3884 }
3885 s += u;
67306194 3886 }
4c8a458a 3887 if (in_iota_subscript) {
a78bc3c6
KW		 3888 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3889 d += capital_iota_len;
4c8a458a 3890 }
67306194
NC		 3891 SvUTF8_on(dest);
3892 *d = '\0';
094a2f8c 3893
67306194 3894 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4c8a458a
KW		 3895 }
3896 else { /* Not UTF-8 */
67306194
NC		 3897 if (len) {
3898 const U8 *const send = s + len;
00f254e2
KW		 3899
3900 /* Use locale casing if in locale; regular style if not treating
3901 * latin1 as having case; otherwise the latin1 casing. Do the
3902 * whole thing in a tight loop, for speed, */
130c5df3 3903#ifdef USE_LOCALE_CTYPE
d6ded950 3904 if (IN_LC_RUNTIME(LC_CTYPE)) {
31f05a37
KW		 3905 if (IN_UTF8_CTYPE_LOCALE) {
3906 goto do_uni_rules;
3907 }
67306194 3908 for (; s < send; d++, s++)
31f05a37 3909 *d = (U8) toUPPER_LC(*s);
31351b04 3910 }
130c5df3
KW		 3911 else
3912#endif
3913 if (! IN_UNI_8_BIT) {
00f254e2 3914 for (; s < send; d++, s++) {
67306194 3915 *d = toUPPER(*s);
00f254e2 3916 }
31351b04 3917 }
00f254e2 3918 else {
91191cf7 3919#ifdef USE_LOCALE_CTYPE
31f05a37 3920 do_uni_rules:
91191cf7 3921#endif
00f254e2
KW		 3922 for (; s < send; d++, s++) {
3923 *d = toUPPER_LATIN1_MOD(*s);
d14578b8
KW		 3924 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3925 continue;
3926 }
00f254e2
KW		 3927
3928 /* The mainstream case is the tight loop above. To avoid
3929 * extra tests in that, all three characters that require
3930 * special handling are mapped by the MOD to the one tested
3931 * just above.
3932 * Use the source to distinguish between the three cases */
3933
3934 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3935
3936 /* uc() of this requires 2 characters, but they are
3937 * ASCII. If not enough room, grow the string */
3938 if (SvLEN(dest) < ++min) {
3939 const UV o = d - (U8*)SvPVX_const(dest);
3940 SvGROW(dest, min);
3941 d = (U8*)SvPVX(dest) + o;
3942 }
3943 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3944 continue; /* Back to the tight loop; still in ASCII */
3945 }
3946
3947 /* The other two special handling characters have their
3948 * upper cases outside the latin1 range, hence need to be
3949 * in UTF-8, so the whole result needs to be in UTF-8. So,
3950 * here we are somewhere in the middle of processing a
3951 * non-UTF-8 string, and realize that we will have to convert
3952 * the whole thing to UTF-8. What to do? There are
3953 * several possibilities. The simplest to code is to
3954 * convert what we have so far, set a flag, and continue on
3955 * in the loop. The flag would be tested each time through
3956 * the loop, and if set, the next character would be
3957 * converted to UTF-8 and stored. But, I (khw) didn't want
3958 * to slow down the mainstream case at all for this fairly
3959 * rare case, so I didn't want to add a test that didn't
3960 * absolutely have to be there in the loop, besides the
3961 * possibility that it would get too complicated for
3962 * optimizers to deal with. Another possibility is to just
3963 * give up, convert the source to UTF-8, and restart the
3964 * function that way. Another possibility is to convert
3965 * both what has already been processed and what is yet to
3966 * come separately to UTF-8, then jump into the loop that
3967 * handles UTF-8. But the most efficient time-wise of the
3968 * ones I could think of is what follows, and turned out to
3969 * not require much extra code. */
3970
3971 /* Convert what we have so far into UTF-8, telling the
3972 * function that we know it should be converted, and to
3973 * allow extra space for what we haven't processed yet.
3974 * Assume the worst case space requirements for converting
3975 * what we haven't processed so far: that it will require
3976 * two bytes for each remaining source character, plus the
3977 * NUL at the end. This may cause the string pointer to
3978 * move, so re-find it. */
3979
3980 len = d - (U8*)SvPVX_const(dest);
3981 SvCUR_set(dest, len);
3982 len = sv_utf8_upgrade_flags_grow(dest,
3983 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3984 (send -s) * 2 + 1);
3985 d = (U8*)SvPVX(dest) + len;
3986
00f254e2
KW		 3987 /* Now process the remainder of the source, converting to
3988 * upper and UTF-8. If a resulting byte is invariant in
3989 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3990 * append it to the output. */
00f254e2 3991 for (; s < send; s++) {
0ecfbd28
KW		 3992 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3993 d += len;
00f254e2
KW		 3994 }
3995
3996 /* Here have processed the whole source; no need to continue
3997 * with the outer loop. Each character has been converted
3998 * to upper case and converted to UTF-8 */
3999
4000 break;
4001 } /* End of processing all latin1-style chars */
4002 } /* End of processing all chars */
4003 } /* End of source is not empty */
4004
67306194 4005 if (source != dest) {
00f254e2 4006 *d = '\0'; /* Here d points to 1 after last char, add NUL */
67306194
NC		 4007 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4008 }
00f254e2 4009 } /* End of isn't utf8 */
130c5df3 4010#ifdef USE_LOCALE_CTYPE
d6ded950 4011 if (IN_LC_RUNTIME(LC_CTYPE)) {
445bf929
KW		 4012 TAINT;
4013 SvTAINTED_on(dest);
4014 }
130c5df3 4015#endif
539689e7
FC		 4016 if (dest != source && SvTAINTED(source))
4017 SvTAINT(dest);
67306194 4018 SvSETMAGIC(dest);
79072805
LW		 4019 RETURN;
4020}
4021
4022PP(pp_lc)
4023{
39644a26 4024 dSP;
ec9af7d4 4025 SV *source = TOPs;
463ee0b2 4026 STRLEN len;
ec9af7d4
NC		 4027 STRLEN min;
4028 SV *dest;
4029 const U8 *s;
4030 U8 *d;
79072805 4031
ec9af7d4
NC		 4032 SvGETMAGIC(source);
4033
5cd5e2d6
FC		 4034 if ( ( SvPADTMP(source)
4035 || ( SvTEMP(source) && !SvSMAGICAL(source)
4036 && SvREFCNT(source) == 1 )
4037 )
4038 && !SvREADONLY(source) && SvPOK(source)
4039 && !DO_UTF8(source)) {
ec9af7d4 4040
00f254e2
KW		 4041 /* We can convert in place, as lowercasing anything in the latin1 range
4042 * (or else DO_UTF8 would have been on) doesn't lengthen it */
ec9af7d4
NC		 4043 dest = source;
4044 s = d = (U8*)SvPV_force_nomg(source, len);
4045 min = len + 1;
4046 } else {
a0ed51b3 4047 dTARGET;
a0ed51b3 4048
ec9af7d4
NC		 4049 dest = TARG;
4050
841a5e18 4051 s = (const U8*)SvPV_nomg_const(source, len);
ec9af7d4 4052 min = len + 1;
128c9517 4053
ec9af7d4 4054 SvUPGRADE(dest, SVt_PV);
3b416f41 4055 d = (U8*)SvGROW(dest, min);
ec9af7d4
NC		 4056 (void)SvPOK_only(dest);
4057
4058 SETs(dest);
4059 }
4060
4061 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4062 to check DO_UTF8 again here. */
4063
4064 if (DO_UTF8(source)) {
4065 const U8 *const send = s + len;
4066 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4067
4068 while (s < send) {
06b5486a
KW		 4069 const STRLEN u = UTF8SKIP(s);
4070 STRLEN ulen;
00f254e2 4071
130c5df3 4072#ifdef USE_LOCALE_CTYPE
5a6bb681 4073 _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 4074#else
5a6bb681 4075 _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
130c5df3 4076#endif
00f254e2 4077
06b5486a 4078 /* Here is where we would do context-sensitive actions. See the
6006ebd0 4079 * commit message for 86510fb15 for why there isn't any */
00f254e2 4080
06b5486a 4081 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
fdb34c52 4082
06b5486a
KW		 4083 /* If the eventually required minimum size outgrows the
4084 * available space, we need to grow. */
4085 const UV o = d - (U8*)SvPVX_const(dest);
fdb34c52 4086
06b5486a
KW		 4087 /* If someone lowercases one million U+0130s we SvGROW() one
4088 * million times. Or we could try guessing how much to
4089 * allocate without allocating too much. Such is life.
4090 * Another option would be to grow an extra byte or two more
4091 * each time we need to grow, which would cut down the million
4092 * to 500K, with little waste */
4093 SvGROW(dest, min);
4094 d = (U8*)SvPVX(dest) + o;
4095 }
86510fb1 4096
06b5486a
KW		 4097 /* Copy the newly lowercased letter to the output buffer we're
4098 * building */
4099 Copy(tmpbuf, d, ulen, U8);
4100 d += ulen;
4101 s += u;
00f254e2 4102 } /* End of looping through the source string */
ec9af7d4
NC		 4103 SvUTF8_on(dest);
4104 *d = '\0';
4105 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
00f254e2 4106 } else { /* Not utf8 */
31351b04 4107 if (len) {
ec9af7d4 4108 const U8 *const send = s + len;
00f254e2
KW		 4109
4110 /* Use locale casing if in locale; regular style if not treating
4111 * latin1 as having case; otherwise the latin1 casing. Do the
4112 * whole thing in a tight loop, for speed, */
130c5df3 4113#ifdef USE_LOCALE_CTYPE
d6ded950 4114 if (IN_LC_RUNTIME(LC_CTYPE)) {
ec9af7d4
NC		 4115 for (; s < send; d++, s++)
4116 *d = toLOWER_LC(*s);
445bf929 4117 }
130c5df3
KW		 4118 else
4119#endif
4120 if (! IN_UNI_8_BIT) {
00f254e2 4121 for (; s < send; d++, s++) {
ec9af7d4 4122 *d = toLOWER(*s);
00f254e2
KW		 4123 }
4124 }
4125 else {
4126 for (; s < send; d++, s++) {
4127 *d = toLOWER_LATIN1(*s);
4128 }
31351b04 4129 }
bbce6d69 4130 }
ec9af7d4
NC		 4131 if (source != dest) {
4132 *d = '\0';
4133 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4134 }
79072805 4135 }
130c5df3 4136#ifdef USE_LOCALE_CTYPE
d6ded950 4137 if (IN_LC_RUNTIME(LC_CTYPE)) {
445bf929
KW		 4138 TAINT;
4139 SvTAINTED_on(dest);
4140 }
130c5df3 4141#endif
539689e7
FC		 4142 if (dest != source && SvTAINTED(source))
4143 SvTAINT(dest);
ec9af7d4 4144 SvSETMAGIC(dest);
79072805
LW		 4145 RETURN;
4146}
4147
a0d0e21e 4148PP(pp_quotemeta)
79072805 4149{
20b7effb 4150 dSP; dTARGET;
1b6737cc 4151 SV * const sv = TOPs;
a0d0e21e 4152 STRLEN len;
eb578fdb 4153 const char *s = SvPV_const(sv,len);
79072805 4154
7e2040f0 4155 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4156 if (len) {
eb578fdb 4157 char *d;
862a34c6 4158 SvUPGRADE(TARG, SVt_PV);
c07a80fd 4159 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 4160 d = SvPVX(TARG);
7e2040f0 4161 if (DO_UTF8(sv)) {
0dd2cdef 4162 while (len) {
29050de5 4163 STRLEN ulen = UTF8SKIP(s);
2e2b2571
KW		 4164 bool to_quote = FALSE;
4165
4166 if (UTF8_IS_INVARIANT(*s)) {
4167 if (_isQUOTEMETA(*s)) {
4168 to_quote = TRUE;
4169 }
4170 }
4171 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3fea7d29 4172 if (
130c5df3 4173#ifdef USE_LOCALE_CTYPE
20adcf7c
KW		 4174 /* In locale, we quote all non-ASCII Latin1 chars.
4175 * Otherwise use the quoting rules */
3fea7d29
BF		 4176
4177 IN_LC_RUNTIME(LC_CTYPE)
4178 ||
4179#endif
4180 _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
2e2b2571
KW		 4181 {
4182 to_quote = TRUE;
4183 }
4184 }
685289b5 4185 else if (is_QUOTEMETA_high(s)) {
2e2b2571
KW		 4186 to_quote = TRUE;
4187 }
4188
4189 if (to_quote) {
4190 *d++ = '\\';
4191 }
29050de5
KW		 4192 if (ulen > len)
4193 ulen = len;
4194 len -= ulen;
4195 while (ulen--)
4196 *d++ = *s++;
0dd2cdef 4197 }
7e2040f0 4198 SvUTF8_on(TARG);
0dd2cdef 4199 }
2e2b2571
KW		 4200 else if (IN_UNI_8_BIT) {
4201 while (len--) {
4202 if (_isQUOTEMETA(*s))
4203 *d++ = '\\';
4204 *d++ = *s++;
4205 }
4206 }
0dd2cdef 4207 else {
2e2b2571
KW		 4208 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4209 * including everything above ASCII */
0dd2cdef 4210 while (len--) {
adfec831 4211 if (!isWORDCHAR_A(*s))
0dd2cdef
LW		 4212 *d++ = '\\';
4213 *d++ = *s++;
4214 }
79072805 4215 }
a0d0e21e 4216 *d = '\0';
349d4f2f 4217 SvCUR_set(TARG, d - SvPVX_const(TARG));
3aa33fe5 4218 (void)SvPOK_only_UTF8(TARG);
79072805 4219 }
a0d0e21e
LW		 4220 else
4221 sv_setpvn(TARG, s, len);
ec93b65f 4222 SETTARG;
79072805
LW		 4223 RETURN;
4224}
4225
838f2281
BF		 4226PP(pp_fc)
4227{
838f2281
BF		 4228 dTARGET;
4229 dSP;
4230 SV *source = TOPs;
4231 STRLEN len;
4232 STRLEN min;
4233 SV *dest;
4234 const U8 *s;
4235 const U8 *send;
4236 U8 *d;
bfac13d4 4237 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
a4b69695
KW		 4238 const bool full_folding = TRUE; /* This variable is here so we can easily
4239 move to more generality later */
838f2281 4240 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
130c5df3
KW		 4241#ifdef USE_LOCALE_CTYPE
4242 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4243#endif
4244 ;
838f2281
BF		 4245
4246 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4247 * You are welcome(?) -Hugmeir
4248 */
4249
4250 SvGETMAGIC(source);
4251
4252 dest = TARG;
4253
4254 if (SvOK(source)) {
4255 s = (const U8*)SvPV_nomg_const(source, len);
4256 } else {
4257 if (ckWARN(WARN_UNINITIALIZED))
4258 report_uninit(source);
4259 s = (const U8*)"";
4260 len = 0;
4261 }
4262
4263 min = len + 1;
4264
4265 SvUPGRADE(dest, SVt_PV);
4266 d = (U8*)SvGROW(dest, min);
4267 (void)SvPOK_only(dest);
4268
4269 SETs(dest);
4270
4271 send = s + len;
4272 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
838f2281
BF		 4273 while (s < send) {
4274 const STRLEN u = UTF8SKIP(s);
4275 STRLEN ulen;
4276
445bf929 4277 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
838f2281
BF		 4278
4279 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4280 const UV o = d - (U8*)SvPVX_const(dest);
4281 SvGROW(dest, min);
4282 d = (U8*)SvPVX(dest) + o;
4283 }
4284
4285 Copy(tmpbuf, d, ulen, U8);
4286 d += ulen;
4287 s += u;
4288 }
4289 SvUTF8_on(dest);
838f2281 4290 } /* Unflagged string */
0902dd32 4291 else if (len) {
130c5df3 4292#ifdef USE_LOCALE_CTYPE
d6ded950 4293 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
31f05a37
KW		 4294 if (IN_UTF8_CTYPE_LOCALE) {
4295 goto do_uni_folding;
4296 }
838f2281 4297 for (; s < send; d++, s++)
ea36a843 4298 *d = (U8) toFOLD_LC(*s);
838f2281 4299 }
130c5df3
KW		 4300 else
4301#endif
4302 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
838f2281 4303 for (; s < send; d++, s++)
d22b930b 4304 *d = toFOLD(*s);
838f2281
BF		 4305 }
4306 else {
91191cf7 4307#ifdef USE_LOCALE_CTYPE
31f05a37 4308 do_uni_folding:
91191cf7 4309#endif
d14578b8
KW		 4310 /* For ASCII and the Latin-1 range, there's only two troublesome
4311 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
22e255cb 4312 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
d14578b8
KW		 4313 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4314 * For the rest, the casefold is their lowercase. */
838f2281
BF		 4315 for (; s < send; d++, s++) {
4316 if (*s == MICRO_SIGN) {
d14578b8
KW		 4317 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4318 * which is outside of the latin-1 range. There's a couple
4319 * of ways to deal with this -- khw discusses them in
4320 * pp_lc/uc, so go there :) What we do here is upgrade what
4321 * we had already casefolded, then enter an inner loop that
4322 * appends the rest of the characters as UTF-8. */
838f2281
BF		 4323 len = d - (U8*)SvPVX_const(dest);
4324 SvCUR_set(dest, len);
4325 len = sv_utf8_upgrade_flags_grow(dest,
4326 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
ea4d335b
KW		 4327 /* The max expansion for latin1
4328 * chars is 1 byte becomes 2 */
4329 (send -s) * 2 + 1);
838f2281
BF		 4330 d = (U8*)SvPVX(dest) + len;
4331
a78bc3c6
KW		 4332 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4333 d += small_mu_len;
838f2281
BF		 4334 s++;
4335 for (; s < send; s++) {
4336 STRLEN ulen;
4337 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
6f2d5cbc 4338 if UVCHR_IS_INVARIANT(fc) {
d14578b8
KW		 4339 if (full_folding
4340 && *s == LATIN_SMALL_LETTER_SHARP_S)
4341 {
838f2281
BF		 4342 *d++ = 's';
4343 *d++ = 's';
4344 }
4345 else
4346 *d++ = (U8)fc;
4347 }
4348 else {
4349 Copy(tmpbuf, d, ulen, U8);
4350 d += ulen;
4351 }
4352 }
4353 break;
4354 }
4355 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
d14578b8
KW		 4356 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4357 * becomes "ss", which may require growing the SV. */
838f2281
BF		 4358 if (SvLEN(dest) < ++min) {
4359 const UV o = d - (U8*)SvPVX_const(dest);
4360 SvGROW(dest, min);
4361 d = (U8*)SvPVX(dest) + o;
4362 }
4363 *(d)++ = 's';
4364 *d = 's';
4365 }
d14578b8
KW		 4366 else { /* If it's not one of those two, the fold is their lower
4367 case */
838f2281
BF		 4368 *d = toLOWER_LATIN1(*s);
4369 }
4370 }
4371 }
4372 }
4373 *d = '\0';
4374 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4375
130c5df3 4376#ifdef USE_LOCALE_CTYPE
d6ded950 4377 if (IN_LC_RUNTIME(LC_CTYPE)) {
445bf929
KW		 4378 TAINT;
4379 SvTAINTED_on(dest);
4380 }
130c5df3 4381#endif
838f2281
BF		 4382 if (SvTAINTED(source))
4383 SvTAINT(dest);
4384 SvSETMAGIC(dest);
4385 RETURN;
4386}
4387
a0d0e21e 4388/* Arrays. */
79072805 4389
a0d0e21e 4390PP(pp_aslice)
79072805 4391{
20b7effb 4392 dSP; dMARK; dORIGMARK;
eb578fdb
KW		 4393 AV *const av = MUTABLE_AV(POPs);
4394 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
79072805 4395
a0d0e21e 4396 if (SvTYPE(av) == SVt_PVAV) {
4ad10a0b
VP		 4397 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4398 bool can_preserve = FALSE;
4399
4400 if (localizing) {
4401 MAGIC *mg;
4402 HV *stash;
4403
4404 can_preserve = SvCANEXISTDELETE(av);
4405 }
4406
4407 if (lval && localizing) {
eb578fdb 4408 SV **svp;
c70927a6 4409 SSize_t max = -1;
924508f0 4410 for (svp = MARK + 1; svp <= SP; svp++) {
c70927a6 4411 const SSize_t elem = SvIV(*svp);
748a9306
LW		 4412 if (elem > max)
4413 max = elem;
4414 }
4415 if (max > AvMAX(av))
4416 av_extend(av, max);
4417 }
4ad10a0b 4418
a0d0e21e 4419 while (++MARK <= SP) {
eb578fdb 4420 SV **svp;
c70927a6 4421 SSize_t elem = SvIV(*MARK);
4ad10a0b 4422 bool preeminent = TRUE;
a0d0e21e 4423
4ad10a0b
VP		 4424 if (localizing && can_preserve) {
4425 /* If we can determine whether the element exist,
4426 * Try to preserve the existenceness of a tied array
4427 * element by using EXISTS and DELETE if possible.
4428 * Fallback to FETCH and STORE otherwise. */
4429 preeminent = av_exists(av, elem);
4430 }
4431
a0d0e21e
LW		 4432 svp = av_fetch(av, elem, lval);
4433 if (lval) {
ce0d59fd 4434 if (!svp || !*svp)
cea2e8a9 4435 DIE(aTHX_ PL_no_aelem, elem);
4ad10a0b
VP		 4436 if (localizing) {
4437 if (preeminent)
4438 save_aelem(av, elem, svp);
4439 else
4440 SAVEADELETE(av, elem);
4441 }
79072805 4442 }
3280af22 4443 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 4444 }
4445 }
748a9306 4446 if (GIMME != G_ARRAY) {
a0d0e21e 4447 MARK = ORIGMARK;
04ab2c87 4448 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e
LW		 4449 SP = MARK;
4450 }
79072805
LW		 4451 RETURN;
4452}
4453
6dd3e0f2
RZ		 4454PP(pp_kvaslice)
4455{
20b7effb 4456 dSP; dMARK;
6dd3e0f2
RZ		 4457 AV *const av = MUTABLE_AV(POPs);
4458 I32 lval = (PL_op->op_flags & OPf_MOD);
adad97db 4459 SSize_t items = SP - MARK;
6dd3e0f2
RZ		 4460
4461 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4462 const I32 flags = is_lvalue_sub();
4463 if (flags) {
4464 if (!(flags & OPpENTERSUB_INARGS))
7aae0299 4465 /* diag_listed_as: Can't modify %s in %s */
6dd3e0f2
RZ		 4466 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4467 lval = flags;
4468 }
4469 }
4470
4471 MEXTEND(SP,items);
4472 while (items > 1) {
4473 *(MARK+items*2-1) = *(MARK+items);
4474 items--;
4475 }
4476 items = SP-MARK;
4477 SP += items;
4478
4479 while (++MARK <= SP) {
4480 SV **svp;
4481
4482 svp = av_fetch(av, SvIV(*MARK), lval);
4483 if (lval) {
4484 if (!svp || !*svp || *svp == &PL_sv_undef) {
4485 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4486 }
4487 *MARK = sv_mortalcopy(*MARK);
4488 }
4489 *++MARK = svp ? *svp : &PL_sv_undef;
4490 }
4491 if (GIMME != G_ARRAY) {
4492 MARK = SP - items*2;
4493 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4494 SP = MARK;
4495 }
4496 RETURN;
4497}
4498
b1c05ba5 4499
cba5a3b0 4500/* Smart dereferencing for keys, values and each */
b1c05ba5
DM		 4501
4502/* also used for: pp_reach() pp_rvalues() */
4503
cba5a3b0
DG		 4504PP(pp_rkeys)
4505{
cba5a3b0
DG		 4506 dSP;
4507 dPOPss;
4508
7ac5715b
FC		 4509 SvGETMAGIC(sv);
4510
4511 if (
4512 !SvROK(sv)
4513 || (sv = SvRV(sv),
4514 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4515 || SvOBJECT(sv)
4516 )
4517 ) {
4518 DIE(aTHX_
4519 "Type of argument to %s must be unblessed hashref or arrayref",
4c540399 4520 PL_op_desc[PL_op->op_type] );
cba5a3b0
DG		 4521 }
4522
d8065907
FC		 4523 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4524 DIE(aTHX_
4525 "Can't modify %s in %s",
4526 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4527 );
4528
cba5a3b0
DG		 4529 /* Delegate to correct function for op type */
4530 PUSHs(sv);
4531 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4532 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4533 }
4534 else {
d14578b8
KW		 4535 return (SvTYPE(sv) == SVt_PVHV)
4536 ? Perl_pp_each(aTHX)
4537 : Perl_pp_aeach(aTHX);
cba5a3b0
DG		 4538 }
4539}
4540
878d132a
NC		 4541PP(pp_aeach)
4542{
878d132a 4543 dSP;
502c6561 4544 AV *array = MUTABLE_AV(POPs);
878d132a 4545 const I32 gimme = GIMME_V;
453d94a9 4546 IV *iterp = Perl_av_iter_p(aTHX_ array);
878d132a
NC		 4547 const IV current = (*iterp)++;
4548
b9f2b683 4549 if (current > av_tindex(array)) {
878d132a
NC		 4550 *iterp = 0;
4551 if (gimme == G_SCALAR)
4552 RETPUSHUNDEF;
4553 else
4554 RETURN;
4555 }
4556
4557 EXTEND(SP, 2);
e1dccc0d 4558 mPUSHi(current);
878d132a
NC		 4559 if (gimme == G_ARRAY) {
4560 SV **const element = av_fetch(array, current, 0);
4561 PUSHs(element ? *element : &PL_sv_undef);
4562 }
4563 RETURN;
4564}
4565
b1c05ba5 4566/* also used for: pp_avalues()*/
878d132a
NC		 4567PP(pp_akeys)
4568{
878d132a 4569 dSP;
502c6561 4570 AV *array = MUTABLE_AV(POPs);
878d132a
NC		 4571 const I32 gimme = GIMME_V;
4572
4573 *Perl_av_iter_p(aTHX_ array) = 0;
4574
4575 if (gimme == G_SCALAR) {
4576 dTARGET;
b9f2b683 4577 PUSHi(av_tindex(array) + 1);
878d132a
NC		 4578 }
4579 else if (gimme == G_ARRAY) {
4580 IV n = Perl_av_len(aTHX_ array);
e1dccc0d 4581 IV i;
878d132a
NC		 4582
4583 EXTEND(SP, n + 1);
4584
cba5a3b0 4585 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
e1dccc0d 4586 for (i = 0; i <= n; i++) {
878d132a
NC		 4587 mPUSHi(i);
4588 }
4589 }
4590 else {
4591 for (i = 0; i <= n; i++) {
4592 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4593 PUSHs(elem ? *elem : &PL_sv_undef);
4594 }
4595 }
4596 }
4597 RETURN;
4598}
4599
79072805
LW		 4600/* Associative arrays. */
4601
4602PP(pp_each)
4603{
39644a26 4604 dSP;
85fbaab2 4605 HV * hash = MUTABLE_HV(POPs);
c07a80fd 4606 HE *entry;
f54cb97a 4607 const I32 gimme = GIMME_V;
8ec5e241 4608
c07a80fd 4609 PUTBACK;
c750a3ec 4610 /* might clobber stack_sp */
6d822dc4 4611 entry = hv_iternext(hash);
c07a80fd 4612 SPAGAIN;
79072805 4613
79072805
LW		 4614 EXTEND(SP, 2);
4615 if (entry) {
1b6737cc 4616 SV* const sv = hv_iterkeysv(entry);
574c8022 4617 PUSHs(sv); /* won't clobber stack_sp */
54310121 4618 if (gimme == G_ARRAY) {
59af0135 4619 SV *val;
c07a80fd 4620 PUTBACK;
c750a3ec 4621 /* might clobber stack_sp */
6d822dc4 4622 val = hv_iterval(hash, entry);
c07a80fd 4623 SPAGAIN;
59af0135 4624 PUSHs(val);
79072805 4625 }
79072805 4626 }
54310121 4627 else if (gimme == G_SCALAR)
79072805
LW		 4628 RETPUSHUNDEF;
4629
4630 RETURN;
4631}
4632
7332a6c4
VP		 4633STATIC OP *
4634S_do_delete_local(pTHX)
79072805 4635{
39644a26 4636 dSP;
f54cb97a 4637 const I32 gimme = GIMME_V;
7332a6c4
VP		 4638 const MAGIC *mg;
4639 HV *stash;
ca3f996a 4640 const bool sliced = !!(PL_op->op_private & OPpSLICE);
626040f7 4641 SV **unsliced_keysv = sliced ? NULL : sp--;
ca3f996a 4642 SV * const osv = POPs;
626040f7 4643 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
ca3f996a
FC		 4644 dORIGMARK;
4645 const bool tied = SvRMAGICAL(osv)
7332a6c4 4646 && mg_find((const SV *)osv, PERL_MAGIC_tied);
ca3f996a
FC		 4647 const bool can_preserve = SvCANEXISTDELETE(osv);
4648 const U32 type = SvTYPE(osv);
626040f7 4649 SV ** const end = sliced ? SP : unsliced_keysv;
ca3f996a
FC		 4650
4651 if (type == SVt_PVHV) { /* hash element */
7332a6c4 4652 HV * const hv = MUTABLE_HV(osv);
ca3f996a 4653 while (++MARK <= end) {
7332a6c4
VP		 4654 SV * const keysv = *MARK;
4655 SV *sv = NULL;
4656 bool preeminent = TRUE;
4657 if (can_preserve)
4658 preeminent = hv_exists_ent(hv, keysv, 0);
4659 if (tied) {
4660 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4661 if (he)
4662 sv = HeVAL(he);
4663 else
4664 preeminent = FALSE;
4665 }
4666 else {
4667 sv = hv_delete_ent(hv, keysv, 0, 0);
9332b95f
FC		 4668 if (preeminent)
4669 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
7332a6c4
VP		 4670 }
4671 if (preeminent) {
be6064fd 4672 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
7332a6c4
VP		 4673 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4674 if (tied) {
4675 *MARK = sv_mortalcopy(sv);
4676 mg_clear(sv);
4677 } else
4678 *MARK = sv;
4679 }
4680 else {
4681 SAVEHDELETE(hv, keysv);
4682 *MARK = &PL_sv_undef;
4683 }
4684 }
ca3f996a
FC		 4685 }
4686 else if (type == SVt_PVAV) { /* array element */
7332a6c4
VP		 4687 if (PL_op->op_flags & OPf_SPECIAL) {
4688 AV * const av = MUTABLE_AV(osv);
ca3f996a 4689 while (++MARK <= end) {
c70927a6 4690 SSize_t idx = SvIV(*MARK);
7332a6c4
VP		 4691 SV *sv = NULL;
4692 bool preeminent = TRUE;
4693 if (can_preserve)
4694 preeminent = av_exists(av, idx);
4695 if (tied) {
4696 SV **svp = av_fetch(av, idx, 1);
4697 if (svp)
4698 sv = *svp;
4699 else
4700 preeminent = FALSE;
4701 }
4702 else {
4703 sv = av_delete(av, idx, 0);
9332b95f
FC		 4704 if (preeminent)
4705 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
7332a6c4
VP		 4706 }
4707 if (preeminent) {
4708 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4709 if (tied) {
4710 *MARK = sv_mortalcopy(sv);
4711 mg_clear(sv);
4712 } else
4713 *MARK = sv;
4714 }
4715 else {
4716 SAVEADELETE(av, idx);
4717 *MARK = &PL_sv_undef;
4718 }
4719 }
4720 }
ca3f996a
FC		 4721 else
4722 DIE(aTHX_ "panic: avhv_delete no longer supported");
4723 }
4724 else
7332a6c4 4725 DIE(aTHX_ "Not a HASH reference");
ca3f996a 4726 if (sliced) {
7332a6c4
VP		 4727 if (gimme == G_VOID)
4728 SP = ORIGMARK;
4729 else if (gimme == G_SCALAR) {
4730 MARK = ORIGMARK;
4731 if (SP > MARK)
4732 *++MARK = *SP;
4733 else
4734 *++MARK = &PL_sv_undef;
4735 SP = MARK;
4736 }
4737 }
ca3f996a 4738 else if (gimme != G_VOID)
626040f7 4739 PUSHs(*unsliced_keysv);
7332a6c4
VP		 4740
4741 RETURN;
4742}
4743
4744PP(pp_delete)
4745{
7332a6c4
VP		 4746 dSP;
4747 I32 gimme;
4748 I32 discard;
4749
4750 if (PL_op->op_private & OPpLVAL_INTRO)
4751 return do_delete_local();
4752
4753 gimme = GIMME_V;
4754 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5f05dabc 4755
533c011a 4756 if (PL_op->op_private & OPpSLICE) {
5f05dabc 4757 dMARK; dORIGMARK;
85fbaab2 4758 HV * const hv = MUTABLE_HV(POPs);
1b6737cc 4759 const U32 hvtype = SvTYPE(hv);
01020589
GS		 4760 if (hvtype == SVt_PVHV) { /* hash element */
4761 while (++MARK <= SP) {
1b6737cc 4762 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 4763 *MARK = sv ? sv : &PL_sv_undef;
4764 }
5f05dabc 4765 }
6d822dc4
MS		 4766 else if (hvtype == SVt_PVAV) { /* array element */
4767 if (PL_op->op_flags & OPf_SPECIAL) {
4768 while (++MARK <= SP) {
502c6561 4769 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
6d822dc4
MS		 4770 *MARK = sv ? sv : &PL_sv_undef;
4771 }
4772 }
01020589
GS		 4773 }
4774 else
4775 DIE(aTHX_ "Not a HASH reference");
54310121 4776 if (discard)
4777 SP = ORIGMARK;
4778 else if (gimme == G_SCALAR) {
5f05dabc 4779 MARK = ORIGMARK;
9111c9c0
DM		 4780 if (SP > MARK)
4781 *++MARK = *SP;
4782 else
4783 *++MARK = &PL_sv_undef;
5f05dabc 4784 SP = MARK;
4785 }
4786 }
4787 else {
4788 SV *keysv = POPs;
85fbaab2 4789 HV * const hv = MUTABLE_HV(POPs);
295d248e 4790 SV *sv = NULL;
97fcbf96
MB		 4791 if (SvTYPE(hv) == SVt_PVHV)
4792 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 4793 else if (SvTYPE(hv) == SVt_PVAV) {
4794 if (PL_op->op_flags & OPf_SPECIAL)
502c6561 4795 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
af288a60
HS		 4796 else
4797 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 4798 }
97fcbf96 4799 else
cea2e8a9 4800 DIE(aTHX_ "Not a HASH reference");
5f05dabc 4801 if (!sv)
3280af22 4802 sv = &PL_sv_undef;
54310121 4803 if (!discard)
4804 PUSHs(sv);
79072805 4805 }
79072805
LW		 4806 RETURN;
4807}
4808
a0d0e21e 4809PP(pp_exists)
79072805 4810{
39644a26 4811 dSP;
afebc493
GS		 4812 SV *tmpsv;
4813 HV *hv;
4814
c7e88ff3 4815 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
afebc493 4816 GV *gv;
0bd48802 4817 SV * const sv = POPs;
f2c0649b 4818 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
afebc493
GS		 4819 if (cv)
4820 RETPUSHYES;
4821 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4822 RETPUSHYES;
4823 RETPUSHNO;
4824 }
4825 tmpsv = POPs;
85fbaab2 4826 hv = MUTABLE_HV(POPs);
c7e88ff3 4827 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
ae77835f 4828 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 4829 RETPUSHYES;
ef54e1a4
JH		 4830 }
4831 else if (SvTYPE(hv) == SVt_PVAV) {
01020589 4832 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
502c6561 4833 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
01020589
GS		 4834 RETPUSHYES;
4835 }
ef54e1a4
JH		 4836 }
4837 else {
cea2e8a9 4838 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 4839 }
a0d0e21e
LW		 4840 RETPUSHNO;
4841}
79072805 4842
a0d0e21e
LW		 4843PP(pp_hslice)
4844{
20b7effb 4845 dSP; dMARK; dORIGMARK;
eb578fdb
KW		 4846 HV * const hv = MUTABLE_HV(POPs);
4847 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
1b6737cc 4848 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 4849 bool can_preserve = FALSE;
79072805 4850
eb85dfd3
DM		 4851 if (localizing) {
4852 MAGIC *mg;
4853 HV *stash;
4854
2c5f48c2 4855 if (SvCANEXISTDELETE(hv))
d30e492c 4856 can_preserve = TRUE;
eb85dfd3
DM		 4857 }
4858
6d822dc4 4859 while (++MARK <= SP) {
1b6737cc 4860 SV * const keysv = *MARK;
6d822dc4
MS		 4861 SV **svp;
4862 HE *he;
d30e492c
VP		 4863 bool preeminent = TRUE;
4864
4865 if (localizing && can_preserve) {
4866 /* If we can determine whether the element exist,
4867 * try to preserve the existenceness of a tied hash
4868 * element by using EXISTS and DELETE if possible.
4869 * Fallback to FETCH and STORE otherwise. */
4870 preeminent = hv_exists_ent(hv, keysv, 0);
6d822dc4 4871 }
eb85dfd3 4872
6d822dc4 4873 he = hv_fetch_ent(hv, keysv, lval, 0);
fe5bfecd 4874 svp = he ? &HeVAL(he) : NULL;
eb85dfd3 4875
6d822dc4 4876 if (lval) {
746f6409 4877 if (!svp || !*svp || *svp == &PL_sv_undef) {
be2597df 4878 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6d822dc4
MS		 4879 }
4880 if (localizing) {
7a2e501a 4881 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 4882 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP		 4883 else if (preeminent)
4884 save_helem_flags(hv, keysv, svp,
4885 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4886 else
4887 SAVEHDELETE(hv, keysv);
6d822dc4
MS		 4888 }
4889 }
746f6409 4890 *MARK = svp && *svp ? *svp : &PL_sv_undef;
79072805 4891 }
a0d0e21e
LW		 4892 if (GIMME != G_ARRAY) {
4893 MARK = ORIGMARK;
04ab2c87 4894 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e 4895 SP = MARK;
79072805 4896 }
a0d0e21e
LW		 4897 RETURN;
4898}
4899
5cae3edb
RZ		 4900PP(pp_kvhslice)
4901{
20b7effb 4902 dSP; dMARK;
5cae3edb
RZ		 4903 HV * const hv = MUTABLE_HV(POPs);
4904 I32 lval = (PL_op->op_flags & OPf_MOD);
adad97db 4905 SSize_t items = SP - MARK;
5cae3edb
RZ		 4906
4907 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4908 const I32 flags = is_lvalue_sub();
4909 if (flags) {
4910 if (!(flags & OPpENTERSUB_INARGS))
7aae0299 4911 /* diag_listed_as: Can't modify %s in %s */
5cae3edb
RZ		 4912 Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
4913 lval = flags;
4914 }
4915 }
4916
4917 MEXTEND(SP,items);
4918 while (items > 1) {
4919 *(MARK+items*2-1) = *(MARK+items);
4920 items--;
4921 }
4922 items = SP-MARK;
4923 SP += items;
4924
4925 while (++MARK <= SP) {
4926 SV * const keysv = *MARK;
4927 SV **svp;
4928 HE *he;
4929
4930 he = hv_fetch_ent(hv, keysv, lval, 0);
4931 svp = he ? &HeVAL(he) : NULL;
4932
4933 if (lval) {
4934 if (!svp || !*svp || *svp == &PL_sv_undef) {
4935 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4936 }
4937 *MARK = sv_mortalcopy(*MARK);
4938 }
4939 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
4940 }
4941 if (GIMME != G_ARRAY) {
4942 MARK = SP - items*2;
4943 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4944 SP = MARK;
4945 }
4946 RETURN;
4947}
4948
a0d0e21e
LW		 4949/* List operators. */
4950
4951PP(pp_list)
4952{
4fa715fa 4953 I32 markidx = POPMARK;
a0d0e21e 4954 if (GIMME != G_ARRAY) {
4fa715fa
DD		 4955 SV **mark = PL_stack_base + markidx;
4956 dSP;
a0d0e21e
LW		 4957 if (++MARK <= SP)
4958 *MARK = *SP; /* unwanted list, return last item */
8990e307 4959 else
3280af22 4960 *MARK = &PL_sv_undef;
a0d0e21e 4961 SP = MARK;
4fa715fa 4962 PUTBACK;
79072805 4963 }
4fa715fa 4964 return NORMAL;
79072805
LW		 4965}
4966
a0d0e21e 4967PP(pp_lslice)
79072805 4968{
39644a26 4969 dSP;
1b6737cc
AL		 4970 SV ** const lastrelem = PL_stack_sp;
4971 SV ** const lastlelem = PL_stack_base + POPMARK;
4972 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
eb578fdb 4973 SV ** const firstrelem = lastlelem + 1;
42e73ed0 4974 I32 is_something_there = FALSE;
706a6ebc 4975 const U8 mod = PL_op->op_flags & OPf_MOD;
1b6737cc 4976
eb578fdb
KW		 4977 const I32 max = lastrelem - lastlelem;
4978 SV **lelem;
a0d0e21e
LW		 4979
4980 if (GIMME != G_ARRAY) {
4ea561bc 4981 I32 ix = SvIV(*lastlelem);
748a9306
LW		 4982 if (ix < 0)
4983 ix += max;
a0d0e21e 4984 if (ix < 0 || ix >= max)
3280af22 4985 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 4986 else
4987 *firstlelem = firstrelem[ix];
4988 SP = firstlelem;
4989 RETURN;
4990 }
4991
4992 if (max == 0) {
4993 SP = firstlelem - 1;
4994 RETURN;
4995 }
4996
4997 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4ea561bc 4998 I32 ix = SvIV(*lelem);
c73bf8e3 4999 if (ix < 0)
a0d0e21e 5000 ix += max;
c73bf8e3
HS		 5001 if (ix < 0 || ix >= max)
5002 *lelem = &PL_sv_undef;
5003 else {
5004 is_something_there = TRUE;
5005 if (!(*lelem = firstrelem[ix]))
3280af22 5006 *lelem = &PL_sv_undef;
60779a30 5007 else if (mod && SvPADTMP(*lelem)) {
706a6ebc 5008 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
60779a30 5009 }
748a9306 5010 }
79072805 5011 }
4633a7c4
LW		 5012 if (is_something_there)
5013 SP = lastlelem;
5014 else
5015 SP = firstlelem - 1;
79072805
LW		 5016 RETURN;
5017}
5018
a0d0e21e
LW		 5019PP(pp_anonlist)
5020{
20b7effb 5021 dSP; dMARK;
1b6737cc 5022 const I32 items = SP - MARK;
ad64d0ec 5023 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
31476221 5024 SP = MARK;
6e449a3a
MHM		 5025 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5026 ? newRV_noinc(av) : av);
a0d0e21e
LW		 5027 RETURN;
5028}
5029
5030PP(pp_anonhash)
79072805 5031{
20b7effb 5032 dSP; dMARK; dORIGMARK;
67e67fd7 5033 HV* const hv = newHV();
8d455b9f 5034 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
67e67fd7 5035 ? newRV_noinc(MUTABLE_SV(hv))
8d455b9f 5036 : MUTABLE_SV(hv) );
a0d0e21e
LW		 5037
5038 while (MARK < SP) {
3ed356df
FC		 5039 SV * const key =
5040 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5041 SV *val;
a0d0e21e 5042 if (MARK < SP)
3ed356df
FC		 5043 {
5044 MARK++;
5045 SvGETMAGIC(*MARK);
5046 val = newSV(0);
5047 sv_setsv(val, *MARK);
5048 }
a2a5de95 5049 else
3ed356df 5050 {
a2a5de95 5051 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3ed356df
FC		 5052 val = newSV(0);
5053 }
f12c7020 5054 (void)hv_store_ent(hv,key,val,0);
79072805 5055 }
a0d0e21e 5056 SP = ORIGMARK;
8d455b9f 5057 XPUSHs(retval);
79072805
LW		 5058 RETURN;
5059}
5060
d4fc4415
FC		 5061static AV *
5062S_deref_plain_array(pTHX_ AV *ary)
5063{
5064 if (SvTYPE(ary) == SVt_PVAV) return ary;
d2d95e13 5065 SvGETMAGIC((SV *)ary);
d4fc4415
FC		 5066 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5067 Perl_die(aTHX_ "Not an ARRAY reference");
5068 else if (SvOBJECT(SvRV(ary)))
5069 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5070 return (AV *)SvRV(ary);
5071}
5072
5073#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5074# define DEREF_PLAIN_ARRAY(ary) \
5075 ({ \
5076 AV *aRrRay = ary; \
5077 SvTYPE(aRrRay) == SVt_PVAV \
5078 ? aRrRay \
5079 : S_deref_plain_array(aTHX_ aRrRay); \
5080 })
5081#else
5082# define DEREF_PLAIN_ARRAY(ary) \
5083 ( \
3b0f6d32 5084 PL_Sv = (SV *)(ary), \
d4fc4415
FC		 5085 SvTYPE(PL_Sv) == SVt_PVAV \
5086 ? (AV *)PL_Sv \
3b0f6d32 5087 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
d4fc4415
FC		 5088 )
5089#endif
5090
a0d0e21e 5091PP(pp_splice)
79072805 5092{
20b7effb 5093 dSP; dMARK; dORIGMARK;
5cd408a2 5094 int num_args = (SP - MARK);
eb578fdb
KW		 5095 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5096 SV **src;
5097 SV **dst;
c70927a6
FC		 5098 SSize_t i;
5099 SSize_t offset;
5100 SSize_t length;
5101 SSize_t newlen;
5102 SSize_t after;
5103 SSize_t diff;
ad64d0ec 5104 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 5105
1b6737cc 5106 if (mg) {
3e0cb5de 5107 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
af71faff
NC		 5108 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5109 sp - mark);
93965878 5110 }
79072805 5111
a0d0e21e 5112 SP++;
79072805 5113
a0d0e21e 5114 if (++MARK < SP) {
4ea561bc 5115 offset = i = SvIV(*MARK);
a0d0e21e 5116 if (offset < 0)
93965878 5117 offset += AvFILLp(ary) + 1;
84902520 5118 if (offset < 0)
cea2e8a9 5119 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 5120 if (++MARK < SP) {
5121 length = SvIVx(*MARK++);
48cdf507
GA		 5122 if (length < 0) {
5123 length += AvFILLp(ary) - offset + 1;
5124 if (length < 0)
5125 length = 0;
5126 }
79072805
LW		 5127 }
5128 else
a0d0e21e 5129 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 5130 }
a0d0e21e
LW		 5131 else {
5132 offset = 0;
5133 length = AvMAX(ary) + 1;
5134 }
8cbc2e3b 5135 if (offset > AvFILLp(ary) + 1) {
5cd408a2
EB		 5136 if (num_args > 2)
5137 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 5138 offset = AvFILLp(ary) + 1;
8cbc2e3b 5139 }
93965878 5140 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 5141 if (after < 0) { /* not that much array */
5142 length += after; /* offset+length now in array */
5143 after = 0;
5144 if (!AvALLOC(ary))
5145 av_extend(ary, 0);
5146 }
5147
5148 /* At this point, MARK .. SP-1 is our new LIST */
5149
5150 newlen = SP - MARK;
5151 diff = newlen - length;
13d7cbc1
GS		 5152 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5153 av_reify(ary);
a0d0e21e 5154
50528de0
WL		 5155 /* make new elements SVs now: avoid problems if they're from the array */
5156 for (dst = MARK, i = newlen; i; i--) {
1b6737cc 5157 SV * const h = *dst;
f2b990bf 5158 *dst++ = newSVsv(h);
50528de0
WL		 5159 }
5160
a0d0e21e 5161 if (diff < 0) { /* shrinking the area */
95b63a38 5162 SV **tmparyval = NULL;
a0d0e21e 5163 if (newlen) {
a02a5408 5164 Newx(tmparyval, newlen, SV*); /* so remember insertion */
a0d0e21e 5165 Copy(MARK, tmparyval, newlen, SV*);
79072805 5166 }
a0d0e21e
LW		 5167
5168 MARK = ORIGMARK + 1;
5169 if (GIMME == G_ARRAY) { /* copy return vals to stack */
31c61add 5170 const bool real = cBOOL(AvREAL(ary));
a0d0e21e 5171 MEXTEND(MARK, length);
31c61add 5172 if (real)
bbce6d69 5173 EXTEND_MORTAL(length);
31c61add
FC		 5174 for (i = 0, dst = MARK; i < length; i++) {
5175 if ((*dst = AvARRAY(ary)[i+offset])) {
5176 if (real)
486ec47a 5177 sv_2mortal(*dst); /* free them eventually */
36477c24 5178 }
31c61add
FC		 5179 else
5180 *dst = &PL_sv_undef;
5181 dst++;
a0d0e21e
LW		 5182 }
5183 MARK += length - 1;
79072805 5184 }
a0d0e21e
LW		 5185 else {
5186 *MARK = AvARRAY(ary)[offset+length-1];
5187 if (AvREAL(ary)) {
d689ffdd 5188 sv_2mortal(*MARK);
a0d0e21e
LW		 5189 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5190 SvREFCNT_dec(*dst++); /* free them now */
79072805 5191 }
a0d0e21e 5192 }
93965878 5193 AvFILLp(ary) += diff;
a0d0e21e
LW		 5194
5195 /* pull up or down? */
5196
5197 if (offset < after) { /* easier to pull up */
5198 if (offset) { /* esp. if nothing to pull */
5199 src = &AvARRAY(ary)[offset-1];
5200 dst = src - diff; /* diff is negative */
5201 for (i = offset; i > 0; i--) /* can't trust Copy */
5202 *dst-- = *src--;
79072805 5203 }
a0d0e21e 5204 dst = AvARRAY(ary);
9c6bc640 5205 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
a0d0e21e
LW		 5206 AvMAX(ary) += diff;
5207 }
5208 else {
5209 if (after) { /* anything to pull down? */
5210 src = AvARRAY(ary) + offset + length;
5211 dst = src + diff; /* diff is negative */
5212 Move(src, dst, after, SV*);
79072805 5213 }
93965878 5214 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 5215 /* avoid later double free */
5216 }
5217 i = -diff;
5218 while (i)
ce0d59fd 5219 dst[--i] = NULL;
a0d0e21e
LW		 5220
5221 if (newlen) {
50528de0 5222 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e
LW		 5223 Safefree(tmparyval);
5224 }
5225 }
5226 else { /* no, expanding (or same) */
d3961450 5227 SV** tmparyval = NULL;
a0d0e21e 5228 if (length) {
a02a5408 5229 Newx(tmparyval, length, SV*); /* so remember deletion */
a0d0e21e
LW		 5230 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5231 }
5232
5233 if (diff > 0) { /* expanding */
a0d0e21e 5234 /* push up or down? */
a0d0e21e
LW		 5235 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5236 if (offset) {
5237 src = AvARRAY(ary);
5238 dst = src - diff;
5239 Move(src, dst, offset, SV*);
79072805 5240 }
9c6bc640 5241 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
a0d0e21e 5242 AvMAX(ary) += diff;
93965878 5243 AvFILLp(ary) += diff;
79072805
LW		 5244 }
5245 else {
93965878
NIS		 5246 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5247 av_extend(ary, AvFILLp(ary) + diff);
5248 AvFILLp(ary) += diff;
a0d0e21e
LW		 5249
5250 if (after) {
93965878 5251 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 5252 src = dst - diff;
5253 for (i = after; i; i--) {
5254 *dst-- = *src--;
5255 }
79072805
LW		 5256 }
5257 }
a0d0e21e
LW		 5258 }
5259
50528de0
WL		 5260 if (newlen) {
5261 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e 5262 }
50528de0 5263
a0d0e21e
LW		 5264 MARK = ORIGMARK + 1;
5265 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5266 if (length) {
31c61add
FC		 5267 const bool real = cBOOL(AvREAL(ary));
5268 if (real)
bbce6d69 5269 EXTEND_MORTAL(length);
31c61add
FC		 5270 for (i = 0, dst = MARK; i < length; i++) {
5271 if ((*dst = tmparyval[i])) {
5272 if (real)
486ec47a 5273 sv_2mortal(*dst); /* free them eventually */
36477c24 5274 }
31c61add
FC		 5275 else *dst = &PL_sv_undef;
5276 dst++;
79072805
LW		 5277 }
5278 }
a0d0e21e
LW		 5279 MARK += length - 1;
5280 }
5281 else if (length--) {
5282 *MARK = tmparyval[length];
5283 if (AvREAL(ary)) {
d689ffdd 5284 sv_2mortal(*MARK);
a0d0e21e
LW		 5285 while (length-- > 0)
5286 SvREFCNT_dec(tmparyval[length]);
79072805 5287 }
79072805 5288 }
a0d0e21e 5289 else
3280af22 5290 *MARK = &PL_sv_undef;
d3961450 5291 Safefree(tmparyval);
79072805 5292 }
474af990
FR		 5293
5294 if (SvMAGICAL(ary))
5295 mg_set(MUTABLE_SV(ary));
5296
a0d0e21e 5297 SP = MARK;
79072805
LW		 5298 RETURN;
5299}
5300
a0d0e21e 5301PP(pp_push)
79072805 5302{
20b7effb 5303 dSP; dMARK; dORIGMARK; dTARGET;
eb578fdb 5304 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5305 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
79072805 5306
1b6737cc 5307 if (mg) {
ad64d0ec 5308 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
93965878
NIS		 5309 PUSHMARK(MARK);
5310 PUTBACK;
d343c3ef 5311 ENTER_with_name("call_PUSH");
3e0cb5de 5312 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5313 LEAVE_with_name("call_PUSH");
93965878 5314 SPAGAIN;
93965878 5315 }
a60c0954 5316 else {
cb077ed2 5317 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
89c14e2e 5318 PL_delaymagic = DM_DELAY;
a60c0954 5319 for (++MARK; MARK <= SP; MARK++) {
3ed356df
FC		 5320 SV *sv;
5321 if (*MARK) SvGETMAGIC(*MARK);
5322 sv = newSV(0);
a60c0954 5323 if (*MARK)
3ed356df 5324 sv_setsv_nomg(sv, *MARK);
0a75904b 5325 av_store(ary, AvFILLp(ary)+1, sv);
a60c0954 5326 }
354b0578 5327 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 5328 mg_set(MUTABLE_SV(ary));
89c14e2e
BB		 5329
5330 PL_delaymagic = 0;
6eeabd23
VP		 5331 }
5332 SP = ORIGMARK;
5333 if (OP_GIMME(PL_op, 0) != G_VOID) {
5334 PUSHi( AvFILL(ary) + 1 );
79072805 5335 }
79072805
LW		 5336 RETURN;
5337}
5338
b1c05ba5 5339/* also used for: pp_pop()*/
a0d0e21e 5340PP(pp_shift)
79072805 5341{
39644a26 5342 dSP;
538f5756 5343 AV * const av = PL_op->op_flags & OPf_SPECIAL
d4fc4415 5344 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
789b4bc9 5345 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
79072805 5346 EXTEND(SP, 1);
c2b4a044 5347 assert (sv);
d689ffdd 5348 if (AvREAL(av))
a0d0e21e
LW		 5349 (void)sv_2mortal(sv);
5350 PUSHs(sv);
79072805 5351 RETURN;
79072805
LW		 5352}
5353
a0d0e21e 5354PP(pp_unshift)
79072805 5355{
20b7effb 5356 dSP; dMARK; dORIGMARK; dTARGET;
eb578fdb 5357 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5358 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 5359
1b6737cc 5360 if (mg) {
ad64d0ec 5361 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
7fd66d9d 5362 PUSHMARK(MARK);
93965878 5363 PUTBACK;
d343c3ef 5364 ENTER_with_name("call_UNSHIFT");
36925d9e 5365 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5366 LEAVE_with_name("call_UNSHIFT");
93965878 5367 SPAGAIN;
93965878 5368 }
a60c0954 5369 else {
c70927a6 5370 SSize_t i = 0;
a60c0954
NIS		 5371 av_unshift(ary, SP - MARK);
5372 while (MARK < SP) {
1b6737cc 5373 SV * const sv = newSVsv(*++MARK);
a60c0954
NIS		 5374 (void)av_store(ary, i++, sv);
5375 }
79072805 5376 }
a0d0e21e 5377 SP = ORIGMARK;
6eeabd23 5378 if (OP_GIMME(PL_op, 0) != G_VOID) {
5658d0a9
LR		 5379 PUSHi( AvFILL(ary) + 1 );
5380 }
79072805 5381 RETURN;
79072805
LW		 5382}
5383
a0d0e21e 5384PP(pp_reverse)
79072805 5385{
20b7effb 5386 dSP; dMARK;
79072805 5387
a0d0e21e 5388 if (GIMME == G_ARRAY) {
484c818f
VP		 5389 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5390 AV *av;
5391
5392 /* See pp_sort() */
5393 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5394 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5395 av = MUTABLE_AV((*SP));
5396 /* In-place reversing only happens in void context for the array
5397 * assignment. We don't need to push anything on the stack. */
5398 SP = MARK;
5399
5400 if (SvMAGICAL(av)) {
c70927a6 5401 SSize_t i, j;
eb578fdb 5402 SV *tmp = sv_newmortal();
484c818f
VP		 5403 /* For SvCANEXISTDELETE */
5404 HV *stash;
5405 const MAGIC *mg;
5406 bool can_preserve = SvCANEXISTDELETE(av);
5407
b9f2b683 5408 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
eb578fdb 5409 SV *begin, *end;
484c818f
VP		 5410
5411 if (can_preserve) {
5412 if (!av_exists(av, i)) {
5413 if (av_exists(av, j)) {
eb578fdb 5414 SV *sv = av_delete(av, j, 0);
484c818f
VP		 5415 begin = *av_fetch(av, i, TRUE);
5416 sv_setsv_mg(begin, sv);
5417 }
5418 continue;
5419 }
5420 else if (!av_exists(av, j)) {
eb578fdb 5421 SV *sv = av_delete(av, i, 0);
484c818f
VP		 5422 end = *av_fetch(av, j, TRUE);
5423 sv_setsv_mg(end, sv);
5424 continue;
5425 }
5426 }
5427
5428 begin = *av_fetch(av, i, TRUE);
5429 end = *av_fetch(av, j, TRUE);
5430 sv_setsv(tmp, begin);
5431 sv_setsv_mg(begin, end);
5432 sv_setsv_mg(end, tmp);
5433 }
5434 }
5435 else {
5436 SV **begin = AvARRAY(av);
484c818f 5437
95a26d8e
VP		 5438 if (begin) {
5439 SV **end = begin + AvFILLp(av);
5440
5441 while (begin < end) {
eb578fdb 5442 SV * const tmp = *begin;
95a26d8e
VP		 5443 *begin++ = *end;
5444 *end-- = tmp;
5445 }
484c818f
VP		 5446 }
5447 }
5448 }
5449 else {
5450 SV **oldsp = SP;
5451 MARK++;
5452 while (MARK < SP) {
eb578fdb 5453 SV * const tmp = *MARK;
484c818f
VP		 5454 *MARK++ = *SP;
5455 *SP-- = tmp;
5456 }
5457 /* safe as long as stack cannot get extended in the above */
5458 SP = oldsp;
a0d0e21e 5459 }
79072805
LW		 5460 }
5461 else {
eb578fdb
KW		 5462 char *up;
5463 char *down;
5464 I32 tmp;
a0d0e21e
LW		 5465 dTARGET;
5466 STRLEN len;
79072805 5467
7e2040f0 5468 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 5469 if (SP - MARK > 1)
3280af22 5470 do_join(TARG, &PL_sv_no, MARK, SP);
1e21d011 5471 else {
789bd863 5472 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
1e21d011
B		 5473 }
5474
a0d0e21e
LW		 5475 up = SvPV_force(TARG, len);
5476 if (len > 1) {
7e2040f0 5477 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55 5478 U8* s = (U8*)SvPVX(TARG);
349d4f2f 5479 const U8* send = (U8*)(s + len);
a0ed51b3 5480 while (s < send) {
d742c382 5481 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 5482 s++;
5483 continue;
5484 }
5485 else {
4b88fb76 5486 if (!utf8_to_uvchr_buf(s, send, 0))
a0dbb045 5487 break;
dfe13c55 5488 up = (char*)s;
a0ed51b3 5489 s += UTF8SKIP(s);
dfe13c55 5490 down = (char*)(s - 1);
a0dbb045 5491 /* reverse this character */
a0ed51b3
LW		 5492 while (down > up) {
5493 tmp = *up;
5494 *up++ = *down;
eb160463 5495 *down-- = (char)tmp;
a0ed51b3
LW		 5496 }
5497 }
5498 }
5499 up = SvPVX(TARG);
5500 }
a0d0e21e
LW		 5501 down = SvPVX(TARG) + len - 1;
5502 while (down > up) {
5503 tmp = *up;
5504 *up++ = *down;
eb160463 5505 *down-- = (char)tmp;
a0d0e21e 5506 }
3aa33fe5 5507 (void)SvPOK_only_UTF8(TARG);
79072805 5508 }
a0d0e21e
LW		 5509 SP = MARK + 1;
5510 SETTARG;
79072805 5511 }
a0d0e21e 5512 RETURN;
79072805
LW		 5513}
5514
a0d0e21e 5515PP(pp_split)
79072805 5516{
20b7effb 5517 dSP; dTARG;
ef7999f1 5518 AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
eb578fdb 5519 IV limit = POPi; /* note, negative is forever */
1b6737cc 5520 SV * const sv = POPs;
a0d0e21e 5521 STRLEN len;
eb578fdb 5522 const char *s = SvPV_const(sv, len);
1b6737cc 5523 const bool do_utf8 = DO_UTF8(sv);
727b7506 5524 const char *strend = s + len;
eb578fdb
KW		 5525 PMOP *pm;
5526 REGEXP *rx;
5527 SV *dstr;
5528 const char *m;
c70927a6 5529 SSize_t iters = 0;
d14578b8
KW		 5530 const STRLEN slen = do_utf8
5531 ? utf8_length((U8*)s, (U8*)strend)
5532 : (STRLEN)(strend - s);
c70927a6 5533 SSize_t maxiters = slen + 10;
c1a7495a 5534 I32 trailing_empty = 0;
727b7506 5535 const char *orig;
1b6737cc 5536 const I32 origlimit = limit;
a0d0e21e
LW		 5537 I32 realarray = 0;
5538 I32 base;
f54cb97a 5539 const I32 gimme = GIMME_V;
941446f6 5540 bool gimme_scalar;
f54cb97a 5541 const I32 oldsave = PL_savestack_ix;
437d3b4e 5542 U32 make_mortal = SVs_TEMP;
7fba1cd6 5543 bool multiline = 0;
b37c2d43 5544 MAGIC *mg = NULL;
79072805 5545
44a8e56a 5546#ifdef DEBUGGING
5547 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5548#else
5549 pm = (PMOP*)POPs;
5550#endif
b3941ae9 5551 if (!pm)
5637ef5b 5552 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
aaa362c4 5553 rx = PM_GETRE(pm);
bbce6d69 5554
a62b1201 5555 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
dbc200c5 5556 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
bbce6d69 5557
971a9dd3 5558#ifdef USE_ITHREADS
20e98b0f 5559 if (pm->op_pmreplrootu.op_pmtargetoff) {
159b6efe 5560 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
20e98b0f 5561 }
971a9dd3 5562#else
20e98b0f
NC		 5563 if (pm->op_pmreplrootu.op_pmtargetgv) {
5564 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
971a9dd3 5565 }
20e98b0f 5566#endif
ef7999f1
FC		 5567 else if (pm->op_targ)
5568 ary = (AV *)PAD_SVl(pm->op_targ);
bcea25a7 5569 if (ary) {
a0d0e21e 5570 realarray = 1;
8ec5e241 5571 PUTBACK;
a0d0e21e 5572 av_extend(ary,0);
821956c5 5573 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 5574 av_clear(ary);
8ec5e241 5575 SPAGAIN;
ad64d0ec 5576 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
8ec5e241 5577 PUSHMARK(SP);
ad64d0ec 5578 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
8ec5e241
NIS		 5579 }
5580 else {
1c0b011c 5581 if (!AvREAL(ary)) {
1b6737cc 5582 I32 i;
1c0b011c 5583 AvREAL_on(ary);
abff13bb 5584 AvREIFY_off(ary);
1c0b011c 5585 for (i = AvFILLp(ary); i >= 0; i--)
d14578b8 5586 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 5587 }
5588 /* temporarily switch stacks */
8b7059b1 5589 SAVESWITCHSTACK(PL_curstack, ary);
8ec5e241 5590 make_mortal = 0;
1c0b011c 5591 }
79072805 5592 }
3280af22 5593 base = SP - PL_stack_base;
a0d0e21e 5594 orig = s;
dbc200c5 5595 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
613f191e 5596 if (do_utf8) {
76a77b1b 5597 while (isSPACE_utf8(s))
613f191e
TS		 5598 s += UTF8SKIP(s);
5599 }
a62b1201 5600 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
bbce6d69 5601 while (isSPACE_LC(*s))
5602 s++;
5603 }
5604 else {
5605 while (isSPACE(*s))
5606 s++;
5607 }
a0d0e21e 5608 }
73134a2e 5609 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
7fba1cd6 5610 multiline = 1;
c07a80fd 5611 }
5612
941446f6
FC		 5613 gimme_scalar = gimme == G_SCALAR && !ary;
5614
a0d0e21e
LW		 5615 if (!limit)
5616 limit = maxiters + 2;
dbc200c5 5617 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
a0d0e21e 5618 while (--limit) {
bbce6d69 5619 m = s;
8727f688
YO		 5620 /* this one uses 'm' and is a negative test */
5621 if (do_utf8) {
76a77b1b 5622 while (m < strend && ! isSPACE_utf8(m) ) {
613f191e 5623 const int t = UTF8SKIP(m);
76a77b1b 5624 /* isSPACE_utf8 returns FALSE for malform utf8 */
613f191e
TS		 5625 if (strend - m < t)
5626 m = strend;
5627 else
5628 m += t;
5629 }
a62b1201 5630 }
d14578b8
KW		 5631 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5632 {
8727f688
YO		 5633 while (m < strend && !isSPACE_LC(*m))
5634 ++m;
5635 } else {
5636 while (m < strend && !isSPACE(*m))
5637 ++m;
5638 }
a0d0e21e
LW		 5639 if (m >= strend)
5640 break;
bbce6d69 5641
c1a7495a
BB		 5642 if (gimme_scalar) {
5643 iters++;
5644 if (m-s == 0)
5645 trailing_empty++;
5646 else
5647 trailing_empty = 0;
5648 } else {
5649 dstr = newSVpvn_flags(s, m-s,
5650 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5651 XPUSHs(dstr);
5652 }
bbce6d69 5653
613f191e
TS		 5654 /* skip the whitespace found last */
5655 if (do_utf8)
5656 s = m + UTF8SKIP(m);
5657 else
5658 s = m + 1;
5659
8727f688
YO		 5660 /* this one uses 's' and is a positive test */
5661 if (do_utf8) {
76a77b1b 5662 while (s < strend && isSPACE_utf8(s) )
8727f688 5663 s += UTF8SKIP(s);
a62b1201 5664 }
d14578b8
KW		 5665 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5666 {
8727f688
YO		 5667 while (s < strend && isSPACE_LC(*s))
5668 ++s;
5669 } else {
5670 while (s < strend && isSPACE(*s))
5671 ++s;
5672 }
79072805
LW		 5673 }
5674 }
07bc277f 5675 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
a0d0e21e 5676 while (--limit) {
a6e20a40
AL		 5677 for (m = s; m < strend && *m != '\n'; m++)
5678 ;
a0d0e21e
LW		 5679 m++;
5680 if (m >= strend)
5681 break;
c1a7495a
BB		 5682
5683 if (gimme_scalar) {
5684 iters++;
5685 if (m-s == 0)
5686 trailing_empty++;
5687 else
5688 trailing_empty = 0;
5689 } else {
5690 dstr = newSVpvn_flags(s, m-s,
5691 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5692 XPUSHs(dstr);
5693 }
a0d0e21e
LW		 5694 s = m;
5695 }
5696 }
07bc277f 5697 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
640f820d
AB		 5698 /*
5699 Pre-extend the stack, either the number of bytes or
5700 characters in the string or a limited amount, triggered by:
5701
5702 my ($x, $y) = split //, $str;
5703 or
5704 split //, $str, $i;
5705 */
c1a7495a
BB		 5706 if (!gimme_scalar) {
5707 const U32 items = limit - 1;
5708 if (items < slen)
5709 EXTEND(SP, items);
5710 else
5711 EXTEND(SP, slen);
5712 }
640f820d 5713
e9515b0f
AB		 5714 if (do_utf8) {
5715 while (--limit) {
5716 /* keep track of how many bytes we skip over */
5717 m = s;
640f820d 5718 s += UTF8SKIP(s);
c1a7495a
BB		 5719 if (gimme_scalar) {
5720 iters++;
5721 if (s-m == 0)
5722 trailing_empty++;
5723 else
5724 trailing_empty = 0;
5725 } else {
5726 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
640f820d 5727
c1a7495a
BB		 5728 PUSHs(dstr);
5729 }
640f820d 5730
e9515b0f
AB		 5731 if (s >= strend)
5732 break;
5733 }
5734 } else {
5735 while (--limit) {
c1a7495a
BB		 5736 if (gimme_scalar) {
5737 iters++;
5738 } else {
5739 dstr = newSVpvn(s, 1);
e9515b0f 5740
e9515b0f 5741
c1a7495a
BB		 5742 if (make_mortal)
5743 sv_2mortal(dstr);
640f820d 5744
c1a7495a
BB		 5745 PUSHs(dstr);
5746 }
5747
5748 s++;
e9515b0f
AB		 5749
5750 if (s >= strend)
5751 break;
5752 }
640f820d
AB		 5753 }
5754 }
3c8556c3 5755 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
07bc277f
NC		 5756 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5757 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
8e1490ee 5758 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
07bc277f 5759 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
f9f4320a 5760 SV * const csv = CALLREG_INTUIT_STRING(rx);
cf93c79d 5761
07bc277f 5762 len = RX_MINLENRET(rx);
3c8556c3 5763 if (len == 1 && !RX_UTF8(rx) && !tail) {
1b6737cc 5764 const char c = *SvPV_nolen_const(csv);
a0d0e21e 5765 while (--limit) {
a6e20a40
AL		 5766 for (m = s; m < strend && *m != c; m++)
5767 ;
a0d0e21e
LW		 5768 if (m >= strend)
5769 break;
c1a7495a
BB		 5770 if (gimme_scalar) {
5771 iters++;
5772 if (m-s == 0)
5773 trailing_empty++;
5774 else
5775 trailing_empty = 0;
5776 } else {
5777 dstr = newSVpvn_flags(s, m-s,
d14578b8 5778 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
c1a7495a
BB		 5779 XPUSHs(dstr);
5780 }
93f04dac
JH		 5781 /* The rx->minlen is in characters but we want to step
5782 * s ahead by bytes. */
1aa99e6b
IH		 5783 if (do_utf8)
5784 s = (char*)utf8_hop((U8*)m, len);
5785 else
5786 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 5787 }
5788 }
5789 else {
a0d0e21e 5790 while (s < strend && --limit &&
f722798b 5791 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
7fba1cd6 5792 csv, multiline ? FBMrf_MULTILINE : 0)) )
a0d0e21e 5793 {
c1a7495a
BB		 5794 if (gimme_scalar) {
5795 iters++;
5796 if (m-s == 0)
5797 trailing_empty++;
5798 else
5799 trailing_empty = 0;
5800 } else {
5801 dstr = newSVpvn_flags(s, m-s,
d14578b8 5802 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
c1a7495a
BB		 5803 XPUSHs(dstr);
5804 }
93f04dac
JH		 5805 /* The rx->minlen is in characters but we want to step
5806 * s ahead by bytes. */
1aa99e6b
IH		 5807 if (do_utf8)
5808 s = (char*)utf8_hop((U8*)m, len);
5809 else
5810 s = m + len; /* Fake \n at the end */
a0d0e21e 5811 }
463ee0b2 5812 }
463ee0b2 5813 }
a0d0e21e 5814 else {
07bc277f 5815 maxiters += slen * RX_NPARENS(rx);
080c2dec 5816 while (s < strend && --limit)
bbce6d69 5817 {
1b6737cc 5818 I32 rex_return;
080c2dec 5819 PUTBACK;
d14578b8 5820 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
c33e64f0 5821 sv, NULL, 0);
080c2dec 5822 SPAGAIN;
1b6737cc 5823 if (rex_return == 0)
080c2dec 5824 break;
d9f97599 5825 TAINT_IF(RX_MATCH_TAINTED(rx));
6502e081
DM		 5826 /* we never pass the REXEC_COPY_STR flag, so it should
5827 * never get copied */
5828 assert(!RX_MATCH_COPIED(rx));
07bc277f 5829 m = RX_OFFS(rx)[0].start + orig;
c1a7495a
BB		 5830
5831 if (gimme_scalar) {
5832 iters++;
5833 if (m-s == 0)
5834 trailing_empty++;
5835 else
5836 trailing_empty = 0;
5837 } else {
5838 dstr = newSVpvn_flags(s, m-s,
5839 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5840 XPUSHs(dstr);
5841 }
07bc277f 5842 if (RX_NPARENS(rx)) {
1b6737cc 5843 I32 i;
07bc277f
NC		 5844 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5845 s = RX_OFFS(rx)[i].start + orig;
5846 m = RX_OFFS(rx)[i].end + orig;
6de67870
JP		 5847
5848 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5849 parens that didn't match -- they should be set to
5850 undef, not the empty string */
c1a7495a
BB		 5851 if (gimme_scalar) {
5852 iters++;
5853 if (m-s == 0)
5854 trailing_empty++;
5855 else
5856 trailing_empty = 0;
5857 } else {
5858 if (m >= orig && s >= orig) {
5859 dstr = newSVpvn_flags(s, m-s,
5860 (do_utf8 ? SVf_UTF8 : 0)
5861 | make_mortal);
5862 }
5863 else
5864 dstr = &PL_sv_undef; /* undef, not "" */
5865 XPUSHs(dstr);
748a9306 5866 }
c1a7495a 5867
a0d0e21e
LW		 5868 }
5869 }
07bc277f 5870 s = RX_OFFS(rx)[0].end + orig;
a0d0e21e 5871 }
79072805 5872 }
8ec5e241 5873
c1a7495a
BB		 5874 if (!gimme_scalar) {
5875 iters = (SP - PL_stack_base) - base;
5876 }
a0d0e21e 5877 if (iters > maxiters)
cea2e8a9 5878 DIE(aTHX_ "Split loop");
8ec5e241 5879
a0d0e21e
LW		 5880 /* keep field after final delim? */
5881 if (s < strend || (iters && origlimit)) {
c1a7495a
BB		 5882 if (!gimme_scalar) {
5883 const STRLEN l = strend - s;
5884 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5885 XPUSHs(dstr);
5886 }
a0d0e21e 5887 iters++;
79072805 5888 }
a0d0e21e 5889 else if (!origlimit) {
c1a7495a
BB		 5890 if (gimme_scalar) {
5891 iters -= trailing_empty;
5892 } else {
5893 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5894 if (TOPs && !make_mortal)
5895 sv_2mortal(TOPs);
5896 *SP-- = &PL_sv_undef;
5897 iters--;
5898 }
89900bd3 5899 }
a0d0e21e 5900 }
8ec5e241 5901
8b7059b1
DM		 5902 PUTBACK;
5903 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5904 SPAGAIN;
a0d0e21e 5905 if (realarray) {
8ec5e241 5906 if (!mg) {
1c0b011c
NIS		 5907 if (SvSMAGICAL(ary)) {
5908 PUTBACK;
ad64d0ec 5909 mg_set(MUTABLE_SV(ary));
1c0b011c
NIS		 5910 SPAGAIN;
5911 }
5912 if (gimme == G_ARRAY) {
5913 EXTEND(SP, iters);
5914 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5915 SP += iters;
5916 RETURN;
5917 }
8ec5e241 5918 }
1c0b011c 5919 else {
fb73857a 5920 PUTBACK;
d343c3ef 5921 ENTER_with_name("call_PUSH");
36925d9e 5922 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5923 LEAVE_with_name("call_PUSH");
fb73857a 5924 SPAGAIN;
8ec5e241 5925 if (gimme == G_ARRAY) {
c70927a6 5926 SSize_t i;
8ec5e241
NIS		 5927 /* EXTEND should not be needed - we just popped them */
5928 EXTEND(SP, iters);
5929 for (i=0; i < iters; i++) {
5930 SV **svp = av_fetch(ary, i, FALSE);
3280af22 5931 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 5932 }
1c0b011c
NIS		 5933 RETURN;
5934 }
a0d0e21e
LW		 5935 }
5936 }
5937 else {
5938 if (gimme == G_ARRAY)
5939 RETURN;
5940 }
7f18b612
YST		 5941
5942 GETTARGET;
5943 PUSHi(iters);
5944 RETURN;
79072805 5945}
85e6fe83 5946
c5917253
NC		 5947PP(pp_once)
5948{
5949 dSP;
5950 SV *const sv = PAD_SVl(PL_op->op_targ);
5951
5952 if (SvPADSTALE(sv)) {
5953 /* First time. */
5954 SvPADSTALE_off(sv);
5955 RETURNOP(cLOGOP->op_other);
5956 }
5957 RETURNOP(cLOGOP->op_next);
5958}
5959
c0329465
MB		 5960PP(pp_lock)
5961{
39644a26 5962 dSP;
c0329465 5963 dTOPss;
e55aaa0e 5964 SV *retsv = sv;
68795e93 5965 SvLOCK(sv);
f79aa60b
FC		 5966 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5967 || SvTYPE(retsv) == SVt_PVCV) {
e55aaa0e
MB		 5968 retsv = refto(retsv);
5969 }
5970 SETs(retsv);
c0329465
MB		 5971 RETURN;
5972}
a863c7d1 5973
65bca31a 5974
b1c05ba5
DM		 5975/* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
5976 * that aren't implemented on a particular platform */
5977
65bca31a
NC		 5978PP(unimplemented_op)
5979{
361ed549
NC		 5980 const Optype op_type = PL_op->op_type;
5981 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5982 with out of range op numbers - it only "special" cases op_custom.
5983 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5984 if we get here for a custom op then that means that the custom op didn't
5985 have an implementation. Given that OP_NAME() looks up the custom op
5986 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5987 registers &PL_unimplemented_op as the address of their custom op.
5988 NULL doesn't generate a useful error message. "custom" does. */
5989 const char *const name = op_type >= OP_max
5990 ? "[out of range]" : PL_op_name[PL_op->op_type];
7627e6d0
NC		 5991 if(OP_IS_SOCKET(op_type))
5992 DIE(aTHX_ PL_no_sock_func, name);
361ed549 5993 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
65bca31a
NC		 5994}
5995
deb8a388
FC		 5996/* For sorting out arguments passed to a &CORE:: subroutine */
5997PP(pp_coreargs)
5998{
5999 dSP;
7fa5bd9b 6000 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
498a02d8 6001 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
7fa5bd9b 6002 AV * const at_ = GvAV(PL_defgv);
0e80230d
FC		 6003 SV **svp = at_ ? AvARRAY(at_) : NULL;
6004 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
7fa5bd9b 6005 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
46e00a91 6006 bool seen_question = 0;
7fa5bd9b 6007 const char *err = NULL;
3e6568b4 6008 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
7fa5bd9b 6009
46e00a91
FC		 6010 /* Count how many args there are first, to get some idea how far to
6011 extend the stack. */
7fa5bd9b 6012 while (oa) {
bf0571fd 6013 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
7fa5bd9b 6014 maxargs++;
46e00a91
FC		 6015 if (oa & OA_OPTIONAL) seen_question = 1;
6016 if (!seen_question) minargs++;
7fa5bd9b
FC		 6017 oa >>= 4;
6018 }
6019
6020 if(numargs < minargs) err = "Not enough";
6021 else if(numargs > maxargs) err = "Too many";
6022 if (err)
6023 /* diag_listed_as: Too many arguments for %s */
6024 Perl_croak(aTHX_
6025 "%s arguments for %s", err,
2a90c7c6 6026 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
7fa5bd9b
FC		 6027 );
6028
6029 /* Reset the stack pointer. Without this, we end up returning our own
6030 arguments in list context, in addition to the values we are supposed
6031 to return. nextstate usually does this on sub entry, but we need
e1fa07e3 6032 to run the next op with the caller's hints, so we cannot have a
7fa5bd9b
FC		 6033 nextstate. */
6034 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
6035
46e00a91
FC		 6036 if(!maxargs) RETURN;
6037
bf0571fd
FC		 6038 /* We do this here, rather than with a separate pushmark op, as it has
6039 to come in between two things this function does (stack reset and
6040 arg pushing). This seems the easiest way to do it. */
3e6568b4 6041 if (pushmark) {
bf0571fd
FC		 6042 PUTBACK;
6043 (void)Perl_pp_pushmark(aTHX);
6044 }
6045
6046 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
c931b036 6047 PUTBACK; /* The code below can die in various places. */
46e00a91
FC		 6048
6049 oa = PL_opargs[opnum] >> OASHIFT;
3e6568b4 6050 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
c931b036 6051 whicharg++;
46e00a91
FC		 6052 switch (oa & 7) {
6053 case OA_SCALAR:
1efec5ed 6054 try_defsv:
d6d78e19 6055 if (!numargs && defgv && whicharg == minargs + 1) {
d6d78e19 6056 PUSHs(find_rundefsv2(
db4cf31d 6057 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
b4b0692a 6058 cxstack[cxstack_ix].blk_oldcop->cop_seq
d6d78e19
FC		 6059 ));
6060 }
6061 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
46e00a91 6062 break;
bf0571fd
FC		 6063 case OA_LIST:
6064 while (numargs--) {
6065 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6066 svp++;
6067 }
6068 RETURN;
19c481f4
FC		 6069 case OA_HVREF:
6070 if (!svp || !*svp || !SvROK(*svp)
6071 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
6072 DIE(aTHX_
6073 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6074 "Type of arg %d to &CORE::%s must be hash reference",
6075 whicharg, OP_DESC(PL_op->op_next)
6076 );
6077 PUSHs(SvRV(*svp));
6078 break;
c931b036 6079 case OA_FILEREF:
30901a8a
FC		 6080 if (!numargs) PUSHs(NULL);
6081 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
c931b036
FC		 6082 /* no magic here, as the prototype will have added an extra
6083 refgen and we just want what was there before that */
6084 PUSHs(SvRV(*svp));
6085 else {
6086 const bool constr = PL_op->op_private & whicharg;
6087 PUSHs(S_rv2gv(aTHX_
6088 svp && *svp ? *svp : &PL_sv_undef,
b54f893d 6089 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
c931b036
FC		 6090 !constr
6091 ));
6092 }
6093 break;
c72a5629 6094 case OA_SCALARREF:
1efec5ed
FC		 6095 if (!numargs) goto try_defsv;
6096 else {
17008668
FC		 6097 const bool wantscalar =
6098 PL_op->op_private & OPpCOREARGS_SCALARMOD;
c72a5629 6099 if (!svp || !*svp || !SvROK(*svp)
17008668
FC		 6100 /* We have to permit globrefs even for the \$ proto, as
6101 *foo is indistinguishable from ${\*foo}, and the proto-
6102 type permits the latter. */
6103 || SvTYPE(SvRV(*svp)) > (
efe889ae 6104 wantscalar ? SVt_PVLV
46bef06f
FC		 6105 : opnum == OP_LOCK || opnum == OP_UNDEF
6106 ? SVt_PVCV
efe889ae 6107 : SVt_PVHV
17008668 6108 )
c72a5629
FC		 6109 )
6110 DIE(aTHX_
17008668 6111 "Type of arg %d to &CORE::%s must be %s",
46bef06f 6112 whicharg, PL_op_name[opnum],
17008668
FC		 6113 wantscalar
6114 ? "scalar reference"
46bef06f 6115 : opnum == OP_LOCK || opnum == OP_UNDEF
efe889ae
FC		 6116 ? "reference to one of [$@%&*]"
6117 : "reference to one of [$@%*]"
c72a5629
FC		 6118 );
6119 PUSHs(SvRV(*svp));
88bb468b
FC		 6120 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6121 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6122 /* Undo @_ localisation, so that sub exit does not undo
6123 part of our undeffing. */
6124 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6125 POP_SAVEARRAY();
6126 cx->cx_type &= ~ CXp_HASARGS;
6127 assert(!AvREAL(cx->blk_sub.argarray));
6128 }
17008668 6129 }
1efec5ed 6130 break;
46e00a91 6131 default:
46e00a91
FC		 6132 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6133 }
6134 oa = oa >> 4;
6135 }
6136
deb8a388
FC		 6137 RETURN;
6138}
6139
84ed0108
FC		 6140PP(pp_runcv)
6141{
6142 dSP;
6143 CV *cv;
6144 if (PL_op->op_private & OPpOFFBYONE) {
db4cf31d 6145 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
84ed0108
FC		 6146 }
6147 else cv = find_runcv(NULL);
e157a82b 6148 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
84ed0108
FC		 6149 RETURN;
6150}
6151
05a34802 6152static void
2331e434 6153S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
05a34802
FC		 6154 const bool can_preserve)
6155{
2331e434 6156 const SSize_t ix = SvIV(keysv);
05a34802
FC		 6157 if (can_preserve ? av_exists(av, ix) : TRUE) {
6158 SV ** const svp = av_fetch(av, ix, 1);
6159 if (!svp || !*svp)
6160 Perl_croak(aTHX_ PL_no_aelem, ix);
6161 save_aelem(av, ix, svp);
6162 }
6163 else
6164 SAVEADELETE(av, ix);
6165}
6166
5f94141d
FC		 6167static void
6168S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6169 const bool can_preserve)
6170{
6171 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6172 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6173 SV ** const svp = he ? &HeVAL(he) : NULL;
6174 if (!svp || !*svp)
6175 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6176 save_helem_flags(hv, keysv, svp, 0);
6177 }
6178 else
6179 SAVEHDELETE(hv, keysv);
6180}
6181
9782ce69
FC		 6182static void
6183S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6184{
6185 if (type == OPpLVREF_SV) {
6186 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6187 GvSV(gv) = 0;
6188 }
6189 else if (type == OPpLVREF_AV)
6190 /* XXX Inefficient, as it creates a new AV, which we are
6191 about to clobber. */
6192 save_ary(gv);
6193 else {
6194 assert(type == OPpLVREF_HV);
6195 /* XXX Likewise inefficient. */
6196 save_hash(gv);
6197 }
6198}
6199
6200
254da51f
FC		 6201PP(pp_refassign)
6202{
4fec8804 6203 dSP;
6102323a 6204 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
d8a875d9 6205 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
4fec8804 6206 dTOPss;
3f114923 6207 const char *bad = NULL;
ac0da85a 6208 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
4fec8804 6209 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
ac0da85a 6210 switch (type) {
3f114923
FC		 6211 case OPpLVREF_SV:
6212 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6213 bad = " SCALAR";
6214 break;
6215 case OPpLVREF_AV:
6216 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6217 bad = "n ARRAY";
6218 break;
6219 case OPpLVREF_HV:
6220 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6221 bad = " HASH";
6222 break;
6223 case OPpLVREF_CV:
6224 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6225 bad = " CODE";
6226 }
6227 if (bad)
1f8155a2 6228 /* diag_listed_as: Assigned value is not %s reference */
3f114923 6229 DIE(aTHX_ "Assigned value is not a%s reference", bad);
d8a875d9 6230 switch (left ? SvTYPE(left) : 0) {
5f94141d
FC		 6231 MAGIC *mg;
6232 HV *stash;
d8a875d9 6233 case 0:
cf5d2d91
FC		 6234 {
6235 SV * const old = PAD_SV(ARGTARG);
d8a875d9 6236 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
cf5d2d91 6237 SvREFCNT_dec(old);
3ad7d304
FC		 6238 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6239 == OPpLVAL_INTRO)
fc048fcf 6240 SAVECLEARSV(PAD_SVl(ARGTARG));
d8a875d9 6241 break;
cf5d2d91 6242 }
d8a875d9 6243 case SVt_PVGV:
2a57afb1 6244 if (PL_op->op_private & OPpLVAL_INTRO) {
9782ce69 6245 S_localise_gv_slot(aTHX_ (GV *)left, type);
2a57afb1 6246 }
d8a875d9
FC		 6247 gv_setref(left, sv);
6248 SvSETMAGIC(left);
6102323a
FC		 6249 break;
6250 case SVt_PVAV:
40d2b828 6251 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
2331e434 6252 S_localise_aelem_lval(aTHX_ (AV *)left, key,
05a34802 6253 SvCANEXISTDELETE(left));
40d2b828 6254 }
6102323a
FC		 6255 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6256 break;
5f94141d
FC		 6257 case SVt_PVHV:
6258 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
6259 S_localise_helem_lval(aTHX_ (HV *)left, key,
6260 SvCANEXISTDELETE(left));
6261 hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
d8a875d9 6262 }
4fec8804
FC		 6263 if (PL_op->op_flags & OPf_MOD)
6264 SETs(sv_2mortal(newSVsv(sv)));
6265 /* XXX else can weak references go stale before they are read, e.g.,
6266 in leavesub? */
6267 RETURN;
254da51f
FC		 6268}
6269
4c5bab50
FC		 6270PP(pp_lvref)
6271{
26a50d99
FC		 6272 dSP;
6273 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6102323a 6274 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
2a57afb1 6275 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
9782ce69
FC		 6276 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6277 &PL_vtbl_lvref, (char *)elem,
23270f96 6278 elem ? HEf_SVKEY : (I32)ARGTARG);
9782ce69 6279 mg->mg_private = PL_op->op_private;
d39c26a6
FC		 6280 if (PL_op->op_private & OPpLVREF_ITER)
6281 mg->mg_flags |= MGf_PERSIST;
9846cd95 6282 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
40d2b828
FC		 6283 if (elem) {
6284 MAGIC *mg;
6285 HV *stash;
5f94141d
FC		 6286 const bool can_preserve = SvCANEXISTDELETE(arg);
6287 if (SvTYPE(arg) == SVt_PVAV)
2331e434 6288 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
5f94141d
FC		 6289 else
6290 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
40d2b828
FC		 6291 }
6292 else if (arg) {
9782ce69
FC		 6293 S_localise_gv_slot(aTHX_ (GV *)arg,
6294 PL_op->op_private & OPpLVREF_TYPE);
2a57afb1 6295 }
3ad7d304 6296 else if (!(PL_op->op_private & OPpPAD_STATE))
c146a62a 6297 SAVECLEARSV(PAD_SVl(ARGTARG));
1199b01a 6298 }
c146a62a
FC		 6299 XPUSHs(ret);
6300 RETURN;
4c5bab50 6301}
84ed0108 6302
16b99412
FC		 6303PP(pp_lvrefslice)
6304{
a95dad8a 6305 dSP; dMARK;
0ca7b7f7
FC		 6306 AV * const av = (AV *)POPs;
6307 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6308 bool can_preserve = FALSE;
6309
9846cd95 6310 if (UNLIKELY(localizing)) {
0ca7b7f7
FC		 6311 MAGIC *mg;
6312 HV *stash;
6313 SV **svp;
6314
6315 can_preserve = SvCANEXISTDELETE(av);
6316
6317 if (SvTYPE(av) == SVt_PVAV) {
6318 SSize_t max = -1;
6319
6320 for (svp = MARK + 1; svp <= SP; svp++) {
6321 const SSize_t elem = SvIV(*svp);
6322 if (elem > max)
6323 max = elem;
6324 }
6325 if (max > AvMAX(av))
6326 av_extend(av, max);
6327 }
6328 }
6329
6330 while (++MARK <= SP) {
6331 SV * const elemsv = *MARK;
5f94141d 6332 if (SvTYPE(av) == SVt_PVAV)
2331e434 6333 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
5f94141d
FC		 6334 else
6335 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
0ca7b7f7
FC		 6336 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6337 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6338 }
6339 RETURN;
16b99412
FC		 6340}
6341
2882b3ff
FC		 6342PP(pp_lvavref)
6343{
bdaf10a5
FC		 6344 if (PL_op->op_flags & OPf_STACKED)
6345 Perl_pp_rv2av(aTHX);
6346 else
6347 Perl_pp_padav(aTHX);
6348 {
6349 dSP;
6350 dTOPss;
6351 SETs(0); /* special alias marker that aassign recognises */
6352 XPUSHs(sv);
6353 RETURN;
6354 }
2882b3ff
FC		 6355}
6356
e609e586
NC		 6357/*
6358 * Local variables:
6359 * c-indentation-style: bsd
6360 * c-basic-offset: 4
14d04a33 6361 * indent-tabs-mode: nil
e609e586
NC		 6362 * End:
6363 *
14d04a33 6364 * ex: set ts=8 sts=4 sw=4 et:
37442d52 6365 */
Unnamed repository; edit this file 'description' to name the repository.