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