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