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