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