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