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