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
perluniprops: Remove Unicode db files section
[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
KW		 3433/* Below are several macros that generate code */
3434/* Generates code to store a unicode codepoint c that is known to occupy
3435 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3436#define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
3437 STMT_START { \
3438 *(p) = UTF8_TWO_BYTE_HI(c); \
3439 *((p)+1) = UTF8_TWO_BYTE_LO(c); \
3440 } STMT_END
3441
3442/* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3443 * available byte after the two bytes */
3444#define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3445 STMT_START { \
3446 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3447 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3448 } STMT_END
3449
3450/* Generates code to store the upper case of latin1 character l which is known
3451 * to have its upper case be non-latin1 into the two bytes p and p+1. There
3452 * are only two characters that fit this description, and this macro knows
3453 * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3454 * bytes */
3455#define STORE_NON_LATIN1_UC(p, l) \
3456STMT_START { \
3457 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3458 STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3459 } else { /* Must be the following letter */ \
3460 STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3461 } \
3462} STMT_END
3463
3464/* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3465 * after the character stored */
3466#define CAT_NON_LATIN1_UC(p, l) \
3467STMT_START { \
3468 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3469 CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3470 } else { \
3471 CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3472 } \
3473} STMT_END
3474
3475/* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3476 * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
3477 * and must require two bytes to store it. Advances p to point to the next
3478 * available position */
3479#define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
3480STMT_START { \
3481 if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3482 CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3483 } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
3484 *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
3485 } else {/* else is one of the other two special cases */ \
3486 CAT_NON_LATIN1_UC((p), (l)); \
3487 } \
3488} STMT_END
3489
79072805
LW		 3490PP(pp_ucfirst)
3491{
00f254e2
KW		 3492 /* Actually is both lcfirst() and ucfirst(). Only the first character
3493 * changes. This means that possibly we can change in-place, ie., just
3494 * take the source and change that one character and store it back, but not
3495 * if read-only etc, or if the length changes */
3496
97aff369 3497 dVAR;
39644a26 3498 dSP;
d54190f6 3499 SV *source = TOPs;
00f254e2 3500 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC		 3501 STRLEN need;
3502 SV *dest;
00f254e2
KW		 3503 bool inplace; /* ? Convert first char only, in-place */
3504 bool doing_utf8 = FALSE; /* ? using utf8 */
3505 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3506 const int op_type = PL_op->op_type;
d54190f6
NC		 3507 const U8 *s;
3508 U8 *d;
3509 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW		 3510 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3511 * stored as UTF-8 at s. */
3512 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3513 * lowercased) character stored in tmpbuf. May be either
3514 * UTF-8 or not, but in either case is the number of bytes */
d54190f6
NC		 3515
3516 SvGETMAGIC(source);
3517 if (SvOK(source)) {
3518 s = (const U8*)SvPV_nomg_const(source, slen);
3519 } else {
0a0ffbce
RGS		 3520 if (ckWARN(WARN_UNINITIALIZED))
3521 report_uninit(source);
1eced8f8 3522 s = (const U8*)"";
d54190f6
NC		 3523 slen = 0;
3524 }
a0ed51b3 3525
00f254e2
KW		 3526 /* We may be able to get away with changing only the first character, in
3527 * place, but not if read-only, etc. Later we may discover more reasons to
3528 * not convert in-place. */
3529 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3530
3531 /* First calculate what the changed first character should be. This affects
3532 * whether we can just swap it out, leaving the rest of the string unchanged,
3533 * or even if have to convert the dest to UTF-8 when the source isn't */
3534
3535 if (! slen) { /* If empty */
3536 need = 1; /* still need a trailing NUL */
3537 }
3538 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3539 doing_utf8 = TRUE;
00f254e2 3540
00f254e2
KW		 3541 if (UTF8_IS_INVARIANT(*s)) {
3542
3543 /* An invariant source character is either ASCII or, in EBCDIC, an
3544 * ASCII equivalent or a caseless C1 control. In both these cases,
3545 * the lower and upper cases of any character are also invariants
3546 * (and title case is the same as upper case). So it is safe to
3547 * use the simple case change macros which avoid the overhead of
3548 * the general functions. Note that if perl were to be extended to
3549 * do locale handling in UTF-8 strings, this wouldn't be true in,
3550 * for example, Lithuanian or Turkic. */
3551 *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3552 tculen = ulen = 1;
3553 need = slen + 1;
12e9c124 3554 }
00f254e2
KW		 3555 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3556 U8 chr;
3557
3558 /* Similarly, if the source character isn't invariant but is in the
3559 * latin1 range (or EBCDIC equivalent thereof), we have the case
3560 * changes compiled into perl, and can avoid the overhead of the
3561 * general functions. In this range, the characters are stored as
3562 * two UTF-8 bytes, and it so happens that any changed-case version
3563 * is also two bytes (in both ASCIIish and EBCDIC machines). */
3564 tculen = ulen = 2;
3565 need = slen + 1;
3566
3567 /* Convert the two source bytes to a single Unicode code point
3568 * value, change case and save for below */
356979f4 3569 chr = TWO_BYTE_UTF8_TO_UNI(*s, *(s+1));
00f254e2
KW		 3570 if (op_type == OP_LCFIRST) { /* lower casing is easy */
3571 U8 lower = toLOWER_LATIN1(chr);
3572 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3573 }
3574 else { /* ucfirst */
3575 U8 upper = toUPPER_LATIN1_MOD(chr);
3576
3577 /* Most of the latin1 range characters are well-behaved. Their
3578 * title and upper cases are the same, and are also in the
3579 * latin1 range. The macro above returns their upper (hence
3580 * title) case, and all that need be done is to save the result
3581 * for below. However, several characters are problematic, and
3582 * have to be handled specially. The MOD in the macro name
3583 * above means that these tricky characters all get mapped to
3584 * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
3585 * This mapping saves some tests for the majority of the
3586 * characters */
3587
3588 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3589
3590 /* Not tricky. Just save it. */
3591 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
3592 }
3593 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
3594
3595 /* This one is tricky because it is two characters long,
3596 * though the UTF-8 is still two bytes, so the stored
3597 * length doesn't change */
3598 *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
3599 *(tmpbuf + 1) = 's';
3600 }
3601 else {
3602
3603 /* The other two have their title and upper cases the same,
3604 * but are tricky because the changed-case characters
3605 * aren't in the latin1 range. They, however, do fit into
3606 * two UTF-8 bytes */
3607 STORE_NON_LATIN1_UC(tmpbuf, chr);
3608 }
3609 }
3610 }
3611 else {
00f254e2
KW		 3612
3613 /* Here, can't short-cut the general case */
3614
3615 utf8_to_uvchr(s, &ulen);
3616 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3617 else toLOWER_utf8(s, tmpbuf, &tculen);
3618
3619 /* we can't do in-place if the length changes. */
3620 if (ulen != tculen) inplace = FALSE;
3621 need = slen + 1 - ulen + tculen;
00f254e2 3622 }
d54190f6 3623 }
00f254e2
KW		 3624 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3625 * latin1 is treated as caseless. Note that a locale takes
3626 * precedence */
3627 tculen = 1; /* Most characters will require one byte, but this will
3628 * need to be overridden for the tricky ones */
3629 need = slen + 1;
3630
3631 if (op_type == OP_LCFIRST) {
d54190f6 3632
00f254e2
KW		 3633 /* lower case the first letter: no trickiness for any character */
3634 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3635 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3636 }
3637 /* is ucfirst() */
3638 else if (IN_LOCALE_RUNTIME) {
3639 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3640 * have upper and title case different
3641 */
3642 }
3643 else if (! IN_UNI_8_BIT) {
3644 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3645 * on EBCDIC machines whatever the
3646 * native function does */
3647 }
3648 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3649 *tmpbuf = toUPPER_LATIN1_MOD(*s);
3650
3651 /* tmpbuf now has the correct title case for all latin1 characters
3652 * except for the several ones that have tricky handling. All
3653 * of these are mapped by the MOD to the letter below. */
3654 if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3655
3656 /* The length is going to change, with all three of these, so
3657 * can't replace just the first character */
3658 inplace = FALSE;
3659
3660 /* We use the original to distinguish between these tricky
3661 * cases */
3662 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3663 /* Two character title case 'Ss', but can remain non-UTF-8 */
3664 need = slen + 2;
3665 *tmpbuf = 'S';
3666 *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
3667 tculen = 2;
3668 }
3669 else {
d54190f6 3670
00f254e2
KW		 3671 /* The other two tricky ones have their title case outside
3672 * latin1. It is the same as their upper case. */
3673 doing_utf8 = TRUE;
3674 STORE_NON_LATIN1_UC(tmpbuf, *s);
3675
3676 /* The UTF-8 and UTF-EBCDIC lengths of both these characters
3677 * and their upper cases is 2. */
3678 tculen = ulen = 2;
3679
3680 /* The entire result will have to be in UTF-8. Assume worst
3681 * case sizing in conversion. (all latin1 characters occupy
3682 * at most two bytes in utf8) */
3683 convert_source_to_utf8 = TRUE;
3684 need = slen * 2 + 1;
3685 }
3686 } /* End of is one of the three special chars */
3687 } /* End of use Unicode (Latin1) semantics */
3688 } /* End of changing the case of the first character */
3689
3690 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3691 * generate the result */
3692 if (inplace) {
3693
3694 /* We can convert in place. This means we change just the first
3695 * character without disturbing the rest; no need to grow */
d54190f6
NC		 3696 dest = source;
3697 s = d = (U8*)SvPV_force_nomg(source, slen);
3698 } else {
3699 dTARGET;
3700
3701 dest = TARG;
3702
00f254e2
KW		 3703 /* Here, we can't convert in place; we earlier calculated how much
3704 * space we will need, so grow to accommodate that */
d54190f6 3705 SvUPGRADE(dest, SVt_PV);
3b416f41 3706 d = (U8*)SvGROW(dest, need);
d54190f6
NC		 3707 (void)SvPOK_only(dest);
3708
3709 SETs(dest);
d54190f6 3710 }
44bc797b 3711
d54190f6 3712 if (doing_utf8) {
00f254e2
KW		 3713 if (! inplace) {
3714 if (! convert_source_to_utf8) {
3715
3716 /* Here both source and dest are in UTF-8, but have to create
3717 * the entire output. We initialize the result to be the
3718 * title/lower cased first character, and then append the rest
3719 * of the string. */
3720 sv_setpvn(dest, (char*)tmpbuf, tculen);
3721 if (slen > ulen) {
3722 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3723 }
3724 }
3725 else {
3726 const U8 *const send = s + slen;
3727
3728 /* Here the dest needs to be in UTF-8, but the source isn't,
3729 * except we earlier UTF-8'd the first character of the source
3730 * into tmpbuf. First put that into dest, and then append the
3731 * rest of the source, converting it to UTF-8 as we go. */
3732
3733 /* Assert tculen is 2 here because the only two characters that
3734 * get to this part of the code have 2-byte UTF-8 equivalents */
3735 *d++ = *tmpbuf;
3736 *d++ = *(tmpbuf + 1);
3737 s++; /* We have just processed the 1st char */
3738
3739 for (; s < send; s++) {
3740 d = uvchr_to_utf8(d, *s);
3741 }
3742 *d = '\0';
3743 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3744 }
d54190f6 3745 SvUTF8_on(dest);
a0ed51b3 3746 }
00f254e2 3747 else { /* in-place UTF-8. Just overwrite the first character */
d54190f6
NC		 3748 Copy(tmpbuf, d, tculen, U8);
3749 SvCUR_set(dest, need - 1);
a0ed51b3 3750 }
a0ed51b3 3751 }
00f254e2
KW		 3752 else { /* Neither source nor dest are in or need to be UTF-8 */
3753 if (slen) {
2de3dbcc 3754 if (IN_LOCALE_RUNTIME) {
31351b04 3755 TAINT;
d54190f6 3756 SvTAINTED_on(dest);
31351b04 3757 }
00f254e2
KW		 3758 if (inplace) { /* in-place, only need to change the 1st char */
3759 *d = *tmpbuf;
3760 }
3761 else { /* Not in-place */
3762
3763 /* Copy the case-changed character(s) from tmpbuf */
3764 Copy(tmpbuf, d, tculen, U8);
3765 d += tculen - 1; /* Code below expects d to point to final
3766 * character stored */
3767 }
3768 }
3769 else { /* empty source */
3770 /* See bug #39028: Don't taint if empty */
d54190f6
NC		 3771 *d = *s;
3772 }
3773
00f254e2
KW		 3774 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3775 * the destination to retain that flag */
d54190f6
NC		 3776 if (SvUTF8(source))
3777 SvUTF8_on(dest);
3778
00f254e2 3779 if (!inplace) { /* Finish the rest of the string, unchanged */
d54190f6
NC		 3780 /* This will copy the trailing NUL */
3781 Copy(s + 1, d + 1, slen, U8);
3782 SvCUR_set(dest, need - 1);
bbce6d69 3783 }
bbce6d69 3784 }
539689e7
FC		 3785 if (dest != source && SvTAINTED(source))
3786 SvTAINT(dest);
d54190f6 3787 SvSETMAGIC(dest);
79072805
LW		 3788 RETURN;
3789}
3790
67306194
NC		 3791/* There's so much setup/teardown code common between uc and lc, I wonder if
3792 it would be worth merging the two, and just having a switch outside each
00f254e2 3793 of the three tight loops. There is less and less commonality though */
79072805
LW		 3794PP(pp_uc)
3795{
97aff369 3796 dVAR;
39644a26 3797 dSP;
67306194 3798 SV *source = TOPs;
463ee0b2 3799 STRLEN len;
67306194
NC		 3800 STRLEN min;
3801 SV *dest;
3802 const U8 *s;
3803 U8 *d;
79072805 3804
67306194
NC		 3805 SvGETMAGIC(source);
3806
3807 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
00f254e2
KW		 3808 && SvTEMP(source) && !DO_UTF8(source)
3809 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3810
3811 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3812 * make the loop tight, so we overwrite the source with the dest before
3813 * looking at it, and we need to look at the original source
3814 * afterwards. There would also need to be code added to handle
3815 * switching to not in-place in midstream if we run into characters
3816 * that change the length.
3817 */
67306194
NC		 3818 dest = source;
3819 s = d = (U8*)SvPV_force_nomg(source, len);
3820 min = len + 1;
3821 } else {
a0ed51b3 3822 dTARGET;
a0ed51b3 3823
67306194 3824 dest = TARG;
128c9517 3825
67306194
NC		 3826 /* The old implementation would copy source into TARG at this point.
3827 This had the side effect that if source was undef, TARG was now
3828 an undefined SV with PADTMP set, and they don't warn inside
3829 sv_2pv_flags(). However, we're now getting the PV direct from
3830 source, which doesn't have PADTMP set, so it would warn. Hence the
3831 little games. */
3832
3833 if (SvOK(source)) {
3834 s = (const U8*)SvPV_nomg_const(source, len);
3835 } else {
0a0ffbce
RGS		 3836 if (ckWARN(WARN_UNINITIALIZED))
3837 report_uninit(source);
1eced8f8 3838 s = (const U8*)"";
67306194 3839 len = 0;
a0ed51b3 3840 }
67306194
NC		 3841 min = len + 1;
3842
3843 SvUPGRADE(dest, SVt_PV);
3b416f41 3844 d = (U8*)SvGROW(dest, min);
67306194
NC		 3845 (void)SvPOK_only(dest);
3846
3847 SETs(dest);
a0ed51b3 3848 }
31351b04 3849
67306194
NC		 3850 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3851 to check DO_UTF8 again here. */
3852
3853 if (DO_UTF8(source)) {
3854 const U8 *const send = s + len;
3855 U8 tmpbuf[UTF8_MAXBYTES+1];
3856
4c8a458a
KW		 3857 /* All occurrences of these are to be moved to follow any other marks.
3858 * This is context-dependent. We may not be passed enough context to
3859 * move the iota subscript beyond all of them, but we do the best we can
3860 * with what we're given. The result is always better than if we
3861 * hadn't done this. And, the problem would only arise if we are
3862 * passed a character without all its combining marks, which would be
3863 * the caller's mistake. The information this is based on comes from a
3864 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3865 * itself) and so can't be checked properly to see if it ever gets
3866 * revised. But the likelihood of it changing is remote */
00f254e2 3867 bool in_iota_subscript = FALSE;
00f254e2 3868
67306194 3869 while (s < send) {
00f254e2
KW		 3870 if (in_iota_subscript && ! is_utf8_mark(s)) {
3871 /* A non-mark. Time to output the iota subscript */
3872#define GREEK_CAPITAL_LETTER_IOTA 0x0399
3873#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3874
3875 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3876 in_iota_subscript = FALSE;
3877 }
00f254e2 3878
00f254e2
KW		 3879 /* If the UTF-8 character is invariant, then it is in the range
3880 * known by the standard macro; result is only one byte long */
3881 if (UTF8_IS_INVARIANT(*s)) {
3882 *d++ = toUPPER(*s);
3883 s++;
3884 }
3885 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3886
3887 /* Likewise, if it fits in a byte, its case change is in our
3888 * table */
e1a8dbf5 3889 U8 orig = TWO_BYTE_UTF8_TO_UNI(*s, *(s+1));
00f254e2
KW		 3890 U8 upper = toUPPER_LATIN1_MOD(orig);
3891 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
e1a8dbf5 3892 s += 2;
00f254e2
KW		 3893 }
3894 else {
00f254e2
KW		 3895
3896 /* Otherwise, need the general UTF-8 case. Get the changed
3897 * case value and copy it to the output buffer */
3898
3899 const STRLEN u = UTF8SKIP(s);
3900 STRLEN ulen;
67306194 3901
00f254e2 3902 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4c8a458a
KW		 3903 if (uv == GREEK_CAPITAL_LETTER_IOTA
3904 && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3905 {
00f254e2
KW		 3906 in_iota_subscript = TRUE;
3907 }
3908 else {
00f254e2
KW		 3909 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3910 /* If the eventually required minimum size outgrows
3911 * the available space, we need to grow. */
3912 const UV o = d - (U8*)SvPVX_const(dest);
3913
3914 /* If someone uppercases one million U+03B0s we
3915 * SvGROW() one million times. Or we could try
3916 * guessing how much to allocate without allocating too
4c8a458a
KW		 3917 * much. Such is life. See corresponding comment in
3918 * lc code for another option */
00f254e2
KW		 3919 SvGROW(dest, min);
3920 d = (U8*)SvPVX(dest) + o;
3921 }
3922 Copy(tmpbuf, d, ulen, U8);
3923 d += ulen;
00f254e2 3924 }
00f254e2 3925 s += u;
67306194 3926 }
67306194 3927 }
4c8a458a
KW		 3928 if (in_iota_subscript) {
3929 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3930 }
67306194
NC		 3931 SvUTF8_on(dest);
3932 *d = '\0';
3933 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4c8a458a
KW		 3934 }
3935 else { /* Not UTF-8 */
67306194
NC		 3936 if (len) {
3937 const U8 *const send = s + len;
00f254e2
KW		 3938
3939 /* Use locale casing if in locale; regular style if not treating
3940 * latin1 as having case; otherwise the latin1 casing. Do the
3941 * whole thing in a tight loop, for speed, */
2de3dbcc 3942 if (IN_LOCALE_RUNTIME) {
31351b04 3943 TAINT;
67306194
NC		 3944 SvTAINTED_on(dest);
3945 for (; s < send; d++, s++)
3946 *d = toUPPER_LC(*s);
31351b04 3947 }
00f254e2
KW		 3948 else if (! IN_UNI_8_BIT) {
3949 for (; s < send; d++, s++) {
67306194 3950 *d = toUPPER(*s);
00f254e2 3951 }
31351b04 3952 }
00f254e2
KW		 3953 else {
3954 for (; s < send; d++, s++) {
3955 *d = toUPPER_LATIN1_MOD(*s);
3956 if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
3957
3958 /* The mainstream case is the tight loop above. To avoid
3959 * extra tests in that, all three characters that require
3960 * special handling are mapped by the MOD to the one tested
3961 * just above.
3962 * Use the source to distinguish between the three cases */
3963
3964 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3965
3966 /* uc() of this requires 2 characters, but they are
3967 * ASCII. If not enough room, grow the string */
3968 if (SvLEN(dest) < ++min) {
3969 const UV o = d - (U8*)SvPVX_const(dest);
3970 SvGROW(dest, min);
3971 d = (U8*)SvPVX(dest) + o;
3972 }
3973 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3974 continue; /* Back to the tight loop; still in ASCII */
3975 }
3976
3977 /* The other two special handling characters have their
3978 * upper cases outside the latin1 range, hence need to be
3979 * in UTF-8, so the whole result needs to be in UTF-8. So,
3980 * here we are somewhere in the middle of processing a
3981 * non-UTF-8 string, and realize that we will have to convert
3982 * the whole thing to UTF-8. What to do? There are
3983 * several possibilities. The simplest to code is to
3984 * convert what we have so far, set a flag, and continue on
3985 * in the loop. The flag would be tested each time through
3986 * the loop, and if set, the next character would be
3987 * converted to UTF-8 and stored. But, I (khw) didn't want
3988 * to slow down the mainstream case at all for this fairly
3989 * rare case, so I didn't want to add a test that didn't
3990 * absolutely have to be there in the loop, besides the
3991 * possibility that it would get too complicated for
3992 * optimizers to deal with. Another possibility is to just
3993 * give up, convert the source to UTF-8, and restart the
3994 * function that way. Another possibility is to convert
3995 * both what has already been processed and what is yet to
3996 * come separately to UTF-8, then jump into the loop that
3997 * handles UTF-8. But the most efficient time-wise of the
3998 * ones I could think of is what follows, and turned out to
3999 * not require much extra code. */
4000
4001 /* Convert what we have so far into UTF-8, telling the
4002 * function that we know it should be converted, and to
4003 * allow extra space for what we haven't processed yet.
4004 * Assume the worst case space requirements for converting
4005 * what we haven't processed so far: that it will require
4006 * two bytes for each remaining source character, plus the
4007 * NUL at the end. This may cause the string pointer to
4008 * move, so re-find it. */
4009
4010 len = d - (U8*)SvPVX_const(dest);
4011 SvCUR_set(dest, len);
4012 len = sv_utf8_upgrade_flags_grow(dest,
4013 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4014 (send -s) * 2 + 1);
4015 d = (U8*)SvPVX(dest) + len;
4016
4017 /* And append the current character's upper case in UTF-8 */
4018 CAT_NON_LATIN1_UC(d, *s);
4019
4020 /* Now process the remainder of the source, converting to
4021 * upper and UTF-8. If a resulting byte is invariant in
4022 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4023 * append it to the output. */
4024
4025 s++;
4026 for (; s < send; s++) {
4027 U8 upper = toUPPER_LATIN1_MOD(*s);
4028 if UTF8_IS_INVARIANT(upper) {
4029 *d++ = upper;
4030 }
4031 else {
4032 CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4033 }
4034 }
4035
4036 /* Here have processed the whole source; no need to continue
4037 * with the outer loop. Each character has been converted
4038 * to upper case and converted to UTF-8 */
4039
4040 break;
4041 } /* End of processing all latin1-style chars */
4042 } /* End of processing all chars */
4043 } /* End of source is not empty */
4044
67306194 4045 if (source != dest) {
00f254e2 4046 *d = '\0'; /* Here d points to 1 after last char, add NUL */
67306194
NC		 4047 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4048 }
00f254e2 4049 } /* End of isn't utf8 */
539689e7
FC		 4050 if (dest != source && SvTAINTED(source))
4051 SvTAINT(dest);
67306194 4052 SvSETMAGIC(dest);
79072805
LW		 4053 RETURN;
4054}
4055
4056PP(pp_lc)
4057{
97aff369 4058 dVAR;
39644a26 4059 dSP;
ec9af7d4 4060 SV *source = TOPs;
463ee0b2 4061 STRLEN len;
ec9af7d4
NC		 4062 STRLEN min;
4063 SV *dest;
4064 const U8 *s;
4065 U8 *d;
79072805 4066
ec9af7d4
NC		 4067 SvGETMAGIC(source);
4068
4069 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
17fa0776 4070 && SvTEMP(source) && !DO_UTF8(source)) {
ec9af7d4 4071
00f254e2
KW		 4072 /* We can convert in place, as lowercasing anything in the latin1 range
4073 * (or else DO_UTF8 would have been on) doesn't lengthen it */
ec9af7d4
NC		 4074 dest = source;
4075 s = d = (U8*)SvPV_force_nomg(source, len);
4076 min = len + 1;
4077 } else {
a0ed51b3 4078 dTARGET;
a0ed51b3 4079
ec9af7d4
NC		 4080 dest = TARG;
4081
4082 /* The old implementation would copy source into TARG at this point.
4083 This had the side effect that if source was undef, TARG was now
4084 an undefined SV with PADTMP set, and they don't warn inside
4085 sv_2pv_flags(). However, we're now getting the PV direct from
4086 source, which doesn't have PADTMP set, so it would warn. Hence the
4087 little games. */
4088
4089 if (SvOK(source)) {
4090 s = (const U8*)SvPV_nomg_const(source, len);
4091 } else {
0a0ffbce
RGS		 4092 if (ckWARN(WARN_UNINITIALIZED))
4093 report_uninit(source);
1eced8f8 4094 s = (const U8*)"";
ec9af7d4 4095 len = 0;
a0ed51b3 4096 }
ec9af7d4 4097 min = len + 1;
128c9517 4098
ec9af7d4 4099 SvUPGRADE(dest, SVt_PV);
3b416f41 4100 d = (U8*)SvGROW(dest, min);
ec9af7d4
NC		 4101 (void)SvPOK_only(dest);
4102
4103 SETs(dest);
4104 }
4105
4106 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4107 to check DO_UTF8 again here. */
4108
4109 if (DO_UTF8(source)) {
4110 const U8 *const send = s + len;
4111 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4112
4113 while (s < send) {
00f254e2 4114 if (UTF8_IS_INVARIANT(*s)) {
89ebb4a3 4115
00f254e2 4116 /* Invariant characters use the standard mappings compiled in.
ec9af7d4 4117 */
00f254e2
KW		 4118 *d++ = toLOWER(*s);
4119 s++;
ec9af7d4 4120 }
00f254e2 4121 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
89ebb4a3 4122
00f254e2 4123 /* As do the ones in the Latin1 range */
e1a8dbf5 4124 U8 lower = toLOWER_LATIN1(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1)));
00f254e2 4125 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
e1a8dbf5 4126 s += 2;
a0ed51b3 4127 }
00f254e2 4128 else {
00f254e2
KW		 4129 /* Here, is utf8 not in Latin-1 range, have to go out and get
4130 * the mappings from the tables. */
4131
4132 const STRLEN u = UTF8SKIP(s);
4133 STRLEN ulen;
4134
00f254e2 4135 toLOWER_utf8(s, tmpbuf, &ulen);
00f254e2 4136
86510fb1
KW		 4137 /* Here is where we would do context-sensitive actions. See
4138 * the commit message for this comment for why there isn't any
4139 */
00f254e2 4140
fdb34c52
KW		 4141 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4142
4143 /* If the eventually required minimum size outgrows the
4144 * available space, we need to grow. */
4145 const UV o = d - (U8*)SvPVX_const(dest);
4146
4147 /* If someone lowercases one million U+0130s we SvGROW()
4148 * one million times. Or we could try guessing how much to
4149 * allocate without allocating too much. Such is life.
4150 * Another option would be to grow an extra byte or two
4151 * more each time we need to grow, which would cut down the
4152 * million to 500K, with little waste */
4153 SvGROW(dest, min);
4154 d = (U8*)SvPVX(dest) + o;
4155 }
86510fb1 4156
00f254e2
KW		 4157 /* Copy the newly lowercased letter to the output buffer we're
4158 * building */
4159 Copy(tmpbuf, d, ulen, U8);
4160 d += ulen;
4161 s += u;
00f254e2 4162 }
00f254e2 4163 } /* End of looping through the source string */
ec9af7d4
NC		 4164 SvUTF8_on(dest);
4165 *d = '\0';
4166 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
00f254e2 4167 } else { /* Not utf8 */
31351b04 4168 if (len) {
ec9af7d4 4169 const U8 *const send = s + len;
00f254e2
KW		 4170
4171 /* Use locale casing if in locale; regular style if not treating
4172 * latin1 as having case; otherwise the latin1 casing. Do the
4173 * whole thing in a tight loop, for speed, */
2de3dbcc 4174 if (IN_LOCALE_RUNTIME) {
31351b04 4175 TAINT;
ec9af7d4
NC		 4176 SvTAINTED_on(dest);
4177 for (; s < send; d++, s++)
4178 *d = toLOWER_LC(*s);
31351b04 4179 }
00f254e2
KW		 4180 else if (! IN_UNI_8_BIT) {
4181 for (; s < send; d++, s++) {
ec9af7d4 4182 *d = toLOWER(*s);
00f254e2
KW		 4183 }
4184 }
4185 else {
4186 for (; s < send; d++, s++) {
4187 *d = toLOWER_LATIN1(*s);
4188 }
31351b04 4189 }
bbce6d69 4190 }
ec9af7d4
NC		 4191 if (source != dest) {
4192 *d = '\0';
4193 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4194 }
79072805 4195 }
539689e7
FC		 4196 if (dest != source && SvTAINTED(source))
4197 SvTAINT(dest);
ec9af7d4 4198 SvSETMAGIC(dest);
79072805
LW		 4199 RETURN;
4200}
4201
a0d0e21e 4202PP(pp_quotemeta)
79072805 4203{
97aff369 4204 dVAR; dSP; dTARGET;
1b6737cc 4205 SV * const sv = TOPs;
a0d0e21e 4206 STRLEN len;
0d46e09a 4207 register const char *s = SvPV_const(sv,len);
79072805 4208
7e2040f0 4209 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4210 if (len) {
1b6737cc 4211 register char *d;
862a34c6 4212 SvUPGRADE(TARG, SVt_PV);
c07a80fd 4213 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 4214 d = SvPVX(TARG);
7e2040f0 4215 if (DO_UTF8(sv)) {
0dd2cdef 4216 while (len) {
fd400ab9 4217 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW		 4218 STRLEN ulen = UTF8SKIP(s);
4219 if (ulen > len)
4220 ulen = len;
4221 len -= ulen;
4222 while (ulen--)
4223 *d++ = *s++;
4224 }
4225 else {
4226 if (!isALNUM(*s))
4227 *d++ = '\\';
4228 *d++ = *s++;
4229 len--;
4230 }
4231 }
7e2040f0 4232 SvUTF8_on(TARG);
0dd2cdef
LW		 4233 }
4234 else {
4235 while (len--) {
4236 if (!isALNUM(*s))
4237 *d++ = '\\';
4238 *d++ = *s++;
4239 }
79072805 4240 }
a0d0e21e 4241 *d = '\0';
349d4f2f 4242 SvCUR_set(TARG, d - SvPVX_const(TARG));
3aa33fe5 4243 (void)SvPOK_only_UTF8(TARG);
79072805 4244 }
a0d0e21e
LW		 4245 else
4246 sv_setpvn(TARG, s, len);
ec93b65f 4247 SETTARG;
79072805
LW		 4248 RETURN;
4249}
4250
a0d0e21e 4251/* Arrays. */
79072805 4252
a0d0e21e 4253PP(pp_aslice)
79072805 4254{
97aff369 4255 dVAR; dSP; dMARK; dORIGMARK;
502c6561 4256 register AV *const av = MUTABLE_AV(POPs);
1b6737cc 4257 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
79072805 4258
a0d0e21e 4259 if (SvTYPE(av) == SVt_PVAV) {
4ad10a0b
VP		 4260 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4261 bool can_preserve = FALSE;
4262
4263 if (localizing) {
4264 MAGIC *mg;
4265 HV *stash;
4266
4267 can_preserve = SvCANEXISTDELETE(av);
4268 }
4269
4270 if (lval && localizing) {
1b6737cc 4271 register SV **svp;
748a9306 4272 I32 max = -1;
924508f0 4273 for (svp = MARK + 1; svp <= SP; svp++) {
4ea561bc 4274 const I32 elem = SvIV(*svp);
748a9306
LW		 4275 if (elem > max)
4276 max = elem;
4277 }
4278 if (max > AvMAX(av))
4279 av_extend(av, max);
4280 }
4ad10a0b 4281
a0d0e21e 4282 while (++MARK <= SP) {
1b6737cc 4283 register SV **svp;
4ea561bc 4284 I32 elem = SvIV(*MARK);
4ad10a0b 4285 bool preeminent = TRUE;
a0d0e21e 4286
4ad10a0b
VP		 4287 if (localizing && can_preserve) {
4288 /* If we can determine whether the element exist,
4289 * Try to preserve the existenceness of a tied array
4290 * element by using EXISTS and DELETE if possible.
4291 * Fallback to FETCH and STORE otherwise. */
4292 preeminent = av_exists(av, elem);
4293 }
4294
a0d0e21e
LW		 4295 svp = av_fetch(av, elem, lval);
4296 if (lval) {
3280af22 4297 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 4298 DIE(aTHX_ PL_no_aelem, elem);
4ad10a0b
VP		 4299 if (localizing) {
4300 if (preeminent)
4301 save_aelem(av, elem, svp);
4302 else
4303 SAVEADELETE(av, elem);
4304 }
79072805 4305 }
3280af22 4306 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 4307 }
4308 }
748a9306 4309 if (GIMME != G_ARRAY) {
a0d0e21e 4310 MARK = ORIGMARK;
04ab2c87 4311 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e
LW		 4312 SP = MARK;
4313 }
79072805
LW		 4314 RETURN;
4315}
4316
cba5a3b0
DG		 4317/* Smart dereferencing for keys, values and each */
4318PP(pp_rkeys)
4319{
4320 dVAR;
4321 dSP;
4322 dPOPss;
4323
7ac5715b
FC		 4324 SvGETMAGIC(sv);
4325
4326 if (
4327 !SvROK(sv)
4328 || (sv = SvRV(sv),
4329 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4330 || SvOBJECT(sv)
4331 )
4332 ) {
4333 DIE(aTHX_
4334 "Type of argument to %s must be unblessed hashref or arrayref",
4c540399 4335 PL_op_desc[PL_op->op_type] );
cba5a3b0
DG		 4336 }
4337
d8065907
FC		 4338 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4339 DIE(aTHX_
4340 "Can't modify %s in %s",
4341 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4342 );
4343
cba5a3b0
DG		 4344 /* Delegate to correct function for op type */
4345 PUSHs(sv);
4346 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4347 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4348 }
4349 else {
4350 return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4351 }
4352}
4353
878d132a
NC		 4354PP(pp_aeach)
4355{
4356 dVAR;
4357 dSP;
502c6561 4358 AV *array = MUTABLE_AV(POPs);
878d132a 4359 const I32 gimme = GIMME_V;
453d94a9 4360 IV *iterp = Perl_av_iter_p(aTHX_ array);
878d132a
NC		 4361 const IV current = (*iterp)++;
4362
4363 if (current > av_len(array)) {
4364 *iterp = 0;
4365 if (gimme == G_SCALAR)
4366 RETPUSHUNDEF;
4367 else
4368 RETURN;
4369 }
4370
4371 EXTEND(SP, 2);
e1dccc0d 4372 mPUSHi(current);
878d132a
NC		 4373 if (gimme == G_ARRAY) {
4374 SV **const element = av_fetch(array, current, 0);
4375 PUSHs(element ? *element : &PL_sv_undef);
4376 }
4377 RETURN;
4378}
4379
4380PP(pp_akeys)
4381{
4382 dVAR;
4383 dSP;
502c6561 4384 AV *array = MUTABLE_AV(POPs);
878d132a
NC		 4385 const I32 gimme = GIMME_V;
4386
4387 *Perl_av_iter_p(aTHX_ array) = 0;
4388
4389 if (gimme == G_SCALAR) {
4390 dTARGET;
4391 PUSHi(av_len(array) + 1);
4392 }
4393 else if (gimme == G_ARRAY) {
4394 IV n = Perl_av_len(aTHX_ array);
e1dccc0d 4395 IV i;
878d132a
NC		 4396
4397 EXTEND(SP, n + 1);
4398
cba5a3b0 4399 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
e1dccc0d 4400 for (i = 0; i <= n; i++) {
878d132a
NC		 4401 mPUSHi(i);
4402 }
4403 }
4404 else {
4405 for (i = 0; i <= n; i++) {
4406 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4407 PUSHs(elem ? *elem : &PL_sv_undef);
4408 }
4409 }
4410 }
4411 RETURN;
4412}
4413
79072805
LW		 4414/* Associative arrays. */
4415
4416PP(pp_each)
4417{
97aff369 4418 dVAR;
39644a26 4419 dSP;
85fbaab2 4420 HV * hash = MUTABLE_HV(POPs);
c07a80fd 4421 HE *entry;
f54cb97a 4422 const I32 gimme = GIMME_V;
8ec5e241 4423
c07a80fd 4424 PUTBACK;
c750a3ec 4425 /* might clobber stack_sp */
6d822dc4 4426 entry = hv_iternext(hash);
c07a80fd 4427 SPAGAIN;
79072805 4428
79072805
LW		 4429 EXTEND(SP, 2);
4430 if (entry) {
1b6737cc 4431 SV* const sv = hv_iterkeysv(entry);
574c8022 4432 PUSHs(sv); /* won't clobber stack_sp */
54310121 4433 if (gimme == G_ARRAY) {
59af0135 4434 SV *val;
c07a80fd 4435 PUTBACK;
c750a3ec 4436 /* might clobber stack_sp */
6d822dc4 4437 val = hv_iterval(hash, entry);
c07a80fd 4438 SPAGAIN;
59af0135 4439 PUSHs(val);
79072805 4440 }
79072805 4441 }
54310121 4442 else if (gimme == G_SCALAR)
79072805
LW		 4443 RETPUSHUNDEF;
4444
4445 RETURN;
4446}
4447
7332a6c4
VP		 4448STATIC OP *
4449S_do_delete_local(pTHX)
79072805 4450{
97aff369 4451 dVAR;
39644a26 4452 dSP;
f54cb97a 4453 const I32 gimme = GIMME_V;
7332a6c4
VP		 4454 const MAGIC *mg;
4455 HV *stash;
4456
4457 if (PL_op->op_private & OPpSLICE) {
4458 dMARK; dORIGMARK;
4459 SV * const osv = POPs;
4460 const bool tied = SvRMAGICAL(osv)
4461 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4462 const bool can_preserve = SvCANEXISTDELETE(osv)
4463 || mg_find((const SV *)osv, PERL_MAGIC_env);
4464 const U32 type = SvTYPE(osv);
4465 if (type == SVt_PVHV) { /* hash element */
4466 HV * const hv = MUTABLE_HV(osv);
4467 while (++MARK <= SP) {
4468 SV * const keysv = *MARK;
4469 SV *sv = NULL;
4470 bool preeminent = TRUE;
4471 if (can_preserve)
4472 preeminent = hv_exists_ent(hv, keysv, 0);
4473 if (tied) {
4474 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4475 if (he)
4476 sv = HeVAL(he);
4477 else
4478 preeminent = FALSE;
4479 }
4480 else {
4481 sv = hv_delete_ent(hv, keysv, 0, 0);
4482 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4483 }
4484 if (preeminent) {
4485 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4486 if (tied) {
4487 *MARK = sv_mortalcopy(sv);
4488 mg_clear(sv);
4489 } else
4490 *MARK = sv;
4491 }
4492 else {
4493 SAVEHDELETE(hv, keysv);
4494 *MARK = &PL_sv_undef;
4495 }
4496 }
4497 }
4498 else if (type == SVt_PVAV) { /* array element */
4499 if (PL_op->op_flags & OPf_SPECIAL) {
4500 AV * const av = MUTABLE_AV(osv);
4501 while (++MARK <= SP) {
4502 I32 idx = SvIV(*MARK);
4503 SV *sv = NULL;
4504 bool preeminent = TRUE;
4505 if (can_preserve)
4506 preeminent = av_exists(av, idx);
4507 if (tied) {
4508 SV **svp = av_fetch(av, idx, 1);
4509 if (svp)
4510 sv = *svp;
4511 else
4512 preeminent = FALSE;
4513 }
4514 else {
4515 sv = av_delete(av, idx, 0);
4516 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4517 }
4518 if (preeminent) {
4519 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4520 if (tied) {
4521 *MARK = sv_mortalcopy(sv);
4522 mg_clear(sv);
4523 } else
4524 *MARK = sv;
4525 }
4526 else {
4527 SAVEADELETE(av, idx);
4528 *MARK = &PL_sv_undef;
4529 }
4530 }
4531 }
4532 }
4533 else
4534 DIE(aTHX_ "Not a HASH reference");
4535 if (gimme == G_VOID)
4536 SP = ORIGMARK;
4537 else if (gimme == G_SCALAR) {
4538 MARK = ORIGMARK;
4539 if (SP > MARK)
4540 *++MARK = *SP;
4541 else
4542 *++MARK = &PL_sv_undef;
4543 SP = MARK;
4544 }
4545 }
4546 else {
4547 SV * const keysv = POPs;
4548 SV * const osv = POPs;
4549 const bool tied = SvRMAGICAL(osv)
4550 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4551 const bool can_preserve = SvCANEXISTDELETE(osv)
4552 || mg_find((const SV *)osv, PERL_MAGIC_env);
4553 const U32 type = SvTYPE(osv);
4554 SV *sv = NULL;
4555 if (type == SVt_PVHV) {
4556 HV * const hv = MUTABLE_HV(osv);
4557 bool preeminent = TRUE;
4558 if (can_preserve)
4559 preeminent = hv_exists_ent(hv, keysv, 0);
4560 if (tied) {
4561 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4562 if (he)
4563 sv = HeVAL(he);
4564 else
4565 preeminent = FALSE;
4566 }
4567 else {
4568 sv = hv_delete_ent(hv, keysv, 0, 0);
4569 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4570 }
4571 if (preeminent) {
4572 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4573 if (tied) {
4574 SV *nsv = sv_mortalcopy(sv);
4575 mg_clear(sv);
4576 sv = nsv;
4577 }
4578 }
4579 else
4580 SAVEHDELETE(hv, keysv);
4581 }
4582 else if (type == SVt_PVAV) {
4583 if (PL_op->op_flags & OPf_SPECIAL) {
4584 AV * const av = MUTABLE_AV(osv);
4585 I32 idx = SvIV(keysv);
4586 bool preeminent = TRUE;
4587 if (can_preserve)
4588 preeminent = av_exists(av, idx);
4589 if (tied) {
4590 SV **svp = av_fetch(av, idx, 1);
4591 if (svp)
4592 sv = *svp;
4593 else
4594 preeminent = FALSE;
4595 }
4596 else {
4597 sv = av_delete(av, idx, 0);
4598 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4599 }
4600 if (preeminent) {
4601 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4602 if (tied) {
4603 SV *nsv = sv_mortalcopy(sv);
4604 mg_clear(sv);
4605 sv = nsv;
4606 }
4607 }
4608 else
4609 SAVEADELETE(av, idx);
4610 }
4611 else
4612 DIE(aTHX_ "panic: avhv_delete no longer supported");
4613 }
4614 else
4615 DIE(aTHX_ "Not a HASH reference");
4616 if (!sv)
4617 sv = &PL_sv_undef;
4618 if (gimme != G_VOID)
4619 PUSHs(sv);
4620 }
4621
4622 RETURN;
4623}
4624
4625PP(pp_delete)
4626{
4627 dVAR;
4628 dSP;
4629 I32 gimme;
4630 I32 discard;
4631
4632 if (PL_op->op_private & OPpLVAL_INTRO)
4633 return do_delete_local();
4634
4635 gimme = GIMME_V;
4636 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5f05dabc 4637
533c011a 4638 if (PL_op->op_private & OPpSLICE) {
5f05dabc 4639 dMARK; dORIGMARK;
85fbaab2 4640 HV * const hv = MUTABLE_HV(POPs);
1b6737cc 4641 const U32 hvtype = SvTYPE(hv);
01020589
GS		 4642 if (hvtype == SVt_PVHV) { /* hash element */
4643 while (++MARK <= SP) {
1b6737cc 4644 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 4645 *MARK = sv ? sv : &PL_sv_undef;
4646 }
5f05dabc 4647 }
6d822dc4
MS		 4648 else if (hvtype == SVt_PVAV) { /* array element */
4649 if (PL_op->op_flags & OPf_SPECIAL) {
4650 while (++MARK <= SP) {
502c6561 4651 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
6d822dc4
MS		 4652 *MARK = sv ? sv : &PL_sv_undef;
4653 }
4654 }
01020589
GS		 4655 }
4656 else
4657 DIE(aTHX_ "Not a HASH reference");
54310121 4658 if (discard)
4659 SP = ORIGMARK;
4660 else if (gimme == G_SCALAR) {
5f05dabc 4661 MARK = ORIGMARK;
9111c9c0
DM		 4662 if (SP > MARK)
4663 *++MARK = *SP;
4664 else
4665 *++MARK = &PL_sv_undef;
5f05dabc 4666 SP = MARK;
4667 }
4668 }
4669 else {
4670 SV *keysv = POPs;
85fbaab2 4671 HV * const hv = MUTABLE_HV(POPs);
295d248e 4672 SV *sv = NULL;
97fcbf96
MB		 4673 if (SvTYPE(hv) == SVt_PVHV)
4674 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 4675 else if (SvTYPE(hv) == SVt_PVAV) {
4676 if (PL_op->op_flags & OPf_SPECIAL)
502c6561 4677 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
af288a60
HS		 4678 else
4679 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 4680 }
97fcbf96 4681 else
cea2e8a9 4682 DIE(aTHX_ "Not a HASH reference");
5f05dabc 4683 if (!sv)
3280af22 4684 sv = &PL_sv_undef;
54310121 4685 if (!discard)
4686 PUSHs(sv);
79072805 4687 }
79072805
LW		 4688 RETURN;
4689}
4690
a0d0e21e 4691PP(pp_exists)
79072805 4692{
97aff369 4693 dVAR;
39644a26 4694 dSP;
afebc493
GS		 4695 SV *tmpsv;
4696 HV *hv;
4697
4698 if (PL_op->op_private & OPpEXISTS_SUB) {
4699 GV *gv;
0bd48802 4700 SV * const sv = POPs;
f2c0649b 4701 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
afebc493
GS		 4702 if (cv)
4703 RETPUSHYES;
4704 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4705 RETPUSHYES;
4706 RETPUSHNO;
4707 }
4708 tmpsv = POPs;
85fbaab2 4709 hv = MUTABLE_HV(POPs);
c750a3ec 4710 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 4711 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 4712 RETPUSHYES;
ef54e1a4
JH		 4713 }
4714 else if (SvTYPE(hv) == SVt_PVAV) {
01020589 4715 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
502c6561 4716 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
01020589
GS		 4717 RETPUSHYES;
4718 }
ef54e1a4
JH		 4719 }
4720 else {
cea2e8a9 4721 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 4722 }
a0d0e21e
LW		 4723 RETPUSHNO;
4724}
79072805 4725
a0d0e21e
LW		 4726PP(pp_hslice)
4727{
97aff369 4728 dVAR; dSP; dMARK; dORIGMARK;
85fbaab2 4729 register HV * const hv = MUTABLE_HV(POPs);
1b6737cc
AL		 4730 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4731 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 4732 bool can_preserve = FALSE;
79072805 4733
eb85dfd3
DM		 4734 if (localizing) {
4735 MAGIC *mg;
4736 HV *stash;
4737
d30e492c
VP		 4738 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4739 can_preserve = TRUE;
eb85dfd3
DM		 4740 }
4741
6d822dc4 4742 while (++MARK <= SP) {
1b6737cc 4743 SV * const keysv = *MARK;
6d822dc4
MS		 4744 SV **svp;
4745 HE *he;
d30e492c
VP		 4746 bool preeminent = TRUE;
4747
4748 if (localizing && can_preserve) {
4749 /* If we can determine whether the element exist,
4750 * try to preserve the existenceness of a tied hash
4751 * element by using EXISTS and DELETE if possible.
4752 * Fallback to FETCH and STORE otherwise. */
4753 preeminent = hv_exists_ent(hv, keysv, 0);
6d822dc4 4754 }
eb85dfd3 4755
6d822dc4 4756 he = hv_fetch_ent(hv, keysv, lval, 0);
fe5bfecd 4757 svp = he ? &HeVAL(he) : NULL;
eb85dfd3 4758
6d822dc4
MS		 4759 if (lval) {
4760 if (!svp || *svp == &PL_sv_undef) {
be2597df 4761 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6d822dc4
MS		 4762 }
4763 if (localizing) {
7a2e501a 4764 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 4765 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP		 4766 else if (preeminent)
4767 save_helem_flags(hv, keysv, svp,
4768 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4769 else
4770 SAVEHDELETE(hv, keysv);
6d822dc4
MS		 4771 }
4772 }
4773 *MARK = svp ? *svp : &PL_sv_undef;
79072805 4774 }
a0d0e21e
LW		 4775 if (GIMME != G_ARRAY) {
4776 MARK = ORIGMARK;
04ab2c87 4777 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e 4778 SP = MARK;
79072805 4779 }
a0d0e21e
LW		 4780 RETURN;
4781}
4782
4783/* List operators. */
4784
4785PP(pp_list)
4786{
97aff369 4787 dVAR; dSP; dMARK;
a0d0e21e
LW		 4788 if (GIMME != G_ARRAY) {
4789 if (++MARK <= SP)
4790 *MARK = *SP; /* unwanted list, return last item */
8990e307 4791 else
3280af22 4792 *MARK = &PL_sv_undef;
a0d0e21e 4793 SP = MARK;
79072805 4794 }
a0d0e21e 4795 RETURN;
79072805
LW		 4796}
4797
a0d0e21e 4798PP(pp_lslice)
79072805 4799{
97aff369 4800 dVAR;
39644a26 4801 dSP;
1b6737cc
AL		 4802 SV ** const lastrelem = PL_stack_sp;
4803 SV ** const lastlelem = PL_stack_base + POPMARK;
4804 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4805 register SV ** const firstrelem = lastlelem + 1;
42e73ed0 4806 I32 is_something_there = FALSE;
1b6737cc
AL		 4807
4808 register const I32 max = lastrelem - lastlelem;
a0d0e21e 4809 register SV **lelem;
a0d0e21e
LW		 4810
4811 if (GIMME != G_ARRAY) {
4ea561bc 4812 I32 ix = SvIV(*lastlelem);
748a9306
LW		 4813 if (ix < 0)
4814 ix += max;
a0d0e21e 4815 if (ix < 0 || ix >= max)
3280af22 4816 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 4817 else
4818 *firstlelem = firstrelem[ix];
4819 SP = firstlelem;
4820 RETURN;
4821 }
4822
4823 if (max == 0) {
4824 SP = firstlelem - 1;
4825 RETURN;
4826 }
4827
4828 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4ea561bc 4829 I32 ix = SvIV(*lelem);
c73bf8e3 4830 if (ix < 0)
a0d0e21e 4831 ix += max;
c73bf8e3
HS		 4832 if (ix < 0 || ix >= max)
4833 *lelem = &PL_sv_undef;
4834 else {
4835 is_something_there = TRUE;
4836 if (!(*lelem = firstrelem[ix]))
3280af22 4837 *lelem = &PL_sv_undef;
748a9306 4838 }
79072805 4839 }
4633a7c4
LW		 4840 if (is_something_there)
4841 SP = lastlelem;
4842 else
4843 SP = firstlelem - 1;
79072805
LW		 4844 RETURN;
4845}
4846
a0d0e21e
LW		 4847PP(pp_anonlist)
4848{
97aff369 4849 dVAR; dSP; dMARK; dORIGMARK;
1b6737cc 4850 const I32 items = SP - MARK;
ad64d0ec 4851 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
44a8e56a 4852 SP = ORIGMARK; /* av_make() might realloc stack_sp */
6e449a3a
MHM		 4853 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4854 ? newRV_noinc(av) : av);
a0d0e21e
LW		 4855 RETURN;
4856}
4857
4858PP(pp_anonhash)
79072805 4859{
97aff369 4860 dVAR; dSP; dMARK; dORIGMARK;
78c72037 4861 HV* const hv = newHV();
a0d0e21e
LW		 4862
4863 while (MARK < SP) {
1b6737cc 4864 SV * const key = *++MARK;
561b68a9 4865 SV * const val = newSV(0);
a0d0e21e
LW		 4866 if (MARK < SP)
4867 sv_setsv(val, *++MARK);
a2a5de95
NC		 4868 else
4869 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
f12c7020 4870 (void)hv_store_ent(hv,key,val,0);
79072805 4871 }
a0d0e21e 4872 SP = ORIGMARK;
6e449a3a 4873 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
ad64d0ec 4874 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
79072805
LW		 4875 RETURN;
4876}
4877
d4fc4415
FC		 4878static AV *
4879S_deref_plain_array(pTHX_ AV *ary)
4880{
4881 if (SvTYPE(ary) == SVt_PVAV) return ary;
d2d95e13 4882 SvGETMAGIC((SV *)ary);
d4fc4415
FC		 4883 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4884 Perl_die(aTHX_ "Not an ARRAY reference");
4885 else if (SvOBJECT(SvRV(ary)))
4886 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4887 return (AV *)SvRV(ary);
4888}
4889
4890#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4891# define DEREF_PLAIN_ARRAY(ary) \
4892 ({ \
4893 AV *aRrRay = ary; \
4894 SvTYPE(aRrRay) == SVt_PVAV \
4895 ? aRrRay \
4896 : S_deref_plain_array(aTHX_ aRrRay); \
4897 })
4898#else
4899# define DEREF_PLAIN_ARRAY(ary) \
4900 ( \
3b0f6d32 4901 PL_Sv = (SV *)(ary), \
d4fc4415
FC		 4902 SvTYPE(PL_Sv) == SVt_PVAV \
4903 ? (AV *)PL_Sv \
3b0f6d32 4904 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
d4fc4415
FC		 4905 )
4906#endif
4907
a0d0e21e 4908PP(pp_splice)
79072805 4909{
27da23d5 4910 dVAR; dSP; dMARK; dORIGMARK;
5cd408a2 4911 int num_args = (SP - MARK);
d4fc4415 4912 register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
a0d0e21e
LW		 4913 register SV **src;
4914 register SV **dst;
4915 register I32 i;
4916 register I32 offset;
4917 register I32 length;
4918 I32 newlen;
4919 I32 after;
4920 I32 diff;
ad64d0ec 4921 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 4922
1b6737cc 4923 if (mg) {
af71faff
NC		 4924 return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
4925 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4926 sp - mark);
93965878 4927 }
79072805 4928
a0d0e21e 4929 SP++;
79072805 4930
a0d0e21e 4931 if (++MARK < SP) {
4ea561bc 4932 offset = i = SvIV(*MARK);
a0d0e21e 4933 if (offset < 0)
93965878 4934 offset += AvFILLp(ary) + 1;
84902520 4935 if (offset < 0)
cea2e8a9 4936 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 4937 if (++MARK < SP) {
4938 length = SvIVx(*MARK++);
48cdf507
GA		 4939 if (length < 0) {
4940 length += AvFILLp(ary) - offset + 1;
4941 if (length < 0)
4942 length = 0;
4943 }
79072805
LW		 4944 }
4945 else
a0d0e21e 4946 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 4947 }
a0d0e21e
LW		 4948 else {
4949 offset = 0;
4950 length = AvMAX(ary) + 1;
4951 }
8cbc2e3b 4952 if (offset > AvFILLp(ary) + 1) {
5cd408a2
EB		 4953 if (num_args > 2)
4954 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 4955 offset = AvFILLp(ary) + 1;
8cbc2e3b 4956 }
93965878 4957 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 4958 if (after < 0) { /* not that much array */
4959 length += after; /* offset+length now in array */
4960 after = 0;
4961 if (!AvALLOC(ary))
4962 av_extend(ary, 0);
4963 }
4964
4965 /* At this point, MARK .. SP-1 is our new LIST */
4966
4967 newlen = SP - MARK;
4968 diff = newlen - length;
13d7cbc1
GS		 4969 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4970 av_reify(ary);
a0d0e21e 4971
50528de0
WL		 4972 /* make new elements SVs now: avoid problems if they're from the array */
4973 for (dst = MARK, i = newlen; i; i--) {
1b6737cc 4974 SV * const h = *dst;
f2b990bf 4975 *dst++ = newSVsv(h);
50528de0
WL		 4976 }
4977
a0d0e21e 4978 if (diff < 0) { /* shrinking the area */
95b63a38 4979 SV **tmparyval = NULL;
a0d0e21e 4980 if (newlen) {
a02a5408 4981 Newx(tmparyval, newlen, SV*); /* so remember insertion */
a0d0e21e 4982 Copy(MARK, tmparyval, newlen, SV*);
79072805 4983 }
a0d0e21e
LW		 4984
4985 MARK = ORIGMARK + 1;
4986 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4987 MEXTEND(MARK, length);
4988 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4989 if (AvREAL(ary)) {
bbce6d69 4990 EXTEND_MORTAL(length);
36477c24 4991 for (i = length, dst = MARK; i; i--) {
486ec47a 4992 sv_2mortal(*dst); /* free them eventually */
36477c24 4993 dst++;
4994 }
a0d0e21e
LW		 4995 }
4996 MARK += length - 1;
79072805 4997 }
a0d0e21e
LW		 4998 else {
4999 *MARK = AvARRAY(ary)[offset+length-1];
5000 if (AvREAL(ary)) {
d689ffdd 5001 sv_2mortal(*MARK);
a0d0e21e
LW		 5002 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5003 SvREFCNT_dec(*dst++); /* free them now */
79072805 5004 }
a0d0e21e 5005 }
93965878 5006 AvFILLp(ary) += diff;
a0d0e21e
LW		 5007
5008 /* pull up or down? */
5009
5010 if (offset < after) { /* easier to pull up */
5011 if (offset) { /* esp. if nothing to pull */
5012 src = &AvARRAY(ary)[offset-1];
5013 dst = src - diff; /* diff is negative */
5014 for (i = offset; i > 0; i--) /* can't trust Copy */
5015 *dst-- = *src--;
79072805 5016 }
a0d0e21e 5017 dst = AvARRAY(ary);
9c6bc640 5018 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
a0d0e21e
LW		 5019 AvMAX(ary) += diff;
5020 }
5021 else {
5022 if (after) { /* anything to pull down? */
5023 src = AvARRAY(ary) + offset + length;
5024 dst = src + diff; /* diff is negative */
5025 Move(src, dst, after, SV*);
79072805 5026 }
93965878 5027 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 5028 /* avoid later double free */
5029 }
5030 i = -diff;
5031 while (i)
3280af22 5032 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 5033
5034 if (newlen) {
50528de0 5035 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e
LW		 5036 Safefree(tmparyval);
5037 }
5038 }
5039 else { /* no, expanding (or same) */
d3961450 5040 SV** tmparyval = NULL;
a0d0e21e 5041 if (length) {
a02a5408 5042 Newx(tmparyval, length, SV*); /* so remember deletion */
a0d0e21e
LW		 5043 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5044 }
5045
5046 if (diff > 0) { /* expanding */
a0d0e21e 5047 /* push up or down? */
a0d0e21e
LW		 5048 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5049 if (offset) {
5050 src = AvARRAY(ary);
5051 dst = src - diff;
5052 Move(src, dst, offset, SV*);
79072805 5053 }
9c6bc640 5054 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
a0d0e21e 5055 AvMAX(ary) += diff;
93965878 5056 AvFILLp(ary) += diff;
79072805
LW		 5057 }
5058 else {
93965878
NIS		 5059 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5060 av_extend(ary, AvFILLp(ary) + diff);
5061 AvFILLp(ary) += diff;
a0d0e21e
LW		 5062
5063 if (after) {
93965878 5064 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 5065 src = dst - diff;
5066 for (i = after; i; i--) {
5067 *dst-- = *src--;
5068 }
79072805
LW		 5069 }
5070 }
a0d0e21e
LW		 5071 }
5072
50528de0
WL		 5073 if (newlen) {
5074 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e 5075 }
50528de0 5076
a0d0e21e
LW		 5077 MARK = ORIGMARK + 1;
5078 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5079 if (length) {
5080 Copy(tmparyval, MARK, length, SV*);
5081 if (AvREAL(ary)) {
bbce6d69 5082 EXTEND_MORTAL(length);
36477c24 5083 for (i = length, dst = MARK; i; i--) {
486ec47a 5084 sv_2mortal(*dst); /* free them eventually */
36477c24 5085 dst++;
5086 }
79072805
LW		 5087 }
5088 }
a0d0e21e
LW		 5089 MARK += length - 1;
5090 }
5091 else if (length--) {
5092 *MARK = tmparyval[length];
5093 if (AvREAL(ary)) {
d689ffdd 5094 sv_2mortal(*MARK);
a0d0e21e
LW		 5095 while (length-- > 0)
5096 SvREFCNT_dec(tmparyval[length]);
79072805 5097 }
79072805 5098 }
a0d0e21e 5099 else
3280af22 5100 *MARK = &PL_sv_undef;
d3961450 5101 Safefree(tmparyval);
79072805 5102 }
474af990
FR		 5103
5104 if (SvMAGICAL(ary))
5105 mg_set(MUTABLE_SV(ary));
5106
a0d0e21e 5107 SP = MARK;
79072805
LW		 5108 RETURN;
5109}
5110
a0d0e21e 5111PP(pp_push)
79072805 5112{
27da23d5 5113 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
d4fc4415 5114 register AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5115 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
79072805 5116
1b6737cc 5117 if (mg) {
ad64d0ec 5118 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
93965878
NIS		 5119 PUSHMARK(MARK);
5120 PUTBACK;
d343c3ef 5121 ENTER_with_name("call_PUSH");
864dbfa3 5122 call_method("PUSH",G_SCALAR|G_DISCARD);
d343c3ef 5123 LEAVE_with_name("call_PUSH");
93965878 5124 SPAGAIN;
93965878 5125 }
a60c0954 5126 else {
89c14e2e 5127 PL_delaymagic = DM_DELAY;
a60c0954 5128 for (++MARK; MARK <= SP; MARK++) {
561b68a9 5129 SV * const sv = newSV(0);
a60c0954
NIS		 5130 if (*MARK)
5131 sv_setsv(sv, *MARK);
0a75904b 5132 av_store(ary, AvFILLp(ary)+1, sv);
a60c0954 5133 }
354b0578 5134 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 5135 mg_set(MUTABLE_SV(ary));
89c14e2e
BB		 5136
5137 PL_delaymagic = 0;
6eeabd23
VP		 5138 }
5139 SP = ORIGMARK;
5140 if (OP_GIMME(PL_op, 0) != G_VOID) {
5141 PUSHi( AvFILL(ary) + 1 );
79072805 5142 }
79072805
LW		 5143 RETURN;
5144}
5145
a0d0e21e 5146PP(pp_shift)
79072805 5147{
97aff369 5148 dVAR;
39644a26 5149 dSP;
538f5756 5150 AV * const av = PL_op->op_flags & OPf_SPECIAL
d4fc4415 5151 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
789b4bc9 5152 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
79072805 5153 EXTEND(SP, 1);
c2b4a044 5154 assert (sv);
d689ffdd 5155 if (AvREAL(av))
a0d0e21e
LW		 5156 (void)sv_2mortal(sv);
5157 PUSHs(sv);
79072805 5158 RETURN;
79072805
LW		 5159}
5160
a0d0e21e 5161PP(pp_unshift)
79072805 5162{
27da23d5 5163 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
d4fc4415 5164 register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5165 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 5166
1b6737cc 5167 if (mg) {
ad64d0ec 5168 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
7fd66d9d 5169 PUSHMARK(MARK);
93965878 5170 PUTBACK;
d343c3ef 5171 ENTER_with_name("call_UNSHIFT");
864dbfa3 5172 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
d343c3ef 5173 LEAVE_with_name("call_UNSHIFT");
93965878 5174 SPAGAIN;
93965878 5175 }
a60c0954 5176 else {
1b6737cc 5177 register I32 i = 0;
a60c0954
NIS		 5178 av_unshift(ary, SP - MARK);
5179 while (MARK < SP) {
1b6737cc 5180 SV * const sv = newSVsv(*++MARK);
a60c0954
NIS		 5181 (void)av_store(ary, i++, sv);
5182 }
79072805 5183 }
a0d0e21e 5184 SP = ORIGMARK;
6eeabd23 5185 if (OP_GIMME(PL_op, 0) != G_VOID) {
5658d0a9
LR		 5186 PUSHi( AvFILL(ary) + 1 );
5187 }
79072805 5188 RETURN;
79072805
LW		 5189}
5190
a0d0e21e 5191PP(pp_reverse)
79072805 5192{
97aff369 5193 dVAR; dSP; dMARK;
79072805 5194
a0d0e21e 5195 if (GIMME == G_ARRAY) {
484c818f
VP		 5196 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5197 AV *av;
5198
5199 /* See pp_sort() */
5200 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5201 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5202 av = MUTABLE_AV((*SP));
5203 /* In-place reversing only happens in void context for the array
5204 * assignment. We don't need to push anything on the stack. */
5205 SP = MARK;
5206
5207 if (SvMAGICAL(av)) {
5208 I32 i, j;
5209 register SV *tmp = sv_newmortal();
5210 /* For SvCANEXISTDELETE */
5211 HV *stash;
5212 const MAGIC *mg;
5213 bool can_preserve = SvCANEXISTDELETE(av);
5214
5215 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5216 register SV *begin, *end;
5217
5218 if (can_preserve) {
5219 if (!av_exists(av, i)) {
5220 if (av_exists(av, j)) {
5221 register SV *sv = av_delete(av, j, 0);
5222 begin = *av_fetch(av, i, TRUE);
5223 sv_setsv_mg(begin, sv);
5224 }
5225 continue;
5226 }
5227 else if (!av_exists(av, j)) {
5228 register SV *sv = av_delete(av, i, 0);
5229 end = *av_fetch(av, j, TRUE);
5230 sv_setsv_mg(end, sv);
5231 continue;
5232 }
5233 }
5234
5235 begin = *av_fetch(av, i, TRUE);
5236 end = *av_fetch(av, j, TRUE);
5237 sv_setsv(tmp, begin);
5238 sv_setsv_mg(begin, end);
5239 sv_setsv_mg(end, tmp);
5240 }
5241 }
5242 else {
5243 SV **begin = AvARRAY(av);
484c818f 5244
95a26d8e
VP		 5245 if (begin) {
5246 SV **end = begin + AvFILLp(av);
5247
5248 while (begin < end) {
5249 register SV * const tmp = *begin;
5250 *begin++ = *end;
5251 *end-- = tmp;
5252 }
484c818f
VP		 5253 }
5254 }
5255 }
5256 else {
5257 SV **oldsp = SP;
5258 MARK++;
5259 while (MARK < SP) {
5260 register SV * const tmp = *MARK;
5261 *MARK++ = *SP;
5262 *SP-- = tmp;
5263 }
5264 /* safe as long as stack cannot get extended in the above */
5265 SP = oldsp;
a0d0e21e 5266 }
79072805
LW		 5267 }
5268 else {
a0d0e21e
LW		 5269 register char *up;
5270 register char *down;
5271 register I32 tmp;
5272 dTARGET;
5273 STRLEN len;
79072805 5274
7e2040f0 5275 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 5276 if (SP - MARK > 1)
3280af22 5277 do_join(TARG, &PL_sv_no, MARK, SP);
1e21d011 5278 else {
789bd863 5279 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
1e21d011
B		 5280 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5281 report_uninit(TARG);
5282 }
5283
a0d0e21e
LW		 5284 up = SvPV_force(TARG, len);
5285 if (len > 1) {
7e2040f0 5286 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55 5287 U8* s = (U8*)SvPVX(TARG);
349d4f2f 5288 const U8* send = (U8*)(s + len);
a0ed51b3 5289 while (s < send) {
d742c382 5290 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 5291 s++;
5292 continue;
5293 }
5294 else {
9041c2e3 5295 if (!utf8_to_uvchr(s, 0))
a0dbb045 5296 break;
dfe13c55 5297 up = (char*)s;
a0ed51b3 5298 s += UTF8SKIP(s);
dfe13c55 5299 down = (char*)(s - 1);
a0dbb045 5300 /* reverse this character */
a0ed51b3
LW		 5301 while (down > up) {
5302 tmp = *up;
5303 *up++ = *down;
eb160463 5304 *down-- = (char)tmp;
a0ed51b3
LW		 5305 }
5306 }
5307 }
5308 up = SvPVX(TARG);
5309 }
a0d0e21e
LW		 5310 down = SvPVX(TARG) + len - 1;
5311 while (down > up) {
5312 tmp = *up;
5313 *up++ = *down;
eb160463 5314 *down-- = (char)tmp;
a0d0e21e 5315 }
3aa33fe5 5316 (void)SvPOK_only_UTF8(TARG);
79072805 5317 }
a0d0e21e
LW		 5318 SP = MARK + 1;
5319 SETTARG;
79072805 5320 }
a0d0e21e 5321 RETURN;
79072805
LW		 5322}
5323
a0d0e21e 5324PP(pp_split)
79072805 5325{
27da23d5 5326 dVAR; dSP; dTARG;
a0d0e21e 5327 AV *ary;
467f0320 5328 register IV limit = POPi; /* note, negative is forever */
1b6737cc 5329 SV * const sv = POPs;
a0d0e21e 5330 STRLEN len;
727b7506 5331 register const char *s = SvPV_const(sv, len);
1b6737cc 5332 const bool do_utf8 = DO_UTF8(sv);
727b7506 5333 const char *strend = s + len;
44a8e56a 5334 register PMOP *pm;
d9f97599 5335 register REGEXP *rx;
a0d0e21e 5336 register SV *dstr;
727b7506 5337 register const char *m;
a0d0e21e 5338 I32 iters = 0;
bb7a0f54 5339 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
792b2c16 5340 I32 maxiters = slen + 10;
c1a7495a 5341 I32 trailing_empty = 0;
727b7506 5342 const char *orig;
1b6737cc 5343 const I32 origlimit = limit;
a0d0e21e
LW		 5344 I32 realarray = 0;
5345 I32 base;
f54cb97a 5346 const I32 gimme = GIMME_V;
941446f6 5347 bool gimme_scalar;
f54cb97a 5348 const I32 oldsave = PL_savestack_ix;
437d3b4e 5349 U32 make_mortal = SVs_TEMP;
7fba1cd6 5350 bool multiline = 0;
b37c2d43 5351 MAGIC *mg = NULL;
79072805 5352
44a8e56a 5353#ifdef DEBUGGING
5354 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5355#else
5356 pm = (PMOP*)POPs;
5357#endif
a0d0e21e 5358 if (!pm || !s)
2269b42e 5359 DIE(aTHX_ "panic: pp_split");
aaa362c4 5360 rx = PM_GETRE(pm);
bbce6d69 5361
a62b1201 5362 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
07bc277f 5363 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
bbce6d69 5364
a30b2f1f 5365 RX_MATCH_UTF8_set(rx, do_utf8);
d9f424b2 5366
971a9dd3 5367#ifdef USE_ITHREADS
20e98b0f 5368 if (pm->op_pmreplrootu.op_pmtargetoff) {
159b6efe 5369 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
20e98b0f 5370 }
971a9dd3 5371#else
20e98b0f
NC		 5372 if (pm->op_pmreplrootu.op_pmtargetgv) {
5373 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
971a9dd3 5374 }
20e98b0f 5375#endif
79072805 5376 else
7d49f689 5377 ary = NULL;
a0d0e21e
LW		 5378 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5379 realarray = 1;
8ec5e241 5380 PUTBACK;
a0d0e21e
LW		 5381 av_extend(ary,0);
5382 av_clear(ary);
8ec5e241 5383 SPAGAIN;
ad64d0ec 5384 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
8ec5e241 5385 PUSHMARK(SP);
ad64d0ec 5386 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
8ec5e241
NIS		 5387 }
5388 else {
1c0b011c 5389 if (!AvREAL(ary)) {
1b6737cc 5390 I32 i;
1c0b011c 5391 AvREAL_on(ary);
abff13bb 5392 AvREIFY_off(ary);
1c0b011c 5393 for (i = AvFILLp(ary); i >= 0; i--)
3280af22 5394 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 5395 }
5396 /* temporarily switch stacks */
8b7059b1 5397 SAVESWITCHSTACK(PL_curstack, ary);
8ec5e241 5398 make_mortal = 0;
1c0b011c 5399 }
79072805 5400 }
3280af22 5401 base = SP - PL_stack_base;
a0d0e21e 5402 orig = s;
07bc277f 5403 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
613f191e
TS		 5404 if (do_utf8) {
5405 while (*s == ' ' || is_utf8_space((U8*)s))
5406 s += UTF8SKIP(s);
5407 }
a62b1201 5408 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
bbce6d69 5409 while (isSPACE_LC(*s))
5410 s++;
5411 }
5412 else {
5413 while (isSPACE(*s))
5414 s++;
5415 }
a0d0e21e 5416 }
73134a2e 5417 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
7fba1cd6 5418 multiline = 1;
c07a80fd 5419 }
5420
941446f6
FC		 5421 gimme_scalar = gimme == G_SCALAR && !ary;
5422
a0d0e21e
LW		 5423 if (!limit)
5424 limit = maxiters + 2;
07bc277f 5425 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
a0d0e21e 5426 while (--limit) {
bbce6d69 5427 m = s;
8727f688
YO		 5428 /* this one uses 'm' and is a negative test */
5429 if (do_utf8) {
613f191e
TS		 5430 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5431 const int t = UTF8SKIP(m);
5432 /* is_utf8_space returns FALSE for malform utf8 */
5433 if (strend - m < t)
5434 m = strend;
5435 else
5436 m += t;
5437 }
a62b1201
KW		 5438 }
5439 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
8727f688
YO		 5440 while (m < strend && !isSPACE_LC(*m))
5441 ++m;
5442 } else {
5443 while (m < strend && !isSPACE(*m))
5444 ++m;
5445 }
a0d0e21e
LW		 5446 if (m >= strend)
5447 break;
bbce6d69 5448
c1a7495a
BB		 5449 if (gimme_scalar) {
5450 iters++;
5451 if (m-s == 0)
5452 trailing_empty++;
5453 else
5454 trailing_empty = 0;
5455 } else {
5456 dstr = newSVpvn_flags(s, m-s,
5457 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5458 XPUSHs(dstr);
5459 }
bbce6d69 5460
613f191e
TS		 5461 /* skip the whitespace found last */
5462 if (do_utf8)
5463 s = m + UTF8SKIP(m);
5464 else
5465 s = m + 1;
5466
8727f688
YO		 5467 /* this one uses 's' and is a positive test */
5468 if (do_utf8) {
613f191e 5469 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
8727f688 5470 s += UTF8SKIP(s);
a62b1201
KW		 5471 }
5472 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
8727f688
YO		 5473 while (s < strend && isSPACE_LC(*s))
5474 ++s;
5475 } else {
5476 while (s < strend && isSPACE(*s))
5477 ++s;
5478 }
79072805
LW		 5479 }
5480 }
07bc277f 5481 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
a0d0e21e 5482 while (--limit) {
a6e20a40
AL		 5483 for (m = s; m < strend && *m != '\n'; m++)
5484 ;
a0d0e21e
LW		 5485 m++;
5486 if (m >= strend)
5487 break;
c1a7495a
BB		 5488
5489 if (gimme_scalar) {
5490 iters++;
5491 if (m-s == 0)
5492 trailing_empty++;
5493 else
5494 trailing_empty = 0;
5495 } else {
5496 dstr = newSVpvn_flags(s, m-s,
5497 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5498 XPUSHs(dstr);
5499 }
a0d0e21e
LW		 5500 s = m;
5501 }
5502 }
07bc277f 5503 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
640f820d
AB		 5504 /*
5505 Pre-extend the stack, either the number of bytes or
5506 characters in the string or a limited amount, triggered by:
5507
5508 my ($x, $y) = split //, $str;
5509 or
5510 split //, $str, $i;
5511 */
c1a7495a
BB		 5512 if (!gimme_scalar) {
5513 const U32 items = limit - 1;
5514 if (items < slen)
5515 EXTEND(SP, items);
5516 else
5517 EXTEND(SP, slen);
5518 }
640f820d 5519
e9515b0f
AB		 5520 if (do_utf8) {
5521 while (--limit) {
5522 /* keep track of how many bytes we skip over */
5523 m = s;
640f820d 5524 s += UTF8SKIP(s);
c1a7495a
BB		 5525 if (gimme_scalar) {
5526 iters++;
5527 if (s-m == 0)
5528 trailing_empty++;
5529 else
5530 trailing_empty = 0;
5531 } else {
5532 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
640f820d 5533
c1a7495a
BB		 5534 PUSHs(dstr);
5535 }
640f820d 5536
e9515b0f
AB		 5537 if (s >= strend)
5538 break;
5539 }
5540 } else {
5541 while (--limit) {
c1a7495a
BB		 5542 if (gimme_scalar) {
5543 iters++;
5544 } else {
5545 dstr = newSVpvn(s, 1);
e9515b0f 5546
e9515b0f 5547
c1a7495a
BB		 5548 if (make_mortal)
5549 sv_2mortal(dstr);
640f820d 5550
c1a7495a
BB		 5551 PUSHs(dstr);
5552 }
5553
5554 s++;
e9515b0f
AB		 5555
5556 if (s >= strend)
5557 break;
5558 }
640f820d
AB		 5559 }
5560 }
3c8556c3 5561 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
07bc277f
NC		 5562 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5563 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5564 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5565 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
f9f4320a 5566 SV * const csv = CALLREG_INTUIT_STRING(rx);
cf93c79d 5567
07bc277f 5568 len = RX_MINLENRET(rx);
3c8556c3 5569 if (len == 1 && !RX_UTF8(rx) && !tail) {
1b6737cc 5570 const char c = *SvPV_nolen_const(csv);
a0d0e21e 5571 while (--limit) {
a6e20a40
AL		 5572 for (m = s; m < strend && *m != c; m++)
5573 ;
a0d0e21e
LW		 5574 if (m >= strend)
5575 break;
c1a7495a
BB		 5576 if (gimme_scalar) {
5577 iters++;
5578 if (m-s == 0)
5579 trailing_empty++;
5580 else
5581 trailing_empty = 0;
5582 } else {
5583 dstr = newSVpvn_flags(s, m-s,
5584 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5585 XPUSHs(dstr);
5586 }
93f04dac
JH		 5587 /* The rx->minlen is in characters but we want to step
5588 * s ahead by bytes. */
1aa99e6b
IH		 5589 if (do_utf8)
5590 s = (char*)utf8_hop((U8*)m, len);
5591 else
5592 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 5593 }
5594 }
5595 else {
a0d0e21e 5596 while (s < strend && --limit &&
f722798b 5597 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
7fba1cd6 5598 csv, multiline ? FBMrf_MULTILINE : 0)) )
a0d0e21e 5599 {
c1a7495a
BB		 5600 if (gimme_scalar) {
5601 iters++;
5602 if (m-s == 0)
5603 trailing_empty++;
5604 else
5605 trailing_empty = 0;
5606 } else {
5607 dstr = newSVpvn_flags(s, m-s,
5608 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5609 XPUSHs(dstr);
5610 }
93f04dac
JH		 5611 /* The rx->minlen is in characters but we want to step
5612 * s ahead by bytes. */
1aa99e6b
IH		 5613 if (do_utf8)
5614 s = (char*)utf8_hop((U8*)m, len);
5615 else
5616 s = m + len; /* Fake \n at the end */
a0d0e21e 5617 }
463ee0b2 5618 }
463ee0b2 5619 }
a0d0e21e 5620 else {
07bc277f 5621 maxiters += slen * RX_NPARENS(rx);
080c2dec 5622 while (s < strend && --limit)
bbce6d69 5623 {
1b6737cc 5624 I32 rex_return;
080c2dec 5625 PUTBACK;
f9f4320a 5626 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
bfafcb9a 5627 sv, NULL, SvSCREAM(sv) ? REXEC_SCREAM : 0);
080c2dec 5628 SPAGAIN;
1b6737cc 5629 if (rex_return == 0)
080c2dec 5630 break;
d9f97599 5631 TAINT_IF(RX_MATCH_TAINTED(rx));
07bc277f 5632 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
a0d0e21e
LW		 5633 m = s;
5634 s = orig;
07bc277f 5635 orig = RX_SUBBEG(rx);
a0d0e21e
LW		 5636 s = orig + (m - s);
5637 strend = s + (strend - m);
5638 }
07bc277f 5639 m = RX_OFFS(rx)[0].start + orig;
c1a7495a
BB		 5640
5641 if (gimme_scalar) {
5642 iters++;
5643 if (m-s == 0)
5644 trailing_empty++;
5645 else
5646 trailing_empty = 0;
5647 } else {
5648 dstr = newSVpvn_flags(s, m-s,
5649 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5650 XPUSHs(dstr);
5651 }
07bc277f 5652 if (RX_NPARENS(rx)) {
1b6737cc 5653 I32 i;
07bc277f
NC		 5654 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5655 s = RX_OFFS(rx)[i].start + orig;
5656 m = RX_OFFS(rx)[i].end + orig;
6de67870
JP		 5657
5658 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5659 parens that didn't match -- they should be set to
5660 undef, not the empty string */
c1a7495a
BB		 5661 if (gimme_scalar) {
5662 iters++;
5663 if (m-s == 0)
5664 trailing_empty++;
5665 else
5666 trailing_empty = 0;
5667 } else {
5668 if (m >= orig && s >= orig) {
5669 dstr = newSVpvn_flags(s, m-s,
5670 (do_utf8 ? SVf_UTF8 : 0)
5671 | make_mortal);
5672 }
5673 else
5674 dstr = &PL_sv_undef; /* undef, not "" */
5675 XPUSHs(dstr);
748a9306 5676 }
c1a7495a 5677
a0d0e21e
LW		 5678 }
5679 }
07bc277f 5680 s = RX_OFFS(rx)[0].end + orig;
a0d0e21e 5681 }
79072805 5682 }
8ec5e241 5683
c1a7495a
BB		 5684 if (!gimme_scalar) {
5685 iters = (SP - PL_stack_base) - base;
5686 }
a0d0e21e 5687 if (iters > maxiters)
cea2e8a9 5688 DIE(aTHX_ "Split loop");
8ec5e241 5689
a0d0e21e
LW		 5690 /* keep field after final delim? */
5691 if (s < strend || (iters && origlimit)) {
c1a7495a
BB		 5692 if (!gimme_scalar) {
5693 const STRLEN l = strend - s;
5694 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5695 XPUSHs(dstr);
5696 }
a0d0e21e 5697 iters++;
79072805 5698 }
a0d0e21e 5699 else if (!origlimit) {
c1a7495a
BB		 5700 if (gimme_scalar) {
5701 iters -= trailing_empty;
5702 } else {
5703 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5704 if (TOPs && !make_mortal)
5705 sv_2mortal(TOPs);
5706 *SP-- = &PL_sv_undef;
5707 iters--;
5708 }
89900bd3 5709 }
a0d0e21e 5710 }
8ec5e241 5711
8b7059b1
DM		 5712 PUTBACK;
5713 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5714 SPAGAIN;
a0d0e21e 5715 if (realarray) {
8ec5e241 5716 if (!mg) {
1c0b011c
NIS		 5717 if (SvSMAGICAL(ary)) {
5718 PUTBACK;
ad64d0ec 5719 mg_set(MUTABLE_SV(ary));
1c0b011c
NIS		 5720 SPAGAIN;
5721 }
5722 if (gimme == G_ARRAY) {
5723 EXTEND(SP, iters);
5724 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5725 SP += iters;
5726 RETURN;
5727 }
8ec5e241 5728 }
1c0b011c 5729 else {
fb73857a 5730 PUTBACK;
d343c3ef 5731 ENTER_with_name("call_PUSH");
864dbfa3 5732 call_method("PUSH",G_SCALAR|G_DISCARD);
d343c3ef 5733 LEAVE_with_name("call_PUSH");
fb73857a 5734 SPAGAIN;
8ec5e241 5735 if (gimme == G_ARRAY) {
1b6737cc 5736 I32 i;
8ec5e241
NIS		 5737 /* EXTEND should not be needed - we just popped them */
5738 EXTEND(SP, iters);
5739 for (i=0; i < iters; i++) {
5740 SV **svp = av_fetch(ary, i, FALSE);
3280af22 5741 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 5742 }
1c0b011c
NIS		 5743 RETURN;
5744 }
a0d0e21e
LW		 5745 }
5746 }
5747 else {
5748 if (gimme == G_ARRAY)
5749 RETURN;
5750 }
7f18b612
YST		 5751
5752 GETTARGET;
5753 PUSHi(iters);
5754 RETURN;
79072805 5755}
85e6fe83 5756
c5917253
NC		 5757PP(pp_once)
5758{
5759 dSP;
5760 SV *const sv = PAD_SVl(PL_op->op_targ);
5761
5762 if (SvPADSTALE(sv)) {
5763 /* First time. */
5764 SvPADSTALE_off(sv);
5765 RETURNOP(cLOGOP->op_other);
5766 }
5767 RETURNOP(cLOGOP->op_next);
5768}
5769
c0329465
MB		 5770PP(pp_lock)
5771{
97aff369 5772 dVAR;
39644a26 5773 dSP;
c0329465 5774 dTOPss;
e55aaa0e 5775 SV *retsv = sv;
68795e93 5776 SvLOCK(sv);
f79aa60b
FC		 5777 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5778 || SvTYPE(retsv) == SVt_PVCV) {
e55aaa0e
MB		 5779 retsv = refto(retsv);
5780 }
5781 SETs(retsv);
c0329465
MB		 5782 RETURN;
5783}
a863c7d1 5784
65bca31a
NC		 5785
5786PP(unimplemented_op)
5787{
97aff369 5788 dVAR;
361ed549
NC		 5789 const Optype op_type = PL_op->op_type;
5790 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5791 with out of range op numbers - it only "special" cases op_custom.
5792 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5793 if we get here for a custom op then that means that the custom op didn't
5794 have an implementation. Given that OP_NAME() looks up the custom op
5795 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5796 registers &PL_unimplemented_op as the address of their custom op.
5797 NULL doesn't generate a useful error message. "custom" does. */
5798 const char *const name = op_type >= OP_max
5799 ? "[out of range]" : PL_op_name[PL_op->op_type];
7627e6d0
NC		 5800 if(OP_IS_SOCKET(op_type))
5801 DIE(aTHX_ PL_no_sock_func, name);
361ed549 5802 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
65bca31a
NC		 5803}
5804
867fa1e2
YO		 5805PP(pp_boolkeys)
5806{
5807 dVAR;
5808 dSP;
5809 HV * const hv = (HV*)POPs;
5810
fd1d9b5c
FC		 5811 if (SvTYPE(hv) != SVt_PVHV) { XPUSHs(&PL_sv_no); RETURN; }
5812
867fa1e2
YO		 5813 if (SvRMAGICAL(hv)) {
5814 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
5815 if (mg) {
5816 XPUSHs(magic_scalarpack(hv, mg));
5817 RETURN;
5818 }
5819 }
5820
1b95d04f 5821 XPUSHs(boolSV(HvUSEDKEYS(hv) != 0));
867fa1e2
YO		 5822 RETURN;
5823}
5824
deb8a388
FC		 5825/* For sorting out arguments passed to a &CORE:: subroutine */
5826PP(pp_coreargs)
5827{
5828 dSP;
7fa5bd9b 5829 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
19c481f4 5830 int defgv = PL_opargs[opnum] & OA_DEFGV, whicharg = 0;
7fa5bd9b 5831 AV * const at_ = GvAV(PL_defgv);
46e00a91 5832 SV **svp = AvARRAY(at_);
19c481f4 5833 I32 minargs = 0, maxargs = 0, numargs = AvFILLp(at_)+1;
7fa5bd9b 5834 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
46e00a91 5835 bool seen_question = 0;
7fa5bd9b 5836 const char *err = NULL;
3e6568b4 5837 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
7fa5bd9b 5838
46e00a91
FC		 5839 /* Count how many args there are first, to get some idea how far to
5840 extend the stack. */
7fa5bd9b 5841 while (oa) {
bf0571fd 5842 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
7fa5bd9b 5843 maxargs++;
46e00a91
FC		 5844 if (oa & OA_OPTIONAL) seen_question = 1;
5845 if (!seen_question) minargs++;
7fa5bd9b
FC		 5846 oa >>= 4;
5847 }
5848
5849 if(numargs < minargs) err = "Not enough";
5850 else if(numargs > maxargs) err = "Too many";
5851 if (err)
5852 /* diag_listed_as: Too many arguments for %s */
5853 Perl_croak(aTHX_
5854 "%s arguments for %s", err,
5855 opnum ? OP_DESC(PL_op->op_next) : SvPV_nolen_const(cSVOP_sv)
5856 );
5857
5858 /* Reset the stack pointer. Without this, we end up returning our own
5859 arguments in list context, in addition to the values we are supposed
5860 to return. nextstate usually does this on sub entry, but we need
5861 to run the next op with the caller’s hints, so we cannot have a
5862 nextstate. */
5863 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5864
46e00a91
FC		 5865 if(!maxargs) RETURN;
5866
bf0571fd
FC		 5867 /* We do this here, rather than with a separate pushmark op, as it has
5868 to come in between two things this function does (stack reset and
5869 arg pushing). This seems the easiest way to do it. */
3e6568b4 5870 if (pushmark) {
bf0571fd
FC		 5871 PUTBACK;
5872 (void)Perl_pp_pushmark(aTHX);
5873 }
5874
5875 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
c931b036 5876 PUTBACK; /* The code below can die in various places. */
46e00a91
FC		 5877
5878 oa = PL_opargs[opnum] >> OASHIFT;
3e6568b4 5879 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
c931b036 5880 whicharg++;
46e00a91
FC		 5881 switch (oa & 7) {
5882 case OA_SCALAR:
d6d78e19
FC		 5883 if (!numargs && defgv && whicharg == minargs + 1) {
5884 PERL_SI * const oldsi = PL_curstackinfo;
5885 I32 const oldcxix = oldsi->si_cxix;
5886 CV *caller;
5887 if (oldcxix) oldsi->si_cxix--;
5888 else PL_curstackinfo = oldsi->si_prev;
5889 caller = find_runcv(NULL);
5890 PL_curstackinfo = oldsi;
5891 oldsi->si_cxix = oldcxix;
5892 PUSHs(find_rundefsv2(
5893 caller,cxstack[cxstack_ix].blk_oldcop->cop_seq
5894 ));
5895 }
5896 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
46e00a91 5897 break;
bf0571fd
FC		 5898 case OA_LIST:
5899 while (numargs--) {
5900 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5901 svp++;
5902 }
5903 RETURN;
19c481f4
FC		 5904 case OA_HVREF:
5905 if (!svp || !*svp || !SvROK(*svp)
5906 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5907 DIE(aTHX_
5908 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5909 "Type of arg %d to &CORE::%s must be hash reference",
5910 whicharg, OP_DESC(PL_op->op_next)
5911 );
5912 PUSHs(SvRV(*svp));
5913 break;
c931b036 5914 case OA_FILEREF:
30901a8a
FC		 5915 if (!numargs) PUSHs(NULL);
5916 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
c931b036
FC		 5917 /* no magic here, as the prototype will have added an extra
5918 refgen and we just want what was there before that */
5919 PUSHs(SvRV(*svp));
5920 else {
5921 const bool constr = PL_op->op_private & whicharg;
5922 PUSHs(S_rv2gv(aTHX_
5923 svp && *svp ? *svp : &PL_sv_undef,
5924 constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5925 !constr
5926 ));
5927 }
5928 break;
c72a5629 5929 case OA_SCALARREF:
17008668
FC		 5930 {
5931 const bool wantscalar =
5932 PL_op->op_private & OPpCOREARGS_SCALARMOD;
c72a5629 5933 if (!svp || !*svp || !SvROK(*svp)
17008668
FC		 5934 /* We have to permit globrefs even for the \$ proto, as
5935 *foo is indistinguishable from ${\*foo}, and the proto-
5936 type permits the latter. */
5937 || SvTYPE(SvRV(*svp)) > (
efe889ae
FC		 5938 wantscalar ? SVt_PVLV
5939 : opnum == OP_LOCK ? SVt_PVCV
5940 : SVt_PVHV
17008668 5941 )
c72a5629
FC		 5942 )
5943 DIE(aTHX_
5944 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
17008668
FC		 5945 "Type of arg %d to &CORE::%s must be %s",
5946 whicharg, OP_DESC(PL_op->op_next),
5947 wantscalar
5948 ? "scalar reference"
efe889ae
FC		 5949 : opnum == OP_LOCK
5950 ? "reference to one of [$@%&*]"
5951 : "reference to one of [$@%*]"
c72a5629
FC		 5952 );
5953 PUSHs(SvRV(*svp));
5954 break;
17008668 5955 }
46e00a91 5956 default:
46e00a91
FC		 5957 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
5958 }
5959 oa = oa >> 4;
5960 }
5961
deb8a388
FC		 5962 RETURN;
5963}
5964
e609e586
NC		 5965/*
5966 * Local variables:
5967 * c-indentation-style: bsd
5968 * c-basic-offset: 4
5969 * indent-tabs-mode: t
5970 * End:
5971 *
37442d52
RGS		 5972 * ex: set ts=8 sts=4 sw=4 noet:
5973 */
Unnamed repository; edit this file 'description' to name the repository.