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