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