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