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