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