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