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
Increase $SelfLoader::VERSION to 1.19
[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
2957PP(pp_substr)
2958{
97aff369 2959 dVAR; dSP; dTARGET;
79072805 2960 SV *sv;
463ee0b2 2961 STRLEN curlen;
9402d6ed 2962 STRLEN utf8_curlen;
777f7c56
EB		 2963 SV * pos_sv;
2964 IV pos1_iv;
2965 int pos1_is_uv;
2966 IV pos2_iv;
2967 int pos2_is_uv;
2968 SV * len_sv;
2969 IV len_iv = 0;
2970 int len_is_uv = 1;
050e6362 2971 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 2972 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 2973 const char *tmps;
9402d6ed 2974 SV *repl_sv = NULL;
cbbf8932 2975 const char *repl = NULL;
7b8d334a 2976 STRLEN repl_len;
7bc95ae1 2977 int num_args = PL_op->op_private & 7;
13e30c65 2978 bool repl_need_utf8_upgrade = FALSE;
9402d6ed 2979 bool repl_is_utf8 = FALSE;
79072805 2980
78f9721b
SM		 2981 if (num_args > 2) {
2982 if (num_args > 3) {
7bc95ae1 2983 if((repl_sv = POPs)) {
83003860 2984 repl = SvPV_const(repl_sv, repl_len);
bf32a30c 2985 repl_is_utf8 = DO_UTF8(repl_sv) && repl_len;
7bc95ae1
FC		 2986 }
2987 else num_args--;
2988 }
2989 if ((len_sv = POPs)) {
2990 len_iv = SvIV(len_sv);
2991 len_is_uv = SvIOK_UV(len_sv);
7b8d334a 2992 }
7bc95ae1 2993 else num_args--;
5d82c453 2994 }
777f7c56
EB		 2995 pos_sv = POPs;
2996 pos1_iv = SvIV(pos_sv);
2997 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 2998 sv = POPs;
849ca7ee 2999 PUTBACK;
9402d6ed
JH		 3000 if (repl_sv) {
3001 if (repl_is_utf8) {
3002 if (!DO_UTF8(sv))
3003 sv_utf8_upgrade(sv);
3004 }
13e30c65
JH		 3005 else if (DO_UTF8(sv))
3006 repl_need_utf8_upgrade = TRUE;
9402d6ed 3007 }
5c144d81 3008 tmps = SvPV_const(sv, curlen);
7e2040f0 3009 if (DO_UTF8(sv)) {
9402d6ed
JH		 3010 utf8_curlen = sv_len_utf8(sv);
3011 if (utf8_curlen == curlen)
3012 utf8_curlen = 0;
a0ed51b3 3013 else
9402d6ed 3014 curlen = utf8_curlen;
a0ed51b3 3015 }
d1c2b58a 3016 else
9402d6ed 3017 utf8_curlen = 0;
a0ed51b3 3018
e1dccc0d
Z		 3019 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3020 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3021 pos1_iv += curlen;
777f7c56 3022 }
e1dccc0d
Z		 3023 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3024 goto bound_fail;
777f7c56
EB		 3025
3026 if (num_args > 2) {
3027 if (!len_is_uv && len_iv < 0) {
3028 pos2_iv = curlen + len_iv;
3029 if (curlen)
3030 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3031 else
3032 pos2_is_uv = 0;
3033 } else { /* len_iv >= 0 */
3034 if (!pos1_is_uv && pos1_iv < 0) {
3035 pos2_iv = pos1_iv + len_iv;
3036 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3037 } else {
3038 if ((UV)len_iv > curlen-(UV)pos1_iv)
3039 pos2_iv = curlen;
3040 else
3041 pos2_iv = pos1_iv+len_iv;
3042 pos2_is_uv = 1;
3043 }
5d82c453 3044 }
2304df62 3045 }
79072805 3046 else {
777f7c56
EB		 3047 pos2_iv = curlen;
3048 pos2_is_uv = 1;
3049 }
3050
3051 if (!pos2_is_uv && pos2_iv < 0) {
3052 if (!pos1_is_uv && pos1_iv < 0)
1c900557 3053 goto bound_fail;
777f7c56
EB		 3054 pos2_iv = 0;
3055 }
3056 else if (!pos1_is_uv && pos1_iv < 0)
3057 pos1_iv = 0;
3058
3059 if ((UV)pos2_iv < (UV)pos1_iv)
3060 pos2_iv = pos1_iv;
3061 if ((UV)pos2_iv > curlen)
3062 pos2_iv = curlen;
3063
3064 {
3065 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3066 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3067 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
777f7c56 3068 STRLEN byte_len = len;
d931b1be
NC		 3069 STRLEN byte_pos = utf8_curlen
3070 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3071
2154eca7
EB		 3072 if (lvalue && !repl) {
3073 SV * ret;
3074
3075 if (!SvGMAGICAL(sv)) {
3076 if (SvROK(sv)) {
3077 SvPV_force_nolen(sv);
3078 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3079 "Attempt to use reference as lvalue in substr");
3080 }
3081 if (isGV_with_GP(sv))
3082 SvPV_force_nolen(sv);
3083 else if (SvOK(sv)) /* is it defined ? */
3084 (void)SvPOK_only_UTF8(sv);
3085 else
3086 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
781e7547 3087 }
2154eca7
EB		 3088
3089 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3090 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3091 LvTYPE(ret) = 'x';
3092 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3093 LvTARGOFF(ret) = pos;
3094 LvTARGLEN(ret) = len;
3095
3096 SPAGAIN;
3097 PUSHs(ret); /* avoid SvSETMAGIC here */
3098 RETURN;
781e7547
DM		 3099 }
3100
2154eca7 3101 tmps += byte_pos;
bbddc9e0
CS		 3102
3103 if (rvalue) {
3104 SvTAINTED_off(TARG); /* decontaminate */
3105 SvUTF8_off(TARG); /* decontaminate */
3106 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3107#ifdef USE_LOCALE_COLLATE
bbddc9e0 3108 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3109#endif
bbddc9e0
CS		 3110 if (utf8_curlen)
3111 SvUTF8_on(TARG);
3112 }
2154eca7 3113
f7928d6c 3114 if (repl) {
13e30c65
JH		 3115 SV* repl_sv_copy = NULL;
3116
3117 if (repl_need_utf8_upgrade) {
3118 repl_sv_copy = newSVsv(repl_sv);
3119 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3120 repl = SvPV_const(repl_sv_copy, repl_len);
bf32a30c 3121 repl_is_utf8 = DO_UTF8(repl_sv_copy) && repl_len;
13e30c65 3122 }
502d9230
VP		 3123 if (!SvOK(sv))
3124 sv_setpvs(sv, "");
777f7c56 3125 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
9402d6ed 3126 if (repl_is_utf8)
f7928d6c 3127 SvUTF8_on(sv);
ef8d46e8 3128 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3129 }
79072805 3130 }
849ca7ee 3131 SPAGAIN;
bbddc9e0
CS		 3132 if (rvalue) {
3133 SvSETMAGIC(TARG);
3134 PUSHs(TARG);
3135 }
79072805 3136 RETURN;
777f7c56 3137
1c900557 3138bound_fail:
777f7c56
EB		 3139 if (lvalue || repl)
3140 Perl_croak(aTHX_ "substr outside of string");
3141 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3142 RETPUSHUNDEF;
79072805
LW		 3143}
3144
3145PP(pp_vec)
3146{
2154eca7 3147 dVAR; dSP;
1b6737cc
AL		 3148 register const IV size = POPi;
3149 register const IV offset = POPi;
3150 register SV * const src = POPs;
3151 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3152 SV * ret;
a0d0e21e 3153
81e118e0 3154 if (lvalue) { /* it's an lvalue! */
2154eca7
EB		 3155 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3156 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3157 LvTYPE(ret) = 'v';
3158 LvTARG(ret) = SvREFCNT_inc_simple(src);
3159 LvTARGOFF(ret) = offset;
3160 LvTARGLEN(ret) = size;
3161 }
3162 else {
3163 dTARGET;
3164 SvTAINTED_off(TARG); /* decontaminate */
3165 ret = TARG;
79072805
LW		 3166 }
3167
2154eca7
EB		 3168 sv_setuv(ret, do_vecget(src, offset, size));
3169 PUSHs(ret);
79072805
LW		 3170 RETURN;
3171}
3172
3173PP(pp_index)
3174{
97aff369 3175 dVAR; dSP; dTARGET;
79072805
LW		 3176 SV *big;
3177 SV *little;
c445ea15 3178 SV *temp = NULL;
ad66a58c 3179 STRLEN biglen;
2723d216 3180 STRLEN llen = 0;
79072805
LW		 3181 I32 offset;
3182 I32 retval;
73ee8be2
NC		 3183 const char *big_p;
3184 const char *little_p;
2f040f7f
NC		 3185 bool big_utf8;
3186 bool little_utf8;
2723d216 3187 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3188 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3189
e1dccc0d
Z		 3190 if (threeargs)
3191 offset = POPi;
79072805
LW		 3192 little = POPs;
3193 big = POPs;
73ee8be2
NC		 3194 big_p = SvPV_const(big, biglen);
3195 little_p = SvPV_const(little, llen);
3196
e609e586
NC		 3197 big_utf8 = DO_UTF8(big);
3198 little_utf8 = DO_UTF8(little);
3199 if (big_utf8 ^ little_utf8) {
3200 /* One needs to be upgraded. */
2f040f7f
NC		 3201 if (little_utf8 && !PL_encoding) {
3202 /* Well, maybe instead we might be able to downgrade the small
3203 string? */
1eced8f8 3204 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC		 3205 &little_utf8);
3206 if (little_utf8) {
3207 /* If the large string is ISO-8859-1, and it's not possible to
3208 convert the small string to ISO-8859-1, then there is no
3209 way that it could be found anywhere by index. */
3210 retval = -1;
3211 goto fail;
3212 }
e609e586 3213
2f040f7f
NC		 3214 /* At this point, pv is a malloc()ed string. So donate it to temp
3215 to ensure it will get free()d */
3216 little = temp = newSV(0);
73ee8be2
NC		 3217 sv_usepvn(temp, pv, llen);
3218 little_p = SvPVX(little);
e609e586 3219 } else {
73ee8be2
NC		 3220 temp = little_utf8
3221 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f
NC		 3222
3223 if (PL_encoding) {
3224 sv_recode_to_utf8(temp, PL_encoding);
3225 } else {
3226 sv_utf8_upgrade(temp);
3227 }
3228 if (little_utf8) {
3229 big = temp;
3230 big_utf8 = TRUE;
73ee8be2 3231 big_p = SvPV_const(big, biglen);
2f040f7f
NC		 3232 } else {
3233 little = temp;
73ee8be2 3234 little_p = SvPV_const(little, llen);
2f040f7f 3235 }
e609e586
NC		 3236 }
3237 }
73ee8be2
NC		 3238 if (SvGAMAGIC(big)) {
3239 /* Life just becomes a lot easier if I use a temporary here.
3240 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3241 will trigger magic and overloading again, as will fbm_instr()
3242 */
59cd0e26
NC		 3243 big = newSVpvn_flags(big_p, biglen,
3244 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC		 3245 big_p = SvPVX(big);
3246 }
e4e44778 3247 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC		 3248 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3249 warn on undef, and we've already triggered a warning with the
3250 SvPV_const some lines above. We can't remove that, as we need to
3251 call some SvPV to trigger overloading early and find out if the
3252 string is UTF-8.
3253 This is all getting to messy. The API isn't quite clean enough,
3254 because data access has side effects.
3255 */
59cd0e26
NC		 3256 little = newSVpvn_flags(little_p, llen,
3257 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC		 3258 little_p = SvPVX(little);
3259 }
e609e586 3260
d3e26383 3261 if (!threeargs)
2723d216 3262 offset = is_index ? 0 : biglen;
a0ed51b3 3263 else {
ad66a58c 3264 if (big_utf8 && offset > 0)
a0ed51b3 3265 sv_pos_u2b(big, &offset, 0);
73ee8be2
NC		 3266 if (!is_index)
3267 offset += llen;
a0ed51b3 3268 }
79072805
LW		 3269 if (offset < 0)
3270 offset = 0;
ad66a58c
NC		 3271 else if (offset > (I32)biglen)
3272 offset = biglen;
73ee8be2
NC		 3273 if (!(little_p = is_index
3274 ? fbm_instr((unsigned char*)big_p + offset,
3275 (unsigned char*)big_p + biglen, little, 0)
3276 : rninstr(big_p, big_p + offset,
3277 little_p, little_p + llen)))
a0ed51b3 3278 retval = -1;
ad66a58c 3279 else {
73ee8be2 3280 retval = little_p - big_p;
ad66a58c
NC		 3281 if (retval > 0 && big_utf8)
3282 sv_pos_b2u(big, &retval);
3283 }
ef8d46e8 3284 SvREFCNT_dec(temp);
2723d216 3285 fail:
e1dccc0d 3286 PUSHi(retval);
79072805
LW		 3287 RETURN;
3288}
3289
3290PP(pp_sprintf)
3291{
97aff369 3292 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3293 SvTAINTED_off(TARG);
79072805 3294 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3295 TAINT_IF(SvTAINTED(TARG));
79072805
LW		 3296 SP = ORIGMARK;
3297 PUSHTARG;
3298 RETURN;
3299}
3300
79072805
LW		 3301PP(pp_ord)
3302{
97aff369 3303 dVAR; dSP; dTARGET;
1eced8f8 3304
7df053ec 3305 SV *argsv = POPs;
ba210ebe 3306 STRLEN len;
349d4f2f 3307 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3308
799ef3cb 3309 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3310 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3311 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
121910a4
JH		 3312 argsv = tmpsv;
3313 }
79072805 3314
872c91ae 3315 XPUSHu(DO_UTF8(argsv) ?
89ebb4a3 3316 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
5fc32dea 3317 (UV)(*s & 0xff));
68795e93 3318
79072805
LW		 3319 RETURN;
3320}
3321
463ee0b2
LW		 3322PP(pp_chr)
3323{
97aff369 3324 dVAR; dSP; dTARGET;
463ee0b2 3325 char *tmps;
8a064bd6
JH		 3326 UV value;
3327
3328 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3329 ||
3330 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3331 if (IN_BYTES) {
3332 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3333 } else {
3334 (void) POPs; /* Ignore the argument value. */
3335 value = UNICODE_REPLACEMENT;
3336 }
3337 } else {
3338 value = POPu;
3339 }
463ee0b2 3340
862a34c6 3341 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3342
0064a8a9 3343 if (value > 255 && !IN_BYTES) {
eb160463 3344 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3345 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3346 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW		 3347 *tmps = '\0';
3348 (void)SvPOK_only(TARG);
aa6ffa16 3349 SvUTF8_on(TARG);
a0ed51b3
LW		 3350 XPUSHs(TARG);
3351 RETURN;
3352 }
3353
748a9306 3354 SvGROW(TARG,2);
463ee0b2
LW		 3355 SvCUR_set(TARG, 1);
3356 tmps = SvPVX(TARG);
eb160463 3357 *tmps++ = (char)value;
748a9306 3358 *tmps = '\0';
a0d0e21e 3359 (void)SvPOK_only(TARG);
4c5ed6e2 3360
88632417 3361 if (PL_encoding && !IN_BYTES) {
799ef3cb 3362 sv_recode_to_utf8(TARG, PL_encoding);
88632417
JH		 3363 tmps = SvPVX(TARG);
3364 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
4c5ed6e2
TS		 3365 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3366 SvGROW(TARG, 2);
d5a15ac2 3367 tmps = SvPVX(TARG);
4c5ed6e2
TS		 3368 SvCUR_set(TARG, 1);
3369 *tmps++ = (char)value;
88632417 3370 *tmps = '\0';
4c5ed6e2 3371 SvUTF8_off(TARG);
88632417
JH		 3372 }
3373 }
4c5ed6e2 3374
463ee0b2
LW		 3375 XPUSHs(TARG);
3376 RETURN;
3377}
3378
79072805
LW		 3379PP(pp_crypt)
3380{
79072805 3381#ifdef HAS_CRYPT
97aff369 3382 dVAR; dSP; dTARGET;
5f74f29c 3383 dPOPTOPssrl;
85c16d83 3384 STRLEN len;
10516c54 3385 const char *tmps = SvPV_const(left, len);
2bc69dc4 3386
85c16d83 3387 if (DO_UTF8(left)) {
2bc69dc4 3388 /* If Unicode, try to downgrade.
f2791508
JH		 3389 * If not possible, croak.
3390 * Yes, we made this up. */
1b6737cc 3391 SV* const tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3392
f2791508 3393 SvUTF8_on(tsv);
2bc69dc4 3394 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3395 tmps = SvPV_const(tsv, len);
85c16d83 3396 }
05404ffe
JH		 3397# ifdef USE_ITHREADS
3398# ifdef HAS_CRYPT_R
3399 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3400 /* This should be threadsafe because in ithreads there is only
3401 * one thread per interpreter. If this would not be true,
3402 * we would need a mutex to protect this malloc. */
3403 PL_reentrant_buffer->_crypt_struct_buffer =
3404 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3405#if defined(__GLIBC__) || defined(__EMX__)
3406 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3407 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3408 /* work around glibc-2.2.5 bug */
3409 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3410 }
05404ffe 3411#endif
6ab58e4d 3412 }
05404ffe
JH		 3413# endif /* HAS_CRYPT_R */
3414# endif /* USE_ITHREADS */
5f74f29c 3415# ifdef FCRYPT
83003860 3416 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3417# else
83003860 3418 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3419# endif
ec93b65f 3420 SETTARG;
4808266b 3421 RETURN;
79072805 3422#else
b13b2135 3423 DIE(aTHX_
79072805
LW		 3424 "The crypt() function is unimplemented due to excessive paranoia.");
3425#endif
79072805
LW		 3426}
3427
00f254e2
KW		 3428/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3429 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3430
00f254e2 3431/* Generates code to store a unicode codepoint c that is known to occupy
12b093a1
KW		 3432 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1,
3433 * and p is advanced to point to the next available byte after the two bytes */
00f254e2
KW		 3434#define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3435 STMT_START { \
3436 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3437 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3438 } STMT_END
3439
79072805
LW		 3440PP(pp_ucfirst)
3441{
00f254e2
KW		 3442 /* Actually is both lcfirst() and ucfirst(). Only the first character
3443 * changes. This means that possibly we can change in-place, ie., just
3444 * take the source and change that one character and store it back, but not
3445 * if read-only etc, or if the length changes */
3446
97aff369 3447 dVAR;
39644a26 3448 dSP;
d54190f6 3449 SV *source = TOPs;
00f254e2 3450 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC		 3451 STRLEN need;
3452 SV *dest;
00f254e2
KW		 3453 bool inplace; /* ? Convert first char only, in-place */
3454 bool doing_utf8 = FALSE; /* ? using utf8 */
3455 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3456 const int op_type = PL_op->op_type;
d54190f6
NC		 3457 const U8 *s;
3458 U8 *d;
3459 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW		 3460 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3461 * stored as UTF-8 at s. */
3462 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3463 * lowercased) character stored in tmpbuf. May be either
3464 * UTF-8 or not, but in either case is the number of bytes */
d54190f6
NC		 3465
3466 SvGETMAGIC(source);
3467 if (SvOK(source)) {
3468 s = (const U8*)SvPV_nomg_const(source, slen);
3469 } else {
0a0ffbce
RGS		 3470 if (ckWARN(WARN_UNINITIALIZED))
3471 report_uninit(source);
1eced8f8 3472 s = (const U8*)"";
d54190f6
NC		 3473 slen = 0;
3474 }
a0ed51b3 3475
00f254e2
KW		 3476 /* We may be able to get away with changing only the first character, in
3477 * place, but not if read-only, etc. Later we may discover more reasons to
3478 * not convert in-place. */
3479 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3480
3481 /* First calculate what the changed first character should be. This affects
3482 * whether we can just swap it out, leaving the rest of the string unchanged,
3483 * or even if have to convert the dest to UTF-8 when the source isn't */
3484
3485 if (! slen) { /* If empty */
3486 need = 1; /* still need a trailing NUL */
b7576bcb 3487 ulen = 0;
00f254e2
KW		 3488 }
3489 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3490 doing_utf8 = TRUE;
17e95c9d
KW		 3491 ulen = UTF8SKIP(s);
3492 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3493 else toLOWER_utf8(s, tmpbuf, &tculen);
00f254e2 3494
17e95c9d
KW		 3495 /* we can't do in-place if the length changes. */
3496 if (ulen != tculen) inplace = FALSE;
3497 need = slen + 1 - ulen + tculen;
d54190f6 3498 }
00f254e2
KW		 3499 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3500 * latin1 is treated as caseless. Note that a locale takes
3501 * precedence */
167d19f2 3502 ulen = 1; /* Original character is 1 byte */
00f254e2
KW		 3503 tculen = 1; /* Most characters will require one byte, but this will
3504 * need to be overridden for the tricky ones */
3505 need = slen + 1;
3506
3507 if (op_type == OP_LCFIRST) {
d54190f6 3508
00f254e2
KW		 3509 /* lower case the first letter: no trickiness for any character */
3510 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3511 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3512 }
3513 /* is ucfirst() */
3514 else if (IN_LOCALE_RUNTIME) {
3515 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3516 * have upper and title case different
3517 */
3518 }
3519 else if (! IN_UNI_8_BIT) {
3520 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3521 * on EBCDIC machines whatever the
3522 * native function does */
3523 }
3524 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
167d19f2
KW		 3525 UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3526 if (tculen > 1) {
3527 assert(tculen == 2);
3528
3529 /* If the result is an upper Latin1-range character, it can
3530 * still be represented in one byte, which is its ordinal */
3531 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3532 *tmpbuf = (U8) title_ord;
3533 tculen = 1;
00f254e2
KW		 3534 }
3535 else {
167d19f2
KW		 3536 /* Otherwise it became more than one ASCII character (in
3537 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3538 * beyond Latin1, so the number of bytes changed, so can't
3539 * replace just the first character in place. */
3540 inplace = FALSE;
3541
3542 /* If the result won't fit in a byte, the entire result will
3543 * have to be in UTF-8. Assume worst case sizing in
3544 * conversion. (all latin1 characters occupy at most two bytes
3545 * in utf8) */
3546 if (title_ord > 255) {
3547 doing_utf8 = TRUE;
3548 convert_source_to_utf8 = TRUE;
3549 need = slen * 2 + 1;
3550
3551 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3552 * (both) characters whose title case is above 255 is
3553 * 2. */
3554 ulen = 2;
3555 }
3556 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3557 need = slen + 1 + 1;
3558 }
00f254e2 3559 }
167d19f2 3560 }
00f254e2
KW		 3561 } /* End of use Unicode (Latin1) semantics */
3562 } /* End of changing the case of the first character */
3563
3564 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3565 * generate the result */
3566 if (inplace) {
3567
3568 /* We can convert in place. This means we change just the first
3569 * character without disturbing the rest; no need to grow */
d54190f6
NC		 3570 dest = source;
3571 s = d = (U8*)SvPV_force_nomg(source, slen);
3572 } else {
3573 dTARGET;
3574
3575 dest = TARG;
3576
00f254e2
KW		 3577 /* Here, we can't convert in place; we earlier calculated how much
3578 * space we will need, so grow to accommodate that */
d54190f6 3579 SvUPGRADE(dest, SVt_PV);
3b416f41 3580 d = (U8*)SvGROW(dest, need);
d54190f6
NC		 3581 (void)SvPOK_only(dest);
3582
3583 SETs(dest);
d54190f6 3584 }
44bc797b 3585
d54190f6 3586 if (doing_utf8) {
00f254e2
KW		 3587 if (! inplace) {
3588 if (! convert_source_to_utf8) {
3589
3590 /* Here both source and dest are in UTF-8, but have to create
3591 * the entire output. We initialize the result to be the
3592 * title/lower cased first character, and then append the rest
3593 * of the string. */
3594 sv_setpvn(dest, (char*)tmpbuf, tculen);
3595 if (slen > ulen) {
3596 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3597 }
3598 }
3599 else {
3600 const U8 *const send = s + slen;
3601
3602 /* Here the dest needs to be in UTF-8, but the source isn't,
3603 * except we earlier UTF-8'd the first character of the source
3604 * into tmpbuf. First put that into dest, and then append the
3605 * rest of the source, converting it to UTF-8 as we go. */
3606
3607 /* Assert tculen is 2 here because the only two characters that
3608 * get to this part of the code have 2-byte UTF-8 equivalents */
3609 *d++ = *tmpbuf;
3610 *d++ = *(tmpbuf + 1);
3611 s++; /* We have just processed the 1st char */
3612
3613 for (; s < send; s++) {
3614 d = uvchr_to_utf8(d, *s);
3615 }
3616 *d = '\0';
3617 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3618 }
d54190f6 3619 SvUTF8_on(dest);
a0ed51b3 3620 }
00f254e2 3621 else { /* in-place UTF-8. Just overwrite the first character */
d54190f6
NC		 3622 Copy(tmpbuf, d, tculen, U8);
3623 SvCUR_set(dest, need - 1);
a0ed51b3 3624 }
a0ed51b3 3625 }
00f254e2
KW		 3626 else { /* Neither source nor dest are in or need to be UTF-8 */
3627 if (slen) {
2de3dbcc 3628 if (IN_LOCALE_RUNTIME) {
31351b04 3629 TAINT;
d54190f6 3630 SvTAINTED_on(dest);
31351b04 3631 }
00f254e2
KW		 3632 if (inplace) { /* in-place, only need to change the 1st char */
3633 *d = *tmpbuf;
3634 }
3635 else { /* Not in-place */
3636
3637 /* Copy the case-changed character(s) from tmpbuf */
3638 Copy(tmpbuf, d, tculen, U8);
3639 d += tculen - 1; /* Code below expects d to point to final
3640 * character stored */
3641 }
3642 }
3643 else { /* empty source */
3644 /* See bug #39028: Don't taint if empty */
d54190f6
NC		 3645 *d = *s;
3646 }
3647
00f254e2
KW		 3648 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3649 * the destination to retain that flag */
d54190f6
NC		 3650 if (SvUTF8(source))
3651 SvUTF8_on(dest);
3652
00f254e2 3653 if (!inplace) { /* Finish the rest of the string, unchanged */
d54190f6
NC		 3654 /* This will copy the trailing NUL */
3655 Copy(s + 1, d + 1, slen, U8);
3656 SvCUR_set(dest, need - 1);
bbce6d69 3657 }
bbce6d69 3658 }
539689e7
FC		 3659 if (dest != source && SvTAINTED(source))
3660 SvTAINT(dest);
d54190f6 3661 SvSETMAGIC(dest);
79072805
LW		 3662 RETURN;
3663}
3664
67306194
NC		 3665/* There's so much setup/teardown code common between uc and lc, I wonder if
3666 it would be worth merging the two, and just having a switch outside each
00f254e2 3667 of the three tight loops. There is less and less commonality though */
79072805
LW		 3668PP(pp_uc)
3669{
97aff369 3670 dVAR;
39644a26 3671 dSP;
67306194 3672 SV *source = TOPs;
463ee0b2 3673 STRLEN len;
67306194
NC		 3674 STRLEN min;
3675 SV *dest;
3676 const U8 *s;
3677 U8 *d;
79072805 3678
67306194
NC		 3679 SvGETMAGIC(source);
3680
3681 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
00f254e2
KW		 3682 && SvTEMP(source) && !DO_UTF8(source)
3683 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3684
3685 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3686 * make the loop tight, so we overwrite the source with the dest before
3687 * looking at it, and we need to look at the original source
3688 * afterwards. There would also need to be code added to handle
3689 * switching to not in-place in midstream if we run into characters
3690 * that change the length.
3691 */
67306194
NC		 3692 dest = source;
3693 s = d = (U8*)SvPV_force_nomg(source, len);
3694 min = len + 1;
3695 } else {
a0ed51b3 3696 dTARGET;
a0ed51b3 3697
67306194 3698 dest = TARG;
128c9517 3699
67306194
NC		 3700 /* The old implementation would copy source into TARG at this point.
3701 This had the side effect that if source was undef, TARG was now
3702 an undefined SV with PADTMP set, and they don't warn inside
3703 sv_2pv_flags(). However, we're now getting the PV direct from
3704 source, which doesn't have PADTMP set, so it would warn. Hence the
3705 little games. */
3706
3707 if (SvOK(source)) {
3708 s = (const U8*)SvPV_nomg_const(source, len);
3709 } else {
0a0ffbce
RGS		 3710 if (ckWARN(WARN_UNINITIALIZED))
3711 report_uninit(source);
1eced8f8 3712 s = (const U8*)"";
67306194 3713 len = 0;
a0ed51b3 3714 }
67306194
NC		 3715 min = len + 1;
3716
3717 SvUPGRADE(dest, SVt_PV);
3b416f41 3718 d = (U8*)SvGROW(dest, min);
67306194
NC		 3719 (void)SvPOK_only(dest);
3720
3721 SETs(dest);
a0ed51b3 3722 }
31351b04 3723
67306194
NC		 3724 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3725 to check DO_UTF8 again here. */
3726
3727 if (DO_UTF8(source)) {
3728 const U8 *const send = s + len;
3729 U8 tmpbuf[UTF8_MAXBYTES+1];
3730
4c8a458a
KW		 3731 /* All occurrences of these are to be moved to follow any other marks.
3732 * This is context-dependent. We may not be passed enough context to
3733 * move the iota subscript beyond all of them, but we do the best we can
3734 * with what we're given. The result is always better than if we
3735 * hadn't done this. And, the problem would only arise if we are
3736 * passed a character without all its combining marks, which would be
3737 * the caller's mistake. The information this is based on comes from a
3738 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3739 * itself) and so can't be checked properly to see if it ever gets
3740 * revised. But the likelihood of it changing is remote */
00f254e2 3741 bool in_iota_subscript = FALSE;
00f254e2 3742
67306194 3743 while (s < send) {
3e16b0e6
KW		 3744 STRLEN u;
3745 STRLEN ulen;
3746 UV uv;
00f254e2 3747 if (in_iota_subscript && ! is_utf8_mark(s)) {
3e16b0e6 3748
00f254e2
KW		 3749 /* A non-mark. Time to output the iota subscript */
3750#define GREEK_CAPITAL_LETTER_IOTA 0x0399
3751#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3752
3753 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3754 in_iota_subscript = FALSE;
8e058693 3755 }
00f254e2 3756
8e058693
KW		 3757 /* Then handle the current character. Get the changed case value
3758 * and copy it to the output buffer */
00f254e2 3759
8e058693
KW		 3760 u = UTF8SKIP(s);
3761 uv = toUPPER_utf8(s, tmpbuf, &ulen);
3762 if (uv == GREEK_CAPITAL_LETTER_IOTA
3763 && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3764 {
3765 in_iota_subscript = TRUE;
3766 }
3767 else {
3768 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3769 /* If the eventually required minimum size outgrows the
3770 * available space, we need to grow. */
3771 const UV o = d - (U8*)SvPVX_const(dest);
3772
3773 /* If someone uppercases one million U+03B0s we SvGROW()
3774 * one million times. Or we could try guessing how much to
3775 * allocate without allocating too much. Such is life.
3776 * See corresponding comment in lc code for another option
3777 * */
3778 SvGROW(dest, min);
3779 d = (U8*)SvPVX(dest) + o;
3780 }
3781 Copy(tmpbuf, d, ulen, U8);
3782 d += ulen;
3783 }
3784 s += u;
67306194 3785 }
4c8a458a
KW		 3786 if (in_iota_subscript) {
3787 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3788 }
67306194
NC		 3789 SvUTF8_on(dest);
3790 *d = '\0';
3791 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4c8a458a
KW		 3792 }
3793 else { /* Not UTF-8 */
67306194
NC		 3794 if (len) {
3795 const U8 *const send = s + len;
00f254e2
KW		 3796
3797 /* Use locale casing if in locale; regular style if not treating
3798 * latin1 as having case; otherwise the latin1 casing. Do the
3799 * whole thing in a tight loop, for speed, */
2de3dbcc 3800 if (IN_LOCALE_RUNTIME) {
31351b04 3801 TAINT;
67306194
NC		 3802 SvTAINTED_on(dest);
3803 for (; s < send; d++, s++)
3804 *d = toUPPER_LC(*s);
31351b04 3805 }
00f254e2
KW		 3806 else if (! IN_UNI_8_BIT) {
3807 for (; s < send; d++, s++) {
67306194 3808 *d = toUPPER(*s);
00f254e2 3809 }
31351b04 3810 }
00f254e2
KW		 3811 else {
3812 for (; s < send; d++, s++) {
3813 *d = toUPPER_LATIN1_MOD(*s);
e67da29c 3814 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) continue;
00f254e2
KW		 3815
3816 /* The mainstream case is the tight loop above. To avoid
3817 * extra tests in that, all three characters that require
3818 * special handling are mapped by the MOD to the one tested
3819 * just above.
3820 * Use the source to distinguish between the three cases */
3821
3822 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3823
3824 /* uc() of this requires 2 characters, but they are
3825 * ASCII. If not enough room, grow the string */
3826 if (SvLEN(dest) < ++min) {
3827 const UV o = d - (U8*)SvPVX_const(dest);
3828 SvGROW(dest, min);
3829 d = (U8*)SvPVX(dest) + o;
3830 }
3831 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3832 continue; /* Back to the tight loop; still in ASCII */
3833 }
3834
3835 /* The other two special handling characters have their
3836 * upper cases outside the latin1 range, hence need to be
3837 * in UTF-8, so the whole result needs to be in UTF-8. So,
3838 * here we are somewhere in the middle of processing a
3839 * non-UTF-8 string, and realize that we will have to convert
3840 * the whole thing to UTF-8. What to do? There are
3841 * several possibilities. The simplest to code is to
3842 * convert what we have so far, set a flag, and continue on
3843 * in the loop. The flag would be tested each time through
3844 * the loop, and if set, the next character would be
3845 * converted to UTF-8 and stored. But, I (khw) didn't want
3846 * to slow down the mainstream case at all for this fairly
3847 * rare case, so I didn't want to add a test that didn't
3848 * absolutely have to be there in the loop, besides the
3849 * possibility that it would get too complicated for
3850 * optimizers to deal with. Another possibility is to just
3851 * give up, convert the source to UTF-8, and restart the
3852 * function that way. Another possibility is to convert
3853 * both what has already been processed and what is yet to
3854 * come separately to UTF-8, then jump into the loop that
3855 * handles UTF-8. But the most efficient time-wise of the
3856 * ones I could think of is what follows, and turned out to
3857 * not require much extra code. */
3858
3859 /* Convert what we have so far into UTF-8, telling the
3860 * function that we know it should be converted, and to
3861 * allow extra space for what we haven't processed yet.
3862 * Assume the worst case space requirements for converting
3863 * what we haven't processed so far: that it will require
3864 * two bytes for each remaining source character, plus the
3865 * NUL at the end. This may cause the string pointer to
3866 * move, so re-find it. */
3867
3868 len = d - (U8*)SvPVX_const(dest);
3869 SvCUR_set(dest, len);
3870 len = sv_utf8_upgrade_flags_grow(dest,
3871 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3872 (send -s) * 2 + 1);
3873 d = (U8*)SvPVX(dest) + len;
3874
00f254e2
KW		 3875 /* Now process the remainder of the source, converting to
3876 * upper and UTF-8. If a resulting byte is invariant in
3877 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3878 * append it to the output. */
00f254e2 3879 for (; s < send; s++) {
0ecfbd28
KW		 3880 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3881 d += len;
00f254e2
KW		 3882 }
3883
3884 /* Here have processed the whole source; no need to continue
3885 * with the outer loop. Each character has been converted
3886 * to upper case and converted to UTF-8 */
3887
3888 break;
3889 } /* End of processing all latin1-style chars */
3890 } /* End of processing all chars */
3891 } /* End of source is not empty */
3892
67306194 3893 if (source != dest) {
00f254e2 3894 *d = '\0'; /* Here d points to 1 after last char, add NUL */
67306194
NC		 3895 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3896 }
00f254e2 3897 } /* End of isn't utf8 */
539689e7
FC		 3898 if (dest != source && SvTAINTED(source))
3899 SvTAINT(dest);
67306194 3900 SvSETMAGIC(dest);
79072805
LW		 3901 RETURN;
3902}
3903
3904PP(pp_lc)
3905{
97aff369 3906 dVAR;
39644a26 3907 dSP;
ec9af7d4 3908 SV *source = TOPs;
463ee0b2 3909 STRLEN len;
ec9af7d4
NC		 3910 STRLEN min;
3911 SV *dest;
3912 const U8 *s;
3913 U8 *d;
79072805 3914
ec9af7d4
NC		 3915 SvGETMAGIC(source);
3916
3917 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
17fa0776 3918 && SvTEMP(source) && !DO_UTF8(source)) {
ec9af7d4 3919
00f254e2
KW		 3920 /* We can convert in place, as lowercasing anything in the latin1 range
3921 * (or else DO_UTF8 would have been on) doesn't lengthen it */
ec9af7d4
NC		 3922 dest = source;
3923 s = d = (U8*)SvPV_force_nomg(source, len);
3924 min = len + 1;
3925 } else {
a0ed51b3 3926 dTARGET;
a0ed51b3 3927
ec9af7d4
NC		 3928 dest = TARG;
3929
3930 /* The old implementation would copy source into TARG at this point.
3931 This had the side effect that if source was undef, TARG was now
3932 an undefined SV with PADTMP set, and they don't warn inside
3933 sv_2pv_flags(). However, we're now getting the PV direct from
3934 source, which doesn't have PADTMP set, so it would warn. Hence the
3935 little games. */
3936
3937 if (SvOK(source)) {
3938 s = (const U8*)SvPV_nomg_const(source, len);
3939 } else {
0a0ffbce
RGS		 3940 if (ckWARN(WARN_UNINITIALIZED))
3941 report_uninit(source);
1eced8f8 3942 s = (const U8*)"";
ec9af7d4 3943 len = 0;
a0ed51b3 3944 }
ec9af7d4 3945 min = len + 1;
128c9517 3946
ec9af7d4 3947 SvUPGRADE(dest, SVt_PV);
3b416f41 3948 d = (U8*)SvGROW(dest, min);
ec9af7d4
NC		 3949 (void)SvPOK_only(dest);
3950
3951 SETs(dest);
3952 }
3953
3954 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3955 to check DO_UTF8 again here. */
3956
3957 if (DO_UTF8(source)) {
3958 const U8 *const send = s + len;
3959 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3960
3961 while (s < send) {
06b5486a
KW		 3962 const STRLEN u = UTF8SKIP(s);
3963 STRLEN ulen;
00f254e2 3964
06b5486a 3965 toLOWER_utf8(s, tmpbuf, &ulen);
00f254e2 3966
06b5486a
KW		 3967 /* Here is where we would do context-sensitive actions. See the
3968 * commit message for this comment for why there isn't any */
00f254e2 3969
06b5486a 3970 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
fdb34c52 3971
06b5486a
KW		 3972 /* If the eventually required minimum size outgrows the
3973 * available space, we need to grow. */
3974 const UV o = d - (U8*)SvPVX_const(dest);
fdb34c52 3975
06b5486a
KW		 3976 /* If someone lowercases one million U+0130s we SvGROW() one
3977 * million times. Or we could try guessing how much to
3978 * allocate without allocating too much. Such is life.
3979 * Another option would be to grow an extra byte or two more
3980 * each time we need to grow, which would cut down the million
3981 * to 500K, with little waste */
3982 SvGROW(dest, min);
3983 d = (U8*)SvPVX(dest) + o;
3984 }
86510fb1 3985
06b5486a
KW		 3986 /* Copy the newly lowercased letter to the output buffer we're
3987 * building */
3988 Copy(tmpbuf, d, ulen, U8);
3989 d += ulen;
3990 s += u;
00f254e2 3991 } /* End of looping through the source string */
ec9af7d4
NC		 3992 SvUTF8_on(dest);
3993 *d = '\0';
3994 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
00f254e2 3995 } else { /* Not utf8 */
31351b04 3996 if (len) {
ec9af7d4 3997 const U8 *const send = s + len;
00f254e2
KW		 3998
3999 /* Use locale casing if in locale; regular style if not treating
4000 * latin1 as having case; otherwise the latin1 casing. Do the
4001 * whole thing in a tight loop, for speed, */
2de3dbcc 4002 if (IN_LOCALE_RUNTIME) {
31351b04 4003 TAINT;
ec9af7d4
NC		 4004 SvTAINTED_on(dest);
4005 for (; s < send; d++, s++)
4006 *d = toLOWER_LC(*s);
31351b04 4007 }
00f254e2
KW		 4008 else if (! IN_UNI_8_BIT) {
4009 for (; s < send; d++, s++) {
ec9af7d4 4010 *d = toLOWER(*s);
00f254e2
KW		 4011 }
4012 }
4013 else {
4014 for (; s < send; d++, s++) {
4015 *d = toLOWER_LATIN1(*s);
4016 }
31351b04 4017 }
bbce6d69 4018 }
ec9af7d4
NC		 4019 if (source != dest) {
4020 *d = '\0';
4021 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4022 }
79072805 4023 }
539689e7
FC		 4024 if (dest != source && SvTAINTED(source))
4025 SvTAINT(dest);
ec9af7d4 4026 SvSETMAGIC(dest);
79072805
LW		 4027 RETURN;
4028}
4029
a0d0e21e 4030PP(pp_quotemeta)
79072805 4031{
97aff369 4032 dVAR; dSP; dTARGET;
1b6737cc 4033 SV * const sv = TOPs;
a0d0e21e 4034 STRLEN len;
0d46e09a 4035 register const char *s = SvPV_const(sv,len);
79072805 4036
7e2040f0 4037 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4038 if (len) {
1b6737cc 4039 register char *d;
862a34c6 4040 SvUPGRADE(TARG, SVt_PV);
c07a80fd 4041 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 4042 d = SvPVX(TARG);
7e2040f0 4043 if (DO_UTF8(sv)) {
0dd2cdef 4044 while (len) {
fd400ab9 4045 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW		 4046 STRLEN ulen = UTF8SKIP(s);
4047 if (ulen > len)
4048 ulen = len;
4049 len -= ulen;
4050 while (ulen--)
4051 *d++ = *s++;
4052 }
4053 else {
4054 if (!isALNUM(*s))
4055 *d++ = '\\';
4056 *d++ = *s++;
4057 len--;
4058 }
4059 }
7e2040f0 4060 SvUTF8_on(TARG);
0dd2cdef
LW		 4061 }
4062 else {
4063 while (len--) {
4064 if (!isALNUM(*s))
4065 *d++ = '\\';
4066 *d++ = *s++;
4067 }
79072805 4068 }
a0d0e21e 4069 *d = '\0';
349d4f2f 4070 SvCUR_set(TARG, d - SvPVX_const(TARG));
3aa33fe5 4071 (void)SvPOK_only_UTF8(TARG);
79072805 4072 }
a0d0e21e
LW		 4073 else
4074 sv_setpvn(TARG, s, len);
ec93b65f 4075 SETTARG;
79072805
LW		 4076 RETURN;
4077}
4078
a0d0e21e 4079/* Arrays. */
79072805 4080
a0d0e21e 4081PP(pp_aslice)
79072805 4082{
97aff369 4083 dVAR; dSP; dMARK; dORIGMARK;
502c6561 4084 register AV *const av = MUTABLE_AV(POPs);
1b6737cc 4085 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
79072805 4086
a0d0e21e 4087 if (SvTYPE(av) == SVt_PVAV) {
4ad10a0b
VP		 4088 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4089 bool can_preserve = FALSE;
4090
4091 if (localizing) {
4092 MAGIC *mg;
4093 HV *stash;
4094
4095 can_preserve = SvCANEXISTDELETE(av);
4096 }
4097
4098 if (lval && localizing) {
1b6737cc 4099 register SV **svp;
748a9306 4100 I32 max = -1;
924508f0 4101 for (svp = MARK + 1; svp <= SP; svp++) {
4ea561bc 4102 const I32 elem = SvIV(*svp);
748a9306
LW		 4103 if (elem > max)
4104 max = elem;
4105 }
4106 if (max > AvMAX(av))
4107 av_extend(av, max);
4108 }
4ad10a0b 4109
a0d0e21e 4110 while (++MARK <= SP) {
1b6737cc 4111 register SV **svp;
4ea561bc 4112 I32 elem = SvIV(*MARK);
4ad10a0b 4113 bool preeminent = TRUE;
a0d0e21e 4114
4ad10a0b
VP		 4115 if (localizing && can_preserve) {
4116 /* If we can determine whether the element exist,
4117 * Try to preserve the existenceness of a tied array
4118 * element by using EXISTS and DELETE if possible.
4119 * Fallback to FETCH and STORE otherwise. */
4120 preeminent = av_exists(av, elem);
4121 }
4122
a0d0e21e
LW		 4123 svp = av_fetch(av, elem, lval);
4124 if (lval) {
3280af22 4125 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 4126 DIE(aTHX_ PL_no_aelem, elem);
4ad10a0b
VP		 4127 if (localizing) {
4128 if (preeminent)
4129 save_aelem(av, elem, svp);
4130 else
4131 SAVEADELETE(av, elem);
4132 }
79072805 4133 }
3280af22 4134 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 4135 }
4136 }
748a9306 4137 if (GIMME != G_ARRAY) {
a0d0e21e 4138 MARK = ORIGMARK;
04ab2c87 4139 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e
LW		 4140 SP = MARK;
4141 }
79072805
LW		 4142 RETURN;
4143}
4144
cba5a3b0
DG		 4145/* Smart dereferencing for keys, values and each */
4146PP(pp_rkeys)
4147{
4148 dVAR;
4149 dSP;
4150 dPOPss;
4151
7ac5715b
FC		 4152 SvGETMAGIC(sv);
4153
4154 if (
4155 !SvROK(sv)
4156 || (sv = SvRV(sv),
4157 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4158 || SvOBJECT(sv)
4159 )
4160 ) {
4161 DIE(aTHX_
4162 "Type of argument to %s must be unblessed hashref or arrayref",
4c540399 4163 PL_op_desc[PL_op->op_type] );
cba5a3b0
DG		 4164 }
4165
d8065907
FC		 4166 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4167 DIE(aTHX_
4168 "Can't modify %s in %s",
4169 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4170 );
4171
cba5a3b0
DG		 4172 /* Delegate to correct function for op type */
4173 PUSHs(sv);
4174 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4175 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4176 }
4177 else {
4178 return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4179 }
4180}
4181
878d132a
NC		 4182PP(pp_aeach)
4183{
4184 dVAR;
4185 dSP;
502c6561 4186 AV *array = MUTABLE_AV(POPs);
878d132a 4187 const I32 gimme = GIMME_V;
453d94a9 4188 IV *iterp = Perl_av_iter_p(aTHX_ array);
878d132a
NC		 4189 const IV current = (*iterp)++;
4190
4191 if (current > av_len(array)) {
4192 *iterp = 0;
4193 if (gimme == G_SCALAR)
4194 RETPUSHUNDEF;
4195 else
4196 RETURN;
4197 }
4198
4199 EXTEND(SP, 2);
e1dccc0d 4200 mPUSHi(current);
878d132a
NC		 4201 if (gimme == G_ARRAY) {
4202 SV **const element = av_fetch(array, current, 0);
4203 PUSHs(element ? *element : &PL_sv_undef);
4204 }
4205 RETURN;
4206}
4207
4208PP(pp_akeys)
4209{
4210 dVAR;
4211 dSP;
502c6561 4212 AV *array = MUTABLE_AV(POPs);
878d132a
NC		 4213 const I32 gimme = GIMME_V;
4214
4215 *Perl_av_iter_p(aTHX_ array) = 0;
4216
4217 if (gimme == G_SCALAR) {
4218 dTARGET;
4219 PUSHi(av_len(array) + 1);
4220 }
4221 else if (gimme == G_ARRAY) {
4222 IV n = Perl_av_len(aTHX_ array);
e1dccc0d 4223 IV i;
878d132a
NC		 4224
4225 EXTEND(SP, n + 1);
4226
cba5a3b0 4227 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
e1dccc0d 4228 for (i = 0; i <= n; i++) {
878d132a
NC		 4229 mPUSHi(i);
4230 }
4231 }
4232 else {
4233 for (i = 0; i <= n; i++) {
4234 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4235 PUSHs(elem ? *elem : &PL_sv_undef);
4236 }
4237 }
4238 }
4239 RETURN;
4240}
4241
79072805
LW		 4242/* Associative arrays. */
4243
4244PP(pp_each)
4245{
97aff369 4246 dVAR;
39644a26 4247 dSP;
85fbaab2 4248 HV * hash = MUTABLE_HV(POPs);
c07a80fd 4249 HE *entry;
f54cb97a 4250 const I32 gimme = GIMME_V;
8ec5e241 4251
c07a80fd 4252 PUTBACK;
c750a3ec 4253 /* might clobber stack_sp */
6d822dc4 4254 entry = hv_iternext(hash);
c07a80fd 4255 SPAGAIN;
79072805 4256
79072805
LW		 4257 EXTEND(SP, 2);
4258 if (entry) {
1b6737cc 4259 SV* const sv = hv_iterkeysv(entry);
574c8022 4260 PUSHs(sv); /* won't clobber stack_sp */
54310121 4261 if (gimme == G_ARRAY) {
59af0135 4262 SV *val;
c07a80fd 4263 PUTBACK;
c750a3ec 4264 /* might clobber stack_sp */
6d822dc4 4265 val = hv_iterval(hash, entry);
c07a80fd 4266 SPAGAIN;
59af0135 4267 PUSHs(val);
79072805 4268 }
79072805 4269 }
54310121 4270 else if (gimme == G_SCALAR)
79072805
LW		 4271 RETPUSHUNDEF;
4272
4273 RETURN;
4274}
4275
7332a6c4
VP		 4276STATIC OP *
4277S_do_delete_local(pTHX)
79072805 4278{
97aff369 4279 dVAR;
39644a26 4280 dSP;
f54cb97a 4281 const I32 gimme = GIMME_V;
7332a6c4
VP		 4282 const MAGIC *mg;
4283 HV *stash;
4284
4285 if (PL_op->op_private & OPpSLICE) {
4286 dMARK; dORIGMARK;
4287 SV * const osv = POPs;
4288 const bool tied = SvRMAGICAL(osv)
4289 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4290 const bool can_preserve = SvCANEXISTDELETE(osv)
4291 || mg_find((const SV *)osv, PERL_MAGIC_env);
4292 const U32 type = SvTYPE(osv);
4293 if (type == SVt_PVHV) { /* hash element */
4294 HV * const hv = MUTABLE_HV(osv);
4295 while (++MARK <= SP) {
4296 SV * const keysv = *MARK;
4297 SV *sv = NULL;
4298 bool preeminent = TRUE;
4299 if (can_preserve)
4300 preeminent = hv_exists_ent(hv, keysv, 0);
4301 if (tied) {
4302 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4303 if (he)
4304 sv = HeVAL(he);
4305 else
4306 preeminent = FALSE;
4307 }
4308 else {
4309 sv = hv_delete_ent(hv, keysv, 0, 0);
4310 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4311 }
4312 if (preeminent) {
4313 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4314 if (tied) {
4315 *MARK = sv_mortalcopy(sv);
4316 mg_clear(sv);
4317 } else
4318 *MARK = sv;
4319 }
4320 else {
4321 SAVEHDELETE(hv, keysv);
4322 *MARK = &PL_sv_undef;
4323 }
4324 }
4325 }
4326 else if (type == SVt_PVAV) { /* array element */
4327 if (PL_op->op_flags & OPf_SPECIAL) {
4328 AV * const av = MUTABLE_AV(osv);
4329 while (++MARK <= SP) {
4330 I32 idx = SvIV(*MARK);
4331 SV *sv = NULL;
4332 bool preeminent = TRUE;
4333 if (can_preserve)
4334 preeminent = av_exists(av, idx);
4335 if (tied) {
4336 SV **svp = av_fetch(av, idx, 1);
4337 if (svp)
4338 sv = *svp;
4339 else
4340 preeminent = FALSE;
4341 }
4342 else {
4343 sv = av_delete(av, idx, 0);
4344 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4345 }
4346 if (preeminent) {
4347 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4348 if (tied) {
4349 *MARK = sv_mortalcopy(sv);
4350 mg_clear(sv);
4351 } else
4352 *MARK = sv;
4353 }
4354 else {
4355 SAVEADELETE(av, idx);
4356 *MARK = &PL_sv_undef;
4357 }
4358 }
4359 }
4360 }
4361 else
4362 DIE(aTHX_ "Not a HASH reference");
4363 if (gimme == G_VOID)
4364 SP = ORIGMARK;
4365 else if (gimme == G_SCALAR) {
4366 MARK = ORIGMARK;
4367 if (SP > MARK)
4368 *++MARK = *SP;
4369 else
4370 *++MARK = &PL_sv_undef;
4371 SP = MARK;
4372 }
4373 }
4374 else {
4375 SV * const keysv = POPs;
4376 SV * const osv = POPs;
4377 const bool tied = SvRMAGICAL(osv)
4378 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4379 const bool can_preserve = SvCANEXISTDELETE(osv)
4380 || mg_find((const SV *)osv, PERL_MAGIC_env);
4381 const U32 type = SvTYPE(osv);
4382 SV *sv = NULL;
4383 if (type == SVt_PVHV) {
4384 HV * const hv = MUTABLE_HV(osv);
4385 bool preeminent = TRUE;
4386 if (can_preserve)
4387 preeminent = hv_exists_ent(hv, keysv, 0);
4388 if (tied) {
4389 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4390 if (he)
4391 sv = HeVAL(he);
4392 else
4393 preeminent = FALSE;
4394 }
4395 else {
4396 sv = hv_delete_ent(hv, keysv, 0, 0);
4397 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4398 }
4399 if (preeminent) {
4400 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4401 if (tied) {
4402 SV *nsv = sv_mortalcopy(sv);
4403 mg_clear(sv);
4404 sv = nsv;
4405 }
4406 }
4407 else
4408 SAVEHDELETE(hv, keysv);
4409 }
4410 else if (type == SVt_PVAV) {
4411 if (PL_op->op_flags & OPf_SPECIAL) {
4412 AV * const av = MUTABLE_AV(osv);
4413 I32 idx = SvIV(keysv);
4414 bool preeminent = TRUE;
4415 if (can_preserve)
4416 preeminent = av_exists(av, idx);
4417 if (tied) {
4418 SV **svp = av_fetch(av, idx, 1);
4419 if (svp)
4420 sv = *svp;
4421 else
4422 preeminent = FALSE;
4423 }
4424 else {
4425 sv = av_delete(av, idx, 0);
4426 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4427 }
4428 if (preeminent) {
4429 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4430 if (tied) {
4431 SV *nsv = sv_mortalcopy(sv);
4432 mg_clear(sv);
4433 sv = nsv;
4434 }
4435 }
4436 else
4437 SAVEADELETE(av, idx);
4438 }
4439 else
4440 DIE(aTHX_ "panic: avhv_delete no longer supported");
4441 }
4442 else
4443 DIE(aTHX_ "Not a HASH reference");
4444 if (!sv)
4445 sv = &PL_sv_undef;
4446 if (gimme != G_VOID)
4447 PUSHs(sv);
4448 }
4449
4450 RETURN;
4451}
4452
4453PP(pp_delete)
4454{
4455 dVAR;
4456 dSP;
4457 I32 gimme;
4458 I32 discard;
4459
4460 if (PL_op->op_private & OPpLVAL_INTRO)
4461 return do_delete_local();
4462
4463 gimme = GIMME_V;
4464 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5f05dabc 4465
533c011a 4466 if (PL_op->op_private & OPpSLICE) {
5f05dabc 4467 dMARK; dORIGMARK;
85fbaab2 4468 HV * const hv = MUTABLE_HV(POPs);
1b6737cc 4469 const U32 hvtype = SvTYPE(hv);
01020589
GS		 4470 if (hvtype == SVt_PVHV) { /* hash element */
4471 while (++MARK <= SP) {
1b6737cc 4472 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 4473 *MARK = sv ? sv : &PL_sv_undef;
4474 }
5f05dabc 4475 }
6d822dc4
MS		 4476 else if (hvtype == SVt_PVAV) { /* array element */
4477 if (PL_op->op_flags & OPf_SPECIAL) {
4478 while (++MARK <= SP) {
502c6561 4479 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
6d822dc4
MS		 4480 *MARK = sv ? sv : &PL_sv_undef;
4481 }
4482 }
01020589
GS		 4483 }
4484 else
4485 DIE(aTHX_ "Not a HASH reference");
54310121 4486 if (discard)
4487 SP = ORIGMARK;
4488 else if (gimme == G_SCALAR) {
5f05dabc 4489 MARK = ORIGMARK;
9111c9c0
DM		 4490 if (SP > MARK)
4491 *++MARK = *SP;
4492 else
4493 *++MARK = &PL_sv_undef;
5f05dabc 4494 SP = MARK;
4495 }
4496 }
4497 else {
4498 SV *keysv = POPs;
85fbaab2 4499 HV * const hv = MUTABLE_HV(POPs);
295d248e 4500 SV *sv = NULL;
97fcbf96
MB		 4501 if (SvTYPE(hv) == SVt_PVHV)
4502 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 4503 else if (SvTYPE(hv) == SVt_PVAV) {
4504 if (PL_op->op_flags & OPf_SPECIAL)
502c6561 4505 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
af288a60
HS		 4506 else
4507 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 4508 }
97fcbf96 4509 else
cea2e8a9 4510 DIE(aTHX_ "Not a HASH reference");
5f05dabc 4511 if (!sv)
3280af22 4512 sv = &PL_sv_undef;
54310121 4513 if (!discard)
4514 PUSHs(sv);
79072805 4515 }
79072805
LW		 4516 RETURN;
4517}
4518
a0d0e21e 4519PP(pp_exists)
79072805 4520{
97aff369 4521 dVAR;
39644a26 4522 dSP;
afebc493
GS		 4523 SV *tmpsv;
4524 HV *hv;
4525
4526 if (PL_op->op_private & OPpEXISTS_SUB) {
4527 GV *gv;
0bd48802 4528 SV * const sv = POPs;
f2c0649b 4529 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
afebc493
GS		 4530 if (cv)
4531 RETPUSHYES;
4532 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4533 RETPUSHYES;
4534 RETPUSHNO;
4535 }
4536 tmpsv = POPs;
85fbaab2 4537 hv = MUTABLE_HV(POPs);
c750a3ec 4538 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 4539 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 4540 RETPUSHYES;
ef54e1a4
JH		 4541 }
4542 else if (SvTYPE(hv) == SVt_PVAV) {
01020589 4543 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
502c6561 4544 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
01020589
GS		 4545 RETPUSHYES;
4546 }
ef54e1a4
JH		 4547 }
4548 else {
cea2e8a9 4549 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 4550 }
a0d0e21e
LW		 4551 RETPUSHNO;
4552}
79072805 4553
a0d0e21e
LW		 4554PP(pp_hslice)
4555{
97aff369 4556 dVAR; dSP; dMARK; dORIGMARK;
85fbaab2 4557 register HV * const hv = MUTABLE_HV(POPs);
1b6737cc
AL		 4558 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4559 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 4560 bool can_preserve = FALSE;
79072805 4561
eb85dfd3
DM		 4562 if (localizing) {
4563 MAGIC *mg;
4564 HV *stash;
4565
d30e492c
VP		 4566 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4567 can_preserve = TRUE;
eb85dfd3
DM		 4568 }
4569
6d822dc4 4570 while (++MARK <= SP) {
1b6737cc 4571 SV * const keysv = *MARK;
6d822dc4
MS		 4572 SV **svp;
4573 HE *he;
d30e492c
VP		 4574 bool preeminent = TRUE;
4575
4576 if (localizing && can_preserve) {
4577 /* If we can determine whether the element exist,
4578 * try to preserve the existenceness of a tied hash
4579 * element by using EXISTS and DELETE if possible.
4580 * Fallback to FETCH and STORE otherwise. */
4581 preeminent = hv_exists_ent(hv, keysv, 0);
6d822dc4 4582 }
eb85dfd3 4583
6d822dc4 4584 he = hv_fetch_ent(hv, keysv, lval, 0);
fe5bfecd 4585 svp = he ? &HeVAL(he) : NULL;
eb85dfd3 4586
6d822dc4
MS		 4587 if (lval) {
4588 if (!svp || *svp == &PL_sv_undef) {
be2597df 4589 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6d822dc4
MS		 4590 }
4591 if (localizing) {
7a2e501a 4592 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 4593 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP		 4594 else if (preeminent)
4595 save_helem_flags(hv, keysv, svp,
4596 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4597 else
4598 SAVEHDELETE(hv, keysv);
6d822dc4
MS		 4599 }
4600 }
4601 *MARK = svp ? *svp : &PL_sv_undef;
79072805 4602 }
a0d0e21e
LW		 4603 if (GIMME != G_ARRAY) {
4604 MARK = ORIGMARK;
04ab2c87 4605 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e 4606 SP = MARK;
79072805 4607 }
a0d0e21e
LW		 4608 RETURN;
4609}
4610
4611/* List operators. */
4612
4613PP(pp_list)
4614{
97aff369 4615 dVAR; dSP; dMARK;
a0d0e21e
LW		 4616 if (GIMME != G_ARRAY) {
4617 if (++MARK <= SP)
4618 *MARK = *SP; /* unwanted list, return last item */
8990e307 4619 else
3280af22 4620 *MARK = &PL_sv_undef;
a0d0e21e 4621 SP = MARK;
79072805 4622 }
a0d0e21e 4623 RETURN;
79072805
LW		 4624}
4625
a0d0e21e 4626PP(pp_lslice)
79072805 4627{
97aff369 4628 dVAR;
39644a26 4629 dSP;
1b6737cc
AL		 4630 SV ** const lastrelem = PL_stack_sp;
4631 SV ** const lastlelem = PL_stack_base + POPMARK;
4632 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4633 register SV ** const firstrelem = lastlelem + 1;
42e73ed0 4634 I32 is_something_there = FALSE;
1b6737cc
AL		 4635
4636 register const I32 max = lastrelem - lastlelem;
a0d0e21e 4637 register SV **lelem;
a0d0e21e
LW		 4638
4639 if (GIMME != G_ARRAY) {
4ea561bc 4640 I32 ix = SvIV(*lastlelem);
748a9306
LW		 4641 if (ix < 0)
4642 ix += max;
a0d0e21e 4643 if (ix < 0 || ix >= max)
3280af22 4644 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 4645 else
4646 *firstlelem = firstrelem[ix];
4647 SP = firstlelem;
4648 RETURN;
4649 }
4650
4651 if (max == 0) {
4652 SP = firstlelem - 1;
4653 RETURN;
4654 }
4655
4656 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4ea561bc 4657 I32 ix = SvIV(*lelem);
c73bf8e3 4658 if (ix < 0)
a0d0e21e 4659 ix += max;
c73bf8e3
HS		 4660 if (ix < 0 || ix >= max)
4661 *lelem = &PL_sv_undef;
4662 else {
4663 is_something_there = TRUE;
4664 if (!(*lelem = firstrelem[ix]))
3280af22 4665 *lelem = &PL_sv_undef;
748a9306 4666 }
79072805 4667 }
4633a7c4
LW		 4668 if (is_something_there)
4669 SP = lastlelem;
4670 else
4671 SP = firstlelem - 1;
79072805
LW		 4672 RETURN;
4673}
4674
a0d0e21e
LW		 4675PP(pp_anonlist)
4676{
97aff369 4677 dVAR; dSP; dMARK; dORIGMARK;
1b6737cc 4678 const I32 items = SP - MARK;
ad64d0ec 4679 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
44a8e56a 4680 SP = ORIGMARK; /* av_make() might realloc stack_sp */
6e449a3a
MHM		 4681 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4682 ? newRV_noinc(av) : av);
a0d0e21e
LW		 4683 RETURN;
4684}
4685
4686PP(pp_anonhash)
79072805 4687{
97aff369 4688 dVAR; dSP; dMARK; dORIGMARK;
78c72037 4689 HV* const hv = newHV();
a0d0e21e
LW		 4690
4691 while (MARK < SP) {
1b6737cc 4692 SV * const key = *++MARK;
561b68a9 4693 SV * const val = newSV(0);
a0d0e21e
LW		 4694 if (MARK < SP)
4695 sv_setsv(val, *++MARK);
a2a5de95
NC		 4696 else
4697 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
f12c7020 4698 (void)hv_store_ent(hv,key,val,0);
79072805 4699 }
a0d0e21e 4700 SP = ORIGMARK;
6e449a3a 4701 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
ad64d0ec 4702 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
79072805
LW		 4703 RETURN;
4704}
4705
d4fc4415
FC		 4706static AV *
4707S_deref_plain_array(pTHX_ AV *ary)
4708{
4709 if (SvTYPE(ary) == SVt_PVAV) return ary;
d2d95e13 4710 SvGETMAGIC((SV *)ary);
d4fc4415
FC		 4711 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4712 Perl_die(aTHX_ "Not an ARRAY reference");
4713 else if (SvOBJECT(SvRV(ary)))
4714 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4715 return (AV *)SvRV(ary);
4716}
4717
4718#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4719# define DEREF_PLAIN_ARRAY(ary) \
4720 ({ \
4721 AV *aRrRay = ary; \
4722 SvTYPE(aRrRay) == SVt_PVAV \
4723 ? aRrRay \
4724 : S_deref_plain_array(aTHX_ aRrRay); \
4725 })
4726#else
4727# define DEREF_PLAIN_ARRAY(ary) \
4728 ( \
3b0f6d32 4729 PL_Sv = (SV *)(ary), \
d4fc4415
FC		 4730 SvTYPE(PL_Sv) == SVt_PVAV \
4731 ? (AV *)PL_Sv \
3b0f6d32 4732 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
d4fc4415
FC		 4733 )
4734#endif
4735
a0d0e21e 4736PP(pp_splice)
79072805 4737{
27da23d5 4738 dVAR; dSP; dMARK; dORIGMARK;
5cd408a2 4739 int num_args = (SP - MARK);
d4fc4415 4740 register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
a0d0e21e
LW		 4741 register SV **src;
4742 register SV **dst;
4743 register I32 i;
4744 register I32 offset;
4745 register I32 length;
4746 I32 newlen;
4747 I32 after;
4748 I32 diff;
ad64d0ec 4749 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 4750
1b6737cc 4751 if (mg) {
af71faff
NC		 4752 return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
4753 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4754 sp - mark);
93965878 4755 }
79072805 4756
a0d0e21e 4757 SP++;
79072805 4758
a0d0e21e 4759 if (++MARK < SP) {
4ea561bc 4760 offset = i = SvIV(*MARK);
a0d0e21e 4761 if (offset < 0)
93965878 4762 offset += AvFILLp(ary) + 1;
84902520 4763 if (offset < 0)
cea2e8a9 4764 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 4765 if (++MARK < SP) {
4766 length = SvIVx(*MARK++);
48cdf507
GA		 4767 if (length < 0) {
4768 length += AvFILLp(ary) - offset + 1;
4769 if (length < 0)
4770 length = 0;
4771 }
79072805
LW		 4772 }
4773 else
a0d0e21e 4774 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 4775 }
a0d0e21e
LW		 4776 else {
4777 offset = 0;
4778 length = AvMAX(ary) + 1;
4779 }
8cbc2e3b 4780 if (offset > AvFILLp(ary) + 1) {
5cd408a2
EB		 4781 if (num_args > 2)
4782 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 4783 offset = AvFILLp(ary) + 1;
8cbc2e3b 4784 }
93965878 4785 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 4786 if (after < 0) { /* not that much array */
4787 length += after; /* offset+length now in array */
4788 after = 0;
4789 if (!AvALLOC(ary))
4790 av_extend(ary, 0);
4791 }
4792
4793 /* At this point, MARK .. SP-1 is our new LIST */
4794
4795 newlen = SP - MARK;
4796 diff = newlen - length;
13d7cbc1
GS		 4797 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4798 av_reify(ary);
a0d0e21e 4799
50528de0
WL		 4800 /* make new elements SVs now: avoid problems if they're from the array */
4801 for (dst = MARK, i = newlen; i; i--) {
1b6737cc 4802 SV * const h = *dst;
f2b990bf 4803 *dst++ = newSVsv(h);
50528de0
WL		 4804 }
4805
a0d0e21e 4806 if (diff < 0) { /* shrinking the area */
95b63a38 4807 SV **tmparyval = NULL;
a0d0e21e 4808 if (newlen) {
a02a5408 4809 Newx(tmparyval, newlen, SV*); /* so remember insertion */
a0d0e21e 4810 Copy(MARK, tmparyval, newlen, SV*);
79072805 4811 }
a0d0e21e
LW		 4812
4813 MARK = ORIGMARK + 1;
4814 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4815 MEXTEND(MARK, length);
4816 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4817 if (AvREAL(ary)) {
bbce6d69 4818 EXTEND_MORTAL(length);
36477c24 4819 for (i = length, dst = MARK; i; i--) {
486ec47a 4820 sv_2mortal(*dst); /* free them eventually */
36477c24 4821 dst++;
4822 }
a0d0e21e
LW		 4823 }
4824 MARK += length - 1;
79072805 4825 }
a0d0e21e
LW		 4826 else {
4827 *MARK = AvARRAY(ary)[offset+length-1];
4828 if (AvREAL(ary)) {
d689ffdd 4829 sv_2mortal(*MARK);
a0d0e21e
LW		 4830 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4831 SvREFCNT_dec(*dst++); /* free them now */
79072805 4832 }
a0d0e21e 4833 }
93965878 4834 AvFILLp(ary) += diff;
a0d0e21e
LW		 4835
4836 /* pull up or down? */
4837
4838 if (offset < after) { /* easier to pull up */
4839 if (offset) { /* esp. if nothing to pull */
4840 src = &AvARRAY(ary)[offset-1];
4841 dst = src - diff; /* diff is negative */
4842 for (i = offset; i > 0; i--) /* can't trust Copy */
4843 *dst-- = *src--;
79072805 4844 }
a0d0e21e 4845 dst = AvARRAY(ary);
9c6bc640 4846 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
a0d0e21e
LW		 4847 AvMAX(ary) += diff;
4848 }
4849 else {
4850 if (after) { /* anything to pull down? */
4851 src = AvARRAY(ary) + offset + length;
4852 dst = src + diff; /* diff is negative */
4853 Move(src, dst, after, SV*);
79072805 4854 }
93965878 4855 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 4856 /* avoid later double free */
4857 }
4858 i = -diff;
4859 while (i)
3280af22 4860 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 4861
4862 if (newlen) {
50528de0 4863 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e
LW		 4864 Safefree(tmparyval);
4865 }
4866 }
4867 else { /* no, expanding (or same) */
d3961450 4868 SV** tmparyval = NULL;
a0d0e21e 4869 if (length) {
a02a5408 4870 Newx(tmparyval, length, SV*); /* so remember deletion */
a0d0e21e
LW		 4871 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4872 }
4873
4874 if (diff > 0) { /* expanding */
a0d0e21e 4875 /* push up or down? */
a0d0e21e
LW		 4876 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4877 if (offset) {
4878 src = AvARRAY(ary);
4879 dst = src - diff;
4880 Move(src, dst, offset, SV*);
79072805 4881 }
9c6bc640 4882 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
a0d0e21e 4883 AvMAX(ary) += diff;
93965878 4884 AvFILLp(ary) += diff;
79072805
LW		 4885 }
4886 else {
93965878
NIS		 4887 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4888 av_extend(ary, AvFILLp(ary) + diff);
4889 AvFILLp(ary) += diff;
a0d0e21e
LW		 4890
4891 if (after) {
93965878 4892 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 4893 src = dst - diff;
4894 for (i = after; i; i--) {
4895 *dst-- = *src--;
4896 }
79072805
LW		 4897 }
4898 }
a0d0e21e
LW		 4899 }
4900
50528de0
WL		 4901 if (newlen) {
4902 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e 4903 }
50528de0 4904
a0d0e21e
LW		 4905 MARK = ORIGMARK + 1;
4906 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4907 if (length) {
4908 Copy(tmparyval, MARK, length, SV*);
4909 if (AvREAL(ary)) {
bbce6d69 4910 EXTEND_MORTAL(length);
36477c24 4911 for (i = length, dst = MARK; i; i--) {
486ec47a 4912 sv_2mortal(*dst); /* free them eventually */
36477c24 4913 dst++;
4914 }
79072805
LW		 4915 }
4916 }
a0d0e21e
LW		 4917 MARK += length - 1;
4918 }
4919 else if (length--) {
4920 *MARK = tmparyval[length];
4921 if (AvREAL(ary)) {
d689ffdd 4922 sv_2mortal(*MARK);
a0d0e21e
LW		 4923 while (length-- > 0)
4924 SvREFCNT_dec(tmparyval[length]);
79072805 4925 }
79072805 4926 }
a0d0e21e 4927 else
3280af22 4928 *MARK = &PL_sv_undef;
d3961450 4929 Safefree(tmparyval);
79072805 4930 }
474af990
FR		 4931
4932 if (SvMAGICAL(ary))
4933 mg_set(MUTABLE_SV(ary));
4934
a0d0e21e 4935 SP = MARK;
79072805
LW		 4936 RETURN;
4937}
4938
a0d0e21e 4939PP(pp_push)
79072805 4940{
27da23d5 4941 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
d4fc4415 4942 register AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 4943 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
79072805 4944
1b6737cc 4945 if (mg) {
ad64d0ec 4946 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
93965878
NIS		 4947 PUSHMARK(MARK);
4948 PUTBACK;
d343c3ef 4949 ENTER_with_name("call_PUSH");
864dbfa3 4950 call_method("PUSH",G_SCALAR|G_DISCARD);
d343c3ef 4951 LEAVE_with_name("call_PUSH");
93965878 4952 SPAGAIN;
93965878 4953 }
a60c0954 4954 else {
89c14e2e 4955 PL_delaymagic = DM_DELAY;
a60c0954 4956 for (++MARK; MARK <= SP; MARK++) {
561b68a9 4957 SV * const sv = newSV(0);
a60c0954
NIS		 4958 if (*MARK)
4959 sv_setsv(sv, *MARK);
0a75904b 4960 av_store(ary, AvFILLp(ary)+1, sv);
a60c0954 4961 }
354b0578 4962 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 4963 mg_set(MUTABLE_SV(ary));
89c14e2e
BB		 4964
4965 PL_delaymagic = 0;
6eeabd23
VP		 4966 }
4967 SP = ORIGMARK;
4968 if (OP_GIMME(PL_op, 0) != G_VOID) {
4969 PUSHi( AvFILL(ary) + 1 );
79072805 4970 }
79072805
LW		 4971 RETURN;
4972}
4973
a0d0e21e 4974PP(pp_shift)
79072805 4975{
97aff369 4976 dVAR;
39644a26 4977 dSP;
538f5756 4978 AV * const av = PL_op->op_flags & OPf_SPECIAL
d4fc4415 4979 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
789b4bc9 4980 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
79072805 4981 EXTEND(SP, 1);
c2b4a044 4982 assert (sv);
d689ffdd 4983 if (AvREAL(av))
a0d0e21e
LW		 4984 (void)sv_2mortal(sv);
4985 PUSHs(sv);
79072805 4986 RETURN;
79072805
LW		 4987}
4988
a0d0e21e 4989PP(pp_unshift)
79072805 4990{
27da23d5 4991 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
d4fc4415 4992 register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 4993 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 4994
1b6737cc 4995 if (mg) {
ad64d0ec 4996 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
7fd66d9d 4997 PUSHMARK(MARK);
93965878 4998 PUTBACK;
d343c3ef 4999 ENTER_with_name("call_UNSHIFT");
864dbfa3 5000 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
d343c3ef 5001 LEAVE_with_name("call_UNSHIFT");
93965878 5002 SPAGAIN;
93965878 5003 }
a60c0954 5004 else {
1b6737cc 5005 register I32 i = 0;
a60c0954
NIS		 5006 av_unshift(ary, SP - MARK);
5007 while (MARK < SP) {
1b6737cc 5008 SV * const sv = newSVsv(*++MARK);
a60c0954
NIS		 5009 (void)av_store(ary, i++, sv);
5010 }
79072805 5011 }
a0d0e21e 5012 SP = ORIGMARK;
6eeabd23 5013 if (OP_GIMME(PL_op, 0) != G_VOID) {
5658d0a9
LR		 5014 PUSHi( AvFILL(ary) + 1 );
5015 }
79072805 5016 RETURN;
79072805
LW		 5017}
5018
a0d0e21e 5019PP(pp_reverse)
79072805 5020{
97aff369 5021 dVAR; dSP; dMARK;
79072805 5022
a0d0e21e 5023 if (GIMME == G_ARRAY) {
484c818f
VP		 5024 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5025 AV *av;
5026
5027 /* See pp_sort() */
5028 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5029 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5030 av = MUTABLE_AV((*SP));
5031 /* In-place reversing only happens in void context for the array
5032 * assignment. We don't need to push anything on the stack. */
5033 SP = MARK;
5034
5035 if (SvMAGICAL(av)) {
5036 I32 i, j;
5037 register SV *tmp = sv_newmortal();
5038 /* For SvCANEXISTDELETE */
5039 HV *stash;
5040 const MAGIC *mg;
5041 bool can_preserve = SvCANEXISTDELETE(av);
5042
5043 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5044 register SV *begin, *end;
5045
5046 if (can_preserve) {
5047 if (!av_exists(av, i)) {
5048 if (av_exists(av, j)) {
5049 register SV *sv = av_delete(av, j, 0);
5050 begin = *av_fetch(av, i, TRUE);
5051 sv_setsv_mg(begin, sv);
5052 }
5053 continue;
5054 }
5055 else if (!av_exists(av, j)) {
5056 register SV *sv = av_delete(av, i, 0);
5057 end = *av_fetch(av, j, TRUE);
5058 sv_setsv_mg(end, sv);
5059 continue;
5060 }
5061 }
5062
5063 begin = *av_fetch(av, i, TRUE);
5064 end = *av_fetch(av, j, TRUE);
5065 sv_setsv(tmp, begin);
5066 sv_setsv_mg(begin, end);
5067 sv_setsv_mg(end, tmp);
5068 }
5069 }
5070 else {
5071 SV **begin = AvARRAY(av);
484c818f 5072
95a26d8e
VP		 5073 if (begin) {
5074 SV **end = begin + AvFILLp(av);
5075
5076 while (begin < end) {
5077 register SV * const tmp = *begin;
5078 *begin++ = *end;
5079 *end-- = tmp;
5080 }
484c818f
VP		 5081 }
5082 }
5083 }
5084 else {
5085 SV **oldsp = SP;
5086 MARK++;
5087 while (MARK < SP) {
5088 register SV * const tmp = *MARK;
5089 *MARK++ = *SP;
5090 *SP-- = tmp;
5091 }
5092 /* safe as long as stack cannot get extended in the above */
5093 SP = oldsp;
a0d0e21e 5094 }
79072805
LW		 5095 }
5096 else {
a0d0e21e
LW		 5097 register char *up;
5098 register char *down;
5099 register I32 tmp;
5100 dTARGET;
5101 STRLEN len;
79072805 5102
7e2040f0 5103 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 5104 if (SP - MARK > 1)
3280af22 5105 do_join(TARG, &PL_sv_no, MARK, SP);
1e21d011 5106 else {
789bd863 5107 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
1e21d011
B		 5108 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5109 report_uninit(TARG);
5110 }
5111
a0d0e21e
LW		 5112 up = SvPV_force(TARG, len);
5113 if (len > 1) {
7e2040f0 5114 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55 5115 U8* s = (U8*)SvPVX(TARG);
349d4f2f 5116 const U8* send = (U8*)(s + len);
a0ed51b3 5117 while (s < send) {
d742c382 5118 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 5119 s++;
5120 continue;
5121 }
5122 else {
9041c2e3 5123 if (!utf8_to_uvchr(s, 0))
a0dbb045 5124 break;
dfe13c55 5125 up = (char*)s;
a0ed51b3 5126 s += UTF8SKIP(s);
dfe13c55 5127 down = (char*)(s - 1);
a0dbb045 5128 /* reverse this character */
a0ed51b3
LW		 5129 while (down > up) {
5130 tmp = *up;
5131 *up++ = *down;
eb160463 5132 *down-- = (char)tmp;
a0ed51b3
LW		 5133 }
5134 }
5135 }
5136 up = SvPVX(TARG);
5137 }
a0d0e21e
LW		 5138 down = SvPVX(TARG) + len - 1;
5139 while (down > up) {
5140 tmp = *up;
5141 *up++ = *down;
eb160463 5142 *down-- = (char)tmp;
a0d0e21e 5143 }
3aa33fe5 5144 (void)SvPOK_only_UTF8(TARG);
79072805 5145 }
a0d0e21e
LW		 5146 SP = MARK + 1;
5147 SETTARG;
79072805 5148 }
a0d0e21e 5149 RETURN;
79072805
LW		 5150}
5151
a0d0e21e 5152PP(pp_split)
79072805 5153{
27da23d5 5154 dVAR; dSP; dTARG;
a0d0e21e 5155 AV *ary;
467f0320 5156 register IV limit = POPi; /* note, negative is forever */
1b6737cc 5157 SV * const sv = POPs;
a0d0e21e 5158 STRLEN len;
727b7506 5159 register const char *s = SvPV_const(sv, len);
1b6737cc 5160 const bool do_utf8 = DO_UTF8(sv);
727b7506 5161 const char *strend = s + len;
44a8e56a 5162 register PMOP *pm;
d9f97599 5163 register REGEXP *rx;
a0d0e21e 5164 register SV *dstr;
727b7506 5165 register const char *m;
a0d0e21e 5166 I32 iters = 0;
bb7a0f54 5167 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
792b2c16 5168 I32 maxiters = slen + 10;
c1a7495a 5169 I32 trailing_empty = 0;
727b7506 5170 const char *orig;
1b6737cc 5171 const I32 origlimit = limit;
a0d0e21e
LW		 5172 I32 realarray = 0;
5173 I32 base;
f54cb97a 5174 const I32 gimme = GIMME_V;
941446f6 5175 bool gimme_scalar;
f54cb97a 5176 const I32 oldsave = PL_savestack_ix;
437d3b4e 5177 U32 make_mortal = SVs_TEMP;
7fba1cd6 5178 bool multiline = 0;
b37c2d43 5179 MAGIC *mg = NULL;
79072805 5180
44a8e56a 5181#ifdef DEBUGGING
5182 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5183#else
5184 pm = (PMOP*)POPs;
5185#endif
a0d0e21e 5186 if (!pm || !s)
2269b42e 5187 DIE(aTHX_ "panic: pp_split");
aaa362c4 5188 rx = PM_GETRE(pm);
bbce6d69 5189
a62b1201 5190 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
07bc277f 5191 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
bbce6d69 5192
a30b2f1f 5193 RX_MATCH_UTF8_set(rx, do_utf8);
d9f424b2 5194
971a9dd3 5195#ifdef USE_ITHREADS
20e98b0f 5196 if (pm->op_pmreplrootu.op_pmtargetoff) {
159b6efe 5197 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
20e98b0f 5198 }
971a9dd3 5199#else
20e98b0f
NC		 5200 if (pm->op_pmreplrootu.op_pmtargetgv) {
5201 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
971a9dd3 5202 }
20e98b0f 5203#endif
79072805 5204 else
7d49f689 5205 ary = NULL;
a0d0e21e
LW		 5206 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5207 realarray = 1;
8ec5e241 5208 PUTBACK;
a0d0e21e
LW		 5209 av_extend(ary,0);
5210 av_clear(ary);
8ec5e241 5211 SPAGAIN;
ad64d0ec 5212 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
8ec5e241 5213 PUSHMARK(SP);
ad64d0ec 5214 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
8ec5e241
NIS		 5215 }
5216 else {
1c0b011c 5217 if (!AvREAL(ary)) {
1b6737cc 5218 I32 i;
1c0b011c 5219 AvREAL_on(ary);
abff13bb 5220 AvREIFY_off(ary);
1c0b011c 5221 for (i = AvFILLp(ary); i >= 0; i--)
3280af22 5222 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 5223 }
5224 /* temporarily switch stacks */
8b7059b1 5225 SAVESWITCHSTACK(PL_curstack, ary);
8ec5e241 5226 make_mortal = 0;
1c0b011c 5227 }
79072805 5228 }
3280af22 5229 base = SP - PL_stack_base;
a0d0e21e 5230 orig = s;
07bc277f 5231 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
613f191e
TS		 5232 if (do_utf8) {
5233 while (*s == ' ' || is_utf8_space((U8*)s))
5234 s += UTF8SKIP(s);
5235 }
a62b1201 5236 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
bbce6d69 5237 while (isSPACE_LC(*s))
5238 s++;
5239 }
5240 else {
5241 while (isSPACE(*s))
5242 s++;
5243 }
a0d0e21e 5244 }
73134a2e 5245 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
7fba1cd6 5246 multiline = 1;
c07a80fd 5247 }
5248
941446f6
FC		 5249 gimme_scalar = gimme == G_SCALAR && !ary;
5250
a0d0e21e
LW		 5251 if (!limit)
5252 limit = maxiters + 2;
07bc277f 5253 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
a0d0e21e 5254 while (--limit) {
bbce6d69 5255 m = s;
8727f688
YO		 5256 /* this one uses 'm' and is a negative test */
5257 if (do_utf8) {
613f191e
TS		 5258 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5259 const int t = UTF8SKIP(m);
5260 /* is_utf8_space returns FALSE for malform utf8 */
5261 if (strend - m < t)
5262 m = strend;
5263 else
5264 m += t;
5265 }
a62b1201
KW		 5266 }
5267 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
8727f688
YO		 5268 while (m < strend && !isSPACE_LC(*m))
5269 ++m;
5270 } else {
5271 while (m < strend && !isSPACE(*m))
5272 ++m;
5273 }
a0d0e21e
LW		 5274 if (m >= strend)
5275 break;
bbce6d69 5276
c1a7495a
BB		 5277 if (gimme_scalar) {
5278 iters++;
5279 if (m-s == 0)
5280 trailing_empty++;
5281 else
5282 trailing_empty = 0;
5283 } else {
5284 dstr = newSVpvn_flags(s, m-s,
5285 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5286 XPUSHs(dstr);
5287 }
bbce6d69 5288
613f191e
TS		 5289 /* skip the whitespace found last */
5290 if (do_utf8)
5291 s = m + UTF8SKIP(m);
5292 else
5293 s = m + 1;
5294
8727f688
YO		 5295 /* this one uses 's' and is a positive test */
5296 if (do_utf8) {
613f191e 5297 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
8727f688 5298 s += UTF8SKIP(s);
a62b1201
KW		 5299 }
5300 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
8727f688
YO		 5301 while (s < strend && isSPACE_LC(*s))
5302 ++s;
5303 } else {
5304 while (s < strend && isSPACE(*s))
5305 ++s;
5306 }
79072805
LW		 5307 }
5308 }
07bc277f 5309 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
a0d0e21e 5310 while (--limit) {
a6e20a40
AL		 5311 for (m = s; m < strend && *m != '\n'; m++)
5312 ;
a0d0e21e
LW		 5313 m++;
5314 if (m >= strend)
5315 break;
c1a7495a
BB		 5316
5317 if (gimme_scalar) {
5318 iters++;
5319 if (m-s == 0)
5320 trailing_empty++;
5321 else
5322 trailing_empty = 0;
5323 } else {
5324 dstr = newSVpvn_flags(s, m-s,
5325 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5326 XPUSHs(dstr);
5327 }
a0d0e21e
LW		 5328 s = m;
5329 }
5330 }
07bc277f 5331 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
640f820d
AB		 5332 /*
5333 Pre-extend the stack, either the number of bytes or
5334 characters in the string or a limited amount, triggered by:
5335
5336 my ($x, $y) = split //, $str;
5337 or
5338 split //, $str, $i;
5339 */
c1a7495a
BB		 5340 if (!gimme_scalar) {
5341 const U32 items = limit - 1;
5342 if (items < slen)
5343 EXTEND(SP, items);
5344 else
5345 EXTEND(SP, slen);
5346 }
640f820d 5347
e9515b0f
AB		 5348 if (do_utf8) {
5349 while (--limit) {
5350 /* keep track of how many bytes we skip over */
5351 m = s;
640f820d 5352 s += UTF8SKIP(s);
c1a7495a
BB		 5353 if (gimme_scalar) {
5354 iters++;
5355 if (s-m == 0)
5356 trailing_empty++;
5357 else
5358 trailing_empty = 0;
5359 } else {
5360 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
640f820d 5361
c1a7495a
BB		 5362 PUSHs(dstr);
5363 }
640f820d 5364
e9515b0f
AB		 5365 if (s >= strend)
5366 break;
5367 }
5368 } else {
5369 while (--limit) {
c1a7495a
BB		 5370 if (gimme_scalar) {
5371 iters++;
5372 } else {
5373 dstr = newSVpvn(s, 1);
e9515b0f 5374
e9515b0f 5375
c1a7495a
BB		 5376 if (make_mortal)
5377 sv_2mortal(dstr);
640f820d 5378
c1a7495a
BB		 5379 PUSHs(dstr);
5380 }
5381
5382 s++;
e9515b0f
AB		 5383
5384 if (s >= strend)
5385 break;
5386 }
640f820d
AB		 5387 }
5388 }
3c8556c3 5389 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
07bc277f
NC		 5390 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5391 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5392 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5393 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
f9f4320a 5394 SV * const csv = CALLREG_INTUIT_STRING(rx);
cf93c79d 5395
07bc277f 5396 len = RX_MINLENRET(rx);
3c8556c3 5397 if (len == 1 && !RX_UTF8(rx) && !tail) {
1b6737cc 5398 const char c = *SvPV_nolen_const(csv);
a0d0e21e 5399 while (--limit) {
a6e20a40
AL		 5400 for (m = s; m < strend && *m != c; m++)
5401 ;
a0d0e21e
LW		 5402 if (m >= strend)
5403 break;
c1a7495a
BB		 5404 if (gimme_scalar) {
5405 iters++;
5406 if (m-s == 0)
5407 trailing_empty++;
5408 else
5409 trailing_empty = 0;
5410 } else {
5411 dstr = newSVpvn_flags(s, m-s,
5412 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5413 XPUSHs(dstr);
5414 }
93f04dac
JH		 5415 /* The rx->minlen is in characters but we want to step
5416 * s ahead by bytes. */
1aa99e6b
IH		 5417 if (do_utf8)
5418 s = (char*)utf8_hop((U8*)m, len);
5419 else
5420 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 5421 }
5422 }
5423 else {
a0d0e21e 5424 while (s < strend && --limit &&
f722798b 5425 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
7fba1cd6 5426 csv, multiline ? FBMrf_MULTILINE : 0)) )
a0d0e21e 5427 {
c1a7495a
BB		 5428 if (gimme_scalar) {
5429 iters++;
5430 if (m-s == 0)
5431 trailing_empty++;
5432 else
5433 trailing_empty = 0;
5434 } else {
5435 dstr = newSVpvn_flags(s, m-s,
5436 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5437 XPUSHs(dstr);
5438 }
93f04dac
JH		 5439 /* The rx->minlen is in characters but we want to step
5440 * s ahead by bytes. */
1aa99e6b
IH		 5441 if (do_utf8)
5442 s = (char*)utf8_hop((U8*)m, len);
5443 else
5444 s = m + len; /* Fake \n at the end */
a0d0e21e 5445 }
463ee0b2 5446 }
463ee0b2 5447 }
a0d0e21e 5448 else {
07bc277f 5449 maxiters += slen * RX_NPARENS(rx);
080c2dec 5450 while (s < strend && --limit)
bbce6d69 5451 {
1b6737cc 5452 I32 rex_return;
080c2dec 5453 PUTBACK;
f9f4320a 5454 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
bfafcb9a 5455 sv, NULL, SvSCREAM(sv) ? REXEC_SCREAM : 0);
080c2dec 5456 SPAGAIN;
1b6737cc 5457 if (rex_return == 0)
080c2dec 5458 break;
d9f97599 5459 TAINT_IF(RX_MATCH_TAINTED(rx));
07bc277f 5460 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
a0d0e21e
LW		 5461 m = s;
5462 s = orig;
07bc277f 5463 orig = RX_SUBBEG(rx);
a0d0e21e
LW		 5464 s = orig + (m - s);
5465 strend = s + (strend - m);
5466 }
07bc277f 5467 m = RX_OFFS(rx)[0].start + orig;
c1a7495a
BB		 5468
5469 if (gimme_scalar) {
5470 iters++;
5471 if (m-s == 0)
5472 trailing_empty++;
5473 else
5474 trailing_empty = 0;
5475 } else {
5476 dstr = newSVpvn_flags(s, m-s,
5477 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5478 XPUSHs(dstr);
5479 }
07bc277f 5480 if (RX_NPARENS(rx)) {
1b6737cc 5481 I32 i;
07bc277f
NC		 5482 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5483 s = RX_OFFS(rx)[i].start + orig;
5484 m = RX_OFFS(rx)[i].end + orig;
6de67870
JP		 5485
5486 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5487 parens that didn't match -- they should be set to
5488 undef, not the empty string */
c1a7495a
BB		 5489 if (gimme_scalar) {
5490 iters++;
5491 if (m-s == 0)
5492 trailing_empty++;
5493 else
5494 trailing_empty = 0;
5495 } else {
5496 if (m >= orig && s >= orig) {
5497 dstr = newSVpvn_flags(s, m-s,
5498 (do_utf8 ? SVf_UTF8 : 0)
5499 | make_mortal);
5500 }
5501 else
5502 dstr = &PL_sv_undef; /* undef, not "" */
5503 XPUSHs(dstr);
748a9306 5504 }
c1a7495a 5505
a0d0e21e
LW		 5506 }
5507 }
07bc277f 5508 s = RX_OFFS(rx)[0].end + orig;
a0d0e21e 5509 }
79072805 5510 }
8ec5e241 5511
c1a7495a
BB		 5512 if (!gimme_scalar) {
5513 iters = (SP - PL_stack_base) - base;
5514 }
a0d0e21e 5515 if (iters > maxiters)
cea2e8a9 5516 DIE(aTHX_ "Split loop");
8ec5e241 5517
a0d0e21e
LW		 5518 /* keep field after final delim? */
5519 if (s < strend || (iters && origlimit)) {
c1a7495a
BB		 5520 if (!gimme_scalar) {
5521 const STRLEN l = strend - s;
5522 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5523 XPUSHs(dstr);
5524 }
a0d0e21e 5525 iters++;
79072805 5526 }
a0d0e21e 5527 else if (!origlimit) {
c1a7495a
BB		 5528 if (gimme_scalar) {
5529 iters -= trailing_empty;
5530 } else {
5531 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5532 if (TOPs && !make_mortal)
5533 sv_2mortal(TOPs);
5534 *SP-- = &PL_sv_undef;
5535 iters--;
5536 }
89900bd3 5537 }
a0d0e21e 5538 }
8ec5e241 5539
8b7059b1
DM		 5540 PUTBACK;
5541 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5542 SPAGAIN;
a0d0e21e 5543 if (realarray) {
8ec5e241 5544 if (!mg) {
1c0b011c
NIS		 5545 if (SvSMAGICAL(ary)) {
5546 PUTBACK;
ad64d0ec 5547 mg_set(MUTABLE_SV(ary));
1c0b011c
NIS		 5548 SPAGAIN;
5549 }
5550 if (gimme == G_ARRAY) {
5551 EXTEND(SP, iters);
5552 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5553 SP += iters;
5554 RETURN;
5555 }
8ec5e241 5556 }
1c0b011c 5557 else {
fb73857a 5558 PUTBACK;
d343c3ef 5559 ENTER_with_name("call_PUSH");
864dbfa3 5560 call_method("PUSH",G_SCALAR|G_DISCARD);
d343c3ef 5561 LEAVE_with_name("call_PUSH");
fb73857a 5562 SPAGAIN;
8ec5e241 5563 if (gimme == G_ARRAY) {
1b6737cc 5564 I32 i;
8ec5e241
NIS		 5565 /* EXTEND should not be needed - we just popped them */
5566 EXTEND(SP, iters);
5567 for (i=0; i < iters; i++) {
5568 SV **svp = av_fetch(ary, i, FALSE);
3280af22 5569 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 5570 }
1c0b011c
NIS		 5571 RETURN;
5572 }
a0d0e21e
LW		 5573 }
5574 }
5575 else {
5576 if (gimme == G_ARRAY)
5577 RETURN;
5578 }
7f18b612
YST		 5579
5580 GETTARGET;
5581 PUSHi(iters);
5582 RETURN;
79072805 5583}
85e6fe83 5584
c5917253
NC		 5585PP(pp_once)
5586{
5587 dSP;
5588 SV *const sv = PAD_SVl(PL_op->op_targ);
5589
5590 if (SvPADSTALE(sv)) {
5591 /* First time. */
5592 SvPADSTALE_off(sv);
5593 RETURNOP(cLOGOP->op_other);
5594 }
5595 RETURNOP(cLOGOP->op_next);
5596}
5597
c0329465
MB		 5598PP(pp_lock)
5599{
97aff369 5600 dVAR;
39644a26 5601 dSP;
c0329465 5602 dTOPss;
e55aaa0e 5603 SV *retsv = sv;
68795e93 5604 SvLOCK(sv);
f79aa60b
FC		 5605 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5606 || SvTYPE(retsv) == SVt_PVCV) {
e55aaa0e
MB		 5607 retsv = refto(retsv);
5608 }
5609 SETs(retsv);
c0329465
MB		 5610 RETURN;
5611}
a863c7d1 5612
65bca31a
NC		 5613
5614PP(unimplemented_op)
5615{
97aff369 5616 dVAR;
361ed549
NC		 5617 const Optype op_type = PL_op->op_type;
5618 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5619 with out of range op numbers - it only "special" cases op_custom.
5620 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5621 if we get here for a custom op then that means that the custom op didn't
5622 have an implementation. Given that OP_NAME() looks up the custom op
5623 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5624 registers &PL_unimplemented_op as the address of their custom op.
5625 NULL doesn't generate a useful error message. "custom" does. */
5626 const char *const name = op_type >= OP_max
5627 ? "[out of range]" : PL_op_name[PL_op->op_type];
7627e6d0
NC		 5628 if(OP_IS_SOCKET(op_type))
5629 DIE(aTHX_ PL_no_sock_func, name);
361ed549 5630 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
65bca31a
NC		 5631}
5632
867fa1e2
YO		 5633PP(pp_boolkeys)
5634{
5635 dVAR;
5636 dSP;
5637 HV * const hv = (HV*)POPs;
5638
fd1d9b5c
FC		 5639 if (SvTYPE(hv) != SVt_PVHV) { XPUSHs(&PL_sv_no); RETURN; }
5640
867fa1e2
YO		 5641 if (SvRMAGICAL(hv)) {
5642 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
5643 if (mg) {
5644 XPUSHs(magic_scalarpack(hv, mg));
5645 RETURN;
5646 }
5647 }
5648
1b95d04f 5649 XPUSHs(boolSV(HvUSEDKEYS(hv) != 0));
867fa1e2
YO		 5650 RETURN;
5651}
5652
deb8a388
FC		 5653/* For sorting out arguments passed to a &CORE:: subroutine */
5654PP(pp_coreargs)
5655{
5656 dSP;
7fa5bd9b 5657 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
19c481f4 5658 int defgv = PL_opargs[opnum] & OA_DEFGV, whicharg = 0;
7fa5bd9b 5659 AV * const at_ = GvAV(PL_defgv);
46e00a91 5660 SV **svp = AvARRAY(at_);
19c481f4 5661 I32 minargs = 0, maxargs = 0, numargs = AvFILLp(at_)+1;
7fa5bd9b 5662 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
46e00a91 5663 bool seen_question = 0;
7fa5bd9b 5664 const char *err = NULL;
3e6568b4 5665 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
7fa5bd9b 5666
46e00a91
FC		 5667 /* Count how many args there are first, to get some idea how far to
5668 extend the stack. */
7fa5bd9b 5669 while (oa) {
bf0571fd 5670 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
7fa5bd9b 5671 maxargs++;
46e00a91
FC		 5672 if (oa & OA_OPTIONAL) seen_question = 1;
5673 if (!seen_question) minargs++;
7fa5bd9b
FC		 5674 oa >>= 4;
5675 }
5676
5677 if(numargs < minargs) err = "Not enough";
5678 else if(numargs > maxargs) err = "Too many";
5679 if (err)
5680 /* diag_listed_as: Too many arguments for %s */
5681 Perl_croak(aTHX_
5682 "%s arguments for %s", err,
5683 opnum ? OP_DESC(PL_op->op_next) : SvPV_nolen_const(cSVOP_sv)
5684 );
5685
5686 /* Reset the stack pointer. Without this, we end up returning our own
5687 arguments in list context, in addition to the values we are supposed
5688 to return. nextstate usually does this on sub entry, but we need
e1fa07e3 5689 to run the next op with the caller's hints, so we cannot have a
7fa5bd9b
FC		 5690 nextstate. */
5691 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5692
46e00a91
FC		 5693 if(!maxargs) RETURN;
5694
bf0571fd
FC		 5695 /* We do this here, rather than with a separate pushmark op, as it has
5696 to come in between two things this function does (stack reset and
5697 arg pushing). This seems the easiest way to do it. */
3e6568b4 5698 if (pushmark) {
bf0571fd
FC		 5699 PUTBACK;
5700 (void)Perl_pp_pushmark(aTHX);
5701 }
5702
5703 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
c931b036 5704 PUTBACK; /* The code below can die in various places. */
46e00a91
FC		 5705
5706 oa = PL_opargs[opnum] >> OASHIFT;
3e6568b4 5707 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
c931b036 5708 whicharg++;
46e00a91
FC		 5709 switch (oa & 7) {
5710 case OA_SCALAR:
d6d78e19
FC		 5711 if (!numargs && defgv && whicharg == minargs + 1) {
5712 PERL_SI * const oldsi = PL_curstackinfo;
5713 I32 const oldcxix = oldsi->si_cxix;
5714 CV *caller;
5715 if (oldcxix) oldsi->si_cxix--;
5716 else PL_curstackinfo = oldsi->si_prev;
5717 caller = find_runcv(NULL);
5718 PL_curstackinfo = oldsi;
5719 oldsi->si_cxix = oldcxix;
5720 PUSHs(find_rundefsv2(
5721 caller,cxstack[cxstack_ix].blk_oldcop->cop_seq
5722 ));
5723 }
5724 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
46e00a91 5725 break;
bf0571fd
FC		 5726 case OA_LIST:
5727 while (numargs--) {
5728 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5729 svp++;
5730 }
5731 RETURN;
19c481f4
FC		 5732 case OA_HVREF:
5733 if (!svp || !*svp || !SvROK(*svp)
5734 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5735 DIE(aTHX_
5736 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5737 "Type of arg %d to &CORE::%s must be hash reference",
5738 whicharg, OP_DESC(PL_op->op_next)
5739 );
5740 PUSHs(SvRV(*svp));
5741 break;
c931b036 5742 case OA_FILEREF:
30901a8a
FC		 5743 if (!numargs) PUSHs(NULL);
5744 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
c931b036
FC		 5745 /* no magic here, as the prototype will have added an extra
5746 refgen and we just want what was there before that */
5747 PUSHs(SvRV(*svp));
5748 else {
5749 const bool constr = PL_op->op_private & whicharg;
5750 PUSHs(S_rv2gv(aTHX_
5751 svp && *svp ? *svp : &PL_sv_undef,
5752 constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5753 !constr
5754 ));
5755 }
5756 break;
c72a5629 5757 case OA_SCALARREF:
17008668
FC		 5758 {
5759 const bool wantscalar =
5760 PL_op->op_private & OPpCOREARGS_SCALARMOD;
c72a5629 5761 if (!svp || !*svp || !SvROK(*svp)
17008668
FC		 5762 /* We have to permit globrefs even for the \$ proto, as
5763 *foo is indistinguishable from ${\*foo}, and the proto-
5764 type permits the latter. */
5765 || SvTYPE(SvRV(*svp)) > (
efe889ae
FC		 5766 wantscalar ? SVt_PVLV
5767 : opnum == OP_LOCK ? SVt_PVCV
5768 : SVt_PVHV
17008668 5769 )
c72a5629
FC		 5770 )
5771 DIE(aTHX_
5772 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
17008668
FC		 5773 "Type of arg %d to &CORE::%s must be %s",
5774 whicharg, OP_DESC(PL_op->op_next),
5775 wantscalar
5776 ? "scalar reference"
efe889ae
FC		 5777 : opnum == OP_LOCK
5778 ? "reference to one of [$@%&*]"
5779 : "reference to one of [$@%*]"
c72a5629
FC		 5780 );
5781 PUSHs(SvRV(*svp));
5782 break;
17008668 5783 }
46e00a91 5784 default:
46e00a91
FC		 5785 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
5786 }
5787 oa = oa >> 4;
5788 }
5789
deb8a388
FC		 5790 RETURN;
5791}
5792
84ed0108
FC		 5793PP(pp_runcv)
5794{
5795 dSP;
5796 CV *cv;
5797 if (PL_op->op_private & OPpOFFBYONE) {
5798 PERL_SI * const oldsi = PL_curstackinfo;
5799 I32 const oldcxix = oldsi->si_cxix;
5800 if (oldcxix) oldsi->si_cxix--;
5801 else PL_curstackinfo = oldsi->si_prev;
5802 cv = find_runcv(NULL);
5803 PL_curstackinfo = oldsi;
5804 oldsi->si_cxix = oldcxix;
5805 }
5806 else cv = find_runcv(NULL);
5807 XPUSHs(CvUNIQUE(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
5808 RETURN;
5809}
5810
5811
e609e586
NC		 5812/*
5813 * Local variables:
5814 * c-indentation-style: bsd
5815 * c-basic-offset: 4
5816 * indent-tabs-mode: t
5817 * End:
5818 *
37442d52
RGS		 5819 * ex: set ts=8 sts=4 sw=4 noet:
5820 */
Unnamed repository; edit this file 'description' to name the repository.