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