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