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