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