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
rename RXf_UNUSED flags to match their BASE_SHIFT offset
[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);
4f6386b6 3327 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
121910a4
JH		 3328 argsv = tmpsv;
3329 }
79072805 3330
d8f42585 3331 XPUSHu(DO_UTF8(argsv)
4f6386b6 3332 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
f3943cf2 3333 : (UV)(*s));
68795e93 3334
79072805
LW		 3335 RETURN;
3336}
3337
463ee0b2
LW		 3338PP(pp_chr)
3339{
97aff369 3340 dVAR; dSP; dTARGET;
463ee0b2 3341 char *tmps;
8a064bd6 3342 UV value;
71739502 3343 SV *top = POPs;
8a064bd6 3344
71739502
FC		 3345 SvGETMAGIC(top);
3346 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3347 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
8a064bd6 3348 ||
71739502
FC		 3349 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3350 && SvNV_nomg(top) < 0.0))) {
b3fe8680
FC		 3351 if (ckWARN(WARN_UTF8)) {
3352 if (SvGMAGICAL(top)) {
3353 SV *top2 = sv_newmortal();
3354 sv_setsv_nomg(top2, top);
3355 top = top2;
3356 }
3357 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3358 "Invalid negative number (%"SVf") in chr", top);
3359 }
8a064bd6 3360 value = UNICODE_REPLACEMENT;
8a064bd6 3361 } else {
71739502 3362 value = SvUV_nomg(top);
8a064bd6 3363 }
463ee0b2 3364
862a34c6 3365 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3366
0064a8a9 3367 if (value > 255 && !IN_BYTES) {
eb160463 3368 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3369 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3370 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW		 3371 *tmps = '\0';
3372 (void)SvPOK_only(TARG);
aa6ffa16 3373 SvUTF8_on(TARG);
a0ed51b3
LW		 3374 XPUSHs(TARG);
3375 RETURN;
3376 }
3377
748a9306 3378 SvGROW(TARG,2);
463ee0b2
LW		 3379 SvCUR_set(TARG, 1);
3380 tmps = SvPVX(TARG);
eb160463 3381 *tmps++ = (char)value;
748a9306 3382 *tmps = '\0';
a0d0e21e 3383 (void)SvPOK_only(TARG);
4c5ed6e2 3384
88632417 3385 if (PL_encoding && !IN_BYTES) {
799ef3cb 3386 sv_recode_to_utf8(TARG, PL_encoding);
88632417 3387 tmps = SvPVX(TARG);
28936164
KW		 3388 if (SvCUR(TARG) == 0
3389 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3390 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3391 {
4c5ed6e2 3392 SvGROW(TARG, 2);
d5a15ac2 3393 tmps = SvPVX(TARG);
4c5ed6e2
TS		 3394 SvCUR_set(TARG, 1);
3395 *tmps++ = (char)value;
88632417 3396 *tmps = '\0';
4c5ed6e2 3397 SvUTF8_off(TARG);
88632417
JH		 3398 }
3399 }
4c5ed6e2 3400
463ee0b2
LW		 3401 XPUSHs(TARG);
3402 RETURN;
3403}
3404
79072805
LW		 3405PP(pp_crypt)
3406{
79072805 3407#ifdef HAS_CRYPT
97aff369 3408 dVAR; dSP; dTARGET;
5f74f29c 3409 dPOPTOPssrl;
85c16d83 3410 STRLEN len;
10516c54 3411 const char *tmps = SvPV_const(left, len);
2bc69dc4 3412
85c16d83 3413 if (DO_UTF8(left)) {
2bc69dc4 3414 /* If Unicode, try to downgrade.
f2791508
JH		 3415 * If not possible, croak.
3416 * Yes, we made this up. */
1b6737cc 3417 SV* const tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3418
f2791508 3419 SvUTF8_on(tsv);
2bc69dc4 3420 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3421 tmps = SvPV_const(tsv, len);
85c16d83 3422 }
05404ffe
JH		 3423# ifdef USE_ITHREADS
3424# ifdef HAS_CRYPT_R
3425 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3426 /* This should be threadsafe because in ithreads there is only
3427 * one thread per interpreter. If this would not be true,
3428 * we would need a mutex to protect this malloc. */
3429 PL_reentrant_buffer->_crypt_struct_buffer =
3430 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3431#if defined(__GLIBC__) || defined(__EMX__)
3432 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3433 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3434 /* work around glibc-2.2.5 bug */
3435 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3436 }
05404ffe 3437#endif
6ab58e4d 3438 }
05404ffe
JH		 3439# endif /* HAS_CRYPT_R */
3440# endif /* USE_ITHREADS */
5f74f29c 3441# ifdef FCRYPT
83003860 3442 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3443# else
83003860 3444 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3445# endif
ec93b65f 3446 SETTARG;
4808266b 3447 RETURN;
79072805 3448#else
b13b2135 3449 DIE(aTHX_
79072805
LW		 3450 "The crypt() function is unimplemented due to excessive paranoia.");
3451#endif
79072805
LW		 3452}
3453
00f254e2
KW		 3454/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3455 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3456
79072805
LW		 3457PP(pp_ucfirst)
3458{
00f254e2
KW		 3459 /* Actually is both lcfirst() and ucfirst(). Only the first character
3460 * changes. This means that possibly we can change in-place, ie., just
3461 * take the source and change that one character and store it back, but not
3462 * if read-only etc, or if the length changes */
3463
97aff369 3464 dVAR;
39644a26 3465 dSP;
d54190f6 3466 SV *source = TOPs;
00f254e2 3467 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC		 3468 STRLEN need;
3469 SV *dest;
00f254e2
KW		 3470 bool inplace; /* ? Convert first char only, in-place */
3471 bool doing_utf8 = FALSE; /* ? using utf8 */
3472 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3473 const int op_type = PL_op->op_type;
d54190f6
NC		 3474 const U8 *s;
3475 U8 *d;
3476 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW		 3477 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3478 * stored as UTF-8 at s. */
3479 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3480 * lowercased) character stored in tmpbuf. May be either
3481 * UTF-8 or not, but in either case is the number of bytes */
d54190f6 3482
841a5e18 3483 s = (const U8*)SvPV_const(source, slen);
a0ed51b3 3484
00f254e2
KW		 3485 /* We may be able to get away with changing only the first character, in
3486 * place, but not if read-only, etc. Later we may discover more reasons to
3487 * not convert in-place. */
5cd5e2d6
FC		 3488 inplace = !SvREADONLY(source)
3489 && ( SvPADTMP(source)
3490 || ( SvTEMP(source) && !SvSMAGICAL(source)
3491 && SvREFCNT(source) == 1));
00f254e2
KW		 3492
3493 /* First calculate what the changed first character should be. This affects
3494 * whether we can just swap it out, leaving the rest of the string unchanged,
3495 * or even if have to convert the dest to UTF-8 when the source isn't */
3496
3497 if (! slen) { /* If empty */
3498 need = 1; /* still need a trailing NUL */
b7576bcb 3499 ulen = 0;
00f254e2
KW		 3500 }
3501 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3502 doing_utf8 = TRUE;
17e95c9d 3503 ulen = UTF8SKIP(s);
094a2f8c 3504 if (op_type == OP_UCFIRST) {
445bf929 3505 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LOCALE_RUNTIME);
094a2f8c
KW		 3506 }
3507 else {
445bf929 3508 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LOCALE_RUNTIME);
094a2f8c 3509 }
00f254e2 3510
17e95c9d
KW		 3511 /* we can't do in-place if the length changes. */
3512 if (ulen != tculen) inplace = FALSE;
3513 need = slen + 1 - ulen + tculen;
d54190f6 3514 }
00f254e2
KW		 3515 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3516 * latin1 is treated as caseless. Note that a locale takes
3517 * precedence */
167d19f2 3518 ulen = 1; /* Original character is 1 byte */
00f254e2
KW		 3519 tculen = 1; /* Most characters will require one byte, but this will
3520 * need to be overridden for the tricky ones */
3521 need = slen + 1;
3522
3523 if (op_type == OP_LCFIRST) {
d54190f6 3524
00f254e2
KW		 3525 /* lower case the first letter: no trickiness for any character */
3526 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3527 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3528 }
3529 /* is ucfirst() */
3530 else if (IN_LOCALE_RUNTIME) {
31f05a37
KW		 3531 if (IN_UTF8_CTYPE_LOCALE) {
3532 goto do_uni_rules;
3533 }
3534
3535 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3536 locales have upper and title case
3537 different */
00f254e2
KW		 3538 }
3539 else if (! IN_UNI_8_BIT) {
3540 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3541 * on EBCDIC machines whatever the
3542 * native function does */
3543 }
31f05a37
KW		 3544 else {
3545 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3546 * UTF-8, which we treat as not in locale), and cased latin1 */
3547 UV title_ord;
3548
3549 do_uni_rules:
3550
3551 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
167d19f2
KW		 3552 if (tculen > 1) {
3553 assert(tculen == 2);
3554
3555 /* If the result is an upper Latin1-range character, it can
3556 * still be represented in one byte, which is its ordinal */
3557 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3558 *tmpbuf = (U8) title_ord;
3559 tculen = 1;
00f254e2
KW		 3560 }
3561 else {
167d19f2
KW		 3562 /* Otherwise it became more than one ASCII character (in
3563 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3564 * beyond Latin1, so the number of bytes changed, so can't
3565 * replace just the first character in place. */
3566 inplace = FALSE;
3567
d14578b8
KW		 3568 /* If the result won't fit in a byte, the entire result
3569 * will have to be in UTF-8. Assume worst case sizing in
3570 * conversion. (all latin1 characters occupy at most two
3571 * bytes in utf8) */
167d19f2
KW		 3572 if (title_ord > 255) {
3573 doing_utf8 = TRUE;
3574 convert_source_to_utf8 = TRUE;
3575 need = slen * 2 + 1;
3576
3577 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3578 * (both) characters whose title case is above 255 is
3579 * 2. */
3580 ulen = 2;
3581 }
3582 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3583 need = slen + 1 + 1;
3584 }
00f254e2 3585 }
167d19f2 3586 }
00f254e2
KW		 3587 } /* End of use Unicode (Latin1) semantics */
3588 } /* End of changing the case of the first character */
3589
3590 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3591 * generate the result */
3592 if (inplace) {
3593
3594 /* We can convert in place. This means we change just the first
3595 * character without disturbing the rest; no need to grow */
d54190f6
NC		 3596 dest = source;
3597 s = d = (U8*)SvPV_force_nomg(source, slen);
3598 } else {
3599 dTARGET;
3600
3601 dest = TARG;
3602
00f254e2
KW		 3603 /* Here, we can't convert in place; we earlier calculated how much
3604 * space we will need, so grow to accommodate that */
d54190f6 3605 SvUPGRADE(dest, SVt_PV);
3b416f41 3606 d = (U8*)SvGROW(dest, need);
d54190f6
NC		 3607 (void)SvPOK_only(dest);
3608
3609 SETs(dest);
d54190f6 3610 }
44bc797b 3611
d54190f6 3612 if (doing_utf8) {
00f254e2
KW		 3613 if (! inplace) {
3614 if (! convert_source_to_utf8) {
3615
3616 /* Here both source and dest are in UTF-8, but have to create
3617 * the entire output. We initialize the result to be the
3618 * title/lower cased first character, and then append the rest
3619 * of the string. */
3620 sv_setpvn(dest, (char*)tmpbuf, tculen);
3621 if (slen > ulen) {
3622 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3623 }
3624 }
3625 else {
3626 const U8 *const send = s + slen;
3627
3628 /* Here the dest needs to be in UTF-8, but the source isn't,
3629 * except we earlier UTF-8'd the first character of the source
3630 * into tmpbuf. First put that into dest, and then append the
3631 * rest of the source, converting it to UTF-8 as we go. */
3632
3633 /* Assert tculen is 2 here because the only two characters that
3634 * get to this part of the code have 2-byte UTF-8 equivalents */
3635 *d++ = *tmpbuf;
3636 *d++ = *(tmpbuf + 1);
3637 s++; /* We have just processed the 1st char */
3638
3639 for (; s < send; s++) {
3640 d = uvchr_to_utf8(d, *s);
3641 }
3642 *d = '\0';
3643 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3644 }
d54190f6 3645 SvUTF8_on(dest);
a0ed51b3 3646 }
00f254e2 3647 else { /* in-place UTF-8. Just overwrite the first character */
d54190f6
NC		 3648 Copy(tmpbuf, d, tculen, U8);
3649 SvCUR_set(dest, need - 1);
a0ed51b3 3650 }
094a2f8c 3651
a0ed51b3 3652 }
00f254e2
KW		 3653 else { /* Neither source nor dest are in or need to be UTF-8 */
3654 if (slen) {
00f254e2
KW		 3655 if (inplace) { /* in-place, only need to change the 1st char */
3656 *d = *tmpbuf;
3657 }
3658 else { /* Not in-place */
3659
3660 /* Copy the case-changed character(s) from tmpbuf */
3661 Copy(tmpbuf, d, tculen, U8);
3662 d += tculen - 1; /* Code below expects d to point to final
3663 * character stored */
3664 }
3665 }
3666 else { /* empty source */
3667 /* See bug #39028: Don't taint if empty */
d54190f6
NC		 3668 *d = *s;
3669 }
3670
00f254e2
KW		 3671 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3672 * the destination to retain that flag */
93e088e8 3673 if (SvUTF8(source) && ! IN_BYTES)
d54190f6
NC		 3674 SvUTF8_on(dest);
3675
00f254e2 3676 if (!inplace) { /* Finish the rest of the string, unchanged */
d54190f6
NC		 3677 /* This will copy the trailing NUL */
3678 Copy(s + 1, d + 1, slen, U8);
3679 SvCUR_set(dest, need - 1);
bbce6d69 3680 }
bbce6d69 3681 }
445bf929
KW		 3682 if (IN_LOCALE_RUNTIME) {
3683 TAINT;
3684 SvTAINTED_on(dest);
3685 }
539689e7
FC		 3686 if (dest != source && SvTAINTED(source))
3687 SvTAINT(dest);
d54190f6 3688 SvSETMAGIC(dest);
79072805
LW		 3689 RETURN;
3690}
3691
67306194
NC		 3692/* There's so much setup/teardown code common between uc and lc, I wonder if
3693 it would be worth merging the two, and just having a switch outside each
00f254e2 3694 of the three tight loops. There is less and less commonality though */
79072805
LW		 3695PP(pp_uc)
3696{
97aff369 3697 dVAR;
39644a26 3698 dSP;
67306194 3699 SV *source = TOPs;
463ee0b2 3700 STRLEN len;
67306194
NC		 3701 STRLEN min;
3702 SV *dest;
3703 const U8 *s;
3704 U8 *d;
79072805 3705
67306194
NC		 3706 SvGETMAGIC(source);
3707
5cd5e2d6
FC		 3708 if ((SvPADTMP(source)
3709 ||
3710 (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
3711 && !SvREADONLY(source) && SvPOK(source)
3712 && !DO_UTF8(source)
31f05a37
KW		 3713 && ((IN_LOCALE_RUNTIME)
3714 ? ! IN_UTF8_CTYPE_LOCALE
3715 : ! IN_UNI_8_BIT))
3716 {
3717
3718 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3719 * make the loop tight, so we overwrite the source with the dest before
3720 * looking at it, and we need to look at the original source
3721 * afterwards. There would also need to be code added to handle
3722 * switching to not in-place in midstream if we run into characters
3723 * that change the length. Since being in locale overrides UNI_8_BIT,
3724 * that latter becomes irrelevant in the above test; instead for
3725 * locale, the size can't normally change, except if the locale is a
3726 * UTF-8 one */
67306194
NC		 3727 dest = source;
3728 s = d = (U8*)SvPV_force_nomg(source, len);
3729 min = len + 1;
3730 } else {
a0ed51b3 3731 dTARGET;
a0ed51b3 3732
67306194 3733 dest = TARG;
128c9517 3734
841a5e18 3735 s = (const U8*)SvPV_nomg_const(source, len);
67306194
NC		 3736 min = len + 1;
3737
3738 SvUPGRADE(dest, SVt_PV);
3b416f41 3739 d = (U8*)SvGROW(dest, min);
67306194
NC		 3740 (void)SvPOK_only(dest);
3741
3742 SETs(dest);
a0ed51b3 3743 }
31351b04 3744
67306194
NC		 3745 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3746 to check DO_UTF8 again here. */
3747
3748 if (DO_UTF8(source)) {
3749 const U8 *const send = s + len;
bfac13d4 3750 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
67306194 3751
4c8a458a
KW		 3752 /* All occurrences of these are to be moved to follow any other marks.
3753 * This is context-dependent. We may not be passed enough context to
3754 * move the iota subscript beyond all of them, but we do the best we can
3755 * with what we're given. The result is always better than if we
3756 * hadn't done this. And, the problem would only arise if we are
3757 * passed a character without all its combining marks, which would be
3758 * the caller's mistake. The information this is based on comes from a
3759 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3760 * itself) and so can't be checked properly to see if it ever gets
3761 * revised. But the likelihood of it changing is remote */
00f254e2 3762 bool in_iota_subscript = FALSE;
00f254e2 3763
67306194 3764 while (s < send) {
3e16b0e6
KW		 3765 STRLEN u;
3766 STRLEN ulen;
3767 UV uv;
7dbf68d2 3768 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3e16b0e6 3769
00f254e2 3770 /* A non-mark. Time to output the iota subscript */
a78bc3c6
KW		 3771 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3772 d += capital_iota_len;
00f254e2 3773 in_iota_subscript = FALSE;
8e058693 3774 }
00f254e2 3775
8e058693
KW		 3776 /* Then handle the current character. Get the changed case value
3777 * and copy it to the output buffer */
00f254e2 3778
8e058693 3779 u = UTF8SKIP(s);
445bf929 3780 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LOCALE_RUNTIME);
a78bc3c6
KW		 3781#define GREEK_CAPITAL_LETTER_IOTA 0x0399
3782#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
8e058693 3783 if (uv == GREEK_CAPITAL_LETTER_IOTA
4b88fb76 3784 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
8e058693
KW		 3785 {
3786 in_iota_subscript = TRUE;
3787 }
3788 else {
3789 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3790 /* If the eventually required minimum size outgrows the
3791 * available space, we need to grow. */
3792 const UV o = d - (U8*)SvPVX_const(dest);
3793
3794 /* If someone uppercases one million U+03B0s we SvGROW()
3795 * one million times. Or we could try guessing how much to
3796 * allocate without allocating too much. Such is life.
3797 * See corresponding comment in lc code for another option
3798 * */
3799 SvGROW(dest, min);
3800 d = (U8*)SvPVX(dest) + o;
3801 }
3802 Copy(tmpbuf, d, ulen, U8);
3803 d += ulen;
3804 }
3805 s += u;
67306194 3806 }
4c8a458a 3807 if (in_iota_subscript) {
a78bc3c6
KW		 3808 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3809 d += capital_iota_len;
4c8a458a 3810 }
67306194
NC		 3811 SvUTF8_on(dest);
3812 *d = '\0';
094a2f8c 3813
67306194 3814 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4c8a458a
KW		 3815 }
3816 else { /* Not UTF-8 */
67306194
NC		 3817 if (len) {
3818 const U8 *const send = s + len;
00f254e2
KW		 3819
3820 /* Use locale casing if in locale; regular style if not treating
3821 * latin1 as having case; otherwise the latin1 casing. Do the
3822 * whole thing in a tight loop, for speed, */
2de3dbcc 3823 if (IN_LOCALE_RUNTIME) {
31f05a37
KW		 3824 if (IN_UTF8_CTYPE_LOCALE) {
3825 goto do_uni_rules;
3826 }
67306194 3827 for (; s < send; d++, s++)
31f05a37 3828 *d = (U8) toUPPER_LC(*s);
31351b04 3829 }
00f254e2
KW		 3830 else if (! IN_UNI_8_BIT) {
3831 for (; s < send; d++, s++) {
67306194 3832 *d = toUPPER(*s);
00f254e2 3833 }
31351b04 3834 }
00f254e2 3835 else {
31f05a37 3836 do_uni_rules:
00f254e2
KW		 3837 for (; s < send; d++, s++) {
3838 *d = toUPPER_LATIN1_MOD(*s);
d14578b8
KW		 3839 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3840 continue;
3841 }
00f254e2
KW		 3842
3843 /* The mainstream case is the tight loop above. To avoid
3844 * extra tests in that, all three characters that require
3845 * special handling are mapped by the MOD to the one tested
3846 * just above.
3847 * Use the source to distinguish between the three cases */
3848
3849 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3850
3851 /* uc() of this requires 2 characters, but they are
3852 * ASCII. If not enough room, grow the string */
3853 if (SvLEN(dest) < ++min) {
3854 const UV o = d - (U8*)SvPVX_const(dest);
3855 SvGROW(dest, min);
3856 d = (U8*)SvPVX(dest) + o;
3857 }
3858 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3859 continue; /* Back to the tight loop; still in ASCII */
3860 }
3861
3862 /* The other two special handling characters have their
3863 * upper cases outside the latin1 range, hence need to be
3864 * in UTF-8, so the whole result needs to be in UTF-8. So,
3865 * here we are somewhere in the middle of processing a
3866 * non-UTF-8 string, and realize that we will have to convert
3867 * the whole thing to UTF-8. What to do? There are
3868 * several possibilities. The simplest to code is to
3869 * convert what we have so far, set a flag, and continue on
3870 * in the loop. The flag would be tested each time through
3871 * the loop, and if set, the next character would be
3872 * converted to UTF-8 and stored. But, I (khw) didn't want
3873 * to slow down the mainstream case at all for this fairly
3874 * rare case, so I didn't want to add a test that didn't
3875 * absolutely have to be there in the loop, besides the
3876 * possibility that it would get too complicated for
3877 * optimizers to deal with. Another possibility is to just
3878 * give up, convert the source to UTF-8, and restart the
3879 * function that way. Another possibility is to convert
3880 * both what has already been processed and what is yet to
3881 * come separately to UTF-8, then jump into the loop that
3882 * handles UTF-8. But the most efficient time-wise of the
3883 * ones I could think of is what follows, and turned out to
3884 * not require much extra code. */
3885
3886 /* Convert what we have so far into UTF-8, telling the
3887 * function that we know it should be converted, and to
3888 * allow extra space for what we haven't processed yet.
3889 * Assume the worst case space requirements for converting
3890 * what we haven't processed so far: that it will require
3891 * two bytes for each remaining source character, plus the
3892 * NUL at the end. This may cause the string pointer to
3893 * move, so re-find it. */
3894
3895 len = d - (U8*)SvPVX_const(dest);
3896 SvCUR_set(dest, len);
3897 len = sv_utf8_upgrade_flags_grow(dest,
3898 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3899 (send -s) * 2 + 1);
3900 d = (U8*)SvPVX(dest) + len;
3901
00f254e2
KW		 3902 /* Now process the remainder of the source, converting to
3903 * upper and UTF-8. If a resulting byte is invariant in
3904 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3905 * append it to the output. */
00f254e2 3906 for (; s < send; s++) {
0ecfbd28
KW		 3907 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3908 d += len;
00f254e2
KW		 3909 }
3910
3911 /* Here have processed the whole source; no need to continue
3912 * with the outer loop. Each character has been converted
3913 * to upper case and converted to UTF-8 */
3914
3915 break;
3916 } /* End of processing all latin1-style chars */
3917 } /* End of processing all chars */
3918 } /* End of source is not empty */
3919
67306194 3920 if (source != dest) {
00f254e2 3921 *d = '\0'; /* Here d points to 1 after last char, add NUL */
67306194
NC		 3922 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3923 }
00f254e2 3924 } /* End of isn't utf8 */
445bf929
KW		 3925 if (IN_LOCALE_RUNTIME) {
3926 TAINT;
3927 SvTAINTED_on(dest);
3928 }
539689e7
FC		 3929 if (dest != source && SvTAINTED(source))
3930 SvTAINT(dest);
67306194 3931 SvSETMAGIC(dest);
79072805
LW		 3932 RETURN;
3933}
3934
3935PP(pp_lc)
3936{
97aff369 3937 dVAR;
39644a26 3938 dSP;
ec9af7d4 3939 SV *source = TOPs;
463ee0b2 3940 STRLEN len;
ec9af7d4
NC		 3941 STRLEN min;
3942 SV *dest;
3943 const U8 *s;
3944 U8 *d;
79072805 3945
ec9af7d4
NC		 3946 SvGETMAGIC(source);
3947
5cd5e2d6
FC		 3948 if ( ( SvPADTMP(source)
3949 || ( SvTEMP(source) && !SvSMAGICAL(source)
3950 && SvREFCNT(source) == 1 )
3951 )
3952 && !SvREADONLY(source) && SvPOK(source)
3953 && !DO_UTF8(source)) {
ec9af7d4 3954
00f254e2
KW		 3955 /* We can convert in place, as lowercasing anything in the latin1 range
3956 * (or else DO_UTF8 would have been on) doesn't lengthen it */
ec9af7d4
NC		 3957 dest = source;
3958 s = d = (U8*)SvPV_force_nomg(source, len);
3959 min = len + 1;
3960 } else {
a0ed51b3 3961 dTARGET;
a0ed51b3 3962
ec9af7d4
NC		 3963 dest = TARG;
3964
841a5e18 3965 s = (const U8*)SvPV_nomg_const(source, len);
ec9af7d4 3966 min = len + 1;
128c9517 3967
ec9af7d4 3968 SvUPGRADE(dest, SVt_PV);
3b416f41 3969 d = (U8*)SvGROW(dest, min);
ec9af7d4
NC		 3970 (void)SvPOK_only(dest);
3971
3972 SETs(dest);
3973 }
3974
3975 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3976 to check DO_UTF8 again here. */
3977
3978 if (DO_UTF8(source)) {
3979 const U8 *const send = s + len;
3980 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3981
3982 while (s < send) {
06b5486a
KW		 3983 const STRLEN u = UTF8SKIP(s);
3984 STRLEN ulen;
00f254e2 3985
445bf929 3986 _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LOCALE_RUNTIME);
00f254e2 3987
06b5486a 3988 /* Here is where we would do context-sensitive actions. See the
6006ebd0 3989 * commit message for 86510fb15 for why there isn't any */
00f254e2 3990
06b5486a 3991 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
fdb34c52 3992
06b5486a
KW		 3993 /* If the eventually required minimum size outgrows the
3994 * available space, we need to grow. */
3995 const UV o = d - (U8*)SvPVX_const(dest);
fdb34c52 3996
06b5486a
KW		 3997 /* If someone lowercases one million U+0130s we SvGROW() one
3998 * million times. Or we could try guessing how much to
3999 * allocate without allocating too much. Such is life.
4000 * Another option would be to grow an extra byte or two more
4001 * each time we need to grow, which would cut down the million
4002 * to 500K, with little waste */
4003 SvGROW(dest, min);
4004 d = (U8*)SvPVX(dest) + o;
4005 }
86510fb1 4006
06b5486a
KW		 4007 /* Copy the newly lowercased letter to the output buffer we're
4008 * building */
4009 Copy(tmpbuf, d, ulen, U8);
4010 d += ulen;
4011 s += u;
00f254e2 4012 } /* End of looping through the source string */
ec9af7d4
NC		 4013 SvUTF8_on(dest);
4014 *d = '\0';
4015 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
00f254e2 4016 } else { /* Not utf8 */
31351b04 4017 if (len) {
ec9af7d4 4018 const U8 *const send = s + len;
00f254e2
KW		 4019
4020 /* Use locale casing if in locale; regular style if not treating
4021 * latin1 as having case; otherwise the latin1 casing. Do the
4022 * whole thing in a tight loop, for speed, */
445bf929 4023 if (IN_LOCALE_RUNTIME) {
ec9af7d4
NC		 4024 for (; s < send; d++, s++)
4025 *d = toLOWER_LC(*s);
445bf929 4026 }
00f254e2
KW		 4027 else if (! IN_UNI_8_BIT) {
4028 for (; s < send; d++, s++) {
ec9af7d4 4029 *d = toLOWER(*s);
00f254e2
KW		 4030 }
4031 }
4032 else {
4033 for (; s < send; d++, s++) {
4034 *d = toLOWER_LATIN1(*s);
4035 }
31351b04 4036 }
bbce6d69 4037 }
ec9af7d4
NC		 4038 if (source != dest) {
4039 *d = '\0';
4040 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4041 }
79072805 4042 }
445bf929
KW		 4043 if (IN_LOCALE_RUNTIME) {
4044 TAINT;
4045 SvTAINTED_on(dest);
4046 }
539689e7
FC		 4047 if (dest != source && SvTAINTED(source))
4048 SvTAINT(dest);
ec9af7d4 4049 SvSETMAGIC(dest);
79072805
LW		 4050 RETURN;
4051}
4052
a0d0e21e 4053PP(pp_quotemeta)
79072805 4054{
97aff369 4055 dVAR; dSP; dTARGET;
1b6737cc 4056 SV * const sv = TOPs;
a0d0e21e 4057 STRLEN len;
eb578fdb 4058 const char *s = SvPV_const(sv,len);
79072805 4059
7e2040f0 4060 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4061 if (len) {
eb578fdb 4062 char *d;
862a34c6 4063 SvUPGRADE(TARG, SVt_PV);
c07a80fd 4064 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 4065 d = SvPVX(TARG);
7e2040f0 4066 if (DO_UTF8(sv)) {
0dd2cdef 4067 while (len) {
29050de5 4068 STRLEN ulen = UTF8SKIP(s);
2e2b2571
KW		 4069 bool to_quote = FALSE;
4070
4071 if (UTF8_IS_INVARIANT(*s)) {
4072 if (_isQUOTEMETA(*s)) {
4073 to_quote = TRUE;
4074 }
4075 }
4076 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
20adcf7c
KW		 4077
4078 /* In locale, we quote all non-ASCII Latin1 chars.
4079 * Otherwise use the quoting rules */
4080 if (IN_LOCALE_RUNTIME
94bb8c36 4081 || _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
2e2b2571
KW		 4082 {
4083 to_quote = TRUE;
4084 }
4085 }
685289b5 4086 else if (is_QUOTEMETA_high(s)) {
2e2b2571
KW		 4087 to_quote = TRUE;
4088 }
4089
4090 if (to_quote) {
4091 *d++ = '\\';
4092 }
29050de5
KW		 4093 if (ulen > len)
4094 ulen = len;
4095 len -= ulen;
4096 while (ulen--)
4097 *d++ = *s++;
0dd2cdef 4098 }
7e2040f0 4099 SvUTF8_on(TARG);
0dd2cdef 4100 }
2e2b2571
KW		 4101 else if (IN_UNI_8_BIT) {
4102 while (len--) {
4103 if (_isQUOTEMETA(*s))
4104 *d++ = '\\';
4105 *d++ = *s++;
4106 }
4107 }
0dd2cdef 4108 else {
2e2b2571
KW		 4109 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4110 * including everything above ASCII */
0dd2cdef 4111 while (len--) {
adfec831 4112 if (!isWORDCHAR_A(*s))
0dd2cdef
LW		 4113 *d++ = '\\';
4114 *d++ = *s++;
4115 }
79072805 4116 }
a0d0e21e 4117 *d = '\0';
349d4f2f 4118 SvCUR_set(TARG, d - SvPVX_const(TARG));
3aa33fe5 4119 (void)SvPOK_only_UTF8(TARG);
79072805 4120 }
a0d0e21e
LW		 4121 else
4122 sv_setpvn(TARG, s, len);
ec93b65f 4123 SETTARG;
79072805
LW		 4124 RETURN;
4125}
4126
838f2281
BF		 4127PP(pp_fc)
4128{
4129 dVAR;
4130 dTARGET;
4131 dSP;
4132 SV *source = TOPs;
4133 STRLEN len;
4134 STRLEN min;
4135 SV *dest;
4136 const U8 *s;
4137 const U8 *send;
4138 U8 *d;
bfac13d4 4139 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
838f2281
BF		 4140 const bool full_folding = TRUE;
4141 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4142 | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
4143
4144 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4145 * You are welcome(?) -Hugmeir
4146 */
4147
4148 SvGETMAGIC(source);
4149
4150 dest = TARG;
4151
4152 if (SvOK(source)) {
4153 s = (const U8*)SvPV_nomg_const(source, len);
4154 } else {
4155 if (ckWARN(WARN_UNINITIALIZED))
4156 report_uninit(source);
4157 s = (const U8*)"";
4158 len = 0;
4159 }
4160
4161 min = len + 1;
4162
4163 SvUPGRADE(dest, SVt_PV);
4164 d = (U8*)SvGROW(dest, min);
4165 (void)SvPOK_only(dest);
4166
4167 SETs(dest);
4168
4169 send = s + len;
4170 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
838f2281
BF		 4171 while (s < send) {
4172 const STRLEN u = UTF8SKIP(s);
4173 STRLEN ulen;
4174
445bf929 4175 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
838f2281
BF		 4176
4177 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4178 const UV o = d - (U8*)SvPVX_const(dest);
4179 SvGROW(dest, min);
4180 d = (U8*)SvPVX(dest) + o;
4181 }
4182
4183 Copy(tmpbuf, d, ulen, U8);
4184 d += ulen;
4185 s += u;
4186 }
4187 SvUTF8_on(dest);
838f2281 4188 } /* Unflagged string */
0902dd32 4189 else if (len) {
838f2281 4190 if ( IN_LOCALE_RUNTIME ) { /* Under locale */
31f05a37
KW		 4191 if (IN_UTF8_CTYPE_LOCALE) {
4192 goto do_uni_folding;
4193 }
838f2281 4194 for (; s < send; d++, s++)
d22b930b 4195 *d = toFOLD_LC(*s);
838f2281
BF		 4196 }
4197 else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4198 for (; s < send; d++, s++)
d22b930b 4199 *d = toFOLD(*s);
838f2281
BF		 4200 }
4201 else {
31f05a37 4202 do_uni_folding:
d14578b8
KW		 4203 /* For ASCII and the Latin-1 range, there's only two troublesome
4204 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
22e255cb 4205 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
d14578b8
KW		 4206 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4207 * For the rest, the casefold is their lowercase. */
838f2281
BF		 4208 for (; s < send; d++, s++) {
4209 if (*s == MICRO_SIGN) {
d14578b8
KW		 4210 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4211 * which is outside of the latin-1 range. There's a couple
4212 * of ways to deal with this -- khw discusses them in
4213 * pp_lc/uc, so go there :) What we do here is upgrade what
4214 * we had already casefolded, then enter an inner loop that
4215 * appends the rest of the characters as UTF-8. */
838f2281
BF		 4216 len = d - (U8*)SvPVX_const(dest);
4217 SvCUR_set(dest, len);
4218 len = sv_utf8_upgrade_flags_grow(dest,
4219 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
ea4d335b
KW		 4220 /* The max expansion for latin1
4221 * chars is 1 byte becomes 2 */
4222 (send -s) * 2 + 1);
838f2281
BF		 4223 d = (U8*)SvPVX(dest) + len;
4224
a78bc3c6
KW		 4225 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4226 d += small_mu_len;
838f2281
BF		 4227 s++;
4228 for (; s < send; s++) {
4229 STRLEN ulen;
4230 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
6f2d5cbc 4231 if UVCHR_IS_INVARIANT(fc) {
d14578b8
KW		 4232 if (full_folding
4233 && *s == LATIN_SMALL_LETTER_SHARP_S)
4234 {
838f2281
BF		 4235 *d++ = 's';
4236 *d++ = 's';
4237 }
4238 else
4239 *d++ = (U8)fc;
4240 }
4241 else {
4242 Copy(tmpbuf, d, ulen, U8);
4243 d += ulen;
4244 }
4245 }
4246 break;
4247 }
4248 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
d14578b8
KW		 4249 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4250 * becomes "ss", which may require growing the SV. */
838f2281
BF		 4251 if (SvLEN(dest) < ++min) {
4252 const UV o = d - (U8*)SvPVX_const(dest);
4253 SvGROW(dest, min);
4254 d = (U8*)SvPVX(dest) + o;
4255 }
4256 *(d)++ = 's';
4257 *d = 's';
4258 }
d14578b8
KW		 4259 else { /* If it's not one of those two, the fold is their lower
4260 case */
838f2281
BF		 4261 *d = toLOWER_LATIN1(*s);
4262 }
4263 }
4264 }
4265 }
4266 *d = '\0';
4267 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4268
445bf929
KW		 4269 if (IN_LOCALE_RUNTIME) {
4270 TAINT;
4271 SvTAINTED_on(dest);
4272 }
838f2281
BF		 4273 if (SvTAINTED(source))
4274 SvTAINT(dest);
4275 SvSETMAGIC(dest);
4276 RETURN;
4277}
4278
a0d0e21e 4279/* Arrays. */
79072805 4280
a0d0e21e 4281PP(pp_aslice)
79072805 4282{
97aff369 4283 dVAR; dSP; dMARK; dORIGMARK;
eb578fdb
KW		 4284 AV *const av = MUTABLE_AV(POPs);
4285 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
79072805 4286
a0d0e21e 4287 if (SvTYPE(av) == SVt_PVAV) {
4ad10a0b
VP		 4288 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4289 bool can_preserve = FALSE;
4290
4291 if (localizing) {
4292 MAGIC *mg;
4293 HV *stash;
4294
4295 can_preserve = SvCANEXISTDELETE(av);
4296 }
4297
4298 if (lval && localizing) {
eb578fdb 4299 SV **svp;
c70927a6 4300 SSize_t max = -1;
924508f0 4301 for (svp = MARK + 1; svp <= SP; svp++) {
c70927a6 4302 const SSize_t elem = SvIV(*svp);
748a9306
LW		 4303 if (elem > max)
4304 max = elem;
4305 }
4306 if (max > AvMAX(av))
4307 av_extend(av, max);
4308 }
4ad10a0b 4309
a0d0e21e 4310 while (++MARK <= SP) {
eb578fdb 4311 SV **svp;
c70927a6 4312 SSize_t elem = SvIV(*MARK);
4ad10a0b 4313 bool preeminent = TRUE;
a0d0e21e 4314
4ad10a0b
VP		 4315 if (localizing && can_preserve) {
4316 /* If we can determine whether the element exist,
4317 * Try to preserve the existenceness of a tied array
4318 * element by using EXISTS and DELETE if possible.
4319 * Fallback to FETCH and STORE otherwise. */
4320 preeminent = av_exists(av, elem);
4321 }
4322
a0d0e21e
LW		 4323 svp = av_fetch(av, elem, lval);
4324 if (lval) {
ce0d59fd 4325 if (!svp || !*svp)
cea2e8a9 4326 DIE(aTHX_ PL_no_aelem, elem);
4ad10a0b
VP		 4327 if (localizing) {
4328 if (preeminent)
4329 save_aelem(av, elem, svp);
4330 else
4331 SAVEADELETE(av, elem);
4332 }
79072805 4333 }
3280af22 4334 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 4335 }
4336 }
748a9306 4337 if (GIMME != G_ARRAY) {
a0d0e21e 4338 MARK = ORIGMARK;
04ab2c87 4339 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e
LW		 4340 SP = MARK;
4341 }
79072805
LW		 4342 RETURN;
4343}
4344
6dd3e0f2
RZ		 4345PP(pp_kvaslice)
4346{
4347 dVAR; dSP; dMARK;
4348 AV *const av = MUTABLE_AV(POPs);
4349 I32 lval = (PL_op->op_flags & OPf_MOD);
adad97db 4350 SSize_t items = SP - MARK;
6dd3e0f2
RZ		 4351
4352 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4353 const I32 flags = is_lvalue_sub();
4354 if (flags) {
4355 if (!(flags & OPpENTERSUB_INARGS))
7aae0299 4356 /* diag_listed_as: Can't modify %s in %s */
6dd3e0f2
RZ		 4357 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4358 lval = flags;
4359 }
4360 }
4361
4362 MEXTEND(SP,items);
4363 while (items > 1) {
4364 *(MARK+items*2-1) = *(MARK+items);
4365 items--;
4366 }
4367 items = SP-MARK;
4368 SP += items;
4369
4370 while (++MARK <= SP) {
4371 SV **svp;
4372
4373 svp = av_fetch(av, SvIV(*MARK), lval);
4374 if (lval) {
4375 if (!svp || !*svp || *svp == &PL_sv_undef) {
4376 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4377 }
4378 *MARK = sv_mortalcopy(*MARK);
4379 }
4380 *++MARK = svp ? *svp : &PL_sv_undef;
4381 }
4382 if (GIMME != G_ARRAY) {
4383 MARK = SP - items*2;
4384 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4385 SP = MARK;
4386 }
4387 RETURN;
4388}
4389
cba5a3b0
DG		 4390/* Smart dereferencing for keys, values and each */
4391PP(pp_rkeys)
4392{
4393 dVAR;
4394 dSP;
4395 dPOPss;
4396
7ac5715b
FC		 4397 SvGETMAGIC(sv);
4398
4399 if (
4400 !SvROK(sv)
4401 || (sv = SvRV(sv),
4402 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4403 || SvOBJECT(sv)
4404 )
4405 ) {
4406 DIE(aTHX_
4407 "Type of argument to %s must be unblessed hashref or arrayref",
4c540399 4408 PL_op_desc[PL_op->op_type] );
cba5a3b0
DG		 4409 }
4410
d8065907
FC		 4411 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4412 DIE(aTHX_
4413 "Can't modify %s in %s",
4414 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4415 );
4416
cba5a3b0
DG		 4417 /* Delegate to correct function for op type */
4418 PUSHs(sv);
4419 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4420 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4421 }
4422 else {
d14578b8
KW		 4423 return (SvTYPE(sv) == SVt_PVHV)
4424 ? Perl_pp_each(aTHX)
4425 : Perl_pp_aeach(aTHX);
cba5a3b0
DG		 4426 }
4427}
4428
878d132a
NC		 4429PP(pp_aeach)
4430{
4431 dVAR;
4432 dSP;
502c6561 4433 AV *array = MUTABLE_AV(POPs);
878d132a 4434 const I32 gimme = GIMME_V;
453d94a9 4435 IV *iterp = Perl_av_iter_p(aTHX_ array);
878d132a
NC		 4436 const IV current = (*iterp)++;
4437
4438 if (current > av_len(array)) {
4439 *iterp = 0;
4440 if (gimme == G_SCALAR)
4441 RETPUSHUNDEF;
4442 else
4443 RETURN;
4444 }
4445
4446 EXTEND(SP, 2);
e1dccc0d 4447 mPUSHi(current);
878d132a
NC		 4448 if (gimme == G_ARRAY) {
4449 SV **const element = av_fetch(array, current, 0);
4450 PUSHs(element ? *element : &PL_sv_undef);
4451 }
4452 RETURN;
4453}
4454
4455PP(pp_akeys)
4456{
4457 dVAR;
4458 dSP;
502c6561 4459 AV *array = MUTABLE_AV(POPs);
878d132a
NC		 4460 const I32 gimme = GIMME_V;
4461
4462 *Perl_av_iter_p(aTHX_ array) = 0;
4463
4464 if (gimme == G_SCALAR) {
4465 dTARGET;
4466 PUSHi(av_len(array) + 1);
4467 }
4468 else if (gimme == G_ARRAY) {
4469 IV n = Perl_av_len(aTHX_ array);
e1dccc0d 4470 IV i;
878d132a
NC		 4471
4472 EXTEND(SP, n + 1);
4473
cba5a3b0 4474 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
e1dccc0d 4475 for (i = 0; i <= n; i++) {
878d132a
NC		 4476 mPUSHi(i);
4477 }
4478 }
4479 else {
4480 for (i = 0; i <= n; i++) {
4481 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4482 PUSHs(elem ? *elem : &PL_sv_undef);
4483 }
4484 }
4485 }
4486 RETURN;
4487}
4488
79072805
LW		 4489/* Associative arrays. */
4490
4491PP(pp_each)
4492{
97aff369 4493 dVAR;
39644a26 4494 dSP;
85fbaab2 4495 HV * hash = MUTABLE_HV(POPs);
c07a80fd 4496 HE *entry;
f54cb97a 4497 const I32 gimme = GIMME_V;
8ec5e241 4498
c07a80fd 4499 PUTBACK;
c750a3ec 4500 /* might clobber stack_sp */
6d822dc4 4501 entry = hv_iternext(hash);
c07a80fd 4502 SPAGAIN;
79072805 4503
79072805
LW		 4504 EXTEND(SP, 2);
4505 if (entry) {
1b6737cc 4506 SV* const sv = hv_iterkeysv(entry);
574c8022 4507 PUSHs(sv); /* won't clobber stack_sp */
54310121 4508 if (gimme == G_ARRAY) {
59af0135 4509 SV *val;
c07a80fd 4510 PUTBACK;
c750a3ec 4511 /* might clobber stack_sp */
6d822dc4 4512 val = hv_iterval(hash, entry);
c07a80fd 4513 SPAGAIN;
59af0135 4514 PUSHs(val);
79072805 4515 }
79072805 4516 }
54310121 4517 else if (gimme == G_SCALAR)
79072805
LW		 4518 RETPUSHUNDEF;
4519
4520 RETURN;
4521}
4522
7332a6c4
VP		 4523STATIC OP *
4524S_do_delete_local(pTHX)
79072805 4525{
97aff369 4526 dVAR;
39644a26 4527 dSP;
f54cb97a 4528 const I32 gimme = GIMME_V;
7332a6c4
VP		 4529 const MAGIC *mg;
4530 HV *stash;
ca3f996a
FC		 4531 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4532 SV *unsliced_keysv = sliced ? NULL : POPs;
4533 SV * const osv = POPs;
eb578fdb 4534 SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
ca3f996a
FC		 4535 dORIGMARK;
4536 const bool tied = SvRMAGICAL(osv)
7332a6c4 4537 && mg_find((const SV *)osv, PERL_MAGIC_tied);
ca3f996a
FC		 4538 const bool can_preserve = SvCANEXISTDELETE(osv);
4539 const U32 type = SvTYPE(osv);
4540 SV ** const end = sliced ? SP : &unsliced_keysv;
4541
4542 if (type == SVt_PVHV) { /* hash element */
7332a6c4 4543 HV * const hv = MUTABLE_HV(osv);
ca3f996a 4544 while (++MARK <= end) {
7332a6c4
VP		 4545 SV * const keysv = *MARK;
4546 SV *sv = NULL;
4547 bool preeminent = TRUE;
4548 if (can_preserve)
4549 preeminent = hv_exists_ent(hv, keysv, 0);
4550 if (tied) {
4551 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4552 if (he)
4553 sv = HeVAL(he);
4554 else
4555 preeminent = FALSE;
4556 }
4557 else {
4558 sv = hv_delete_ent(hv, keysv, 0, 0);
9332b95f
FC		 4559 if (preeminent)
4560 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
7332a6c4
VP		 4561 }
4562 if (preeminent) {
be6064fd 4563 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
7332a6c4
VP		 4564 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4565 if (tied) {
4566 *MARK = sv_mortalcopy(sv);
4567 mg_clear(sv);
4568 } else
4569 *MARK = sv;
4570 }
4571 else {
4572 SAVEHDELETE(hv, keysv);
4573 *MARK = &PL_sv_undef;
4574 }
4575 }
ca3f996a
FC		 4576 }
4577 else if (type == SVt_PVAV) { /* array element */
7332a6c4
VP		 4578 if (PL_op->op_flags & OPf_SPECIAL) {
4579 AV * const av = MUTABLE_AV(osv);
ca3f996a 4580 while (++MARK <= end) {
c70927a6 4581 SSize_t idx = SvIV(*MARK);
7332a6c4
VP		 4582 SV *sv = NULL;
4583 bool preeminent = TRUE;
4584 if (can_preserve)
4585 preeminent = av_exists(av, idx);
4586 if (tied) {
4587 SV **svp = av_fetch(av, idx, 1);
4588 if (svp)
4589 sv = *svp;
4590 else
4591 preeminent = FALSE;
4592 }
4593 else {
4594 sv = av_delete(av, idx, 0);
9332b95f
FC		 4595 if (preeminent)
4596 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
7332a6c4
VP		 4597 }
4598 if (preeminent) {
4599 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4600 if (tied) {
4601 *MARK = sv_mortalcopy(sv);
4602 mg_clear(sv);
4603 } else
4604 *MARK = sv;
4605 }
4606 else {
4607 SAVEADELETE(av, idx);
4608 *MARK = &PL_sv_undef;
4609 }
4610 }
4611 }
ca3f996a
FC		 4612 else
4613 DIE(aTHX_ "panic: avhv_delete no longer supported");
4614 }
4615 else
7332a6c4 4616 DIE(aTHX_ "Not a HASH reference");
ca3f996a 4617 if (sliced) {
7332a6c4
VP		 4618 if (gimme == G_VOID)
4619 SP = ORIGMARK;
4620 else if (gimme == G_SCALAR) {
4621 MARK = ORIGMARK;
4622 if (SP > MARK)
4623 *++MARK = *SP;
4624 else
4625 *++MARK = &PL_sv_undef;
4626 SP = MARK;
4627 }
4628 }
ca3f996a
FC		 4629 else if (gimme != G_VOID)
4630 PUSHs(unsliced_keysv);
7332a6c4
VP		 4631
4632 RETURN;
4633}
4634
4635PP(pp_delete)
4636{
4637 dVAR;
4638 dSP;
4639 I32 gimme;
4640 I32 discard;
4641
4642 if (PL_op->op_private & OPpLVAL_INTRO)
4643 return do_delete_local();
4644
4645 gimme = GIMME_V;
4646 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5f05dabc 4647
533c011a 4648 if (PL_op->op_private & OPpSLICE) {
5f05dabc 4649 dMARK; dORIGMARK;
85fbaab2 4650 HV * const hv = MUTABLE_HV(POPs);
1b6737cc 4651 const U32 hvtype = SvTYPE(hv);
01020589
GS		 4652 if (hvtype == SVt_PVHV) { /* hash element */
4653 while (++MARK <= SP) {
1b6737cc 4654 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 4655 *MARK = sv ? sv : &PL_sv_undef;
4656 }
5f05dabc 4657 }
6d822dc4
MS		 4658 else if (hvtype == SVt_PVAV) { /* array element */
4659 if (PL_op->op_flags & OPf_SPECIAL) {
4660 while (++MARK <= SP) {
502c6561 4661 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
6d822dc4
MS		 4662 *MARK = sv ? sv : &PL_sv_undef;
4663 }
4664 }
01020589
GS		 4665 }
4666 else
4667 DIE(aTHX_ "Not a HASH reference");
54310121 4668 if (discard)
4669 SP = ORIGMARK;
4670 else if (gimme == G_SCALAR) {
5f05dabc 4671 MARK = ORIGMARK;
9111c9c0
DM		 4672 if (SP > MARK)
4673 *++MARK = *SP;
4674 else
4675 *++MARK = &PL_sv_undef;
5f05dabc 4676 SP = MARK;
4677 }
4678 }
4679 else {
4680 SV *keysv = POPs;
85fbaab2 4681 HV * const hv = MUTABLE_HV(POPs);
295d248e 4682 SV *sv = NULL;
97fcbf96
MB		 4683 if (SvTYPE(hv) == SVt_PVHV)
4684 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 4685 else if (SvTYPE(hv) == SVt_PVAV) {
4686 if (PL_op->op_flags & OPf_SPECIAL)
502c6561 4687 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
af288a60
HS		 4688 else
4689 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 4690 }
97fcbf96 4691 else
cea2e8a9 4692 DIE(aTHX_ "Not a HASH reference");
5f05dabc 4693 if (!sv)
3280af22 4694 sv = &PL_sv_undef;
54310121 4695 if (!discard)
4696 PUSHs(sv);
79072805 4697 }
79072805
LW		 4698 RETURN;
4699}
4700
a0d0e21e 4701PP(pp_exists)
79072805 4702{
97aff369 4703 dVAR;
39644a26 4704 dSP;
afebc493
GS		 4705 SV *tmpsv;
4706 HV *hv;
4707
c7e88ff3 4708 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
afebc493 4709 GV *gv;
0bd48802 4710 SV * const sv = POPs;
f2c0649b 4711 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
afebc493
GS		 4712 if (cv)
4713 RETPUSHYES;
4714 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4715 RETPUSHYES;
4716 RETPUSHNO;
4717 }
4718 tmpsv = POPs;
85fbaab2 4719 hv = MUTABLE_HV(POPs);
c7e88ff3 4720 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
ae77835f 4721 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 4722 RETPUSHYES;
ef54e1a4
JH		 4723 }
4724 else if (SvTYPE(hv) == SVt_PVAV) {
01020589 4725 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
502c6561 4726 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
01020589
GS		 4727 RETPUSHYES;
4728 }
ef54e1a4
JH		 4729 }
4730 else {
cea2e8a9 4731 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 4732 }
a0d0e21e
LW		 4733 RETPUSHNO;
4734}
79072805 4735
a0d0e21e
LW		 4736PP(pp_hslice)
4737{
97aff369 4738 dVAR; dSP; dMARK; dORIGMARK;
eb578fdb
KW		 4739 HV * const hv = MUTABLE_HV(POPs);
4740 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
1b6737cc 4741 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 4742 bool can_preserve = FALSE;
79072805 4743
eb85dfd3
DM		 4744 if (localizing) {
4745 MAGIC *mg;
4746 HV *stash;
4747
2c5f48c2 4748 if (SvCANEXISTDELETE(hv))
d30e492c 4749 can_preserve = TRUE;
eb85dfd3
DM		 4750 }
4751
6d822dc4 4752 while (++MARK <= SP) {
1b6737cc 4753 SV * const keysv = *MARK;
6d822dc4
MS		 4754 SV **svp;
4755 HE *he;
d30e492c
VP		 4756 bool preeminent = TRUE;
4757
4758 if (localizing && can_preserve) {
4759 /* If we can determine whether the element exist,
4760 * try to preserve the existenceness of a tied hash
4761 * element by using EXISTS and DELETE if possible.
4762 * Fallback to FETCH and STORE otherwise. */
4763 preeminent = hv_exists_ent(hv, keysv, 0);
6d822dc4 4764 }
eb85dfd3 4765
6d822dc4 4766 he = hv_fetch_ent(hv, keysv, lval, 0);
fe5bfecd 4767 svp = he ? &HeVAL(he) : NULL;
eb85dfd3 4768
6d822dc4 4769 if (lval) {
746f6409 4770 if (!svp || !*svp || *svp == &PL_sv_undef) {
be2597df 4771 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6d822dc4
MS		 4772 }
4773 if (localizing) {
7a2e501a 4774 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 4775 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP		 4776 else if (preeminent)
4777 save_helem_flags(hv, keysv, svp,
4778 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4779 else
4780 SAVEHDELETE(hv, keysv);
6d822dc4
MS		 4781 }
4782 }
746f6409 4783 *MARK = svp && *svp ? *svp : &PL_sv_undef;
79072805 4784 }
a0d0e21e
LW		 4785 if (GIMME != G_ARRAY) {
4786 MARK = ORIGMARK;
04ab2c87 4787 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e 4788 SP = MARK;
79072805 4789 }
a0d0e21e
LW		 4790 RETURN;
4791}
4792
5cae3edb
RZ		 4793PP(pp_kvhslice)
4794{
21671fea 4795 dVAR; dSP; dMARK;
5cae3edb
RZ		 4796 HV * const hv = MUTABLE_HV(POPs);
4797 I32 lval = (PL_op->op_flags & OPf_MOD);
adad97db 4798 SSize_t items = SP - MARK;
5cae3edb
RZ		 4799
4800 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4801 const I32 flags = is_lvalue_sub();
4802 if (flags) {
4803 if (!(flags & OPpENTERSUB_INARGS))
7aae0299 4804 /* diag_listed_as: Can't modify %s in %s */
5cae3edb
RZ		 4805 Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
4806 lval = flags;
4807 }
4808 }
4809
4810 MEXTEND(SP,items);
4811 while (items > 1) {
4812 *(MARK+items*2-1) = *(MARK+items);
4813 items--;
4814 }
4815 items = SP-MARK;
4816 SP += items;
4817
4818 while (++MARK <= SP) {
4819 SV * const keysv = *MARK;
4820 SV **svp;
4821 HE *he;
4822
4823 he = hv_fetch_ent(hv, keysv, lval, 0);
4824 svp = he ? &HeVAL(he) : NULL;
4825
4826 if (lval) {
4827 if (!svp || !*svp || *svp == &PL_sv_undef) {
4828 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4829 }
4830 *MARK = sv_mortalcopy(*MARK);
4831 }
4832 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
4833 }
4834 if (GIMME != G_ARRAY) {
4835 MARK = SP - items*2;
4836 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4837 SP = MARK;
4838 }
4839 RETURN;
4840}
4841
a0d0e21e
LW		 4842/* List operators. */
4843
4844PP(pp_list)
4845{
97aff369 4846 dVAR; dSP; dMARK;
a0d0e21e
LW		 4847 if (GIMME != G_ARRAY) {
4848 if (++MARK <= SP)
4849 *MARK = *SP; /* unwanted list, return last item */
8990e307 4850 else
3280af22 4851 *MARK = &PL_sv_undef;
a0d0e21e 4852 SP = MARK;
79072805 4853 }
a0d0e21e 4854 RETURN;
79072805
LW		 4855}
4856
a0d0e21e 4857PP(pp_lslice)
79072805 4858{
97aff369 4859 dVAR;
39644a26 4860 dSP;
1b6737cc
AL		 4861 SV ** const lastrelem = PL_stack_sp;
4862 SV ** const lastlelem = PL_stack_base + POPMARK;
4863 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
eb578fdb 4864 SV ** const firstrelem = lastlelem + 1;
42e73ed0 4865 I32 is_something_there = FALSE;
706a6ebc 4866 const U8 mod = PL_op->op_flags & OPf_MOD;
1b6737cc 4867
eb578fdb
KW		 4868 const I32 max = lastrelem - lastlelem;
4869 SV **lelem;
a0d0e21e
LW		 4870
4871 if (GIMME != G_ARRAY) {
4ea561bc 4872 I32 ix = SvIV(*lastlelem);
748a9306
LW		 4873 if (ix < 0)
4874 ix += max;
a0d0e21e 4875 if (ix < 0 || ix >= max)
3280af22 4876 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 4877 else
4878 *firstlelem = firstrelem[ix];
4879 SP = firstlelem;
4880 RETURN;
4881 }
4882
4883 if (max == 0) {
4884 SP = firstlelem - 1;
4885 RETURN;
4886 }
4887
4888 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4ea561bc 4889 I32 ix = SvIV(*lelem);
c73bf8e3 4890 if (ix < 0)
a0d0e21e 4891 ix += max;
c73bf8e3
HS		 4892 if (ix < 0 || ix >= max)
4893 *lelem = &PL_sv_undef;
4894 else {
4895 is_something_there = TRUE;
4896 if (!(*lelem = firstrelem[ix]))
3280af22 4897 *lelem = &PL_sv_undef;
706a6ebc
FC		 4898 else if (mod && SvPADTMP(*lelem) && !IS_PADGV(*lelem))
4899 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
748a9306 4900 }
79072805 4901 }
4633a7c4
LW		 4902 if (is_something_there)
4903 SP = lastlelem;
4904 else
4905 SP = firstlelem - 1;
79072805
LW		 4906 RETURN;
4907}
4908
a0d0e21e
LW		 4909PP(pp_anonlist)
4910{
31476221 4911 dVAR; dSP; dMARK;
1b6737cc 4912 const I32 items = SP - MARK;
ad64d0ec 4913 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
31476221 4914 SP = MARK;
6e449a3a
MHM		 4915 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4916 ? newRV_noinc(av) : av);
a0d0e21e
LW		 4917 RETURN;
4918}
4919
4920PP(pp_anonhash)
79072805 4921{
97aff369 4922 dVAR; dSP; dMARK; dORIGMARK;
67e67fd7 4923 HV* const hv = newHV();
8d455b9f 4924 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
67e67fd7 4925 ? newRV_noinc(MUTABLE_SV(hv))
8d455b9f 4926 : MUTABLE_SV(hv) );
a0d0e21e
LW		 4927
4928 while (MARK < SP) {
3ed356df
FC		 4929 SV * const key =
4930 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
4931 SV *val;
a0d0e21e 4932 if (MARK < SP)
3ed356df
FC		 4933 {
4934 MARK++;
4935 SvGETMAGIC(*MARK);
4936 val = newSV(0);
4937 sv_setsv(val, *MARK);
4938 }
a2a5de95 4939 else
3ed356df 4940 {
a2a5de95 4941 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3ed356df
FC		 4942 val = newSV(0);
4943 }
f12c7020 4944 (void)hv_store_ent(hv,key,val,0);
79072805 4945 }
a0d0e21e 4946 SP = ORIGMARK;
8d455b9f 4947 XPUSHs(retval);
79072805
LW		 4948 RETURN;
4949}
4950
d4fc4415
FC		 4951static AV *
4952S_deref_plain_array(pTHX_ AV *ary)
4953{
4954 if (SvTYPE(ary) == SVt_PVAV) return ary;
d2d95e13 4955 SvGETMAGIC((SV *)ary);
d4fc4415
FC		 4956 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4957 Perl_die(aTHX_ "Not an ARRAY reference");
4958 else if (SvOBJECT(SvRV(ary)))
4959 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4960 return (AV *)SvRV(ary);
4961}
4962
4963#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4964# define DEREF_PLAIN_ARRAY(ary) \
4965 ({ \
4966 AV *aRrRay = ary; \
4967 SvTYPE(aRrRay) == SVt_PVAV \
4968 ? aRrRay \
4969 : S_deref_plain_array(aTHX_ aRrRay); \
4970 })
4971#else
4972# define DEREF_PLAIN_ARRAY(ary) \
4973 ( \
3b0f6d32 4974 PL_Sv = (SV *)(ary), \
d4fc4415
FC		 4975 SvTYPE(PL_Sv) == SVt_PVAV \
4976 ? (AV *)PL_Sv \
3b0f6d32 4977 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
d4fc4415
FC		 4978 )
4979#endif
4980
a0d0e21e 4981PP(pp_splice)
79072805 4982{
27da23d5 4983 dVAR; dSP; dMARK; dORIGMARK;
5cd408a2 4984 int num_args = (SP - MARK);
eb578fdb
KW		 4985 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4986 SV **src;
4987 SV **dst;
c70927a6
FC		 4988 SSize_t i;
4989 SSize_t offset;
4990 SSize_t length;
4991 SSize_t newlen;
4992 SSize_t after;
4993 SSize_t diff;
ad64d0ec 4994 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 4995
1b6737cc 4996 if (mg) {
3e0cb5de 4997 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
af71faff
NC		 4998 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4999 sp - mark);
93965878 5000 }
79072805 5001
a0d0e21e 5002 SP++;
79072805 5003
a0d0e21e 5004 if (++MARK < SP) {
4ea561bc 5005 offset = i = SvIV(*MARK);
a0d0e21e 5006 if (offset < 0)
93965878 5007 offset += AvFILLp(ary) + 1;
84902520 5008 if (offset < 0)
cea2e8a9 5009 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 5010 if (++MARK < SP) {
5011 length = SvIVx(*MARK++);
48cdf507
GA		 5012 if (length < 0) {
5013 length += AvFILLp(ary) - offset + 1;
5014 if (length < 0)
5015 length = 0;
5016 }
79072805
LW		 5017 }
5018 else
a0d0e21e 5019 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 5020 }
a0d0e21e
LW		 5021 else {
5022 offset = 0;
5023 length = AvMAX(ary) + 1;
5024 }
8cbc2e3b 5025 if (offset > AvFILLp(ary) + 1) {
5cd408a2
EB		 5026 if (num_args > 2)
5027 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 5028 offset = AvFILLp(ary) + 1;
8cbc2e3b 5029 }
93965878 5030 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 5031 if (after < 0) { /* not that much array */
5032 length += after; /* offset+length now in array */
5033 after = 0;
5034 if (!AvALLOC(ary))
5035 av_extend(ary, 0);
5036 }
5037
5038 /* At this point, MARK .. SP-1 is our new LIST */
5039
5040 newlen = SP - MARK;
5041 diff = newlen - length;
13d7cbc1
GS		 5042 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5043 av_reify(ary);
a0d0e21e 5044
50528de0
WL		 5045 /* make new elements SVs now: avoid problems if they're from the array */
5046 for (dst = MARK, i = newlen; i; i--) {
1b6737cc 5047 SV * const h = *dst;
f2b990bf 5048 *dst++ = newSVsv(h);
50528de0
WL		 5049 }
5050
a0d0e21e 5051 if (diff < 0) { /* shrinking the area */
95b63a38 5052 SV **tmparyval = NULL;
a0d0e21e 5053 if (newlen) {
a02a5408 5054 Newx(tmparyval, newlen, SV*); /* so remember insertion */
a0d0e21e 5055 Copy(MARK, tmparyval, newlen, SV*);
79072805 5056 }
a0d0e21e
LW		 5057
5058 MARK = ORIGMARK + 1;
5059 if (GIMME == G_ARRAY) { /* copy return vals to stack */
31c61add 5060 const bool real = cBOOL(AvREAL(ary));
a0d0e21e 5061 MEXTEND(MARK, length);
31c61add 5062 if (real)
bbce6d69 5063 EXTEND_MORTAL(length);
31c61add
FC		 5064 for (i = 0, dst = MARK; i < length; i++) {
5065 if ((*dst = AvARRAY(ary)[i+offset])) {
5066 if (real)
486ec47a 5067 sv_2mortal(*dst); /* free them eventually */
36477c24 5068 }
31c61add
FC		 5069 else
5070 *dst = &PL_sv_undef;
5071 dst++;
a0d0e21e
LW		 5072 }
5073 MARK += length - 1;
79072805 5074 }
a0d0e21e
LW		 5075 else {
5076 *MARK = AvARRAY(ary)[offset+length-1];
5077 if (AvREAL(ary)) {
d689ffdd 5078 sv_2mortal(*MARK);
a0d0e21e
LW		 5079 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5080 SvREFCNT_dec(*dst++); /* free them now */
79072805 5081 }
a0d0e21e 5082 }
93965878 5083 AvFILLp(ary) += diff;
a0d0e21e
LW		 5084
5085 /* pull up or down? */
5086
5087 if (offset < after) { /* easier to pull up */
5088 if (offset) { /* esp. if nothing to pull */
5089 src = &AvARRAY(ary)[offset-1];
5090 dst = src - diff; /* diff is negative */
5091 for (i = offset; i > 0; i--) /* can't trust Copy */
5092 *dst-- = *src--;
79072805 5093 }
a0d0e21e 5094 dst = AvARRAY(ary);
9c6bc640 5095 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
a0d0e21e
LW		 5096 AvMAX(ary) += diff;
5097 }
5098 else {
5099 if (after) { /* anything to pull down? */
5100 src = AvARRAY(ary) + offset + length;
5101 dst = src + diff; /* diff is negative */
5102 Move(src, dst, after, SV*);
79072805 5103 }
93965878 5104 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 5105 /* avoid later double free */
5106 }
5107 i = -diff;
5108 while (i)
ce0d59fd 5109 dst[--i] = NULL;
a0d0e21e
LW		 5110
5111 if (newlen) {
50528de0 5112 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e
LW		 5113 Safefree(tmparyval);
5114 }
5115 }
5116 else { /* no, expanding (or same) */
d3961450 5117 SV** tmparyval = NULL;
a0d0e21e 5118 if (length) {
a02a5408 5119 Newx(tmparyval, length, SV*); /* so remember deletion */
a0d0e21e
LW		 5120 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5121 }
5122
5123 if (diff > 0) { /* expanding */
a0d0e21e 5124 /* push up or down? */
a0d0e21e
LW		 5125 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5126 if (offset) {
5127 src = AvARRAY(ary);
5128 dst = src - diff;
5129 Move(src, dst, offset, SV*);
79072805 5130 }
9c6bc640 5131 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
a0d0e21e 5132 AvMAX(ary) += diff;
93965878 5133 AvFILLp(ary) += diff;
79072805
LW		 5134 }
5135 else {
93965878
NIS		 5136 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5137 av_extend(ary, AvFILLp(ary) + diff);
5138 AvFILLp(ary) += diff;
a0d0e21e
LW		 5139
5140 if (after) {
93965878 5141 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 5142 src = dst - diff;
5143 for (i = after; i; i--) {
5144 *dst-- = *src--;
5145 }
79072805
LW		 5146 }
5147 }
a0d0e21e
LW		 5148 }
5149
50528de0
WL		 5150 if (newlen) {
5151 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e 5152 }
50528de0 5153
a0d0e21e
LW		 5154 MARK = ORIGMARK + 1;
5155 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5156 if (length) {
31c61add
FC		 5157 const bool real = cBOOL(AvREAL(ary));
5158 if (real)
bbce6d69 5159 EXTEND_MORTAL(length);
31c61add
FC		 5160 for (i = 0, dst = MARK; i < length; i++) {
5161 if ((*dst = tmparyval[i])) {
5162 if (real)
486ec47a 5163 sv_2mortal(*dst); /* free them eventually */
36477c24 5164 }
31c61add
FC		 5165 else *dst = &PL_sv_undef;
5166 dst++;
79072805
LW		 5167 }
5168 }
a0d0e21e
LW		 5169 MARK += length - 1;
5170 }
5171 else if (length--) {
5172 *MARK = tmparyval[length];
5173 if (AvREAL(ary)) {
d689ffdd 5174 sv_2mortal(*MARK);
a0d0e21e
LW		 5175 while (length-- > 0)
5176 SvREFCNT_dec(tmparyval[length]);
79072805 5177 }
79072805 5178 }
a0d0e21e 5179 else
3280af22 5180 *MARK = &PL_sv_undef;
d3961450 5181 Safefree(tmparyval);
79072805 5182 }
474af990
FR		 5183
5184 if (SvMAGICAL(ary))
5185 mg_set(MUTABLE_SV(ary));
5186
a0d0e21e 5187 SP = MARK;
79072805
LW		 5188 RETURN;
5189}
5190
a0d0e21e 5191PP(pp_push)
79072805 5192{
27da23d5 5193 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
eb578fdb 5194 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5195 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
79072805 5196
1b6737cc 5197 if (mg) {
ad64d0ec 5198 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
93965878
NIS		 5199 PUSHMARK(MARK);
5200 PUTBACK;
d343c3ef 5201 ENTER_with_name("call_PUSH");
3e0cb5de 5202 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5203 LEAVE_with_name("call_PUSH");
93965878 5204 SPAGAIN;
93965878 5205 }
a60c0954 5206 else {
cb077ed2 5207 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
89c14e2e 5208 PL_delaymagic = DM_DELAY;
a60c0954 5209 for (++MARK; MARK <= SP; MARK++) {
3ed356df
FC		 5210 SV *sv;
5211 if (*MARK) SvGETMAGIC(*MARK);
5212 sv = newSV(0);
a60c0954 5213 if (*MARK)
3ed356df 5214 sv_setsv_nomg(sv, *MARK);
0a75904b 5215 av_store(ary, AvFILLp(ary)+1, sv);
a60c0954 5216 }
354b0578 5217 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 5218 mg_set(MUTABLE_SV(ary));
89c14e2e
BB		 5219
5220 PL_delaymagic = 0;
6eeabd23
VP		 5221 }
5222 SP = ORIGMARK;
5223 if (OP_GIMME(PL_op, 0) != G_VOID) {
5224 PUSHi( AvFILL(ary) + 1 );
79072805 5225 }
79072805
LW		 5226 RETURN;
5227}
5228
a0d0e21e 5229PP(pp_shift)
79072805 5230{
97aff369 5231 dVAR;
39644a26 5232 dSP;
538f5756 5233 AV * const av = PL_op->op_flags & OPf_SPECIAL
d4fc4415 5234 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
789b4bc9 5235 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
79072805 5236 EXTEND(SP, 1);
c2b4a044 5237 assert (sv);
d689ffdd 5238 if (AvREAL(av))
a0d0e21e
LW		 5239 (void)sv_2mortal(sv);
5240 PUSHs(sv);
79072805 5241 RETURN;
79072805
LW		 5242}
5243
a0d0e21e 5244PP(pp_unshift)
79072805 5245{
27da23d5 5246 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
eb578fdb 5247 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5248 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 5249
1b6737cc 5250 if (mg) {
ad64d0ec 5251 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
7fd66d9d 5252 PUSHMARK(MARK);
93965878 5253 PUTBACK;
d343c3ef 5254 ENTER_with_name("call_UNSHIFT");
36925d9e 5255 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5256 LEAVE_with_name("call_UNSHIFT");
93965878 5257 SPAGAIN;
93965878 5258 }
a60c0954 5259 else {
c70927a6 5260 SSize_t i = 0;
a60c0954
NIS		 5261 av_unshift(ary, SP - MARK);
5262 while (MARK < SP) {
1b6737cc 5263 SV * const sv = newSVsv(*++MARK);
a60c0954
NIS		 5264 (void)av_store(ary, i++, sv);
5265 }
79072805 5266 }
a0d0e21e 5267 SP = ORIGMARK;
6eeabd23 5268 if (OP_GIMME(PL_op, 0) != G_VOID) {
5658d0a9
LR		 5269 PUSHi( AvFILL(ary) + 1 );
5270 }
79072805 5271 RETURN;
79072805
LW		 5272}
5273
a0d0e21e 5274PP(pp_reverse)
79072805 5275{
97aff369 5276 dVAR; dSP; dMARK;
79072805 5277
a0d0e21e 5278 if (GIMME == G_ARRAY) {
484c818f
VP		 5279 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5280 AV *av;
5281
5282 /* See pp_sort() */
5283 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5284 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5285 av = MUTABLE_AV((*SP));
5286 /* In-place reversing only happens in void context for the array
5287 * assignment. We don't need to push anything on the stack. */
5288 SP = MARK;
5289
5290 if (SvMAGICAL(av)) {
c70927a6 5291 SSize_t i, j;
eb578fdb 5292 SV *tmp = sv_newmortal();
484c818f
VP		 5293 /* For SvCANEXISTDELETE */
5294 HV *stash;
5295 const MAGIC *mg;
5296 bool can_preserve = SvCANEXISTDELETE(av);
5297
5298 for (i = 0, j = av_len(av); i < j; ++i, --j) {
eb578fdb 5299 SV *begin, *end;
484c818f
VP		 5300
5301 if (can_preserve) {
5302 if (!av_exists(av, i)) {
5303 if (av_exists(av, j)) {
eb578fdb 5304 SV *sv = av_delete(av, j, 0);
484c818f
VP		 5305 begin = *av_fetch(av, i, TRUE);
5306 sv_setsv_mg(begin, sv);
5307 }
5308 continue;
5309 }
5310 else if (!av_exists(av, j)) {
eb578fdb 5311 SV *sv = av_delete(av, i, 0);
484c818f
VP		 5312 end = *av_fetch(av, j, TRUE);
5313 sv_setsv_mg(end, sv);
5314 continue;
5315 }
5316 }
5317
5318 begin = *av_fetch(av, i, TRUE);
5319 end = *av_fetch(av, j, TRUE);
5320 sv_setsv(tmp, begin);
5321 sv_setsv_mg(begin, end);
5322 sv_setsv_mg(end, tmp);
5323 }
5324 }
5325 else {
5326 SV **begin = AvARRAY(av);
484c818f 5327
95a26d8e
VP		 5328 if (begin) {
5329 SV **end = begin + AvFILLp(av);
5330
5331 while (begin < end) {
eb578fdb 5332 SV * const tmp = *begin;
95a26d8e
VP		 5333 *begin++ = *end;
5334 *end-- = tmp;
5335 }
484c818f
VP		 5336 }
5337 }
5338 }
5339 else {
5340 SV **oldsp = SP;
5341 MARK++;
5342 while (MARK < SP) {
eb578fdb 5343 SV * const tmp = *MARK;
484c818f
VP		 5344 *MARK++ = *SP;
5345 *SP-- = tmp;
5346 }
5347 /* safe as long as stack cannot get extended in the above */
5348 SP = oldsp;
a0d0e21e 5349 }
79072805
LW		 5350 }
5351 else {
eb578fdb
KW		 5352 char *up;
5353 char *down;
5354 I32 tmp;
a0d0e21e
LW		 5355 dTARGET;
5356 STRLEN len;
79072805 5357
7e2040f0 5358 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 5359 if (SP - MARK > 1)
3280af22 5360 do_join(TARG, &PL_sv_no, MARK, SP);
1e21d011 5361 else {
789bd863 5362 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
1e21d011
B		 5363 }
5364
a0d0e21e
LW		 5365 up = SvPV_force(TARG, len);
5366 if (len > 1) {
7e2040f0 5367 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55 5368 U8* s = (U8*)SvPVX(TARG);
349d4f2f 5369 const U8* send = (U8*)(s + len);
a0ed51b3 5370 while (s < send) {
d742c382 5371 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 5372 s++;
5373 continue;
5374 }
5375 else {
4b88fb76 5376 if (!utf8_to_uvchr_buf(s, send, 0))
a0dbb045 5377 break;
dfe13c55 5378 up = (char*)s;
a0ed51b3 5379 s += UTF8SKIP(s);
dfe13c55 5380 down = (char*)(s - 1);
a0dbb045 5381 /* reverse this character */
a0ed51b3
LW		 5382 while (down > up) {
5383 tmp = *up;
5384 *up++ = *down;
eb160463 5385 *down-- = (char)tmp;
a0ed51b3
LW		 5386 }
5387 }
5388 }
5389 up = SvPVX(TARG);
5390 }
a0d0e21e
LW		 5391 down = SvPVX(TARG) + len - 1;
5392 while (down > up) {
5393 tmp = *up;
5394 *up++ = *down;
eb160463 5395 *down-- = (char)tmp;
a0d0e21e 5396 }
3aa33fe5 5397 (void)SvPOK_only_UTF8(TARG);
79072805 5398 }
a0d0e21e
LW		 5399 SP = MARK + 1;
5400 SETTARG;
79072805 5401 }
a0d0e21e 5402 RETURN;
79072805
LW		 5403}
5404
a0d0e21e 5405PP(pp_split)
79072805 5406{
27da23d5 5407 dVAR; dSP; dTARG;
a0d0e21e 5408 AV *ary;
eb578fdb 5409 IV limit = POPi; /* note, negative is forever */
1b6737cc 5410 SV * const sv = POPs;
a0d0e21e 5411 STRLEN len;
eb578fdb 5412 const char *s = SvPV_const(sv, len);
1b6737cc 5413 const bool do_utf8 = DO_UTF8(sv);
727b7506 5414 const char *strend = s + len;
eb578fdb
KW		 5415 PMOP *pm;
5416 REGEXP *rx;
5417 SV *dstr;
5418 const char *m;
c70927a6 5419 SSize_t iters = 0;
d14578b8
KW		 5420 const STRLEN slen = do_utf8
5421 ? utf8_length((U8*)s, (U8*)strend)
5422 : (STRLEN)(strend - s);
c70927a6 5423 SSize_t maxiters = slen + 10;
c1a7495a 5424 I32 trailing_empty = 0;
727b7506 5425 const char *orig;
1b6737cc 5426 const I32 origlimit = limit;
a0d0e21e
LW		 5427 I32 realarray = 0;
5428 I32 base;
f54cb97a 5429 const I32 gimme = GIMME_V;
941446f6 5430 bool gimme_scalar;
f54cb97a 5431 const I32 oldsave = PL_savestack_ix;
437d3b4e 5432 U32 make_mortal = SVs_TEMP;
7fba1cd6 5433 bool multiline = 0;
b37c2d43 5434 MAGIC *mg = NULL;
79072805 5435
44a8e56a 5436#ifdef DEBUGGING
5437 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5438#else
5439 pm = (PMOP*)POPs;
5440#endif
a0d0e21e 5441 if (!pm || !s)
5637ef5b 5442 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
aaa362c4 5443 rx = PM_GETRE(pm);
bbce6d69 5444
a62b1201 5445 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
dbc200c5 5446 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
bbce6d69 5447
971a9dd3 5448#ifdef USE_ITHREADS
20e98b0f 5449 if (pm->op_pmreplrootu.op_pmtargetoff) {
159b6efe 5450 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
20e98b0f 5451 }
971a9dd3 5452#else
20e98b0f
NC		 5453 if (pm->op_pmreplrootu.op_pmtargetgv) {
5454 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
971a9dd3 5455 }
20e98b0f 5456#endif
79072805 5457 else
7d49f689 5458 ary = NULL;
bcea25a7 5459 if (ary) {
a0d0e21e 5460 realarray = 1;
8ec5e241 5461 PUTBACK;
a0d0e21e
LW		 5462 av_extend(ary,0);
5463 av_clear(ary);
8ec5e241 5464 SPAGAIN;
ad64d0ec 5465 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
8ec5e241 5466 PUSHMARK(SP);
ad64d0ec 5467 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
8ec5e241
NIS		 5468 }
5469 else {
1c0b011c 5470 if (!AvREAL(ary)) {
1b6737cc 5471 I32 i;
1c0b011c 5472 AvREAL_on(ary);
abff13bb 5473 AvREIFY_off(ary);
1c0b011c 5474 for (i = AvFILLp(ary); i >= 0; i--)
d14578b8 5475 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 5476 }
5477 /* temporarily switch stacks */
8b7059b1 5478 SAVESWITCHSTACK(PL_curstack, ary);
8ec5e241 5479 make_mortal = 0;
1c0b011c 5480 }
79072805 5481 }
3280af22 5482 base = SP - PL_stack_base;
a0d0e21e 5483 orig = s;
dbc200c5 5484 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
613f191e 5485 if (do_utf8) {
76a77b1b 5486 while (isSPACE_utf8(s))
613f191e
TS		 5487 s += UTF8SKIP(s);
5488 }
a62b1201 5489 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
bbce6d69 5490 while (isSPACE_LC(*s))
5491 s++;
5492 }
5493 else {
5494 while (isSPACE(*s))
5495 s++;
5496 }
a0d0e21e 5497 }
73134a2e 5498 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
7fba1cd6 5499 multiline = 1;
c07a80fd 5500 }
5501
941446f6
FC		 5502 gimme_scalar = gimme == G_SCALAR && !ary;
5503
a0d0e21e
LW		 5504 if (!limit)
5505 limit = maxiters + 2;
dbc200c5 5506 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
a0d0e21e 5507 while (--limit) {
bbce6d69 5508 m = s;
8727f688
YO		 5509 /* this one uses 'm' and is a negative test */
5510 if (do_utf8) {
76a77b1b 5511 while (m < strend && ! isSPACE_utf8(m) ) {
613f191e 5512 const int t = UTF8SKIP(m);
76a77b1b 5513 /* isSPACE_utf8 returns FALSE for malform utf8 */
613f191e
TS		 5514 if (strend - m < t)
5515 m = strend;
5516 else
5517 m += t;
5518 }
a62b1201 5519 }
d14578b8
KW		 5520 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5521 {
8727f688
YO		 5522 while (m < strend && !isSPACE_LC(*m))
5523 ++m;
5524 } else {
5525 while (m < strend && !isSPACE(*m))
5526 ++m;
5527 }
a0d0e21e
LW		 5528 if (m >= strend)
5529 break;
bbce6d69 5530
c1a7495a
BB		 5531 if (gimme_scalar) {
5532 iters++;
5533 if (m-s == 0)
5534 trailing_empty++;
5535 else
5536 trailing_empty = 0;
5537 } else {
5538 dstr = newSVpvn_flags(s, m-s,
5539 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5540 XPUSHs(dstr);
5541 }
bbce6d69 5542
613f191e
TS		 5543 /* skip the whitespace found last */
5544 if (do_utf8)
5545 s = m + UTF8SKIP(m);
5546 else
5547 s = m + 1;
5548
8727f688
YO		 5549 /* this one uses 's' and is a positive test */
5550 if (do_utf8) {
76a77b1b 5551 while (s < strend && isSPACE_utf8(s) )
8727f688 5552 s += UTF8SKIP(s);
a62b1201 5553 }
d14578b8
KW		 5554 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5555 {
8727f688
YO		 5556 while (s < strend && isSPACE_LC(*s))
5557 ++s;
5558 } else {
5559 while (s < strend && isSPACE(*s))
5560 ++s;
5561 }
79072805
LW		 5562 }
5563 }
07bc277f 5564 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
a0d0e21e 5565 while (--limit) {
a6e20a40
AL		 5566 for (m = s; m < strend && *m != '\n'; m++)
5567 ;
a0d0e21e
LW		 5568 m++;
5569 if (m >= strend)
5570 break;
c1a7495a
BB		 5571
5572 if (gimme_scalar) {
5573 iters++;
5574 if (m-s == 0)
5575 trailing_empty++;
5576 else
5577 trailing_empty = 0;
5578 } else {
5579 dstr = newSVpvn_flags(s, m-s,
5580 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5581 XPUSHs(dstr);
5582 }
a0d0e21e
LW		 5583 s = m;
5584 }
5585 }
07bc277f 5586 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
640f820d
AB		 5587 /*
5588 Pre-extend the stack, either the number of bytes or
5589 characters in the string or a limited amount, triggered by:
5590
5591 my ($x, $y) = split //, $str;
5592 or
5593 split //, $str, $i;
5594 */
c1a7495a
BB		 5595 if (!gimme_scalar) {
5596 const U32 items = limit - 1;
5597 if (items < slen)
5598 EXTEND(SP, items);
5599 else
5600 EXTEND(SP, slen);
5601 }
640f820d 5602
e9515b0f
AB		 5603 if (do_utf8) {
5604 while (--limit) {
5605 /* keep track of how many bytes we skip over */
5606 m = s;
640f820d 5607 s += UTF8SKIP(s);
c1a7495a
BB		 5608 if (gimme_scalar) {
5609 iters++;
5610 if (s-m == 0)
5611 trailing_empty++;
5612 else
5613 trailing_empty = 0;
5614 } else {
5615 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
640f820d 5616
c1a7495a
BB		 5617 PUSHs(dstr);
5618 }
640f820d 5619
e9515b0f
AB		 5620 if (s >= strend)
5621 break;
5622 }
5623 } else {
5624 while (--limit) {
c1a7495a
BB		 5625 if (gimme_scalar) {
5626 iters++;
5627 } else {
5628 dstr = newSVpvn(s, 1);
e9515b0f 5629
e9515b0f 5630
c1a7495a
BB		 5631 if (make_mortal)
5632 sv_2mortal(dstr);
640f820d 5633
c1a7495a
BB		 5634 PUSHs(dstr);
5635 }
5636
5637 s++;
e9515b0f
AB		 5638
5639 if (s >= strend)
5640 break;
5641 }
640f820d
AB		 5642 }
5643 }
3c8556c3 5644 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
07bc277f
NC		 5645 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5646 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5647 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5648 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
f9f4320a 5649 SV * const csv = CALLREG_INTUIT_STRING(rx);
cf93c79d 5650
07bc277f 5651 len = RX_MINLENRET(rx);
3c8556c3 5652 if (len == 1 && !RX_UTF8(rx) && !tail) {
1b6737cc 5653 const char c = *SvPV_nolen_const(csv);
a0d0e21e 5654 while (--limit) {
a6e20a40
AL		 5655 for (m = s; m < strend && *m != c; m++)
5656 ;
a0d0e21e
LW		 5657 if (m >= strend)
5658 break;
c1a7495a
BB		 5659 if (gimme_scalar) {
5660 iters++;
5661 if (m-s == 0)
5662 trailing_empty++;
5663 else
5664 trailing_empty = 0;
5665 } else {
5666 dstr = newSVpvn_flags(s, m-s,
d14578b8 5667 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
c1a7495a
BB		 5668 XPUSHs(dstr);
5669 }
93f04dac
JH		 5670 /* The rx->minlen is in characters but we want to step
5671 * s ahead by bytes. */
1aa99e6b
IH		 5672 if (do_utf8)
5673 s = (char*)utf8_hop((U8*)m, len);
5674 else
5675 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 5676 }
5677 }
5678 else {
a0d0e21e 5679 while (s < strend && --limit &&
f722798b 5680 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
7fba1cd6 5681 csv, multiline ? FBMrf_MULTILINE : 0)) )
a0d0e21e 5682 {
c1a7495a
BB		 5683 if (gimme_scalar) {
5684 iters++;
5685 if (m-s == 0)
5686 trailing_empty++;
5687 else
5688 trailing_empty = 0;
5689 } else {
5690 dstr = newSVpvn_flags(s, m-s,
d14578b8 5691 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
c1a7495a
BB		 5692 XPUSHs(dstr);
5693 }
93f04dac
JH		 5694 /* The rx->minlen is in characters but we want to step
5695 * s ahead by bytes. */
1aa99e6b
IH		 5696 if (do_utf8)
5697 s = (char*)utf8_hop((U8*)m, len);
5698 else
5699 s = m + len; /* Fake \n at the end */
a0d0e21e 5700 }
463ee0b2 5701 }
463ee0b2 5702 }
a0d0e21e 5703 else {
07bc277f 5704 maxiters += slen * RX_NPARENS(rx);
080c2dec 5705 while (s < strend && --limit)
bbce6d69 5706 {
1b6737cc 5707 I32 rex_return;
080c2dec 5708 PUTBACK;
d14578b8 5709 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
c33e64f0 5710 sv, NULL, 0);
080c2dec 5711 SPAGAIN;
1b6737cc 5712 if (rex_return == 0)
080c2dec 5713 break;
d9f97599 5714 TAINT_IF(RX_MATCH_TAINTED(rx));
6502e081
DM		 5715 /* we never pass the REXEC_COPY_STR flag, so it should
5716 * never get copied */
5717 assert(!RX_MATCH_COPIED(rx));
07bc277f 5718 m = RX_OFFS(rx)[0].start + orig;
c1a7495a
BB		 5719
5720 if (gimme_scalar) {
5721 iters++;
5722 if (m-s == 0)
5723 trailing_empty++;
5724 else
5725 trailing_empty = 0;
5726 } else {
5727 dstr = newSVpvn_flags(s, m-s,
5728 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5729 XPUSHs(dstr);
5730 }
07bc277f 5731 if (RX_NPARENS(rx)) {
1b6737cc 5732 I32 i;
07bc277f
NC		 5733 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5734 s = RX_OFFS(rx)[i].start + orig;
5735 m = RX_OFFS(rx)[i].end + orig;
6de67870
JP		 5736
5737 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5738 parens that didn't match -- they should be set to
5739 undef, not the empty string */
c1a7495a
BB		 5740 if (gimme_scalar) {
5741 iters++;
5742 if (m-s == 0)
5743 trailing_empty++;
5744 else
5745 trailing_empty = 0;
5746 } else {
5747 if (m >= orig && s >= orig) {
5748 dstr = newSVpvn_flags(s, m-s,
5749 (do_utf8 ? SVf_UTF8 : 0)
5750 | make_mortal);
5751 }
5752 else
5753 dstr = &PL_sv_undef; /* undef, not "" */
5754 XPUSHs(dstr);
748a9306 5755 }
c1a7495a 5756
a0d0e21e
LW		 5757 }
5758 }
07bc277f 5759 s = RX_OFFS(rx)[0].end + orig;
a0d0e21e 5760 }
79072805 5761 }
8ec5e241 5762
c1a7495a
BB		 5763 if (!gimme_scalar) {
5764 iters = (SP - PL_stack_base) - base;
5765 }
a0d0e21e 5766 if (iters > maxiters)
cea2e8a9 5767 DIE(aTHX_ "Split loop");
8ec5e241 5768
a0d0e21e
LW		 5769 /* keep field after final delim? */
5770 if (s < strend || (iters && origlimit)) {
c1a7495a
BB		 5771 if (!gimme_scalar) {
5772 const STRLEN l = strend - s;
5773 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5774 XPUSHs(dstr);
5775 }
a0d0e21e 5776 iters++;
79072805 5777 }
a0d0e21e 5778 else if (!origlimit) {
c1a7495a
BB		 5779 if (gimme_scalar) {
5780 iters -= trailing_empty;
5781 } else {
5782 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5783 if (TOPs && !make_mortal)
5784 sv_2mortal(TOPs);
5785 *SP-- = &PL_sv_undef;
5786 iters--;
5787 }
89900bd3 5788 }
a0d0e21e 5789 }
8ec5e241 5790
8b7059b1
DM		 5791 PUTBACK;
5792 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5793 SPAGAIN;
a0d0e21e 5794 if (realarray) {
8ec5e241 5795 if (!mg) {
1c0b011c
NIS		 5796 if (SvSMAGICAL(ary)) {
5797 PUTBACK;
ad64d0ec 5798 mg_set(MUTABLE_SV(ary));
1c0b011c
NIS		 5799 SPAGAIN;
5800 }
5801 if (gimme == G_ARRAY) {
5802 EXTEND(SP, iters);
5803 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5804 SP += iters;
5805 RETURN;
5806 }
8ec5e241 5807 }
1c0b011c 5808 else {
fb73857a 5809 PUTBACK;
d343c3ef 5810 ENTER_with_name("call_PUSH");
36925d9e 5811 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5812 LEAVE_with_name("call_PUSH");
fb73857a 5813 SPAGAIN;
8ec5e241 5814 if (gimme == G_ARRAY) {
c70927a6 5815 SSize_t i;
8ec5e241
NIS		 5816 /* EXTEND should not be needed - we just popped them */
5817 EXTEND(SP, iters);
5818 for (i=0; i < iters; i++) {
5819 SV **svp = av_fetch(ary, i, FALSE);
3280af22 5820 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 5821 }
1c0b011c
NIS		 5822 RETURN;
5823 }
a0d0e21e
LW		 5824 }
5825 }
5826 else {
5827 if (gimme == G_ARRAY)
5828 RETURN;
5829 }
7f18b612
YST		 5830
5831 GETTARGET;
5832 PUSHi(iters);
5833 RETURN;
79072805 5834}
85e6fe83 5835
c5917253
NC		 5836PP(pp_once)
5837{
5838 dSP;
5839 SV *const sv = PAD_SVl(PL_op->op_targ);
5840
5841 if (SvPADSTALE(sv)) {
5842 /* First time. */
5843 SvPADSTALE_off(sv);
5844 RETURNOP(cLOGOP->op_other);
5845 }
5846 RETURNOP(cLOGOP->op_next);
5847}
5848
c0329465
MB		 5849PP(pp_lock)
5850{
97aff369 5851 dVAR;
39644a26 5852 dSP;
c0329465 5853 dTOPss;
e55aaa0e 5854 SV *retsv = sv;
68795e93 5855 SvLOCK(sv);
f79aa60b
FC		 5856 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5857 || SvTYPE(retsv) == SVt_PVCV) {
e55aaa0e
MB		 5858 retsv = refto(retsv);
5859 }
5860 SETs(retsv);
c0329465
MB		 5861 RETURN;
5862}
a863c7d1 5863
65bca31a
NC		 5864
5865PP(unimplemented_op)
5866{
97aff369 5867 dVAR;
361ed549
NC		 5868 const Optype op_type = PL_op->op_type;
5869 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5870 with out of range op numbers - it only "special" cases op_custom.
5871 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5872 if we get here for a custom op then that means that the custom op didn't
5873 have an implementation. Given that OP_NAME() looks up the custom op
5874 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5875 registers &PL_unimplemented_op as the address of their custom op.
5876 NULL doesn't generate a useful error message. "custom" does. */
5877 const char *const name = op_type >= OP_max
5878 ? "[out of range]" : PL_op_name[PL_op->op_type];
7627e6d0
NC		 5879 if(OP_IS_SOCKET(op_type))
5880 DIE(aTHX_ PL_no_sock_func, name);
361ed549 5881 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
65bca31a
NC		 5882}
5883
deb8a388
FC		 5884/* For sorting out arguments passed to a &CORE:: subroutine */
5885PP(pp_coreargs)
5886{
5887 dSP;
7fa5bd9b 5888 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
498a02d8 5889 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
7fa5bd9b 5890 AV * const at_ = GvAV(PL_defgv);
0e80230d
FC		 5891 SV **svp = at_ ? AvARRAY(at_) : NULL;
5892 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
7fa5bd9b 5893 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
46e00a91 5894 bool seen_question = 0;
7fa5bd9b 5895 const char *err = NULL;
3e6568b4 5896 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
7fa5bd9b 5897
46e00a91
FC		 5898 /* Count how many args there are first, to get some idea how far to
5899 extend the stack. */
7fa5bd9b 5900 while (oa) {
bf0571fd 5901 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
7fa5bd9b 5902 maxargs++;
46e00a91
FC		 5903 if (oa & OA_OPTIONAL) seen_question = 1;
5904 if (!seen_question) minargs++;
7fa5bd9b
FC		 5905 oa >>= 4;
5906 }
5907
5908 if(numargs < minargs) err = "Not enough";
5909 else if(numargs > maxargs) err = "Too many";
5910 if (err)
5911 /* diag_listed_as: Too many arguments for %s */
5912 Perl_croak(aTHX_
5913 "%s arguments for %s", err,
2a90c7c6 5914 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
7fa5bd9b
FC		 5915 );
5916
5917 /* Reset the stack pointer. Without this, we end up returning our own
5918 arguments in list context, in addition to the values we are supposed
5919 to return. nextstate usually does this on sub entry, but we need
e1fa07e3 5920 to run the next op with the caller's hints, so we cannot have a
7fa5bd9b
FC		 5921 nextstate. */
5922 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5923
46e00a91
FC		 5924 if(!maxargs) RETURN;
5925
bf0571fd
FC		 5926 /* We do this here, rather than with a separate pushmark op, as it has
5927 to come in between two things this function does (stack reset and
5928 arg pushing). This seems the easiest way to do it. */
3e6568b4 5929 if (pushmark) {
bf0571fd
FC		 5930 PUTBACK;
5931 (void)Perl_pp_pushmark(aTHX);
5932 }
5933
5934 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
c931b036 5935 PUTBACK; /* The code below can die in various places. */
46e00a91
FC		 5936
5937 oa = PL_opargs[opnum] >> OASHIFT;
3e6568b4 5938 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
c931b036 5939 whicharg++;
46e00a91
FC		 5940 switch (oa & 7) {
5941 case OA_SCALAR:
1efec5ed 5942 try_defsv:
d6d78e19 5943 if (!numargs && defgv && whicharg == minargs + 1) {
d6d78e19 5944 PUSHs(find_rundefsv2(
db4cf31d 5945 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
b4b0692a 5946 cxstack[cxstack_ix].blk_oldcop->cop_seq
d6d78e19
FC		 5947 ));
5948 }
5949 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
46e00a91 5950 break;
bf0571fd
FC		 5951 case OA_LIST:
5952 while (numargs--) {
5953 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5954 svp++;
5955 }
5956 RETURN;
19c481f4
FC		 5957 case OA_HVREF:
5958 if (!svp || !*svp || !SvROK(*svp)
5959 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5960 DIE(aTHX_
5961 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5962 "Type of arg %d to &CORE::%s must be hash reference",
5963 whicharg, OP_DESC(PL_op->op_next)
5964 );
5965 PUSHs(SvRV(*svp));
5966 break;
c931b036 5967 case OA_FILEREF:
30901a8a
FC		 5968 if (!numargs) PUSHs(NULL);
5969 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
c931b036
FC		 5970 /* no magic here, as the prototype will have added an extra
5971 refgen and we just want what was there before that */
5972 PUSHs(SvRV(*svp));
5973 else {
5974 const bool constr = PL_op->op_private & whicharg;
5975 PUSHs(S_rv2gv(aTHX_
5976 svp && *svp ? *svp : &PL_sv_undef,
b54f893d 5977 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
c931b036
FC		 5978 !constr
5979 ));
5980 }
5981 break;
c72a5629 5982 case OA_SCALARREF:
1efec5ed
FC		 5983 if (!numargs) goto try_defsv;
5984 else {
17008668
FC		 5985 const bool wantscalar =
5986 PL_op->op_private & OPpCOREARGS_SCALARMOD;
c72a5629 5987 if (!svp || !*svp || !SvROK(*svp)
17008668
FC		 5988 /* We have to permit globrefs even for the \$ proto, as
5989 *foo is indistinguishable from ${\*foo}, and the proto-
5990 type permits the latter. */
5991 || SvTYPE(SvRV(*svp)) > (
efe889ae 5992 wantscalar ? SVt_PVLV
46bef06f
FC		 5993 : opnum == OP_LOCK || opnum == OP_UNDEF
5994 ? SVt_PVCV
efe889ae 5995 : SVt_PVHV
17008668 5996 )
c72a5629
FC		 5997 )
5998 DIE(aTHX_
17008668 5999 "Type of arg %d to &CORE::%s must be %s",
46bef06f 6000 whicharg, PL_op_name[opnum],
17008668
FC		 6001 wantscalar
6002 ? "scalar reference"
46bef06f 6003 : opnum == OP_LOCK || opnum == OP_UNDEF
efe889ae
FC		 6004 ? "reference to one of [$@%&*]"
6005 : "reference to one of [$@%*]"
c72a5629
FC		 6006 );
6007 PUSHs(SvRV(*svp));
88bb468b
FC		 6008 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6009 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6010 /* Undo @_ localisation, so that sub exit does not undo
6011 part of our undeffing. */
6012 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6013 POP_SAVEARRAY();
6014 cx->cx_type &= ~ CXp_HASARGS;
6015 assert(!AvREAL(cx->blk_sub.argarray));
6016 }
17008668 6017 }
1efec5ed 6018 break;
46e00a91 6019 default:
46e00a91
FC		 6020 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6021 }
6022 oa = oa >> 4;
6023 }
6024
deb8a388
FC		 6025 RETURN;
6026}
6027
84ed0108
FC		 6028PP(pp_runcv)
6029{
6030 dSP;
6031 CV *cv;
6032 if (PL_op->op_private & OPpOFFBYONE) {
db4cf31d 6033 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
84ed0108
FC		 6034 }
6035 else cv = find_runcv(NULL);
e157a82b 6036 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
84ed0108
FC		 6037 RETURN;
6038}
6039
6040
e609e586
NC		 6041/*
6042 * Local variables:
6043 * c-indentation-style: bsd
6044 * c-basic-offset: 4
14d04a33 6045 * indent-tabs-mode: nil
e609e586
NC		 6046 * End:
6047 *
14d04a33 6048 * ex: set ts=8 sts=4 sw=4 et:
37442d52 6049 */
Unnamed repository; edit this file 'description' to name the repository.