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