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