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