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