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