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