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