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