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