This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
regcomp.c: Remove wrong/obsolete line
[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);
565764a8 442 if (mg && mg->mg_len >= 0) {
2154eca7 443 dTARGET;
a0ed51b3 444 I32 i = mg->mg_len;
7e2040f0 445 if (DO_UTF8(sv))
a0ed51b3 446 sv_pos_b2u(sv, &i);
e1dccc0d 447 PUSHi(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;
79072805 1660
2b573ace
JH		 1661 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1662 /* Did the max computation overflow? */
27d5b266 1663 if (items > 0 && max > 0 && (max < items || max < count))
0157ef98 1664 Perl_croak(aTHX_ "%s", oom_list_extend);
a0d0e21e
LW		 1665 MEXTEND(MARK, max);
1666 if (count > 1) {
1667 while (SP > MARK) {
976c8a39
JH		 1668#if 0
1669 /* This code was intended to fix 20010809.028:
1670
1671 $x = 'abcd';
1672 for (($x =~ /./g) x 2) {
1673 print chop; # "abcdabcd" expected as output.
1674 }
1675
1676 * but that change (#11635) broke this code:
1677
1678 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1679
1680 * I can't think of a better fix that doesn't introduce
1681 * an efficiency hit by copying the SVs. The stack isn't
1682 * refcounted, and mortalisation obviously doesn't
1683 * Do The Right Thing when the stack has more than
1684 * one pointer to the same mortal value.
1685 * .robin.
1686 */
e30acc16
RH		 1687 if (*SP) {
1688 *SP = sv_2mortal(newSVsv(*SP));
1689 SvREADONLY_on(*SP);
1690 }
976c8a39
JH		 1691#else
1692 if (*SP)
1693 SvTEMP_off((*SP));
1694#endif
a0d0e21e 1695 SP--;
79072805 1696 }
a0d0e21e
LW		 1697 MARK++;
1698 repeatcpy((char*)(MARK + items), (char*)MARK,
ad64d0ec 1699 items * sizeof(const SV *), count - 1);
a0d0e21e 1700 SP += max;
79072805 1701 }
a0d0e21e
LW		 1702 else if (count <= 0)
1703 SP -= items;
79072805 1704 }
a0d0e21e 1705 else { /* Note: mark already snarfed by pp_list */
0bd48802 1706 SV * const tmpstr = POPs;
a0d0e21e 1707 STRLEN len;
9b877dbb 1708 bool isutf;
a1894d81 1709 static const char* const oom_string_extend =
2b573ace 1710 "Out of memory during string extend";
a0d0e21e 1711
6f1401dc
DM		 1712 if (TARG != tmpstr)
1713 sv_setsv_nomg(TARG, tmpstr);
1714 SvPV_force_nomg(TARG, len);
9b877dbb 1715 isutf = DO_UTF8(TARG);
8ebc5c01 1716 if (count != 1) {
1717 if (count < 1)
1718 SvCUR_set(TARG, 0);
1719 else {
c445ea15 1720 const STRLEN max = (UV)count * len;
19a94d75 1721 if (len > MEM_SIZE_MAX / count)
0157ef98 1722 Perl_croak(aTHX_ "%s", oom_string_extend);
2b573ace 1723 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
8569b9dc 1724 SvGROW(TARG, max + 1);
a0d0e21e 1725 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
b162af07 1726 SvCUR_set(TARG, SvCUR(TARG) * count);
7a4c00b4 1727 }
a0d0e21e 1728 *SvEND(TARG) = '\0';
a0d0e21e 1729 }
dfcb284a
GS		 1730 if (isutf)
1731 (void)SvPOK_only_UTF8(TARG);
1732 else
1733 (void)SvPOK_only(TARG);
b80b6069
RH		 1734
1735 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1736 /* The parser saw this as a list repeat, and there
1737 are probably several items on the stack. But we're
1738 in scalar context, and there's no pp_list to save us
1739 now. So drop the rest of the items -- robin@kitsite.com
1740 */
1741 dMARK;
1742 SP = MARK;
1743 }
a0d0e21e 1744 PUSHTARG;
79072805 1745 }
a0d0e21e
LW		 1746 RETURN;
1747}
79072805 1748
a0d0e21e
LW		 1749PP(pp_subtract)
1750{
800401ee 1751 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM		 1752 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1753 svr = TOPs;
1754 svl = TOPm1s;
800401ee 1755 useleft = USE_LEFT(svl);
28e5dec8 1756#ifdef PERL_PRESERVE_IVUV
7dca457a
NC		 1757 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1758 "bad things" happen if you rely on signed integers wrapping. */
01f91bf2 1759 if (SvIV_please_nomg(svr)) {
28e5dec8
JH		 1760 /* Unless the left argument is integer in range we are going to have to
1761 use NV maths. Hence only attempt to coerce the right argument if
1762 we know the left is integer. */
eb578fdb 1763 UV auv = 0;
9c5ffd7c 1764 bool auvok = FALSE;
7dca457a
NC		 1765 bool a_valid = 0;
1766
28e5dec8 1767 if (!useleft) {
7dca457a
NC		 1768 auv = 0;
1769 a_valid = auvok = 1;
1770 /* left operand is undef, treat as zero. */
28e5dec8
JH		 1771 } else {
1772 /* Left operand is defined, so is it IV? */
01f91bf2 1773 if (SvIV_please_nomg(svl)) {
800401ee
JH		 1774 if ((auvok = SvUOK(svl)))
1775 auv = SvUVX(svl);
7dca457a 1776 else {
eb578fdb 1777 const IV aiv = SvIVX(svl);
7dca457a
NC		 1778 if (aiv >= 0) {
1779 auv = aiv;
1780 auvok = 1; /* Now acting as a sign flag. */
1781 } else { /* 2s complement assumption for IV_MIN */
1782 auv = (UV)-aiv;
28e5dec8 1783 }
7dca457a
NC		 1784 }
1785 a_valid = 1;
1786 }
1787 }
1788 if (a_valid) {
1789 bool result_good = 0;
1790 UV result;
eb578fdb 1791 UV buv;
800401ee 1792 bool buvok = SvUOK(svr);
9041c2e3 1793
7dca457a 1794 if (buvok)
800401ee 1795 buv = SvUVX(svr);
7dca457a 1796 else {
eb578fdb 1797 const IV biv = SvIVX(svr);
7dca457a
NC		 1798 if (biv >= 0) {
1799 buv = biv;
1800 buvok = 1;
1801 } else
1802 buv = (UV)-biv;
1803 }
1804 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1805 else "IV" now, independent of how it came in.
7dca457a
NC		 1806 if a, b represents positive, A, B negative, a maps to -A etc
1807 a - b => (a - b)
1808 A - b => -(a + b)
1809 a - B => (a + b)
1810 A - B => -(a - b)
1811 all UV maths. negate result if A negative.
1812 subtract if signs same, add if signs differ. */
1813
1814 if (auvok ^ buvok) {
1815 /* Signs differ. */
1816 result = auv + buv;
1817 if (result >= auv)
1818 result_good = 1;
1819 } else {
1820 /* Signs same */
1821 if (auv >= buv) {
1822 result = auv - buv;
1823 /* Must get smaller */
1824 if (result <= auv)
1825 result_good = 1;
1826 } else {
1827 result = buv - auv;
1828 if (result <= buv) {
1829 /* result really should be -(auv-buv). as its negation
1830 of true value, need to swap our result flag */
1831 auvok = !auvok;
1832 result_good = 1;
28e5dec8 1833 }
28e5dec8
JH		 1834 }
1835 }
7dca457a
NC		 1836 if (result_good) {
1837 SP--;
1838 if (auvok)
1839 SETu( result );
1840 else {
1841 /* Negate result */
1842 if (result <= (UV)IV_MIN)
1843 SETi( -(IV)result );
1844 else {
1845 /* result valid, but out of range for IV. */
1846 SETn( -(NV)result );
1847 }
1848 }
1849 RETURN;
1850 } /* Overflow, drop through to NVs. */
28e5dec8
JH		 1851 }
1852 }
1853#endif
a0d0e21e 1854 {
6f1401dc 1855 NV value = SvNV_nomg(svr);
4efa5a16
RD		 1856 (void)POPs;
1857
28e5dec8
JH		 1858 if (!useleft) {
1859 /* left operand is undef, treat as zero - value */
1860 SETn(-value);
1861 RETURN;
1862 }
6f1401dc 1863 SETn( SvNV_nomg(svl) - value );
28e5dec8 1864 RETURN;
79072805 1865 }
a0d0e21e 1866}
79072805 1867
a0d0e21e
LW		 1868PP(pp_left_shift)
1869{
6f1401dc 1870 dVAR; dSP; dATARGET; SV *svl, *svr;
a42d0242 1871 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM		 1872 svr = POPs;
1873 svl = TOPs;
a0d0e21e 1874 {
6f1401dc 1875 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1876 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1877 const IV i = SvIV_nomg(svl);
972b05a9 1878 SETi(i << shift);
d0ba1bd2
JH		 1879 }
1880 else {
6f1401dc 1881 const UV u = SvUV_nomg(svl);
972b05a9 1882 SETu(u << shift);
d0ba1bd2 1883 }
55497cff 1884 RETURN;
79072805 1885 }
a0d0e21e 1886}
79072805 1887
a0d0e21e
LW		 1888PP(pp_right_shift)
1889{
6f1401dc 1890 dVAR; dSP; dATARGET; SV *svl, *svr;
a42d0242 1891 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM		 1892 svr = POPs;
1893 svl = TOPs;
a0d0e21e 1894 {
6f1401dc 1895 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1896 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1897 const IV i = SvIV_nomg(svl);
972b05a9 1898 SETi(i >> shift);
d0ba1bd2
JH		 1899 }
1900 else {
6f1401dc 1901 const UV u = SvUV_nomg(svl);
972b05a9 1902 SETu(u >> shift);
d0ba1bd2 1903 }
a0d0e21e 1904 RETURN;
93a17b20 1905 }
79072805
LW		 1906}
1907
a0d0e21e 1908PP(pp_lt)
79072805 1909{
6f1401dc 1910 dVAR; dSP;
33efebe6
DM		 1911 SV *left, *right;
1912
a42d0242 1913 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
33efebe6
DM		 1914 right = POPs;
1915 left = TOPs;
1916 SETs(boolSV(
1917 (SvIOK_notUV(left) && SvIOK_notUV(right))
1918 ? (SvIVX(left) < SvIVX(right))
1919 : (do_ncmp(left, right) == -1)
1920 ));
1921 RETURN;
a0d0e21e 1922}
79072805 1923
a0d0e21e
LW		 1924PP(pp_gt)
1925{
6f1401dc 1926 dVAR; dSP;
33efebe6 1927 SV *left, *right;
1b6737cc 1928
33efebe6
DM		 1929 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1930 right = POPs;
1931 left = TOPs;
1932 SETs(boolSV(
1933 (SvIOK_notUV(left) && SvIOK_notUV(right))
1934 ? (SvIVX(left) > SvIVX(right))
1935 : (do_ncmp(left, right) == 1)
1936 ));
1937 RETURN;
a0d0e21e
LW		 1938}
1939
1940PP(pp_le)
1941{
6f1401dc 1942 dVAR; dSP;
33efebe6 1943 SV *left, *right;
1b6737cc 1944
33efebe6
DM		 1945 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1946 right = POPs;
1947 left = TOPs;
1948 SETs(boolSV(
1949 (SvIOK_notUV(left) && SvIOK_notUV(right))
1950 ? (SvIVX(left) <= SvIVX(right))
1951 : (do_ncmp(left, right) <= 0)
1952 ));
1953 RETURN;
a0d0e21e
LW		 1954}
1955
1956PP(pp_ge)
1957{
6f1401dc 1958 dVAR; dSP;
33efebe6
DM		 1959 SV *left, *right;
1960
1961 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1962 right = POPs;
1963 left = TOPs;
1964 SETs(boolSV(
1965 (SvIOK_notUV(left) && SvIOK_notUV(right))
1966 ? (SvIVX(left) >= SvIVX(right))
1967 : ( (do_ncmp(left, right) & 2) == 0)
1968 ));
1969 RETURN;
1970}
1b6737cc 1971
33efebe6
DM		 1972PP(pp_ne)
1973{
1974 dVAR; dSP;
1975 SV *left, *right;
1976
1977 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1978 right = POPs;
1979 left = TOPs;
1980 SETs(boolSV(
1981 (SvIOK_notUV(left) && SvIOK_notUV(right))
1982 ? (SvIVX(left) != SvIVX(right))
1983 : (do_ncmp(left, right) != 0)
1984 ));
1985 RETURN;
1986}
1b6737cc 1987
33efebe6
DM		 1988/* compare left and right SVs. Returns:
1989 * -1: <
1990 * 0: ==
1991 * 1: >
1992 * 2: left or right was a NaN
1993 */
1994I32
1995Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
1996{
1997 dVAR;
1b6737cc 1998
33efebe6
DM		 1999 PERL_ARGS_ASSERT_DO_NCMP;
2000#ifdef PERL_PRESERVE_IVUV
33efebe6 2001 /* Fortunately it seems NaN isn't IOK */
01f91bf2 2002 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
33efebe6
DM		 2003 if (!SvUOK(left)) {
2004 const IV leftiv = SvIVX(left);
2005 if (!SvUOK(right)) {
2006 /* ## IV <=> IV ## */
2007 const IV rightiv = SvIVX(right);
2008 return (leftiv > rightiv) - (leftiv < rightiv);
28e5dec8 2009 }
33efebe6
DM		 2010 /* ## IV <=> UV ## */
2011 if (leftiv < 0)
2012 /* As (b) is a UV, it's >=0, so it must be < */
2013 return -1;
2014 {
2015 const UV rightuv = SvUVX(right);
2016 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
28e5dec8 2017 }
28e5dec8 2018 }
79072805 2019
33efebe6
DM		 2020 if (SvUOK(right)) {
2021 /* ## UV <=> UV ## */
2022 const UV leftuv = SvUVX(left);
2023 const UV rightuv = SvUVX(right);
2024 return (leftuv > rightuv) - (leftuv < rightuv);
28e5dec8 2025 }
33efebe6
DM		 2026 /* ## UV <=> IV ## */
2027 {
2028 const IV rightiv = SvIVX(right);
2029 if (rightiv < 0)
2030 /* As (a) is a UV, it's >=0, so it cannot be < */
2031 return 1;
2032 {
2033 const UV leftuv = SvUVX(left);
2034 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
28e5dec8 2035 }
28e5dec8 2036 }
118e2215 2037 assert(0); /* NOTREACHED */
28e5dec8
JH		 2038 }
2039#endif
a0d0e21e 2040 {
33efebe6
DM		 2041 NV const rnv = SvNV_nomg(right);
2042 NV const lnv = SvNV_nomg(left);
2043
cab190d4 2044#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
33efebe6
DM		 2045 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2046 return 2;
2047 }
2048 return (lnv > rnv) - (lnv < rnv);
cab190d4 2049#else
33efebe6
DM		 2050 if (lnv < rnv)
2051 return -1;
2052 if (lnv > rnv)
2053 return 1;
2054 if (lnv == rnv)
2055 return 0;
2056 return 2;
cab190d4 2057#endif
a0d0e21e 2058 }
79072805
LW		 2059}
2060
33efebe6 2061
a0d0e21e 2062PP(pp_ncmp)
79072805 2063{
33efebe6
DM		 2064 dVAR; dSP;
2065 SV *left, *right;
2066 I32 value;
a42d0242 2067 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
33efebe6
DM		 2068 right = POPs;
2069 left = TOPs;
2070 value = do_ncmp(left, right);
2071 if (value == 2) {
3280af22 2072 SETs(&PL_sv_undef);
79072805 2073 }
33efebe6
DM		 2074 else {
2075 dTARGET;
2076 SETi(value);
2077 }
2078 RETURN;
a0d0e21e 2079}
79072805 2080
afd9910b 2081PP(pp_sle)
a0d0e21e 2082{
97aff369 2083 dVAR; dSP;
79072805 2084
afd9910b
NC		 2085 int amg_type = sle_amg;
2086 int multiplier = 1;
2087 int rhs = 1;
79072805 2088
afd9910b
NC		 2089 switch (PL_op->op_type) {
2090 case OP_SLT:
2091 amg_type = slt_amg;
2092 /* cmp < 0 */
2093 rhs = 0;
2094 break;
2095 case OP_SGT:
2096 amg_type = sgt_amg;
2097 /* cmp > 0 */
2098 multiplier = -1;
2099 rhs = 0;
2100 break;
2101 case OP_SGE:
2102 amg_type = sge_amg;
2103 /* cmp >= 0 */
2104 multiplier = -1;
2105 break;
79072805 2106 }
79072805 2107
6f1401dc 2108 tryAMAGICbin_MG(amg_type, AMGf_set);
a0d0e21e
LW		 2109 {
2110 dPOPTOPssrl;
1b6737cc 2111 const int cmp = (IN_LOCALE_RUNTIME
078504b2
FC		 2112 ? sv_cmp_locale_flags(left, right, 0)
2113 : sv_cmp_flags(left, right, 0));
afd9910b 2114 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW		 2115 RETURN;
2116 }
2117}
79072805 2118
36477c24 2119PP(pp_seq)
2120{
6f1401dc
DM		 2121 dVAR; dSP;
2122 tryAMAGICbin_MG(seq_amg, AMGf_set);
36477c24 2123 {
2124 dPOPTOPssrl;
078504b2 2125 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW		 2126 RETURN;
2127 }
2128}
79072805 2129
a0d0e21e 2130PP(pp_sne)
79072805 2131{
6f1401dc
DM		 2132 dVAR; dSP;
2133 tryAMAGICbin_MG(sne_amg, AMGf_set);
a0d0e21e
LW		 2134 {
2135 dPOPTOPssrl;
078504b2 2136 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2137 RETURN;
463ee0b2 2138 }
79072805
LW		 2139}
2140
a0d0e21e 2141PP(pp_scmp)
79072805 2142{
6f1401dc
DM		 2143 dVAR; dSP; dTARGET;
2144 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW		 2145 {
2146 dPOPTOPssrl;
1b6737cc 2147 const int cmp = (IN_LOCALE_RUNTIME
078504b2
FC		 2148 ? sv_cmp_locale_flags(left, right, 0)
2149 : sv_cmp_flags(left, right, 0));
bbce6d69 2150 SETi( cmp );
a0d0e21e
LW		 2151 RETURN;
2152 }
2153}
79072805 2154
55497cff 2155PP(pp_bit_and)
2156{
6f1401dc
DM		 2157 dVAR; dSP; dATARGET;
2158 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW		 2159 {
2160 dPOPTOPssrl;
4633a7c4 2161 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC		 2162 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2163 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2164 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2165 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2166 SETi(i);
d0ba1bd2
JH		 2167 }
2168 else {
1b6737cc 2169 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2170 SETu(u);
d0ba1bd2 2171 }
5ee80e13 2172 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2173 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW		 2174 }
2175 else {
533c011a 2176 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2177 SETTARG;
2178 }
2179 RETURN;
2180 }
2181}
79072805 2182
a0d0e21e
LW		 2183PP(pp_bit_or)
2184{
3658c1f1
NC		 2185 dVAR; dSP; dATARGET;
2186 const int op_type = PL_op->op_type;
2187
6f1401dc 2188 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW		 2189 {
2190 dPOPTOPssrl;
4633a7c4 2191 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC		 2192 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2193 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2194 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC		 2195 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2196 const IV r = SvIV_nomg(right);
2197 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2198 SETi(result);
d0ba1bd2
JH		 2199 }
2200 else {
3658c1f1
NC		 2201 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2202 const UV r = SvUV_nomg(right);
2203 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2204 SETu(result);
d0ba1bd2 2205 }
5ee80e13 2206 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2207 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW		 2208 }
2209 else {
3658c1f1 2210 do_vop(op_type, TARG, left, right);
a0d0e21e
LW		 2211 SETTARG;
2212 }
2213 RETURN;
79072805 2214 }
a0d0e21e 2215}
79072805 2216
1c2b3fd6
FC		 2217PERL_STATIC_INLINE bool
2218S_negate_string(pTHX)
2219{
2220 dTARGET; dSP;
2221 STRLEN len;
2222 const char *s;
2223 SV * const sv = TOPs;
2224 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2225 return FALSE;
2226 s = SvPV_nomg_const(sv, len);
2227 if (isIDFIRST(*s)) {
2228 sv_setpvs(TARG, "-");
2229 sv_catsv(TARG, sv);
2230 }
2231 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2232 sv_setsv_nomg(TARG, sv);
2233 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2234 }
2235 else return FALSE;
2236 SETTARG; PUTBACK;
2237 return TRUE;
2238}
2239
a0d0e21e
LW		 2240PP(pp_negate)
2241{
6f1401dc
DM		 2242 dVAR; dSP; dTARGET;
2243 tryAMAGICun_MG(neg_amg, AMGf_numeric);
1c2b3fd6 2244 if (S_negate_string(aTHX)) return NORMAL;
a0d0e21e 2245 {
6f1401dc 2246 SV * const sv = TOPs;
a5b92898 2247
d96ab1b5 2248 if (SvIOK(sv)) {
7dbe3150 2249 /* It's publicly an integer */
28e5dec8 2250 oops_its_an_int:
9b0e499b
GS		 2251 if (SvIsUV(sv)) {
2252 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2253 /* 2s complement assumption. */
d14578b8
KW		 2254 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2255 IV_MIN */
9b0e499b
GS		 2256 RETURN;
2257 }
2258 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2259 SETi(-SvIVX(sv));
9b0e499b
GS		 2260 RETURN;
2261 }
2262 }
2263 else if (SvIVX(sv) != IV_MIN) {
2264 SETi(-SvIVX(sv));
2265 RETURN;
2266 }
28e5dec8
JH		 2267#ifdef PERL_PRESERVE_IVUV
2268 else {
2269 SETu((UV)IV_MIN);
2270 RETURN;
2271 }
2272#endif
9b0e499b 2273 }
8a5decd8 2274 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
6f1401dc 2275 SETn(-SvNV_nomg(sv));
1c2b3fd6 2276 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
8eb28a70 2277 goto oops_its_an_int;
4633a7c4 2278 else
6f1401dc 2279 SETn(-SvNV_nomg(sv));
79072805 2280 }
a0d0e21e 2281 RETURN;
79072805
LW		 2282}
2283
a0d0e21e 2284PP(pp_not)
79072805 2285{
6f1401dc
DM		 2286 dVAR; dSP;
2287 tryAMAGICun_MG(not_amg, AMGf_set);
06c841cf 2288 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
a0d0e21e 2289 return NORMAL;
79072805
LW		 2290}
2291
a0d0e21e 2292PP(pp_complement)
79072805 2293{
6f1401dc 2294 dVAR; dSP; dTARGET;
a42d0242 2295 tryAMAGICun_MG(compl_amg, AMGf_numeric);
a0d0e21e
LW		 2296 {
2297 dTOPss;
4633a7c4 2298 if (SvNIOKp(sv)) {
d0ba1bd2 2299 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2300 const IV i = ~SvIV_nomg(sv);
972b05a9 2301 SETi(i);
d0ba1bd2
JH		 2302 }
2303 else {
1b6737cc 2304 const UV u = ~SvUV_nomg(sv);
972b05a9 2305 SETu(u);
d0ba1bd2 2306 }
a0d0e21e
LW		 2307 }
2308 else {
eb578fdb
KW		 2309 U8 *tmps;
2310 I32 anum;
a0d0e21e
LW		 2311 STRLEN len;
2312
10516c54 2313 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
891f9566 2314 sv_setsv_nomg(TARG, sv);
6f1401dc 2315 tmps = (U8*)SvPV_force_nomg(TARG, len);
a0d0e21e 2316 anum = len;
1d68d6cd 2317 if (SvUTF8(TARG)) {
a1ca4561 2318 /* Calculate exact length, let's not estimate. */
1d68d6cd 2319 STRLEN targlen = 0;
ba210ebe 2320 STRLEN l;
a1ca4561
YST		 2321 UV nchar = 0;
2322 UV nwide = 0;
01f6e806 2323 U8 * const send = tmps + len;
74d49cd0
TS		 2324 U8 * const origtmps = tmps;
2325 const UV utf8flags = UTF8_ALLOW_ANYUV;
1d68d6cd 2326
1d68d6cd 2327 while (tmps < send) {
74d49cd0
TS		 2328 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2329 tmps += l;
5bbb0b5a 2330 targlen += UNISKIP(~c);
a1ca4561
YST		 2331 nchar++;
2332 if (c > 0xff)
2333 nwide++;
1d68d6cd
SC		 2334 }
2335
2336 /* Now rewind strings and write them. */
74d49cd0 2337 tmps = origtmps;
a1ca4561
YST		 2338
2339 if (nwide) {
01f6e806
AL		 2340 U8 *result;
2341 U8 *p;
2342
74d49cd0 2343 Newx(result, targlen + 1, U8);
01f6e806 2344 p = result;
a1ca4561 2345 while (tmps < send) {
74d49cd0
TS		 2346 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2347 tmps += l;
01f6e806 2348 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
a1ca4561 2349 }
01f6e806 2350 *p = '\0';
c1c21316
NC		 2351 sv_usepvn_flags(TARG, (char*)result, targlen,
2352 SV_HAS_TRAILING_NUL);
a1ca4561
YST		 2353 SvUTF8_on(TARG);
2354 }
2355 else {
01f6e806
AL		 2356 U8 *result;
2357 U8 *p;
2358
74d49cd0 2359 Newx(result, nchar + 1, U8);
01f6e806 2360 p = result;
a1ca4561 2361 while (tmps < send) {
74d49cd0
TS		 2362 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2363 tmps += l;
01f6e806 2364 *p++ = ~c;
a1ca4561 2365 }
01f6e806 2366 *p = '\0';
c1c21316 2367 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
d0a21e00 2368 SvUTF8_off(TARG);
1d68d6cd 2369 }
ec93b65f 2370 SETTARG;
1d68d6cd
SC		 2371 RETURN;
2372 }
a0d0e21e 2373#ifdef LIBERAL
51723571 2374 {
eb578fdb 2375 long *tmpl;
51723571
JH		 2376 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2377 *tmps = ~*tmps;
2378 tmpl = (long*)tmps;
bb7a0f54 2379 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH		 2380 *tmpl = ~*tmpl;
2381 tmps = (U8*)tmpl;
2382 }
a0d0e21e
LW		 2383#endif
2384 for ( ; anum > 0; anum--, tmps++)
2385 *tmps = ~*tmps;
ec93b65f 2386 SETTARG;
a0d0e21e
LW		 2387 }
2388 RETURN;
2389 }
79072805
LW		 2390}
2391
a0d0e21e
LW		 2392/* integer versions of some of the above */
2393
a0d0e21e 2394PP(pp_i_multiply)
79072805 2395{
6f1401dc
DM		 2396 dVAR; dSP; dATARGET;
2397 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2398 {
6f1401dc 2399 dPOPTOPiirl_nomg;
a0d0e21e
LW		 2400 SETi( left * right );
2401 RETURN;
2402 }
79072805
LW		 2403}
2404
a0d0e21e 2405PP(pp_i_divide)
79072805 2406{
85935d8e 2407 IV num;
6f1401dc
DM		 2408 dVAR; dSP; dATARGET;
2409 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2410 {
6f1401dc 2411 dPOPTOPssrl;
85935d8e 2412 IV value = SvIV_nomg(right);
a0d0e21e 2413 if (value == 0)
ece1bcef 2414 DIE(aTHX_ "Illegal division by zero");
85935d8e 2415 num = SvIV_nomg(left);
a0cec769
YST		 2416
2417 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2418 if (value == -1)
2419 value = - num;
2420 else
2421 value = num / value;
6f1401dc 2422 SETi(value);
a0d0e21e
LW		 2423 RETURN;
2424 }
79072805
LW		 2425}
2426
a5bd31f4 2427#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
224ec323
JH		 2428STATIC
2429PP(pp_i_modulo_0)
befad5d1
NC		 2430#else
2431PP(pp_i_modulo)
2432#endif
224ec323
JH		 2433{
2434 /* This is the vanilla old i_modulo. */
6f1401dc
DM		 2435 dVAR; dSP; dATARGET;
2436 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2437 {
6f1401dc 2438 dPOPTOPiirl_nomg;
224ec323
JH		 2439 if (!right)
2440 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST		 2441 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2442 if (right == -1)
2443 SETi( 0 );
2444 else
2445 SETi( left % right );
224ec323
JH		 2446 RETURN;
2447 }
2448}
2449
a5bd31f4 2450#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
224ec323
JH		 2451STATIC
2452PP(pp_i_modulo_1)
befad5d1 2453
224ec323 2454{
224ec323 2455 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2456 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2457 * See below for pp_i_modulo. */
6f1401dc
DM		 2458 dVAR; dSP; dATARGET;
2459 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2460 {
6f1401dc 2461 dPOPTOPiirl_nomg;
224ec323
JH		 2462 if (!right)
2463 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST		 2464 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2465 if (right == -1)
2466 SETi( 0 );
2467 else
2468 SETi( left % PERL_ABS(right) );
224ec323
JH		 2469 RETURN;
2470 }
224ec323
JH		 2471}
2472
a0d0e21e 2473PP(pp_i_modulo)
79072805 2474{
6f1401dc
DM		 2475 dVAR; dSP; dATARGET;
2476 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2477 {
6f1401dc 2478 dPOPTOPiirl_nomg;
224ec323
JH		 2479 if (!right)
2480 DIE(aTHX_ "Illegal modulus zero");
2481 /* The assumption is to use hereafter the old vanilla version... */
2482 PL_op->op_ppaddr =
2483 PL_ppaddr[OP_I_MODULO] =
1c127fab 2484 Perl_pp_i_modulo_0;
224ec323
JH		 2485 /* .. but if we have glibc, we might have a buggy _moddi3
2486 * (at least glicb 2.2.5 is known to have this bug), in other
2487 * words our integer modulus with negative quad as the second
2488 * argument might be broken. Test for this and re-patch the
2489 * opcode dispatch table if that is the case, remembering to
2490 * also apply the workaround so that this first round works
2491 * right, too. See [perl #9402] for more information. */
224ec323
JH		 2492 {
2493 IV l = 3;
2494 IV r = -10;
2495 /* Cannot do this check with inlined IV constants since
2496 * that seems to work correctly even with the buggy glibc. */
2497 if (l % r == -3) {
2498 /* Yikes, we have the bug.
2499 * Patch in the workaround version. */
2500 PL_op->op_ppaddr =
2501 PL_ppaddr[OP_I_MODULO] =
2502 &Perl_pp_i_modulo_1;
2503 /* Make certain we work right this time, too. */
32fdb065 2504 right = PERL_ABS(right);
224ec323
JH		 2505 }
2506 }
a0cec769
YST		 2507 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2508 if (right == -1)
2509 SETi( 0 );
2510 else
2511 SETi( left % right );
224ec323
JH		 2512 RETURN;
2513 }
79072805 2514}
befad5d1 2515#endif
79072805 2516
a0d0e21e 2517PP(pp_i_add)
79072805 2518{
6f1401dc
DM		 2519 dVAR; dSP; dATARGET;
2520 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2521 {
6f1401dc 2522 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW		 2523 SETi( left + right );
2524 RETURN;
79072805 2525 }
79072805
LW		 2526}
2527
a0d0e21e 2528PP(pp_i_subtract)
79072805 2529{
6f1401dc
DM		 2530 dVAR; dSP; dATARGET;
2531 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2532 {
6f1401dc 2533 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW		 2534 SETi( left - right );
2535 RETURN;
79072805 2536 }
79072805
LW		 2537}
2538
a0d0e21e 2539PP(pp_i_lt)
79072805 2540{
6f1401dc
DM		 2541 dVAR; dSP;
2542 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2543 {
96b6b87f 2544 dPOPTOPiirl_nomg;
54310121 2545 SETs(boolSV(left < right));
a0d0e21e
LW		 2546 RETURN;
2547 }
79072805
LW		 2548}
2549
a0d0e21e 2550PP(pp_i_gt)
79072805 2551{
6f1401dc
DM		 2552 dVAR; dSP;
2553 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2554 {
96b6b87f 2555 dPOPTOPiirl_nomg;
54310121 2556 SETs(boolSV(left > right));
a0d0e21e
LW		 2557 RETURN;
2558 }
79072805
LW		 2559}
2560
a0d0e21e 2561PP(pp_i_le)
79072805 2562{
6f1401dc
DM		 2563 dVAR; dSP;
2564 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 2565 {
96b6b87f 2566 dPOPTOPiirl_nomg;
54310121 2567 SETs(boolSV(left <= right));
a0d0e21e 2568 RETURN;
85e6fe83 2569 }
79072805
LW		 2570}
2571
a0d0e21e 2572PP(pp_i_ge)
79072805 2573{
6f1401dc
DM		 2574 dVAR; dSP;
2575 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 2576 {
96b6b87f 2577 dPOPTOPiirl_nomg;
54310121 2578 SETs(boolSV(left >= right));
a0d0e21e
LW		 2579 RETURN;
2580 }
79072805
LW		 2581}
2582
a0d0e21e 2583PP(pp_i_eq)
79072805 2584{
6f1401dc
DM		 2585 dVAR; dSP;
2586 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 2587 {
96b6b87f 2588 dPOPTOPiirl_nomg;
54310121 2589 SETs(boolSV(left == right));
a0d0e21e
LW		 2590 RETURN;
2591 }
79072805
LW		 2592}
2593
a0d0e21e 2594PP(pp_i_ne)
79072805 2595{
6f1401dc
DM		 2596 dVAR; dSP;
2597 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 2598 {
96b6b87f 2599 dPOPTOPiirl_nomg;
54310121 2600 SETs(boolSV(left != right));
a0d0e21e
LW		 2601 RETURN;
2602 }
79072805
LW		 2603}
2604
a0d0e21e 2605PP(pp_i_ncmp)
79072805 2606{
6f1401dc
DM		 2607 dVAR; dSP; dTARGET;
2608 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2609 {
96b6b87f 2610 dPOPTOPiirl_nomg;
a0d0e21e 2611 I32 value;
79072805 2612
a0d0e21e 2613 if (left > right)
79072805 2614 value = 1;
a0d0e21e 2615 else if (left < right)
79072805 2616 value = -1;
a0d0e21e 2617 else
79072805 2618 value = 0;
a0d0e21e
LW		 2619 SETi(value);
2620 RETURN;
79072805 2621 }
85e6fe83
LW		 2622}
2623
2624PP(pp_i_negate)
2625{
6f1401dc
DM		 2626 dVAR; dSP; dTARGET;
2627 tryAMAGICun_MG(neg_amg, 0);
1c2b3fd6 2628 if (S_negate_string(aTHX)) return NORMAL;
6f1401dc
DM		 2629 {
2630 SV * const sv = TOPs;
2631 IV const i = SvIV_nomg(sv);
2632 SETi(-i);
2633 RETURN;
2634 }
85e6fe83
LW		 2635}
2636
79072805
LW		 2637/* High falutin' math. */
2638
2639PP(pp_atan2)
2640{
6f1401dc
DM		 2641 dVAR; dSP; dTARGET;
2642 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2643 {
096c060c 2644 dPOPTOPnnrl_nomg;
a1021d57 2645 SETn(Perl_atan2(left, right));
a0d0e21e
LW		 2646 RETURN;
2647 }
79072805
LW		 2648}
2649
2650PP(pp_sin)
2651{
71302fe3
NC		 2652 dVAR; dSP; dTARGET;
2653 int amg_type = sin_amg;
2654 const char *neg_report = NULL;
bc81784a 2655 NV (*func)(NV) = Perl_sin;
71302fe3
NC		 2656 const int op_type = PL_op->op_type;
2657
2658 switch (op_type) {
2659 case OP_COS:
2660 amg_type = cos_amg;
bc81784a 2661 func = Perl_cos;
71302fe3
NC		 2662 break;
2663 case OP_EXP:
2664 amg_type = exp_amg;
bc81784a 2665 func = Perl_exp;
71302fe3
NC		 2666 break;
2667 case OP_LOG:
2668 amg_type = log_amg;
bc81784a 2669 func = Perl_log;
71302fe3
NC		 2670 neg_report = "log";
2671 break;
2672 case OP_SQRT:
2673 amg_type = sqrt_amg;
bc81784a 2674 func = Perl_sqrt;
71302fe3
NC		 2675 neg_report = "sqrt";
2676 break;
a0d0e21e 2677 }
79072805 2678
6f1401dc
DM		 2679
2680 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 2681 {
6f1401dc
DM		 2682 SV * const arg = POPs;
2683 const NV value = SvNV_nomg(arg);
71302fe3
NC		 2684 if (neg_report) {
2685 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2686 SET_NUMERIC_STANDARD();
dcbac5bb 2687 /* diag_listed_as: Can't take log of %g */
71302fe3
NC		 2688 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2689 }
2690 }
2691 XPUSHn(func(value));
a0d0e21e
LW		 2692 RETURN;
2693 }
79072805
LW		 2694}
2695
56cb0a1c
AD		 2696/* Support Configure command-line overrides for rand() functions.
2697 After 5.005, perhaps we should replace this by Configure support
2698 for drand48(), random(), or rand(). For 5.005, though, maintain
2699 compatibility by calling rand() but allow the user to override it.
2700 See INSTALL for details. --Andy Dougherty 15 July 1998
2701*/
85ab1d1d
JH		 2702/* Now it's after 5.005, and Configure supports drand48() and random(),
2703 in addition to rand(). So the overrides should not be needed any more.
2704 --Jarkko Hietaniemi 27 September 1998
2705 */
2706
2707#ifndef HAS_DRAND48_PROTO
20ce7b12 2708extern double drand48 (void);
56cb0a1c
AD		 2709#endif
2710
79072805
LW		 2711PP(pp_rand)
2712{
fdf4dddd 2713 dVAR;
80252599 2714 if (!PL_srand_called) {
85ab1d1d 2715 (void)seedDrand01((Rand_seed_t)seed());
80252599 2716 PL_srand_called = TRUE;
93dc8474 2717 }
fdf4dddd
DD		 2718 {
2719 dSP;
2720 NV value;
2721 EXTEND(SP, 1);
2722
2723 if (MAXARG < 1)
2724 value = 1.0;
2725 else {
2726 SV * const sv = POPs;
2727 if(!sv)
2728 value = 1.0;
2729 else
2730 value = SvNV(sv);
2731 }
2732 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2733 if (value == 0.0)
2734 value = 1.0;
2735 {
2736 dTARGET;
2737 PUSHs(TARG);
2738 PUTBACK;
2739 value *= Drand01();
2740 sv_setnv_mg(TARG, value);
2741 }
2742 }
2743 return NORMAL;
79072805
LW		 2744}
2745
2746PP(pp_srand)
2747{
83832992 2748 dVAR; dSP; dTARGET;
f914a682
JL		 2749 UV anum;
2750
0a5f3363 2751 if (MAXARG >= 1 && (TOPs || POPs)) {
f914a682
JL		 2752 SV *top;
2753 char *pv;
2754 STRLEN len;
2755 int flags;
2756
2757 top = POPs;
2758 pv = SvPV(top, len);
2759 flags = grok_number(pv, len, &anum);
2760
2761 if (!(flags & IS_NUMBER_IN_UV)) {
2762 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2763 "Integer overflow in srand");
2764 anum = UV_MAX;
2765 }
2766 }
2767 else {
2768 anum = seed();
2769 }
2770
85ab1d1d 2771 (void)seedDrand01((Rand_seed_t)anum);
80252599 2772 PL_srand_called = TRUE;
da1010ec
NC		 2773 if (anum)
2774 XPUSHu(anum);
2775 else {
2776 /* Historically srand always returned true. We can avoid breaking
2777 that like this: */
2778 sv_setpvs(TARG, "0 but true");
2779 XPUSHTARG;
2780 }
83832992 2781 RETURN;
79072805
LW		 2782}
2783
79072805
LW		 2784PP(pp_int)
2785{
6f1401dc
DM		 2786 dVAR; dSP; dTARGET;
2787 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 2788 {
6f1401dc
DM		 2789 SV * const sv = TOPs;
2790 const IV iv = SvIV_nomg(sv);
28e5dec8
JH		 2791 /* XXX it's arguable that compiler casting to IV might be subtly
2792 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2793 else preferring IV has introduced a subtle behaviour change bug. OTOH
2794 relying on floating point to be accurate is a bug. */
2795
c781a409 2796 if (!SvOK(sv)) {
922c4365 2797 SETu(0);
c781a409
RD		 2798 }
2799 else if (SvIOK(sv)) {
2800 if (SvIsUV(sv))
6f1401dc 2801 SETu(SvUV_nomg(sv));
c781a409 2802 else
28e5dec8 2803 SETi(iv);
c781a409 2804 }
c781a409 2805 else {
6f1401dc 2806 const NV value = SvNV_nomg(sv);
1048ea30 2807 if (value >= 0.0) {
28e5dec8
JH		 2808 if (value < (NV)UV_MAX + 0.5) {
2809 SETu(U_V(value));
2810 } else {
059a1014 2811 SETn(Perl_floor(value));
28e5dec8 2812 }
1048ea30 2813 }
28e5dec8
JH		 2814 else {
2815 if (value > (NV)IV_MIN - 0.5) {
2816 SETi(I_V(value));
2817 } else {
1bbae031 2818 SETn(Perl_ceil(value));
28e5dec8
JH		 2819 }
2820 }
774d564b 2821 }
79072805 2822 }
79072805
LW		 2823 RETURN;
2824}
2825
463ee0b2
LW		 2826PP(pp_abs)
2827{
6f1401dc
DM		 2828 dVAR; dSP; dTARGET;
2829 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 2830 {
6f1401dc 2831 SV * const sv = TOPs;
28e5dec8 2832 /* This will cache the NV value if string isn't actually integer */
6f1401dc 2833 const IV iv = SvIV_nomg(sv);
a227d84d 2834
800401ee 2835 if (!SvOK(sv)) {
922c4365 2836 SETu(0);
800401ee
JH		 2837 }
2838 else if (SvIOK(sv)) {
28e5dec8 2839 /* IVX is precise */
800401ee 2840 if (SvIsUV(sv)) {
6f1401dc 2841 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH		 2842 } else {
2843 if (iv >= 0) {
2844 SETi(iv);
2845 } else {
2846 if (iv != IV_MIN) {
2847 SETi(-iv);
2848 } else {
2849 /* 2s complement assumption. Also, not really needed as
2850 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2851 SETu(IV_MIN);
2852 }
a227d84d 2853 }
28e5dec8
JH		 2854 }
2855 } else{
6f1401dc 2856 const NV value = SvNV_nomg(sv);
774d564b 2857 if (value < 0.0)
1b6737cc 2858 SETn(-value);
a4474c9e
DD		 2859 else
2860 SETn(value);
774d564b 2861 }
a0d0e21e 2862 }
774d564b 2863 RETURN;
463ee0b2
LW		 2864}
2865
79072805
LW		 2866PP(pp_oct)
2867{
97aff369 2868 dVAR; dSP; dTARGET;
5c144d81 2869 const char *tmps;
53305cf1 2870 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2871 STRLEN len;
53305cf1
NC		 2872 NV result_nv;
2873 UV result_uv;
1b6737cc 2874 SV* const sv = POPs;
79072805 2875
349d4f2f 2876 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS		 2877 if (DO_UTF8(sv)) {
2878 /* If Unicode, try to downgrade
2879 * If not possible, croak. */
1b6737cc 2880 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS		 2881
2882 SvUTF8_on(tsv);
2883 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2884 tmps = SvPV_const(tsv, len);
2bc69dc4 2885 }
daa2adfd
NC		 2886 if (PL_op->op_type == OP_HEX)
2887 goto hex;
2888
6f894ead 2889 while (*tmps && len && isSPACE(*tmps))
53305cf1 2890 tmps++, len--;
9e24b6e2 2891 if (*tmps == '0')
53305cf1 2892 tmps++, len--;
a674e8db 2893 if (*tmps == 'x' || *tmps == 'X') {
daa2adfd 2894 hex:
53305cf1 2895 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 2896 }
a674e8db 2897 else if (*tmps == 'b' || *tmps == 'B')
53305cf1 2898 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2899 else
53305cf1
NC		 2900 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2901
2902 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2903 XPUSHn(result_nv);
2904 }
2905 else {
2906 XPUSHu(result_uv);
2907 }
79072805
LW		 2908 RETURN;
2909}
2910
2911/* String stuff. */
2912
2913PP(pp_length)
2914{
97aff369 2915 dVAR; dSP; dTARGET;
0bd48802 2916 SV * const sv = TOPs;
a0ed51b3 2917
0f43fd57
FC		 2918 SvGETMAGIC(sv);
2919 if (SvOK(sv)) {
193059ca 2920 if (!IN_BYTES)
0f43fd57 2921 SETi(sv_len_utf8_nomg(sv));
9f621bb0 2922 else
0f43fd57
FC		 2923 {
2924 STRLEN len;
2925 (void)SvPV_nomg_const(sv,len);
2926 SETi(len);
2927 }
656266fc 2928 } else {
9407f9c1
DL		 2929 if (!SvPADTMP(TARG)) {
2930 sv_setsv_nomg(TARG, &PL_sv_undef);
2931 SETTARG;
2932 }
2933 SETs(&PL_sv_undef);
92331800 2934 }
79072805
LW		 2935 RETURN;
2936}
2937
83f78d1a
FC		 2938/* Returns false if substring is completely outside original string.
2939 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2940 always be true for an explicit 0.
2941*/
2942bool
2943Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2944 bool pos1_is_uv, IV len_iv,
2945 bool len_is_uv, STRLEN *posp,
2946 STRLEN *lenp)
2947{
2948 IV pos2_iv;
2949 int pos2_is_uv;
2950
2951 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2952
2953 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2954 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2955 pos1_iv += curlen;
2956 }
2957 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2958 return FALSE;
2959
2960 if (len_iv || len_is_uv) {
2961 if (!len_is_uv && len_iv < 0) {
2962 pos2_iv = curlen + len_iv;
2963 if (curlen)
2964 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2965 else
2966 pos2_is_uv = 0;
2967 } else { /* len_iv >= 0 */
2968 if (!pos1_is_uv && pos1_iv < 0) {
2969 pos2_iv = pos1_iv + len_iv;
2970 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
2971 } else {
2972 if ((UV)len_iv > curlen-(UV)pos1_iv)
2973 pos2_iv = curlen;
2974 else
2975 pos2_iv = pos1_iv+len_iv;
2976 pos2_is_uv = 1;
2977 }
2978 }
2979 }
2980 else {
2981 pos2_iv = curlen;
2982 pos2_is_uv = 1;
2983 }
2984
2985 if (!pos2_is_uv && pos2_iv < 0) {
2986 if (!pos1_is_uv && pos1_iv < 0)
2987 return FALSE;
2988 pos2_iv = 0;
2989 }
2990 else if (!pos1_is_uv && pos1_iv < 0)
2991 pos1_iv = 0;
2992
2993 if ((UV)pos2_iv < (UV)pos1_iv)
2994 pos2_iv = pos1_iv;
2995 if ((UV)pos2_iv > curlen)
2996 pos2_iv = curlen;
2997
2998 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
2999 *posp = (STRLEN)( (UV)pos1_iv );
3000 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3001
3002 return TRUE;
3003}
3004
79072805
LW		 3005PP(pp_substr)
3006{
97aff369 3007 dVAR; dSP; dTARGET;
79072805 3008 SV *sv;
463ee0b2 3009 STRLEN curlen;
9402d6ed 3010 STRLEN utf8_curlen;
777f7c56
EB		 3011 SV * pos_sv;
3012 IV pos1_iv;
3013 int pos1_is_uv;
777f7c56
EB		 3014 SV * len_sv;
3015 IV len_iv = 0;
83f78d1a 3016 int len_is_uv = 0;
24fcb59f 3017 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 3018 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 3019 const char *tmps;
9402d6ed 3020 SV *repl_sv = NULL;
cbbf8932 3021 const char *repl = NULL;
7b8d334a 3022 STRLEN repl_len;
7bc95ae1 3023 int num_args = PL_op->op_private & 7;
13e30c65 3024 bool repl_need_utf8_upgrade = FALSE;
79072805 3025
78f9721b
SM		 3026 if (num_args > 2) {
3027 if (num_args > 3) {
24fcb59f 3028 if(!(repl_sv = POPs)) num_args--;
7bc95ae1
FC		 3029 }
3030 if ((len_sv = POPs)) {
3031 len_iv = SvIV(len_sv);
83f78d1a 3032 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
7b8d334a 3033 }
7bc95ae1 3034 else num_args--;
5d82c453 3035 }
777f7c56
EB		 3036 pos_sv = POPs;
3037 pos1_iv = SvIV(pos_sv);
3038 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3039 sv = POPs;
24fcb59f
FC		 3040 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3041 assert(!repl_sv);
3042 repl_sv = POPs;
3043 }
849ca7ee 3044 PUTBACK;
6582db62 3045 if (lvalue && !repl_sv) {
83f78d1a
FC		 3046 SV * ret;
3047 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3048 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3049 LvTYPE(ret) = 'x';
3050 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3051 LvTARGOFF(ret) =
3052 pos1_is_uv || pos1_iv >= 0
3053 ? (STRLEN)(UV)pos1_iv
3054 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3055 LvTARGLEN(ret) =
3056 len_is_uv || len_iv > 0
3057 ? (STRLEN)(UV)len_iv
3058 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3059
3060 SPAGAIN;
3061 PUSHs(ret); /* avoid SvSETMAGIC here */
3062 RETURN;
a74fb2cd 3063 }
6582db62
FC		 3064 if (repl_sv) {
3065 repl = SvPV_const(repl_sv, repl_len);
3066 SvGETMAGIC(sv);
3067 if (SvROK(sv))
3068 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3069 "Attempt to use reference as lvalue in substr"
3070 );
3071 tmps = SvPV_force_nomg(sv, curlen);
3072 if (DO_UTF8(repl_sv) && repl_len) {
3073 if (!DO_UTF8(sv)) {
01680ee9 3074 sv_utf8_upgrade_nomg(sv);
6582db62
FC		 3075 curlen = SvCUR(sv);
3076 }
3077 }
3078 else if (DO_UTF8(sv))
3079 repl_need_utf8_upgrade = TRUE;
3080 }
3081 else tmps = SvPV_const(sv, curlen);
7e2040f0 3082 if (DO_UTF8(sv)) {
0d788f38 3083 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
9402d6ed
JH		 3084 if (utf8_curlen == curlen)
3085 utf8_curlen = 0;
a0ed51b3 3086 else
9402d6ed 3087 curlen = utf8_curlen;
a0ed51b3 3088 }
d1c2b58a 3089 else
9402d6ed 3090 utf8_curlen = 0;
a0ed51b3 3091
83f78d1a
FC		 3092 {
3093 STRLEN pos, len, byte_len, byte_pos;
777f7c56 3094
83f78d1a
FC		 3095 if (!translate_substr_offsets(
3096 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3097 )) goto bound_fail;
777f7c56 3098
83f78d1a
FC		 3099 byte_len = len;
3100 byte_pos = utf8_curlen
0d788f38 3101 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
d931b1be 3102
2154eca7 3103 tmps += byte_pos;
bbddc9e0
CS		 3104
3105 if (rvalue) {
3106 SvTAINTED_off(TARG); /* decontaminate */
3107 SvUTF8_off(TARG); /* decontaminate */
3108 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3109#ifdef USE_LOCALE_COLLATE
bbddc9e0 3110 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3111#endif
bbddc9e0
CS		 3112 if (utf8_curlen)
3113 SvUTF8_on(TARG);
3114 }
2154eca7 3115
f7928d6c 3116 if (repl) {
13e30c65
JH		 3117 SV* repl_sv_copy = NULL;
3118
3119 if (repl_need_utf8_upgrade) {
3120 repl_sv_copy = newSVsv(repl_sv);
3121 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3122 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65 3123 }
502d9230
VP		 3124 if (!SvOK(sv))
3125 sv_setpvs(sv, "");
777f7c56 3126 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
ef8d46e8 3127 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3128 }
79072805 3129 }
849ca7ee 3130 SPAGAIN;
bbddc9e0
CS		 3131 if (rvalue) {
3132 SvSETMAGIC(TARG);
3133 PUSHs(TARG);
3134 }
79072805 3135 RETURN;
777f7c56 3136
1c900557 3137bound_fail:
83f78d1a 3138 if (repl)
777f7c56
EB		 3139 Perl_croak(aTHX_ "substr outside of string");
3140 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3141 RETPUSHUNDEF;
79072805
LW		 3142}
3143
3144PP(pp_vec)
3145{
2154eca7 3146 dVAR; dSP;
eb578fdb
KW		 3147 const IV size = POPi;
3148 const IV offset = POPi;
3149 SV * const src = POPs;
1b6737cc 3150 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3151 SV * ret;
a0d0e21e 3152
81e118e0 3153 if (lvalue) { /* it's an lvalue! */
2154eca7
EB		 3154 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3155 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3156 LvTYPE(ret) = 'v';
3157 LvTARG(ret) = SvREFCNT_inc_simple(src);
3158 LvTARGOFF(ret) = offset;
3159 LvTARGLEN(ret) = size;
3160 }
3161 else {
3162 dTARGET;
3163 SvTAINTED_off(TARG); /* decontaminate */
3164 ret = TARG;
79072805
LW		 3165 }
3166
2154eca7
EB		 3167 sv_setuv(ret, do_vecget(src, offset, size));
3168 PUSHs(ret);
79072805
LW		 3169 RETURN;
3170}
3171
3172PP(pp_index)
3173{
97aff369 3174 dVAR; dSP; dTARGET;
79072805
LW		 3175 SV *big;
3176 SV *little;
c445ea15 3177 SV *temp = NULL;
ad66a58c 3178 STRLEN biglen;
2723d216 3179 STRLEN llen = 0;
79072805
LW		 3180 I32 offset;
3181 I32 retval;
73ee8be2
NC		 3182 const char *big_p;
3183 const char *little_p;
2f040f7f
NC		 3184 bool big_utf8;
3185 bool little_utf8;
2723d216 3186 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3187 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3188
e1dccc0d
Z		 3189 if (threeargs)
3190 offset = POPi;
79072805
LW		 3191 little = POPs;
3192 big = POPs;
73ee8be2
NC		 3193 big_p = SvPV_const(big, biglen);
3194 little_p = SvPV_const(little, llen);
3195
e609e586
NC		 3196 big_utf8 = DO_UTF8(big);
3197 little_utf8 = DO_UTF8(little);
3198 if (big_utf8 ^ little_utf8) {
3199 /* One needs to be upgraded. */
2f040f7f
NC		 3200 if (little_utf8 && !PL_encoding) {
3201 /* Well, maybe instead we might be able to downgrade the small
3202 string? */
1eced8f8 3203 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC		 3204 &little_utf8);
3205 if (little_utf8) {
3206 /* If the large string is ISO-8859-1, and it's not possible to
3207 convert the small string to ISO-8859-1, then there is no
3208 way that it could be found anywhere by index. */
3209 retval = -1;
3210 goto fail;
3211 }
e609e586 3212
2f040f7f
NC		 3213 /* At this point, pv is a malloc()ed string. So donate it to temp
3214 to ensure it will get free()d */
3215 little = temp = newSV(0);
73ee8be2
NC		 3216 sv_usepvn(temp, pv, llen);
3217 little_p = SvPVX(little);
e609e586 3218 } else {
73ee8be2
NC		 3219 temp = little_utf8
3220 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f
NC		 3221
3222 if (PL_encoding) {
3223 sv_recode_to_utf8(temp, PL_encoding);
3224 } else {
3225 sv_utf8_upgrade(temp);
3226 }
3227 if (little_utf8) {
3228 big = temp;
3229 big_utf8 = TRUE;
73ee8be2 3230 big_p = SvPV_const(big, biglen);
2f040f7f
NC		 3231 } else {
3232 little = temp;
73ee8be2 3233 little_p = SvPV_const(little, llen);
2f040f7f 3234 }
e609e586
NC		 3235 }
3236 }
73ee8be2
NC		 3237 if (SvGAMAGIC(big)) {
3238 /* Life just becomes a lot easier if I use a temporary here.
3239 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3240 will trigger magic and overloading again, as will fbm_instr()
3241 */
59cd0e26
NC		 3242 big = newSVpvn_flags(big_p, biglen,
3243 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC		 3244 big_p = SvPVX(big);
3245 }
e4e44778 3246 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC		 3247 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3248 warn on undef, and we've already triggered a warning with the
3249 SvPV_const some lines above. We can't remove that, as we need to
3250 call some SvPV to trigger overloading early and find out if the
3251 string is UTF-8.
3252 This is all getting to messy. The API isn't quite clean enough,
3253 because data access has side effects.
3254 */
59cd0e26
NC		 3255 little = newSVpvn_flags(little_p, llen,
3256 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC		 3257 little_p = SvPVX(little);
3258 }
e609e586 3259
d3e26383 3260 if (!threeargs)
2723d216 3261 offset = is_index ? 0 : biglen;
a0ed51b3 3262 else {
ad66a58c 3263 if (big_utf8 && offset > 0)
a0ed51b3 3264 sv_pos_u2b(big, &offset, 0);
73ee8be2
NC		 3265 if (!is_index)
3266 offset += llen;
a0ed51b3 3267 }
79072805
LW		 3268 if (offset < 0)
3269 offset = 0;
ad66a58c
NC		 3270 else if (offset > (I32)biglen)
3271 offset = biglen;
73ee8be2
NC		 3272 if (!(little_p = is_index
3273 ? fbm_instr((unsigned char*)big_p + offset,
3274 (unsigned char*)big_p + biglen, little, 0)
3275 : rninstr(big_p, big_p + offset,
3276 little_p, little_p + llen)))
a0ed51b3 3277 retval = -1;
ad66a58c 3278 else {
73ee8be2 3279 retval = little_p - big_p;
ad66a58c
NC		 3280 if (retval > 0 && big_utf8)
3281 sv_pos_b2u(big, &retval);
3282 }
ef8d46e8 3283 SvREFCNT_dec(temp);
2723d216 3284 fail:
e1dccc0d 3285 PUSHi(retval);
79072805
LW		 3286 RETURN;
3287}
3288
3289PP(pp_sprintf)
3290{
97aff369 3291 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3292 SvTAINTED_off(TARG);
79072805 3293 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3294 TAINT_IF(SvTAINTED(TARG));
79072805
LW		 3295 SP = ORIGMARK;
3296 PUSHTARG;
3297 RETURN;
3298}
3299
79072805
LW		 3300PP(pp_ord)
3301{
97aff369 3302 dVAR; dSP; dTARGET;
1eced8f8 3303
7df053ec 3304 SV *argsv = POPs;
ba210ebe 3305 STRLEN len;
349d4f2f 3306 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3307
799ef3cb 3308 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3309 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3310 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
121910a4
JH		 3311 argsv = tmpsv;
3312 }
79072805 3313
872c91ae 3314 XPUSHu(DO_UTF8(argsv) ?
89ebb4a3 3315 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
5fc32dea 3316 (UV)(*s & 0xff));
68795e93 3317
79072805
LW		 3318 RETURN;
3319}
3320
463ee0b2
LW		 3321PP(pp_chr)
3322{
97aff369 3323 dVAR; dSP; dTARGET;
463ee0b2 3324 char *tmps;
8a064bd6 3325 UV value;
71739502 3326 SV *top = POPs;
8a064bd6 3327
71739502
FC		 3328 SvGETMAGIC(top);
3329 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3330 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
8a064bd6 3331 ||
71739502
FC		 3332 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3333 && SvNV_nomg(top) < 0.0))) {
b3fe8680
FC		 3334 if (ckWARN(WARN_UTF8)) {
3335 if (SvGMAGICAL(top)) {
3336 SV *top2 = sv_newmortal();
3337 sv_setsv_nomg(top2, top);
3338 top = top2;
3339 }
3340 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3341 "Invalid negative number (%"SVf") in chr", top);
3342 }
8a064bd6 3343 value = UNICODE_REPLACEMENT;
8a064bd6 3344 } else {
71739502 3345 value = SvUV_nomg(top);
8a064bd6 3346 }
463ee0b2 3347
862a34c6 3348 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3349
0064a8a9 3350 if (value > 255 && !IN_BYTES) {
eb160463 3351 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3352 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3353 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW		 3354 *tmps = '\0';
3355 (void)SvPOK_only(TARG);
aa6ffa16 3356 SvUTF8_on(TARG);
a0ed51b3
LW		 3357 XPUSHs(TARG);
3358 RETURN;
3359 }
3360
748a9306 3361 SvGROW(TARG,2);
463ee0b2
LW		 3362 SvCUR_set(TARG, 1);
3363 tmps = SvPVX(TARG);
eb160463 3364 *tmps++ = (char)value;
748a9306 3365 *tmps = '\0';
a0d0e21e 3366 (void)SvPOK_only(TARG);
4c5ed6e2 3367
88632417 3368 if (PL_encoding && !IN_BYTES) {
799ef3cb 3369 sv_recode_to_utf8(TARG, PL_encoding);
88632417 3370 tmps = SvPVX(TARG);
28936164
KW		 3371 if (SvCUR(TARG) == 0
3372 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3373 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3374 {
4c5ed6e2 3375 SvGROW(TARG, 2);
d5a15ac2 3376 tmps = SvPVX(TARG);
4c5ed6e2
TS		 3377 SvCUR_set(TARG, 1);
3378 *tmps++ = (char)value;
88632417 3379 *tmps = '\0';
4c5ed6e2 3380 SvUTF8_off(TARG);
88632417
JH		 3381 }
3382 }
4c5ed6e2 3383
463ee0b2
LW		 3384 XPUSHs(TARG);
3385 RETURN;
3386}
3387
79072805
LW		 3388PP(pp_crypt)
3389{
79072805 3390#ifdef HAS_CRYPT
97aff369 3391 dVAR; dSP; dTARGET;
5f74f29c 3392 dPOPTOPssrl;
85c16d83 3393 STRLEN len;
10516c54 3394 const char *tmps = SvPV_const(left, len);
2bc69dc4 3395
85c16d83 3396 if (DO_UTF8(left)) {
2bc69dc4 3397 /* If Unicode, try to downgrade.
f2791508
JH		 3398 * If not possible, croak.
3399 * Yes, we made this up. */
1b6737cc 3400 SV* const tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3401
f2791508 3402 SvUTF8_on(tsv);
2bc69dc4 3403 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3404 tmps = SvPV_const(tsv, len);
85c16d83 3405 }
05404ffe
JH		 3406# ifdef USE_ITHREADS
3407# ifdef HAS_CRYPT_R
3408 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3409 /* This should be threadsafe because in ithreads there is only
3410 * one thread per interpreter. If this would not be true,
3411 * we would need a mutex to protect this malloc. */
3412 PL_reentrant_buffer->_crypt_struct_buffer =
3413 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3414#if defined(__GLIBC__) || defined(__EMX__)
3415 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3416 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3417 /* work around glibc-2.2.5 bug */
3418 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3419 }
05404ffe 3420#endif
6ab58e4d 3421 }
05404ffe
JH		 3422# endif /* HAS_CRYPT_R */
3423# endif /* USE_ITHREADS */
5f74f29c 3424# ifdef FCRYPT
83003860 3425 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3426# else
83003860 3427 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3428# endif
ec93b65f 3429 SETTARG;
4808266b 3430 RETURN;
79072805 3431#else
b13b2135 3432 DIE(aTHX_
79072805
LW		 3433 "The crypt() function is unimplemented due to excessive paranoia.");
3434#endif
79072805
LW		 3435}
3436
00f254e2
KW		 3437/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3438 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3439
79072805
LW		 3440PP(pp_ucfirst)
3441{
00f254e2
KW		 3442 /* Actually is both lcfirst() and ucfirst(). Only the first character
3443 * changes. This means that possibly we can change in-place, ie., just
3444 * take the source and change that one character and store it back, but not
3445 * if read-only etc, or if the length changes */
3446
97aff369 3447 dVAR;
39644a26 3448 dSP;
d54190f6 3449 SV *source = TOPs;
00f254e2 3450 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC		 3451 STRLEN need;
3452 SV *dest;
00f254e2
KW		 3453 bool inplace; /* ? Convert first char only, in-place */
3454 bool doing_utf8 = FALSE; /* ? using utf8 */
3455 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3456 const int op_type = PL_op->op_type;
d54190f6
NC		 3457 const U8 *s;
3458 U8 *d;
3459 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW		 3460 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3461 * stored as UTF-8 at s. */
3462 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3463 * lowercased) character stored in tmpbuf. May be either
3464 * UTF-8 or not, but in either case is the number of bytes */
094a2f8c 3465 bool tainted = FALSE;
d54190f6
NC		 3466
3467 SvGETMAGIC(source);
3468 if (SvOK(source)) {
3469 s = (const U8*)SvPV_nomg_const(source, slen);
3470 } else {
0a0ffbce
RGS		 3471 if (ckWARN(WARN_UNINITIALIZED))
3472 report_uninit(source);
1eced8f8 3473 s = (const U8*)"";
d54190f6
NC		 3474 slen = 0;
3475 }
a0ed51b3 3476
00f254e2
KW		 3477 /* We may be able to get away with changing only the first character, in
3478 * place, but not if read-only, etc. Later we may discover more reasons to
3479 * not convert in-place. */
3480 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3481
3482 /* First calculate what the changed first character should be. This affects
3483 * whether we can just swap it out, leaving the rest of the string unchanged,
3484 * or even if have to convert the dest to UTF-8 when the source isn't */
3485
3486 if (! slen) { /* If empty */
3487 need = 1; /* still need a trailing NUL */
b7576bcb 3488 ulen = 0;
00f254e2
KW		 3489 }
3490 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3491 doing_utf8 = TRUE;
17e95c9d 3492 ulen = UTF8SKIP(s);
094a2f8c
KW		 3493 if (op_type == OP_UCFIRST) {
3494 _to_utf8_title_flags(s, tmpbuf, &tculen,
3495 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3496 }
3497 else {
3498 _to_utf8_lower_flags(s, tmpbuf, &tculen,
3499 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3500 }
00f254e2 3501
17e95c9d
KW		 3502 /* we can't do in-place if the length changes. */
3503 if (ulen != tculen) inplace = FALSE;
3504 need = slen + 1 - ulen + tculen;
d54190f6 3505 }
00f254e2
KW		 3506 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3507 * latin1 is treated as caseless. Note that a locale takes
3508 * precedence */
167d19f2 3509 ulen = 1; /* Original character is 1 byte */
00f254e2
KW		 3510 tculen = 1; /* Most characters will require one byte, but this will
3511 * need to be overridden for the tricky ones */
3512 need = slen + 1;
3513
3514 if (op_type == OP_LCFIRST) {
d54190f6 3515
00f254e2
KW		 3516 /* lower case the first letter: no trickiness for any character */
3517 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3518 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3519 }
3520 /* is ucfirst() */
3521 else if (IN_LOCALE_RUNTIME) {
3522 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3523 * have upper and title case different
3524 */
3525 }
3526 else if (! IN_UNI_8_BIT) {
3527 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3528 * on EBCDIC machines whatever the
3529 * native function does */
3530 }
3531 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
167d19f2
KW		 3532 UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3533 if (tculen > 1) {
3534 assert(tculen == 2);
3535
3536 /* If the result is an upper Latin1-range character, it can
3537 * still be represented in one byte, which is its ordinal */
3538 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3539 *tmpbuf = (U8) title_ord;
3540 tculen = 1;
00f254e2
KW		 3541 }
3542 else {
167d19f2
KW		 3543 /* Otherwise it became more than one ASCII character (in
3544 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3545 * beyond Latin1, so the number of bytes changed, so can't
3546 * replace just the first character in place. */
3547 inplace = FALSE;
3548
d14578b8
KW		 3549 /* If the result won't fit in a byte, the entire result
3550 * will have to be in UTF-8. Assume worst case sizing in
3551 * conversion. (all latin1 characters occupy at most two
3552 * bytes in utf8) */
167d19f2
KW		 3553 if (title_ord > 255) {
3554 doing_utf8 = TRUE;
3555 convert_source_to_utf8 = TRUE;
3556 need = slen * 2 + 1;
3557
3558 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3559 * (both) characters whose title case is above 255 is
3560 * 2. */
3561 ulen = 2;
3562 }
3563 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3564 need = slen + 1 + 1;
3565 }
00f254e2 3566 }
167d19f2 3567 }
00f254e2
KW		 3568 } /* End of use Unicode (Latin1) semantics */
3569 } /* End of changing the case of the first character */
3570
3571 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3572 * generate the result */
3573 if (inplace) {
3574
3575 /* We can convert in place. This means we change just the first
3576 * character without disturbing the rest; no need to grow */
d54190f6
NC		 3577 dest = source;
3578 s = d = (U8*)SvPV_force_nomg(source, slen);
3579 } else {
3580 dTARGET;
3581
3582 dest = TARG;
3583
00f254e2
KW		 3584 /* Here, we can't convert in place; we earlier calculated how much
3585 * space we will need, so grow to accommodate that */
d54190f6 3586 SvUPGRADE(dest, SVt_PV);
3b416f41 3587 d = (U8*)SvGROW(dest, need);
d54190f6
NC		 3588 (void)SvPOK_only(dest);
3589
3590 SETs(dest);
d54190f6 3591 }
44bc797b 3592
d54190f6 3593 if (doing_utf8) {
00f254e2
KW		 3594 if (! inplace) {
3595 if (! convert_source_to_utf8) {
3596
3597 /* Here both source and dest are in UTF-8, but have to create
3598 * the entire output. We initialize the result to be the
3599 * title/lower cased first character, and then append the rest
3600 * of the string. */
3601 sv_setpvn(dest, (char*)tmpbuf, tculen);
3602 if (slen > ulen) {
3603 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3604 }
3605 }
3606 else {
3607 const U8 *const send = s + slen;
3608
3609 /* Here the dest needs to be in UTF-8, but the source isn't,
3610 * except we earlier UTF-8'd the first character of the source
3611 * into tmpbuf. First put that into dest, and then append the
3612 * rest of the source, converting it to UTF-8 as we go. */
3613
3614 /* Assert tculen is 2 here because the only two characters that
3615 * get to this part of the code have 2-byte UTF-8 equivalents */
3616 *d++ = *tmpbuf;
3617 *d++ = *(tmpbuf + 1);
3618 s++; /* We have just processed the 1st char */
3619
3620 for (; s < send; s++) {
3621 d = uvchr_to_utf8(d, *s);
3622 }
3623 *d = '\0';
3624 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3625 }
d54190f6 3626 SvUTF8_on(dest);
a0ed51b3 3627 }
00f254e2 3628 else { /* in-place UTF-8. Just overwrite the first character */
d54190f6
NC		 3629 Copy(tmpbuf, d, tculen, U8);
3630 SvCUR_set(dest, need - 1);
a0ed51b3 3631 }
094a2f8c
KW		 3632
3633 if (tainted) {
3634 TAINT;
3635 SvTAINTED_on(dest);
3636 }
a0ed51b3 3637 }
00f254e2
KW		 3638 else { /* Neither source nor dest are in or need to be UTF-8 */
3639 if (slen) {
2de3dbcc 3640 if (IN_LOCALE_RUNTIME) {
31351b04 3641 TAINT;
d54190f6 3642 SvTAINTED_on(dest);
31351b04 3643 }
00f254e2
KW		 3644 if (inplace) { /* in-place, only need to change the 1st char */
3645 *d = *tmpbuf;
3646 }
3647 else { /* Not in-place */
3648
3649 /* Copy the case-changed character(s) from tmpbuf */
3650 Copy(tmpbuf, d, tculen, U8);
3651 d += tculen - 1; /* Code below expects d to point to final
3652 * character stored */
3653 }
3654 }
3655 else { /* empty source */
3656 /* See bug #39028: Don't taint if empty */
d54190f6
NC		 3657 *d = *s;
3658 }
3659
00f254e2
KW		 3660 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3661 * the destination to retain that flag */
d54190f6
NC		 3662 if (SvUTF8(source))
3663 SvUTF8_on(dest);
3664
00f254e2 3665 if (!inplace) { /* Finish the rest of the string, unchanged */
d54190f6
NC		 3666 /* This will copy the trailing NUL */
3667 Copy(s + 1, d + 1, slen, U8);
3668 SvCUR_set(dest, need - 1);
bbce6d69 3669 }
bbce6d69 3670 }
539689e7
FC		 3671 if (dest != source && SvTAINTED(source))
3672 SvTAINT(dest);
d54190f6 3673 SvSETMAGIC(dest);
79072805
LW		 3674 RETURN;
3675}
3676
67306194
NC		 3677/* There's so much setup/teardown code common between uc and lc, I wonder if
3678 it would be worth merging the two, and just having a switch outside each
00f254e2 3679 of the three tight loops. There is less and less commonality though */
79072805
LW		 3680PP(pp_uc)
3681{
97aff369 3682 dVAR;
39644a26 3683 dSP;
67306194 3684 SV *source = TOPs;
463ee0b2 3685 STRLEN len;
67306194
NC		 3686 STRLEN min;
3687 SV *dest;
3688 const U8 *s;
3689 U8 *d;
79072805 3690
67306194
NC		 3691 SvGETMAGIC(source);
3692
3693 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
00f254e2
KW		 3694 && SvTEMP(source) && !DO_UTF8(source)
3695 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3696
3697 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3698 * make the loop tight, so we overwrite the source with the dest before
3699 * looking at it, and we need to look at the original source
3700 * afterwards. There would also need to be code added to handle
3701 * switching to not in-place in midstream if we run into characters
3702 * that change the length.
3703 */
67306194
NC		 3704 dest = source;
3705 s = d = (U8*)SvPV_force_nomg(source, len);
3706 min = len + 1;
3707 } else {
a0ed51b3 3708 dTARGET;
a0ed51b3 3709
67306194 3710 dest = TARG;
128c9517 3711
67306194
NC		 3712 /* The old implementation would copy source into TARG at this point.
3713 This had the side effect that if source was undef, TARG was now
3714 an undefined SV with PADTMP set, and they don't warn inside
3715 sv_2pv_flags(). However, we're now getting the PV direct from
3716 source, which doesn't have PADTMP set, so it would warn. Hence the
3717 little games. */
3718
3719 if (SvOK(source)) {
3720 s = (const U8*)SvPV_nomg_const(source, len);
3721 } else {
0a0ffbce
RGS		 3722 if (ckWARN(WARN_UNINITIALIZED))
3723 report_uninit(source);
1eced8f8 3724 s = (const U8*)"";
67306194 3725 len = 0;
a0ed51b3 3726 }
67306194
NC		 3727 min = len + 1;
3728
3729 SvUPGRADE(dest, SVt_PV);
3b416f41 3730 d = (U8*)SvGROW(dest, min);
67306194
NC		 3731 (void)SvPOK_only(dest);
3732
3733 SETs(dest);
a0ed51b3 3734 }
31351b04 3735
67306194
NC		 3736 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3737 to check DO_UTF8 again here. */
3738
3739 if (DO_UTF8(source)) {
3740 const U8 *const send = s + len;
bfac13d4 3741 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
094a2f8c 3742 bool tainted = FALSE;
67306194 3743
4c8a458a
KW		 3744 /* All occurrences of these are to be moved to follow any other marks.
3745 * This is context-dependent. We may not be passed enough context to
3746 * move the iota subscript beyond all of them, but we do the best we can
3747 * with what we're given. The result is always better than if we
3748 * hadn't done this. And, the problem would only arise if we are
3749 * passed a character without all its combining marks, which would be
3750 * the caller's mistake. The information this is based on comes from a
3751 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3752 * itself) and so can't be checked properly to see if it ever gets
3753 * revised. But the likelihood of it changing is remote */
00f254e2 3754 bool in_iota_subscript = FALSE;
00f254e2 3755
67306194 3756 while (s < send) {
3e16b0e6
KW		 3757 STRLEN u;
3758 STRLEN ulen;
3759 UV uv;
7dbf68d2 3760 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3e16b0e6 3761
00f254e2 3762 /* A non-mark. Time to output the iota subscript */
a78bc3c6
KW		 3763 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3764 d += capital_iota_len;
00f254e2 3765 in_iota_subscript = FALSE;
8e058693 3766 }
00f254e2 3767
8e058693
KW		 3768 /* Then handle the current character. Get the changed case value
3769 * and copy it to the output buffer */
00f254e2 3770
8e058693 3771 u = UTF8SKIP(s);
094a2f8c
KW		 3772 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
3773 cBOOL(IN_LOCALE_RUNTIME), &tainted);
a78bc3c6
KW		 3774#define GREEK_CAPITAL_LETTER_IOTA 0x0399
3775#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
8e058693 3776 if (uv == GREEK_CAPITAL_LETTER_IOTA
4b88fb76 3777 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
8e058693
KW		 3778 {
3779 in_iota_subscript = TRUE;
3780 }
3781 else {
3782 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3783 /* If the eventually required minimum size outgrows the
3784 * available space, we need to grow. */
3785 const UV o = d - (U8*)SvPVX_const(dest);
3786
3787 /* If someone uppercases one million U+03B0s we SvGROW()
3788 * one million times. Or we could try guessing how much to
3789 * allocate without allocating too much. Such is life.
3790 * See corresponding comment in lc code for another option
3791 * */
3792 SvGROW(dest, min);
3793 d = (U8*)SvPVX(dest) + o;
3794 }
3795 Copy(tmpbuf, d, ulen, U8);
3796 d += ulen;
3797 }
3798 s += u;
67306194 3799 }
4c8a458a 3800 if (in_iota_subscript) {
a78bc3c6
KW		 3801 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3802 d += capital_iota_len;
4c8a458a 3803 }
67306194
NC		 3804 SvUTF8_on(dest);
3805 *d = '\0';
094a2f8c 3806
67306194 3807 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
094a2f8c
KW		 3808 if (tainted) {
3809 TAINT;
3810 SvTAINTED_on(dest);
3811 }
4c8a458a
KW		 3812 }
3813 else { /* Not UTF-8 */
67306194
NC		 3814 if (len) {
3815 const U8 *const send = s + len;
00f254e2
KW		 3816
3817 /* Use locale casing if in locale; regular style if not treating
3818 * latin1 as having case; otherwise the latin1 casing. Do the
3819 * whole thing in a tight loop, for speed, */
2de3dbcc 3820 if (IN_LOCALE_RUNTIME) {
31351b04 3821 TAINT;
67306194
NC		 3822 SvTAINTED_on(dest);
3823 for (; s < send; d++, s++)
3824 *d = toUPPER_LC(*s);
31351b04 3825 }
00f254e2
KW		 3826 else if (! IN_UNI_8_BIT) {
3827 for (; s < send; d++, s++) {
67306194 3828 *d = toUPPER(*s);
00f254e2 3829 }
31351b04 3830 }
00f254e2
KW		 3831 else {
3832 for (; s < send; d++, s++) {
3833 *d = toUPPER_LATIN1_MOD(*s);
d14578b8
KW		 3834 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3835 continue;
3836 }
00f254e2
KW		 3837
3838 /* The mainstream case is the tight loop above. To avoid
3839 * extra tests in that, all three characters that require
3840 * special handling are mapped by the MOD to the one tested
3841 * just above.
3842 * Use the source to distinguish between the three cases */
3843
3844 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3845
3846 /* uc() of this requires 2 characters, but they are
3847 * ASCII. If not enough room, grow the string */
3848 if (SvLEN(dest) < ++min) {
3849 const UV o = d - (U8*)SvPVX_const(dest);
3850 SvGROW(dest, min);
3851 d = (U8*)SvPVX(dest) + o;
3852 }
3853 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3854 continue; /* Back to the tight loop; still in ASCII */
3855 }
3856
3857 /* The other two special handling characters have their
3858 * upper cases outside the latin1 range, hence need to be
3859 * in UTF-8, so the whole result needs to be in UTF-8. So,
3860 * here we are somewhere in the middle of processing a
3861 * non-UTF-8 string, and realize that we will have to convert
3862 * the whole thing to UTF-8. What to do? There are
3863 * several possibilities. The simplest to code is to
3864 * convert what we have so far, set a flag, and continue on
3865 * in the loop. The flag would be tested each time through
3866 * the loop, and if set, the next character would be
3867 * converted to UTF-8 and stored. But, I (khw) didn't want
3868 * to slow down the mainstream case at all for this fairly
3869 * rare case, so I didn't want to add a test that didn't
3870 * absolutely have to be there in the loop, besides the
3871 * possibility that it would get too complicated for
3872 * optimizers to deal with. Another possibility is to just
3873 * give up, convert the source to UTF-8, and restart the
3874 * function that way. Another possibility is to convert
3875 * both what has already been processed and what is yet to
3876 * come separately to UTF-8, then jump into the loop that
3877 * handles UTF-8. But the most efficient time-wise of the
3878 * ones I could think of is what follows, and turned out to
3879 * not require much extra code. */
3880
3881 /* Convert what we have so far into UTF-8, telling the
3882 * function that we know it should be converted, and to
3883 * allow extra space for what we haven't processed yet.
3884 * Assume the worst case space requirements for converting
3885 * what we haven't processed so far: that it will require
3886 * two bytes for each remaining source character, plus the
3887 * NUL at the end. This may cause the string pointer to
3888 * move, so re-find it. */
3889
3890 len = d - (U8*)SvPVX_const(dest);
3891 SvCUR_set(dest, len);
3892 len = sv_utf8_upgrade_flags_grow(dest,
3893 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3894 (send -s) * 2 + 1);
3895 d = (U8*)SvPVX(dest) + len;
3896
00f254e2
KW		 3897 /* Now process the remainder of the source, converting to
3898 * upper and UTF-8. If a resulting byte is invariant in
3899 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3900 * append it to the output. */
00f254e2 3901 for (; s < send; s++) {
0ecfbd28
KW		 3902 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3903 d += len;
00f254e2
KW		 3904 }
3905
3906 /* Here have processed the whole source; no need to continue
3907 * with the outer loop. Each character has been converted
3908 * to upper case and converted to UTF-8 */
3909
3910 break;
3911 } /* End of processing all latin1-style chars */
3912 } /* End of processing all chars */
3913 } /* End of source is not empty */
3914
67306194 3915 if (source != dest) {
00f254e2 3916 *d = '\0'; /* Here d points to 1 after last char, add NUL */
67306194
NC		 3917 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3918 }
00f254e2 3919 } /* End of isn't utf8 */
539689e7
FC		 3920 if (dest != source && SvTAINTED(source))
3921 SvTAINT(dest);
67306194 3922 SvSETMAGIC(dest);
79072805
LW		 3923 RETURN;
3924}
3925
3926PP(pp_lc)
3927{
97aff369 3928 dVAR;
39644a26 3929 dSP;
ec9af7d4 3930 SV *source = TOPs;
463ee0b2 3931 STRLEN len;
ec9af7d4
NC		 3932 STRLEN min;
3933 SV *dest;
3934 const U8 *s;
3935 U8 *d;
79072805 3936
ec9af7d4
NC		 3937 SvGETMAGIC(source);
3938
3939 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
17fa0776 3940 && SvTEMP(source) && !DO_UTF8(source)) {
ec9af7d4 3941
00f254e2
KW		 3942 /* We can convert in place, as lowercasing anything in the latin1 range
3943 * (or else DO_UTF8 would have been on) doesn't lengthen it */
ec9af7d4
NC		 3944 dest = source;
3945 s = d = (U8*)SvPV_force_nomg(source, len);
3946 min = len + 1;
3947 } else {
a0ed51b3 3948 dTARGET;
a0ed51b3 3949
ec9af7d4
NC		 3950 dest = TARG;
3951
3952 /* The old implementation would copy source into TARG at this point.
3953 This had the side effect that if source was undef, TARG was now
3954 an undefined SV with PADTMP set, and they don't warn inside
3955 sv_2pv_flags(). However, we're now getting the PV direct from
3956 source, which doesn't have PADTMP set, so it would warn. Hence the
3957 little games. */
3958
3959 if (SvOK(source)) {
3960 s = (const U8*)SvPV_nomg_const(source, len);
3961 } else {
0a0ffbce
RGS		 3962 if (ckWARN(WARN_UNINITIALIZED))
3963 report_uninit(source);
1eced8f8 3964 s = (const U8*)"";
ec9af7d4 3965 len = 0;
a0ed51b3 3966 }
ec9af7d4 3967 min = len + 1;
128c9517 3968
ec9af7d4 3969 SvUPGRADE(dest, SVt_PV);
3b416f41 3970 d = (U8*)SvGROW(dest, min);
ec9af7d4
NC		 3971 (void)SvPOK_only(dest);
3972
3973 SETs(dest);
3974 }
3975
3976 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3977 to check DO_UTF8 again here. */
3978
3979 if (DO_UTF8(source)) {
3980 const U8 *const send = s + len;
3981 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
094a2f8c 3982 bool tainted = FALSE;
ec9af7d4
NC		 3983
3984 while (s < send) {
06b5486a
KW		 3985 const STRLEN u = UTF8SKIP(s);
3986 STRLEN ulen;
00f254e2 3987
094a2f8c
KW		 3988 _to_utf8_lower_flags(s, tmpbuf, &ulen,
3989 cBOOL(IN_LOCALE_RUNTIME), &tainted);
00f254e2 3990
06b5486a
KW		 3991 /* Here is where we would do context-sensitive actions. See the
3992 * commit message for this comment for why there isn't any */
00f254e2 3993
06b5486a 3994 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
fdb34c52 3995
06b5486a
KW		 3996 /* If the eventually required minimum size outgrows the
3997 * available space, we need to grow. */
3998 const UV o = d - (U8*)SvPVX_const(dest);
fdb34c52 3999
06b5486a
KW		 4000 /* If someone lowercases one million U+0130s we SvGROW() one
4001 * million times. Or we could try guessing how much to
4002 * allocate without allocating too much. Such is life.
4003 * Another option would be to grow an extra byte or two more
4004 * each time we need to grow, which would cut down the million
4005 * to 500K, with little waste */
4006 SvGROW(dest, min);
4007 d = (U8*)SvPVX(dest) + o;
4008 }
86510fb1 4009
06b5486a
KW		 4010 /* Copy the newly lowercased letter to the output buffer we're
4011 * building */
4012 Copy(tmpbuf, d, ulen, U8);
4013 d += ulen;
4014 s += u;
00f254e2 4015 } /* End of looping through the source string */
ec9af7d4
NC		 4016 SvUTF8_on(dest);
4017 *d = '\0';
4018 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
094a2f8c
KW		 4019 if (tainted) {
4020 TAINT;
4021 SvTAINTED_on(dest);
4022 }
00f254e2 4023 } else { /* Not utf8 */
31351b04 4024 if (len) {
ec9af7d4 4025 const U8 *const send = s + len;
00f254e2
KW		 4026
4027 /* Use locale casing if in locale; regular style if not treating
4028 * latin1 as having case; otherwise the latin1 casing. Do the
4029 * whole thing in a tight loop, for speed, */
2de3dbcc 4030 if (IN_LOCALE_RUNTIME) {
31351b04 4031 TAINT;
ec9af7d4
NC		 4032 SvTAINTED_on(dest);
4033 for (; s < send; d++, s++)
4034 *d = toLOWER_LC(*s);
31351b04 4035 }
00f254e2
KW		 4036 else if (! IN_UNI_8_BIT) {
4037 for (; s < send; d++, s++) {
ec9af7d4 4038 *d = toLOWER(*s);
00f254e2
KW		 4039 }
4040 }
4041 else {
4042 for (; s < send; d++, s++) {
4043 *d = toLOWER_LATIN1(*s);
4044 }
31351b04 4045 }
bbce6d69 4046 }
ec9af7d4
NC		 4047 if (source != dest) {
4048 *d = '\0';
4049 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4050 }
79072805 4051 }
539689e7
FC		 4052 if (dest != source && SvTAINTED(source))
4053 SvTAINT(dest);
ec9af7d4 4054 SvSETMAGIC(dest);
79072805
LW		 4055 RETURN;
4056}
4057
a0d0e21e 4058PP(pp_quotemeta)
79072805 4059{
97aff369 4060 dVAR; dSP; dTARGET;
1b6737cc 4061 SV * const sv = TOPs;
a0d0e21e 4062 STRLEN len;
eb578fdb 4063 const char *s = SvPV_const(sv,len);
79072805 4064
7e2040f0 4065 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4066 if (len) {
eb578fdb 4067 char *d;
862a34c6 4068 SvUPGRADE(TARG, SVt_PV);
c07a80fd 4069 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 4070 d = SvPVX(TARG);
7e2040f0 4071 if (DO_UTF8(sv)) {
0dd2cdef 4072 while (len) {
29050de5 4073 STRLEN ulen = UTF8SKIP(s);
2e2b2571
KW		 4074 bool to_quote = FALSE;
4075
4076 if (UTF8_IS_INVARIANT(*s)) {
4077 if (_isQUOTEMETA(*s)) {
4078 to_quote = TRUE;
4079 }
4080 }
4081 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
20adcf7c
KW		 4082
4083 /* In locale, we quote all non-ASCII Latin1 chars.
4084 * Otherwise use the quoting rules */
4085 if (IN_LOCALE_RUNTIME
4086 || _isQUOTEMETA(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1))))
2e2b2571
KW		 4087 {
4088 to_quote = TRUE;
4089 }
4090 }
685289b5 4091 else if (is_QUOTEMETA_high(s)) {
2e2b2571
KW		 4092 to_quote = TRUE;
4093 }
4094
4095 if (to_quote) {
4096 *d++ = '\\';
4097 }
29050de5
KW		 4098 if (ulen > len)
4099 ulen = len;
4100 len -= ulen;
4101 while (ulen--)
4102 *d++ = *s++;
0dd2cdef 4103 }
7e2040f0 4104 SvUTF8_on(TARG);
0dd2cdef 4105 }
2e2b2571
KW		 4106 else if (IN_UNI_8_BIT) {
4107 while (len--) {
4108 if (_isQUOTEMETA(*s))
4109 *d++ = '\\';
4110 *d++ = *s++;
4111 }
4112 }
0dd2cdef 4113 else {
2e2b2571
KW		 4114 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4115 * including everything above ASCII */
0dd2cdef 4116 while (len--) {
adfec831 4117 if (!isWORDCHAR_A(*s))
0dd2cdef
LW		 4118 *d++ = '\\';
4119 *d++ = *s++;
4120 }
79072805 4121 }
a0d0e21e 4122 *d = '\0';
349d4f2f 4123 SvCUR_set(TARG, d - SvPVX_const(TARG));
3aa33fe5 4124 (void)SvPOK_only_UTF8(TARG);
79072805 4125 }
a0d0e21e
LW		 4126 else
4127 sv_setpvn(TARG, s, len);
ec93b65f 4128 SETTARG;
79072805
LW		 4129 RETURN;
4130}
4131
838f2281
BF		 4132PP(pp_fc)
4133{
4134 dVAR;
4135 dTARGET;
4136 dSP;
4137 SV *source = TOPs;
4138 STRLEN len;
4139 STRLEN min;
4140 SV *dest;
4141 const U8 *s;
4142 const U8 *send;
4143 U8 *d;
bfac13d4 4144 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
838f2281
BF		 4145 const bool full_folding = TRUE;
4146 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4147 | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
4148
4149 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4150 * You are welcome(?) -Hugmeir
4151 */
4152
4153 SvGETMAGIC(source);
4154
4155 dest = TARG;
4156
4157 if (SvOK(source)) {
4158 s = (const U8*)SvPV_nomg_const(source, len);
4159 } else {
4160 if (ckWARN(WARN_UNINITIALIZED))
4161 report_uninit(source);
4162 s = (const U8*)"";
4163 len = 0;
4164 }
4165
4166 min = len + 1;
4167
4168 SvUPGRADE(dest, SVt_PV);
4169 d = (U8*)SvGROW(dest, min);
4170 (void)SvPOK_only(dest);
4171
4172 SETs(dest);
4173
4174 send = s + len;
4175 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4176 bool tainted = FALSE;
4177 while (s < send) {
4178 const STRLEN u = UTF8SKIP(s);
4179 STRLEN ulen;
4180
4181 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
4182
4183 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4184 const UV o = d - (U8*)SvPVX_const(dest);
4185 SvGROW(dest, min);
4186 d = (U8*)SvPVX(dest) + o;
4187 }
4188
4189 Copy(tmpbuf, d, ulen, U8);
4190 d += ulen;
4191 s += u;
4192 }
4193 SvUTF8_on(dest);
4194 if (tainted) {
4195 TAINT;
4196 SvTAINTED_on(dest);
4197 }
4198 } /* Unflagged string */
0902dd32 4199 else if (len) {
838f2281
BF		 4200 if ( IN_LOCALE_RUNTIME ) { /* Under locale */
4201 TAINT;
4202 SvTAINTED_on(dest);
4203 for (; s < send; d++, s++)
d22b930b 4204 *d = toFOLD_LC(*s);
838f2281
BF		 4205 }
4206 else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4207 for (; s < send; d++, s++)
d22b930b 4208 *d = toFOLD(*s);
838f2281
BF		 4209 }
4210 else {
d14578b8
KW		 4211 /* For ASCII and the Latin-1 range, there's only two troublesome
4212 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
22e255cb 4213 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
d14578b8
KW		 4214 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4215 * For the rest, the casefold is their lowercase. */
838f2281
BF		 4216 for (; s < send; d++, s++) {
4217 if (*s == MICRO_SIGN) {
d14578b8
KW		 4218 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4219 * which is outside of the latin-1 range. There's a couple
4220 * of ways to deal with this -- khw discusses them in
4221 * pp_lc/uc, so go there :) What we do here is upgrade what
4222 * we had already casefolded, then enter an inner loop that
4223 * appends the rest of the characters as UTF-8. */
838f2281
BF		 4224 len = d - (U8*)SvPVX_const(dest);
4225 SvCUR_set(dest, len);
4226 len = sv_utf8_upgrade_flags_grow(dest,
4227 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
ea4d335b
KW		 4228 /* The max expansion for latin1
4229 * chars is 1 byte becomes 2 */
4230 (send -s) * 2 + 1);
838f2281
BF		 4231 d = (U8*)SvPVX(dest) + len;
4232
a78bc3c6
KW		 4233 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4234 d += small_mu_len;
838f2281
BF		 4235 s++;
4236 for (; s < send; s++) {
4237 STRLEN ulen;
4238 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4239 if UNI_IS_INVARIANT(fc) {
d14578b8
KW		 4240 if (full_folding
4241 && *s == LATIN_SMALL_LETTER_SHARP_S)
4242 {
838f2281
BF		 4243 *d++ = 's';
4244 *d++ = 's';
4245 }
4246 else
4247 *d++ = (U8)fc;
4248 }
4249 else {
4250 Copy(tmpbuf, d, ulen, U8);
4251 d += ulen;
4252 }
4253 }
4254 break;
4255 }
4256 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
d14578b8
KW		 4257 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4258 * becomes "ss", which may require growing the SV. */
838f2281
BF		 4259 if (SvLEN(dest) < ++min) {
4260 const UV o = d - (U8*)SvPVX_const(dest);
4261 SvGROW(dest, min);
4262 d = (U8*)SvPVX(dest) + o;
4263 }
4264 *(d)++ = 's';
4265 *d = 's';
4266 }
d14578b8
KW		 4267 else { /* If it's not one of those two, the fold is their lower
4268 case */
838f2281
BF		 4269 *d = toLOWER_LATIN1(*s);
4270 }
4271 }
4272 }
4273 }
4274 *d = '\0';
4275 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4276
4277 if (SvTAINTED(source))
4278 SvTAINT(dest);
4279 SvSETMAGIC(dest);
4280 RETURN;
4281}
4282
a0d0e21e 4283/* Arrays. */
79072805 4284
a0d0e21e 4285PP(pp_aslice)
79072805 4286{
97aff369 4287 dVAR; dSP; dMARK; dORIGMARK;
eb578fdb
KW		 4288 AV *const av = MUTABLE_AV(POPs);
4289 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
79072805 4290
a0d0e21e 4291 if (SvTYPE(av) == SVt_PVAV) {
4ad10a0b
VP		 4292 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4293 bool can_preserve = FALSE;
4294
4295 if (localizing) {
4296 MAGIC *mg;
4297 HV *stash;
4298
4299 can_preserve = SvCANEXISTDELETE(av);
4300 }
4301
4302 if (lval && localizing) {
eb578fdb 4303 SV **svp;
748a9306 4304 I32 max = -1;
924508f0 4305 for (svp = MARK + 1; svp <= SP; svp++) {
4ea561bc 4306 const I32 elem = SvIV(*svp);
748a9306
LW		 4307 if (elem > max)
4308 max = elem;
4309 }
4310 if (max > AvMAX(av))
4311 av_extend(av, max);
4312 }
4ad10a0b 4313
a0d0e21e 4314 while (++MARK <= SP) {
eb578fdb 4315 SV **svp;
4ea561bc 4316 I32 elem = SvIV(*MARK);
4ad10a0b 4317 bool preeminent = TRUE;
a0d0e21e 4318
4ad10a0b
VP		 4319 if (localizing && can_preserve) {
4320 /* If we can determine whether the element exist,
4321 * Try to preserve the existenceness of a tied array
4322 * element by using EXISTS and DELETE if possible.
4323 * Fallback to FETCH and STORE otherwise. */
4324 preeminent = av_exists(av, elem);
4325 }
4326
a0d0e21e
LW		 4327 svp = av_fetch(av, elem, lval);
4328 if (lval) {
3280af22 4329 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 4330 DIE(aTHX_ PL_no_aelem, elem);
4ad10a0b
VP		 4331 if (localizing) {
4332 if (preeminent)
4333 save_aelem(av, elem, svp);
4334 else
4335 SAVEADELETE(av, elem);
4336 }
79072805 4337 }
3280af22 4338 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 4339 }
4340 }
748a9306 4341 if (GIMME != G_ARRAY) {
a0d0e21e 4342 MARK = ORIGMARK;
04ab2c87 4343 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e
LW		 4344 SP = MARK;
4345 }
79072805
LW		 4346 RETURN;
4347}
4348
cba5a3b0
DG		 4349/* Smart dereferencing for keys, values and each */
4350PP(pp_rkeys)
4351{
4352 dVAR;
4353 dSP;
4354 dPOPss;
4355
7ac5715b
FC		 4356 SvGETMAGIC(sv);
4357
4358 if (
4359 !SvROK(sv)
4360 || (sv = SvRV(sv),
4361 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4362 || SvOBJECT(sv)
4363 )
4364 ) {
4365 DIE(aTHX_
4366 "Type of argument to %s must be unblessed hashref or arrayref",
4c540399 4367 PL_op_desc[PL_op->op_type] );
cba5a3b0
DG		 4368 }
4369
d8065907
FC		 4370 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4371 DIE(aTHX_
4372 "Can't modify %s in %s",
4373 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4374 );
4375
cba5a3b0
DG		 4376 /* Delegate to correct function for op type */
4377 PUSHs(sv);
4378 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4379 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4380 }
4381 else {
d14578b8
KW		 4382 return (SvTYPE(sv) == SVt_PVHV)
4383 ? Perl_pp_each(aTHX)
4384 : Perl_pp_aeach(aTHX);
cba5a3b0
DG		 4385 }
4386}
4387
878d132a
NC		 4388PP(pp_aeach)
4389{
4390 dVAR;
4391 dSP;
502c6561 4392 AV *array = MUTABLE_AV(POPs);
878d132a 4393 const I32 gimme = GIMME_V;
453d94a9 4394 IV *iterp = Perl_av_iter_p(aTHX_ array);
878d132a
NC		 4395 const IV current = (*iterp)++;
4396
4397 if (current > av_len(array)) {
4398 *iterp = 0;
4399 if (gimme == G_SCALAR)
4400 RETPUSHUNDEF;
4401 else
4402 RETURN;
4403 }
4404
4405 EXTEND(SP, 2);
e1dccc0d 4406 mPUSHi(current);
878d132a
NC		 4407 if (gimme == G_ARRAY) {
4408 SV **const element = av_fetch(array, current, 0);
4409 PUSHs(element ? *element : &PL_sv_undef);
4410 }
4411 RETURN;
4412}
4413
4414PP(pp_akeys)
4415{
4416 dVAR;
4417 dSP;
502c6561 4418 AV *array = MUTABLE_AV(POPs);
878d132a
NC		 4419 const I32 gimme = GIMME_V;
4420
4421 *Perl_av_iter_p(aTHX_ array) = 0;
4422
4423 if (gimme == G_SCALAR) {
4424 dTARGET;
4425 PUSHi(av_len(array) + 1);
4426 }
4427 else if (gimme == G_ARRAY) {
4428 IV n = Perl_av_len(aTHX_ array);
e1dccc0d 4429 IV i;
878d132a
NC		 4430
4431 EXTEND(SP, n + 1);
4432
cba5a3b0 4433 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
e1dccc0d 4434 for (i = 0; i <= n; i++) {
878d132a
NC		 4435 mPUSHi(i);
4436 }
4437 }
4438 else {
4439 for (i = 0; i <= n; i++) {
4440 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4441 PUSHs(elem ? *elem : &PL_sv_undef);
4442 }
4443 }
4444 }
4445 RETURN;
4446}
4447
79072805
LW		 4448/* Associative arrays. */
4449
4450PP(pp_each)
4451{
97aff369 4452 dVAR;
39644a26 4453 dSP;
85fbaab2 4454 HV * hash = MUTABLE_HV(POPs);
c07a80fd 4455 HE *entry;
f54cb97a 4456 const I32 gimme = GIMME_V;
8ec5e241 4457
c07a80fd 4458 PUTBACK;
c750a3ec 4459 /* might clobber stack_sp */
6d822dc4 4460 entry = hv_iternext(hash);
c07a80fd 4461 SPAGAIN;
79072805 4462
79072805
LW		 4463 EXTEND(SP, 2);
4464 if (entry) {
1b6737cc 4465 SV* const sv = hv_iterkeysv(entry);
574c8022 4466 PUSHs(sv); /* won't clobber stack_sp */
54310121 4467 if (gimme == G_ARRAY) {
59af0135 4468 SV *val;
c07a80fd 4469 PUTBACK;
c750a3ec 4470 /* might clobber stack_sp */
6d822dc4 4471 val = hv_iterval(hash, entry);
c07a80fd 4472 SPAGAIN;
59af0135 4473 PUSHs(val);
79072805 4474 }
79072805 4475 }
54310121 4476 else if (gimme == G_SCALAR)
79072805
LW		 4477 RETPUSHUNDEF;
4478
4479 RETURN;
4480}
4481
7332a6c4
VP		 4482STATIC OP *
4483S_do_delete_local(pTHX)
79072805 4484{
97aff369 4485 dVAR;
39644a26 4486 dSP;
f54cb97a 4487 const I32 gimme = GIMME_V;
7332a6c4
VP		 4488 const MAGIC *mg;
4489 HV *stash;
ca3f996a
FC		 4490 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4491 SV *unsliced_keysv = sliced ? NULL : POPs;
4492 SV * const osv = POPs;
eb578fdb 4493 SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
ca3f996a
FC		 4494 dORIGMARK;
4495 const bool tied = SvRMAGICAL(osv)
7332a6c4 4496 && mg_find((const SV *)osv, PERL_MAGIC_tied);
ca3f996a
FC		 4497 const bool can_preserve = SvCANEXISTDELETE(osv);
4498 const U32 type = SvTYPE(osv);
4499 SV ** const end = sliced ? SP : &unsliced_keysv;
4500
4501 if (type == SVt_PVHV) { /* hash element */
7332a6c4 4502 HV * const hv = MUTABLE_HV(osv);
ca3f996a 4503 while (++MARK <= end) {
7332a6c4
VP		 4504 SV * const keysv = *MARK;
4505 SV *sv = NULL;
4506 bool preeminent = TRUE;
4507 if (can_preserve)
4508 preeminent = hv_exists_ent(hv, keysv, 0);
4509 if (tied) {
4510 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4511 if (he)
4512 sv = HeVAL(he);
4513 else
4514 preeminent = FALSE;
4515 }
4516 else {
4517 sv = hv_delete_ent(hv, keysv, 0, 0);
9332b95f
FC		 4518 if (preeminent)
4519 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
7332a6c4
VP		 4520 }
4521 if (preeminent) {
be6064fd 4522 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
7332a6c4
VP		 4523 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4524 if (tied) {
4525 *MARK = sv_mortalcopy(sv);
4526 mg_clear(sv);
4527 } else
4528 *MARK = sv;
4529 }
4530 else {
4531 SAVEHDELETE(hv, keysv);
4532 *MARK = &PL_sv_undef;
4533 }
4534 }
ca3f996a
FC		 4535 }
4536 else if (type == SVt_PVAV) { /* array element */
7332a6c4
VP		 4537 if (PL_op->op_flags & OPf_SPECIAL) {
4538 AV * const av = MUTABLE_AV(osv);
ca3f996a 4539 while (++MARK <= end) {
7332a6c4
VP		 4540 I32 idx = SvIV(*MARK);
4541 SV *sv = NULL;
4542 bool preeminent = TRUE;
4543 if (can_preserve)
4544 preeminent = av_exists(av, idx);
4545 if (tied) {
4546 SV **svp = av_fetch(av, idx, 1);
4547 if (svp)
4548 sv = *svp;
4549 else
4550 preeminent = FALSE;
4551 }
4552 else {
4553 sv = av_delete(av, idx, 0);
9332b95f
FC		 4554 if (preeminent)
4555 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
7332a6c4
VP		 4556 }
4557 if (preeminent) {
4558 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4559 if (tied) {
4560 *MARK = sv_mortalcopy(sv);
4561 mg_clear(sv);
4562 } else
4563 *MARK = sv;
4564 }
4565 else {
4566 SAVEADELETE(av, idx);
4567 *MARK = &PL_sv_undef;
4568 }
4569 }
4570 }
ca3f996a
FC		 4571 else
4572 DIE(aTHX_ "panic: avhv_delete no longer supported");
4573 }
4574 else
7332a6c4 4575 DIE(aTHX_ "Not a HASH reference");
ca3f996a 4576 if (sliced) {
7332a6c4
VP		 4577 if (gimme == G_VOID)
4578 SP = ORIGMARK;
4579 else if (gimme == G_SCALAR) {
4580 MARK = ORIGMARK;
4581 if (SP > MARK)
4582 *++MARK = *SP;
4583 else
4584 *++MARK = &PL_sv_undef;
4585 SP = MARK;
4586 }
4587 }
ca3f996a
FC		 4588 else if (gimme != G_VOID)
4589 PUSHs(unsliced_keysv);
7332a6c4
VP		 4590
4591 RETURN;
4592}
4593
4594PP(pp_delete)
4595{
4596 dVAR;
4597 dSP;
4598 I32 gimme;
4599 I32 discard;
4600
4601 if (PL_op->op_private & OPpLVAL_INTRO)
4602 return do_delete_local();
4603
4604 gimme = GIMME_V;
4605 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5f05dabc 4606
533c011a 4607 if (PL_op->op_private & OPpSLICE) {
5f05dabc 4608 dMARK; dORIGMARK;
85fbaab2 4609 HV * const hv = MUTABLE_HV(POPs);
1b6737cc 4610 const U32 hvtype = SvTYPE(hv);
01020589
GS		 4611 if (hvtype == SVt_PVHV) { /* hash element */
4612 while (++MARK <= SP) {
1b6737cc 4613 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 4614 *MARK = sv ? sv : &PL_sv_undef;
4615 }
5f05dabc 4616 }
6d822dc4
MS		 4617 else if (hvtype == SVt_PVAV) { /* array element */
4618 if (PL_op->op_flags & OPf_SPECIAL) {
4619 while (++MARK <= SP) {
502c6561 4620 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
6d822dc4
MS		 4621 *MARK = sv ? sv : &PL_sv_undef;
4622 }
4623 }
01020589
GS		 4624 }
4625 else
4626 DIE(aTHX_ "Not a HASH reference");
54310121 4627 if (discard)
4628 SP = ORIGMARK;
4629 else if (gimme == G_SCALAR) {
5f05dabc 4630 MARK = ORIGMARK;
9111c9c0
DM		 4631 if (SP > MARK)
4632 *++MARK = *SP;
4633 else
4634 *++MARK = &PL_sv_undef;
5f05dabc 4635 SP = MARK;
4636 }
4637 }
4638 else {
4639 SV *keysv = POPs;
85fbaab2 4640 HV * const hv = MUTABLE_HV(POPs);
295d248e 4641 SV *sv = NULL;
97fcbf96
MB		 4642 if (SvTYPE(hv) == SVt_PVHV)
4643 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 4644 else if (SvTYPE(hv) == SVt_PVAV) {
4645 if (PL_op->op_flags & OPf_SPECIAL)
502c6561 4646 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
af288a60
HS		 4647 else
4648 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 4649 }
97fcbf96 4650 else
cea2e8a9 4651 DIE(aTHX_ "Not a HASH reference");
5f05dabc 4652 if (!sv)
3280af22 4653 sv = &PL_sv_undef;
54310121 4654 if (!discard)
4655 PUSHs(sv);
79072805 4656 }
79072805
LW		 4657 RETURN;
4658}
4659
a0d0e21e 4660PP(pp_exists)
79072805 4661{
97aff369 4662 dVAR;
39644a26 4663 dSP;
afebc493
GS		 4664 SV *tmpsv;
4665 HV *hv;
4666
c7e88ff3 4667 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
afebc493 4668 GV *gv;
0bd48802 4669 SV * const sv = POPs;
f2c0649b 4670 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
afebc493
GS		 4671 if (cv)
4672 RETPUSHYES;
4673 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4674 RETPUSHYES;
4675 RETPUSHNO;
4676 }
4677 tmpsv = POPs;
85fbaab2 4678 hv = MUTABLE_HV(POPs);
c7e88ff3 4679 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
ae77835f 4680 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 4681 RETPUSHYES;
ef54e1a4
JH		 4682 }
4683 else if (SvTYPE(hv) == SVt_PVAV) {
01020589 4684 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
502c6561 4685 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
01020589
GS		 4686 RETPUSHYES;
4687 }
ef54e1a4
JH		 4688 }
4689 else {
cea2e8a9 4690 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 4691 }
a0d0e21e
LW		 4692 RETPUSHNO;
4693}
79072805 4694
a0d0e21e
LW		 4695PP(pp_hslice)
4696{
97aff369 4697 dVAR; dSP; dMARK; dORIGMARK;
eb578fdb
KW		 4698 HV * const hv = MUTABLE_HV(POPs);
4699 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
1b6737cc 4700 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 4701 bool can_preserve = FALSE;
79072805 4702
eb85dfd3
DM		 4703 if (localizing) {
4704 MAGIC *mg;
4705 HV *stash;
4706
2c5f48c2 4707 if (SvCANEXISTDELETE(hv))
d30e492c 4708 can_preserve = TRUE;
eb85dfd3
DM		 4709 }
4710
6d822dc4 4711 while (++MARK <= SP) {
1b6737cc 4712 SV * const keysv = *MARK;
6d822dc4
MS		 4713 SV **svp;
4714 HE *he;
d30e492c
VP		 4715 bool preeminent = TRUE;
4716
4717 if (localizing && can_preserve) {
4718 /* If we can determine whether the element exist,
4719 * try to preserve the existenceness of a tied hash
4720 * element by using EXISTS and DELETE if possible.
4721 * Fallback to FETCH and STORE otherwise. */
4722 preeminent = hv_exists_ent(hv, keysv, 0);
6d822dc4 4723 }
eb85dfd3 4724
6d822dc4 4725 he = hv_fetch_ent(hv, keysv, lval, 0);
fe5bfecd 4726 svp = he ? &HeVAL(he) : NULL;
eb85dfd3 4727
6d822dc4 4728 if (lval) {
746f6409 4729 if (!svp || !*svp || *svp == &PL_sv_undef) {
be2597df 4730 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6d822dc4
MS		 4731 }
4732 if (localizing) {
7a2e501a 4733 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 4734 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP		 4735 else if (preeminent)
4736 save_helem_flags(hv, keysv, svp,
4737 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4738 else
4739 SAVEHDELETE(hv, keysv);
6d822dc4
MS		 4740 }
4741 }
746f6409 4742 *MARK = svp && *svp ? *svp : &PL_sv_undef;
79072805 4743 }
a0d0e21e
LW		 4744 if (GIMME != G_ARRAY) {
4745 MARK = ORIGMARK;
04ab2c87 4746 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e 4747 SP = MARK;
79072805 4748 }
a0d0e21e
LW		 4749 RETURN;
4750}
4751
4752/* List operators. */
4753
4754PP(pp_list)
4755{
97aff369 4756 dVAR; dSP; dMARK;
a0d0e21e
LW		 4757 if (GIMME != G_ARRAY) {
4758 if (++MARK <= SP)
4759 *MARK = *SP; /* unwanted list, return last item */
8990e307 4760 else
3280af22 4761 *MARK = &PL_sv_undef;
a0d0e21e 4762 SP = MARK;
79072805 4763 }
a0d0e21e 4764 RETURN;
79072805
LW		 4765}
4766
a0d0e21e 4767PP(pp_lslice)
79072805 4768{
97aff369 4769 dVAR;
39644a26 4770 dSP;
1b6737cc
AL		 4771 SV ** const lastrelem = PL_stack_sp;
4772 SV ** const lastlelem = PL_stack_base + POPMARK;
4773 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
eb578fdb 4774 SV ** const firstrelem = lastlelem + 1;
42e73ed0 4775 I32 is_something_there = FALSE;
1b6737cc 4776
eb578fdb
KW		 4777 const I32 max = lastrelem - lastlelem;
4778 SV **lelem;
a0d0e21e
LW		 4779
4780 if (GIMME != G_ARRAY) {
4ea561bc 4781 I32 ix = SvIV(*lastlelem);
748a9306
LW		 4782 if (ix < 0)
4783 ix += max;
a0d0e21e 4784 if (ix < 0 || ix >= max)
3280af22 4785 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 4786 else
4787 *firstlelem = firstrelem[ix];
4788 SP = firstlelem;
4789 RETURN;
4790 }
4791
4792 if (max == 0) {
4793 SP = firstlelem - 1;
4794 RETURN;
4795 }
4796
4797 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4ea561bc 4798 I32 ix = SvIV(*lelem);
c73bf8e3 4799 if (ix < 0)
a0d0e21e 4800 ix += max;
c73bf8e3
HS		 4801 if (ix < 0 || ix >= max)
4802 *lelem = &PL_sv_undef;
4803 else {
4804 is_something_there = TRUE;
4805 if (!(*lelem = firstrelem[ix]))
3280af22 4806 *lelem = &PL_sv_undef;
748a9306 4807 }
79072805 4808 }
4633a7c4
LW		 4809 if (is_something_there)
4810 SP = lastlelem;
4811 else
4812 SP = firstlelem - 1;
79072805
LW		 4813 RETURN;
4814}
4815
a0d0e21e
LW		 4816PP(pp_anonlist)
4817{
31476221 4818 dVAR; dSP; dMARK;
1b6737cc 4819 const I32 items = SP - MARK;
ad64d0ec 4820 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
31476221 4821 SP = MARK;
6e449a3a
MHM		 4822 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4823 ? newRV_noinc(av) : av);
a0d0e21e
LW		 4824 RETURN;
4825}
4826
4827PP(pp_anonhash)
79072805 4828{
97aff369 4829 dVAR; dSP; dMARK; dORIGMARK;
67e67fd7 4830 HV* const hv = newHV();
8d455b9f 4831 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
67e67fd7 4832 ? newRV_noinc(MUTABLE_SV(hv))
8d455b9f 4833 : MUTABLE_SV(hv) );
a0d0e21e
LW		 4834
4835 while (MARK < SP) {
3ed356df
FC		 4836 SV * const key =
4837 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
4838 SV *val;
a0d0e21e 4839 if (MARK < SP)
3ed356df
FC		 4840 {
4841 MARK++;
4842 SvGETMAGIC(*MARK);
4843 val = newSV(0);
4844 sv_setsv(val, *MARK);
4845 }
a2a5de95 4846 else
3ed356df 4847 {
a2a5de95 4848 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3ed356df
FC		 4849 val = newSV(0);
4850 }
f12c7020 4851 (void)hv_store_ent(hv,key,val,0);
79072805 4852 }
a0d0e21e 4853 SP = ORIGMARK;
8d455b9f 4854 XPUSHs(retval);
79072805
LW		 4855 RETURN;
4856}
4857
d4fc4415
FC		 4858static AV *
4859S_deref_plain_array(pTHX_ AV *ary)
4860{
4861 if (SvTYPE(ary) == SVt_PVAV) return ary;
d2d95e13 4862 SvGETMAGIC((SV *)ary);
d4fc4415
FC		 4863 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4864 Perl_die(aTHX_ "Not an ARRAY reference");
4865 else if (SvOBJECT(SvRV(ary)))
4866 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4867 return (AV *)SvRV(ary);
4868}
4869
4870#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4871# define DEREF_PLAIN_ARRAY(ary) \
4872 ({ \
4873 AV *aRrRay = ary; \
4874 SvTYPE(aRrRay) == SVt_PVAV \
4875 ? aRrRay \
4876 : S_deref_plain_array(aTHX_ aRrRay); \
4877 })
4878#else
4879# define DEREF_PLAIN_ARRAY(ary) \
4880 ( \
3b0f6d32 4881 PL_Sv = (SV *)(ary), \
d4fc4415
FC		 4882 SvTYPE(PL_Sv) == SVt_PVAV \
4883 ? (AV *)PL_Sv \
3b0f6d32 4884 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
d4fc4415
FC		 4885 )
4886#endif
4887
a0d0e21e 4888PP(pp_splice)
79072805 4889{
27da23d5 4890 dVAR; dSP; dMARK; dORIGMARK;
5cd408a2 4891 int num_args = (SP - MARK);
eb578fdb
KW		 4892 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4893 SV **src;
4894 SV **dst;
4895 I32 i;
4896 I32 offset;
4897 I32 length;
a0d0e21e
LW		 4898 I32 newlen;
4899 I32 after;
4900 I32 diff;
ad64d0ec 4901 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 4902
1b6737cc 4903 if (mg) {
3e0cb5de 4904 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
af71faff
NC		 4905 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4906 sp - mark);
93965878 4907 }
79072805 4908
a0d0e21e 4909 SP++;
79072805 4910
a0d0e21e 4911 if (++MARK < SP) {
4ea561bc 4912 offset = i = SvIV(*MARK);
a0d0e21e 4913 if (offset < 0)
93965878 4914 offset += AvFILLp(ary) + 1;
84902520 4915 if (offset < 0)
cea2e8a9 4916 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 4917 if (++MARK < SP) {
4918 length = SvIVx(*MARK++);
48cdf507
GA		 4919 if (length < 0) {
4920 length += AvFILLp(ary) - offset + 1;
4921 if (length < 0)
4922 length = 0;
4923 }
79072805
LW		 4924 }
4925 else
a0d0e21e 4926 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 4927 }
a0d0e21e
LW		 4928 else {
4929 offset = 0;
4930 length = AvMAX(ary) + 1;
4931 }
8cbc2e3b 4932 if (offset > AvFILLp(ary) + 1) {
5cd408a2
EB		 4933 if (num_args > 2)
4934 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 4935 offset = AvFILLp(ary) + 1;
8cbc2e3b 4936 }
93965878 4937 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 4938 if (after < 0) { /* not that much array */
4939 length += after; /* offset+length now in array */
4940 after = 0;
4941 if (!AvALLOC(ary))
4942 av_extend(ary, 0);
4943 }
4944
4945 /* At this point, MARK .. SP-1 is our new LIST */
4946
4947 newlen = SP - MARK;
4948 diff = newlen - length;
13d7cbc1
GS		 4949 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4950 av_reify(ary);
a0d0e21e 4951
50528de0
WL		 4952 /* make new elements SVs now: avoid problems if they're from the array */
4953 for (dst = MARK, i = newlen; i; i--) {
1b6737cc 4954 SV * const h = *dst;
f2b990bf 4955 *dst++ = newSVsv(h);
50528de0
WL		 4956 }
4957
a0d0e21e 4958 if (diff < 0) { /* shrinking the area */
95b63a38 4959 SV **tmparyval = NULL;
a0d0e21e 4960 if (newlen) {
a02a5408 4961 Newx(tmparyval, newlen, SV*); /* so remember insertion */
a0d0e21e 4962 Copy(MARK, tmparyval, newlen, SV*);
79072805 4963 }
a0d0e21e
LW		 4964
4965 MARK = ORIGMARK + 1;
4966 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4967 MEXTEND(MARK, length);
4968 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4969 if (AvREAL(ary)) {
bbce6d69 4970 EXTEND_MORTAL(length);
36477c24 4971 for (i = length, dst = MARK; i; i--) {
486ec47a 4972 sv_2mortal(*dst); /* free them eventually */
36477c24 4973 dst++;
4974 }
a0d0e21e
LW		 4975 }
4976 MARK += length - 1;
79072805 4977 }
a0d0e21e
LW		 4978 else {
4979 *MARK = AvARRAY(ary)[offset+length-1];
4980 if (AvREAL(ary)) {
d689ffdd 4981 sv_2mortal(*MARK);
a0d0e21e
LW		 4982 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4983 SvREFCNT_dec(*dst++); /* free them now */
79072805 4984 }
a0d0e21e 4985 }
93965878 4986 AvFILLp(ary) += diff;
a0d0e21e
LW		 4987
4988 /* pull up or down? */
4989
4990 if (offset < after) { /* easier to pull up */
4991 if (offset) { /* esp. if nothing to pull */
4992 src = &AvARRAY(ary)[offset-1];
4993 dst = src - diff; /* diff is negative */
4994 for (i = offset; i > 0; i--) /* can't trust Copy */
4995 *dst-- = *src--;
79072805 4996 }
a0d0e21e 4997 dst = AvARRAY(ary);
9c6bc640 4998 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
a0d0e21e
LW		 4999 AvMAX(ary) += diff;
5000 }
5001 else {
5002 if (after) { /* anything to pull down? */
5003 src = AvARRAY(ary) + offset + length;
5004 dst = src + diff; /* diff is negative */
5005 Move(src, dst, after, SV*);
79072805 5006 }
93965878 5007 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 5008 /* avoid later double free */
5009 }
5010 i = -diff;
5011 while (i)
3280af22 5012 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 5013
5014 if (newlen) {
50528de0 5015 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e
LW		 5016 Safefree(tmparyval);
5017 }
5018 }
5019 else { /* no, expanding (or same) */
d3961450 5020 SV** tmparyval = NULL;
a0d0e21e 5021 if (length) {
a02a5408 5022 Newx(tmparyval, length, SV*); /* so remember deletion */
a0d0e21e
LW		 5023 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5024 }
5025
5026 if (diff > 0) { /* expanding */
a0d0e21e 5027 /* push up or down? */
a0d0e21e
LW		 5028 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5029 if (offset) {
5030 src = AvARRAY(ary);
5031 dst = src - diff;
5032 Move(src, dst, offset, SV*);
79072805 5033 }
9c6bc640 5034 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
a0d0e21e 5035 AvMAX(ary) += diff;
93965878 5036 AvFILLp(ary) += diff;
79072805
LW		 5037 }
5038 else {
93965878
NIS		 5039 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5040 av_extend(ary, AvFILLp(ary) + diff);
5041 AvFILLp(ary) += diff;
a0d0e21e
LW		 5042
5043 if (after) {
93965878 5044 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 5045 src = dst - diff;
5046 for (i = after; i; i--) {
5047 *dst-- = *src--;
5048 }
79072805
LW		 5049 }
5050 }
a0d0e21e
LW		 5051 }
5052
50528de0
WL		 5053 if (newlen) {
5054 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e 5055 }
50528de0 5056
a0d0e21e
LW		 5057 MARK = ORIGMARK + 1;
5058 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5059 if (length) {
5060 Copy(tmparyval, MARK, length, SV*);
5061 if (AvREAL(ary)) {
bbce6d69 5062 EXTEND_MORTAL(length);
36477c24 5063 for (i = length, dst = MARK; i; i--) {
486ec47a 5064 sv_2mortal(*dst); /* free them eventually */
36477c24 5065 dst++;
5066 }
79072805
LW		 5067 }
5068 }
a0d0e21e
LW		 5069 MARK += length - 1;
5070 }
5071 else if (length--) {
5072 *MARK = tmparyval[length];
5073 if (AvREAL(ary)) {
d689ffdd 5074 sv_2mortal(*MARK);
a0d0e21e
LW		 5075 while (length-- > 0)
5076 SvREFCNT_dec(tmparyval[length]);
79072805 5077 }
79072805 5078 }
a0d0e21e 5079 else
3280af22 5080 *MARK = &PL_sv_undef;
d3961450 5081 Safefree(tmparyval);
79072805 5082 }
474af990
FR		 5083
5084 if (SvMAGICAL(ary))
5085 mg_set(MUTABLE_SV(ary));
5086
a0d0e21e 5087 SP = MARK;
79072805
LW		 5088 RETURN;
5089}
5090
a0d0e21e 5091PP(pp_push)
79072805 5092{
27da23d5 5093 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
eb578fdb 5094 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5095 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
79072805 5096
1b6737cc 5097 if (mg) {
ad64d0ec 5098 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
93965878
NIS		 5099 PUSHMARK(MARK);
5100 PUTBACK;
d343c3ef 5101 ENTER_with_name("call_PUSH");
3e0cb5de 5102 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5103 LEAVE_with_name("call_PUSH");
93965878 5104 SPAGAIN;
93965878 5105 }
a60c0954 5106 else {
cb077ed2 5107 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
89c14e2e 5108 PL_delaymagic = DM_DELAY;
a60c0954 5109 for (++MARK; MARK <= SP; MARK++) {
3ed356df
FC		 5110 SV *sv;
5111 if (*MARK) SvGETMAGIC(*MARK);
5112 sv = newSV(0);
a60c0954 5113 if (*MARK)
3ed356df 5114 sv_setsv_nomg(sv, *MARK);
0a75904b 5115 av_store(ary, AvFILLp(ary)+1, sv);
a60c0954 5116 }
354b0578 5117 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 5118 mg_set(MUTABLE_SV(ary));
89c14e2e
BB		 5119
5120 PL_delaymagic = 0;
6eeabd23
VP		 5121 }
5122 SP = ORIGMARK;
5123 if (OP_GIMME(PL_op, 0) != G_VOID) {
5124 PUSHi( AvFILL(ary) + 1 );
79072805 5125 }
79072805
LW		 5126 RETURN;
5127}
5128
a0d0e21e 5129PP(pp_shift)
79072805 5130{
97aff369 5131 dVAR;
39644a26 5132 dSP;
538f5756 5133 AV * const av = PL_op->op_flags & OPf_SPECIAL
d4fc4415 5134 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
789b4bc9 5135 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
79072805 5136 EXTEND(SP, 1);
c2b4a044 5137 assert (sv);
d689ffdd 5138 if (AvREAL(av))
a0d0e21e
LW		 5139 (void)sv_2mortal(sv);
5140 PUSHs(sv);
79072805 5141 RETURN;
79072805
LW		 5142}
5143
a0d0e21e 5144PP(pp_unshift)
79072805 5145{
27da23d5 5146 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
eb578fdb 5147 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5148 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 5149
1b6737cc 5150 if (mg) {
ad64d0ec 5151 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
7fd66d9d 5152 PUSHMARK(MARK);
93965878 5153 PUTBACK;
d343c3ef 5154 ENTER_with_name("call_UNSHIFT");
36925d9e 5155 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5156 LEAVE_with_name("call_UNSHIFT");
93965878 5157 SPAGAIN;
93965878 5158 }
a60c0954 5159 else {
eb578fdb 5160 I32 i = 0;
a60c0954
NIS		 5161 av_unshift(ary, SP - MARK);
5162 while (MARK < SP) {
1b6737cc 5163 SV * const sv = newSVsv(*++MARK);
a60c0954
NIS		 5164 (void)av_store(ary, i++, sv);
5165 }
79072805 5166 }
a0d0e21e 5167 SP = ORIGMARK;
6eeabd23 5168 if (OP_GIMME(PL_op, 0) != G_VOID) {
5658d0a9
LR		 5169 PUSHi( AvFILL(ary) + 1 );
5170 }
79072805 5171 RETURN;
79072805
LW		 5172}
5173
a0d0e21e 5174PP(pp_reverse)
79072805 5175{
97aff369 5176 dVAR; dSP; dMARK;
79072805 5177
a0d0e21e 5178 if (GIMME == G_ARRAY) {
484c818f
VP		 5179 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5180 AV *av;
5181
5182 /* See pp_sort() */
5183 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5184 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5185 av = MUTABLE_AV((*SP));
5186 /* In-place reversing only happens in void context for the array
5187 * assignment. We don't need to push anything on the stack. */
5188 SP = MARK;
5189
5190 if (SvMAGICAL(av)) {
5191 I32 i, j;
eb578fdb 5192 SV *tmp = sv_newmortal();
484c818f
VP		 5193 /* For SvCANEXISTDELETE */
5194 HV *stash;
5195 const MAGIC *mg;
5196 bool can_preserve = SvCANEXISTDELETE(av);
5197
5198 for (i = 0, j = av_len(av); i < j; ++i, --j) {
eb578fdb 5199 SV *begin, *end;
484c818f
VP		 5200
5201 if (can_preserve) {
5202 if (!av_exists(av, i)) {
5203 if (av_exists(av, j)) {
eb578fdb 5204 SV *sv = av_delete(av, j, 0);
484c818f
VP		 5205 begin = *av_fetch(av, i, TRUE);
5206 sv_setsv_mg(begin, sv);
5207 }
5208 continue;
5209 }
5210 else if (!av_exists(av, j)) {
eb578fdb 5211 SV *sv = av_delete(av, i, 0);
484c818f
VP		 5212 end = *av_fetch(av, j, TRUE);
5213 sv_setsv_mg(end, sv);
5214 continue;
5215 }
5216 }
5217
5218 begin = *av_fetch(av, i, TRUE);
5219 end = *av_fetch(av, j, TRUE);
5220 sv_setsv(tmp, begin);
5221 sv_setsv_mg(begin, end);
5222 sv_setsv_mg(end, tmp);
5223 }
5224 }
5225 else {
5226 SV **begin = AvARRAY(av);
484c818f 5227
95a26d8e
VP		 5228 if (begin) {
5229 SV **end = begin + AvFILLp(av);
5230
5231 while (begin < end) {
eb578fdb 5232 SV * const tmp = *begin;
95a26d8e
VP		 5233 *begin++ = *end;
5234 *end-- = tmp;
5235 }
484c818f
VP		 5236 }
5237 }
5238 }
5239 else {
5240 SV **oldsp = SP;
5241 MARK++;
5242 while (MARK < SP) {
eb578fdb 5243 SV * const tmp = *MARK;
484c818f
VP		 5244 *MARK++ = *SP;
5245 *SP-- = tmp;
5246 }
5247 /* safe as long as stack cannot get extended in the above */
5248 SP = oldsp;
a0d0e21e 5249 }
79072805
LW		 5250 }
5251 else {
eb578fdb
KW		 5252 char *up;
5253 char *down;
5254 I32 tmp;
a0d0e21e
LW		 5255 dTARGET;
5256 STRLEN len;
79072805 5257
7e2040f0 5258 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 5259 if (SP - MARK > 1)
3280af22 5260 do_join(TARG, &PL_sv_no, MARK, SP);
1e21d011 5261 else {
789bd863 5262 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
1e21d011
B		 5263 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5264 report_uninit(TARG);
5265 }
5266
a0d0e21e
LW		 5267 up = SvPV_force(TARG, len);
5268 if (len > 1) {
7e2040f0 5269 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55 5270 U8* s = (U8*)SvPVX(TARG);
349d4f2f 5271 const U8* send = (U8*)(s + len);
a0ed51b3 5272 while (s < send) {
d742c382 5273 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 5274 s++;
5275 continue;
5276 }
5277 else {
4b88fb76 5278 if (!utf8_to_uvchr_buf(s, send, 0))
a0dbb045 5279 break;
dfe13c55 5280 up = (char*)s;
a0ed51b3 5281 s += UTF8SKIP(s);
dfe13c55 5282 down = (char*)(s - 1);
a0dbb045 5283 /* reverse this character */
a0ed51b3
LW		 5284 while (down > up) {
5285 tmp = *up;
5286 *up++ = *down;
eb160463 5287 *down-- = (char)tmp;
a0ed51b3
LW		 5288 }
5289 }
5290 }
5291 up = SvPVX(TARG);
5292 }
a0d0e21e
LW		 5293 down = SvPVX(TARG) + len - 1;
5294 while (down > up) {
5295 tmp = *up;
5296 *up++ = *down;
eb160463 5297 *down-- = (char)tmp;
a0d0e21e 5298 }
3aa33fe5 5299 (void)SvPOK_only_UTF8(TARG);
79072805 5300 }
a0d0e21e
LW		 5301 SP = MARK + 1;
5302 SETTARG;
79072805 5303 }
a0d0e21e 5304 RETURN;
79072805
LW		 5305}
5306
a0d0e21e 5307PP(pp_split)
79072805 5308{
27da23d5 5309 dVAR; dSP; dTARG;
a0d0e21e 5310 AV *ary;
eb578fdb 5311 IV limit = POPi; /* note, negative is forever */
1b6737cc 5312 SV * const sv = POPs;
a0d0e21e 5313 STRLEN len;
eb578fdb 5314 const char *s = SvPV_const(sv, len);
1b6737cc 5315 const bool do_utf8 = DO_UTF8(sv);
727b7506 5316 const char *strend = s + len;
eb578fdb
KW		 5317 PMOP *pm;
5318 REGEXP *rx;
5319 SV *dstr;
5320 const char *m;
a0d0e21e 5321 I32 iters = 0;
d14578b8
KW		 5322 const STRLEN slen = do_utf8
5323 ? utf8_length((U8*)s, (U8*)strend)
5324 : (STRLEN)(strend - s);
792b2c16 5325 I32 maxiters = slen + 10;
c1a7495a 5326 I32 trailing_empty = 0;
727b7506 5327 const char *orig;
1b6737cc 5328 const I32 origlimit = limit;
a0d0e21e
LW		 5329 I32 realarray = 0;
5330 I32 base;
f54cb97a 5331 const I32 gimme = GIMME_V;
941446f6 5332 bool gimme_scalar;
f54cb97a 5333 const I32 oldsave = PL_savestack_ix;
437d3b4e 5334 U32 make_mortal = SVs_TEMP;
7fba1cd6 5335 bool multiline = 0;
b37c2d43 5336 MAGIC *mg = NULL;
79072805 5337
44a8e56a 5338#ifdef DEBUGGING
5339 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5340#else
5341 pm = (PMOP*)POPs;
5342#endif
a0d0e21e 5343 if (!pm || !s)
5637ef5b 5344 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
aaa362c4 5345 rx = PM_GETRE(pm);
bbce6d69 5346
a62b1201 5347 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
dbc200c5 5348 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
bbce6d69 5349
971a9dd3 5350#ifdef USE_ITHREADS
20e98b0f 5351 if (pm->op_pmreplrootu.op_pmtargetoff) {
159b6efe 5352 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
20e98b0f 5353 }
971a9dd3 5354#else
20e98b0f
NC		 5355 if (pm->op_pmreplrootu.op_pmtargetgv) {
5356 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
971a9dd3 5357 }
20e98b0f 5358#endif
79072805 5359 else
7d49f689 5360 ary = NULL;
bcea25a7 5361 if (ary) {
a0d0e21e 5362 realarray = 1;
8ec5e241 5363 PUTBACK;
a0d0e21e
LW		 5364 av_extend(ary,0);
5365 av_clear(ary);
8ec5e241 5366 SPAGAIN;
ad64d0ec 5367 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
8ec5e241 5368 PUSHMARK(SP);
ad64d0ec 5369 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
8ec5e241
NIS		 5370 }
5371 else {
1c0b011c 5372 if (!AvREAL(ary)) {
1b6737cc 5373 I32 i;
1c0b011c 5374 AvREAL_on(ary);
abff13bb 5375 AvREIFY_off(ary);
1c0b011c 5376 for (i = AvFILLp(ary); i >= 0; i--)
d14578b8 5377 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 5378 }
5379 /* temporarily switch stacks */
8b7059b1 5380 SAVESWITCHSTACK(PL_curstack, ary);
8ec5e241 5381 make_mortal = 0;
1c0b011c 5382 }
79072805 5383 }
3280af22 5384 base = SP - PL_stack_base;
a0d0e21e 5385 orig = s;
dbc200c5 5386 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
613f191e 5387 if (do_utf8) {
76a77b1b 5388 while (isSPACE_utf8(s))
613f191e
TS		 5389 s += UTF8SKIP(s);
5390 }
a62b1201 5391 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
bbce6d69 5392 while (isSPACE_LC(*s))
5393 s++;
5394 }
5395 else {
5396 while (isSPACE(*s))
5397 s++;
5398 }
a0d0e21e 5399 }
73134a2e 5400 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
7fba1cd6 5401 multiline = 1;
c07a80fd 5402 }
5403
941446f6
FC		 5404 gimme_scalar = gimme == G_SCALAR && !ary;
5405
a0d0e21e
LW		 5406 if (!limit)
5407 limit = maxiters + 2;
dbc200c5 5408 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
a0d0e21e 5409 while (--limit) {
bbce6d69 5410 m = s;
8727f688
YO		 5411 /* this one uses 'm' and is a negative test */
5412 if (do_utf8) {
76a77b1b 5413 while (m < strend && ! isSPACE_utf8(m) ) {
613f191e 5414 const int t = UTF8SKIP(m);
76a77b1b 5415 /* isSPACE_utf8 returns FALSE for malform utf8 */
613f191e
TS		 5416 if (strend - m < t)
5417 m = strend;
5418 else
5419 m += t;
5420 }
a62b1201 5421 }
d14578b8
KW		 5422 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5423 {
8727f688
YO		 5424 while (m < strend && !isSPACE_LC(*m))
5425 ++m;
5426 } else {
5427 while (m < strend && !isSPACE(*m))
5428 ++m;
5429 }
a0d0e21e
LW		 5430 if (m >= strend)
5431 break;
bbce6d69 5432
c1a7495a
BB		 5433 if (gimme_scalar) {
5434 iters++;
5435 if (m-s == 0)
5436 trailing_empty++;
5437 else
5438 trailing_empty = 0;
5439 } else {
5440 dstr = newSVpvn_flags(s, m-s,
5441 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5442 XPUSHs(dstr);
5443 }
bbce6d69 5444
613f191e
TS		 5445 /* skip the whitespace found last */
5446 if (do_utf8)
5447 s = m + UTF8SKIP(m);
5448 else
5449 s = m + 1;
5450
8727f688
YO		 5451 /* this one uses 's' and is a positive test */
5452 if (do_utf8) {
76a77b1b 5453 while (s < strend && isSPACE_utf8(s) )
8727f688 5454 s += UTF8SKIP(s);
a62b1201 5455 }
d14578b8
KW		 5456 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5457 {
8727f688
YO		 5458 while (s < strend && isSPACE_LC(*s))
5459 ++s;
5460 } else {
5461 while (s < strend && isSPACE(*s))
5462 ++s;
5463 }
79072805
LW		 5464 }
5465 }
07bc277f 5466 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
a0d0e21e 5467 while (--limit) {
a6e20a40
AL		 5468 for (m = s; m < strend && *m != '\n'; m++)
5469 ;
a0d0e21e
LW		 5470 m++;
5471 if (m >= strend)
5472 break;
c1a7495a
BB		 5473
5474 if (gimme_scalar) {
5475 iters++;
5476 if (m-s == 0)
5477 trailing_empty++;
5478 else
5479 trailing_empty = 0;
5480 } else {
5481 dstr = newSVpvn_flags(s, m-s,
5482 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5483 XPUSHs(dstr);
5484 }
a0d0e21e
LW		 5485 s = m;
5486 }
5487 }
07bc277f 5488 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
640f820d
AB		 5489 /*
5490 Pre-extend the stack, either the number of bytes or
5491 characters in the string or a limited amount, triggered by:
5492
5493 my ($x, $y) = split //, $str;
5494 or
5495 split //, $str, $i;
5496 */
c1a7495a
BB		 5497 if (!gimme_scalar) {
5498 const U32 items = limit - 1;
5499 if (items < slen)
5500 EXTEND(SP, items);
5501 else
5502 EXTEND(SP, slen);
5503 }
640f820d 5504
e9515b0f
AB		 5505 if (do_utf8) {
5506 while (--limit) {
5507 /* keep track of how many bytes we skip over */
5508 m = s;
640f820d 5509 s += UTF8SKIP(s);
c1a7495a
BB		 5510 if (gimme_scalar) {
5511 iters++;
5512 if (s-m == 0)
5513 trailing_empty++;
5514 else
5515 trailing_empty = 0;
5516 } else {
5517 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
640f820d 5518
c1a7495a
BB		 5519 PUSHs(dstr);
5520 }
640f820d 5521
e9515b0f
AB		 5522 if (s >= strend)
5523 break;
5524 }
5525 } else {
5526 while (--limit) {
c1a7495a
BB		 5527 if (gimme_scalar) {
5528 iters++;
5529 } else {
5530 dstr = newSVpvn(s, 1);
e9515b0f 5531
e9515b0f 5532
c1a7495a
BB		 5533 if (make_mortal)
5534 sv_2mortal(dstr);
640f820d 5535
c1a7495a
BB		 5536 PUSHs(dstr);
5537 }
5538
5539 s++;
e9515b0f
AB		 5540
5541 if (s >= strend)
5542 break;
5543 }
640f820d
AB		 5544 }
5545 }
3c8556c3 5546 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
07bc277f
NC		 5547 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5548 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5549 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5550 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
f9f4320a 5551 SV * const csv = CALLREG_INTUIT_STRING(rx);
cf93c79d 5552
07bc277f 5553 len = RX_MINLENRET(rx);
3c8556c3 5554 if (len == 1 && !RX_UTF8(rx) && !tail) {
1b6737cc 5555 const char c = *SvPV_nolen_const(csv);
a0d0e21e 5556 while (--limit) {
a6e20a40
AL		 5557 for (m = s; m < strend && *m != c; m++)
5558 ;
a0d0e21e
LW		 5559 if (m >= strend)
5560 break;
c1a7495a
BB		 5561 if (gimme_scalar) {
5562 iters++;
5563 if (m-s == 0)
5564 trailing_empty++;
5565 else
5566 trailing_empty = 0;
5567 } else {
5568 dstr = newSVpvn_flags(s, m-s,
d14578b8 5569 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
c1a7495a
BB		 5570 XPUSHs(dstr);
5571 }
93f04dac
JH		 5572 /* The rx->minlen is in characters but we want to step
5573 * s ahead by bytes. */
1aa99e6b
IH		 5574 if (do_utf8)
5575 s = (char*)utf8_hop((U8*)m, len);
5576 else
5577 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 5578 }
5579 }
5580 else {
a0d0e21e 5581 while (s < strend && --limit &&
f722798b 5582 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
7fba1cd6 5583 csv, multiline ? FBMrf_MULTILINE : 0)) )
a0d0e21e 5584 {
c1a7495a
BB		 5585 if (gimme_scalar) {
5586 iters++;
5587 if (m-s == 0)
5588 trailing_empty++;
5589 else
5590 trailing_empty = 0;
5591 } else {
5592 dstr = newSVpvn_flags(s, m-s,
d14578b8 5593 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
c1a7495a
BB		 5594 XPUSHs(dstr);
5595 }
93f04dac
JH		 5596 /* The rx->minlen is in characters but we want to step
5597 * s ahead by bytes. */
1aa99e6b
IH		 5598 if (do_utf8)
5599 s = (char*)utf8_hop((U8*)m, len);
5600 else
5601 s = m + len; /* Fake \n at the end */
a0d0e21e 5602 }
463ee0b2 5603 }
463ee0b2 5604 }
a0d0e21e 5605 else {
07bc277f 5606 maxiters += slen * RX_NPARENS(rx);
080c2dec 5607 while (s < strend && --limit)
bbce6d69 5608 {
1b6737cc 5609 I32 rex_return;
080c2dec 5610 PUTBACK;
d14578b8 5611 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
c33e64f0 5612 sv, NULL, 0);
080c2dec 5613 SPAGAIN;
1b6737cc 5614 if (rex_return == 0)
080c2dec 5615 break;
d9f97599 5616 TAINT_IF(RX_MATCH_TAINTED(rx));
6502e081
DM		 5617 /* we never pass the REXEC_COPY_STR flag, so it should
5618 * never get copied */
5619 assert(!RX_MATCH_COPIED(rx));
07bc277f 5620 m = RX_OFFS(rx)[0].start + orig;
c1a7495a
BB		 5621
5622 if (gimme_scalar) {
5623 iters++;
5624 if (m-s == 0)
5625 trailing_empty++;
5626 else
5627 trailing_empty = 0;
5628 } else {
5629 dstr = newSVpvn_flags(s, m-s,
5630 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5631 XPUSHs(dstr);
5632 }
07bc277f 5633 if (RX_NPARENS(rx)) {
1b6737cc 5634 I32 i;
07bc277f
NC		 5635 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5636 s = RX_OFFS(rx)[i].start + orig;
5637 m = RX_OFFS(rx)[i].end + orig;
6de67870
JP		 5638
5639 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5640 parens that didn't match -- they should be set to
5641 undef, not the empty string */
c1a7495a
BB		 5642 if (gimme_scalar) {
5643 iters++;
5644 if (m-s == 0)
5645 trailing_empty++;
5646 else
5647 trailing_empty = 0;
5648 } else {
5649 if (m >= orig && s >= orig) {
5650 dstr = newSVpvn_flags(s, m-s,
5651 (do_utf8 ? SVf_UTF8 : 0)
5652 | make_mortal);
5653 }
5654 else
5655 dstr = &PL_sv_undef; /* undef, not "" */
5656 XPUSHs(dstr);
748a9306 5657 }
c1a7495a 5658
a0d0e21e
LW		 5659 }
5660 }
07bc277f 5661 s = RX_OFFS(rx)[0].end + orig;
a0d0e21e 5662 }
79072805 5663 }
8ec5e241 5664
c1a7495a
BB		 5665 if (!gimme_scalar) {
5666 iters = (SP - PL_stack_base) - base;
5667 }
a0d0e21e 5668 if (iters > maxiters)
cea2e8a9 5669 DIE(aTHX_ "Split loop");
8ec5e241 5670
a0d0e21e
LW		 5671 /* keep field after final delim? */
5672 if (s < strend || (iters && origlimit)) {
c1a7495a
BB		 5673 if (!gimme_scalar) {
5674 const STRLEN l = strend - s;
5675 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5676 XPUSHs(dstr);
5677 }
a0d0e21e 5678 iters++;
79072805 5679 }
a0d0e21e 5680 else if (!origlimit) {
c1a7495a
BB		 5681 if (gimme_scalar) {
5682 iters -= trailing_empty;
5683 } else {
5684 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5685 if (TOPs && !make_mortal)
5686 sv_2mortal(TOPs);
5687 *SP-- = &PL_sv_undef;
5688 iters--;
5689 }
89900bd3 5690 }
a0d0e21e 5691 }
8ec5e241 5692
8b7059b1
DM		 5693 PUTBACK;
5694 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5695 SPAGAIN;
a0d0e21e 5696 if (realarray) {
8ec5e241 5697 if (!mg) {
1c0b011c
NIS		 5698 if (SvSMAGICAL(ary)) {
5699 PUTBACK;
ad64d0ec 5700 mg_set(MUTABLE_SV(ary));
1c0b011c
NIS		 5701 SPAGAIN;
5702 }
5703 if (gimme == G_ARRAY) {
5704 EXTEND(SP, iters);
5705 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5706 SP += iters;
5707 RETURN;
5708 }
8ec5e241 5709 }
1c0b011c 5710 else {
fb73857a 5711 PUTBACK;
d343c3ef 5712 ENTER_with_name("call_PUSH");
36925d9e 5713 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5714 LEAVE_with_name("call_PUSH");
fb73857a 5715 SPAGAIN;
8ec5e241 5716 if (gimme == G_ARRAY) {
1b6737cc 5717 I32 i;
8ec5e241
NIS		 5718 /* EXTEND should not be needed - we just popped them */
5719 EXTEND(SP, iters);
5720 for (i=0; i < iters; i++) {
5721 SV **svp = av_fetch(ary, i, FALSE);
3280af22 5722 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 5723 }
1c0b011c
NIS		 5724 RETURN;
5725 }
a0d0e21e
LW		 5726 }
5727 }
5728 else {
5729 if (gimme == G_ARRAY)
5730 RETURN;
5731 }
7f18b612
YST		 5732
5733 GETTARGET;
5734 PUSHi(iters);
5735 RETURN;
79072805 5736}
85e6fe83 5737
c5917253
NC		 5738PP(pp_once)
5739{
5740 dSP;
5741 SV *const sv = PAD_SVl(PL_op->op_targ);
5742
5743 if (SvPADSTALE(sv)) {
5744 /* First time. */
5745 SvPADSTALE_off(sv);
5746 RETURNOP(cLOGOP->op_other);
5747 }
5748 RETURNOP(cLOGOP->op_next);
5749}
5750
c0329465
MB		 5751PP(pp_lock)
5752{
97aff369 5753 dVAR;
39644a26 5754 dSP;
c0329465 5755 dTOPss;
e55aaa0e 5756 SV *retsv = sv;
68795e93 5757 SvLOCK(sv);
f79aa60b
FC		 5758 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5759 || SvTYPE(retsv) == SVt_PVCV) {
e55aaa0e
MB		 5760 retsv = refto(retsv);
5761 }
5762 SETs(retsv);
c0329465
MB		 5763 RETURN;
5764}
a863c7d1 5765
65bca31a
NC		 5766
5767PP(unimplemented_op)
5768{
97aff369 5769 dVAR;
361ed549
NC		 5770 const Optype op_type = PL_op->op_type;
5771 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5772 with out of range op numbers - it only "special" cases op_custom.
5773 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5774 if we get here for a custom op then that means that the custom op didn't
5775 have an implementation. Given that OP_NAME() looks up the custom op
5776 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5777 registers &PL_unimplemented_op as the address of their custom op.
5778 NULL doesn't generate a useful error message. "custom" does. */
5779 const char *const name = op_type >= OP_max
5780 ? "[out of range]" : PL_op_name[PL_op->op_type];
7627e6d0
NC		 5781 if(OP_IS_SOCKET(op_type))
5782 DIE(aTHX_ PL_no_sock_func, name);
361ed549 5783 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
65bca31a
NC		 5784}
5785
deb8a388
FC		 5786/* For sorting out arguments passed to a &CORE:: subroutine */
5787PP(pp_coreargs)
5788{
5789 dSP;
7fa5bd9b 5790 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
498a02d8 5791 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
7fa5bd9b 5792 AV * const at_ = GvAV(PL_defgv);
0e80230d
FC		 5793 SV **svp = at_ ? AvARRAY(at_) : NULL;
5794 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
7fa5bd9b 5795 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
46e00a91 5796 bool seen_question = 0;
7fa5bd9b 5797 const char *err = NULL;
3e6568b4 5798 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
7fa5bd9b 5799
46e00a91
FC		 5800 /* Count how many args there are first, to get some idea how far to
5801 extend the stack. */
7fa5bd9b 5802 while (oa) {
bf0571fd 5803 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
7fa5bd9b 5804 maxargs++;
46e00a91
FC		 5805 if (oa & OA_OPTIONAL) seen_question = 1;
5806 if (!seen_question) minargs++;
7fa5bd9b
FC		 5807 oa >>= 4;
5808 }
5809
5810 if(numargs < minargs) err = "Not enough";
5811 else if(numargs > maxargs) err = "Too many";
5812 if (err)
5813 /* diag_listed_as: Too many arguments for %s */
5814 Perl_croak(aTHX_
5815 "%s arguments for %s", err,
2a90c7c6 5816 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
7fa5bd9b
FC		 5817 );
5818
5819 /* Reset the stack pointer. Without this, we end up returning our own
5820 arguments in list context, in addition to the values we are supposed
5821 to return. nextstate usually does this on sub entry, but we need
e1fa07e3 5822 to run the next op with the caller's hints, so we cannot have a
7fa5bd9b
FC		 5823 nextstate. */
5824 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5825
46e00a91
FC		 5826 if(!maxargs) RETURN;
5827
bf0571fd
FC		 5828 /* We do this here, rather than with a separate pushmark op, as it has
5829 to come in between two things this function does (stack reset and
5830 arg pushing). This seems the easiest way to do it. */
3e6568b4 5831 if (pushmark) {
bf0571fd
FC		 5832 PUTBACK;
5833 (void)Perl_pp_pushmark(aTHX);
5834 }
5835
5836 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
c931b036 5837 PUTBACK; /* The code below can die in various places. */
46e00a91
FC		 5838
5839 oa = PL_opargs[opnum] >> OASHIFT;
3e6568b4 5840 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
c931b036 5841 whicharg++;
46e00a91
FC		 5842 switch (oa & 7) {
5843 case OA_SCALAR:
1efec5ed 5844 try_defsv:
d6d78e19 5845 if (!numargs && defgv && whicharg == minargs + 1) {
d6d78e19 5846 PUSHs(find_rundefsv2(
db4cf31d 5847 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
b4b0692a 5848 cxstack[cxstack_ix].blk_oldcop->cop_seq
d6d78e19
FC		 5849 ));
5850 }
5851 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
46e00a91 5852 break;
bf0571fd
FC		 5853 case OA_LIST:
5854 while (numargs--) {
5855 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5856 svp++;
5857 }
5858 RETURN;
19c481f4
FC		 5859 case OA_HVREF:
5860 if (!svp || !*svp || !SvROK(*svp)
5861 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5862 DIE(aTHX_
5863 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5864 "Type of arg %d to &CORE::%s must be hash reference",
5865 whicharg, OP_DESC(PL_op->op_next)
5866 );
5867 PUSHs(SvRV(*svp));
5868 break;
c931b036 5869 case OA_FILEREF:
30901a8a
FC		 5870 if (!numargs) PUSHs(NULL);
5871 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
c931b036
FC		 5872 /* no magic here, as the prototype will have added an extra
5873 refgen and we just want what was there before that */
5874 PUSHs(SvRV(*svp));
5875 else {
5876 const bool constr = PL_op->op_private & whicharg;
5877 PUSHs(S_rv2gv(aTHX_
5878 svp && *svp ? *svp : &PL_sv_undef,
5879 constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5880 !constr
5881 ));
5882 }
5883 break;
c72a5629 5884 case OA_SCALARREF:
1efec5ed
FC		 5885 if (!numargs) goto try_defsv;
5886 else {
17008668
FC		 5887 const bool wantscalar =
5888 PL_op->op_private & OPpCOREARGS_SCALARMOD;
c72a5629 5889 if (!svp || !*svp || !SvROK(*svp)
17008668
FC		 5890 /* We have to permit globrefs even for the \$ proto, as
5891 *foo is indistinguishable from ${\*foo}, and the proto-
5892 type permits the latter. */
5893 || SvTYPE(SvRV(*svp)) > (
efe889ae 5894 wantscalar ? SVt_PVLV
46bef06f
FC		 5895 : opnum == OP_LOCK || opnum == OP_UNDEF
5896 ? SVt_PVCV
efe889ae 5897 : SVt_PVHV
17008668 5898 )
c72a5629
FC		 5899 )
5900 DIE(aTHX_
5901 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
17008668 5902 "Type of arg %d to &CORE::%s must be %s",
46bef06f 5903 whicharg, PL_op_name[opnum],
17008668
FC		 5904 wantscalar
5905 ? "scalar reference"
46bef06f 5906 : opnum == OP_LOCK || opnum == OP_UNDEF
efe889ae
FC		 5907 ? "reference to one of [$@%&*]"
5908 : "reference to one of [$@%*]"
c72a5629
FC		 5909 );
5910 PUSHs(SvRV(*svp));
88bb468b
FC		 5911 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
5912 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
5913 /* Undo @_ localisation, so that sub exit does not undo
5914 part of our undeffing. */
5915 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
5916 POP_SAVEARRAY();
5917 cx->cx_type &= ~ CXp_HASARGS;
5918 assert(!AvREAL(cx->blk_sub.argarray));
5919 }
17008668 5920 }
1efec5ed 5921 break;
46e00a91 5922 default:
46e00a91
FC		 5923 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
5924 }
5925 oa = oa >> 4;
5926 }
5927
deb8a388
FC		 5928 RETURN;
5929}
5930
84ed0108
FC		 5931PP(pp_runcv)
5932{
5933 dSP;
5934 CV *cv;
5935 if (PL_op->op_private & OPpOFFBYONE) {
db4cf31d 5936 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
84ed0108
FC		 5937 }
5938 else cv = find_runcv(NULL);
e157a82b 5939 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
84ed0108
FC		 5940 RETURN;
5941}
5942
5943
e609e586
NC		 5944/*
5945 * Local variables:
5946 * c-indentation-style: bsd
5947 * c-basic-offset: 4
14d04a33 5948 * indent-tabs-mode: nil
e609e586
NC		 5949 * End:
5950 *
14d04a33 5951 * ex: set ts=8 sts=4 sw=4 et:
37442d52 5952 */
Unnamed repository; edit this file 'description' to name the repository.