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