This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Add :const anon sub attribute
[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;
a1894d81 1720 static const char* const oom_list_extend = "Out of memory during list extend";
0bd48802
AL		 1721 const I32 items = SP - MARK;
1722 const I32 max = items * count;
da9e430b 1723 const U8 mod = PL_op->op_flags & OPf_MOD;
79072805 1724
2b573ace
JH		 1725 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1726 /* Did the max computation overflow? */
27d5b266 1727 if (items > 0 && max > 0 && (max < items || max < count))
0157ef98 1728 Perl_croak(aTHX_ "%s", oom_list_extend);
a0d0e21e
LW		 1729 MEXTEND(MARK, max);
1730 if (count > 1) {
1731 while (SP > MARK) {
60779a30
DM		 1732 if (*SP) {
1733 if (mod && SvPADTMP(*SP)) {
da9e430b 1734 *SP = sv_mortalcopy(*SP);
60779a30 1735 }
976c8a39 1736 SvTEMP_off((*SP));
da9e430b 1737 }
a0d0e21e 1738 SP--;
79072805 1739 }
a0d0e21e
LW		 1740 MARK++;
1741 repeatcpy((char*)(MARK + items), (char*)MARK,
ad64d0ec 1742 items * sizeof(const SV *), count - 1);
a0d0e21e 1743 SP += max;
79072805 1744 }
a0d0e21e
LW		 1745 else if (count <= 0)
1746 SP -= items;
79072805 1747 }
a0d0e21e 1748 else { /* Note: mark already snarfed by pp_list */
0bd48802 1749 SV * const tmpstr = POPs;
a0d0e21e 1750 STRLEN len;
9b877dbb 1751 bool isutf;
a1894d81 1752 static const char* const oom_string_extend =
2b573ace 1753 "Out of memory during string extend";
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 {
c445ea15 1763 const STRLEN max = (UV)count * len;
19a94d75 1764 if (len > MEM_SIZE_MAX / count)
0157ef98 1765 Perl_croak(aTHX_ "%s", oom_string_extend);
2b573ace 1766 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
8569b9dc 1767 SvGROW(TARG, max + 1);
a0d0e21e 1768 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
b162af07 1769 SvCUR_set(TARG, SvCUR(TARG) * count);
7a4c00b4 1770 }
a0d0e21e 1771 *SvEND(TARG) = '\0';
a0d0e21e 1772 }
dfcb284a
GS		 1773 if (isutf)
1774 (void)SvPOK_only_UTF8(TARG);
1775 else
1776 (void)SvPOK_only(TARG);
b80b6069 1777
a0d0e21e 1778 PUSHTARG;
79072805 1779 }
a0d0e21e
LW		 1780 RETURN;
1781}
79072805 1782
a0d0e21e
LW		 1783PP(pp_subtract)
1784{
20b7effb 1785 dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM		 1786 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1787 svr = TOPs;
1788 svl = TOPm1s;
800401ee 1789 useleft = USE_LEFT(svl);
28e5dec8 1790#ifdef PERL_PRESERVE_IVUV
7dca457a
NC		 1791 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1792 "bad things" happen if you rely on signed integers wrapping. */
01f91bf2 1793 if (SvIV_please_nomg(svr)) {
28e5dec8
JH		 1794 /* Unless the left argument is integer in range we are going to have to
1795 use NV maths. Hence only attempt to coerce the right argument if
1796 we know the left is integer. */
eb578fdb 1797 UV auv = 0;
9c5ffd7c 1798 bool auvok = FALSE;
7dca457a
NC		 1799 bool a_valid = 0;
1800
28e5dec8 1801 if (!useleft) {
7dca457a
NC		 1802 auv = 0;
1803 a_valid = auvok = 1;
1804 /* left operand is undef, treat as zero. */
28e5dec8
JH		 1805 } else {
1806 /* Left operand is defined, so is it IV? */
01f91bf2 1807 if (SvIV_please_nomg(svl)) {
800401ee
JH		 1808 if ((auvok = SvUOK(svl)))
1809 auv = SvUVX(svl);
7dca457a 1810 else {
eb578fdb 1811 const IV aiv = SvIVX(svl);
7dca457a
NC		 1812 if (aiv >= 0) {
1813 auv = aiv;
1814 auvok = 1; /* Now acting as a sign flag. */
1815 } else { /* 2s complement assumption for IV_MIN */
53e2bfb7 1816 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
28e5dec8 1817 }
7dca457a
NC		 1818 }
1819 a_valid = 1;
1820 }
1821 }
1822 if (a_valid) {
1823 bool result_good = 0;
1824 UV result;
eb578fdb 1825 UV buv;
800401ee 1826 bool buvok = SvUOK(svr);
9041c2e3 1827
7dca457a 1828 if (buvok)
800401ee 1829 buv = SvUVX(svr);
7dca457a 1830 else {
eb578fdb 1831 const IV biv = SvIVX(svr);
7dca457a
NC		 1832 if (biv >= 0) {
1833 buv = biv;
1834 buvok = 1;
1835 } else
53e2bfb7 1836 buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
7dca457a
NC		 1837 }
1838 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1839 else "IV" now, independent of how it came in.
7dca457a
NC		 1840 if a, b represents positive, A, B negative, a maps to -A etc
1841 a - b => (a - b)
1842 A - b => -(a + b)
1843 a - B => (a + b)
1844 A - B => -(a - b)
1845 all UV maths. negate result if A negative.
1846 subtract if signs same, add if signs differ. */
1847
1848 if (auvok ^ buvok) {
1849 /* Signs differ. */
1850 result = auv + buv;
1851 if (result >= auv)
1852 result_good = 1;
1853 } else {
1854 /* Signs same */
1855 if (auv >= buv) {
1856 result = auv - buv;
1857 /* Must get smaller */
1858 if (result <= auv)
1859 result_good = 1;
1860 } else {
1861 result = buv - auv;
1862 if (result <= buv) {
1863 /* result really should be -(auv-buv). as its negation
1864 of true value, need to swap our result flag */
1865 auvok = !auvok;
1866 result_good = 1;
28e5dec8 1867 }
28e5dec8
JH		 1868 }
1869 }
7dca457a
NC		 1870 if (result_good) {
1871 SP--;
1872 if (auvok)
1873 SETu( result );
1874 else {
1875 /* Negate result */
1876 if (result <= (UV)IV_MIN)
53e2bfb7
DM		 1877 SETi(result == (UV)IV_MIN
1878 ? IV_MIN : -(IV)result);
7dca457a
NC		 1879 else {
1880 /* result valid, but out of range for IV. */
1881 SETn( -(NV)result );
1882 }
1883 }
1884 RETURN;
1885 } /* Overflow, drop through to NVs. */
28e5dec8
JH		 1886 }
1887 }
1888#endif
a0d0e21e 1889 {
6f1401dc 1890 NV value = SvNV_nomg(svr);
4efa5a16
RD		 1891 (void)POPs;
1892
28e5dec8
JH		 1893 if (!useleft) {
1894 /* left operand is undef, treat as zero - value */
1895 SETn(-value);
1896 RETURN;
1897 }
6f1401dc 1898 SETn( SvNV_nomg(svl) - value );
28e5dec8 1899 RETURN;
79072805 1900 }
a0d0e21e 1901}
79072805 1902
a0d0e21e
LW		 1903PP(pp_left_shift)
1904{
20b7effb 1905 dSP; dATARGET; SV *svl, *svr;
a42d0242 1906 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM		 1907 svr = POPs;
1908 svl = TOPs;
a0d0e21e 1909 {
6f1401dc 1910 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1911 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1912 const IV i = SvIV_nomg(svl);
972b05a9 1913 SETi(i << shift);
d0ba1bd2
JH		 1914 }
1915 else {
6f1401dc 1916 const UV u = SvUV_nomg(svl);
972b05a9 1917 SETu(u << shift);
d0ba1bd2 1918 }
55497cff 1919 RETURN;
79072805 1920 }
a0d0e21e 1921}
79072805 1922
a0d0e21e
LW		 1923PP(pp_right_shift)
1924{
20b7effb 1925 dSP; dATARGET; SV *svl, *svr;
a42d0242 1926 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM		 1927 svr = POPs;
1928 svl = TOPs;
a0d0e21e 1929 {
6f1401dc 1930 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1931 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1932 const IV i = SvIV_nomg(svl);
972b05a9 1933 SETi(i >> shift);
d0ba1bd2
JH		 1934 }
1935 else {
6f1401dc 1936 const UV u = SvUV_nomg(svl);
972b05a9 1937 SETu(u >> shift);
d0ba1bd2 1938 }
a0d0e21e 1939 RETURN;
93a17b20 1940 }
79072805
LW		 1941}
1942
a0d0e21e 1943PP(pp_lt)
79072805 1944{
20b7effb 1945 dSP;
33efebe6
DM		 1946 SV *left, *right;
1947
a42d0242 1948 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
33efebe6
DM		 1949 right = POPs;
1950 left = TOPs;
1951 SETs(boolSV(
1952 (SvIOK_notUV(left) && SvIOK_notUV(right))
1953 ? (SvIVX(left) < SvIVX(right))
1954 : (do_ncmp(left, right) == -1)
1955 ));
1956 RETURN;
a0d0e21e 1957}
79072805 1958
a0d0e21e
LW		 1959PP(pp_gt)
1960{
20b7effb 1961 dSP;
33efebe6 1962 SV *left, *right;
1b6737cc 1963
33efebe6
DM		 1964 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1965 right = POPs;
1966 left = TOPs;
1967 SETs(boolSV(
1968 (SvIOK_notUV(left) && SvIOK_notUV(right))
1969 ? (SvIVX(left) > SvIVX(right))
1970 : (do_ncmp(left, right) == 1)
1971 ));
1972 RETURN;
a0d0e21e
LW		 1973}
1974
1975PP(pp_le)
1976{
20b7effb 1977 dSP;
33efebe6 1978 SV *left, *right;
1b6737cc 1979
33efebe6
DM		 1980 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1981 right = POPs;
1982 left = TOPs;
1983 SETs(boolSV(
1984 (SvIOK_notUV(left) && SvIOK_notUV(right))
1985 ? (SvIVX(left) <= SvIVX(right))
1986 : (do_ncmp(left, right) <= 0)
1987 ));
1988 RETURN;
a0d0e21e
LW		 1989}
1990
1991PP(pp_ge)
1992{
20b7effb 1993 dSP;
33efebe6
DM		 1994 SV *left, *right;
1995
1996 tryAMAGICbin_MG(ge_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) & 2) == 0)
2003 ));
2004 RETURN;
2005}
1b6737cc 2006
33efebe6
DM		 2007PP(pp_ne)
2008{
20b7effb 2009 dSP;
33efebe6
DM		 2010 SV *left, *right;
2011
2012 tryAMAGICbin_MG(ne_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;
2021}
1b6737cc 2022
33efebe6
DM		 2023/* compare left and right SVs. Returns:
2024 * -1: <
2025 * 0: ==
2026 * 1: >
2027 * 2: left or right was a NaN
2028 */
2029I32
2030Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2031{
33efebe6
DM		 2032 PERL_ARGS_ASSERT_DO_NCMP;
2033#ifdef PERL_PRESERVE_IVUV
33efebe6 2034 /* Fortunately it seems NaN isn't IOK */
01f91bf2 2035 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
33efebe6
DM		 2036 if (!SvUOK(left)) {
2037 const IV leftiv = SvIVX(left);
2038 if (!SvUOK(right)) {
2039 /* ## IV <=> IV ## */
2040 const IV rightiv = SvIVX(right);
2041 return (leftiv > rightiv) - (leftiv < rightiv);
28e5dec8 2042 }
33efebe6
DM		 2043 /* ## IV <=> UV ## */
2044 if (leftiv < 0)
2045 /* As (b) is a UV, it's >=0, so it must be < */
2046 return -1;
2047 {
2048 const UV rightuv = SvUVX(right);
2049 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
28e5dec8 2050 }
28e5dec8 2051 }
79072805 2052
33efebe6
DM		 2053 if (SvUOK(right)) {
2054 /* ## UV <=> UV ## */
2055 const UV leftuv = SvUVX(left);
2056 const UV rightuv = SvUVX(right);
2057 return (leftuv > rightuv) - (leftuv < rightuv);
28e5dec8 2058 }
33efebe6
DM		 2059 /* ## UV <=> IV ## */
2060 {
2061 const IV rightiv = SvIVX(right);
2062 if (rightiv < 0)
2063 /* As (a) is a UV, it's >=0, so it cannot be < */
2064 return 1;
2065 {
2066 const UV leftuv = SvUVX(left);
2067 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
28e5dec8 2068 }
28e5dec8 2069 }
e5964223 2070 NOT_REACHED; /* NOTREACHED */
28e5dec8
JH		 2071 }
2072#endif
a0d0e21e 2073 {
33efebe6
DM		 2074 NV const rnv = SvNV_nomg(right);
2075 NV const lnv = SvNV_nomg(left);
2076
cab190d4 2077#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
33efebe6
DM		 2078 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2079 return 2;
2080 }
2081 return (lnv > rnv) - (lnv < rnv);
cab190d4 2082#else
33efebe6
DM		 2083 if (lnv < rnv)
2084 return -1;
2085 if (lnv > rnv)
2086 return 1;
659c4b96 2087 if (lnv == rnv)
33efebe6
DM		 2088 return 0;
2089 return 2;
cab190d4 2090#endif
a0d0e21e 2091 }
79072805
LW		 2092}
2093
33efebe6 2094
a0d0e21e 2095PP(pp_ncmp)
79072805 2096{
20b7effb 2097 dSP;
33efebe6
DM		 2098 SV *left, *right;
2099 I32 value;
a42d0242 2100 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
33efebe6
DM		 2101 right = POPs;
2102 left = TOPs;
2103 value = do_ncmp(left, right);
2104 if (value == 2) {
3280af22 2105 SETs(&PL_sv_undef);
79072805 2106 }
33efebe6
DM		 2107 else {
2108 dTARGET;
2109 SETi(value);
2110 }
2111 RETURN;
a0d0e21e 2112}
79072805 2113
b1c05ba5
DM		 2114
2115/* also used for: pp_sge() pp_sgt() pp_slt() */
2116
afd9910b 2117PP(pp_sle)
a0d0e21e 2118{
20b7effb 2119 dSP;
79072805 2120
afd9910b
NC		 2121 int amg_type = sle_amg;
2122 int multiplier = 1;
2123 int rhs = 1;
79072805 2124
afd9910b
NC		 2125 switch (PL_op->op_type) {
2126 case OP_SLT:
2127 amg_type = slt_amg;
2128 /* cmp < 0 */
2129 rhs = 0;
2130 break;
2131 case OP_SGT:
2132 amg_type = sgt_amg;
2133 /* cmp > 0 */
2134 multiplier = -1;
2135 rhs = 0;
2136 break;
2137 case OP_SGE:
2138 amg_type = sge_amg;
2139 /* cmp >= 0 */
2140 multiplier = -1;
2141 break;
79072805 2142 }
79072805 2143
6f1401dc 2144 tryAMAGICbin_MG(amg_type, AMGf_set);
a0d0e21e
LW		 2145 {
2146 dPOPTOPssrl;
130c5df3 2147 const int cmp =
5778acb6 2148#ifdef USE_LOCALE_COLLATE
130c5df3
KW		 2149 (IN_LC_RUNTIME(LC_COLLATE))
2150 ? sv_cmp_locale_flags(left, right, 0)
2151 :
2152#endif
2153 sv_cmp_flags(left, right, 0);
afd9910b 2154 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW		 2155 RETURN;
2156 }
2157}
79072805 2158
36477c24 2159PP(pp_seq)
2160{
20b7effb 2161 dSP;
6f1401dc 2162 tryAMAGICbin_MG(seq_amg, AMGf_set);
36477c24 2163 {
2164 dPOPTOPssrl;
078504b2 2165 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW		 2166 RETURN;
2167 }
2168}
79072805 2169
a0d0e21e 2170PP(pp_sne)
79072805 2171{
20b7effb 2172 dSP;
6f1401dc 2173 tryAMAGICbin_MG(sne_amg, AMGf_set);
a0d0e21e
LW		 2174 {
2175 dPOPTOPssrl;
078504b2 2176 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2177 RETURN;
463ee0b2 2178 }
79072805
LW		 2179}
2180
a0d0e21e 2181PP(pp_scmp)
79072805 2182{
20b7effb 2183 dSP; dTARGET;
6f1401dc 2184 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW		 2185 {
2186 dPOPTOPssrl;
130c5df3 2187 const int cmp =
5778acb6 2188#ifdef USE_LOCALE_COLLATE
130c5df3
KW		 2189 (IN_LC_RUNTIME(LC_COLLATE))
2190 ? sv_cmp_locale_flags(left, right, 0)
2191 :
2192#endif
2193 sv_cmp_flags(left, right, 0);
bbce6d69 2194 SETi( cmp );
a0d0e21e
LW		 2195 RETURN;
2196 }
2197}
79072805 2198
55497cff 2199PP(pp_bit_and)
2200{
20b7effb 2201 dSP; dATARGET;
6f1401dc 2202 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW		 2203 {
2204 dPOPTOPssrl;
4633a7c4 2205 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC		 2206 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2207 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2208 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2209 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2210 SETi(i);
d0ba1bd2
JH		 2211 }
2212 else {
1b6737cc 2213 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2214 SETu(u);
d0ba1bd2 2215 }
5ee80e13 2216 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2217 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW		 2218 }
2219 else {
533c011a 2220 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2221 SETTARG;
2222 }
2223 RETURN;
2224 }
2225}
79072805 2226
b1c05ba5
DM		 2227
2228/* also used for: pp_bit_xor() */
2229
a0d0e21e
LW		 2230PP(pp_bit_or)
2231{
20b7effb 2232 dSP; dATARGET;
3658c1f1
NC		 2233 const int op_type = PL_op->op_type;
2234
6f1401dc 2235 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW		 2236 {
2237 dPOPTOPssrl;
4633a7c4 2238 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC		 2239 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2240 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2241 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC		 2242 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2243 const IV r = SvIV_nomg(right);
2244 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2245 SETi(result);
d0ba1bd2
JH		 2246 }
2247 else {
3658c1f1
NC		 2248 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2249 const UV r = SvUV_nomg(right);
2250 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2251 SETu(result);
d0ba1bd2 2252 }
5ee80e13 2253 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2254 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW		 2255 }
2256 else {
3658c1f1 2257 do_vop(op_type, TARG, left, right);
a0d0e21e
LW		 2258 SETTARG;
2259 }
2260 RETURN;
79072805 2261 }
a0d0e21e 2262}
79072805 2263
1c2b3fd6
FC		 2264PERL_STATIC_INLINE bool
2265S_negate_string(pTHX)
2266{
2267 dTARGET; dSP;
2268 STRLEN len;
2269 const char *s;
2270 SV * const sv = TOPs;
2271 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2272 return FALSE;
2273 s = SvPV_nomg_const(sv, len);
2274 if (isIDFIRST(*s)) {
2275 sv_setpvs(TARG, "-");
2276 sv_catsv(TARG, sv);
2277 }
2278 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2279 sv_setsv_nomg(TARG, sv);
2280 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2281 }
2282 else return FALSE;
245d035e 2283 SETTARG;
1c2b3fd6
FC		 2284 return TRUE;
2285}
2286
a0d0e21e
LW		 2287PP(pp_negate)
2288{
20b7effb 2289 dSP; dTARGET;
6f1401dc 2290 tryAMAGICun_MG(neg_amg, AMGf_numeric);
1c2b3fd6 2291 if (S_negate_string(aTHX)) return NORMAL;
a0d0e21e 2292 {
6f1401dc 2293 SV * const sv = TOPs;
a5b92898 2294
d96ab1b5 2295 if (SvIOK(sv)) {
7dbe3150 2296 /* It's publicly an integer */
28e5dec8 2297 oops_its_an_int:
9b0e499b
GS		 2298 if (SvIsUV(sv)) {
2299 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2300 /* 2s complement assumption. */
d14578b8
KW		 2301 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2302 IV_MIN */
245d035e 2303 return NORMAL;
9b0e499b
GS		 2304 }
2305 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2306 SETi(-SvIVX(sv));
245d035e 2307 return NORMAL;
9b0e499b
GS		 2308 }
2309 }
2310 else if (SvIVX(sv) != IV_MIN) {
2311 SETi(-SvIVX(sv));
245d035e 2312 return NORMAL;
9b0e499b 2313 }
28e5dec8
JH		 2314#ifdef PERL_PRESERVE_IVUV
2315 else {
2316 SETu((UV)IV_MIN);
245d035e 2317 return NORMAL;
28e5dec8
JH		 2318 }
2319#endif
9b0e499b 2320 }
8a5decd8 2321 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
6f1401dc 2322 SETn(-SvNV_nomg(sv));
1c2b3fd6 2323 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
8eb28a70 2324 goto oops_its_an_int;
4633a7c4 2325 else
6f1401dc 2326 SETn(-SvNV_nomg(sv));
79072805 2327 }
245d035e 2328 return NORMAL;
79072805
LW		 2329}
2330
a0d0e21e 2331PP(pp_not)
79072805 2332{
20b7effb 2333 dSP;
6f1401dc 2334 tryAMAGICun_MG(not_amg, AMGf_set);
06c841cf 2335 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
a0d0e21e 2336 return NORMAL;
79072805
LW		 2337}
2338
a0d0e21e 2339PP(pp_complement)
79072805 2340{
20b7effb 2341 dSP; dTARGET;
a42d0242 2342 tryAMAGICun_MG(compl_amg, AMGf_numeric);
a0d0e21e
LW		 2343 {
2344 dTOPss;
4633a7c4 2345 if (SvNIOKp(sv)) {
d0ba1bd2 2346 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2347 const IV i = ~SvIV_nomg(sv);
972b05a9 2348 SETi(i);
d0ba1bd2
JH		 2349 }
2350 else {
1b6737cc 2351 const UV u = ~SvUV_nomg(sv);
972b05a9 2352 SETu(u);
d0ba1bd2 2353 }
a0d0e21e
LW		 2354 }
2355 else {
eb578fdb
KW		 2356 U8 *tmps;
2357 I32 anum;
a0d0e21e
LW		 2358 STRLEN len;
2359
85b0ee6e
FC		 2360 sv_copypv_nomg(TARG, sv);
2361 tmps = (U8*)SvPV_nomg(TARG, len);
a0d0e21e 2362 anum = len;
1d68d6cd 2363 if (SvUTF8(TARG)) {
a1ca4561 2364 /* Calculate exact length, let's not estimate. */
1d68d6cd 2365 STRLEN targlen = 0;
ba210ebe 2366 STRLEN l;
a1ca4561
YST		 2367 UV nchar = 0;
2368 UV nwide = 0;
01f6e806 2369 U8 * const send = tmps + len;
74d49cd0
TS		 2370 U8 * const origtmps = tmps;
2371 const UV utf8flags = UTF8_ALLOW_ANYUV;
1d68d6cd 2372
1d68d6cd 2373 while (tmps < send) {
74d49cd0
TS		 2374 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2375 tmps += l;
5bbb0b5a 2376 targlen += UNISKIP(~c);
a1ca4561
YST		 2377 nchar++;
2378 if (c > 0xff)
2379 nwide++;
1d68d6cd
SC		 2380 }
2381
2382 /* Now rewind strings and write them. */
74d49cd0 2383 tmps = origtmps;
a1ca4561
YST		 2384
2385 if (nwide) {
01f6e806
AL		 2386 U8 *result;
2387 U8 *p;
2388
74d49cd0 2389 Newx(result, targlen + 1, U8);
01f6e806 2390 p = result;
a1ca4561 2391 while (tmps < send) {
74d49cd0
TS		 2392 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2393 tmps += l;
01f6e806 2394 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
a1ca4561 2395 }
01f6e806 2396 *p = '\0';
c1c21316
NC		 2397 sv_usepvn_flags(TARG, (char*)result, targlen,
2398 SV_HAS_TRAILING_NUL);
a1ca4561
YST		 2399 SvUTF8_on(TARG);
2400 }
2401 else {
01f6e806
AL		 2402 U8 *result;
2403 U8 *p;
2404
74d49cd0 2405 Newx(result, nchar + 1, U8);
01f6e806 2406 p = result;
a1ca4561 2407 while (tmps < send) {
74d49cd0
TS		 2408 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2409 tmps += l;
01f6e806 2410 *p++ = ~c;
a1ca4561 2411 }
01f6e806 2412 *p = '\0';
c1c21316 2413 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
d0a21e00 2414 SvUTF8_off(TARG);
1d68d6cd 2415 }
ec93b65f 2416 SETTARG;
24840750 2417 return NORMAL;
1d68d6cd 2418 }
a0d0e21e 2419#ifdef LIBERAL
51723571 2420 {
eb578fdb 2421 long *tmpl;
51723571
JH		 2422 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2423 *tmps = ~*tmps;
2424 tmpl = (long*)tmps;
bb7a0f54 2425 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH		 2426 *tmpl = ~*tmpl;
2427 tmps = (U8*)tmpl;
2428 }
a0d0e21e
LW		 2429#endif
2430 for ( ; anum > 0; anum--, tmps++)
2431 *tmps = ~*tmps;
ec93b65f 2432 SETTARG;
a0d0e21e 2433 }
24840750 2434 return NORMAL;
a0d0e21e 2435 }
79072805
LW		 2436}
2437
a0d0e21e
LW		 2438/* integer versions of some of the above */
2439
a0d0e21e 2440PP(pp_i_multiply)
79072805 2441{
20b7effb 2442 dSP; dATARGET;
6f1401dc 2443 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2444 {
6f1401dc 2445 dPOPTOPiirl_nomg;
a0d0e21e
LW		 2446 SETi( left * right );
2447 RETURN;
2448 }
79072805
LW		 2449}
2450
a0d0e21e 2451PP(pp_i_divide)
79072805 2452{
85935d8e 2453 IV num;
20b7effb 2454 dSP; dATARGET;
6f1401dc 2455 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2456 {
6f1401dc 2457 dPOPTOPssrl;
85935d8e 2458 IV value = SvIV_nomg(right);
a0d0e21e 2459 if (value == 0)
ece1bcef 2460 DIE(aTHX_ "Illegal division by zero");
85935d8e 2461 num = SvIV_nomg(left);
a0cec769
YST		 2462
2463 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2464 if (value == -1)
2465 value = - num;
2466 else
2467 value = num / value;
6f1401dc 2468 SETi(value);
a0d0e21e
LW		 2469 RETURN;
2470 }
79072805
LW		 2471}
2472
bf3d06aa
JC		 2473#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2474 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
224ec323
JH		 2475STATIC
2476PP(pp_i_modulo_0)
befad5d1
NC		 2477#else
2478PP(pp_i_modulo)
2479#endif
224ec323
JH		 2480{
2481 /* This is the vanilla old i_modulo. */
20b7effb 2482 dSP; dATARGET;
6f1401dc 2483 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2484 {
6f1401dc 2485 dPOPTOPiirl_nomg;
224ec323
JH		 2486 if (!right)
2487 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST		 2488 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2489 if (right == -1)
2490 SETi( 0 );
2491 else
2492 SETi( left % right );
224ec323
JH		 2493 RETURN;
2494 }
2495}
2496
bf3d06aa
JC		 2497#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
2498 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
224ec323
JH		 2499STATIC
2500PP(pp_i_modulo_1)
befad5d1 2501
224ec323 2502{
224ec323 2503 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2504 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2505 * See below for pp_i_modulo. */
20b7effb 2506 dSP; dATARGET;
6f1401dc 2507 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2508 {
6f1401dc 2509 dPOPTOPiirl_nomg;
224ec323
JH		 2510 if (!right)
2511 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST		 2512 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2513 if (right == -1)
2514 SETi( 0 );
2515 else
2516 SETi( left % PERL_ABS(right) );
224ec323
JH		 2517 RETURN;
2518 }
224ec323
JH		 2519}
2520
a0d0e21e 2521PP(pp_i_modulo)
79072805 2522{
6f1401dc
DM		 2523 dVAR; dSP; dATARGET;
2524 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2525 {
6f1401dc 2526 dPOPTOPiirl_nomg;
224ec323
JH		 2527 if (!right)
2528 DIE(aTHX_ "Illegal modulus zero");
2529 /* The assumption is to use hereafter the old vanilla version... */
2530 PL_op->op_ppaddr =
2531 PL_ppaddr[OP_I_MODULO] =
1c127fab 2532 Perl_pp_i_modulo_0;
224ec323 2533 /* .. but if we have glibc, we might have a buggy _moddi3
bf3d06aa 2534 * (at least glibc 2.2.5 is known to have this bug), in other
224ec323
JH		 2535 * words our integer modulus with negative quad as the second
2536 * argument might be broken. Test for this and re-patch the
2537 * opcode dispatch table if that is the case, remembering to
2538 * also apply the workaround so that this first round works
2539 * right, too. See [perl #9402] for more information. */
224ec323
JH		 2540 {
2541 IV l = 3;
2542 IV r = -10;
2543 /* Cannot do this check with inlined IV constants since
2544 * that seems to work correctly even with the buggy glibc. */
2545 if (l % r == -3) {
2546 /* Yikes, we have the bug.
2547 * Patch in the workaround version. */
2548 PL_op->op_ppaddr =
2549 PL_ppaddr[OP_I_MODULO] =
2550 &Perl_pp_i_modulo_1;
2551 /* Make certain we work right this time, too. */
32fdb065 2552 right = PERL_ABS(right);
224ec323
JH		 2553 }
2554 }
a0cec769
YST		 2555 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2556 if (right == -1)
2557 SETi( 0 );
2558 else
2559 SETi( left % right );
224ec323
JH		 2560 RETURN;
2561 }
79072805 2562}
befad5d1 2563#endif
79072805 2564
a0d0e21e 2565PP(pp_i_add)
79072805 2566{
20b7effb 2567 dSP; dATARGET;
6f1401dc 2568 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2569 {
6f1401dc 2570 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW		 2571 SETi( left + right );
2572 RETURN;
79072805 2573 }
79072805
LW		 2574}
2575
a0d0e21e 2576PP(pp_i_subtract)
79072805 2577{
20b7effb 2578 dSP; dATARGET;
6f1401dc 2579 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2580 {
6f1401dc 2581 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW		 2582 SETi( left - right );
2583 RETURN;
79072805 2584 }
79072805
LW		 2585}
2586
a0d0e21e 2587PP(pp_i_lt)
79072805 2588{
20b7effb 2589 dSP;
6f1401dc 2590 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2591 {
96b6b87f 2592 dPOPTOPiirl_nomg;
54310121 2593 SETs(boolSV(left < right));
a0d0e21e
LW		 2594 RETURN;
2595 }
79072805
LW		 2596}
2597
a0d0e21e 2598PP(pp_i_gt)
79072805 2599{
20b7effb 2600 dSP;
6f1401dc 2601 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2602 {
96b6b87f 2603 dPOPTOPiirl_nomg;
54310121 2604 SETs(boolSV(left > right));
a0d0e21e
LW		 2605 RETURN;
2606 }
79072805
LW		 2607}
2608
a0d0e21e 2609PP(pp_i_le)
79072805 2610{
20b7effb 2611 dSP;
6f1401dc 2612 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 2613 {
96b6b87f 2614 dPOPTOPiirl_nomg;
54310121 2615 SETs(boolSV(left <= right));
a0d0e21e 2616 RETURN;
85e6fe83 2617 }
79072805
LW		 2618}
2619
a0d0e21e 2620PP(pp_i_ge)
79072805 2621{
20b7effb 2622 dSP;
6f1401dc 2623 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 2624 {
96b6b87f 2625 dPOPTOPiirl_nomg;
54310121 2626 SETs(boolSV(left >= right));
a0d0e21e
LW		 2627 RETURN;
2628 }
79072805
LW		 2629}
2630
a0d0e21e 2631PP(pp_i_eq)
79072805 2632{
20b7effb 2633 dSP;
6f1401dc 2634 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 2635 {
96b6b87f 2636 dPOPTOPiirl_nomg;
54310121 2637 SETs(boolSV(left == right));
a0d0e21e
LW		 2638 RETURN;
2639 }
79072805
LW		 2640}
2641
a0d0e21e 2642PP(pp_i_ne)
79072805 2643{
20b7effb 2644 dSP;
6f1401dc 2645 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 2646 {
96b6b87f 2647 dPOPTOPiirl_nomg;
54310121 2648 SETs(boolSV(left != right));
a0d0e21e
LW		 2649 RETURN;
2650 }
79072805
LW		 2651}
2652
a0d0e21e 2653PP(pp_i_ncmp)
79072805 2654{
20b7effb 2655 dSP; dTARGET;
6f1401dc 2656 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2657 {
96b6b87f 2658 dPOPTOPiirl_nomg;
a0d0e21e 2659 I32 value;
79072805 2660
a0d0e21e 2661 if (left > right)
79072805 2662 value = 1;
a0d0e21e 2663 else if (left < right)
79072805 2664 value = -1;
a0d0e21e 2665 else
79072805 2666 value = 0;
a0d0e21e
LW		 2667 SETi(value);
2668 RETURN;
79072805 2669 }
85e6fe83
LW		 2670}
2671
2672PP(pp_i_negate)
2673{
20b7effb 2674 dSP; dTARGET;
6f1401dc 2675 tryAMAGICun_MG(neg_amg, 0);
1c2b3fd6 2676 if (S_negate_string(aTHX)) return NORMAL;
6f1401dc
DM		 2677 {
2678 SV * const sv = TOPs;
2679 IV const i = SvIV_nomg(sv);
2680 SETi(-i);
ae642386 2681 return NORMAL;
6f1401dc 2682 }
85e6fe83
LW		 2683}
2684
79072805
LW		 2685/* High falutin' math. */
2686
2687PP(pp_atan2)
2688{
20b7effb 2689 dSP; dTARGET;
6f1401dc 2690 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2691 {
096c060c 2692 dPOPTOPnnrl_nomg;
a1021d57 2693 SETn(Perl_atan2(left, right));
a0d0e21e
LW		 2694 RETURN;
2695 }
79072805
LW		 2696}
2697
b1c05ba5
DM		 2698
2699/* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2700
79072805
LW		 2701PP(pp_sin)
2702{
20b7effb 2703 dSP; dTARGET;
af71714e 2704 int amg_type = fallback_amg;
71302fe3 2705 const char *neg_report = NULL;
71302fe3
NC		 2706 const int op_type = PL_op->op_type;
2707
2708 switch (op_type) {
af71714e
JH		 2709 case OP_SIN: amg_type = sin_amg; break;
2710 case OP_COS: amg_type = cos_amg; break;
2711 case OP_EXP: amg_type = exp_amg; break;
2712 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2713 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
a0d0e21e 2714 }
79072805 2715
af71714e 2716 assert(amg_type != fallback_amg);
6f1401dc
DM		 2717
2718 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 2719 {
8c78ed36 2720 SV * const arg = TOPs;
6f1401dc 2721 const NV value = SvNV_nomg(arg);
f256868e 2722 NV result = NV_NAN;
af71714e 2723 if (neg_report) { /* log or sqrt */
a3463d96
DD		 2724 if (
2725#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2726 ! Perl_isnan(value) &&
2727#endif
2728 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
71302fe3 2729 SET_NUMERIC_STANDARD();
dcbac5bb 2730 /* diag_listed_as: Can't take log of %g */
71302fe3
NC		 2731 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2732 }
2733 }
af71714e 2734 switch (op_type) {
f256868e 2735 default:
af71714e
JH		 2736 case OP_SIN: result = Perl_sin(value); break;
2737 case OP_COS: result = Perl_cos(value); break;
2738 case OP_EXP: result = Perl_exp(value); break;
2739 case OP_LOG: result = Perl_log(value); break;
2740 case OP_SQRT: result = Perl_sqrt(value); break;
2741 }
8c78ed36
FC		 2742 SETn(result);
2743 return NORMAL;
a0d0e21e 2744 }
79072805
LW		 2745}
2746
56cb0a1c
AD		 2747/* Support Configure command-line overrides for rand() functions.
2748 After 5.005, perhaps we should replace this by Configure support
2749 for drand48(), random(), or rand(). For 5.005, though, maintain
2750 compatibility by calling rand() but allow the user to override it.
2751 See INSTALL for details. --Andy Dougherty 15 July 1998
2752*/
85ab1d1d
JH		 2753/* Now it's after 5.005, and Configure supports drand48() and random(),
2754 in addition to rand(). So the overrides should not be needed any more.
2755 --Jarkko Hietaniemi 27 September 1998
2756 */
2757
79072805
LW		 2758PP(pp_rand)
2759{
80252599 2760 if (!PL_srand_called) {
85ab1d1d 2761 (void)seedDrand01((Rand_seed_t)seed());
80252599 2762 PL_srand_called = TRUE;
93dc8474 2763 }
fdf4dddd
DD		 2764 {
2765 dSP;
2766 NV value;
fdf4dddd
DD		 2767
2768 if (MAXARG < 1)
7e9044f9
FC		 2769 {
2770 EXTEND(SP, 1);
fdf4dddd 2771 value = 1.0;
7e9044f9 2772 }
fdf4dddd
DD		 2773 else {
2774 SV * const sv = POPs;
2775 if(!sv)
2776 value = 1.0;
2777 else
2778 value = SvNV(sv);
2779 }
2780 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
a3463d96
DD		 2781#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2782 if (! Perl_isnan(value) && value == 0.0)
2783#else
659c4b96 2784 if (value == 0.0)
a3463d96 2785#endif
fdf4dddd
DD		 2786 value = 1.0;
2787 {
2788 dTARGET;
2789 PUSHs(TARG);
2790 PUTBACK;
2791 value *= Drand01();
2792 sv_setnv_mg(TARG, value);
2793 }
2794 }
2795 return NORMAL;
79072805
LW		 2796}
2797
2798PP(pp_srand)
2799{
20b7effb 2800 dSP; dTARGET;
f914a682
JL		 2801 UV anum;
2802
0a5f3363 2803 if (MAXARG >= 1 && (TOPs || POPs)) {
f914a682
JL		 2804 SV *top;
2805 char *pv;
2806 STRLEN len;
2807 int flags;
2808
2809 top = POPs;
2810 pv = SvPV(top, len);
2811 flags = grok_number(pv, len, &anum);
2812
2813 if (!(flags & IS_NUMBER_IN_UV)) {
2814 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2815 "Integer overflow in srand");
2816 anum = UV_MAX;
2817 }
2818 }
2819 else {
2820 anum = seed();
2821 }
2822
85ab1d1d 2823 (void)seedDrand01((Rand_seed_t)anum);
80252599 2824 PL_srand_called = TRUE;
da1010ec
NC		 2825 if (anum)
2826 XPUSHu(anum);
2827 else {
2828 /* Historically srand always returned true. We can avoid breaking
2829 that like this: */
2830 sv_setpvs(TARG, "0 but true");
2831 XPUSHTARG;
2832 }
83832992 2833 RETURN;
79072805
LW		 2834}
2835
79072805
LW		 2836PP(pp_int)
2837{
20b7effb 2838 dSP; dTARGET;
6f1401dc 2839 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 2840 {
6f1401dc
DM		 2841 SV * const sv = TOPs;
2842 const IV iv = SvIV_nomg(sv);
28e5dec8
JH		 2843 /* XXX it's arguable that compiler casting to IV might be subtly
2844 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2845 else preferring IV has introduced a subtle behaviour change bug. OTOH
2846 relying on floating point to be accurate is a bug. */
2847
c781a409 2848 if (!SvOK(sv)) {
922c4365 2849 SETu(0);
c781a409
RD		 2850 }
2851 else if (SvIOK(sv)) {
2852 if (SvIsUV(sv))
6f1401dc 2853 SETu(SvUV_nomg(sv));
c781a409 2854 else
28e5dec8 2855 SETi(iv);
c781a409 2856 }
c781a409 2857 else {
6f1401dc 2858 const NV value = SvNV_nomg(sv);
b9d05018
FC		 2859 if (UNLIKELY(Perl_isinfnan(value)))
2860 SETn(value);
5bf8b78e 2861 else if (value >= 0.0) {
28e5dec8
JH		 2862 if (value < (NV)UV_MAX + 0.5) {
2863 SETu(U_V(value));
2864 } else {
059a1014 2865 SETn(Perl_floor(value));
28e5dec8 2866 }
1048ea30 2867 }
28e5dec8
JH		 2868 else {
2869 if (value > (NV)IV_MIN - 0.5) {
2870 SETi(I_V(value));
2871 } else {
1bbae031 2872 SETn(Perl_ceil(value));
28e5dec8
JH		 2873 }
2874 }
774d564b 2875 }
79072805 2876 }
699e9491 2877 return NORMAL;
79072805
LW		 2878}
2879
463ee0b2
LW		 2880PP(pp_abs)
2881{
20b7effb 2882 dSP; dTARGET;
6f1401dc 2883 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 2884 {
6f1401dc 2885 SV * const sv = TOPs;
28e5dec8 2886 /* This will cache the NV value if string isn't actually integer */
6f1401dc 2887 const IV iv = SvIV_nomg(sv);
a227d84d 2888
800401ee 2889 if (!SvOK(sv)) {
922c4365 2890 SETu(0);
800401ee
JH		 2891 }
2892 else if (SvIOK(sv)) {
28e5dec8 2893 /* IVX is precise */
800401ee 2894 if (SvIsUV(sv)) {
6f1401dc 2895 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH		 2896 } else {
2897 if (iv >= 0) {
2898 SETi(iv);
2899 } else {
2900 if (iv != IV_MIN) {
2901 SETi(-iv);
2902 } else {
2903 /* 2s complement assumption. Also, not really needed as
2904 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2905 SETu(IV_MIN);
2906 }
a227d84d 2907 }
28e5dec8
JH		 2908 }
2909 } else{
6f1401dc 2910 const NV value = SvNV_nomg(sv);
774d564b 2911 if (value < 0.0)
1b6737cc 2912 SETn(-value);
a4474c9e
DD		 2913 else
2914 SETn(value);
774d564b 2915 }
a0d0e21e 2916 }
067b7929 2917 return NORMAL;
463ee0b2
LW		 2918}
2919
b1c05ba5
DM		 2920
2921/* also used for: pp_hex() */
2922
79072805
LW		 2923PP(pp_oct)
2924{
20b7effb 2925 dSP; dTARGET;
5c144d81 2926 const char *tmps;
53305cf1 2927 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2928 STRLEN len;
53305cf1
NC		 2929 NV result_nv;
2930 UV result_uv;
4e51bcca 2931 SV* const sv = TOPs;
79072805 2932
349d4f2f 2933 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS		 2934 if (DO_UTF8(sv)) {
2935 /* If Unicode, try to downgrade
2936 * If not possible, croak. */
1b6737cc 2937 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS		 2938
2939 SvUTF8_on(tsv);
2940 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2941 tmps = SvPV_const(tsv, len);
2bc69dc4 2942 }
daa2adfd
NC		 2943 if (PL_op->op_type == OP_HEX)
2944 goto hex;
2945
6f894ead 2946 while (*tmps && len && isSPACE(*tmps))
53305cf1 2947 tmps++, len--;
9e24b6e2 2948 if (*tmps == '0')
53305cf1 2949 tmps++, len--;
305b8651 2950 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
daa2adfd 2951 hex:
53305cf1 2952 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 2953 }
305b8651 2954 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
53305cf1 2955 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2956 else
53305cf1
NC		 2957 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2958
2959 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
4e51bcca 2960 SETn(result_nv);
53305cf1
NC		 2961 }
2962 else {
4e51bcca 2963 SETu(result_uv);
53305cf1 2964 }
4e51bcca 2965 return NORMAL;
79072805
LW		 2966}
2967
2968/* String stuff. */
2969
2970PP(pp_length)
2971{
20b7effb 2972 dSP; dTARGET;
0bd48802 2973 SV * const sv = TOPs;
a0ed51b3 2974
7776003e
DD		 2975 U32 in_bytes = IN_BYTES;
2976 /* simplest case shortcut */
2977 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
2978 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
6d59e610 2979 STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
7776003e
DD		 2980 SETs(TARG);
2981
2982 if(LIKELY(svflags == SVf_POK))
2983 goto simple_pv;
2984 if(svflags & SVs_GMG)
2985 mg_get(sv);
0f43fd57 2986 if (SvOK(sv)) {
7776003e
DD		 2987 if (!IN_BYTES) /* reread to avoid using an C auto/register */
2988 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
9f621bb0 2989 else
0f43fd57
FC		 2990 {
2991 STRLEN len;
7776003e
DD		 2992 /* unrolled SvPV_nomg_const(sv,len) */
2993 if(SvPOK_nog(sv)){
2994 simple_pv:
2995 len = SvCUR(sv);
2996 } else {
2997 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
2998 }
2999 sv_setiv(TARG, (IV)(len));
0f43fd57 3000 }
656266fc 3001 } else {
9407f9c1
DL		 3002 if (!SvPADTMP(TARG)) {
3003 sv_setsv_nomg(TARG, &PL_sv_undef);
7776003e
DD		 3004 } else { /* TARG is on stack at this point and is overwriten by SETs.
3005 This branch is the odd one out, so put TARG by default on
3006 stack earlier to let local SP go out of liveness sooner */
3007 SETs(&PL_sv_undef);
3008 goto no_set_magic;
3009 }
92331800 3010 }
7776003e
DD		 3011 SvSETMAGIC(TARG);
3012 no_set_magic:
3013 return NORMAL; /* no putback, SP didn't move in this opcode */
79072805
LW		 3014}
3015
83f78d1a
FC		 3016/* Returns false if substring is completely outside original string.
3017 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3018 always be true for an explicit 0.
3019*/
3020bool
ddeaf645
DD		 3021Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3022 bool pos1_is_uv, IV len_iv,
3023 bool len_is_uv, STRLEN *posp,
3024 STRLEN *lenp)
83f78d1a
FC		 3025{
3026 IV pos2_iv;
3027 int pos2_is_uv;
3028
3029 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3030
3031 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3032 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3033 pos1_iv += curlen;
3034 }
3035 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3036 return FALSE;
3037
3038 if (len_iv || len_is_uv) {
3039 if (!len_is_uv && len_iv < 0) {
3040 pos2_iv = curlen + len_iv;
3041 if (curlen)
3042 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3043 else
3044 pos2_is_uv = 0;
3045 } else { /* len_iv >= 0 */
3046 if (!pos1_is_uv && pos1_iv < 0) {
3047 pos2_iv = pos1_iv + len_iv;
3048 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3049 } else {
3050 if ((UV)len_iv > curlen-(UV)pos1_iv)
3051 pos2_iv = curlen;
3052 else
3053 pos2_iv = pos1_iv+len_iv;
3054 pos2_is_uv = 1;
3055 }
3056 }
3057 }
3058 else {
3059 pos2_iv = curlen;
3060 pos2_is_uv = 1;
3061 }
3062
3063 if (!pos2_is_uv && pos2_iv < 0) {
3064 if (!pos1_is_uv && pos1_iv < 0)
3065 return FALSE;
3066 pos2_iv = 0;
3067 }
3068 else if (!pos1_is_uv && pos1_iv < 0)
3069 pos1_iv = 0;
3070
3071 if ((UV)pos2_iv < (UV)pos1_iv)
3072 pos2_iv = pos1_iv;
3073 if ((UV)pos2_iv > curlen)
3074 pos2_iv = curlen;
3075
3076 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3077 *posp = (STRLEN)( (UV)pos1_iv );
3078 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3079
3080 return TRUE;
3081}
3082
79072805
LW		 3083PP(pp_substr)
3084{
20b7effb 3085 dSP; dTARGET;
79072805 3086 SV *sv;
463ee0b2 3087 STRLEN curlen;
9402d6ed 3088 STRLEN utf8_curlen;
777f7c56
EB		 3089 SV * pos_sv;
3090 IV pos1_iv;
3091 int pos1_is_uv;
777f7c56
EB		 3092 SV * len_sv;
3093 IV len_iv = 0;
83f78d1a 3094 int len_is_uv = 0;
24fcb59f 3095 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 3096 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 3097 const char *tmps;
9402d6ed 3098 SV *repl_sv = NULL;
cbbf8932 3099 const char *repl = NULL;
7b8d334a 3100 STRLEN repl_len;
7bc95ae1 3101 int num_args = PL_op->op_private & 7;
13e30c65 3102 bool repl_need_utf8_upgrade = FALSE;
79072805 3103
78f9721b
SM		 3104 if (num_args > 2) {
3105 if (num_args > 3) {
24fcb59f 3106 if(!(repl_sv = POPs)) num_args--;
7bc95ae1
FC		 3107 }
3108 if ((len_sv = POPs)) {
3109 len_iv = SvIV(len_sv);
83f78d1a 3110 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
7b8d334a 3111 }
7bc95ae1 3112 else num_args--;
5d82c453 3113 }
777f7c56
EB		 3114 pos_sv = POPs;
3115 pos1_iv = SvIV(pos_sv);
3116 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3117 sv = POPs;
24fcb59f
FC		 3118 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3119 assert(!repl_sv);
3120 repl_sv = POPs;
3121 }
6582db62 3122 if (lvalue && !repl_sv) {
83f78d1a
FC		 3123 SV * ret;
3124 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3125 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3126 LvTYPE(ret) = 'x';
3127 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3128 LvTARGOFF(ret) =
3129 pos1_is_uv || pos1_iv >= 0
3130 ? (STRLEN)(UV)pos1_iv
3131 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3132 LvTARGLEN(ret) =
3133 len_is_uv || len_iv > 0
3134 ? (STRLEN)(UV)len_iv
3135 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3136
83f78d1a
FC		 3137 PUSHs(ret); /* avoid SvSETMAGIC here */
3138 RETURN;
a74fb2cd 3139 }
6582db62
FC		 3140 if (repl_sv) {
3141 repl = SvPV_const(repl_sv, repl_len);
3142 SvGETMAGIC(sv);
3143 if (SvROK(sv))
3144 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3145 "Attempt to use reference as lvalue in substr"
3146 );
3147 tmps = SvPV_force_nomg(sv, curlen);
3148 if (DO_UTF8(repl_sv) && repl_len) {
3149 if (!DO_UTF8(sv)) {
01680ee9 3150 sv_utf8_upgrade_nomg(sv);
6582db62
FC		 3151 curlen = SvCUR(sv);
3152 }
3153 }
3154 else if (DO_UTF8(sv))
3155 repl_need_utf8_upgrade = TRUE;
3156 }
3157 else tmps = SvPV_const(sv, curlen);
7e2040f0 3158 if (DO_UTF8(sv)) {
0d788f38 3159 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
9402d6ed
JH		 3160 if (utf8_curlen == curlen)
3161 utf8_curlen = 0;
a0ed51b3 3162 else
9402d6ed 3163 curlen = utf8_curlen;
a0ed51b3 3164 }
d1c2b58a 3165 else
9402d6ed 3166 utf8_curlen = 0;
a0ed51b3 3167
83f78d1a
FC		 3168 {
3169 STRLEN pos, len, byte_len, byte_pos;
777f7c56 3170
83f78d1a
FC		 3171 if (!translate_substr_offsets(
3172 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3173 )) goto bound_fail;
777f7c56 3174
83f78d1a
FC		 3175 byte_len = len;
3176 byte_pos = utf8_curlen
0d788f38 3177 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
d931b1be 3178
2154eca7 3179 tmps += byte_pos;
bbddc9e0
CS		 3180
3181 if (rvalue) {
3182 SvTAINTED_off(TARG); /* decontaminate */
3183 SvUTF8_off(TARG); /* decontaminate */
3184 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3185#ifdef USE_LOCALE_COLLATE
bbddc9e0 3186 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3187#endif
bbddc9e0
CS		 3188 if (utf8_curlen)
3189 SvUTF8_on(TARG);
3190 }
2154eca7 3191
f7928d6c 3192 if (repl) {
13e30c65
JH		 3193 SV* repl_sv_copy = NULL;
3194
3195 if (repl_need_utf8_upgrade) {
3196 repl_sv_copy = newSVsv(repl_sv);
3197 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3198 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65 3199 }
502d9230
VP		 3200 if (!SvOK(sv))
3201 sv_setpvs(sv, "");
777f7c56 3202 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
ef8d46e8 3203 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3204 }
79072805 3205 }
6a9665b0
FC		 3206 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3207 SP++;
3208 else if (rvalue) {
bbddc9e0
CS		 3209 SvSETMAGIC(TARG);
3210 PUSHs(TARG);
3211 }
79072805 3212 RETURN;
777f7c56 3213
1c900557 3214bound_fail:
83f78d1a 3215 if (repl)
777f7c56
EB		 3216 Perl_croak(aTHX_ "substr outside of string");
3217 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3218 RETPUSHUNDEF;
79072805
LW		 3219}
3220
3221PP(pp_vec)
3222{
20b7effb 3223 dSP;
eb578fdb
KW		 3224 const IV size = POPi;
3225 const IV offset = POPi;
3226 SV * const src = POPs;
1b6737cc 3227 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3228 SV * ret;
a0d0e21e 3229
81e118e0 3230 if (lvalue) { /* it's an lvalue! */
2154eca7
EB		 3231 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3232 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3233 LvTYPE(ret) = 'v';
3234 LvTARG(ret) = SvREFCNT_inc_simple(src);
3235 LvTARGOFF(ret) = offset;
3236 LvTARGLEN(ret) = size;
3237 }
3238 else {
3239 dTARGET;
3240 SvTAINTED_off(TARG); /* decontaminate */
3241 ret = TARG;
79072805
LW		 3242 }
3243
2154eca7 3244 sv_setuv(ret, do_vecget(src, offset, size));
f9e95907
FC		 3245 if (!lvalue)
3246 SvSETMAGIC(ret);
2154eca7 3247 PUSHs(ret);
79072805
LW		 3248 RETURN;
3249}
3250
b1c05ba5
DM		 3251
3252/* also used for: pp_rindex() */
3253
79072805
LW		 3254PP(pp_index)
3255{
20b7effb 3256 dSP; dTARGET;
79072805
LW		 3257 SV *big;
3258 SV *little;
c445ea15 3259 SV *temp = NULL;
ad66a58c 3260 STRLEN biglen;
2723d216 3261 STRLEN llen = 0;
b464e2b7
TC		 3262 SSize_t offset = 0;
3263 SSize_t retval;
73ee8be2
NC		 3264 const char *big_p;
3265 const char *little_p;
2f040f7f
NC		 3266 bool big_utf8;
3267 bool little_utf8;
2723d216 3268 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3269 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3270
e1dccc0d
Z		 3271 if (threeargs)
3272 offset = POPi;
79072805
LW		 3273 little = POPs;
3274 big = POPs;
73ee8be2
NC		 3275 big_p = SvPV_const(big, biglen);
3276 little_p = SvPV_const(little, llen);
3277
e609e586
NC		 3278 big_utf8 = DO_UTF8(big);
3279 little_utf8 = DO_UTF8(little);
3280 if (big_utf8 ^ little_utf8) {
3281 /* One needs to be upgraded. */
47e13f24 3282 if (little_utf8 && !IN_ENCODING) {
2f040f7f
NC		 3283 /* Well, maybe instead we might be able to downgrade the small
3284 string? */
1eced8f8 3285 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC		 3286 &little_utf8);
3287 if (little_utf8) {
3288 /* If the large string is ISO-8859-1, and it's not possible to
3289 convert the small string to ISO-8859-1, then there is no
3290 way that it could be found anywhere by index. */
3291 retval = -1;
3292 goto fail;
3293 }
e609e586 3294
2f040f7f
NC		 3295 /* At this point, pv is a malloc()ed string. So donate it to temp
3296 to ensure it will get free()d */
3297 little = temp = newSV(0);
73ee8be2
NC		 3298 sv_usepvn(temp, pv, llen);
3299 little_p = SvPVX(little);
e609e586 3300 } else {
73ee8be2
NC		 3301 temp = little_utf8
3302 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f 3303
47e13f24 3304 if (IN_ENCODING) {
ad2de1b2 3305 sv_recode_to_utf8(temp, _get_encoding());
2f040f7f
NC		 3306 } else {
3307 sv_utf8_upgrade(temp);
3308 }
3309 if (little_utf8) {
3310 big = temp;
3311 big_utf8 = TRUE;
73ee8be2 3312 big_p = SvPV_const(big, biglen);
2f040f7f
NC		 3313 } else {
3314 little = temp;
73ee8be2 3315 little_p = SvPV_const(little, llen);
2f040f7f 3316 }
e609e586
NC		 3317 }
3318 }
73ee8be2
NC		 3319 if (SvGAMAGIC(big)) {
3320 /* Life just becomes a lot easier if I use a temporary here.
3321 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3322 will trigger magic and overloading again, as will fbm_instr()
3323 */
59cd0e26
NC		 3324 big = newSVpvn_flags(big_p, biglen,
3325 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC		 3326 big_p = SvPVX(big);
3327 }
e4e44778 3328 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC		 3329 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3330 warn on undef, and we've already triggered a warning with the
3331 SvPV_const some lines above. We can't remove that, as we need to
3332 call some SvPV to trigger overloading early and find out if the
3333 string is UTF-8.
3334 This is all getting to messy. The API isn't quite clean enough,
3335 because data access has side effects.
3336 */
59cd0e26
NC		 3337 little = newSVpvn_flags(little_p, llen,
3338 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC		 3339 little_p = SvPVX(little);
3340 }
e609e586 3341
d3e26383 3342 if (!threeargs)
2723d216 3343 offset = is_index ? 0 : biglen;
a0ed51b3 3344 else {
ad66a58c 3345 if (big_utf8 && offset > 0)
b464e2b7 3346 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
73ee8be2
NC		 3347 if (!is_index)
3348 offset += llen;
a0ed51b3 3349 }
79072805
LW		 3350 if (offset < 0)
3351 offset = 0;
b464e2b7 3352 else if (offset > (SSize_t)biglen)
ad66a58c 3353 offset = biglen;
73ee8be2
NC		 3354 if (!(little_p = is_index
3355 ? fbm_instr((unsigned char*)big_p + offset,
3356 (unsigned char*)big_p + biglen, little, 0)
3357 : rninstr(big_p, big_p + offset,
3358 little_p, little_p + llen)))
a0ed51b3 3359 retval = -1;
ad66a58c 3360 else {
73ee8be2 3361 retval = little_p - big_p;
15c41403 3362 if (retval > 1 && big_utf8)
b464e2b7 3363 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
ad66a58c 3364 }
ef8d46e8 3365 SvREFCNT_dec(temp);
2723d216 3366 fail:
e1dccc0d 3367 PUSHi(retval);
79072805
LW		 3368 RETURN;
3369}
3370
3371PP(pp_sprintf)
3372{
20b7effb 3373 dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3374 SvTAINTED_off(TARG);
79072805 3375 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3376 TAINT_IF(SvTAINTED(TARG));
79072805
LW		 3377 SP = ORIGMARK;
3378 PUSHTARG;
3379 RETURN;
3380}
3381
79072805
LW		 3382PP(pp_ord)
3383{
20b7effb 3384 dSP; dTARGET;
1eced8f8 3385
6ba92227 3386 SV *argsv = TOPs;
ba210ebe 3387 STRLEN len;
349d4f2f 3388 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3389
47e13f24 3390 if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3391 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
ad2de1b2 3392 s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding());
4f6386b6 3393 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
121910a4
JH		 3394 argsv = tmpsv;
3395 }
79072805 3396
6ba92227 3397 SETu(DO_UTF8(argsv)
4f6386b6 3398 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
f3943cf2 3399 : (UV)(*s));
68795e93 3400
6ba92227 3401 return NORMAL;
79072805
LW		 3402}
3403
463ee0b2
LW		 3404PP(pp_chr)
3405{
20b7effb 3406 dSP; dTARGET;
463ee0b2 3407 char *tmps;
8a064bd6 3408 UV value;
d3261b99 3409 SV *top = TOPs;
8a064bd6 3410
71739502 3411 SvGETMAGIC(top);
9911fc4e
FC		 3412 if (UNLIKELY(SvAMAGIC(top)))
3413 top = sv_2num(top);
99f450cc 3414 if (UNLIKELY(isinfnansv(top)))
0c7df902 3415 Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
1cd88304
JH		 3416 else {
3417 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3418 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3419 ||
3420 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3421 && SvNV_nomg(top) < 0.0))) {
b3fe8680
FC		 3422 if (ckWARN(WARN_UTF8)) {
3423 if (SvGMAGICAL(top)) {
3424 SV *top2 = sv_newmortal();
3425 sv_setsv_nomg(top2, top);
3426 top = top2;
3427 }
1cd88304
JH		 3428 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3429 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3430 }
3431 value = UNICODE_REPLACEMENT;
3432 } else {
3433 value = SvUV_nomg(top);
3434 }
8a064bd6 3435 }
463ee0b2 3436
862a34c6 3437 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3438
0064a8a9 3439 if (value > 255 && !IN_BYTES) {
eb160463 3440 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3441 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3442 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW		 3443 *tmps = '\0';
3444 (void)SvPOK_only(TARG);
aa6ffa16 3445 SvUTF8_on(TARG);
d3261b99
FC		 3446 SETTARG;
3447 return NORMAL;
a0ed51b3
LW		 3448 }
3449
748a9306 3450 SvGROW(TARG,2);
463ee0b2
LW		 3451 SvCUR_set(TARG, 1);
3452 tmps = SvPVX(TARG);
eb160463 3453 *tmps++ = (char)value;
748a9306 3454 *tmps = '\0';
a0d0e21e 3455 (void)SvPOK_only(TARG);
4c5ed6e2 3456
47e13f24 3457 if (IN_ENCODING && !IN_BYTES) {
ad2de1b2 3458 sv_recode_to_utf8(TARG, _get_encoding());
88632417 3459 tmps = SvPVX(TARG);
28936164
KW		 3460 if (SvCUR(TARG) == 0
3461 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3462 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3463 {
4c5ed6e2 3464 SvGROW(TARG, 2);
d5a15ac2 3465 tmps = SvPVX(TARG);
4c5ed6e2
TS		 3466 SvCUR_set(TARG, 1);
3467 *tmps++ = (char)value;
88632417 3468 *tmps = '\0';
4c5ed6e2 3469 SvUTF8_off(TARG);
88632417
JH		 3470 }
3471 }
4c5ed6e2 3472
d3261b99
FC		 3473 SETTARG;
3474 return NORMAL;
463ee0b2
LW		 3475}
3476
79072805
LW		 3477PP(pp_crypt)
3478{
79072805 3479#ifdef HAS_CRYPT
20b7effb 3480 dSP; dTARGET;
5f74f29c 3481 dPOPTOPssrl;
85c16d83 3482 STRLEN len;
10516c54 3483 const char *tmps = SvPV_const(left, len);
2bc69dc4 3484
85c16d83 3485 if (DO_UTF8(left)) {
2bc69dc4 3486 /* If Unicode, try to downgrade.
f2791508
JH		 3487 * If not possible, croak.
3488 * Yes, we made this up. */
659fbb76 3489 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
2bc69dc4 3490
2bc69dc4 3491 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3492 tmps = SvPV_const(tsv, len);
85c16d83 3493 }
05404ffe
JH		 3494# ifdef USE_ITHREADS
3495# ifdef HAS_CRYPT_R
3496 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3497 /* This should be threadsafe because in ithreads there is only
3498 * one thread per interpreter. If this would not be true,
3499 * we would need a mutex to protect this malloc. */
3500 PL_reentrant_buffer->_crypt_struct_buffer =
3501 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3502#if defined(__GLIBC__) || defined(__EMX__)
3503 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3504 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3505 /* work around glibc-2.2.5 bug */
3506 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3507 }
05404ffe 3508#endif
6ab58e4d 3509 }
05404ffe
JH		 3510# endif /* HAS_CRYPT_R */
3511# endif /* USE_ITHREADS */
5f74f29c 3512# ifdef FCRYPT
83003860 3513 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3514# else
83003860 3515 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3516# endif
fbc76eb3 3517 SvUTF8_off(TARG);
ec93b65f 3518 SETTARG;
4808266b 3519 RETURN;
79072805 3520#else
b13b2135 3521 DIE(aTHX_
79072805
LW		 3522 "The crypt() function is unimplemented due to excessive paranoia.");
3523#endif
79072805
LW		 3524}
3525
00f254e2
KW		 3526/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3527 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3528
b1c05ba5
DM		 3529
3530/* also used for: pp_lcfirst() */
3531
79072805
LW		 3532PP(pp_ucfirst)
3533{
00f254e2
KW		 3534 /* Actually is both lcfirst() and ucfirst(). Only the first character
3535 * changes. This means that possibly we can change in-place, ie., just
3536 * take the source and change that one character and store it back, but not
3537 * if read-only etc, or if the length changes */
3538
39644a26 3539 dSP;
d54190f6 3540 SV *source = TOPs;
00f254e2 3541 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC		 3542 STRLEN need;
3543 SV *dest;
00f254e2
KW		 3544 bool inplace; /* ? Convert first char only, in-place */
3545 bool doing_utf8 = FALSE; /* ? using utf8 */
3546 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3547 const int op_type = PL_op->op_type;
d54190f6
NC		 3548 const U8 *s;
3549 U8 *d;
3550 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW		 3551 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3552 * stored as UTF-8 at s. */
3553 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3554 * lowercased) character stored in tmpbuf. May be either
3555 * UTF-8 or not, but in either case is the number of bytes */
d54190f6 3556
841a5e18 3557 s = (const U8*)SvPV_const(source, slen);
a0ed51b3 3558
00f254e2
KW		 3559 /* We may be able to get away with changing only the first character, in
3560 * place, but not if read-only, etc. Later we may discover more reasons to
3561 * not convert in-place. */
5cd5e2d6
FC		 3562 inplace = !SvREADONLY(source)
3563 && ( SvPADTMP(source)
3564 || ( SvTEMP(source) && !SvSMAGICAL(source)
3565 && SvREFCNT(source) == 1));
00f254e2
KW		 3566
3567 /* First calculate what the changed first character should be. This affects
3568 * whether we can just swap it out, leaving the rest of the string unchanged,
3569 * or even if have to convert the dest to UTF-8 when the source isn't */
3570
3571 if (! slen) { /* If empty */
3572 need = 1; /* still need a trailing NUL */
b7576bcb 3573 ulen = 0;
00f254e2
KW		 3574 }
3575 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3576 doing_utf8 = TRUE;
17e95c9d 3577 ulen = UTF8SKIP(s);
094a2f8c 3578 if (op_type == OP_UCFIRST) {
130c5df3 3579#ifdef USE_LOCALE_CTYPE
5a6bb681 3580 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3581#else
5a6bb681 3582 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
130c5df3 3583#endif
094a2f8c
KW		 3584 }
3585 else {
130c5df3 3586#ifdef USE_LOCALE_CTYPE
5a6bb681 3587 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3588#else
5a6bb681 3589 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
130c5df3 3590#endif
094a2f8c 3591 }
00f254e2 3592
17e95c9d
KW		 3593 /* we can't do in-place if the length changes. */
3594 if (ulen != tculen) inplace = FALSE;
3595 need = slen + 1 - ulen + tculen;
d54190f6 3596 }
00f254e2
KW		 3597 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3598 * latin1 is treated as caseless. Note that a locale takes
3599 * precedence */
167d19f2 3600 ulen = 1; /* Original character is 1 byte */
00f254e2
KW		 3601 tculen = 1; /* Most characters will require one byte, but this will
3602 * need to be overridden for the tricky ones */
3603 need = slen + 1;
3604
3605 if (op_type == OP_LCFIRST) {
d54190f6 3606
00f254e2 3607 /* lower case the first letter: no trickiness for any character */
130c5df3 3608#ifdef USE_LOCALE_CTYPE
780fcc9f
KW		 3609 if (IN_LC_RUNTIME(LC_CTYPE)) {
3610 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3611 *tmpbuf = toLOWER_LC(*s);
3612 }
3613 else
130c5df3 3614#endif
780fcc9f
KW		 3615 {
3616 *tmpbuf = (IN_UNI_8_BIT)
3617 ? toLOWER_LATIN1(*s)
3618 : toLOWER(*s);
3619 }
00f254e2 3620 }
130c5df3 3621#ifdef USE_LOCALE_CTYPE
780fcc9f 3622 /* is ucfirst() */
d6ded950 3623 else if (IN_LC_RUNTIME(LC_CTYPE)) {
31f05a37
KW		 3624 if (IN_UTF8_CTYPE_LOCALE) {
3625 goto do_uni_rules;
3626 }
3627
780fcc9f 3628 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
31f05a37
KW		 3629 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3630 locales have upper and title case
3631 different */
00f254e2 3632 }
130c5df3 3633#endif
00f254e2
KW		 3634 else if (! IN_UNI_8_BIT) {
3635 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3636 * on EBCDIC machines whatever the
3637 * native function does */
3638 }
31f05a37
KW		 3639 else {
3640 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3641 * UTF-8, which we treat as not in locale), and cased latin1 */
3642 UV title_ord;
91191cf7 3643#ifdef USE_LOCALE_CTYPE
31f05a37 3644 do_uni_rules:
91191cf7 3645#endif
31f05a37
KW		 3646
3647 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
167d19f2
KW		 3648 if (tculen > 1) {
3649 assert(tculen == 2);
3650
3651 /* If the result is an upper Latin1-range character, it can
3652 * still be represented in one byte, which is its ordinal */
3653 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3654 *tmpbuf = (U8) title_ord;
3655 tculen = 1;
00f254e2
KW		 3656 }
3657 else {
167d19f2
KW		 3658 /* Otherwise it became more than one ASCII character (in
3659 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3660 * beyond Latin1, so the number of bytes changed, so can't
3661 * replace just the first character in place. */
3662 inplace = FALSE;
3663
d14578b8
KW		 3664 /* If the result won't fit in a byte, the entire result
3665 * will have to be in UTF-8. Assume worst case sizing in
3666 * conversion. (all latin1 characters occupy at most two
3667 * bytes in utf8) */
167d19f2
KW		 3668 if (title_ord > 255) {
3669 doing_utf8 = TRUE;
3670 convert_source_to_utf8 = TRUE;
3671 need = slen * 2 + 1;
3672
3673 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3674 * (both) characters whose title case is above 255 is
3675 * 2. */
3676 ulen = 2;
3677 }
3678 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3679 need = slen + 1 + 1;
3680 }
00f254e2 3681 }
167d19f2 3682 }
00f254e2
KW		 3683 } /* End of use Unicode (Latin1) semantics */
3684 } /* End of changing the case of the first character */
3685
3686 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3687 * generate the result */
3688 if (inplace) {
3689
3690 /* We can convert in place. This means we change just the first
3691 * character without disturbing the rest; no need to grow */
d54190f6
NC		 3692 dest = source;
3693 s = d = (U8*)SvPV_force_nomg(source, slen);
3694 } else {
3695 dTARGET;
3696
3697 dest = TARG;
3698
00f254e2
KW		 3699 /* Here, we can't convert in place; we earlier calculated how much
3700 * space we will need, so grow to accommodate that */
d54190f6 3701 SvUPGRADE(dest, SVt_PV);
3b416f41 3702 d = (U8*)SvGROW(dest, need);
d54190f6
NC		 3703 (void)SvPOK_only(dest);
3704
3705 SETs(dest);
d54190f6 3706 }
44bc797b 3707
d54190f6 3708 if (doing_utf8) {
00f254e2
KW		 3709 if (! inplace) {
3710 if (! convert_source_to_utf8) {
3711
3712 /* Here both source and dest are in UTF-8, but have to create
3713 * the entire output. We initialize the result to be the
3714 * title/lower cased first character, and then append the rest
3715 * of the string. */
3716 sv_setpvn(dest, (char*)tmpbuf, tculen);
3717 if (slen > ulen) {
3718 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3719 }
3720 }
3721 else {
3722 const U8 *const send = s + slen;
3723
3724 /* Here the dest needs to be in UTF-8, but the source isn't,
3725 * except we earlier UTF-8'd the first character of the source
3726 * into tmpbuf. First put that into dest, and then append the
3727 * rest of the source, converting it to UTF-8 as we go. */
3728
3729 /* Assert tculen is 2 here because the only two characters that
3730 * get to this part of the code have 2-byte UTF-8 equivalents */
3731 *d++ = *tmpbuf;
3732 *d++ = *(tmpbuf + 1);
3733 s++; /* We have just processed the 1st char */
3734
3735 for (; s < send; s++) {
3736 d = uvchr_to_utf8(d, *s);
3737 }
3738 *d = '\0';
3739 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3740 }
d54190f6 3741 SvUTF8_on(dest);
a0ed51b3 3742 }
00f254e2 3743 else { /* in-place UTF-8. Just overwrite the first character */
d54190f6
NC		 3744 Copy(tmpbuf, d, tculen, U8);
3745 SvCUR_set(dest, need - 1);
a0ed51b3 3746 }
094a2f8c 3747
a0ed51b3 3748 }
00f254e2
KW		 3749 else { /* Neither source nor dest are in or need to be UTF-8 */
3750 if (slen) {
00f254e2
KW		 3751 if (inplace) { /* in-place, only need to change the 1st char */
3752 *d = *tmpbuf;
3753 }
3754 else { /* Not in-place */
3755
3756 /* Copy the case-changed character(s) from tmpbuf */
3757 Copy(tmpbuf, d, tculen, U8);
3758 d += tculen - 1; /* Code below expects d to point to final
3759 * character stored */
3760 }
3761 }
3762 else { /* empty source */
3763 /* See bug #39028: Don't taint if empty */
d54190f6
NC		 3764 *d = *s;
3765 }
3766
00f254e2
KW		 3767 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3768 * the destination to retain that flag */
93e088e8 3769 if (SvUTF8(source) && ! IN_BYTES)
d54190f6
NC		 3770 SvUTF8_on(dest);
3771
00f254e2 3772 if (!inplace) { /* Finish the rest of the string, unchanged */
d54190f6
NC		 3773 /* This will copy the trailing NUL */
3774 Copy(s + 1, d + 1, slen, U8);
3775 SvCUR_set(dest, need - 1);
bbce6d69 3776 }
bbce6d69 3777 }
130c5df3 3778#ifdef USE_LOCALE_CTYPE
d6ded950 3779 if (IN_LC_RUNTIME(LC_CTYPE)) {
445bf929
KW		 3780 TAINT;
3781 SvTAINTED_on(dest);
3782 }
130c5df3 3783#endif
539689e7
FC		 3784 if (dest != source && SvTAINTED(source))
3785 SvTAINT(dest);
d54190f6 3786 SvSETMAGIC(dest);
3cb4e04f 3787 return NORMAL;
79072805
LW		 3788}
3789
67306194
NC		 3790/* There's so much setup/teardown code common between uc and lc, I wonder if
3791 it would be worth merging the two, and just having a switch outside each
00f254e2 3792 of the three tight loops. There is less and less commonality though */
79072805
LW		 3793PP(pp_uc)
3794{
39644a26 3795 dSP;
67306194 3796 SV *source = TOPs;
463ee0b2 3797 STRLEN len;
67306194
NC		 3798 STRLEN min;
3799 SV *dest;
3800 const U8 *s;
3801 U8 *d;
79072805 3802
67306194
NC		 3803 SvGETMAGIC(source);
3804
5cd5e2d6
FC		 3805 if ((SvPADTMP(source)
3806 ||
3807 (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
3808 && !SvREADONLY(source) && SvPOK(source)
3809 && !DO_UTF8(source)
130c5df3
KW		 3810 && (
3811#ifdef USE_LOCALE_CTYPE
3812 (IN_LC_RUNTIME(LC_CTYPE))
31f05a37 3813 ? ! IN_UTF8_CTYPE_LOCALE
130c5df3
KW		 3814 :
3815#endif
3816 ! IN_UNI_8_BIT))
31f05a37
KW		 3817 {
3818
3819 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3820 * make the loop tight, so we overwrite the source with the dest before
3821 * looking at it, and we need to look at the original source
3822 * afterwards. There would also need to be code added to handle
3823 * switching to not in-place in midstream if we run into characters
3824 * that change the length. Since being in locale overrides UNI_8_BIT,
3825 * that latter becomes irrelevant in the above test; instead for
3826 * locale, the size can't normally change, except if the locale is a
3827 * UTF-8 one */
67306194
NC		 3828 dest = source;
3829 s = d = (U8*)SvPV_force_nomg(source, len);
3830 min = len + 1;
3831 } else {
a0ed51b3 3832 dTARGET;
a0ed51b3 3833
67306194 3834 dest = TARG;
128c9517 3835
841a5e18 3836 s = (const U8*)SvPV_nomg_const(source, len);
67306194
NC		 3837 min = len + 1;
3838
3839 SvUPGRADE(dest, SVt_PV);
3b416f41 3840 d = (U8*)SvGROW(dest, min);
67306194
NC		 3841 (void)SvPOK_only(dest);
3842
3843 SETs(dest);
a0ed51b3 3844 }
31351b04 3845
67306194
NC		 3846 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3847 to check DO_UTF8 again here. */
3848
3849 if (DO_UTF8(source)) {
3850 const U8 *const send = s + len;
bfac13d4 3851 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
67306194 3852
4c8a458a
KW		 3853 /* All occurrences of these are to be moved to follow any other marks.
3854 * This is context-dependent. We may not be passed enough context to
3855 * move the iota subscript beyond all of them, but we do the best we can
3856 * with what we're given. The result is always better than if we
3857 * hadn't done this. And, the problem would only arise if we are
3858 * passed a character without all its combining marks, which would be
3859 * the caller's mistake. The information this is based on comes from a
3860 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3861 * itself) and so can't be checked properly to see if it ever gets
3862 * revised. But the likelihood of it changing is remote */
00f254e2 3863 bool in_iota_subscript = FALSE;
00f254e2 3864
67306194 3865 while (s < send) {
3e16b0e6
KW		 3866 STRLEN u;
3867 STRLEN ulen;
3868 UV uv;
7dbf68d2 3869 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3e16b0e6 3870
00f254e2 3871 /* A non-mark. Time to output the iota subscript */
a78bc3c6
KW		 3872 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3873 d += capital_iota_len;
00f254e2 3874 in_iota_subscript = FALSE;
8e058693 3875 }
00f254e2 3876
8e058693
KW		 3877 /* Then handle the current character. Get the changed case value
3878 * and copy it to the output buffer */
00f254e2 3879
8e058693 3880 u = UTF8SKIP(s);
130c5df3 3881#ifdef USE_LOCALE_CTYPE
5a6bb681 3882 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3883#else
5a6bb681 3884 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
130c5df3 3885#endif
a78bc3c6
KW		 3886#define GREEK_CAPITAL_LETTER_IOTA 0x0399
3887#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
8e058693 3888 if (uv == GREEK_CAPITAL_LETTER_IOTA
4b88fb76 3889 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
8e058693
KW		 3890 {
3891 in_iota_subscript = TRUE;
3892 }
3893 else {
3894 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3895 /* If the eventually required minimum size outgrows the
3896 * available space, we need to grow. */
3897 const UV o = d - (U8*)SvPVX_const(dest);
3898
3899 /* If someone uppercases one million U+03B0s we SvGROW()
3900 * one million times. Or we could try guessing how much to
3901 * allocate without allocating too much. Such is life.
3902 * See corresponding comment in lc code for another option
3903 * */
3904 SvGROW(dest, min);
3905 d = (U8*)SvPVX(dest) + o;
3906 }
3907 Copy(tmpbuf, d, ulen, U8);
3908 d += ulen;
3909 }
3910 s += u;
67306194 3911 }
4c8a458a 3912 if (in_iota_subscript) {
a78bc3c6
KW		 3913 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3914 d += capital_iota_len;
4c8a458a 3915 }
67306194
NC		 3916 SvUTF8_on(dest);
3917 *d = '\0';
094a2f8c 3918
67306194 3919 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4c8a458a
KW		 3920 }
3921 else { /* Not UTF-8 */
67306194
NC		 3922 if (len) {
3923 const U8 *const send = s + len;
00f254e2
KW		 3924
3925 /* Use locale casing if in locale; regular style if not treating
3926 * latin1 as having case; otherwise the latin1 casing. Do the
3927 * whole thing in a tight loop, for speed, */
130c5df3 3928#ifdef USE_LOCALE_CTYPE
d6ded950 3929 if (IN_LC_RUNTIME(LC_CTYPE)) {
31f05a37
KW		 3930 if (IN_UTF8_CTYPE_LOCALE) {
3931 goto do_uni_rules;
3932 }
780fcc9f 3933 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
67306194 3934 for (; s < send; d++, s++)
31f05a37 3935 *d = (U8) toUPPER_LC(*s);
31351b04 3936 }
130c5df3
KW		 3937 else
3938#endif
3939 if (! IN_UNI_8_BIT) {
00f254e2 3940 for (; s < send; d++, s++) {
67306194 3941 *d = toUPPER(*s);
00f254e2 3942 }
31351b04 3943 }
00f254e2 3944 else {
91191cf7 3945#ifdef USE_LOCALE_CTYPE
31f05a37 3946 do_uni_rules:
91191cf7 3947#endif
00f254e2
KW		 3948 for (; s < send; d++, s++) {
3949 *d = toUPPER_LATIN1_MOD(*s);
d14578b8
KW		 3950 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3951 continue;
3952 }
00f254e2
KW		 3953
3954 /* The mainstream case is the tight loop above. To avoid
3955 * extra tests in that, all three characters that require
3956 * special handling are mapped by the MOD to the one tested
3957 * just above.
3958 * Use the source to distinguish between the three cases */
3959
3960 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3961
3962 /* uc() of this requires 2 characters, but they are
3963 * ASCII. If not enough room, grow the string */
3964 if (SvLEN(dest) < ++min) {
3965 const UV o = d - (U8*)SvPVX_const(dest);
3966 SvGROW(dest, min);
3967 d = (U8*)SvPVX(dest) + o;
3968 }
3969 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3970 continue; /* Back to the tight loop; still in ASCII */
3971 }
3972
3973 /* The other two special handling characters have their
3974 * upper cases outside the latin1 range, hence need to be
3975 * in UTF-8, so the whole result needs to be in UTF-8. So,
3976 * here we are somewhere in the middle of processing a
3977 * non-UTF-8 string, and realize that we will have to convert
3978 * the whole thing to UTF-8. What to do? There are
3979 * several possibilities. The simplest to code is to
3980 * convert what we have so far, set a flag, and continue on
3981 * in the loop. The flag would be tested each time through
3982 * the loop, and if set, the next character would be
3983 * converted to UTF-8 and stored. But, I (khw) didn't want
3984 * to slow down the mainstream case at all for this fairly
3985 * rare case, so I didn't want to add a test that didn't
3986 * absolutely have to be there in the loop, besides the
3987 * possibility that it would get too complicated for
3988 * optimizers to deal with. Another possibility is to just
3989 * give up, convert the source to UTF-8, and restart the
3990 * function that way. Another possibility is to convert
3991 * both what has already been processed and what is yet to
3992 * come separately to UTF-8, then jump into the loop that
3993 * handles UTF-8. But the most efficient time-wise of the
3994 * ones I could think of is what follows, and turned out to
3995 * not require much extra code. */
3996
3997 /* Convert what we have so far into UTF-8, telling the
3998 * function that we know it should be converted, and to
3999 * allow extra space for what we haven't processed yet.
4000 * Assume the worst case space requirements for converting
4001 * what we haven't processed so far: that it will require
4002 * two bytes for each remaining source character, plus the
4003 * NUL at the end. This may cause the string pointer to
4004 * move, so re-find it. */
4005
4006 len = d - (U8*)SvPVX_const(dest);
4007 SvCUR_set(dest, len);
4008 len = sv_utf8_upgrade_flags_grow(dest,
4009 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4010 (send -s) * 2 + 1);
4011 d = (U8*)SvPVX(dest) + len;
4012
00f254e2
KW		 4013 /* Now process the remainder of the source, converting to
4014 * upper and UTF-8. If a resulting byte is invariant in
4015 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4016 * append it to the output. */
00f254e2 4017 for (; s < send; s++) {
0ecfbd28
KW		 4018 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4019 d += len;
00f254e2
KW		 4020 }
4021
4022 /* Here have processed the whole source; no need to continue
4023 * with the outer loop. Each character has been converted
4024 * to upper case and converted to UTF-8 */
4025
4026 break;
4027 } /* End of processing all latin1-style chars */
4028 } /* End of processing all chars */
4029 } /* End of source is not empty */
4030
67306194 4031 if (source != dest) {
00f254e2 4032 *d = '\0'; /* Here d points to 1 after last char, add NUL */
67306194
NC		 4033 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4034 }
00f254e2 4035 } /* End of isn't utf8 */
130c5df3 4036#ifdef USE_LOCALE_CTYPE
d6ded950 4037 if (IN_LC_RUNTIME(LC_CTYPE)) {
445bf929
KW		 4038 TAINT;
4039 SvTAINTED_on(dest);
4040 }
130c5df3 4041#endif
539689e7
FC		 4042 if (dest != source && SvTAINTED(source))
4043 SvTAINT(dest);
67306194 4044 SvSETMAGIC(dest);
3cb4e04f 4045 return NORMAL;
79072805
LW		 4046}
4047
4048PP(pp_lc)
4049{
39644a26 4050 dSP;
ec9af7d4 4051 SV *source = TOPs;
463ee0b2 4052 STRLEN len;
ec9af7d4
NC		 4053 STRLEN min;
4054 SV *dest;
4055 const U8 *s;
4056 U8 *d;
79072805 4057
ec9af7d4
NC		 4058 SvGETMAGIC(source);
4059
5cd5e2d6
FC		 4060 if ( ( SvPADTMP(source)
4061 || ( SvTEMP(source) && !SvSMAGICAL(source)
4062 && SvREFCNT(source) == 1 )
4063 )
4064 && !SvREADONLY(source) && SvPOK(source)
4065 && !DO_UTF8(source)) {
ec9af7d4 4066
00f254e2
KW		 4067 /* We can convert in place, as lowercasing anything in the latin1 range
4068 * (or else DO_UTF8 would have been on) doesn't lengthen it */
ec9af7d4
NC		 4069 dest = source;
4070 s = d = (U8*)SvPV_force_nomg(source, len);
4071 min = len + 1;
4072 } else {
a0ed51b3 4073 dTARGET;
a0ed51b3 4074
ec9af7d4
NC		 4075 dest = TARG;
4076
841a5e18 4077 s = (const U8*)SvPV_nomg_const(source, len);
ec9af7d4 4078 min = len + 1;
128c9517 4079
ec9af7d4 4080 SvUPGRADE(dest, SVt_PV);
3b416f41 4081 d = (U8*)SvGROW(dest, min);
ec9af7d4
NC		 4082 (void)SvPOK_only(dest);
4083
4084 SETs(dest);
4085 }
4086
4087 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4088 to check DO_UTF8 again here. */
4089
4090 if (DO_UTF8(source)) {
4091 const U8 *const send = s + len;
4092 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4093
4094 while (s < send) {
06b5486a
KW		 4095 const STRLEN u = UTF8SKIP(s);
4096 STRLEN ulen;
00f254e2 4097
130c5df3 4098#ifdef USE_LOCALE_CTYPE
5a6bb681 4099 _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 4100#else
5a6bb681 4101 _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
130c5df3 4102#endif
00f254e2 4103
06b5486a 4104 /* Here is where we would do context-sensitive actions. See the
6006ebd0 4105 * commit message for 86510fb15 for why there isn't any */
00f254e2 4106
06b5486a 4107 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
fdb34c52 4108
06b5486a
KW		 4109 /* If the eventually required minimum size outgrows the
4110 * available space, we need to grow. */
4111 const UV o = d - (U8*)SvPVX_const(dest);
fdb34c52 4112
06b5486a
KW		 4113 /* If someone lowercases one million U+0130s we SvGROW() one
4114 * million times. Or we could try guessing how much to
4115 * allocate without allocating too much. Such is life.
4116 * Another option would be to grow an extra byte or two more
4117 * each time we need to grow, which would cut down the million
4118 * to 500K, with little waste */
4119 SvGROW(dest, min);
4120 d = (U8*)SvPVX(dest) + o;
4121 }
86510fb1 4122
06b5486a
KW		 4123 /* Copy the newly lowercased letter to the output buffer we're
4124 * building */
4125 Copy(tmpbuf, d, ulen, U8);
4126 d += ulen;
4127 s += u;
00f254e2 4128 } /* End of looping through the source string */
ec9af7d4
NC		 4129 SvUTF8_on(dest);
4130 *d = '\0';
4131 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
00f254e2 4132 } else { /* Not utf8 */
31351b04 4133 if (len) {
ec9af7d4 4134 const U8 *const send = s + len;
00f254e2
KW		 4135
4136 /* Use locale casing if in locale; regular style if not treating
4137 * latin1 as having case; otherwise the latin1 casing. Do the
4138 * whole thing in a tight loop, for speed, */
130c5df3 4139#ifdef USE_LOCALE_CTYPE
d6ded950 4140 if (IN_LC_RUNTIME(LC_CTYPE)) {
780fcc9f 4141 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
ec9af7d4
NC		 4142 for (; s < send; d++, s++)
4143 *d = toLOWER_LC(*s);
445bf929 4144 }
130c5df3
KW		 4145 else
4146#endif
4147 if (! IN_UNI_8_BIT) {
00f254e2 4148 for (; s < send; d++, s++) {
ec9af7d4 4149 *d = toLOWER(*s);
00f254e2
KW		 4150 }
4151 }
4152 else {
4153 for (; s < send; d++, s++) {
4154 *d = toLOWER_LATIN1(*s);
4155 }
31351b04 4156 }
bbce6d69 4157 }
ec9af7d4
NC		 4158 if (source != dest) {
4159 *d = '\0';
4160 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4161 }
79072805 4162 }
130c5df3 4163#ifdef USE_LOCALE_CTYPE
d6ded950 4164 if (IN_LC_RUNTIME(LC_CTYPE)) {
445bf929
KW		 4165 TAINT;
4166 SvTAINTED_on(dest);
4167 }
130c5df3 4168#endif
539689e7
FC		 4169 if (dest != source && SvTAINTED(source))
4170 SvTAINT(dest);
ec9af7d4 4171 SvSETMAGIC(dest);
3cb4e04f 4172 return NORMAL;
79072805
LW		 4173}
4174
a0d0e21e 4175PP(pp_quotemeta)
79072805 4176{
20b7effb 4177 dSP; dTARGET;
1b6737cc 4178 SV * const sv = TOPs;
a0d0e21e 4179 STRLEN len;
eb578fdb 4180 const char *s = SvPV_const(sv,len);
79072805 4181
7e2040f0 4182 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4183 if (len) {
eb578fdb 4184 char *d;
862a34c6 4185 SvUPGRADE(TARG, SVt_PV);
c07a80fd 4186 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 4187 d = SvPVX(TARG);
7e2040f0 4188 if (DO_UTF8(sv)) {
0dd2cdef 4189 while (len) {
29050de5 4190 STRLEN ulen = UTF8SKIP(s);
2e2b2571
KW		 4191 bool to_quote = FALSE;
4192
4193 if (UTF8_IS_INVARIANT(*s)) {
4194 if (_isQUOTEMETA(*s)) {
4195 to_quote = TRUE;
4196 }
4197 }
4198 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3fea7d29 4199 if (
130c5df3 4200#ifdef USE_LOCALE_CTYPE
20adcf7c
KW		 4201 /* In locale, we quote all non-ASCII Latin1 chars.
4202 * Otherwise use the quoting rules */
3fea7d29
BF		 4203
4204 IN_LC_RUNTIME(LC_CTYPE)
4205 ||
4206#endif
4207 _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
2e2b2571
KW		 4208 {
4209 to_quote = TRUE;
4210 }
4211 }
685289b5 4212 else if (is_QUOTEMETA_high(s)) {
2e2b2571
KW		 4213 to_quote = TRUE;
4214 }
4215
4216 if (to_quote) {
4217 *d++ = '\\';
4218 }
29050de5
KW		 4219 if (ulen > len)
4220 ulen = len;
4221 len -= ulen;
4222 while (ulen--)
4223 *d++ = *s++;
0dd2cdef 4224 }
7e2040f0 4225 SvUTF8_on(TARG);
0dd2cdef 4226 }
2e2b2571
KW		 4227 else if (IN_UNI_8_BIT) {
4228 while (len--) {
4229 if (_isQUOTEMETA(*s))
4230 *d++ = '\\';
4231 *d++ = *s++;
4232 }
4233 }
0dd2cdef 4234 else {
2e2b2571
KW		 4235 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4236 * including everything above ASCII */
0dd2cdef 4237 while (len--) {
adfec831 4238 if (!isWORDCHAR_A(*s))
0dd2cdef
LW		 4239 *d++ = '\\';
4240 *d++ = *s++;
4241 }
79072805 4242 }
a0d0e21e 4243 *d = '\0';
349d4f2f 4244 SvCUR_set(TARG, d - SvPVX_const(TARG));
3aa33fe5 4245 (void)SvPOK_only_UTF8(TARG);
79072805 4246 }
a0d0e21e
LW		 4247 else
4248 sv_setpvn(TARG, s, len);
ec93b65f 4249 SETTARG;
cfe40115 4250 return NORMAL;
79072805
LW		 4251}
4252
838f2281
BF		 4253PP(pp_fc)
4254{
838f2281
BF		 4255 dTARGET;
4256 dSP;
4257 SV *source = TOPs;
4258 STRLEN len;
4259 STRLEN min;
4260 SV *dest;
4261 const U8 *s;
4262 const U8 *send;
4263 U8 *d;
bfac13d4 4264 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
a4b69695
KW		 4265 const bool full_folding = TRUE; /* This variable is here so we can easily
4266 move to more generality later */
838f2281 4267 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
130c5df3
KW		 4268#ifdef USE_LOCALE_CTYPE
4269 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4270#endif
4271 ;
838f2281
BF		 4272
4273 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4274 * You are welcome(?) -Hugmeir
4275 */
4276
4277 SvGETMAGIC(source);
4278
4279 dest = TARG;
4280
4281 if (SvOK(source)) {
4282 s = (const U8*)SvPV_nomg_const(source, len);
4283 } else {
4284 if (ckWARN(WARN_UNINITIALIZED))
4285 report_uninit(source);
4286 s = (const U8*)"";
4287 len = 0;
4288 }
4289
4290 min = len + 1;
4291
4292 SvUPGRADE(dest, SVt_PV);
4293 d = (U8*)SvGROW(dest, min);
4294 (void)SvPOK_only(dest);
4295
4296 SETs(dest);
4297
4298 send = s + len;
4299 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
838f2281
BF		 4300 while (s < send) {
4301 const STRLEN u = UTF8SKIP(s);
4302 STRLEN ulen;
4303
445bf929 4304 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
838f2281
BF		 4305
4306 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4307 const UV o = d - (U8*)SvPVX_const(dest);
4308 SvGROW(dest, min);
4309 d = (U8*)SvPVX(dest) + o;
4310 }
4311
4312 Copy(tmpbuf, d, ulen, U8);
4313 d += ulen;
4314 s += u;
4315 }
4316 SvUTF8_on(dest);
838f2281 4317 } /* Unflagged string */
0902dd32 4318 else if (len) {
130c5df3 4319#ifdef USE_LOCALE_CTYPE
d6ded950 4320 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
31f05a37
KW		 4321 if (IN_UTF8_CTYPE_LOCALE) {
4322 goto do_uni_folding;
4323 }
780fcc9f 4324 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
838f2281 4325 for (; s < send; d++, s++)
ea36a843 4326 *d = (U8) toFOLD_LC(*s);
838f2281 4327 }
130c5df3
KW		 4328 else
4329#endif
4330 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
838f2281 4331 for (; s < send; d++, s++)
d22b930b 4332 *d = toFOLD(*s);
838f2281
BF		 4333 }
4334 else {
91191cf7 4335#ifdef USE_LOCALE_CTYPE
31f05a37 4336 do_uni_folding:
91191cf7 4337#endif
d14578b8
KW		 4338 /* For ASCII and the Latin-1 range, there's only two troublesome
4339 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
22e255cb 4340 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
d14578b8
KW		 4341 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4342 * For the rest, the casefold is their lowercase. */
838f2281
BF		 4343 for (; s < send; d++, s++) {
4344 if (*s == MICRO_SIGN) {
d14578b8
KW		 4345 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4346 * which is outside of the latin-1 range. There's a couple
4347 * of ways to deal with this -- khw discusses them in
4348 * pp_lc/uc, so go there :) What we do here is upgrade what
4349 * we had already casefolded, then enter an inner loop that
4350 * appends the rest of the characters as UTF-8. */
838f2281
BF		 4351 len = d - (U8*)SvPVX_const(dest);
4352 SvCUR_set(dest, len);
4353 len = sv_utf8_upgrade_flags_grow(dest,
4354 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
ea4d335b
KW		 4355 /* The max expansion for latin1
4356 * chars is 1 byte becomes 2 */
4357 (send -s) * 2 + 1);
838f2281
BF		 4358 d = (U8*)SvPVX(dest) + len;
4359
a78bc3c6
KW		 4360 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4361 d += small_mu_len;
838f2281
BF		 4362 s++;
4363 for (; s < send; s++) {
4364 STRLEN ulen;
4365 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
6f2d5cbc 4366 if UVCHR_IS_INVARIANT(fc) {
d14578b8
KW		 4367 if (full_folding
4368 && *s == LATIN_SMALL_LETTER_SHARP_S)
4369 {
838f2281
BF		 4370 *d++ = 's';
4371 *d++ = 's';
4372 }
4373 else
4374 *d++ = (U8)fc;
4375 }
4376 else {
4377 Copy(tmpbuf, d, ulen, U8);
4378 d += ulen;
4379 }
4380 }
4381 break;
4382 }
4383 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
d14578b8
KW		 4384 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4385 * becomes "ss", which may require growing the SV. */
838f2281
BF		 4386 if (SvLEN(dest) < ++min) {
4387 const UV o = d - (U8*)SvPVX_const(dest);
4388 SvGROW(dest, min);
4389 d = (U8*)SvPVX(dest) + o;
4390 }
4391 *(d)++ = 's';
4392 *d = 's';
4393 }
d14578b8
KW		 4394 else { /* If it's not one of those two, the fold is their lower
4395 case */
838f2281
BF		 4396 *d = toLOWER_LATIN1(*s);
4397 }
4398 }
4399 }
4400 }
4401 *d = '\0';
4402 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4403
130c5df3 4404#ifdef USE_LOCALE_CTYPE
d6ded950 4405 if (IN_LC_RUNTIME(LC_CTYPE)) {
445bf929
KW		 4406 TAINT;
4407 SvTAINTED_on(dest);
4408 }
130c5df3 4409#endif
838f2281
BF		 4410 if (SvTAINTED(source))
4411 SvTAINT(dest);
4412 SvSETMAGIC(dest);
4413 RETURN;
4414}
4415
a0d0e21e 4416/* Arrays. */
79072805 4417
a0d0e21e 4418PP(pp_aslice)
79072805 4419{
20b7effb 4420 dSP; dMARK; dORIGMARK;
eb578fdb
KW		 4421 AV *const av = MUTABLE_AV(POPs);
4422 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
79072805 4423
a0d0e21e 4424 if (SvTYPE(av) == SVt_PVAV) {
4ad10a0b
VP		 4425 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4426 bool can_preserve = FALSE;
4427
4428 if (localizing) {
4429 MAGIC *mg;
4430 HV *stash;
4431
4432 can_preserve = SvCANEXISTDELETE(av);
4433 }
4434
4435 if (lval && localizing) {
eb578fdb 4436 SV **svp;
c70927a6 4437 SSize_t max = -1;
924508f0 4438 for (svp = MARK + 1; svp <= SP; svp++) {
c70927a6 4439 const SSize_t elem = SvIV(*svp);
748a9306
LW		 4440 if (elem > max)
4441 max = elem;
4442 }
4443 if (max > AvMAX(av))
4444 av_extend(av, max);
4445 }
4ad10a0b 4446
a0d0e21e 4447 while (++MARK <= SP) {
eb578fdb 4448 SV **svp;
c70927a6 4449 SSize_t elem = SvIV(*MARK);
4ad10a0b 4450 bool preeminent = TRUE;
a0d0e21e 4451
4ad10a0b
VP		 4452 if (localizing && can_preserve) {
4453 /* If we can determine whether the element exist,
4454 * Try to preserve the existenceness of a tied array
4455 * element by using EXISTS and DELETE if possible.
4456 * Fallback to FETCH and STORE otherwise. */
4457 preeminent = av_exists(av, elem);
4458 }
4459
a0d0e21e
LW		 4460 svp = av_fetch(av, elem, lval);
4461 if (lval) {
ce0d59fd 4462 if (!svp || !*svp)
cea2e8a9 4463 DIE(aTHX_ PL_no_aelem, elem);
4ad10a0b
VP		 4464 if (localizing) {
4465 if (preeminent)
4466 save_aelem(av, elem, svp);
4467 else
4468 SAVEADELETE(av, elem);
4469 }
79072805 4470 }
3280af22 4471 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 4472 }
4473 }
82334630 4474 if (GIMME_V != G_ARRAY) {
a0d0e21e 4475 MARK = ORIGMARK;
04ab2c87 4476 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e
LW		 4477 SP = MARK;
4478 }
79072805
LW		 4479 RETURN;
4480}
4481
6dd3e0f2
RZ		 4482PP(pp_kvaslice)
4483{
20b7effb 4484 dSP; dMARK;
6dd3e0f2
RZ		 4485 AV *const av = MUTABLE_AV(POPs);
4486 I32 lval = (PL_op->op_flags & OPf_MOD);
adad97db 4487 SSize_t items = SP - MARK;
6dd3e0f2
RZ		 4488
4489 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4490 const I32 flags = is_lvalue_sub();
4491 if (flags) {
4492 if (!(flags & OPpENTERSUB_INARGS))
7aae0299 4493 /* diag_listed_as: Can't modify %s in %s */
6dd3e0f2
RZ		 4494 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4495 lval = flags;
4496 }
4497 }
4498
4499 MEXTEND(SP,items);
4500 while (items > 1) {
4501 *(MARK+items*2-1) = *(MARK+items);
4502 items--;
4503 }
4504 items = SP-MARK;
4505 SP += items;
4506
4507 while (++MARK <= SP) {
4508 SV **svp;
4509
4510 svp = av_fetch(av, SvIV(*MARK), lval);
4511 if (lval) {
4512 if (!svp || !*svp || *svp == &PL_sv_undef) {
4513 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4514 }
4515 *MARK = sv_mortalcopy(*MARK);
4516 }
4517 *++MARK = svp ? *svp : &PL_sv_undef;
4518 }
82334630 4519 if (GIMME_V != G_ARRAY) {
6dd3e0f2
RZ		 4520 MARK = SP - items*2;
4521 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4522 SP = MARK;
4523 }
4524 RETURN;
4525}
4526
b1c05ba5 4527
cba5a3b0 4528/* Smart dereferencing for keys, values and each */
b1c05ba5
DM		 4529
4530/* also used for: pp_reach() pp_rvalues() */
4531
cba5a3b0
DG		 4532PP(pp_rkeys)
4533{
cba5a3b0
DG		 4534 dSP;
4535 dPOPss;
4536
7ac5715b
FC		 4537 SvGETMAGIC(sv);
4538
4539 if (
4540 !SvROK(sv)
4541 || (sv = SvRV(sv),
4542 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4543 || SvOBJECT(sv)
4544 )
4545 ) {
4546 DIE(aTHX_
4547 "Type of argument to %s must be unblessed hashref or arrayref",
4c540399 4548 PL_op_desc[PL_op->op_type] );
cba5a3b0
DG		 4549 }
4550
d8065907
FC		 4551 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4552 DIE(aTHX_
4553 "Can't modify %s in %s",
4554 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4555 );
4556
cba5a3b0
DG		 4557 /* Delegate to correct function for op type */
4558 PUSHs(sv);
4559 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4560 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4561 }
4562 else {
d14578b8
KW		 4563 return (SvTYPE(sv) == SVt_PVHV)
4564 ? Perl_pp_each(aTHX)
4565 : Perl_pp_aeach(aTHX);
cba5a3b0
DG		 4566 }
4567}
4568
878d132a
NC		 4569PP(pp_aeach)
4570{
878d132a 4571 dSP;
502c6561 4572 AV *array = MUTABLE_AV(POPs);
878d132a 4573 const I32 gimme = GIMME_V;
453d94a9 4574 IV *iterp = Perl_av_iter_p(aTHX_ array);
878d132a
NC		 4575 const IV current = (*iterp)++;
4576
b9f2b683 4577 if (current > av_tindex(array)) {
878d132a
NC		 4578 *iterp = 0;
4579 if (gimme == G_SCALAR)
4580 RETPUSHUNDEF;
4581 else
4582 RETURN;
4583 }
4584
4585 EXTEND(SP, 2);
e1dccc0d 4586 mPUSHi(current);
878d132a
NC		 4587 if (gimme == G_ARRAY) {
4588 SV **const element = av_fetch(array, current, 0);
4589 PUSHs(element ? *element : &PL_sv_undef);
4590 }
4591 RETURN;
4592}
4593
b1c05ba5 4594/* also used for: pp_avalues()*/
878d132a
NC		 4595PP(pp_akeys)
4596{
878d132a 4597 dSP;
502c6561 4598 AV *array = MUTABLE_AV(POPs);
878d132a
NC		 4599 const I32 gimme = GIMME_V;
4600
4601 *Perl_av_iter_p(aTHX_ array) = 0;
4602
4603 if (gimme == G_SCALAR) {
4604 dTARGET;
b9f2b683 4605 PUSHi(av_tindex(array) + 1);
878d132a
NC		 4606 }
4607 else if (gimme == G_ARRAY) {
4608 IV n = Perl_av_len(aTHX_ array);
e1dccc0d 4609 IV i;
878d132a
NC		 4610
4611 EXTEND(SP, n + 1);
4612
cba5a3b0 4613 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
e1dccc0d 4614 for (i = 0; i <= n; i++) {
878d132a
NC		 4615 mPUSHi(i);
4616 }
4617 }
4618 else {
4619 for (i = 0; i <= n; i++) {
4620 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4621 PUSHs(elem ? *elem : &PL_sv_undef);
4622 }
4623 }
4624 }
4625 RETURN;
4626}
4627
79072805
LW		 4628/* Associative arrays. */
4629
4630PP(pp_each)
4631{
39644a26 4632 dSP;
85fbaab2 4633 HV * hash = MUTABLE_HV(POPs);
c07a80fd 4634 HE *entry;
f54cb97a 4635 const I32 gimme = GIMME_V;
8ec5e241 4636
6d822dc4 4637 entry = hv_iternext(hash);
79072805 4638
79072805
LW		 4639 EXTEND(SP, 2);
4640 if (entry) {
1b6737cc 4641 SV* const sv = hv_iterkeysv(entry);
2b32fed8 4642 PUSHs(sv);
54310121 4643 if (gimme == G_ARRAY) {
59af0135 4644 SV *val;
6d822dc4 4645 val = hv_iterval(hash, entry);
59af0135 4646 PUSHs(val);
79072805 4647 }
79072805 4648 }
54310121 4649 else if (gimme == G_SCALAR)
79072805
LW		 4650 RETPUSHUNDEF;
4651
4652 RETURN;
4653}
4654
7332a6c4
VP		 4655STATIC OP *
4656S_do_delete_local(pTHX)
79072805 4657{
39644a26 4658 dSP;
f54cb97a 4659 const I32 gimme = GIMME_V;
7332a6c4
VP		 4660 const MAGIC *mg;
4661 HV *stash;
ca3f996a 4662 const bool sliced = !!(PL_op->op_private & OPpSLICE);
626040f7 4663 SV **unsliced_keysv = sliced ? NULL : sp--;
ca3f996a 4664 SV * const osv = POPs;
626040f7 4665 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
ca3f996a
FC		 4666 dORIGMARK;
4667 const bool tied = SvRMAGICAL(osv)
7332a6c4 4668 && mg_find((const SV *)osv, PERL_MAGIC_tied);
ca3f996a
FC		 4669 const bool can_preserve = SvCANEXISTDELETE(osv);
4670 const U32 type = SvTYPE(osv);
626040f7 4671 SV ** const end = sliced ? SP : unsliced_keysv;
ca3f996a
FC		 4672
4673 if (type == SVt_PVHV) { /* hash element */
7332a6c4 4674 HV * const hv = MUTABLE_HV(osv);
ca3f996a 4675 while (++MARK <= end) {
7332a6c4
VP		 4676 SV * const keysv = *MARK;
4677 SV *sv = NULL;
4678 bool preeminent = TRUE;
4679 if (can_preserve)
4680 preeminent = hv_exists_ent(hv, keysv, 0);
4681 if (tied) {
4682 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4683 if (he)
4684 sv = HeVAL(he);
4685 else
4686 preeminent = FALSE;
4687 }
4688 else {
4689 sv = hv_delete_ent(hv, keysv, 0, 0);
9332b95f
FC		 4690 if (preeminent)
4691 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
7332a6c4
VP		 4692 }
4693 if (preeminent) {
be6064fd 4694 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
7332a6c4
VP		 4695 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4696 if (tied) {
4697 *MARK = sv_mortalcopy(sv);
4698 mg_clear(sv);
4699 } else
4700 *MARK = sv;
4701 }
4702 else {
4703 SAVEHDELETE(hv, keysv);
4704 *MARK = &PL_sv_undef;
4705 }
4706 }
ca3f996a
FC		 4707 }
4708 else if (type == SVt_PVAV) { /* array element */
7332a6c4
VP		 4709 if (PL_op->op_flags & OPf_SPECIAL) {
4710 AV * const av = MUTABLE_AV(osv);
ca3f996a 4711 while (++MARK <= end) {
c70927a6 4712 SSize_t idx = SvIV(*MARK);
7332a6c4
VP		 4713 SV *sv = NULL;
4714 bool preeminent = TRUE;
4715 if (can_preserve)
4716 preeminent = av_exists(av, idx);
4717 if (tied) {
4718 SV **svp = av_fetch(av, idx, 1);
4719 if (svp)
4720 sv = *svp;
4721 else
4722 preeminent = FALSE;
4723 }
4724 else {
4725 sv = av_delete(av, idx, 0);
9332b95f
FC		 4726 if (preeminent)
4727 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
7332a6c4
VP		 4728 }
4729 if (preeminent) {
4730 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4731 if (tied) {
4732 *MARK = sv_mortalcopy(sv);
4733 mg_clear(sv);
4734 } else
4735 *MARK = sv;
4736 }
4737 else {
4738 SAVEADELETE(av, idx);
4739 *MARK = &PL_sv_undef;
4740 }
4741 }
4742 }
ca3f996a
FC		 4743 else
4744 DIE(aTHX_ "panic: avhv_delete no longer supported");
4745 }
4746 else
7332a6c4 4747 DIE(aTHX_ "Not a HASH reference");
ca3f996a 4748 if (sliced) {
7332a6c4
VP		 4749 if (gimme == G_VOID)
4750 SP = ORIGMARK;
4751 else if (gimme == G_SCALAR) {
4752 MARK = ORIGMARK;
4753 if (SP > MARK)
4754 *++MARK = *SP;
4755 else
4756 *++MARK = &PL_sv_undef;
4757 SP = MARK;
4758 }
4759 }
ca3f996a 4760 else if (gimme != G_VOID)
626040f7 4761 PUSHs(*unsliced_keysv);
7332a6c4
VP		 4762
4763 RETURN;
4764}
4765
4766PP(pp_delete)
4767{
7332a6c4
VP		 4768 dSP;
4769 I32 gimme;
4770 I32 discard;
4771
4772 if (PL_op->op_private & OPpLVAL_INTRO)
4773 return do_delete_local();
4774
4775 gimme = GIMME_V;
4776 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5f05dabc 4777
533c011a 4778 if (PL_op->op_private & OPpSLICE) {
5f05dabc 4779 dMARK; dORIGMARK;
85fbaab2 4780 HV * const hv = MUTABLE_HV(POPs);
1b6737cc 4781 const U32 hvtype = SvTYPE(hv);
01020589
GS		 4782 if (hvtype == SVt_PVHV) { /* hash element */
4783 while (++MARK <= SP) {
1b6737cc 4784 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 4785 *MARK = sv ? sv : &PL_sv_undef;
4786 }
5f05dabc 4787 }
6d822dc4
MS		 4788 else if (hvtype == SVt_PVAV) { /* array element */
4789 if (PL_op->op_flags & OPf_SPECIAL) {
4790 while (++MARK <= SP) {
502c6561 4791 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
6d822dc4
MS		 4792 *MARK = sv ? sv : &PL_sv_undef;
4793 }
4794 }
01020589
GS		 4795 }
4796 else
4797 DIE(aTHX_ "Not a HASH reference");
54310121 4798 if (discard)
4799 SP = ORIGMARK;
4800 else if (gimme == G_SCALAR) {
5f05dabc 4801 MARK = ORIGMARK;
9111c9c0
DM		 4802 if (SP > MARK)
4803 *++MARK = *SP;
4804 else
4805 *++MARK = &PL_sv_undef;
5f05dabc 4806 SP = MARK;
4807 }
4808 }
4809 else {
4810 SV *keysv = POPs;
85fbaab2 4811 HV * const hv = MUTABLE_HV(POPs);
295d248e 4812 SV *sv = NULL;
97fcbf96
MB		 4813 if (SvTYPE(hv) == SVt_PVHV)
4814 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 4815 else if (SvTYPE(hv) == SVt_PVAV) {
4816 if (PL_op->op_flags & OPf_SPECIAL)
502c6561 4817 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
af288a60
HS		 4818 else
4819 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 4820 }
97fcbf96 4821 else
cea2e8a9 4822 DIE(aTHX_ "Not a HASH reference");
5f05dabc 4823 if (!sv)
3280af22 4824 sv = &PL_sv_undef;
54310121 4825 if (!discard)
4826 PUSHs(sv);
79072805 4827 }
79072805
LW		 4828 RETURN;
4829}
4830
a0d0e21e 4831PP(pp_exists)
79072805 4832{
39644a26 4833 dSP;
afebc493
GS		 4834 SV *tmpsv;
4835 HV *hv;
4836
c7e88ff3 4837 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
afebc493 4838 GV *gv;
0bd48802 4839 SV * const sv = POPs;
f2c0649b 4840 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
afebc493
GS		 4841 if (cv)
4842 RETPUSHYES;
4843 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4844 RETPUSHYES;
4845 RETPUSHNO;
4846 }
4847 tmpsv = POPs;
85fbaab2 4848 hv = MUTABLE_HV(POPs);
c7e88ff3 4849 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
ae77835f 4850 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 4851 RETPUSHYES;
ef54e1a4
JH		 4852 }
4853 else if (SvTYPE(hv) == SVt_PVAV) {
01020589 4854 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
502c6561 4855 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
01020589
GS		 4856 RETPUSHYES;
4857 }
ef54e1a4
JH		 4858 }
4859 else {
cea2e8a9 4860 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 4861 }
a0d0e21e
LW		 4862 RETPUSHNO;
4863}
79072805 4864
a0d0e21e
LW		 4865PP(pp_hslice)
4866{
20b7effb 4867 dSP; dMARK; dORIGMARK;
eb578fdb
KW		 4868 HV * const hv = MUTABLE_HV(POPs);
4869 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
1b6737cc 4870 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 4871 bool can_preserve = FALSE;
79072805 4872
eb85dfd3
DM		 4873 if (localizing) {
4874 MAGIC *mg;
4875 HV *stash;
4876
2c5f48c2 4877 if (SvCANEXISTDELETE(hv))
d30e492c 4878 can_preserve = TRUE;
eb85dfd3
DM		 4879 }
4880
6d822dc4 4881 while (++MARK <= SP) {
1b6737cc 4882 SV * const keysv = *MARK;
6d822dc4
MS		 4883 SV **svp;
4884 HE *he;
d30e492c
VP		 4885 bool preeminent = TRUE;
4886
4887 if (localizing && can_preserve) {
4888 /* If we can determine whether the element exist,
4889 * try to preserve the existenceness of a tied hash
4890 * element by using EXISTS and DELETE if possible.
4891 * Fallback to FETCH and STORE otherwise. */
4892 preeminent = hv_exists_ent(hv, keysv, 0);
6d822dc4 4893 }
eb85dfd3 4894
6d822dc4 4895 he = hv_fetch_ent(hv, keysv, lval, 0);
fe5bfecd 4896 svp = he ? &HeVAL(he) : NULL;
eb85dfd3 4897
6d822dc4 4898 if (lval) {
746f6409 4899 if (!svp || !*svp || *svp == &PL_sv_undef) {
be2597df 4900 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6d822dc4
MS		 4901 }
4902 if (localizing) {
7a2e501a 4903 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 4904 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP		 4905 else if (preeminent)
4906 save_helem_flags(hv, keysv, svp,
4907 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4908 else
4909 SAVEHDELETE(hv, keysv);
6d822dc4
MS		 4910 }
4911 }
746f6409 4912 *MARK = svp && *svp ? *svp : &PL_sv_undef;
79072805 4913 }
82334630 4914 if (GIMME_V != G_ARRAY) {
a0d0e21e 4915 MARK = ORIGMARK;
04ab2c87 4916 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e 4917 SP = MARK;
79072805 4918 }
a0d0e21e
LW		 4919 RETURN;
4920}
4921
5cae3edb
RZ		 4922PP(pp_kvhslice)
4923{
20b7effb 4924 dSP; dMARK;
5cae3edb
RZ		 4925 HV * const hv = MUTABLE_HV(POPs);
4926 I32 lval = (PL_op->op_flags & OPf_MOD);
adad97db 4927 SSize_t items = SP - MARK;
5cae3edb
RZ		 4928
4929 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4930 const I32 flags = is_lvalue_sub();
4931 if (flags) {
4932 if (!(flags & OPpENTERSUB_INARGS))
7aae0299 4933 /* diag_listed_as: Can't modify %s in %s */
5cae3edb
RZ		 4934 Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
4935 lval = flags;
4936 }
4937 }
4938
4939 MEXTEND(SP,items);
4940 while (items > 1) {
4941 *(MARK+items*2-1) = *(MARK+items);
4942 items--;
4943 }
4944 items = SP-MARK;
4945 SP += items;
4946
4947 while (++MARK <= SP) {
4948 SV * const keysv = *MARK;
4949 SV **svp;
4950 HE *he;
4951
4952 he = hv_fetch_ent(hv, keysv, lval, 0);
4953 svp = he ? &HeVAL(he) : NULL;
4954
4955 if (lval) {
4956 if (!svp || !*svp || *svp == &PL_sv_undef) {
4957 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4958 }
4959 *MARK = sv_mortalcopy(*MARK);
4960 }
4961 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
4962 }
82334630 4963 if (GIMME_V != G_ARRAY) {
5cae3edb
RZ		 4964 MARK = SP - items*2;
4965 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4966 SP = MARK;
4967 }
4968 RETURN;
4969}
4970
a0d0e21e
LW		 4971/* List operators. */
4972
4973PP(pp_list)
4974{
4fa715fa 4975 I32 markidx = POPMARK;
82334630 4976 if (GIMME_V != G_ARRAY) {
4fa715fa
DD		 4977 SV **mark = PL_stack_base + markidx;
4978 dSP;
a0d0e21e
LW		 4979 if (++MARK <= SP)
4980 *MARK = *SP; /* unwanted list, return last item */
8990e307 4981 else
3280af22 4982 *MARK = &PL_sv_undef;
a0d0e21e 4983 SP = MARK;
4fa715fa 4984 PUTBACK;
79072805 4985 }
4fa715fa 4986 return NORMAL;
79072805
LW		 4987}
4988
a0d0e21e 4989PP(pp_lslice)
79072805 4990{
39644a26 4991 dSP;
1b6737cc
AL		 4992 SV ** const lastrelem = PL_stack_sp;
4993 SV ** const lastlelem = PL_stack_base + POPMARK;
4994 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
eb578fdb 4995 SV ** const firstrelem = lastlelem + 1;
706a6ebc 4996 const U8 mod = PL_op->op_flags & OPf_MOD;
1b6737cc 4997
eb578fdb
KW		 4998 const I32 max = lastrelem - lastlelem;
4999 SV **lelem;
a0d0e21e 5000
82334630 5001 if (GIMME_V != G_ARRAY) {
4ea561bc 5002 I32 ix = SvIV(*lastlelem);
748a9306
LW		 5003 if (ix < 0)
5004 ix += max;
a0d0e21e 5005 if (ix < 0 || ix >= max)
3280af22 5006 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 5007 else
5008 *firstlelem = firstrelem[ix];
5009 SP = firstlelem;
5010 RETURN;
5011 }
5012
5013 if (max == 0) {
5014 SP = firstlelem - 1;
5015 RETURN;
5016 }
5017
5018 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4ea561bc 5019 I32 ix = SvIV(*lelem);
c73bf8e3 5020 if (ix < 0)
a0d0e21e 5021 ix += max;
c73bf8e3
HS		 5022 if (ix < 0 || ix >= max)
5023 *lelem = &PL_sv_undef;
5024 else {
c73bf8e3 5025 if (!(*lelem = firstrelem[ix]))
3280af22 5026 *lelem = &PL_sv_undef;
60779a30 5027 else if (mod && SvPADTMP(*lelem)) {
706a6ebc 5028 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
60779a30 5029 }
748a9306 5030 }
79072805 5031 }
cbce292e 5032 SP = lastlelem;
79072805
LW		 5033 RETURN;
5034}
5035
a0d0e21e
LW		 5036PP(pp_anonlist)
5037{
20b7effb 5038 dSP; dMARK;
1b6737cc 5039 const I32 items = SP - MARK;
ad64d0ec 5040 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
31476221 5041 SP = MARK;
6e449a3a
MHM		 5042 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5043 ? newRV_noinc(av) : av);
a0d0e21e
LW		 5044 RETURN;
5045}
5046
5047PP(pp_anonhash)
79072805 5048{
20b7effb 5049 dSP; dMARK; dORIGMARK;
67e67fd7 5050 HV* const hv = newHV();
8d455b9f 5051 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
67e67fd7 5052 ? newRV_noinc(MUTABLE_SV(hv))
8d455b9f 5053 : MUTABLE_SV(hv) );
a0d0e21e
LW		 5054
5055 while (MARK < SP) {
3ed356df
FC		 5056 SV * const key =
5057 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5058 SV *val;
a0d0e21e 5059 if (MARK < SP)
3ed356df
FC		 5060 {
5061 MARK++;
5062 SvGETMAGIC(*MARK);
5063 val = newSV(0);
d187b712 5064 sv_setsv_nomg(val, *MARK);
3ed356df 5065 }
a2a5de95 5066 else
3ed356df 5067 {
a2a5de95 5068 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3ed356df
FC		 5069 val = newSV(0);
5070 }
f12c7020 5071 (void)hv_store_ent(hv,key,val,0);
79072805 5072 }
a0d0e21e 5073 SP = ORIGMARK;
8d455b9f 5074 XPUSHs(retval);
79072805
LW		 5075 RETURN;
5076}
5077
d4fc4415
FC		 5078static AV *
5079S_deref_plain_array(pTHX_ AV *ary)
5080{
5081 if (SvTYPE(ary) == SVt_PVAV) return ary;
d2d95e13 5082 SvGETMAGIC((SV *)ary);
d4fc4415
FC		 5083 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5084 Perl_die(aTHX_ "Not an ARRAY reference");
5085 else if (SvOBJECT(SvRV(ary)))
5086 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5087 return (AV *)SvRV(ary);
5088}
5089
5090#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5091# define DEREF_PLAIN_ARRAY(ary) \
5092 ({ \
5093 AV *aRrRay = ary; \
5094 SvTYPE(aRrRay) == SVt_PVAV \
5095 ? aRrRay \
5096 : S_deref_plain_array(aTHX_ aRrRay); \
5097 })
5098#else
5099# define DEREF_PLAIN_ARRAY(ary) \
5100 ( \
3b0f6d32 5101 PL_Sv = (SV *)(ary), \
d4fc4415
FC		 5102 SvTYPE(PL_Sv) == SVt_PVAV \
5103 ? (AV *)PL_Sv \
3b0f6d32 5104 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
d4fc4415
FC		 5105 )
5106#endif
5107
a0d0e21e 5108PP(pp_splice)
79072805 5109{
20b7effb 5110 dSP; dMARK; dORIGMARK;
5cd408a2 5111 int num_args = (SP - MARK);
eb578fdb
KW		 5112 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5113 SV **src;
5114 SV **dst;
c70927a6
FC		 5115 SSize_t i;
5116 SSize_t offset;
5117 SSize_t length;
5118 SSize_t newlen;
5119 SSize_t after;
5120 SSize_t diff;
ad64d0ec 5121 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 5122
1b6737cc 5123 if (mg) {
3e0cb5de 5124 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
af71faff
NC		 5125 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5126 sp - mark);
93965878 5127 }
79072805 5128
a0d0e21e 5129 SP++;
79072805 5130
a0d0e21e 5131 if (++MARK < SP) {
4ea561bc 5132 offset = i = SvIV(*MARK);
a0d0e21e 5133 if (offset < 0)
93965878 5134 offset += AvFILLp(ary) + 1;
84902520 5135 if (offset < 0)
cea2e8a9 5136 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 5137 if (++MARK < SP) {
5138 length = SvIVx(*MARK++);
48cdf507
GA		 5139 if (length < 0) {
5140 length += AvFILLp(ary) - offset + 1;
5141 if (length < 0)
5142 length = 0;
5143 }
79072805
LW		 5144 }
5145 else
a0d0e21e 5146 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 5147 }
a0d0e21e
LW		 5148 else {
5149 offset = 0;
5150 length = AvMAX(ary) + 1;
5151 }
8cbc2e3b 5152 if (offset > AvFILLp(ary) + 1) {
5cd408a2
EB		 5153 if (num_args > 2)
5154 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 5155 offset = AvFILLp(ary) + 1;
8cbc2e3b 5156 }
93965878 5157 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 5158 if (after < 0) { /* not that much array */
5159 length += after; /* offset+length now in array */
5160 after = 0;
5161 if (!AvALLOC(ary))
5162 av_extend(ary, 0);
5163 }
5164
5165 /* At this point, MARK .. SP-1 is our new LIST */
5166
5167 newlen = SP - MARK;
5168 diff = newlen - length;
13d7cbc1
GS		 5169 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5170 av_reify(ary);
a0d0e21e 5171
50528de0
WL		 5172 /* make new elements SVs now: avoid problems if they're from the array */
5173 for (dst = MARK, i = newlen; i; i--) {
1b6737cc 5174 SV * const h = *dst;
f2b990bf 5175 *dst++ = newSVsv(h);
50528de0
WL		 5176 }
5177
a0d0e21e 5178 if (diff < 0) { /* shrinking the area */
95b63a38 5179 SV **tmparyval = NULL;
a0d0e21e 5180 if (newlen) {
a02a5408 5181 Newx(tmparyval, newlen, SV*); /* so remember insertion */
a0d0e21e 5182 Copy(MARK, tmparyval, newlen, SV*);
79072805 5183 }
a0d0e21e
LW		 5184
5185 MARK = ORIGMARK + 1;
82334630 5186 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
31c61add 5187 const bool real = cBOOL(AvREAL(ary));
a0d0e21e 5188 MEXTEND(MARK, length);
31c61add 5189 if (real)
bbce6d69 5190 EXTEND_MORTAL(length);
31c61add
FC		 5191 for (i = 0, dst = MARK; i < length; i++) {
5192 if ((*dst = AvARRAY(ary)[i+offset])) {
5193 if (real)
486ec47a 5194 sv_2mortal(*dst); /* free them eventually */
36477c24 5195 }
31c61add
FC		 5196 else
5197 *dst = &PL_sv_undef;
5198 dst++;
a0d0e21e
LW		 5199 }
5200 MARK += length - 1;
79072805 5201 }
a0d0e21e
LW		 5202 else {
5203 *MARK = AvARRAY(ary)[offset+length-1];
5204 if (AvREAL(ary)) {
d689ffdd 5205 sv_2mortal(*MARK);
a0d0e21e
LW		 5206 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5207 SvREFCNT_dec(*dst++); /* free them now */
79072805 5208 }
a0d0e21e 5209 }
93965878 5210 AvFILLp(ary) += diff;
a0d0e21e
LW		 5211
5212 /* pull up or down? */
5213
5214 if (offset < after) { /* easier to pull up */
5215 if (offset) { /* esp. if nothing to pull */
5216 src = &AvARRAY(ary)[offset-1];
5217 dst = src - diff; /* diff is negative */
5218 for (i = offset; i > 0; i--) /* can't trust Copy */
5219 *dst-- = *src--;
79072805 5220 }
a0d0e21e 5221 dst = AvARRAY(ary);
9c6bc640 5222 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
a0d0e21e
LW		 5223 AvMAX(ary) += diff;
5224 }
5225 else {
5226 if (after) { /* anything to pull down? */
5227 src = AvARRAY(ary) + offset + length;
5228 dst = src + diff; /* diff is negative */
5229 Move(src, dst, after, SV*);
79072805 5230 }
93965878 5231 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 5232 /* avoid later double free */
5233 }
5234 i = -diff;
5235 while (i)
ce0d59fd 5236 dst[--i] = NULL;
a0d0e21e
LW		 5237
5238 if (newlen) {
50528de0 5239 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e
LW		 5240 Safefree(tmparyval);
5241 }
5242 }
5243 else { /* no, expanding (or same) */
d3961450 5244 SV** tmparyval = NULL;
a0d0e21e 5245 if (length) {
a02a5408 5246 Newx(tmparyval, length, SV*); /* so remember deletion */
a0d0e21e
LW		 5247 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5248 }
5249
5250 if (diff > 0) { /* expanding */
a0d0e21e 5251 /* push up or down? */
a0d0e21e
LW		 5252 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5253 if (offset) {
5254 src = AvARRAY(ary);
5255 dst = src - diff;
5256 Move(src, dst, offset, SV*);
79072805 5257 }
9c6bc640 5258 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
a0d0e21e 5259 AvMAX(ary) += diff;
93965878 5260 AvFILLp(ary) += diff;
79072805
LW		 5261 }
5262 else {
93965878
NIS		 5263 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5264 av_extend(ary, AvFILLp(ary) + diff);
5265 AvFILLp(ary) += diff;
a0d0e21e
LW		 5266
5267 if (after) {
93965878 5268 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 5269 src = dst - diff;
5270 for (i = after; i; i--) {
5271 *dst-- = *src--;
5272 }
79072805
LW		 5273 }
5274 }
a0d0e21e
LW		 5275 }
5276
50528de0
WL		 5277 if (newlen) {
5278 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e 5279 }
50528de0 5280
a0d0e21e 5281 MARK = ORIGMARK + 1;
82334630 5282 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
a0d0e21e 5283 if (length) {
31c61add
FC		 5284 const bool real = cBOOL(AvREAL(ary));
5285 if (real)
bbce6d69 5286 EXTEND_MORTAL(length);
31c61add
FC		 5287 for (i = 0, dst = MARK; i < length; i++) {
5288 if ((*dst = tmparyval[i])) {
5289 if (real)
486ec47a 5290 sv_2mortal(*dst); /* free them eventually */
36477c24 5291 }
31c61add
FC		 5292 else *dst = &PL_sv_undef;
5293 dst++;
79072805
LW		 5294 }
5295 }
a0d0e21e
LW		 5296 MARK += length - 1;
5297 }
5298 else if (length--) {
5299 *MARK = tmparyval[length];
5300 if (AvREAL(ary)) {
d689ffdd 5301 sv_2mortal(*MARK);
a0d0e21e
LW		 5302 while (length-- > 0)
5303 SvREFCNT_dec(tmparyval[length]);
79072805 5304 }
79072805 5305 }
a0d0e21e 5306 else
3280af22 5307 *MARK = &PL_sv_undef;
d3961450 5308 Safefree(tmparyval);
79072805 5309 }
474af990
FR		 5310
5311 if (SvMAGICAL(ary))
5312 mg_set(MUTABLE_SV(ary));
5313
a0d0e21e 5314 SP = MARK;
79072805
LW		 5315 RETURN;
5316}
5317
a0d0e21e 5318PP(pp_push)
79072805 5319{
20b7effb 5320 dSP; dMARK; dORIGMARK; dTARGET;
eb578fdb 5321 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5322 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
79072805 5323
1b6737cc 5324 if (mg) {
ad64d0ec 5325 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
93965878
NIS		 5326 PUSHMARK(MARK);
5327 PUTBACK;
d343c3ef 5328 ENTER_with_name("call_PUSH");
3e0cb5de 5329 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5330 LEAVE_with_name("call_PUSH");
93965878 5331 SPAGAIN;
93965878 5332 }
a60c0954 5333 else {
cb077ed2 5334 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
89c14e2e 5335 PL_delaymagic = DM_DELAY;
a60c0954 5336 for (++MARK; MARK <= SP; MARK++) {
3ed356df
FC		 5337 SV *sv;
5338 if (*MARK) SvGETMAGIC(*MARK);
5339 sv = newSV(0);
a60c0954 5340 if (*MARK)
3ed356df 5341 sv_setsv_nomg(sv, *MARK);
0a75904b 5342 av_store(ary, AvFILLp(ary)+1, sv);
a60c0954 5343 }
354b0578 5344 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 5345 mg_set(MUTABLE_SV(ary));
89c14e2e
BB		 5346
5347 PL_delaymagic = 0;
6eeabd23
VP		 5348 }
5349 SP = ORIGMARK;
5350 if (OP_GIMME(PL_op, 0) != G_VOID) {
5351 PUSHi( AvFILL(ary) + 1 );
79072805 5352 }
79072805
LW		 5353 RETURN;
5354}
5355
b1c05ba5 5356/* also used for: pp_pop()*/
a0d0e21e 5357PP(pp_shift)
79072805 5358{
39644a26 5359 dSP;
538f5756 5360 AV * const av = PL_op->op_flags & OPf_SPECIAL
d4fc4415 5361 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
789b4bc9 5362 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
79072805 5363 EXTEND(SP, 1);
c2b4a044 5364 assert (sv);
d689ffdd 5365 if (AvREAL(av))
a0d0e21e
LW		 5366 (void)sv_2mortal(sv);
5367 PUSHs(sv);
79072805 5368 RETURN;
79072805
LW		 5369}
5370
a0d0e21e 5371PP(pp_unshift)
79072805 5372{
20b7effb 5373 dSP; dMARK; dORIGMARK; dTARGET;
eb578fdb 5374 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5375 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 5376
1b6737cc 5377 if (mg) {
ad64d0ec 5378 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
7fd66d9d 5379 PUSHMARK(MARK);
93965878 5380 PUTBACK;
d343c3ef 5381 ENTER_with_name("call_UNSHIFT");
36925d9e 5382 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5383 LEAVE_with_name("call_UNSHIFT");
93965878 5384 SPAGAIN;
93965878 5385 }
a60c0954 5386 else {
c70927a6 5387 SSize_t i = 0;
a60c0954
NIS		 5388 av_unshift(ary, SP - MARK);
5389 while (MARK < SP) {
1b6737cc 5390 SV * const sv = newSVsv(*++MARK);
a60c0954
NIS		 5391 (void)av_store(ary, i++, sv);
5392 }
79072805 5393 }
a0d0e21e 5394 SP = ORIGMARK;
6eeabd23 5395 if (OP_GIMME(PL_op, 0) != G_VOID) {
5658d0a9
LR		 5396 PUSHi( AvFILL(ary) + 1 );
5397 }
79072805 5398 RETURN;
79072805
LW		 5399}
5400
a0d0e21e 5401PP(pp_reverse)
79072805 5402{
20b7effb 5403 dSP; dMARK;
79072805 5404
82334630 5405 if (GIMME_V == G_ARRAY) {
484c818f
VP		 5406 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5407 AV *av;
5408
5409 /* See pp_sort() */
5410 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5411 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5412 av = MUTABLE_AV((*SP));
5413 /* In-place reversing only happens in void context for the array
5414 * assignment. We don't need to push anything on the stack. */
5415 SP = MARK;
5416
5417 if (SvMAGICAL(av)) {
c70927a6 5418 SSize_t i, j;
eb578fdb 5419 SV *tmp = sv_newmortal();
484c818f
VP		 5420 /* For SvCANEXISTDELETE */
5421 HV *stash;
5422 const MAGIC *mg;
5423 bool can_preserve = SvCANEXISTDELETE(av);
5424
b9f2b683 5425 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
eb578fdb 5426 SV *begin, *end;
484c818f
VP		 5427
5428 if (can_preserve) {
5429 if (!av_exists(av, i)) {
5430 if (av_exists(av, j)) {
eb578fdb 5431 SV *sv = av_delete(av, j, 0);
484c818f
VP		 5432 begin = *av_fetch(av, i, TRUE);
5433 sv_setsv_mg(begin, sv);
5434 }
5435 continue;
5436 }
5437 else if (!av_exists(av, j)) {
eb578fdb 5438 SV *sv = av_delete(av, i, 0);
484c818f
VP		 5439 end = *av_fetch(av, j, TRUE);
5440 sv_setsv_mg(end, sv);
5441 continue;
5442 }
5443 }
5444
5445 begin = *av_fetch(av, i, TRUE);
5446 end = *av_fetch(av, j, TRUE);
5447 sv_setsv(tmp, begin);
5448 sv_setsv_mg(begin, end);
5449 sv_setsv_mg(end, tmp);
5450 }
5451 }
5452 else {
5453 SV **begin = AvARRAY(av);
484c818f 5454
95a26d8e
VP		 5455 if (begin) {
5456 SV **end = begin + AvFILLp(av);
5457
5458 while (begin < end) {
eb578fdb 5459 SV * const tmp = *begin;
95a26d8e
VP		 5460 *begin++ = *end;
5461 *end-- = tmp;
5462 }
484c818f
VP		 5463 }
5464 }
5465 }
5466 else {
5467 SV **oldsp = SP;
5468 MARK++;
5469 while (MARK < SP) {
eb578fdb 5470 SV * const tmp = *MARK;
484c818f
VP		 5471 *MARK++ = *SP;
5472 *SP-- = tmp;
5473 }
5474 /* safe as long as stack cannot get extended in the above */
5475 SP = oldsp;
a0d0e21e 5476 }
79072805
LW		 5477 }
5478 else {
eb578fdb
KW		 5479 char *up;
5480 char *down;
5481 I32 tmp;
a0d0e21e
LW		 5482 dTARGET;
5483 STRLEN len;
79072805 5484
7e2040f0 5485 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 5486 if (SP - MARK > 1)
3280af22 5487 do_join(TARG, &PL_sv_no, MARK, SP);
1e21d011 5488 else {
789bd863 5489 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
1e21d011
B		 5490 }
5491
a0d0e21e
LW		 5492 up = SvPV_force(TARG, len);
5493 if (len > 1) {
7e2040f0 5494 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55 5495 U8* s = (U8*)SvPVX(TARG);
349d4f2f 5496 const U8* send = (U8*)(s + len);
a0ed51b3 5497 while (s < send) {
d742c382 5498 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 5499 s++;
5500 continue;
5501 }
5502 else {
4b88fb76 5503 if (!utf8_to_uvchr_buf(s, send, 0))
a0dbb045 5504 break;
dfe13c55 5505 up = (char*)s;
a0ed51b3 5506 s += UTF8SKIP(s);
dfe13c55 5507 down = (char*)(s - 1);
a0dbb045 5508 /* reverse this character */
a0ed51b3
LW		 5509 while (down > up) {
5510 tmp = *up;
5511 *up++ = *down;
eb160463 5512 *down-- = (char)tmp;
a0ed51b3
LW		 5513 }
5514 }
5515 }
5516 up = SvPVX(TARG);
5517 }
a0d0e21e
LW		 5518 down = SvPVX(TARG) + len - 1;
5519 while (down > up) {
5520 tmp = *up;
5521 *up++ = *down;
eb160463 5522 *down-- = (char)tmp;
a0d0e21e 5523 }
3aa33fe5 5524 (void)SvPOK_only_UTF8(TARG);
79072805 5525 }
a0d0e21e
LW		 5526 SP = MARK + 1;
5527 SETTARG;
79072805 5528 }
a0d0e21e 5529 RETURN;
79072805
LW		 5530}
5531
a0d0e21e 5532PP(pp_split)
79072805 5533{
20b7effb 5534 dSP; dTARG;
ef7999f1 5535 AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
eb578fdb 5536 IV limit = POPi; /* note, negative is forever */
1b6737cc 5537 SV * const sv = POPs;
a0d0e21e 5538 STRLEN len;
eb578fdb 5539 const char *s = SvPV_const(sv, len);
1b6737cc 5540 const bool do_utf8 = DO_UTF8(sv);
727b7506 5541 const char *strend = s + len;
eb578fdb
KW		 5542 PMOP *pm;
5543 REGEXP *rx;
5544 SV *dstr;
5545 const char *m;
c70927a6 5546 SSize_t iters = 0;
d14578b8
KW		 5547 const STRLEN slen = do_utf8
5548 ? utf8_length((U8*)s, (U8*)strend)
5549 : (STRLEN)(strend - s);
c70927a6 5550 SSize_t maxiters = slen + 10;
c1a7495a 5551 I32 trailing_empty = 0;
727b7506 5552 const char *orig;
1b6737cc 5553 const I32 origlimit = limit;
a0d0e21e
LW		 5554 I32 realarray = 0;
5555 I32 base;
f54cb97a 5556 const I32 gimme = GIMME_V;
941446f6 5557 bool gimme_scalar;
f54cb97a 5558 const I32 oldsave = PL_savestack_ix;
437d3b4e 5559 U32 make_mortal = SVs_TEMP;
7fba1cd6 5560 bool multiline = 0;
b37c2d43 5561 MAGIC *mg = NULL;
79072805 5562
44a8e56a 5563#ifdef DEBUGGING
5564 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5565#else
5566 pm = (PMOP*)POPs;
5567#endif
b3941ae9 5568 if (!pm)
5637ef5b 5569 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
aaa362c4 5570 rx = PM_GETRE(pm);
bbce6d69 5571
a62b1201 5572 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
dbc200c5 5573 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
bbce6d69 5574
971a9dd3 5575#ifdef USE_ITHREADS
20e98b0f 5576 if (pm->op_pmreplrootu.op_pmtargetoff) {
159b6efe 5577 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
bf7d93ea 5578 goto have_av;
20e98b0f 5579 }
971a9dd3 5580#else
20e98b0f
NC		 5581 if (pm->op_pmreplrootu.op_pmtargetgv) {
5582 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
bf7d93ea 5583 goto have_av;
971a9dd3 5584 }
20e98b0f 5585#endif
ef7999f1
FC		 5586 else if (pm->op_targ)
5587 ary = (AV *)PAD_SVl(pm->op_targ);
bcea25a7 5588 if (ary) {
bf7d93ea 5589 have_av:
a0d0e21e 5590 realarray = 1;
8ec5e241 5591 PUTBACK;
a0d0e21e 5592 av_extend(ary,0);
821956c5 5593 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
a0d0e21e 5594 av_clear(ary);
8ec5e241 5595 SPAGAIN;
ad64d0ec 5596 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
8ec5e241 5597 PUSHMARK(SP);
ad64d0ec 5598 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
8ec5e241
NIS		 5599 }
5600 else {
1c0b011c 5601 if (!AvREAL(ary)) {
1b6737cc 5602 I32 i;
1c0b011c 5603 AvREAL_on(ary);
abff13bb 5604 AvREIFY_off(ary);
1c0b011c 5605 for (i = AvFILLp(ary); i >= 0; i--)
d14578b8 5606 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 5607 }
5608 /* temporarily switch stacks */
8b7059b1 5609 SAVESWITCHSTACK(PL_curstack, ary);
8ec5e241 5610 make_mortal = 0;
1c0b011c 5611 }
79072805 5612 }
3280af22 5613 base = SP - PL_stack_base;
a0d0e21e 5614 orig = s;
dbc200c5 5615 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
613f191e 5616 if (do_utf8) {
76a77b1b 5617 while (isSPACE_utf8(s))
613f191e
TS		 5618 s += UTF8SKIP(s);
5619 }
a62b1201 5620 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
bbce6d69 5621 while (isSPACE_LC(*s))
5622 s++;
5623 }
5624 else {
5625 while (isSPACE(*s))
5626 s++;
5627 }
a0d0e21e 5628 }
73134a2e 5629 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
7fba1cd6 5630 multiline = 1;
c07a80fd 5631 }
5632
941446f6
FC		 5633 gimme_scalar = gimme == G_SCALAR && !ary;
5634
a0d0e21e
LW		 5635 if (!limit)
5636 limit = maxiters + 2;
dbc200c5 5637 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
a0d0e21e 5638 while (--limit) {
bbce6d69 5639 m = s;
8727f688
YO		 5640 /* this one uses 'm' and is a negative test */
5641 if (do_utf8) {
76a77b1b 5642 while (m < strend && ! isSPACE_utf8(m) ) {
613f191e 5643 const int t = UTF8SKIP(m);
76a77b1b 5644 /* isSPACE_utf8 returns FALSE for malform utf8 */
613f191e
TS		 5645 if (strend - m < t)
5646 m = strend;
5647 else
5648 m += t;
5649 }
a62b1201 5650 }
d14578b8
KW		 5651 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5652 {
8727f688
YO		 5653 while (m < strend && !isSPACE_LC(*m))
5654 ++m;
5655 } else {
5656 while (m < strend && !isSPACE(*m))
5657 ++m;
5658 }
a0d0e21e
LW		 5659 if (m >= strend)
5660 break;
bbce6d69 5661
c1a7495a
BB		 5662 if (gimme_scalar) {
5663 iters++;
5664 if (m-s == 0)
5665 trailing_empty++;
5666 else
5667 trailing_empty = 0;
5668 } else {
5669 dstr = newSVpvn_flags(s, m-s,
5670 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5671 XPUSHs(dstr);
5672 }
bbce6d69 5673
613f191e
TS		 5674 /* skip the whitespace found last */
5675 if (do_utf8)
5676 s = m + UTF8SKIP(m);
5677 else
5678 s = m + 1;
5679
8727f688
YO		 5680 /* this one uses 's' and is a positive test */
5681 if (do_utf8) {
76a77b1b 5682 while (s < strend && isSPACE_utf8(s) )
8727f688 5683 s += UTF8SKIP(s);
a62b1201 5684 }
d14578b8
KW		 5685 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5686 {
8727f688
YO		 5687 while (s < strend && isSPACE_LC(*s))
5688 ++s;
5689 } else {
5690 while (s < strend && isSPACE(*s))
5691 ++s;
5692 }
79072805
LW		 5693 }
5694 }
07bc277f 5695 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
a0d0e21e 5696 while (--limit) {
a6e20a40
AL		 5697 for (m = s; m < strend && *m != '\n'; m++)
5698 ;
a0d0e21e
LW		 5699 m++;
5700 if (m >= strend)
5701 break;
c1a7495a
BB		 5702
5703 if (gimme_scalar) {
5704 iters++;
5705 if (m-s == 0)
5706 trailing_empty++;
5707 else
5708 trailing_empty = 0;
5709 } else {
5710 dstr = newSVpvn_flags(s, m-s,
5711 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5712 XPUSHs(dstr);
5713 }
a0d0e21e
LW		 5714 s = m;
5715 }
5716 }
07bc277f 5717 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
640f820d
AB		 5718 /*
5719 Pre-extend the stack, either the number of bytes or
5720 characters in the string or a limited amount, triggered by:
5721
5722 my ($x, $y) = split //, $str;
5723 or
5724 split //, $str, $i;
5725 */
c1a7495a
BB		 5726 if (!gimme_scalar) {
5727 const U32 items = limit - 1;
5728 if (items < slen)
5729 EXTEND(SP, items);
5730 else
5731 EXTEND(SP, slen);
5732 }
640f820d 5733
e9515b0f
AB		 5734 if (do_utf8) {
5735 while (--limit) {
5736 /* keep track of how many bytes we skip over */
5737 m = s;
640f820d 5738 s += UTF8SKIP(s);
c1a7495a
BB		 5739 if (gimme_scalar) {
5740 iters++;
5741 if (s-m == 0)
5742 trailing_empty++;
5743 else
5744 trailing_empty = 0;
5745 } else {
5746 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
640f820d 5747
c1a7495a
BB		 5748 PUSHs(dstr);
5749 }
640f820d 5750
e9515b0f
AB		 5751 if (s >= strend)
5752 break;
5753 }
5754 } else {
5755 while (--limit) {
c1a7495a
BB		 5756 if (gimme_scalar) {
5757 iters++;
5758 } else {
5759 dstr = newSVpvn(s, 1);
e9515b0f 5760
e9515b0f 5761
c1a7495a
BB		 5762 if (make_mortal)
5763 sv_2mortal(dstr);
640f820d 5764
c1a7495a
BB		 5765 PUSHs(dstr);
5766 }
5767
5768 s++;
e9515b0f
AB		 5769
5770 if (s >= strend)
5771 break;
5772 }
640f820d
AB		 5773 }
5774 }
3c8556c3 5775 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
07bc277f
NC		 5776 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5777 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
8e1490ee 5778 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
07bc277f 5779 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
f9f4320a 5780 SV * const csv = CALLREG_INTUIT_STRING(rx);
cf93c79d 5781
07bc277f 5782 len = RX_MINLENRET(rx);
3c8556c3 5783 if (len == 1 && !RX_UTF8(rx) && !tail) {
1b6737cc 5784 const char c = *SvPV_nolen_const(csv);
a0d0e21e 5785 while (--limit) {
a6e20a40
AL		 5786 for (m = s; m < strend && *m != c; m++)
5787 ;
a0d0e21e
LW		 5788 if (m >= strend)
5789 break;
c1a7495a
BB		 5790 if (gimme_scalar) {
5791 iters++;
5792 if (m-s == 0)
5793 trailing_empty++;
5794 else
5795 trailing_empty = 0;
5796 } else {
5797 dstr = newSVpvn_flags(s, m-s,
d14578b8 5798 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
c1a7495a
BB		 5799 XPUSHs(dstr);
5800 }
93f04dac
JH		 5801 /* The rx->minlen is in characters but we want to step
5802 * s ahead by bytes. */
1aa99e6b
IH		 5803 if (do_utf8)
5804 s = (char*)utf8_hop((U8*)m, len);
5805 else
5806 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 5807 }
5808 }
5809 else {
a0d0e21e 5810 while (s < strend && --limit &&
f722798b 5811 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
7fba1cd6 5812 csv, multiline ? FBMrf_MULTILINE : 0)) )
a0d0e21e 5813 {
c1a7495a
BB		 5814 if (gimme_scalar) {
5815 iters++;
5816 if (m-s == 0)
5817 trailing_empty++;
5818 else
5819 trailing_empty = 0;
5820 } else {
5821 dstr = newSVpvn_flags(s, m-s,
d14578b8 5822 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
c1a7495a
BB		 5823 XPUSHs(dstr);
5824 }
93f04dac
JH		 5825 /* The rx->minlen is in characters but we want to step
5826 * s ahead by bytes. */
1aa99e6b
IH		 5827 if (do_utf8)
5828 s = (char*)utf8_hop((U8*)m, len);
5829 else
5830 s = m + len; /* Fake \n at the end */
a0d0e21e 5831 }
463ee0b2 5832 }
463ee0b2 5833 }
a0d0e21e 5834 else {
07bc277f 5835 maxiters += slen * RX_NPARENS(rx);
080c2dec 5836 while (s < strend && --limit)
bbce6d69 5837 {
1b6737cc 5838 I32 rex_return;
080c2dec 5839 PUTBACK;
d14578b8 5840 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
c33e64f0 5841 sv, NULL, 0);
080c2dec 5842 SPAGAIN;
1b6737cc 5843 if (rex_return == 0)
080c2dec 5844 break;
d9f97599 5845 TAINT_IF(RX_MATCH_TAINTED(rx));
6502e081
DM		 5846 /* we never pass the REXEC_COPY_STR flag, so it should
5847 * never get copied */
5848 assert(!RX_MATCH_COPIED(rx));
07bc277f 5849 m = RX_OFFS(rx)[0].start + orig;
c1a7495a
BB		 5850
5851 if (gimme_scalar) {
5852 iters++;
5853 if (m-s == 0)
5854 trailing_empty++;
5855 else
5856 trailing_empty = 0;
5857 } else {
5858 dstr = newSVpvn_flags(s, m-s,
5859 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5860 XPUSHs(dstr);
5861 }
07bc277f 5862 if (RX_NPARENS(rx)) {
1b6737cc 5863 I32 i;
07bc277f
NC		 5864 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5865 s = RX_OFFS(rx)[i].start + orig;
5866 m = RX_OFFS(rx)[i].end + orig;
6de67870
JP		 5867
5868 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5869 parens that didn't match -- they should be set to
5870 undef, not the empty string */
c1a7495a
BB		 5871 if (gimme_scalar) {
5872 iters++;
5873 if (m-s == 0)
5874 trailing_empty++;
5875 else
5876 trailing_empty = 0;
5877 } else {
5878 if (m >= orig && s >= orig) {
5879 dstr = newSVpvn_flags(s, m-s,
5880 (do_utf8 ? SVf_UTF8 : 0)
5881 | make_mortal);
5882 }
5883 else
5884 dstr = &PL_sv_undef; /* undef, not "" */
5885 XPUSHs(dstr);
748a9306 5886 }
c1a7495a 5887
a0d0e21e
LW		 5888 }
5889 }
07bc277f 5890 s = RX_OFFS(rx)[0].end + orig;
a0d0e21e 5891 }
79072805 5892 }
8ec5e241 5893
c1a7495a
BB		 5894 if (!gimme_scalar) {
5895 iters = (SP - PL_stack_base) - base;
5896 }
a0d0e21e 5897 if (iters > maxiters)
cea2e8a9 5898 DIE(aTHX_ "Split loop");
8ec5e241 5899
a0d0e21e
LW		 5900 /* keep field after final delim? */
5901 if (s < strend || (iters && origlimit)) {
c1a7495a
BB		 5902 if (!gimme_scalar) {
5903 const STRLEN l = strend - s;
5904 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5905 XPUSHs(dstr);
5906 }
a0d0e21e 5907 iters++;
79072805 5908 }
a0d0e21e 5909 else if (!origlimit) {
c1a7495a
BB		 5910 if (gimme_scalar) {
5911 iters -= trailing_empty;
5912 } else {
5913 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5914 if (TOPs && !make_mortal)
5915 sv_2mortal(TOPs);
5916 *SP-- = &PL_sv_undef;
5917 iters--;
5918 }
89900bd3 5919 }
a0d0e21e 5920 }
8ec5e241 5921
8b7059b1
DM		 5922 PUTBACK;
5923 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5924 SPAGAIN;
a0d0e21e 5925 if (realarray) {
8ec5e241 5926 if (!mg) {
1c0b011c
NIS		 5927 if (SvSMAGICAL(ary)) {
5928 PUTBACK;
ad64d0ec 5929 mg_set(MUTABLE_SV(ary));
1c0b011c
NIS		 5930 SPAGAIN;
5931 }
5932 if (gimme == G_ARRAY) {
5933 EXTEND(SP, iters);
5934 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5935 SP += iters;
5936 RETURN;
5937 }
8ec5e241 5938 }
1c0b011c 5939 else {
fb73857a 5940 PUTBACK;
d343c3ef 5941 ENTER_with_name("call_PUSH");
36925d9e 5942 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5943 LEAVE_with_name("call_PUSH");
fb73857a 5944 SPAGAIN;
8ec5e241 5945 if (gimme == G_ARRAY) {
c70927a6 5946 SSize_t i;
8ec5e241
NIS		 5947 /* EXTEND should not be needed - we just popped them */
5948 EXTEND(SP, iters);
5949 for (i=0; i < iters; i++) {
5950 SV **svp = av_fetch(ary, i, FALSE);
3280af22 5951 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 5952 }
1c0b011c
NIS		 5953 RETURN;
5954 }
a0d0e21e
LW		 5955 }
5956 }
5957 else {
5958 if (gimme == G_ARRAY)
5959 RETURN;
5960 }
7f18b612
YST		 5961
5962 GETTARGET;
5963 PUSHi(iters);
5964 RETURN;
79072805 5965}
85e6fe83 5966
c5917253
NC		 5967PP(pp_once)
5968{
5969 dSP;
5970 SV *const sv = PAD_SVl(PL_op->op_targ);
5971
5972 if (SvPADSTALE(sv)) {
5973 /* First time. */
5974 SvPADSTALE_off(sv);
5975 RETURNOP(cLOGOP->op_other);
5976 }
5977 RETURNOP(cLOGOP->op_next);
5978}
5979
c0329465
MB		 5980PP(pp_lock)
5981{
39644a26 5982 dSP;
c0329465 5983 dTOPss;
e55aaa0e 5984 SV *retsv = sv;
68795e93 5985 SvLOCK(sv);
f79aa60b
FC		 5986 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5987 || SvTYPE(retsv) == SVt_PVCV) {
e55aaa0e
MB		 5988 retsv = refto(retsv);
5989 }
5990 SETs(retsv);
c0329465
MB		 5991 RETURN;
5992}
a863c7d1 5993
65bca31a 5994
b1c05ba5
DM		 5995/* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
5996 * that aren't implemented on a particular platform */
5997
65bca31a
NC		 5998PP(unimplemented_op)
5999{
361ed549
NC		 6000 const Optype op_type = PL_op->op_type;
6001 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6002 with out of range op numbers - it only "special" cases op_custom.
6003 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6004 if we get here for a custom op then that means that the custom op didn't
6005 have an implementation. Given that OP_NAME() looks up the custom op
6006 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6007 registers &PL_unimplemented_op as the address of their custom op.
6008 NULL doesn't generate a useful error message. "custom" does. */
6009 const char *const name = op_type >= OP_max
6010 ? "[out of range]" : PL_op_name[PL_op->op_type];
7627e6d0
NC		 6011 if(OP_IS_SOCKET(op_type))
6012 DIE(aTHX_ PL_no_sock_func, name);
361ed549 6013 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
65bca31a
NC		 6014}
6015
deb8a388
FC		 6016/* For sorting out arguments passed to a &CORE:: subroutine */
6017PP(pp_coreargs)
6018{
6019 dSP;
7fa5bd9b 6020 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
498a02d8 6021 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
7fa5bd9b 6022 AV * const at_ = GvAV(PL_defgv);
0e80230d
FC		 6023 SV **svp = at_ ? AvARRAY(at_) : NULL;
6024 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
7fa5bd9b 6025 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
46e00a91 6026 bool seen_question = 0;
7fa5bd9b 6027 const char *err = NULL;
3e6568b4 6028 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
7fa5bd9b 6029
46e00a91
FC		 6030 /* Count how many args there are first, to get some idea how far to
6031 extend the stack. */
7fa5bd9b 6032 while (oa) {
bf0571fd 6033 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
7fa5bd9b 6034 maxargs++;
46e00a91
FC		 6035 if (oa & OA_OPTIONAL) seen_question = 1;
6036 if (!seen_question) minargs++;
7fa5bd9b
FC		 6037 oa >>= 4;
6038 }
6039
6040 if(numargs < minargs) err = "Not enough";
6041 else if(numargs > maxargs) err = "Too many";
6042 if (err)
6043 /* diag_listed_as: Too many arguments for %s */
6044 Perl_croak(aTHX_
6045 "%s arguments for %s", err,
2a90c7c6 6046 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
7fa5bd9b
FC		 6047 );
6048
6049 /* Reset the stack pointer. Without this, we end up returning our own
6050 arguments in list context, in addition to the values we are supposed
6051 to return. nextstate usually does this on sub entry, but we need
e1fa07e3 6052 to run the next op with the caller's hints, so we cannot have a
7fa5bd9b
FC		 6053 nextstate. */
6054 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
6055
46e00a91
FC		 6056 if(!maxargs) RETURN;
6057
bf0571fd
FC		 6058 /* We do this here, rather than with a separate pushmark op, as it has
6059 to come in between two things this function does (stack reset and
6060 arg pushing). This seems the easiest way to do it. */
3e6568b4 6061 if (pushmark) {
bf0571fd
FC		 6062 PUTBACK;
6063 (void)Perl_pp_pushmark(aTHX);
6064 }
6065
6066 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
c931b036 6067 PUTBACK; /* The code below can die in various places. */
46e00a91
FC		 6068
6069 oa = PL_opargs[opnum] >> OASHIFT;
3e6568b4 6070 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
c931b036 6071 whicharg++;
46e00a91
FC		 6072 switch (oa & 7) {
6073 case OA_SCALAR:
1efec5ed 6074 try_defsv:
d6d78e19 6075 if (!numargs && defgv && whicharg == minargs + 1) {
d6d78e19 6076 PUSHs(find_rundefsv2(
db4cf31d 6077 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
b4b0692a 6078 cxstack[cxstack_ix].blk_oldcop->cop_seq
d6d78e19
FC		 6079 ));
6080 }
6081 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
46e00a91 6082 break;
bf0571fd
FC		 6083 case OA_LIST:
6084 while (numargs--) {
6085 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6086 svp++;
6087 }
6088 RETURN;
19c481f4
FC		 6089 case OA_HVREF:
6090 if (!svp || !*svp || !SvROK(*svp)
6091 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
6092 DIE(aTHX_
6093 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6094 "Type of arg %d to &CORE::%s must be hash reference",
6095 whicharg, OP_DESC(PL_op->op_next)
6096 );
6097 PUSHs(SvRV(*svp));
6098 break;
c931b036 6099 case OA_FILEREF:
30901a8a
FC		 6100 if (!numargs) PUSHs(NULL);
6101 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
c931b036
FC		 6102 /* no magic here, as the prototype will have added an extra
6103 refgen and we just want what was there before that */
6104 PUSHs(SvRV(*svp));
6105 else {
6106 const bool constr = PL_op->op_private & whicharg;
6107 PUSHs(S_rv2gv(aTHX_
6108 svp && *svp ? *svp : &PL_sv_undef,
b54f893d 6109 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
c931b036
FC		 6110 !constr
6111 ));
6112 }
6113 break;
c72a5629 6114 case OA_SCALARREF:
1efec5ed
FC		 6115 if (!numargs) goto try_defsv;
6116 else {
17008668
FC		 6117 const bool wantscalar =
6118 PL_op->op_private & OPpCOREARGS_SCALARMOD;
c72a5629 6119 if (!svp || !*svp || !SvROK(*svp)
17008668
FC		 6120 /* We have to permit globrefs even for the \$ proto, as
6121 *foo is indistinguishable from ${\*foo}, and the proto-
6122 type permits the latter. */
6123 || SvTYPE(SvRV(*svp)) > (
efe889ae 6124 wantscalar ? SVt_PVLV
46bef06f
FC		 6125 : opnum == OP_LOCK || opnum == OP_UNDEF
6126 ? SVt_PVCV
efe889ae 6127 : SVt_PVHV
17008668 6128 )
c72a5629
FC		 6129 )
6130 DIE(aTHX_
17008668 6131 "Type of arg %d to &CORE::%s must be %s",
46bef06f 6132 whicharg, PL_op_name[opnum],
17008668
FC		 6133 wantscalar
6134 ? "scalar reference"
46bef06f 6135 : opnum == OP_LOCK || opnum == OP_UNDEF
efe889ae
FC		 6136 ? "reference to one of [$@%&*]"
6137 : "reference to one of [$@%*]"
c72a5629
FC		 6138 );
6139 PUSHs(SvRV(*svp));
88bb468b
FC		 6140 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6141 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6142 /* Undo @_ localisation, so that sub exit does not undo
6143 part of our undeffing. */
6144 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6145 POP_SAVEARRAY();
6146 cx->cx_type &= ~ CXp_HASARGS;
6147 assert(!AvREAL(cx->blk_sub.argarray));
6148 }
17008668 6149 }
1efec5ed 6150 break;
46e00a91 6151 default:
46e00a91
FC		 6152 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6153 }
6154 oa = oa >> 4;
6155 }
6156
deb8a388
FC		 6157 RETURN;
6158}
6159
84ed0108
FC		 6160PP(pp_runcv)
6161{
6162 dSP;
6163 CV *cv;
6164 if (PL_op->op_private & OPpOFFBYONE) {
db4cf31d 6165 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
84ed0108
FC		 6166 }
6167 else cv = find_runcv(NULL);
e157a82b 6168 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
84ed0108
FC		 6169 RETURN;
6170}
6171
05a34802 6172static void
2331e434 6173S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
05a34802
FC		 6174 const bool can_preserve)
6175{
2331e434 6176 const SSize_t ix = SvIV(keysv);
05a34802
FC		 6177 if (can_preserve ? av_exists(av, ix) : TRUE) {
6178 SV ** const svp = av_fetch(av, ix, 1);
6179 if (!svp || !*svp)
6180 Perl_croak(aTHX_ PL_no_aelem, ix);
6181 save_aelem(av, ix, svp);
6182 }
6183 else
6184 SAVEADELETE(av, ix);
6185}
6186
5f94141d
FC		 6187static void
6188S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6189 const bool can_preserve)
6190{
6191 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6192 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6193 SV ** const svp = he ? &HeVAL(he) : NULL;
6194 if (!svp || !*svp)
6195 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6196 save_helem_flags(hv, keysv, svp, 0);
6197 }
6198 else
6199 SAVEHDELETE(hv, keysv);
6200}
6201
9782ce69
FC		 6202static void
6203S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6204{
6205 if (type == OPpLVREF_SV) {
6206 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6207 GvSV(gv) = 0;
6208 }
6209 else if (type == OPpLVREF_AV)
6210 /* XXX Inefficient, as it creates a new AV, which we are
6211 about to clobber. */
6212 save_ary(gv);
6213 else {
6214 assert(type == OPpLVREF_HV);
6215 /* XXX Likewise inefficient. */
6216 save_hash(gv);
6217 }
6218}
6219
6220
254da51f
FC		 6221PP(pp_refassign)
6222{
4fec8804 6223 dSP;
6102323a 6224 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
d8a875d9 6225 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
4fec8804 6226 dTOPss;
3f114923 6227 const char *bad = NULL;
ac0da85a 6228 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
4fec8804 6229 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
ac0da85a 6230 switch (type) {
3f114923
FC		 6231 case OPpLVREF_SV:
6232 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6233 bad = " SCALAR";
6234 break;
6235 case OPpLVREF_AV:
6236 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6237 bad = "n ARRAY";
6238 break;
6239 case OPpLVREF_HV:
6240 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6241 bad = " HASH";
6242 break;
6243 case OPpLVREF_CV:
6244 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6245 bad = " CODE";
6246 }
6247 if (bad)
1f8155a2 6248 /* diag_listed_as: Assigned value is not %s reference */
3f114923 6249 DIE(aTHX_ "Assigned value is not a%s reference", bad);
b943805e
JH		 6250 {
6251 MAGIC *mg;
6252 HV *stash;
d8a875d9
FC		 6253 switch (left ? SvTYPE(left) : 0) {
6254 case 0:
cf5d2d91
FC		 6255 {
6256 SV * const old = PAD_SV(ARGTARG);
d8a875d9 6257 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
cf5d2d91 6258 SvREFCNT_dec(old);
3ad7d304
FC		 6259 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6260 == OPpLVAL_INTRO)
fc048fcf 6261 SAVECLEARSV(PAD_SVl(ARGTARG));
d8a875d9 6262 break;
cf5d2d91 6263 }
d8a875d9 6264 case SVt_PVGV:
2a57afb1 6265 if (PL_op->op_private & OPpLVAL_INTRO) {
9782ce69 6266 S_localise_gv_slot(aTHX_ (GV *)left, type);
2a57afb1 6267 }
d8a875d9
FC		 6268 gv_setref(left, sv);
6269 SvSETMAGIC(left);
6102323a
FC		 6270 break;
6271 case SVt_PVAV:
40d2b828 6272 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
2331e434 6273 S_localise_aelem_lval(aTHX_ (AV *)left, key,
05a34802 6274 SvCANEXISTDELETE(left));
40d2b828 6275 }
6102323a
FC		 6276 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6277 break;
5f94141d
FC		 6278 case SVt_PVHV:
6279 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
6280 S_localise_helem_lval(aTHX_ (HV *)left, key,
6281 SvCANEXISTDELETE(left));
7fcb36d5 6282 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
d8a875d9 6283 }
4fec8804
FC		 6284 if (PL_op->op_flags & OPf_MOD)
6285 SETs(sv_2mortal(newSVsv(sv)));
6286 /* XXX else can weak references go stale before they are read, e.g.,
6287 in leavesub? */
6288 RETURN;
b943805e 6289 }
254da51f
FC		 6290}
6291
4c5bab50
FC		 6292PP(pp_lvref)
6293{
26a50d99
FC		 6294 dSP;
6295 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6102323a 6296 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
2a57afb1 6297 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
9782ce69
FC		 6298 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6299 &PL_vtbl_lvref, (char *)elem,
23270f96 6300 elem ? HEf_SVKEY : (I32)ARGTARG);
9782ce69 6301 mg->mg_private = PL_op->op_private;
d39c26a6
FC		 6302 if (PL_op->op_private & OPpLVREF_ITER)
6303 mg->mg_flags |= MGf_PERSIST;
9846cd95 6304 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
40d2b828
FC		 6305 if (elem) {
6306 MAGIC *mg;
6307 HV *stash;
5f94141d
FC		 6308 const bool can_preserve = SvCANEXISTDELETE(arg);
6309 if (SvTYPE(arg) == SVt_PVAV)
2331e434 6310 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
5f94141d
FC		 6311 else
6312 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
40d2b828
FC		 6313 }
6314 else if (arg) {
9782ce69
FC		 6315 S_localise_gv_slot(aTHX_ (GV *)arg,
6316 PL_op->op_private & OPpLVREF_TYPE);
2a57afb1 6317 }
3ad7d304 6318 else if (!(PL_op->op_private & OPpPAD_STATE))
c146a62a 6319 SAVECLEARSV(PAD_SVl(ARGTARG));
1199b01a 6320 }
c146a62a
FC		 6321 XPUSHs(ret);
6322 RETURN;
4c5bab50 6323}
84ed0108 6324
16b99412
FC		 6325PP(pp_lvrefslice)
6326{
a95dad8a 6327 dSP; dMARK;
0ca7b7f7
FC		 6328 AV * const av = (AV *)POPs;
6329 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6330 bool can_preserve = FALSE;
6331
9846cd95 6332 if (UNLIKELY(localizing)) {
0ca7b7f7
FC		 6333 MAGIC *mg;
6334 HV *stash;
6335 SV **svp;
6336
6337 can_preserve = SvCANEXISTDELETE(av);
6338
6339 if (SvTYPE(av) == SVt_PVAV) {
6340 SSize_t max = -1;
6341
6342 for (svp = MARK + 1; svp <= SP; svp++) {
6343 const SSize_t elem = SvIV(*svp);
6344 if (elem > max)
6345 max = elem;
6346 }
6347 if (max > AvMAX(av))
6348 av_extend(av, max);
6349 }
6350 }
6351
6352 while (++MARK <= SP) {
6353 SV * const elemsv = *MARK;
5f94141d 6354 if (SvTYPE(av) == SVt_PVAV)
2331e434 6355 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
5f94141d
FC		 6356 else
6357 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
0ca7b7f7
FC		 6358 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6359 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6360 }
6361 RETURN;
16b99412
FC		 6362}
6363
2882b3ff
FC		 6364PP(pp_lvavref)
6365{
bdaf10a5
FC		 6366 if (PL_op->op_flags & OPf_STACKED)
6367 Perl_pp_rv2av(aTHX);
6368 else
6369 Perl_pp_padav(aTHX);
6370 {
6371 dSP;
6372 dTOPss;
6373 SETs(0); /* special alias marker that aassign recognises */
6374 XPUSHs(sv);
6375 RETURN;
6376 }
2882b3ff
FC		 6377}
6378
b77472f9
FC		 6379PP(pp_anonconst)
6380{
6381 dSP;
6382 dTOPss;
6383 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6384 ? CopSTASH(PL_curcop)
6385 : NULL,
6386 NULL, SvREFCNT_inc_simple_NN(sv))));
6387 RETURN;
6388}
6389
e609e586
NC		 6390/*
6391 * Local variables:
6392 * c-indentation-style: bsd
6393 * c-basic-offset: 4
14d04a33 6394 * indent-tabs-mode: nil
e609e586
NC		 6395 * End:
6396 *
14d04a33 6397 * ex: set ts=8 sts=4 sw=4 et:
37442d52 6398 */
Unnamed repository; edit this file 'description' to name the repository.