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