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
Really apply change #26071.
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
770526c1 4 * 2000, 2001, 2002, 2003, 2004, 2005, 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/*
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
14 */
79072805 15
166f8a29
DM		 16/* This file contains general pp ("push/pop") functions that execute the
17 * opcodes that make up a perl program. A typical pp function expects to
18 * find its arguments on the stack, and usually pushes its results onto
19 * the stack, hence the 'pp' terminology. Each OP structure contains
20 * a pointer to the relevant pp_foo() function.
21 */
22
79072805 23#include "EXTERN.h"
864dbfa3 24#define PERL_IN_PP_C
79072805 25#include "perl.h"
77bc9082 26#include "keywords.h"
79072805 27
a4af207c
JH		 28#include "reentr.h"
29
dfe9444c
AD		 30/* XXX I can't imagine anyone who doesn't have this actually _needs_
31 it, since pid_t is an integral type.
32 --AD 2/20/1998
33*/
34#ifdef NEED_GETPID_PROTO
35extern Pid_t getpid (void);
8ac85365
NIS		 36#endif
37
0630166f
SP		 38/*
39 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
40 * This switches them over to IEEE.
41 */
42#if defined(LIBM_LIB_VERSION)
43 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
44#endif
45
13017935
SM		 46/* variations on pp_null */
47
93a17b20
LW		 48PP(pp_stub)
49{
39644a26 50 dSP;
54310121 51 if (GIMME_V == G_SCALAR)
3280af22 52 XPUSHs(&PL_sv_undef);
93a17b20
LW		 53 RETURN;
54}
55
79072805
LW		 56/* Pushy stuff. */
57
93a17b20
LW		 58PP(pp_padav)
59{
39644a26 60 dSP; dTARGET;
13017935 61 I32 gimme;
533c011a 62 if (PL_op->op_private & OPpLVAL_INTRO)
dd2155a4 63 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
85e6fe83 64 EXTEND(SP, 1);
533c011a 65 if (PL_op->op_flags & OPf_REF) {
85e6fe83 66 PUSHs(TARG);
93a17b20 67 RETURN;
78f9721b
SM		 68 } else if (LVRET) {
69 if (GIMME == G_SCALAR)
70 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
71 PUSHs(TARG);
72 RETURN;
85e6fe83 73 }
13017935
SM		 74 gimme = GIMME_V;
75 if (gimme == G_ARRAY) {
f54cb97a 76 const I32 maxarg = AvFILL((AV*)TARG) + 1;
85e6fe83 77 EXTEND(SP, maxarg);
93965878
NIS		 78 if (SvMAGICAL(TARG)) {
79 U32 i;
eb160463 80 for (i=0; i < (U32)maxarg; i++) {
1b6737cc 81 SV ** const svp = av_fetch((AV*)TARG, i, FALSE);
3280af22 82 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878
NIS		 83 }
84 }
85 else {
86 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
87 }
85e6fe83
LW		 88 SP += maxarg;
89 }
13017935 90 else if (gimme == G_SCALAR) {
1b6737cc 91 SV* const sv = sv_newmortal();
f54cb97a 92 const I32 maxarg = AvFILL((AV*)TARG) + 1;
85e6fe83
LW		 93 sv_setiv(sv, maxarg);
94 PUSHs(sv);
95 }
96 RETURN;
93a17b20
LW		 97}
98
99PP(pp_padhv)
100{
39644a26 101 dSP; dTARGET;
54310121 102 I32 gimme;
103
93a17b20 104 XPUSHs(TARG);
533c011a 105 if (PL_op->op_private & OPpLVAL_INTRO)
dd2155a4 106 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
533c011a 107 if (PL_op->op_flags & OPf_REF)
93a17b20 108 RETURN;
78f9721b
SM		 109 else if (LVRET) {
110 if (GIMME == G_SCALAR)
111 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
112 RETURN;
113 }
54310121 114 gimme = GIMME_V;
115 if (gimme == G_ARRAY) {
cea2e8a9 116 RETURNOP(do_kv());
85e6fe83 117 }
54310121 118 else if (gimme == G_SCALAR) {
1b6737cc 119 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
85e6fe83 120 SETs(sv);
85e6fe83 121 }
54310121 122 RETURN;
93a17b20
LW		 123}
124
79072805
LW		 125/* Translations. */
126
127PP(pp_rv2gv)
128{
39644a26 129 dSP; dTOPss;
8ec5e241 130
ed6116ce 131 if (SvROK(sv)) {
a0d0e21e 132 wasref:
f5284f61
IZ		 133 tryAMAGICunDEREF(to_gv);
134
ed6116ce 135 sv = SvRV(sv);
b1dadf13 136 if (SvTYPE(sv) == SVt_PVIO) {
1b6737cc 137 GV * const gv = (GV*) sv_newmortal();
b1dadf13 138 gv_init(gv, 0, "", 0, 0);
139 GvIOp(gv) = (IO *)sv;
3e3baf6d 140 (void)SvREFCNT_inc(sv);
b1dadf13 141 sv = (SV*) gv;
ef54e1a4
JH		 142 }
143 else if (SvTYPE(sv) != SVt_PVGV)
cea2e8a9 144 DIE(aTHX_ "Not a GLOB reference");
79072805
LW		 145 }
146 else {
93a17b20 147 if (SvTYPE(sv) != SVt_PVGV) {
a0d0e21e
LW		 148 if (SvGMAGICAL(sv)) {
149 mg_get(sv);
150 if (SvROK(sv))
151 goto wasref;
152 }
afd1915d 153 if (!SvOK(sv) && sv != &PL_sv_undef) {
b13b2135 154 /* If this is a 'my' scalar and flag is set then vivify
853846ea 155 * NI-S 1999/05/07
b13b2135 156 */
ac53db4c
DM		 157 if (SvREADONLY(sv))
158 Perl_croak(aTHX_ PL_no_modify);
1d8d4d2a 159 if (PL_op->op_private & OPpDEREF) {
2c8ac474
GS		 160 GV *gv;
161 if (cUNOP->op_targ) {
162 STRLEN len;
dd2155a4 163 SV *namesv = PAD_SV(cUNOP->op_targ);
f54cb97a 164 const char *name = SvPV(namesv, len);
2d6d9f7a 165 gv = (GV*)NEWSV(0,0);
2c8ac474
GS		 166 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
167 }
168 else {
f54cb97a 169 const char *name = CopSTASHPV(PL_curcop);
2c8ac474 170 gv = newGVgen(name);
1d8d4d2a 171 }
b13b2135
NIS		 172 if (SvTYPE(sv) < SVt_RV)
173 sv_upgrade(sv, SVt_RV);
b15aece3 174 if (SvPVX_const(sv)) {
8bd4d4c5 175 SvPV_free(sv);
b162af07
SP		 176 SvLEN_set(sv, 0);
177 SvCUR_set(sv, 0);
8f3c2c0c 178 }
b162af07 179 SvRV_set(sv, (SV*)gv);
853846ea 180 SvROK_on(sv);
1d8d4d2a 181 SvSETMAGIC(sv);
853846ea 182 goto wasref;
2c8ac474 183 }
533c011a
NIS		 184 if (PL_op->op_flags & OPf_REF ||
185 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 186 DIE(aTHX_ PL_no_usym, "a symbol");
599cee73 187 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 188 report_uninit(sv);
a0d0e21e
LW		 189 RETSETUNDEF;
190 }
35cd451c
GS		 191 if ((PL_op->op_flags & OPf_SPECIAL) &&
192 !(PL_op->op_flags & OPf_MOD))
193 {
1b6737cc 194 SV * const temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
7a5fd60d
NC		 195 if (!temp
196 && (!is_gv_magical_sv(sv,0)
197 || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
35cd451c 198 RETSETUNDEF;
c9d5ac95 199 }
7a5fd60d 200 sv = temp;
35cd451c
GS		 201 }
202 else {
203 if (PL_op->op_private & HINT_STRICT_REFS)
7a5fd60d
NC		 204 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
205 sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
35cd451c 206 }
93a17b20 207 }
79072805 208 }
533c011a
NIS		 209 if (PL_op->op_private & OPpLVAL_INTRO)
210 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
79072805
LW		 211 SETs(sv);
212 RETURN;
213}
214
79072805
LW		 215PP(pp_rv2sv)
216{
82d03984 217 GV *gv = Nullgv;
39644a26 218 dSP; dTOPss;
79072805 219
ed6116ce 220 if (SvROK(sv)) {
a0d0e21e 221 wasref:
f5284f61
IZ		 222 tryAMAGICunDEREF(to_sv);
223
ed6116ce 224 sv = SvRV(sv);
79072805
LW		 225 switch (SvTYPE(sv)) {
226 case SVt_PVAV:
227 case SVt_PVHV:
228 case SVt_PVCV:
cea2e8a9 229 DIE(aTHX_ "Not a SCALAR reference");
79072805
LW		 230 }
231 }
232 else {
82d03984 233 gv = (GV*)sv;
748a9306 234
463ee0b2 235 if (SvTYPE(gv) != SVt_PVGV) {
a0d0e21e
LW		 236 if (SvGMAGICAL(sv)) {
237 mg_get(sv);
238 if (SvROK(sv))
239 goto wasref;
240 }
241 if (!SvOK(sv)) {
533c011a
NIS		 242 if (PL_op->op_flags & OPf_REF ||
243 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 244 DIE(aTHX_ PL_no_usym, "a SCALAR");
599cee73 245 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 246 report_uninit(sv);
a0d0e21e
LW		 247 RETSETUNDEF;
248 }
35cd451c
GS		 249 if ((PL_op->op_flags & OPf_SPECIAL) &&
250 !(PL_op->op_flags & OPf_MOD))
251 {
7a5fd60d 252 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
c9d5ac95 253 if (!gv
7a5fd60d
NC		 254 && (!is_gv_magical_sv(sv, 0)
255 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
c9d5ac95 256 {
35cd451c 257 RETSETUNDEF;
c9d5ac95 258 }
35cd451c
GS		 259 }
260 else {
261 if (PL_op->op_private & HINT_STRICT_REFS)
7a5fd60d
NC		 262 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
263 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
35cd451c 264 }
463ee0b2 265 }
29c711a3 266 sv = GvSVn(gv);
a0d0e21e 267 }
533c011a 268 if (PL_op->op_flags & OPf_MOD) {
82d03984
RGS		 269 if (PL_op->op_private & OPpLVAL_INTRO) {
270 if (cUNOP->op_first->op_type == OP_NULL)
271 sv = save_scalar((GV*)TOPs);
272 else if (gv)
273 sv = save_scalar(gv);
274 else
275 Perl_croak(aTHX_ PL_no_localize_ref);
276 }
533c011a
NIS		 277 else if (PL_op->op_private & OPpDEREF)
278 vivify_ref(sv, PL_op->op_private & OPpDEREF);
79072805 279 }
a0d0e21e 280 SETs(sv);
79072805
LW		 281 RETURN;
282}
283
284PP(pp_av2arylen)
285{
39644a26 286 dSP;
1b6737cc
AL		 287 AV * const av = (AV*)TOPs;
288 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
a3874608
NC		 289 if (!*sv) {
290 *sv = NEWSV(0,0);
291 sv_upgrade(*sv, SVt_PVMG);
292 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
79072805 293 }
a3874608 294 SETs(*sv);
79072805
LW		 295 RETURN;
296}
297
a0d0e21e
LW		 298PP(pp_pos)
299{
39644a26 300 dSP; dTARGET; dPOPss;
8ec5e241 301
78f9721b 302 if (PL_op->op_flags & OPf_MOD || LVRET) {
5f05dabc 303 if (SvTYPE(TARG) < SVt_PVLV) {
304 sv_upgrade(TARG, SVt_PVLV);
14befaf4 305 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
5f05dabc 306 }
307
308 LvTYPE(TARG) = '.';
6ff81951
GS		 309 if (LvTARG(TARG) != sv) {
310 if (LvTARG(TARG))
311 SvREFCNT_dec(LvTARG(TARG));
312 LvTARG(TARG) = SvREFCNT_inc(sv);
313 }
a0d0e21e
LW		 314 PUSHs(TARG); /* no SvSETMAGIC */
315 RETURN;
316 }
317 else {
a0d0e21e 318 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
1b6737cc 319 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
565764a8 320 if (mg && mg->mg_len >= 0) {
a0ed51b3 321 I32 i = mg->mg_len;
7e2040f0 322 if (DO_UTF8(sv))
a0ed51b3
LW		 323 sv_pos_b2u(sv, &i);
324 PUSHi(i + PL_curcop->cop_arybase);
a0d0e21e
LW		 325 RETURN;
326 }
327 }
328 RETPUSHUNDEF;
329 }
330}
331
79072805
LW		 332PP(pp_rv2cv)
333{
39644a26 334 dSP;
79072805
LW		 335 GV *gv;
336 HV *stash;
8990e307 337
4633a7c4
LW		 338 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
339 /* (But not in defined().) */
533c011a 340 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
07055b4c
CS		 341 if (cv) {
342 if (CvCLONE(cv))
343 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
d32f2495
SC		 344 if ((PL_op->op_private & OPpLVAL_INTRO)) {
345 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
346 cv = GvCV(gv);
347 if (!CvLVALUE(cv))
348 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
349 }
07055b4c
CS		 350 }
351 else
3280af22 352 cv = (CV*)&PL_sv_undef;
79072805
LW		 353 SETs((SV*)cv);
354 RETURN;
355}
356
c07a80fd 357PP(pp_prototype)
358{
39644a26 359 dSP;
c07a80fd 360 CV *cv;
361 HV *stash;
362 GV *gv;
363 SV *ret;
364
3280af22 365 ret = &PL_sv_undef;
b6c543e3 366 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
b15aece3 367 const char *s = SvPVX_const(TOPs);
b6c543e3 368 if (strnEQ(s, "CORE::", 6)) {
f54cb97a 369 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
b6c543e3
IZ		 370 if (code < 0) { /* Overridable. */
371#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
372 int i = 0, n = 0, seen_question = 0;
373 I32 oa;
374 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
375
bdf1bb36
RGS		 376 if (code == -KEY_chop || code == -KEY_chomp
377 || code == -KEY_exec || code == -KEY_system)
77bc9082 378 goto set;
b6c543e3 379 while (i < MAXO) { /* The slow way. */
22c35a8c
GS		 380 if (strEQ(s + 6, PL_op_name[i])
381 || strEQ(s + 6, PL_op_desc[i]))
382 {
b6c543e3 383 goto found;
22c35a8c 384 }
b6c543e3
IZ		 385 i++;
386 }
387 goto nonesuch; /* Should not happen... */
388 found:
22c35a8c 389 oa = PL_opargs[i] >> OASHIFT;
b6c543e3 390 while (oa) {
3012a639 391 if (oa & OA_OPTIONAL && !seen_question) {
b6c543e3
IZ		 392 seen_question = 1;
393 str[n++] = ';';
ef54e1a4 394 }
b13b2135 395 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
6e97e420
SC		 396 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
397 /* But globs are already references (kinda) */
398 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
399 ) {
b6c543e3
IZ		 400 str[n++] = '\\';
401 }
b6c543e3
IZ		 402 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
403 oa = oa >> 4;
404 }
405 str[n++] = '\0';
79cb57f6 406 ret = sv_2mortal(newSVpvn(str, n - 1));
ef54e1a4
JH		 407 }
408 else if (code) /* Non-Overridable */
b6c543e3
IZ		 409 goto set;
410 else { /* None such */
411 nonesuch:
d470f89e 412 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
b6c543e3
IZ		 413 }
414 }
415 }
c07a80fd 416 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
5f05dabc 417 if (cv && SvPOK(cv))
b15aece3 418 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
b6c543e3 419 set:
c07a80fd 420 SETs(ret);
421 RETURN;
422}
423
a0d0e21e
LW		 424PP(pp_anoncode)
425{
39644a26 426 dSP;
dd2155a4 427 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
a5f75d66 428 if (CvCLONE(cv))
b355b4e0 429 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
5f05dabc 430 EXTEND(SP,1);
748a9306 431 PUSHs((SV*)cv);
a0d0e21e
LW		 432 RETURN;
433}
434
435PP(pp_srefgen)
79072805 436{
39644a26 437 dSP;
71be2cbc 438 *SP = refto(*SP);
79072805 439 RETURN;
8ec5e241 440}
a0d0e21e
LW		 441
442PP(pp_refgen)
443{
39644a26 444 dSP; dMARK;
a0d0e21e 445 if (GIMME != G_ARRAY) {
5f0b1d4e
GS		 446 if (++MARK <= SP)
447 *MARK = *SP;
448 else
3280af22 449 *MARK = &PL_sv_undef;
5f0b1d4e
GS		 450 *MARK = refto(*MARK);
451 SP = MARK;
452 RETURN;
a0d0e21e 453 }
bbce6d69 454 EXTEND_MORTAL(SP - MARK);
71be2cbc 455 while (++MARK <= SP)
456 *MARK = refto(*MARK);
a0d0e21e 457 RETURN;
79072805
LW		 458}
459
76e3520e 460STATIC SV*
cea2e8a9 461S_refto(pTHX_ SV *sv)
71be2cbc 462{
463 SV* rv;
464
465 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
466 if (LvTARGLEN(sv))
68dc0745 467 vivify_defelem(sv);
468 if (!(sv = LvTARG(sv)))
3280af22 469 sv = &PL_sv_undef;
0dd88869 470 else
a6c40364 471 (void)SvREFCNT_inc(sv);
71be2cbc 472 }
d8b46c1b
GS		 473 else if (SvTYPE(sv) == SVt_PVAV) {
474 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
475 av_reify((AV*)sv);
476 SvTEMP_off(sv);
477 (void)SvREFCNT_inc(sv);
478 }
f2933f5f
DM		 479 else if (SvPADTMP(sv) && !IS_PADGV(sv))
480 sv = newSVsv(sv);
71be2cbc 481 else {
482 SvTEMP_off(sv);
483 (void)SvREFCNT_inc(sv);
484 }
485 rv = sv_newmortal();
486 sv_upgrade(rv, SVt_RV);
b162af07 487 SvRV_set(rv, sv);
71be2cbc 488 SvROK_on(rv);
489 return rv;
490}
491
79072805
LW		 492PP(pp_ref)
493{
39644a26 494 dSP; dTARGET;
e1ec3a88 495 const char *pv;
1b6737cc 496 SV * const sv = POPs;
f12c7020 497
5b295bef
RD		 498 if (sv)
499 SvGETMAGIC(sv);
f12c7020 500
a0d0e21e 501 if (!sv || !SvROK(sv))
4633a7c4 502 RETPUSHNO;
79072805 503
1b6737cc 504 pv = sv_reftype(SvRV(sv),TRUE);
463ee0b2 505 PUSHp(pv, strlen(pv));
79072805
LW		 506 RETURN;
507}
508
509PP(pp_bless)
510{
39644a26 511 dSP;
463ee0b2 512 HV *stash;
79072805 513
463ee0b2 514 if (MAXARG == 1)
11faa288 515 stash = CopSTASH(PL_curcop);
7b8d334a 516 else {
1b6737cc 517 SV * const ssv = POPs;
7b8d334a 518 STRLEN len;
e1ec3a88 519 const char *ptr;
81689caa 520
016a42f3 521 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
81689caa 522 Perl_croak(aTHX_ "Attempt to bless into a reference");
5c144d81 523 ptr = SvPV_const(ssv,len);
041457d9 524 if (len == 0 && ckWARN(WARN_MISC))
9014280d 525 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 526 "Explicit blessing to '' (assuming package main)");
7b8d334a
GS		 527 stash = gv_stashpvn(ptr, len, TRUE);
528 }
a0d0e21e 529
5d3fdfeb 530 (void)sv_bless(TOPs, stash);
79072805
LW		 531 RETURN;
532}
533
fb73857a 534PP(pp_gelem)
535{
39644a26 536 dSP;
b13b2135 537
1b6737cc
AL		 538 SV *sv = POPs;
539 const char * const elem = SvPV_nolen_const(sv);
540 GV * const gv = (GV*)POPs;
541 SV * tmpRef = Nullsv;
542
fb73857a 543 sv = Nullsv;
c4ba80c3
NC		 544 if (elem) {
545 /* elem will always be NUL terminated. */
1b6737cc 546 const char * const second_letter = elem + 1;
c4ba80c3
NC		 547 switch (*elem) {
548 case 'A':
1b6737cc 549 if (strEQ(second_letter, "RRAY"))
c4ba80c3
NC		 550 tmpRef = (SV*)GvAV(gv);
551 break;
552 case 'C':
1b6737cc 553 if (strEQ(second_letter, "ODE"))
c4ba80c3
NC		 554 tmpRef = (SV*)GvCVu(gv);
555 break;
556 case 'F':
1b6737cc 557 if (strEQ(second_letter, "ILEHANDLE")) {
c4ba80c3
NC		 558 /* finally deprecated in 5.8.0 */
559 deprecate("*glob{FILEHANDLE}");
560 tmpRef = (SV*)GvIOp(gv);
561 }
562 else
1b6737cc 563 if (strEQ(second_letter, "ORMAT"))
c4ba80c3
NC		 564 tmpRef = (SV*)GvFORM(gv);
565 break;
566 case 'G':
1b6737cc 567 if (strEQ(second_letter, "LOB"))
c4ba80c3
NC		 568 tmpRef = (SV*)gv;
569 break;
570 case 'H':
1b6737cc 571 if (strEQ(second_letter, "ASH"))
c4ba80c3
NC		 572 tmpRef = (SV*)GvHV(gv);
573 break;
574 case 'I':
1b6737cc 575 if (*second_letter == 'O' && !elem[2])
c4ba80c3
NC		 576 tmpRef = (SV*)GvIOp(gv);
577 break;
578 case 'N':
1b6737cc 579 if (strEQ(second_letter, "AME"))
c4ba80c3
NC		 580 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
581 break;
582 case 'P':
1b6737cc 583 if (strEQ(second_letter, "ACKAGE")) {
5aaec2b4
NC		 584 const HEK *hek = HvNAME_HEK(GvSTASH(gv));
585 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8);
c4ba80c3
NC		 586 }
587 break;
588 case 'S':
1b6737cc 589 if (strEQ(second_letter, "CALAR"))
c4ba80c3
NC		 590 tmpRef = GvSV(gv);
591 break;
39b99f21 592 }
fb73857a 593 }
76e3520e
GS		 594 if (tmpRef)
595 sv = newRV(tmpRef);
fb73857a 596 if (sv)
597 sv_2mortal(sv);
598 else
3280af22 599 sv = &PL_sv_undef;
fb73857a 600 XPUSHs(sv);
601 RETURN;
602}
603
a0d0e21e 604/* Pattern matching */
79072805 605
a0d0e21e 606PP(pp_study)
79072805 607{
39644a26 608 dSP; dPOPss;
a0d0e21e
LW		 609 register unsigned char *s;
610 register I32 pos;
611 register I32 ch;
612 register I32 *sfirst;
613 register I32 *snext;
a0d0e21e
LW		 614 STRLEN len;
615
3280af22 616 if (sv == PL_lastscream) {
1e422769 617 if (SvSCREAM(sv))
618 RETPUSHYES;
619 }
c07a80fd 620 else {
3280af22
NIS		 621 if (PL_lastscream) {
622 SvSCREAM_off(PL_lastscream);
623 SvREFCNT_dec(PL_lastscream);
c07a80fd 624 }
3280af22 625 PL_lastscream = SvREFCNT_inc(sv);
c07a80fd 626 }
1e422769 627
628 s = (unsigned char*)(SvPV(sv, len));
629 pos = len;
630 if (pos <= 0)
631 RETPUSHNO;
3280af22
NIS		 632 if (pos > PL_maxscream) {
633 if (PL_maxscream < 0) {
634 PL_maxscream = pos + 80;
a02a5408
JC		 635 Newx(PL_screamfirst, 256, I32);
636 Newx(PL_screamnext, PL_maxscream, I32);
79072805
LW		 637 }
638 else {
3280af22
NIS		 639 PL_maxscream = pos + pos / 4;
640 Renew(PL_screamnext, PL_maxscream, I32);
79072805 641 }
79072805 642 }
a0d0e21e 643
3280af22
NIS		 644 sfirst = PL_screamfirst;
645 snext = PL_screamnext;
a0d0e21e
LW		 646
647 if (!sfirst || !snext)
cea2e8a9 648 DIE(aTHX_ "do_study: out of memory");
a0d0e21e
LW		 649
650 for (ch = 256; ch; --ch)
651 *sfirst++ = -1;
652 sfirst -= 256;
653
654 while (--pos >= 0) {
1b6737cc 655 register const I32 ch = s[pos];
a0d0e21e
LW		 656 if (sfirst[ch] >= 0)
657 snext[pos] = sfirst[ch] - pos;
658 else
659 snext[pos] = -pos;
660 sfirst[ch] = pos;
79072805
LW		 661 }
662
c07a80fd 663 SvSCREAM_on(sv);
14befaf4
DM		 664 /* piggyback on m//g magic */
665 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
1e422769 666 RETPUSHYES;
79072805
LW		 667}
668
a0d0e21e 669PP(pp_trans)
79072805 670{
39644a26 671 dSP; dTARG;
a0d0e21e
LW		 672 SV *sv;
673
533c011a 674 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 675 sv = POPs;
59f00321
RGS		 676 else if (PL_op->op_private & OPpTARGET_MY)
677 sv = GETTARGET;
79072805 678 else {
54b9620d 679 sv = DEFSV;
a0d0e21e 680 EXTEND(SP,1);
79072805 681 }
adbc6bb1 682 TARG = sv_newmortal();
4757a243 683 PUSHi(do_trans(sv));
a0d0e21e 684 RETURN;
79072805
LW		 685}
686
a0d0e21e 687/* Lvalue operators. */
79072805 688
a0d0e21e
LW		 689PP(pp_schop)
690{
39644a26 691 dSP; dTARGET;
a0d0e21e
LW		 692 do_chop(TARG, TOPs);
693 SETTARG;
694 RETURN;
79072805
LW		 695}
696
a0d0e21e 697PP(pp_chop)
79072805 698{
2ec6af5f
RG		 699 dSP; dMARK; dTARGET; dORIGMARK;
700 while (MARK < SP)
701 do_chop(TARG, *++MARK);
702 SP = ORIGMARK;
b59aed67 703 XPUSHTARG;
a0d0e21e 704 RETURN;
79072805
LW		 705}
706
a0d0e21e 707PP(pp_schomp)
79072805 708{
39644a26 709 dSP; dTARGET;
a0d0e21e
LW		 710 SETi(do_chomp(TOPs));
711 RETURN;
79072805
LW		 712}
713
a0d0e21e 714PP(pp_chomp)
79072805 715{
39644a26 716 dSP; dMARK; dTARGET;
a0d0e21e 717 register I32 count = 0;
8ec5e241 718
a0d0e21e
LW		 719 while (SP > MARK)
720 count += do_chomp(POPs);
b59aed67 721 XPUSHi(count);
a0d0e21e 722 RETURN;
79072805
LW		 723}
724
a0d0e21e
LW		 725PP(pp_undef)
726{
39644a26 727 dSP;
a0d0e21e
LW		 728 SV *sv;
729
533c011a 730 if (!PL_op->op_private) {
774d564b 731 EXTEND(SP, 1);
a0d0e21e 732 RETPUSHUNDEF;
774d564b 733 }
79072805 734
a0d0e21e
LW		 735 sv = POPs;
736 if (!sv)
737 RETPUSHUNDEF;
85e6fe83 738
765f542d 739 SV_CHECK_THINKFIRST_COW_DROP(sv);
85e6fe83 740
a0d0e21e
LW		 741 switch (SvTYPE(sv)) {
742 case SVt_NULL:
743 break;
744 case SVt_PVAV:
745 av_undef((AV*)sv);
746 break;
747 case SVt_PVHV:
748 hv_undef((HV*)sv);
749 break;
750 case SVt_PVCV:
041457d9 751 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
9014280d 752 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
54310121 753 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
9607fc9c 754 /* FALL THROUGH */
755 case SVt_PVFM:
6fc92669
GS		 756 {
757 /* let user-undef'd sub keep its identity */
65c50114 758 GV* gv = CvGV((CV*)sv);
6fc92669
GS		 759 cv_undef((CV*)sv);
760 CvGV((CV*)sv) = gv;
761 }
a0d0e21e 762 break;
8e07c86e 763 case SVt_PVGV:
44a8e56a 764 if (SvFAKE(sv))
3280af22 765 SvSetMagicSV(sv, &PL_sv_undef);
20408e3c
GS		 766 else {
767 GP *gp;
768 gp_free((GV*)sv);
a02a5408 769 Newxz(gp, 1, GP);
20408e3c
GS		 770 GvGP(sv) = gp_ref(gp);
771 GvSV(sv) = NEWSV(72,0);
57843af0 772 GvLINE(sv) = CopLINE(PL_curcop);
20408e3c
GS		 773 GvEGV(sv) = (GV*)sv;
774 GvMULTI_on(sv);
775 }
44a8e56a 776 break;
a0d0e21e 777 default:
b15aece3 778 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
8bd4d4c5 779 SvPV_free(sv);
4633a7c4
LW		 780 SvPV_set(sv, Nullch);
781 SvLEN_set(sv, 0);
a0d0e21e 782 }
0c34ef67 783 SvOK_off(sv);
4633a7c4 784 SvSETMAGIC(sv);
79072805 785 }
a0d0e21e
LW		 786
787 RETPUSHUNDEF;
79072805
LW		 788}
789
a0d0e21e 790PP(pp_predec)
79072805 791{
39644a26 792 dSP;
f39684df 793 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
d470f89e 794 DIE(aTHX_ PL_no_modify);
3510b4a1
NC		 795 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
796 && SvIVX(TOPs) != IV_MIN)
55497cff 797 {
45977657 798 SvIV_set(TOPs, SvIVX(TOPs) - 1);
55497cff 799 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 800 }
801 else
802 sv_dec(TOPs);
a0d0e21e
LW		 803 SvSETMAGIC(TOPs);
804 return NORMAL;
805}
79072805 806
a0d0e21e
LW		 807PP(pp_postinc)
808{
39644a26 809 dSP; dTARGET;
f39684df 810 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
d470f89e 811 DIE(aTHX_ PL_no_modify);
a0d0e21e 812 sv_setsv(TARG, TOPs);
3510b4a1
NC		 813 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
814 && SvIVX(TOPs) != IV_MAX)
55497cff 815 {
45977657 816 SvIV_set(TOPs, SvIVX(TOPs) + 1);
55497cff 817 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 818 }
819 else
820 sv_inc(TOPs);
a0d0e21e 821 SvSETMAGIC(TOPs);
1e54a23f 822 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
a0d0e21e
LW		 823 if (!SvOK(TARG))
824 sv_setiv(TARG, 0);
825 SETs(TARG);
826 return NORMAL;
827}
79072805 828
a0d0e21e
LW		 829PP(pp_postdec)
830{
39644a26 831 dSP; dTARGET;
f39684df 832 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
d470f89e 833 DIE(aTHX_ PL_no_modify);
a0d0e21e 834 sv_setsv(TARG, TOPs);
3510b4a1
NC		 835 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
836 && SvIVX(TOPs) != IV_MIN)
55497cff 837 {
45977657 838 SvIV_set(TOPs, SvIVX(TOPs) - 1);
55497cff 839 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 840 }
841 else
842 sv_dec(TOPs);
a0d0e21e
LW		 843 SvSETMAGIC(TOPs);
844 SETs(TARG);
845 return NORMAL;
846}
79072805 847
a0d0e21e
LW		 848/* Ordinary operators. */
849
850PP(pp_pow)
851{
52a96ae6 852 dSP; dATARGET;
58d76dfd 853#ifdef PERL_PRESERVE_IVUV
52a96ae6
HS		 854 bool is_int = 0;
855#endif
856 tryAMAGICbin(pow,opASSIGN);
857#ifdef PERL_PRESERVE_IVUV
858 /* For integer to integer power, we do the calculation by hand wherever
859 we're sure it is safe; otherwise we call pow() and try to convert to
860 integer afterwards. */
58d76dfd 861 {
900658e3
PF		 862 SvIV_please(TOPs);
863 if (SvIOK(TOPs)) {
864 SvIV_please(TOPm1s);
865 if (SvIOK(TOPm1s)) {
866 UV power;
867 bool baseuok;
868 UV baseuv;
869
870 if (SvUOK(TOPs)) {
871 power = SvUVX(TOPs);
872 } else {
873 const IV iv = SvIVX(TOPs);
874 if (iv >= 0) {
875 power = iv;
876 } else {
877 goto float_it; /* Can't do negative powers this way. */
878 }
879 }
880
881 baseuok = SvUOK(TOPm1s);
882 if (baseuok) {
883 baseuv = SvUVX(TOPm1s);
884 } else {
885 const IV iv = SvIVX(TOPm1s);
886 if (iv >= 0) {
887 baseuv = iv;
888 baseuok = TRUE; /* effectively it's a UV now */
889 } else {
890 baseuv = -iv; /* abs, baseuok == false records sign */
891 }
892 }
52a96ae6
HS		 893 /* now we have integer ** positive integer. */
894 is_int = 1;
895
896 /* foo & (foo - 1) is zero only for a power of 2. */
58d76dfd 897 if (!(baseuv & (baseuv - 1))) {
52a96ae6 898 /* We are raising power-of-2 to a positive integer.
58d76dfd
JH		 899 The logic here will work for any base (even non-integer
900 bases) but it can be less accurate than
901 pow (base,power) or exp (power * log (base)) when the
902 intermediate values start to spill out of the mantissa.
903 With powers of 2 we know this can't happen.
904 And powers of 2 are the favourite thing for perl
905 programmers to notice ** not doing what they mean. */
906 NV result = 1.0;
907 NV base = baseuok ? baseuv : -(NV)baseuv;
900658e3
PF		 908
909 if (power & 1) {
910 result *= base;
911 }
912 while (power >>= 1) {
913 base *= base;
914 if (power & 1) {
915 result *= base;
916 }
917 }
58d76dfd
JH		 918 SP--;
919 SETn( result );
52a96ae6 920 SvIV_please(TOPs);
58d76dfd 921 RETURN;
52a96ae6
HS		 922 } else {
923 register unsigned int highbit = 8 * sizeof(UV);
900658e3
PF		 924 register unsigned int diff = 8 * sizeof(UV);
925 while (diff >>= 1) {
926 highbit -= diff;
927 if (baseuv >> highbit) {
928 highbit += diff;
929 }
52a96ae6
HS		 930 }
931 /* we now have baseuv < 2 ** highbit */
932 if (power * highbit <= 8 * sizeof(UV)) {
933 /* result will definitely fit in UV, so use UV math
934 on same algorithm as above */
935 register UV result = 1;
936 register UV base = baseuv;
900658e3
PF		 937 const bool odd_power = (bool)(power & 1);
938 if (odd_power) {
939 result *= base;
940 }
941 while (power >>= 1) {
942 base *= base;
943 if (power & 1) {
52a96ae6 944 result *= base;
52a96ae6
HS		 945 }
946 }
947 SP--;
0615a994 948 if (baseuok || !odd_power)
52a96ae6
HS		 949 /* answer is positive */
950 SETu( result );
951 else if (result <= (UV)IV_MAX)
952 /* answer negative, fits in IV */
953 SETi( -(IV)result );
954 else if (result == (UV)IV_MIN)
955 /* 2's complement assumption: special case IV_MIN */
956 SETi( IV_MIN );
957 else
958 /* answer negative, doesn't fit */
959 SETn( -(NV)result );
960 RETURN;
961 }
962 }
963 }
964 }
58d76dfd 965 }
52a96ae6 966 float_it:
58d76dfd 967#endif
a0d0e21e 968 {
52a96ae6
HS		 969 dPOPTOPnnrl;
970 SETn( Perl_pow( left, right) );
971#ifdef PERL_PRESERVE_IVUV
972 if (is_int)
973 SvIV_please(TOPs);
974#endif
975 RETURN;
93a17b20 976 }
a0d0e21e
LW		 977}
978
979PP(pp_multiply)
980{
39644a26 981 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
28e5dec8
JH		 982#ifdef PERL_PRESERVE_IVUV
983 SvIV_please(TOPs);
984 if (SvIOK(TOPs)) {
985 /* Unless the left argument is integer in range we are going to have to
986 use NV maths. Hence only attempt to coerce the right argument if
987 we know the left is integer. */
988 /* Left operand is defined, so is it IV? */
989 SvIV_please(TOPm1s);
990 if (SvIOK(TOPm1s)) {
991 bool auvok = SvUOK(TOPm1s);
992 bool buvok = SvUOK(TOPs);
993 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
994 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
995 UV alow;
996 UV ahigh;
997 UV blow;
998 UV bhigh;
999
1000 if (auvok) {
1001 alow = SvUVX(TOPm1s);
1002 } else {
1b6737cc 1003 const IV aiv = SvIVX(TOPm1s);
28e5dec8
JH		 1004 if (aiv >= 0) {
1005 alow = aiv;
1006 auvok = TRUE; /* effectively it's a UV now */
1007 } else {
1008 alow = -aiv; /* abs, auvok == false records sign */
1009 }
1010 }
1011 if (buvok) {
1012 blow = SvUVX(TOPs);
1013 } else {
1b6737cc 1014 const IV biv = SvIVX(TOPs);
28e5dec8
JH		 1015 if (biv >= 0) {
1016 blow = biv;
1017 buvok = TRUE; /* effectively it's a UV now */
1018 } else {
1019 blow = -biv; /* abs, buvok == false records sign */
1020 }
1021 }
1022
1023 /* If this does sign extension on unsigned it's time for plan B */
1024 ahigh = alow >> (4 * sizeof (UV));
1025 alow &= botmask;
1026 bhigh = blow >> (4 * sizeof (UV));
1027 blow &= botmask;
1028 if (ahigh && bhigh) {
1029 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1030 which is overflow. Drop to NVs below. */
1031 } else if (!ahigh && !bhigh) {
1032 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1033 so the unsigned multiply cannot overflow. */
1034 UV product = alow * blow;
1035 if (auvok == buvok) {
1036 /* -ve * -ve or +ve * +ve gives a +ve result. */
1037 SP--;
1038 SETu( product );
1039 RETURN;
1040 } else if (product <= (UV)IV_MIN) {
1041 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1042 /* -ve result, which could overflow an IV */
1043 SP--;
25716404 1044 SETi( -(IV)product );
28e5dec8
JH		 1045 RETURN;
1046 } /* else drop to NVs below. */
1047 } else {
1048 /* One operand is large, 1 small */
1049 UV product_middle;
1050 if (bhigh) {
1051 /* swap the operands */
1052 ahigh = bhigh;
1053 bhigh = blow; /* bhigh now the temp var for the swap */
1054 blow = alow;
1055 alow = bhigh;
1056 }
1057 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1058 multiplies can't overflow. shift can, add can, -ve can. */
1059 product_middle = ahigh * blow;
1060 if (!(product_middle & topmask)) {
1061 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1062 UV product_low;
1063 product_middle <<= (4 * sizeof (UV));
1064 product_low = alow * blow;
1065
1066 /* as for pp_add, UV + something mustn't get smaller.
1067 IIRC ANSI mandates this wrapping *behaviour* for
1068 unsigned whatever the actual representation*/
1069 product_low += product_middle;
1070 if (product_low >= product_middle) {
1071 /* didn't overflow */
1072 if (auvok == buvok) {
1073 /* -ve * -ve or +ve * +ve gives a +ve result. */
1074 SP--;
1075 SETu( product_low );
1076 RETURN;
1077 } else if (product_low <= (UV)IV_MIN) {
1078 /* 2s complement assumption again */
1079 /* -ve result, which could overflow an IV */
1080 SP--;
25716404 1081 SETi( -(IV)product_low );
28e5dec8
JH		 1082 RETURN;
1083 } /* else drop to NVs below. */
1084 }
1085 } /* product_middle too large */
1086 } /* ahigh && bhigh */
1087 } /* SvIOK(TOPm1s) */
1088 } /* SvIOK(TOPs) */
1089#endif
a0d0e21e
LW		 1090 {
1091 dPOPTOPnnrl;
1092 SETn( left * right );
1093 RETURN;
79072805 1094 }
a0d0e21e
LW		 1095}
1096
1097PP(pp_divide)
1098{
39644a26 1099 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
5479d192 1100 /* Only try to do UV divide first
68795e93 1101 if ((SLOPPYDIVIDE is true) or
5479d192
NC		 1102 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1103 to preserve))
1104 The assumption is that it is better to use floating point divide
1105 whenever possible, only doing integer divide first if we can't be sure.
1106 If NV_PRESERVES_UV is true then we know at compile time that no UV
1107 can be too large to preserve, so don't need to compile the code to
1108 test the size of UVs. */
1109
a0d0e21e 1110#ifdef SLOPPYDIVIDE
5479d192
NC		 1111# define PERL_TRY_UV_DIVIDE
1112 /* ensure that 20./5. == 4. */
a0d0e21e 1113#else
5479d192
NC		 1114# ifdef PERL_PRESERVE_IVUV
1115# ifndef NV_PRESERVES_UV
1116# define PERL_TRY_UV_DIVIDE
1117# endif
1118# endif
a0d0e21e 1119#endif
5479d192
NC		 1120
1121#ifdef PERL_TRY_UV_DIVIDE
1122 SvIV_please(TOPs);
1123 if (SvIOK(TOPs)) {
1124 SvIV_please(TOPm1s);
1125 if (SvIOK(TOPm1s)) {
1126 bool left_non_neg = SvUOK(TOPm1s);
1127 bool right_non_neg = SvUOK(TOPs);
1128 UV left;
1129 UV right;
1130
1131 if (right_non_neg) {
1132 right = SvUVX(TOPs);
1133 }
1134 else {
1b6737cc 1135 const IV biv = SvIVX(TOPs);
5479d192
NC		 1136 if (biv >= 0) {
1137 right = biv;
1138 right_non_neg = TRUE; /* effectively it's a UV now */
1139 }
1140 else {
1141 right = -biv;
1142 }
1143 }
1144 /* historically undef()/0 gives a "Use of uninitialized value"
1145 warning before dieing, hence this test goes here.
1146 If it were immediately before the second SvIV_please, then
1147 DIE() would be invoked before left was even inspected, so
1148 no inpsection would give no warning. */
1149 if (right == 0)
1150 DIE(aTHX_ "Illegal division by zero");
1151
1152 if (left_non_neg) {
1153 left = SvUVX(TOPm1s);
1154 }
1155 else {
1b6737cc 1156 const IV aiv = SvIVX(TOPm1s);
5479d192
NC		 1157 if (aiv >= 0) {
1158 left = aiv;
1159 left_non_neg = TRUE; /* effectively it's a UV now */
1160 }
1161 else {
1162 left = -aiv;
1163 }
1164 }
1165
1166 if (left >= right
1167#ifdef SLOPPYDIVIDE
1168 /* For sloppy divide we always attempt integer division. */
1169#else
1170 /* Otherwise we only attempt it if either or both operands
1171 would not be preserved by an NV. If both fit in NVs
0c2ee62a
NC		 1172 we fall through to the NV divide code below. However,
1173 as left >= right to ensure integer result here, we know that
1174 we can skip the test on the right operand - right big
1175 enough not to be preserved can't get here unless left is
1176 also too big. */
1177
1178 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
5479d192
NC		 1179#endif
1180 ) {
1181 /* Integer division can't overflow, but it can be imprecise. */
1b6737cc 1182 const UV result = left / right;
5479d192
NC		 1183 if (result * right == left) {
1184 SP--; /* result is valid */
1185 if (left_non_neg == right_non_neg) {
1186 /* signs identical, result is positive. */
1187 SETu( result );
1188 RETURN;
1189 }
1190 /* 2s complement assumption */
1191 if (result <= (UV)IV_MIN)
91f3b821 1192 SETi( -(IV)result );
5479d192
NC		 1193 else {
1194 /* It's exact but too negative for IV. */
1195 SETn( -(NV)result );
1196 }
1197 RETURN;
1198 } /* tried integer divide but it was not an integer result */
32fdb065 1199 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
5479d192
NC		 1200 } /* left wasn't SvIOK */
1201 } /* right wasn't SvIOK */
1202#endif /* PERL_TRY_UV_DIVIDE */
1203 {
1204 dPOPPOPnnrl;
1205 if (right == 0.0)
1206 DIE(aTHX_ "Illegal division by zero");
1207 PUSHn( left / right );
1208 RETURN;
79072805 1209 }
a0d0e21e
LW		 1210}
1211
1212PP(pp_modulo)
1213{
39644a26 1214 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
a0d0e21e 1215 {
9c5ffd7c
JH		 1216 UV left = 0;
1217 UV right = 0;
dc656993
JH		 1218 bool left_neg = FALSE;
1219 bool right_neg = FALSE;
e2c88acc
NC		 1220 bool use_double = FALSE;
1221 bool dright_valid = FALSE;
9c5ffd7c
JH		 1222 NV dright = 0.0;
1223 NV dleft = 0.0;
787eafbd 1224
e2c88acc
NC		 1225 SvIV_please(TOPs);
1226 if (SvIOK(TOPs)) {
1227 right_neg = !SvUOK(TOPs);
1228 if (!right_neg) {
1229 right = SvUVX(POPs);
1230 } else {
1b6737cc 1231 const IV biv = SvIVX(POPs);
e2c88acc
NC		 1232 if (biv >= 0) {
1233 right = biv;
1234 right_neg = FALSE; /* effectively it's a UV now */
1235 } else {
1236 right = -biv;
1237 }
1238 }
1239 }
1240 else {
787eafbd 1241 dright = POPn;
787eafbd
IZ		 1242 right_neg = dright < 0;
1243 if (right_neg)
1244 dright = -dright;
e2c88acc
NC		 1245 if (dright < UV_MAX_P1) {
1246 right = U_V(dright);
1247 dright_valid = TRUE; /* In case we need to use double below. */
1248 } else {
1249 use_double = TRUE;
1250 }
787eafbd 1251 }
a0d0e21e 1252
e2c88acc
NC		 1253 /* At this point use_double is only true if right is out of range for
1254 a UV. In range NV has been rounded down to nearest UV and
1255 use_double false. */
1256 SvIV_please(TOPs);
1257 if (!use_double && SvIOK(TOPs)) {
1258 if (SvIOK(TOPs)) {
1259 left_neg = !SvUOK(TOPs);
1260 if (!left_neg) {
1261 left = SvUVX(POPs);
1262 } else {
1263 IV aiv = SvIVX(POPs);
1264 if (aiv >= 0) {
1265 left = aiv;
1266 left_neg = FALSE; /* effectively it's a UV now */
1267 } else {
1268 left = -aiv;
1269 }
1270 }
1271 }
1272 }
787eafbd
IZ		 1273 else {
1274 dleft = POPn;
787eafbd
IZ		 1275 left_neg = dleft < 0;
1276 if (left_neg)
1277 dleft = -dleft;
68dc0745 1278
e2c88acc
NC		 1279 /* This should be exactly the 5.6 behaviour - if left and right are
1280 both in range for UV then use U_V() rather than floor. */
1281 if (!use_double) {
1282 if (dleft < UV_MAX_P1) {
1283 /* right was in range, so is dleft, so use UVs not double.
1284 */
1285 left = U_V(dleft);
1286 }
1287 /* left is out of range for UV, right was in range, so promote
1288 right (back) to double. */
1289 else {
1290 /* The +0.5 is used in 5.6 even though it is not strictly
1291 consistent with the implicit +0 floor in the U_V()
1292 inside the #if 1. */
1293 dleft = Perl_floor(dleft + 0.5);
1294 use_double = TRUE;
1295 if (dright_valid)
1296 dright = Perl_floor(dright + 0.5);
1297 else
1298 dright = right;
1299 }
1300 }
1301 }
787eafbd 1302 if (use_double) {
65202027 1303 NV dans;
787eafbd 1304
787eafbd 1305 if (!dright)
cea2e8a9 1306 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1307
65202027 1308 dans = Perl_fmod(dleft, dright);
787eafbd
IZ		 1309 if ((left_neg != right_neg) && dans)
1310 dans = dright - dans;
1311 if (right_neg)
1312 dans = -dans;
1313 sv_setnv(TARG, dans);
1314 }
1315 else {
1316 UV ans;
1317
787eafbd 1318 if (!right)
cea2e8a9 1319 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ		 1320
1321 ans = left % right;
1322 if ((left_neg != right_neg) && ans)
1323 ans = right - ans;
1324 if (right_neg) {
1325 /* XXX may warn: unary minus operator applied to unsigned type */
1326 /* could change -foo to be (~foo)+1 instead */
1327 if (ans <= ~((UV)IV_MAX)+1)
1328 sv_setiv(TARG, ~ans+1);
1329 else
65202027 1330 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ		 1331 }
1332 else
1333 sv_setuv(TARG, ans);
1334 }
1335 PUSHTARG;
1336 RETURN;
79072805 1337 }
a0d0e21e 1338}
79072805 1339
a0d0e21e
LW		 1340PP(pp_repeat)
1341{
39644a26 1342 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
748a9306 1343 {
2b573ace
JH		 1344 register IV count;
1345 dPOPss;
5b295bef 1346 SvGETMAGIC(sv);
2b573ace
JH		 1347 if (SvIOKp(sv)) {
1348 if (SvUOK(sv)) {
1b6737cc 1349 const UV uv = SvUV(sv);
2b573ace
JH		 1350 if (uv > IV_MAX)
1351 count = IV_MAX; /* The best we can do? */
1352 else
1353 count = uv;
1354 } else {
1355 IV iv = SvIV(sv);
1356 if (iv < 0)
1357 count = 0;
1358 else
1359 count = iv;
1360 }
1361 }
1362 else if (SvNOKp(sv)) {
1b6737cc 1363 const NV nv = SvNV(sv);
2b573ace
JH		 1364 if (nv < 0.0)
1365 count = 0;
1366 else
1367 count = (IV)nv;
1368 }
1369 else
1370 count = SvIVx(sv);
533c011a 1371 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e
LW		 1372 dMARK;
1373 I32 items = SP - MARK;
1374 I32 max;
2b573ace
JH		 1375 static const char oom_list_extend[] =
1376 "Out of memory during list extend";
79072805 1377
a0d0e21e 1378 max = items * count;
2b573ace
JH		 1379 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1380 /* Did the max computation overflow? */
27d5b266 1381 if (items > 0 && max > 0 && (max < items || max < count))
2b573ace 1382 Perl_croak(aTHX_ oom_list_extend);
a0d0e21e
LW		 1383 MEXTEND(MARK, max);
1384 if (count > 1) {
1385 while (SP > MARK) {
976c8a39
JH		 1386#if 0
1387 /* This code was intended to fix 20010809.028:
1388
1389 $x = 'abcd';
1390 for (($x =~ /./g) x 2) {
1391 print chop; # "abcdabcd" expected as output.
1392 }
1393
1394 * but that change (#11635) broke this code:
1395
1396 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1397
1398 * I can't think of a better fix that doesn't introduce
1399 * an efficiency hit by copying the SVs. The stack isn't
1400 * refcounted, and mortalisation obviously doesn't
1401 * Do The Right Thing when the stack has more than
1402 * one pointer to the same mortal value.
1403 * .robin.
1404 */
e30acc16
RH		 1405 if (*SP) {
1406 *SP = sv_2mortal(newSVsv(*SP));
1407 SvREADONLY_on(*SP);
1408 }
976c8a39
JH		 1409#else
1410 if (*SP)
1411 SvTEMP_off((*SP));
1412#endif
a0d0e21e 1413 SP--;
79072805 1414 }
a0d0e21e
LW		 1415 MARK++;
1416 repeatcpy((char*)(MARK + items), (char*)MARK,
1417 items * sizeof(SV*), count - 1);
1418 SP += max;
79072805 1419 }
a0d0e21e
LW		 1420 else if (count <= 0)
1421 SP -= items;
79072805 1422 }
a0d0e21e 1423 else { /* Note: mark already snarfed by pp_list */
dfcb284a 1424 SV *tmpstr = POPs;
a0d0e21e 1425 STRLEN len;
9b877dbb 1426 bool isutf;
2b573ace
JH		 1427 static const char oom_string_extend[] =
1428 "Out of memory during string extend";
a0d0e21e 1429
a0d0e21e
LW		 1430 SvSetSV(TARG, tmpstr);
1431 SvPV_force(TARG, len);
9b877dbb 1432 isutf = DO_UTF8(TARG);
8ebc5c01 1433 if (count != 1) {
1434 if (count < 1)
1435 SvCUR_set(TARG, 0);
1436 else {
991350d8 1437 STRLEN max = (UV)count * len;
2b573ace
JH		 1438 if (len > ((MEM_SIZE)~0)/count)
1439 Perl_croak(aTHX_ oom_string_extend);
1440 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
8569b9dc 1441 SvGROW(TARG, max + 1);
a0d0e21e 1442 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
b162af07 1443 SvCUR_set(TARG, SvCUR(TARG) * count);
7a4c00b4 1444 }
a0d0e21e 1445 *SvEND(TARG) = '\0';
a0d0e21e 1446 }
dfcb284a
GS		 1447 if (isutf)
1448 (void)SvPOK_only_UTF8(TARG);
1449 else
1450 (void)SvPOK_only(TARG);
b80b6069
RH		 1451
1452 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1453 /* The parser saw this as a list repeat, and there
1454 are probably several items on the stack. But we're
1455 in scalar context, and there's no pp_list to save us
1456 now. So drop the rest of the items -- robin@kitsite.com
1457 */
1458 dMARK;
1459 SP = MARK;
1460 }
a0d0e21e 1461 PUSHTARG;
79072805 1462 }
a0d0e21e 1463 RETURN;
748a9306 1464 }
a0d0e21e 1465}
79072805 1466
a0d0e21e
LW		 1467PP(pp_subtract)
1468{
39644a26 1469 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
28e5dec8
JH		 1470 useleft = USE_LEFT(TOPm1s);
1471#ifdef PERL_PRESERVE_IVUV
7dca457a
NC		 1472 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1473 "bad things" happen if you rely on signed integers wrapping. */
28e5dec8
JH		 1474 SvIV_please(TOPs);
1475 if (SvIOK(TOPs)) {
1476 /* Unless the left argument is integer in range we are going to have to
1477 use NV maths. Hence only attempt to coerce the right argument if
1478 we know the left is integer. */
9c5ffd7c
JH		 1479 register UV auv = 0;
1480 bool auvok = FALSE;
7dca457a
NC		 1481 bool a_valid = 0;
1482
28e5dec8 1483 if (!useleft) {
7dca457a
NC		 1484 auv = 0;
1485 a_valid = auvok = 1;
1486 /* left operand is undef, treat as zero. */
28e5dec8
JH		 1487 } else {
1488 /* Left operand is defined, so is it IV? */
1489 SvIV_please(TOPm1s);
1490 if (SvIOK(TOPm1s)) {
7dca457a
NC		 1491 if ((auvok = SvUOK(TOPm1s)))
1492 auv = SvUVX(TOPm1s);
1493 else {
1b6737cc 1494 register const IV aiv = SvIVX(TOPm1s);
7dca457a
NC		 1495 if (aiv >= 0) {
1496 auv = aiv;
1497 auvok = 1; /* Now acting as a sign flag. */
1498 } else { /* 2s complement assumption for IV_MIN */
1499 auv = (UV)-aiv;
28e5dec8 1500 }
7dca457a
NC		 1501 }
1502 a_valid = 1;
1503 }
1504 }
1505 if (a_valid) {
1506 bool result_good = 0;
1507 UV result;
1508 register UV buv;
1509 bool buvok = SvUOK(TOPs);
9041c2e3 1510
7dca457a
NC		 1511 if (buvok)
1512 buv = SvUVX(TOPs);
1513 else {
1b6737cc 1514 register const IV biv = SvIVX(TOPs);
7dca457a
NC		 1515 if (biv >= 0) {
1516 buv = biv;
1517 buvok = 1;
1518 } else
1519 buv = (UV)-biv;
1520 }
1521 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1522 else "IV" now, independent of how it came in.
7dca457a
NC		 1523 if a, b represents positive, A, B negative, a maps to -A etc
1524 a - b => (a - b)
1525 A - b => -(a + b)
1526 a - B => (a + b)
1527 A - B => -(a - b)
1528 all UV maths. negate result if A negative.
1529 subtract if signs same, add if signs differ. */
1530
1531 if (auvok ^ buvok) {
1532 /* Signs differ. */
1533 result = auv + buv;
1534 if (result >= auv)
1535 result_good = 1;
1536 } else {
1537 /* Signs same */
1538 if (auv >= buv) {
1539 result = auv - buv;
1540 /* Must get smaller */
1541 if (result <= auv)
1542 result_good = 1;
1543 } else {
1544 result = buv - auv;
1545 if (result <= buv) {
1546 /* result really should be -(auv-buv). as its negation
1547 of true value, need to swap our result flag */
1548 auvok = !auvok;
1549 result_good = 1;
28e5dec8 1550 }
28e5dec8
JH		 1551 }
1552 }
7dca457a
NC		 1553 if (result_good) {
1554 SP--;
1555 if (auvok)
1556 SETu( result );
1557 else {
1558 /* Negate result */
1559 if (result <= (UV)IV_MIN)
1560 SETi( -(IV)result );
1561 else {
1562 /* result valid, but out of range for IV. */
1563 SETn( -(NV)result );
1564 }
1565 }
1566 RETURN;
1567 } /* Overflow, drop through to NVs. */
28e5dec8
JH		 1568 }
1569 }
1570#endif
7dca457a 1571 useleft = USE_LEFT(TOPm1s);
a0d0e21e 1572 {
28e5dec8
JH		 1573 dPOPnv;
1574 if (!useleft) {
1575 /* left operand is undef, treat as zero - value */
1576 SETn(-value);
1577 RETURN;
1578 }
1579 SETn( TOPn - value );
1580 RETURN;
79072805 1581 }
a0d0e21e 1582}
79072805 1583
a0d0e21e
LW		 1584PP(pp_left_shift)
1585{
39644a26 1586 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
a0d0e21e 1587 {
1b6737cc 1588 const IV shift = POPi;
d0ba1bd2 1589 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1590 IV i = TOPi;
1591 SETi(i << shift);
d0ba1bd2
JH		 1592 }
1593 else {
972b05a9
JH		 1594 UV u = TOPu;
1595 SETu(u << shift);
d0ba1bd2 1596 }
55497cff 1597 RETURN;
79072805 1598 }
a0d0e21e 1599}
79072805 1600
a0d0e21e
LW		 1601PP(pp_right_shift)
1602{
39644a26 1603 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
a0d0e21e 1604 {
1b6737cc 1605 const IV shift = POPi;
d0ba1bd2 1606 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1607 IV i = TOPi;
1608 SETi(i >> shift);
d0ba1bd2
JH		 1609 }
1610 else {
972b05a9
JH		 1611 UV u = TOPu;
1612 SETu(u >> shift);
d0ba1bd2 1613 }
a0d0e21e 1614 RETURN;
93a17b20 1615 }
79072805
LW		 1616}
1617
a0d0e21e 1618PP(pp_lt)
79072805 1619{
39644a26 1620 dSP; tryAMAGICbinSET(lt,0);
28e5dec8
JH		 1621#ifdef PERL_PRESERVE_IVUV
1622 SvIV_please(TOPs);
1623 if (SvIOK(TOPs)) {
1624 SvIV_please(TOPm1s);
1625 if (SvIOK(TOPm1s)) {
1626 bool auvok = SvUOK(TOPm1s);
1627 bool buvok = SvUOK(TOPs);
a227d84d 1628
28e5dec8 1629 if (!auvok && !buvok) { /* ## IV < IV ## */
1b6737cc
AL		 1630 const IV aiv = SvIVX(TOPm1s);
1631 const IV biv = SvIVX(TOPs);
28e5dec8
JH		 1632
1633 SP--;
1634 SETs(boolSV(aiv < biv));
1635 RETURN;
1636 }
1637 if (auvok && buvok) { /* ## UV < UV ## */
1b6737cc
AL		 1638 const UV auv = SvUVX(TOPm1s);
1639 const UV buv = SvUVX(TOPs);
28e5dec8
JH		 1640
1641 SP--;
1642 SETs(boolSV(auv < buv));
1643 RETURN;
1644 }
1645 if (auvok) { /* ## UV < IV ## */
1646 UV auv;
1b6737cc 1647 const IV biv = SvIVX(TOPs);
28e5dec8
JH		 1648 SP--;
1649 if (biv < 0) {
1650 /* As (a) is a UV, it's >=0, so it cannot be < */
1651 SETs(&PL_sv_no);
1652 RETURN;
1653 }
1654 auv = SvUVX(TOPs);
28e5dec8
JH		 1655 SETs(boolSV(auv < (UV)biv));
1656 RETURN;
1657 }
1658 { /* ## IV < UV ## */
1b6737cc 1659 const IV aiv = SvIVX(TOPm1s);
28e5dec8
JH		 1660 UV buv;
1661
28e5dec8
JH		 1662 if (aiv < 0) {
1663 /* As (b) is a UV, it's >=0, so it must be < */
1664 SP--;
1665 SETs(&PL_sv_yes);
1666 RETURN;
1667 }
1668 buv = SvUVX(TOPs);
1669 SP--;
28e5dec8
JH		 1670 SETs(boolSV((UV)aiv < buv));
1671 RETURN;
1672 }
1673 }
1674 }
1675#endif
30de85b6 1676#ifndef NV_PRESERVES_UV
50fb3111
NC		 1677#ifdef PERL_PRESERVE_IVUV
1678 else
1679#endif
0bdaccee
NC		 1680 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1681 SP--;
1682 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1683 RETURN;
1684 }
30de85b6 1685#endif
a0d0e21e
LW		 1686 {
1687 dPOPnv;
54310121 1688 SETs(boolSV(TOPn < value));
a0d0e21e 1689 RETURN;
79072805 1690 }
a0d0e21e 1691}
79072805 1692
a0d0e21e
LW		 1693PP(pp_gt)
1694{
39644a26 1695 dSP; tryAMAGICbinSET(gt,0);
28e5dec8
JH		 1696#ifdef PERL_PRESERVE_IVUV
1697 SvIV_please(TOPs);
1698 if (SvIOK(TOPs)) {
1699 SvIV_please(TOPm1s);
1700 if (SvIOK(TOPm1s)) {
1701 bool auvok = SvUOK(TOPm1s);
1702 bool buvok = SvUOK(TOPs);
a227d84d 1703
28e5dec8 1704 if (!auvok && !buvok) { /* ## IV > IV ## */
1b6737cc
AL		 1705 const IV aiv = SvIVX(TOPm1s);
1706 const IV biv = SvIVX(TOPs);
1707
28e5dec8
JH		 1708 SP--;
1709 SETs(boolSV(aiv > biv));
1710 RETURN;
1711 }
1712 if (auvok && buvok) { /* ## UV > UV ## */
1b6737cc
AL		 1713 const UV auv = SvUVX(TOPm1s);
1714 const UV buv = SvUVX(TOPs);
28e5dec8
JH		 1715
1716 SP--;
1717 SETs(boolSV(auv > buv));
1718 RETURN;
1719 }
1720 if (auvok) { /* ## UV > IV ## */
1721 UV auv;
1b6737cc
AL		 1722 const IV biv = SvIVX(TOPs);
1723
28e5dec8
JH		 1724 SP--;
1725 if (biv < 0) {
1726 /* As (a) is a UV, it's >=0, so it must be > */
1727 SETs(&PL_sv_yes);
1728 RETURN;
1729 }
1730 auv = SvUVX(TOPs);
28e5dec8
JH		 1731 SETs(boolSV(auv > (UV)biv));
1732 RETURN;
1733 }
1734 { /* ## IV > UV ## */
1b6737cc 1735 const IV aiv = SvIVX(TOPm1s);
28e5dec8
JH		 1736 UV buv;
1737
28e5dec8
JH		 1738 if (aiv < 0) {
1739 /* As (b) is a UV, it's >=0, so it cannot be > */
1740 SP--;
1741 SETs(&PL_sv_no);
1742 RETURN;
1743 }
1744 buv = SvUVX(TOPs);
1745 SP--;
28e5dec8
JH		 1746 SETs(boolSV((UV)aiv > buv));
1747 RETURN;
1748 }
1749 }
1750 }
1751#endif
30de85b6 1752#ifndef NV_PRESERVES_UV
50fb3111
NC		 1753#ifdef PERL_PRESERVE_IVUV
1754 else
1755#endif
0bdaccee 1756 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
30de85b6
NC		 1757 SP--;
1758 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1759 RETURN;
1760 }
1761#endif
a0d0e21e
LW		 1762 {
1763 dPOPnv;
54310121 1764 SETs(boolSV(TOPn > value));
a0d0e21e 1765 RETURN;
79072805 1766 }
a0d0e21e
LW		 1767}
1768
1769PP(pp_le)
1770{
39644a26 1771 dSP; tryAMAGICbinSET(le,0);
28e5dec8
JH		 1772#ifdef PERL_PRESERVE_IVUV
1773 SvIV_please(TOPs);
1774 if (SvIOK(TOPs)) {
1775 SvIV_please(TOPm1s);
1776 if (SvIOK(TOPm1s)) {
1777 bool auvok = SvUOK(TOPm1s);
1778 bool buvok = SvUOK(TOPs);
a227d84d 1779
28e5dec8 1780 if (!auvok && !buvok) { /* ## IV <= IV ## */
1b6737cc
AL		 1781 const IV aiv = SvIVX(TOPm1s);
1782 const IV biv = SvIVX(TOPs);
28e5dec8
JH		 1783
1784 SP--;
1785 SETs(boolSV(aiv <= biv));
1786 RETURN;
1787 }
1788 if (auvok && buvok) { /* ## UV <= UV ## */
1789 UV auv = SvUVX(TOPm1s);
1790 UV buv = SvUVX(TOPs);
1791
1792 SP--;
1793 SETs(boolSV(auv <= buv));
1794 RETURN;
1795 }
1796 if (auvok) { /* ## UV <= IV ## */
1797 UV auv;
1b6737cc
AL		 1798 const IV biv = SvIVX(TOPs);
1799
28e5dec8
JH		 1800 SP--;
1801 if (biv < 0) {
1802 /* As (a) is a UV, it's >=0, so a cannot be <= */
1803 SETs(&PL_sv_no);
1804 RETURN;
1805 }
1806 auv = SvUVX(TOPs);
28e5dec8
JH		 1807 SETs(boolSV(auv <= (UV)biv));
1808 RETURN;
1809 }
1810 { /* ## IV <= UV ## */
1b6737cc 1811 const IV aiv = SvIVX(TOPm1s);
28e5dec8 1812 UV buv;
1b6737cc 1813
28e5dec8
JH		 1814 if (aiv < 0) {
1815 /* As (b) is a UV, it's >=0, so a must be <= */
1816 SP--;
1817 SETs(&PL_sv_yes);
1818 RETURN;
1819 }
1820 buv = SvUVX(TOPs);
1821 SP--;
28e5dec8
JH		 1822 SETs(boolSV((UV)aiv <= buv));
1823 RETURN;
1824 }
1825 }
1826 }
1827#endif
30de85b6 1828#ifndef NV_PRESERVES_UV
50fb3111
NC		 1829#ifdef PERL_PRESERVE_IVUV
1830 else
1831#endif
0bdaccee 1832 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
30de85b6
NC		 1833 SP--;
1834 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1835 RETURN;
1836 }
1837#endif
a0d0e21e
LW		 1838 {
1839 dPOPnv;
54310121 1840 SETs(boolSV(TOPn <= value));
a0d0e21e 1841 RETURN;
79072805 1842 }
a0d0e21e
LW		 1843}
1844
1845PP(pp_ge)
1846{
39644a26 1847 dSP; tryAMAGICbinSET(ge,0);
28e5dec8
JH		 1848#ifdef PERL_PRESERVE_IVUV
1849 SvIV_please(TOPs);
1850 if (SvIOK(TOPs)) {
1851 SvIV_please(TOPm1s);
1852 if (SvIOK(TOPm1s)) {
1853 bool auvok = SvUOK(TOPm1s);
1854 bool buvok = SvUOK(TOPs);
a227d84d 1855
28e5dec8 1856 if (!auvok && !buvok) { /* ## IV >= IV ## */
1b6737cc
AL		 1857 const IV aiv = SvIVX(TOPm1s);
1858 const IV biv = SvIVX(TOPs);
1859
28e5dec8
JH		 1860 SP--;
1861 SETs(boolSV(aiv >= biv));
1862 RETURN;
1863 }
1864 if (auvok && buvok) { /* ## UV >= UV ## */
1b6737cc
AL		 1865 const UV auv = SvUVX(TOPm1s);
1866 const UV buv = SvUVX(TOPs);
1867
28e5dec8
JH		 1868 SP--;
1869 SETs(boolSV(auv >= buv));
1870 RETURN;
1871 }
1872 if (auvok) { /* ## UV >= IV ## */
1873 UV auv;
1b6737cc
AL		 1874 const IV biv = SvIVX(TOPs);
1875
28e5dec8
JH		 1876 SP--;
1877 if (biv < 0) {
1878 /* As (a) is a UV, it's >=0, so it must be >= */
1879 SETs(&PL_sv_yes);
1880 RETURN;
1881 }
1882 auv = SvUVX(TOPs);
28e5dec8
JH		 1883 SETs(boolSV(auv >= (UV)biv));
1884 RETURN;
1885 }
1886 { /* ## IV >= UV ## */
1b6737cc 1887 const IV aiv = SvIVX(TOPm1s);
28e5dec8 1888 UV buv;
1b6737cc 1889
28e5dec8
JH		 1890 if (aiv < 0) {
1891 /* As (b) is a UV, it's >=0, so a cannot be >= */
1892 SP--;
1893 SETs(&PL_sv_no);
1894 RETURN;
1895 }
1896 buv = SvUVX(TOPs);
1897 SP--;
28e5dec8
JH		 1898 SETs(boolSV((UV)aiv >= buv));
1899 RETURN;
1900 }
1901 }
1902 }
1903#endif
30de85b6 1904#ifndef NV_PRESERVES_UV
50fb3111
NC		 1905#ifdef PERL_PRESERVE_IVUV
1906 else
1907#endif
0bdaccee 1908 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
30de85b6
NC		 1909 SP--;
1910 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1911 RETURN;
1912 }
1913#endif
a0d0e21e
LW		 1914 {
1915 dPOPnv;
54310121 1916 SETs(boolSV(TOPn >= value));
a0d0e21e 1917 RETURN;
79072805 1918 }
a0d0e21e 1919}
79072805 1920
a0d0e21e
LW		 1921PP(pp_ne)
1922{
16303949 1923 dSP; tryAMAGICbinSET(ne,0);
3bb2c415 1924#ifndef NV_PRESERVES_UV
0bdaccee 1925 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
e61d22ef
NC		 1926 SP--;
1927 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
3bb2c415
JH		 1928 RETURN;
1929 }
1930#endif
28e5dec8
JH		 1931#ifdef PERL_PRESERVE_IVUV
1932 SvIV_please(TOPs);
1933 if (SvIOK(TOPs)) {
1934 SvIV_please(TOPm1s);
1935 if (SvIOK(TOPm1s)) {
1936 bool auvok = SvUOK(TOPm1s);
1937 bool buvok = SvUOK(TOPs);
a227d84d 1938
30de85b6
NC		 1939 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1940 /* Casting IV to UV before comparison isn't going to matter
1941 on 2s complement. On 1s complement or sign&magnitude
1942 (if we have any of them) it could make negative zero
1943 differ from normal zero. As I understand it. (Need to
1944 check - is negative zero implementation defined behaviour
1945 anyway?). NWC */
1b6737cc
AL		 1946 const UV buv = SvUVX(POPs);
1947 const UV auv = SvUVX(TOPs);
1948
28e5dec8
JH		 1949 SETs(boolSV(auv != buv));
1950 RETURN;
1951 }
1952 { /* ## Mixed IV,UV ## */
1953 IV iv;
1954 UV uv;
1955
1956 /* != is commutative so swap if needed (save code) */
1957 if (auvok) {
1958 /* swap. top of stack (b) is the iv */
1959 iv = SvIVX(TOPs);
1960 SP--;
1961 if (iv < 0) {
1962 /* As (a) is a UV, it's >0, so it cannot be == */
1963 SETs(&PL_sv_yes);
1964 RETURN;
1965 }
1966 uv = SvUVX(TOPs);
1967 } else {
1968 iv = SvIVX(TOPm1s);
1969 SP--;
1970 if (iv < 0) {
1971 /* As (b) is a UV, it's >0, so it cannot be == */
1972 SETs(&PL_sv_yes);
1973 RETURN;
1974 }
1975 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1976 }
28e5dec8
JH		 1977 SETs(boolSV((UV)iv != uv));
1978 RETURN;
1979 }
1980 }
1981 }
1982#endif
a0d0e21e
LW		 1983 {
1984 dPOPnv;
54310121 1985 SETs(boolSV(TOPn != value));
a0d0e21e
LW		 1986 RETURN;
1987 }
79072805
LW		 1988}
1989
a0d0e21e 1990PP(pp_ncmp)
79072805 1991{
39644a26 1992 dSP; dTARGET; tryAMAGICbin(ncmp,0);
d8c7644e 1993#ifndef NV_PRESERVES_UV
0bdaccee 1994 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
e61d22ef
NC		 1995 UV right = PTR2UV(SvRV(POPs));
1996 UV left = PTR2UV(SvRV(TOPs));
1997 SETi((left > right) - (left < right));
d8c7644e
JH		 1998 RETURN;
1999 }
2000#endif
28e5dec8
JH		 2001#ifdef PERL_PRESERVE_IVUV
2002 /* Fortunately it seems NaN isn't IOK */
2003 SvIV_please(TOPs);
2004 if (SvIOK(TOPs)) {
2005 SvIV_please(TOPm1s);
2006 if (SvIOK(TOPm1s)) {
1b6737cc
AL		 2007 const bool leftuvok = SvUOK(TOPm1s);
2008 const bool rightuvok = SvUOK(TOPs);
28e5dec8
JH		 2009 I32 value;
2010 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1b6737cc
AL		 2011 const IV leftiv = SvIVX(TOPm1s);
2012 const IV rightiv = SvIVX(TOPs);
28e5dec8
JH		 2013
2014 if (leftiv > rightiv)
2015 value = 1;
2016 else if (leftiv < rightiv)
2017 value = -1;
2018 else
2019 value = 0;
2020 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1b6737cc
AL		 2021 const UV leftuv = SvUVX(TOPm1s);
2022 const UV rightuv = SvUVX(TOPs);
28e5dec8
JH		 2023
2024 if (leftuv > rightuv)
2025 value = 1;
2026 else if (leftuv < rightuv)
2027 value = -1;
2028 else
2029 value = 0;
2030 } else if (leftuvok) { /* ## UV <=> IV ## */
1b6737cc 2031 const IV rightiv = SvIVX(TOPs);
28e5dec8
JH		 2032 if (rightiv < 0) {
2033 /* As (a) is a UV, it's >=0, so it cannot be < */
2034 value = 1;
2035 } else {
1b6737cc 2036 const UV leftuv = SvUVX(TOPm1s);
83bac5dd 2037 if (leftuv > (UV)rightiv) {
28e5dec8
JH		 2038 value = 1;
2039 } else if (leftuv < (UV)rightiv) {
2040 value = -1;
2041 } else {
2042 value = 0;
2043 }
2044 }
2045 } else { /* ## IV <=> UV ## */
1b6737cc 2046 const IV leftiv = SvIVX(TOPm1s);
28e5dec8
JH		 2047 if (leftiv < 0) {
2048 /* As (b) is a UV, it's >=0, so it must be < */
2049 value = -1;
2050 } else {
1b6737cc 2051 const UV rightuv = SvUVX(TOPs);
83bac5dd 2052 if ((UV)leftiv > rightuv) {
28e5dec8 2053 value = 1;
83bac5dd 2054 } else if ((UV)leftiv < rightuv) {
28e5dec8
JH		 2055 value = -1;
2056 } else {
2057 value = 0;
2058 }
2059 }
2060 }
2061 SP--;
2062 SETi(value);
2063 RETURN;
2064 }
2065 }
2066#endif
a0d0e21e
LW		 2067 {
2068 dPOPTOPnnrl;
2069 I32 value;
79072805 2070
a3540c92 2071#ifdef Perl_isnan
1ad04cfd
JH		 2072 if (Perl_isnan(left) || Perl_isnan(right)) {
2073 SETs(&PL_sv_undef);
2074 RETURN;
2075 }
2076 value = (left > right) - (left < right);
2077#else
ff0cee69 2078 if (left == right)
a0d0e21e 2079 value = 0;
a0d0e21e
LW		 2080 else if (left < right)
2081 value = -1;
44a8e56a 2082 else if (left > right)
2083 value = 1;
2084 else {
3280af22 2085 SETs(&PL_sv_undef);
44a8e56a 2086 RETURN;
2087 }
1ad04cfd 2088#endif
a0d0e21e
LW		 2089 SETi(value);
2090 RETURN;
79072805 2091 }
a0d0e21e 2092}
79072805 2093
afd9910b 2094PP(pp_sle)
a0d0e21e 2095{
afd9910b 2096 dSP;
79072805 2097
afd9910b
NC		 2098 int amg_type = sle_amg;
2099 int multiplier = 1;
2100 int rhs = 1;
79072805 2101
afd9910b
NC		 2102 switch (PL_op->op_type) {
2103 case OP_SLT:
2104 amg_type = slt_amg;
2105 /* cmp < 0 */
2106 rhs = 0;
2107 break;
2108 case OP_SGT:
2109 amg_type = sgt_amg;
2110 /* cmp > 0 */
2111 multiplier = -1;
2112 rhs = 0;
2113 break;
2114 case OP_SGE:
2115 amg_type = sge_amg;
2116 /* cmp >= 0 */
2117 multiplier = -1;
2118 break;
79072805 2119 }
79072805 2120
afd9910b 2121 tryAMAGICbinSET_var(amg_type,0);
a0d0e21e
LW		 2122 {
2123 dPOPTOPssrl;
1b6737cc 2124 const int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2125 ? sv_cmp_locale(left, right)
2126 : sv_cmp(left, right));
afd9910b 2127 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW		 2128 RETURN;
2129 }
2130}
79072805 2131
36477c24 2132PP(pp_seq)
2133{
39644a26 2134 dSP; tryAMAGICbinSET(seq,0);
36477c24 2135 {
2136 dPOPTOPssrl;
54310121 2137 SETs(boolSV(sv_eq(left, right)));
a0d0e21e
LW		 2138 RETURN;
2139 }
2140}
79072805 2141
a0d0e21e 2142PP(pp_sne)
79072805 2143{
39644a26 2144 dSP; tryAMAGICbinSET(sne,0);
a0d0e21e
LW		 2145 {
2146 dPOPTOPssrl;
54310121 2147 SETs(boolSV(!sv_eq(left, right)));
a0d0e21e 2148 RETURN;
463ee0b2 2149 }
79072805
LW		 2150}
2151
a0d0e21e 2152PP(pp_scmp)
79072805 2153{
39644a26 2154 dSP; dTARGET; tryAMAGICbin(scmp,0);
a0d0e21e
LW		 2155 {
2156 dPOPTOPssrl;
1b6737cc 2157 const int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2158 ? sv_cmp_locale(left, right)
2159 : sv_cmp(left, right));
2160 SETi( cmp );
a0d0e21e
LW		 2161 RETURN;
2162 }
2163}
79072805 2164
55497cff 2165PP(pp_bit_and)
2166{
39644a26 2167 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
a0d0e21e
LW		 2168 {
2169 dPOPTOPssrl;
5b295bef
RD		 2170 SvGETMAGIC(left);
2171 SvGETMAGIC(right);
4633a7c4 2172 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2173 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2174 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2175 SETi(i);
d0ba1bd2
JH		 2176 }
2177 else {
1b6737cc 2178 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2179 SETu(u);
d0ba1bd2 2180 }
a0d0e21e
LW		 2181 }
2182 else {
533c011a 2183 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2184 SETTARG;
2185 }
2186 RETURN;
2187 }
2188}
79072805 2189
a0d0e21e
LW		 2190PP(pp_bit_xor)
2191{
39644a26 2192 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
a0d0e21e
LW		 2193 {
2194 dPOPTOPssrl;
5b295bef
RD		 2195 SvGETMAGIC(left);
2196 SvGETMAGIC(right);
4633a7c4 2197 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2198 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2199 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
972b05a9 2200 SETi(i);
d0ba1bd2
JH		 2201 }
2202 else {
1b6737cc 2203 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
972b05a9 2204 SETu(u);
d0ba1bd2 2205 }
a0d0e21e
LW		 2206 }
2207 else {
533c011a 2208 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2209 SETTARG;
2210 }
2211 RETURN;
2212 }
2213}
79072805 2214
a0d0e21e
LW		 2215PP(pp_bit_or)
2216{
39644a26 2217 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
a0d0e21e
LW		 2218 {
2219 dPOPTOPssrl;
5b295bef
RD		 2220 SvGETMAGIC(left);
2221 SvGETMAGIC(right);
4633a7c4 2222 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2223 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2224 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
972b05a9 2225 SETi(i);
d0ba1bd2
JH		 2226 }
2227 else {
1b6737cc 2228 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
972b05a9 2229 SETu(u);
d0ba1bd2 2230 }
a0d0e21e
LW		 2231 }
2232 else {
533c011a 2233 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2234 SETTARG;
2235 }
2236 RETURN;
79072805 2237 }
a0d0e21e 2238}
79072805 2239
a0d0e21e
LW		 2240PP(pp_negate)
2241{
39644a26 2242 dSP; dTARGET; tryAMAGICun(neg);
a0d0e21e
LW		 2243 {
2244 dTOPss;
1b6737cc 2245 const int flags = SvFLAGS(sv);
5b295bef 2246 SvGETMAGIC(sv);
28e5dec8
JH		 2247 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2248 /* It's publicly an integer, or privately an integer-not-float */
2249 oops_its_an_int:
9b0e499b
GS		 2250 if (SvIsUV(sv)) {
2251 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2252 /* 2s complement assumption. */
9b0e499b
GS		 2253 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2254 RETURN;
2255 }
2256 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2257 SETi(-SvIVX(sv));
9b0e499b
GS		 2258 RETURN;
2259 }
2260 }
2261 else if (SvIVX(sv) != IV_MIN) {
2262 SETi(-SvIVX(sv));
2263 RETURN;
2264 }
28e5dec8
JH		 2265#ifdef PERL_PRESERVE_IVUV
2266 else {
2267 SETu((UV)IV_MIN);
2268 RETURN;
2269 }
2270#endif
9b0e499b
GS		 2271 }
2272 if (SvNIOKp(sv))
a0d0e21e 2273 SETn(-SvNV(sv));
4633a7c4 2274 else if (SvPOKp(sv)) {
a0d0e21e 2275 STRLEN len;
6f46942a 2276 const char *s = SvPV_const(sv, len);
bbce6d69 2277 if (isIDFIRST(*s)) {
a0d0e21e
LW		 2278 sv_setpvn(TARG, "-", 1);
2279 sv_catsv(TARG, sv);
79072805 2280 }
a0d0e21e
LW		 2281 else if (*s == '+' || *s == '-') {
2282 sv_setsv(TARG, sv);
2283 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805 2284 }
8eb28a70
JH		 2285 else if (DO_UTF8(sv)) {
2286 SvIV_please(sv);
2287 if (SvIOK(sv))
2288 goto oops_its_an_int;
2289 if (SvNOK(sv))
2290 sv_setnv(TARG, -SvNV(sv));
2291 else {
2292 sv_setpvn(TARG, "-", 1);
2293 sv_catsv(TARG, sv);
2294 }
834a4ddd 2295 }
28e5dec8 2296 else {
8eb28a70
JH		 2297 SvIV_please(sv);
2298 if (SvIOK(sv))
2299 goto oops_its_an_int;
2300 sv_setnv(TARG, -SvNV(sv));
28e5dec8 2301 }
a0d0e21e 2302 SETTARG;
79072805 2303 }
4633a7c4
LW		 2304 else
2305 SETn(-SvNV(sv));
79072805 2306 }
a0d0e21e 2307 RETURN;
79072805
LW		 2308}
2309
a0d0e21e 2310PP(pp_not)
79072805 2311{
39644a26 2312 dSP; tryAMAGICunSET(not);
3280af22 2313 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
a0d0e21e 2314 return NORMAL;
79072805
LW		 2315}
2316
a0d0e21e 2317PP(pp_complement)
79072805 2318{
39644a26 2319 dSP; dTARGET; tryAMAGICun(compl);
a0d0e21e
LW		 2320 {
2321 dTOPss;
5b295bef 2322 SvGETMAGIC(sv);
4633a7c4 2323 if (SvNIOKp(sv)) {
d0ba1bd2 2324 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2325 const IV i = ~SvIV_nomg(sv);
972b05a9 2326 SETi(i);
d0ba1bd2
JH		 2327 }
2328 else {
1b6737cc 2329 const UV u = ~SvUV_nomg(sv);
972b05a9 2330 SETu(u);
d0ba1bd2 2331 }
a0d0e21e
LW		 2332 }
2333 else {
51723571 2334 register U8 *tmps;
55497cff 2335 register I32 anum;
a0d0e21e
LW		 2336 STRLEN len;
2337
10516c54 2338 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
891f9566 2339 sv_setsv_nomg(TARG, sv);
51723571 2340 tmps = (U8*)SvPV_force(TARG, len);
a0d0e21e 2341 anum = len;
1d68d6cd 2342 if (SvUTF8(TARG)) {
a1ca4561 2343 /* Calculate exact length, let's not estimate. */
1d68d6cd
SC		 2344 STRLEN targlen = 0;
2345 U8 *result;
51723571 2346 U8 *send;
ba210ebe 2347 STRLEN l;
a1ca4561
YST		 2348 UV nchar = 0;
2349 UV nwide = 0;
1d68d6cd
SC		 2350
2351 send = tmps + len;
2352 while (tmps < send) {
1b6737cc 2353 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1d68d6cd 2354 tmps += UTF8SKIP(tmps);
5bbb0b5a 2355 targlen += UNISKIP(~c);
a1ca4561
YST		 2356 nchar++;
2357 if (c > 0xff)
2358 nwide++;
1d68d6cd
SC		 2359 }
2360
2361 /* Now rewind strings and write them. */
2362 tmps -= len;
a1ca4561
YST		 2363
2364 if (nwide) {
a02a5408 2365 Newxz(result, targlen + 1, U8);
a1ca4561 2366 while (tmps < send) {
1b6737cc 2367 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
a1ca4561 2368 tmps += UTF8SKIP(tmps);
b851fbc1 2369 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
a1ca4561
YST		 2370 }
2371 *result = '\0';
2372 result -= targlen;
2373 sv_setpvn(TARG, (char*)result, targlen);
2374 SvUTF8_on(TARG);
2375 }
2376 else {
a02a5408 2377 Newxz(result, nchar + 1, U8);
a1ca4561 2378 while (tmps < send) {
1b6737cc 2379 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
a1ca4561
YST		 2380 tmps += UTF8SKIP(tmps);
2381 *result++ = ~c;
2382 }
2383 *result = '\0';
2384 result -= nchar;
2385 sv_setpvn(TARG, (char*)result, nchar);
d0a21e00 2386 SvUTF8_off(TARG);
1d68d6cd 2387 }
1d68d6cd
SC		 2388 Safefree(result);
2389 SETs(TARG);
2390 RETURN;
2391 }
a0d0e21e 2392#ifdef LIBERAL
51723571
JH		 2393 {
2394 register long *tmpl;
2395 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2396 *tmps = ~*tmps;
2397 tmpl = (long*)tmps;
2398 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2399 *tmpl = ~*tmpl;
2400 tmps = (U8*)tmpl;
2401 }
a0d0e21e
LW		 2402#endif
2403 for ( ; anum > 0; anum--, tmps++)
2404 *tmps = ~*tmps;
2405
2406 SETs(TARG);
2407 }
2408 RETURN;
2409 }
79072805
LW		 2410}
2411
a0d0e21e
LW		 2412/* integer versions of some of the above */
2413
a0d0e21e 2414PP(pp_i_multiply)
79072805 2415{
39644a26 2416 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW		 2417 {
2418 dPOPTOPiirl;
2419 SETi( left * right );
2420 RETURN;
2421 }
79072805
LW		 2422}
2423
a0d0e21e 2424PP(pp_i_divide)
79072805 2425{
39644a26 2426 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e
LW		 2427 {
2428 dPOPiv;
2429 if (value == 0)
cea2e8a9 2430 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW		 2431 value = POPi / value;
2432 PUSHi( value );
2433 RETURN;
2434 }
79072805
LW		 2435}
2436
224ec323
JH		 2437STATIC
2438PP(pp_i_modulo_0)
2439{
2440 /* This is the vanilla old i_modulo. */
27da23d5 2441 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
224ec323
JH		 2442 {
2443 dPOPTOPiirl;
2444 if (!right)
2445 DIE(aTHX_ "Illegal modulus zero");
2446 SETi( left % right );
2447 RETURN;
2448 }
2449}
2450
11010fa3 2451#if defined(__GLIBC__) && IVSIZE == 8
224ec323
JH		 2452STATIC
2453PP(pp_i_modulo_1)
2454{
224ec323 2455 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2456 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2457 * See below for pp_i_modulo. */
27da23d5 2458 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
224ec323
JH		 2459 {
2460 dPOPTOPiirl;
2461 if (!right)
2462 DIE(aTHX_ "Illegal modulus zero");
32fdb065 2463 SETi( left % PERL_ABS(right) );
224ec323
JH		 2464 RETURN;
2465 }
224ec323 2466}
fce2b89e 2467#endif
224ec323 2468
a0d0e21e 2469PP(pp_i_modulo)
79072805 2470{
27da23d5 2471 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
224ec323
JH		 2472 {
2473 dPOPTOPiirl;
2474 if (!right)
2475 DIE(aTHX_ "Illegal modulus zero");
2476 /* The assumption is to use hereafter the old vanilla version... */
2477 PL_op->op_ppaddr =
2478 PL_ppaddr[OP_I_MODULO] =
1c127fab 2479 Perl_pp_i_modulo_0;
224ec323
JH		 2480 /* .. but if we have glibc, we might have a buggy _moddi3
2481 * (at least glicb 2.2.5 is known to have this bug), in other
2482 * words our integer modulus with negative quad as the second
2483 * argument might be broken. Test for this and re-patch the
2484 * opcode dispatch table if that is the case, remembering to
2485 * also apply the workaround so that this first round works
2486 * right, too. See [perl #9402] for more information. */
2487#if defined(__GLIBC__) && IVSIZE == 8
2488 {
2489 IV l = 3;
2490 IV r = -10;
2491 /* Cannot do this check with inlined IV constants since
2492 * that seems to work correctly even with the buggy glibc. */
2493 if (l % r == -3) {
2494 /* Yikes, we have the bug.
2495 * Patch in the workaround version. */
2496 PL_op->op_ppaddr =
2497 PL_ppaddr[OP_I_MODULO] =
2498 &Perl_pp_i_modulo_1;
2499 /* Make certain we work right this time, too. */
32fdb065 2500 right = PERL_ABS(right);
224ec323
JH		 2501 }
2502 }
2503#endif
2504 SETi( left % right );
2505 RETURN;
2506 }
79072805
LW		 2507}
2508
a0d0e21e 2509PP(pp_i_add)
79072805 2510{
39644a26 2511 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
a0d0e21e 2512 {
5e66d4f1 2513 dPOPTOPiirl_ul;
a0d0e21e
LW		 2514 SETi( left + right );
2515 RETURN;
79072805 2516 }
79072805
LW		 2517}
2518
a0d0e21e 2519PP(pp_i_subtract)
79072805 2520{
39644a26 2521 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 2522 {
5e66d4f1 2523 dPOPTOPiirl_ul;
a0d0e21e
LW		 2524 SETi( left - right );
2525 RETURN;
79072805 2526 }
79072805
LW		 2527}
2528
a0d0e21e 2529PP(pp_i_lt)
79072805 2530{
39644a26 2531 dSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW		 2532 {
2533 dPOPTOPiirl;
54310121 2534 SETs(boolSV(left < right));
a0d0e21e
LW		 2535 RETURN;
2536 }
79072805
LW		 2537}
2538
a0d0e21e 2539PP(pp_i_gt)
79072805 2540{
39644a26 2541 dSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW		 2542 {
2543 dPOPTOPiirl;
54310121 2544 SETs(boolSV(left > right));
a0d0e21e
LW		 2545 RETURN;
2546 }
79072805
LW		 2547}
2548
a0d0e21e 2549PP(pp_i_le)
79072805 2550{
39644a26 2551 dSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW		 2552 {
2553 dPOPTOPiirl;
54310121 2554 SETs(boolSV(left <= right));
a0d0e21e 2555 RETURN;
85e6fe83 2556 }
79072805
LW		 2557}
2558
a0d0e21e 2559PP(pp_i_ge)
79072805 2560{
39644a26 2561 dSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW		 2562 {
2563 dPOPTOPiirl;
54310121 2564 SETs(boolSV(left >= right));
a0d0e21e
LW		 2565 RETURN;
2566 }
79072805
LW		 2567}
2568
a0d0e21e 2569PP(pp_i_eq)
79072805 2570{
39644a26 2571 dSP; tryAMAGICbinSET(eq,0);
a0d0e21e
LW		 2572 {
2573 dPOPTOPiirl;
54310121 2574 SETs(boolSV(left == right));
a0d0e21e
LW		 2575 RETURN;
2576 }
79072805
LW		 2577}
2578
a0d0e21e 2579PP(pp_i_ne)
79072805 2580{
39644a26 2581 dSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW		 2582 {
2583 dPOPTOPiirl;
54310121 2584 SETs(boolSV(left != right));
a0d0e21e
LW		 2585 RETURN;
2586 }
79072805
LW		 2587}
2588
a0d0e21e 2589PP(pp_i_ncmp)
79072805 2590{
39644a26 2591 dSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW		 2592 {
2593 dPOPTOPiirl;
2594 I32 value;
79072805 2595
a0d0e21e 2596 if (left > right)
79072805 2597 value = 1;
a0d0e21e 2598 else if (left < right)
79072805 2599 value = -1;
a0d0e21e 2600 else
79072805 2601 value = 0;
a0d0e21e
LW		 2602 SETi(value);
2603 RETURN;
79072805 2604 }
85e6fe83
LW		 2605}
2606
2607PP(pp_i_negate)
2608{
39644a26 2609 dSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW		 2610 SETi(-TOPi);
2611 RETURN;
2612}
2613
79072805
LW		 2614/* High falutin' math. */
2615
2616PP(pp_atan2)
2617{
39644a26 2618 dSP; dTARGET; tryAMAGICbin(atan2,0);
a0d0e21e
LW		 2619 {
2620 dPOPTOPnnrl;
65202027 2621 SETn(Perl_atan2(left, right));
a0d0e21e
LW		 2622 RETURN;
2623 }
79072805
LW		 2624}
2625
2626PP(pp_sin)
2627{
39644a26 2628 dSP; dTARGET; tryAMAGICun(sin);
a0d0e21e 2629 {
1b6737cc
AL		 2630 const NV value = POPn;
2631 XPUSHn(Perl_sin(value));
a0d0e21e
LW		 2632 RETURN;
2633 }
79072805
LW		 2634}
2635
2636PP(pp_cos)
2637{
39644a26 2638 dSP; dTARGET; tryAMAGICun(cos);
a0d0e21e 2639 {
1b6737cc
AL		 2640 const NV value = POPn;
2641 XPUSHn(Perl_cos(value));
a0d0e21e
LW		 2642 RETURN;
2643 }
79072805
LW		 2644}
2645
56cb0a1c
AD		 2646/* Support Configure command-line overrides for rand() functions.
2647 After 5.005, perhaps we should replace this by Configure support
2648 for drand48(), random(), or rand(). For 5.005, though, maintain
2649 compatibility by calling rand() but allow the user to override it.
2650 See INSTALL for details. --Andy Dougherty 15 July 1998
2651*/
85ab1d1d
JH		 2652/* Now it's after 5.005, and Configure supports drand48() and random(),
2653 in addition to rand(). So the overrides should not be needed any more.
2654 --Jarkko Hietaniemi 27 September 1998
2655 */
2656
2657#ifndef HAS_DRAND48_PROTO
20ce7b12 2658extern double drand48 (void);
56cb0a1c
AD		 2659#endif
2660
79072805
LW		 2661PP(pp_rand)
2662{
39644a26 2663 dSP; dTARGET;
65202027 2664 NV value;
79072805
LW		 2665 if (MAXARG < 1)
2666 value = 1.0;
2667 else
2668 value = POPn;
2669 if (value == 0.0)
2670 value = 1.0;
80252599 2671 if (!PL_srand_called) {
85ab1d1d 2672 (void)seedDrand01((Rand_seed_t)seed());
80252599 2673 PL_srand_called = TRUE;
93dc8474 2674 }
85ab1d1d 2675 value *= Drand01();
79072805
LW		 2676 XPUSHn(value);
2677 RETURN;
2678}
2679
2680PP(pp_srand)
2681{
39644a26 2682 dSP;
93dc8474
CS		 2683 UV anum;
2684 if (MAXARG < 1)
2685 anum = seed();
79072805 2686 else
93dc8474 2687 anum = POPu;
85ab1d1d 2688 (void)seedDrand01((Rand_seed_t)anum);
80252599 2689 PL_srand_called = TRUE;
79072805
LW		 2690 EXTEND(SP, 1);
2691 RETPUSHYES;
2692}
2693
2694PP(pp_exp)
2695{
39644a26 2696 dSP; dTARGET; tryAMAGICun(exp);
a0d0e21e 2697 {
65202027 2698 NV value;
a0d0e21e 2699 value = POPn;
65202027 2700 value = Perl_exp(value);
a0d0e21e
LW		 2701 XPUSHn(value);
2702 RETURN;
2703 }
79072805
LW		 2704}
2705
2706PP(pp_log)
2707{
39644a26 2708 dSP; dTARGET; tryAMAGICun(log);
a0d0e21e 2709 {
1b6737cc 2710 const NV value = POPn;
bbce6d69 2711 if (value <= 0.0) {
f93f4e46 2712 SET_NUMERIC_STANDARD();
1779d84d 2713 DIE(aTHX_ "Can't take log of %"NVgf, value);
bbce6d69 2714 }
1b6737cc 2715 XPUSHn(Perl_log(value));
a0d0e21e
LW		 2716 RETURN;
2717 }
79072805
LW		 2718}
2719
2720PP(pp_sqrt)
2721{
39644a26 2722 dSP; dTARGET; tryAMAGICun(sqrt);
a0d0e21e 2723 {
1b6737cc 2724 const NV value = POPn;
bbce6d69 2725 if (value < 0.0) {
f93f4e46 2726 SET_NUMERIC_STANDARD();
1779d84d 2727 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
bbce6d69 2728 }
1b6737cc 2729 XPUSHn(Perl_sqrt(value));
a0d0e21e
LW		 2730 RETURN;
2731 }
79072805
LW		 2732}
2733
2734PP(pp_int)
2735{
39644a26 2736 dSP; dTARGET; tryAMAGICun(int);
774d564b 2737 {
1b6737cc 2738 const IV iv = TOPi; /* attempt to convert to IV if possible. */
28e5dec8
JH		 2739 /* XXX it's arguable that compiler casting to IV might be subtly
2740 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2741 else preferring IV has introduced a subtle behaviour change bug. OTOH
2742 relying on floating point to be accurate is a bug. */
2743
922c4365
MHM		 2744 if (!SvOK(TOPs))
2745 SETu(0);
2746 else if (SvIOK(TOPs)) {
28e5dec8 2747 if (SvIsUV(TOPs)) {
1b6737cc 2748 const UV uv = TOPu;
28e5dec8
JH		 2749 SETu(uv);
2750 } else
2751 SETi(iv);
2752 } else {
1b6737cc 2753 const NV value = TOPn;
1048ea30 2754 if (value >= 0.0) {
28e5dec8
JH		 2755 if (value < (NV)UV_MAX + 0.5) {
2756 SETu(U_V(value));
2757 } else {
059a1014 2758 SETn(Perl_floor(value));
28e5dec8 2759 }
1048ea30 2760 }
28e5dec8
JH		 2761 else {
2762 if (value > (NV)IV_MIN - 0.5) {
2763 SETi(I_V(value));
2764 } else {
1bbae031 2765 SETn(Perl_ceil(value));
28e5dec8
JH		 2766 }
2767 }
774d564b 2768 }
79072805 2769 }
79072805
LW		 2770 RETURN;
2771}
2772
463ee0b2
LW		 2773PP(pp_abs)
2774{
39644a26 2775 dSP; dTARGET; tryAMAGICun(abs);
a0d0e21e 2776 {
28e5dec8 2777 /* This will cache the NV value if string isn't actually integer */
1b6737cc 2778 const IV iv = TOPi;
a227d84d 2779
922c4365
MHM		 2780 if (!SvOK(TOPs))
2781 SETu(0);
2782 else if (SvIOK(TOPs)) {
28e5dec8
JH		 2783 /* IVX is precise */
2784 if (SvIsUV(TOPs)) {
2785 SETu(TOPu); /* force it to be numeric only */
2786 } else {
2787 if (iv >= 0) {
2788 SETi(iv);
2789 } else {
2790 if (iv != IV_MIN) {
2791 SETi(-iv);
2792 } else {
2793 /* 2s complement assumption. Also, not really needed as
2794 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2795 SETu(IV_MIN);
2796 }
a227d84d 2797 }
28e5dec8
JH		 2798 }
2799 } else{
1b6737cc 2800 const NV value = TOPn;
774d564b 2801 if (value < 0.0)
1b6737cc 2802 SETn(-value);
a4474c9e
DD		 2803 else
2804 SETn(value);
774d564b 2805 }
a0d0e21e 2806 }
774d564b 2807 RETURN;
463ee0b2
LW		 2808}
2809
53305cf1 2810
79072805
LW		 2811PP(pp_hex)
2812{
39644a26 2813 dSP; dTARGET;
5c144d81 2814 const char *tmps;
53305cf1 2815 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2816 STRLEN len;
53305cf1
NC		 2817 NV result_nv;
2818 UV result_uv;
1b6737cc 2819 SV* const sv = POPs;
79072805 2820
349d4f2f 2821 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS		 2822 if (DO_UTF8(sv)) {
2823 /* If Unicode, try to downgrade
2824 * If not possible, croak. */
1b6737cc 2825 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS		 2826
2827 SvUTF8_on(tsv);
2828 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2829 tmps = SvPV_const(tsv, len);
2bc69dc4 2830 }
53305cf1
NC		 2831 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2832 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2833 XPUSHn(result_nv);
2834 }
2835 else {
2836 XPUSHu(result_uv);
2837 }
79072805
LW		 2838 RETURN;
2839}
2840
2841PP(pp_oct)
2842{
39644a26 2843 dSP; dTARGET;
5c144d81 2844 const char *tmps;
53305cf1 2845 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2846 STRLEN len;
53305cf1
NC		 2847 NV result_nv;
2848 UV result_uv;
1b6737cc 2849 SV* const sv = POPs;
79072805 2850
349d4f2f 2851 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS		 2852 if (DO_UTF8(sv)) {
2853 /* If Unicode, try to downgrade
2854 * If not possible, croak. */
1b6737cc 2855 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS		 2856
2857 SvUTF8_on(tsv);
2858 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2859 tmps = SvPV_const(tsv, len);
2bc69dc4 2860 }
6f894ead 2861 while (*tmps && len && isSPACE(*tmps))
53305cf1 2862 tmps++, len--;
9e24b6e2 2863 if (*tmps == '0')
53305cf1 2864 tmps++, len--;
9e24b6e2 2865 if (*tmps == 'x')
53305cf1 2866 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
9e24b6e2 2867 else if (*tmps == 'b')
53305cf1 2868 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2869 else
53305cf1
NC		 2870 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2871
2872 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2873 XPUSHn(result_nv);
2874 }
2875 else {
2876 XPUSHu(result_uv);
2877 }
79072805
LW		 2878 RETURN;
2879}
2880
2881/* String stuff. */
2882
2883PP(pp_length)
2884{
39644a26 2885 dSP; dTARGET;
7e2040f0 2886 SV *sv = TOPs;
a0ed51b3 2887
7e2040f0
GS		 2888 if (DO_UTF8(sv))
2889 SETi(sv_len_utf8(sv));
2890 else
2891 SETi(sv_len(sv));
79072805
LW		 2892 RETURN;
2893}
2894
2895PP(pp_substr)
2896{
39644a26 2897 dSP; dTARGET;
79072805 2898 SV *sv;
9c5ffd7c 2899 I32 len = 0;
463ee0b2 2900 STRLEN curlen;
9402d6ed 2901 STRLEN utf8_curlen;
79072805
LW		 2902 I32 pos;
2903 I32 rem;
84902520 2904 I32 fail;
e1ec3a88
AL		 2905 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2906 const char *tmps;
2907 const I32 arybase = PL_curcop->cop_arybase;
9402d6ed 2908 SV *repl_sv = NULL;
e1ec3a88 2909 const char *repl = 0;
7b8d334a 2910 STRLEN repl_len;
1b6737cc 2911 const int num_args = PL_op->op_private & 7;
13e30c65 2912 bool repl_need_utf8_upgrade = FALSE;
9402d6ed 2913 bool repl_is_utf8 = FALSE;
79072805 2914
20408e3c 2915 SvTAINTED_off(TARG); /* decontaminate */
7e2040f0 2916 SvUTF8_off(TARG); /* decontaminate */
78f9721b
SM		 2917 if (num_args > 2) {
2918 if (num_args > 3) {
9402d6ed 2919 repl_sv = POPs;
83003860 2920 repl = SvPV_const(repl_sv, repl_len);
9402d6ed 2921 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
7b8d334a 2922 }
79072805 2923 len = POPi;
5d82c453 2924 }
84902520 2925 pos = POPi;
79072805 2926 sv = POPs;
849ca7ee 2927 PUTBACK;
9402d6ed
JH		 2928 if (repl_sv) {
2929 if (repl_is_utf8) {
2930 if (!DO_UTF8(sv))
2931 sv_utf8_upgrade(sv);
2932 }
13e30c65
JH		 2933 else if (DO_UTF8(sv))
2934 repl_need_utf8_upgrade = TRUE;
9402d6ed 2935 }
5c144d81 2936 tmps = SvPV_const(sv, curlen);
7e2040f0 2937 if (DO_UTF8(sv)) {
9402d6ed
JH		 2938 utf8_curlen = sv_len_utf8(sv);
2939 if (utf8_curlen == curlen)
2940 utf8_curlen = 0;
a0ed51b3 2941 else
9402d6ed 2942 curlen = utf8_curlen;
a0ed51b3 2943 }
d1c2b58a 2944 else
9402d6ed 2945 utf8_curlen = 0;
a0ed51b3 2946
84902520
TB		 2947 if (pos >= arybase) {
2948 pos -= arybase;
2949 rem = curlen-pos;
2950 fail = rem;
78f9721b 2951 if (num_args > 2) {
5d82c453
GA		 2952 if (len < 0) {
2953 rem += len;
2954 if (rem < 0)
2955 rem = 0;
2956 }
2957 else if (rem > len)
2958 rem = len;
2959 }
68dc0745 2960 }
84902520 2961 else {
5d82c453 2962 pos += curlen;
78f9721b 2963 if (num_args < 3)
5d82c453
GA		 2964 rem = curlen;
2965 else if (len >= 0) {
2966 rem = pos+len;
2967 if (rem > (I32)curlen)
2968 rem = curlen;
2969 }
2970 else {
2971 rem = curlen+len;
2972 if (rem < pos)
2973 rem = pos;
2974 }
2975 if (pos < 0)
2976 pos = 0;
2977 fail = rem;
2978 rem -= pos;
84902520
TB		 2979 }
2980 if (fail < 0) {
e476b1b5
GS		 2981 if (lvalue || repl)
2982 Perl_croak(aTHX_ "substr outside of string");
2983 if (ckWARN(WARN_SUBSTR))
9014280d 2984 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2304df62
AD		 2985 RETPUSHUNDEF;
2986 }
79072805 2987 else {
1b6737cc
AL		 2988 const I32 upos = pos;
2989 const I32 urem = rem;
9402d6ed 2990 if (utf8_curlen)
a0ed51b3 2991 sv_pos_u2b(sv, &pos, &rem);
79072805 2992 tmps += pos;
781e7547
DM		 2993 /* we either return a PV or an LV. If the TARG hasn't been used
2994 * before, or is of that type, reuse it; otherwise use a mortal
2995 * instead. Note that LVs can have an extended lifetime, so also
2996 * dont reuse if refcount > 1 (bug #20933) */
2997 if (SvTYPE(TARG) > SVt_NULL) {
2998 if ( (SvTYPE(TARG) == SVt_PVLV)
2999 ? (!lvalue || SvREFCNT(TARG) > 1)
3000 : lvalue)
3001 {
3002 TARG = sv_newmortal();
3003 }
3004 }
3005
79072805 3006 sv_setpvn(TARG, tmps, rem);
12aa1545 3007#ifdef USE_LOCALE_COLLATE
14befaf4 3008 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3009#endif
9402d6ed 3010 if (utf8_curlen)
7f66633b 3011 SvUTF8_on(TARG);
f7928d6c 3012 if (repl) {
13e30c65
JH		 3013 SV* repl_sv_copy = NULL;
3014
3015 if (repl_need_utf8_upgrade) {
3016 repl_sv_copy = newSVsv(repl_sv);
3017 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3018 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65
JH		 3019 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3020 }
c8faf1c5 3021 sv_insert(sv, pos, rem, repl, repl_len);
9402d6ed 3022 if (repl_is_utf8)
f7928d6c 3023 SvUTF8_on(sv);
9402d6ed
JH		 3024 if (repl_sv_copy)
3025 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3026 }
c8faf1c5 3027 else if (lvalue) { /* it's an lvalue! */
dedeecda 3028 if (!SvGMAGICAL(sv)) {
3029 if (SvROK(sv)) {
13c5b33c 3030 SvPV_force_nolen(sv);
599cee73 3031 if (ckWARN(WARN_SUBSTR))
9014280d 3032 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
599cee73 3033 "Attempt to use reference as lvalue in substr");
dedeecda 3034 }
3035 if (SvOK(sv)) /* is it defined ? */
7f66633b 3036 (void)SvPOK_only_UTF8(sv);
dedeecda 3037 else
3038 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3039 }
5f05dabc 3040
a0d0e21e
LW		 3041 if (SvTYPE(TARG) < SVt_PVLV) {
3042 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3043 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
ed6116ce 3044 }
6214ab63 3045 else
0c34ef67 3046 SvOK_off(TARG);
a0d0e21e 3047
5f05dabc 3048 LvTYPE(TARG) = 'x';
6ff81951
GS		 3049 if (LvTARG(TARG) != sv) {
3050 if (LvTARG(TARG))
3051 SvREFCNT_dec(LvTARG(TARG));
3052 LvTARG(TARG) = SvREFCNT_inc(sv);
3053 }
9aa983d2
JH		 3054 LvTARGOFF(TARG) = upos;
3055 LvTARGLEN(TARG) = urem;
79072805
LW		 3056 }
3057 }
849ca7ee 3058 SPAGAIN;
79072805
LW		 3059 PUSHs(TARG); /* avoid SvSETMAGIC here */
3060 RETURN;
3061}
3062
3063PP(pp_vec)
3064{
39644a26 3065 dSP; dTARGET;
1b6737cc
AL		 3066 register const IV size = POPi;
3067 register const IV offset = POPi;
3068 register SV * const src = POPs;
3069 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e 3070
81e118e0
JH		 3071 SvTAINTED_off(TARG); /* decontaminate */
3072 if (lvalue) { /* it's an lvalue! */
24aef97f
HS		 3073 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3074 TARG = sv_newmortal();
81e118e0
JH		 3075 if (SvTYPE(TARG) < SVt_PVLV) {
3076 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3077 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
79072805 3078 }
81e118e0
JH		 3079 LvTYPE(TARG) = 'v';
3080 if (LvTARG(TARG) != src) {
3081 if (LvTARG(TARG))
3082 SvREFCNT_dec(LvTARG(TARG));
3083 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 3084 }
81e118e0
JH		 3085 LvTARGOFF(TARG) = offset;
3086 LvTARGLEN(TARG) = size;
79072805
LW		 3087 }
3088
81e118e0 3089 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW		 3090 PUSHs(TARG);
3091 RETURN;
3092}
3093
3094PP(pp_index)
3095{
39644a26 3096 dSP; dTARGET;
79072805
LW		 3097 SV *big;
3098 SV *little;
e609e586 3099 SV *temp = Nullsv;
79072805
LW		 3100 I32 offset;
3101 I32 retval;
10516c54
NC		 3102 const char *tmps;
3103 const char *tmps2;
463ee0b2 3104 STRLEN biglen;
1b6737cc 3105 const I32 arybase = PL_curcop->cop_arybase;
e609e586
NC		 3106 int big_utf8;
3107 int little_utf8;
79072805
LW		 3108
3109 if (MAXARG < 3)
3110 offset = 0;
3111 else
3112 offset = POPi - arybase;
3113 little = POPs;
3114 big = POPs;
e609e586
NC		 3115 big_utf8 = DO_UTF8(big);
3116 little_utf8 = DO_UTF8(little);
3117 if (big_utf8 ^ little_utf8) {
3118 /* One needs to be upgraded. */
1b6737cc 3119 SV * const bytes = little_utf8 ? big : little;
e609e586 3120 STRLEN len;
1b6737cc 3121 const char * const p = SvPV_const(bytes, len);
e609e586
NC		 3122
3123 temp = newSVpvn(p, len);
3124
3125 if (PL_encoding) {
3126 sv_recode_to_utf8(temp, PL_encoding);
3127 } else {
3128 sv_utf8_upgrade(temp);
3129 }
3130 if (little_utf8) {
3131 big = temp;
3132 big_utf8 = TRUE;
3133 } else {
3134 little = temp;
3135 }
3136 }
3137 if (big_utf8 && offset > 0)
a0ed51b3 3138 sv_pos_u2b(big, &offset, 0);
10516c54 3139 tmps = SvPV_const(big, biglen);
79072805
LW		 3140 if (offset < 0)
3141 offset = 0;
eb160463 3142 else if (offset > (I32)biglen)
93a17b20 3143 offset = biglen;
79072805 3144 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 3145 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 3146 retval = -1;
79072805 3147 else
a0ed51b3 3148 retval = tmps2 - tmps;
e609e586 3149 if (retval > 0 && big_utf8)
a0ed51b3 3150 sv_pos_b2u(big, &retval);
e609e586
NC		 3151 if (temp)
3152 SvREFCNT_dec(temp);
a0ed51b3 3153 PUSHi(retval + arybase);
79072805
LW		 3154 RETURN;
3155}
3156
3157PP(pp_rindex)
3158{
39644a26 3159 dSP; dTARGET;
79072805
LW		 3160 SV *big;
3161 SV *little;
e609e586 3162 SV *temp = Nullsv;
463ee0b2
LW		 3163 STRLEN blen;
3164 STRLEN llen;
79072805
LW		 3165 I32 offset;
3166 I32 retval;
10516c54
NC		 3167 const char *tmps;
3168 const char *tmps2;
1b6737cc 3169 const I32 arybase = PL_curcop->cop_arybase;
e609e586
NC		 3170 int big_utf8;
3171 int little_utf8;
79072805 3172
a0d0e21e 3173 if (MAXARG >= 3)
a0ed51b3 3174 offset = POPi;
79072805
LW		 3175 little = POPs;
3176 big = POPs;
e609e586
NC		 3177 big_utf8 = DO_UTF8(big);
3178 little_utf8 = DO_UTF8(little);
3179 if (big_utf8 ^ little_utf8) {
3180 /* One needs to be upgraded. */
1b6737cc 3181 SV * const bytes = little_utf8 ? big : little;
e609e586 3182 STRLEN len;
83003860 3183 const char *p = SvPV_const(bytes, len);
e609e586
NC		 3184
3185 temp = newSVpvn(p, len);
3186
3187 if (PL_encoding) {
3188 sv_recode_to_utf8(temp, PL_encoding);
3189 } else {
3190 sv_utf8_upgrade(temp);
3191 }
3192 if (little_utf8) {
3193 big = temp;
3194 big_utf8 = TRUE;
3195 } else {
3196 little = temp;
3197 }
3198 }
10516c54
NC		 3199 tmps2 = SvPV_const(little, llen);
3200 tmps = SvPV_const(big, blen);
e609e586 3201
79072805 3202 if (MAXARG < 3)
463ee0b2 3203 offset = blen;
a0ed51b3 3204 else {
e609e586 3205 if (offset > 0 && big_utf8)
a0ed51b3
LW		 3206 sv_pos_u2b(big, &offset, 0);
3207 offset = offset - arybase + llen;
3208 }
79072805
LW		 3209 if (offset < 0)
3210 offset = 0;
eb160463 3211 else if (offset > (I32)blen)
463ee0b2 3212 offset = blen;
79072805 3213 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 3214 tmps2, tmps2 + llen)))
a0ed51b3 3215 retval = -1;
79072805 3216 else
a0ed51b3 3217 retval = tmps2 - tmps;
e609e586 3218 if (retval > 0 && big_utf8)
a0ed51b3 3219 sv_pos_b2u(big, &retval);
e609e586
NC		 3220 if (temp)
3221 SvREFCNT_dec(temp);
a0ed51b3 3222 PUSHi(retval + arybase);
79072805
LW		 3223 RETURN;
3224}
3225
3226PP(pp_sprintf)
3227{
39644a26 3228 dSP; dMARK; dORIGMARK; dTARGET;
79072805 3229 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3230 TAINT_IF(SvTAINTED(TARG));
6ee35fb7
JH		 3231 if (DO_UTF8(*(MARK+1)))
3232 SvUTF8_on(TARG);
79072805
LW		 3233 SP = ORIGMARK;
3234 PUSHTARG;
3235 RETURN;
3236}
3237
79072805
LW		 3238PP(pp_ord)
3239{
39644a26 3240 dSP; dTARGET;
7df053ec 3241 SV *argsv = POPs;
ba210ebe 3242 STRLEN len;
349d4f2f 3243 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4
JH		 3244 SV *tmpsv;
3245
799ef3cb 3246 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
121910a4 3247 tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3248 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
121910a4
JH		 3249 argsv = tmpsv;
3250 }
79072805 3251
872c91ae 3252 XPUSHu(DO_UTF8(argsv) ?
89ebb4a3 3253 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
872c91ae 3254 (*s & 0xff));
68795e93 3255
79072805
LW		 3256 RETURN;
3257}
3258
463ee0b2
LW		 3259PP(pp_chr)
3260{
39644a26 3261 dSP; dTARGET;
463ee0b2 3262 char *tmps;
8a064bd6
JH		 3263 UV value;
3264
3265 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3266 ||
3267 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3268 if (IN_BYTES) {
3269 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3270 } else {
3271 (void) POPs; /* Ignore the argument value. */
3272 value = UNICODE_REPLACEMENT;
3273 }
3274 } else {
3275 value = POPu;
3276 }
463ee0b2 3277
862a34c6 3278 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3279
0064a8a9 3280 if (value > 255 && !IN_BYTES) {
eb160463 3281 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3282 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3283 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW		 3284 *tmps = '\0';
3285 (void)SvPOK_only(TARG);
aa6ffa16 3286 SvUTF8_on(TARG);
a0ed51b3
LW		 3287 XPUSHs(TARG);
3288 RETURN;
3289 }
3290
748a9306 3291 SvGROW(TARG,2);
463ee0b2
LW		 3292 SvCUR_set(TARG, 1);
3293 tmps = SvPVX(TARG);
eb160463 3294 *tmps++ = (char)value;
748a9306 3295 *tmps = '\0';
a0d0e21e 3296 (void)SvPOK_only(TARG);
88632417 3297 if (PL_encoding && !IN_BYTES) {
799ef3cb 3298 sv_recode_to_utf8(TARG, PL_encoding);
88632417
JH		 3299 tmps = SvPVX(TARG);
3300 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3301 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
d5a15ac2
JH		 3302 SvGROW(TARG, 3);
3303 tmps = SvPVX(TARG);
88632417
JH		 3304 SvCUR_set(TARG, 2);
3305 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3306 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3307 *tmps = '\0';
3308 SvUTF8_on(TARG);
3309 }
3310 }
463ee0b2
LW		 3311 XPUSHs(TARG);
3312 RETURN;
3313}
3314
79072805
LW		 3315PP(pp_crypt)
3316{
79072805 3317#ifdef HAS_CRYPT
27da23d5 3318 dSP; dTARGET;
5f74f29c 3319 dPOPTOPssrl;
85c16d83 3320 STRLEN len;
10516c54 3321 const char *tmps = SvPV_const(left, len);
2bc69dc4 3322
85c16d83 3323 if (DO_UTF8(left)) {
2bc69dc4 3324 /* If Unicode, try to downgrade.
f2791508
JH		 3325 * If not possible, croak.
3326 * Yes, we made this up. */
1b6737cc 3327 SV* const tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3328
f2791508 3329 SvUTF8_on(tsv);
2bc69dc4 3330 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3331 tmps = SvPV_const(tsv, len);
85c16d83 3332 }
05404ffe
JH		 3333# ifdef USE_ITHREADS
3334# ifdef HAS_CRYPT_R
3335 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3336 /* This should be threadsafe because in ithreads there is only
3337 * one thread per interpreter. If this would not be true,
3338 * we would need a mutex to protect this malloc. */
3339 PL_reentrant_buffer->_crypt_struct_buffer =
3340 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3341#if defined(__GLIBC__) || defined(__EMX__)
3342 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3343 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3344 /* work around glibc-2.2.5 bug */
3345 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3346 }
05404ffe 3347#endif
6ab58e4d 3348 }
05404ffe
JH		 3349# endif /* HAS_CRYPT_R */
3350# endif /* USE_ITHREADS */
5f74f29c 3351# ifdef FCRYPT
83003860 3352 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3353# else
83003860 3354 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3355# endif
4808266b
JH		 3356 SETs(TARG);
3357 RETURN;
79072805 3358#else
b13b2135 3359 DIE(aTHX_
79072805
LW		 3360 "The crypt() function is unimplemented due to excessive paranoia.");
3361#endif
79072805
LW		 3362}
3363
3364PP(pp_ucfirst)
3365{
39644a26 3366 dSP;
79072805 3367 SV *sv = TOPs;
83003860 3368 const U8 *s;
a0ed51b3 3369 STRLEN slen;
12e9c124 3370 const int op_type = PL_op->op_type;
a0ed51b3 3371
d104a74c 3372 SvGETMAGIC(sv);
3a2263fe 3373 if (DO_UTF8(sv) &&
83003860 3374 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3a2263fe 3375 UTF8_IS_START(*s)) {
89ebb4a3 3376 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
44bc797b
JH		 3377 STRLEN ulen;
3378 STRLEN tculen;
a0ed51b3 3379
44bc797b 3380 utf8_to_uvchr(s, &ulen);
12e9c124
NC		 3381 if (op_type == OP_UCFIRST) {
3382 toTITLE_utf8(s, tmpbuf, &tculen);
3383 } else {
3384 toLOWER_utf8(s, tmpbuf, &tculen);
3385 }
44bc797b 3386
6f9b16a7 3387 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
a0ed51b3 3388 dTARGET;
3a2263fe
RGS		 3389 /* slen is the byte length of the whole SV.
3390 * ulen is the byte length of the original Unicode character
3391 * stored as UTF-8 at s.
12e9c124
NC		 3392 * tculen is the byte length of the freshly titlecased (or
3393 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3394 * We first set the result to be the titlecased (/lowercased)
3395 * character, and then append the rest of the SV data. */
44bc797b 3396 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3a2263fe
RGS		 3397 if (slen > ulen)
3398 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3399 SvUTF8_on(TARG);
a0ed51b3
LW		 3400 SETs(TARG);
3401 }
3402 else {
d104a74c 3403 s = (U8*)SvPV_force_nomg(sv, slen);
44bc797b 3404 Copy(tmpbuf, s, tculen, U8);
a0ed51b3 3405 }
a0ed51b3 3406 }
626727d5 3407 else {
83003860 3408 U8 *s1;
014822e4 3409 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3410 dTARGET;
7e2040f0 3411 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3412 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3413 sv = TARG;
3414 SETs(sv);
3415 }
83003860
NC		 3416 s1 = (U8*)SvPV_force_nomg(sv, slen);
3417 if (*s1) {
2de3dbcc 3418 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3419 TAINT;
3420 SvTAINTED_on(sv);
12e9c124
NC		 3421 *s1 = (op_type == OP_UCFIRST)
3422 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
31351b04
JS		 3423 }
3424 else
12e9c124 3425 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
bbce6d69 3426 }
bbce6d69 3427 }
d104a74c 3428 SvSETMAGIC(sv);
79072805
LW		 3429 RETURN;
3430}
3431
3432PP(pp_uc)
3433{
39644a26 3434 dSP;
79072805 3435 SV *sv = TOPs;
463ee0b2 3436 STRLEN len;
79072805 3437
d104a74c 3438 SvGETMAGIC(sv);
7e2040f0 3439 if (DO_UTF8(sv)) {
a0ed51b3 3440 dTARGET;
ba210ebe 3441 STRLEN ulen;
a0ed51b3 3442 register U8 *d;
10516c54
NC		 3443 const U8 *s;
3444 const U8 *send;
89ebb4a3 3445 U8 tmpbuf[UTF8_MAXBYTES+1];
a0ed51b3 3446
10516c54 3447 s = (const U8*)SvPV_nomg_const(sv,len);
a5a20234 3448 if (!len) {
7e2040f0 3449 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3450 sv_setpvn(TARG, "", 0);
3451 SETs(TARG);
a0ed51b3
LW		 3452 }
3453 else {
128c9517
JH		 3454 STRLEN min = len + 1;
3455
862a34c6 3456 SvUPGRADE(TARG, SVt_PV);
128c9517 3457 SvGROW(TARG, min);
31351b04
JS		 3458 (void)SvPOK_only(TARG);
3459 d = (U8*)SvPVX(TARG);
3460 send = s + len;
a2a2844f 3461 while (s < send) {
89ebb4a3
JH		 3462 STRLEN u = UTF8SKIP(s);
3463
6fdb5f96 3464 toUPPER_utf8(s, tmpbuf, &ulen);
128c9517
JH		 3465 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3466 /* If the eventually required minimum size outgrows
3467 * the available space, we need to grow. */
349d4f2f 3468 UV o = d - (U8*)SvPVX_const(TARG);
89ebb4a3
JH		 3469
3470 /* If someone uppercases one million U+03B0s we
3471 * SvGROW() one million times. Or we could try
32c480af
JH		 3472 * guessing how much to allocate without allocating
3473 * too much. Such is life. */
128c9517 3474 SvGROW(TARG, min);
89ebb4a3
JH		 3475 d = (U8*)SvPVX(TARG) + o;
3476 }
a2a2844f
JH		 3477 Copy(tmpbuf, d, ulen, U8);
3478 d += ulen;
89ebb4a3 3479 s += u;
a0ed51b3 3480 }
31351b04 3481 *d = '\0';
7e2040f0 3482 SvUTF8_on(TARG);
349d4f2f 3483 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
31351b04 3484 SETs(TARG);
a0ed51b3 3485 }
a0ed51b3 3486 }
626727d5 3487 else {
10516c54 3488 U8 *s;
014822e4 3489 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3490 dTARGET;
7e2040f0 3491 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3492 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3493 sv = TARG;
3494 SETs(sv);
3495 }
d104a74c 3496 s = (U8*)SvPV_force_nomg(sv, len);
31351b04 3497 if (len) {
0d46e09a 3498 register const U8 *send = s + len;
31351b04 3499
2de3dbcc 3500 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3501 TAINT;
3502 SvTAINTED_on(sv);
3503 for (; s < send; s++)
3504 *s = toUPPER_LC(*s);
3505 }
3506 else {
3507 for (; s < send; s++)
3508 *s = toUPPER(*s);
3509 }
bbce6d69 3510 }
79072805 3511 }
d104a74c 3512 SvSETMAGIC(sv);
79072805
LW		 3513 RETURN;
3514}
3515
3516PP(pp_lc)
3517{
39644a26 3518 dSP;
79072805 3519 SV *sv = TOPs;
463ee0b2 3520 STRLEN len;
79072805 3521
d104a74c 3522 SvGETMAGIC(sv);
7e2040f0 3523 if (DO_UTF8(sv)) {
a0ed51b3 3524 dTARGET;
10516c54 3525 const U8 *s;
ba210ebe 3526 STRLEN ulen;
a0ed51b3 3527 register U8 *d;
10516c54 3528 const U8 *send;
89ebb4a3 3529 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
a0ed51b3 3530
10516c54 3531 s = (const U8*)SvPV_nomg_const(sv,len);
a5a20234 3532 if (!len) {
7e2040f0 3533 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3534 sv_setpvn(TARG, "", 0);
3535 SETs(TARG);
a0ed51b3
LW		 3536 }
3537 else {
128c9517
JH		 3538 STRLEN min = len + 1;
3539
862a34c6 3540 SvUPGRADE(TARG, SVt_PV);
128c9517 3541 SvGROW(TARG, min);
31351b04
JS		 3542 (void)SvPOK_only(TARG);
3543 d = (U8*)SvPVX(TARG);
3544 send = s + len;
a2a2844f 3545 while (s < send) {
1b6737cc
AL		 3546 const STRLEN u = UTF8SKIP(s);
3547 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
89ebb4a3
JH		 3548
3549#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
6fdb5f96
JH		 3550 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3551 /*
3552 * Now if the sigma is NOT followed by
3553 * /$ignorable_sequence$cased_letter/;
3554 * and it IS preceded by
3555 * /$cased_letter$ignorable_sequence/;
3556 * where $ignorable_sequence is
3557 * [\x{2010}\x{AD}\p{Mn}]*
3558 * and $cased_letter is
3559 * [\p{Ll}\p{Lo}\p{Lt}]
3560 * then it should be mapped to 0x03C2,
3561 * (GREEK SMALL LETTER FINAL SIGMA),
3562 * instead of staying 0x03A3.
89ebb4a3
JH		 3563 * "should be": in other words,
3564 * this is not implemented yet.
3565 * See lib/unicore/SpecialCasing.txt.
6fdb5f96
JH		 3566 */
3567 }
128c9517
JH		 3568 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3569 /* If the eventually required minimum size outgrows
3570 * the available space, we need to grow. */
349d4f2f 3571 UV o = d - (U8*)SvPVX_const(TARG);
89ebb4a3
JH		 3572
3573 /* If someone lowercases one million U+0130s we
3574 * SvGROW() one million times. Or we could try
32c480af
JH		 3575 * guessing how much to allocate without allocating.
3576 * too much. Such is life. */
128c9517 3577 SvGROW(TARG, min);
89ebb4a3
JH		 3578 d = (U8*)SvPVX(TARG) + o;
3579 }
a2a2844f
JH		 3580 Copy(tmpbuf, d, ulen, U8);
3581 d += ulen;
89ebb4a3 3582 s += u;
a0ed51b3 3583 }
31351b04 3584 *d = '\0';
7e2040f0 3585 SvUTF8_on(TARG);
349d4f2f 3586 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
31351b04 3587 SETs(TARG);
a0ed51b3 3588 }
79072805 3589 }
626727d5 3590 else {
10516c54 3591 U8 *s;
014822e4 3592 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3593 dTARGET;
7e2040f0 3594 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3595 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3596 sv = TARG;
3597 SETs(sv);
a0ed51b3 3598 }
bbce6d69 3599
d104a74c 3600 s = (U8*)SvPV_force_nomg(sv, len);
31351b04 3601 if (len) {
1b6737cc 3602 register const U8 * const send = s + len;
bbce6d69 3603
2de3dbcc 3604 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3605 TAINT;
3606 SvTAINTED_on(sv);
3607 for (; s < send; s++)
3608 *s = toLOWER_LC(*s);
3609 }
3610 else {
3611 for (; s < send; s++)
3612 *s = toLOWER(*s);
3613 }
bbce6d69 3614 }
79072805 3615 }
d104a74c 3616 SvSETMAGIC(sv);
79072805
LW		 3617 RETURN;
3618}
3619
a0d0e21e 3620PP(pp_quotemeta)
79072805 3621{
39644a26 3622 dSP; dTARGET;
1b6737cc 3623 SV * const sv = TOPs;
a0d0e21e 3624 STRLEN len;
0d46e09a 3625 register const char *s = SvPV_const(sv,len);
79072805 3626
7e2040f0 3627 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 3628 if (len) {
1b6737cc 3629 register char *d;
862a34c6 3630 SvUPGRADE(TARG, SVt_PV);
c07a80fd 3631 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 3632 d = SvPVX(TARG);
7e2040f0 3633 if (DO_UTF8(sv)) {
0dd2cdef 3634 while (len) {
fd400ab9 3635 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW		 3636 STRLEN ulen = UTF8SKIP(s);
3637 if (ulen > len)
3638 ulen = len;
3639 len -= ulen;
3640 while (ulen--)
3641 *d++ = *s++;
3642 }
3643 else {
3644 if (!isALNUM(*s))
3645 *d++ = '\\';
3646 *d++ = *s++;
3647 len--;
3648 }
3649 }
7e2040f0 3650 SvUTF8_on(TARG);
0dd2cdef
LW		 3651 }
3652 else {
3653 while (len--) {
3654 if (!isALNUM(*s))
3655 *d++ = '\\';
3656 *d++ = *s++;
3657 }
79072805 3658 }
a0d0e21e 3659 *d = '\0';
349d4f2f 3660 SvCUR_set(TARG, d - SvPVX_const(TARG));
3aa33fe5 3661 (void)SvPOK_only_UTF8(TARG);
79072805 3662 }
a0d0e21e
LW		 3663 else
3664 sv_setpvn(TARG, s, len);
3665 SETs(TARG);
31351b04
JS		 3666 if (SvSMAGICAL(TARG))
3667 mg_set(TARG);
79072805
LW		 3668 RETURN;
3669}
3670
a0d0e21e 3671/* Arrays. */
79072805 3672
a0d0e21e 3673PP(pp_aslice)
79072805 3674{
39644a26 3675 dSP; dMARK; dORIGMARK;
1b6737cc
AL		 3676 register AV* const av = (AV*)POPs;
3677 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
79072805 3678
a0d0e21e 3679 if (SvTYPE(av) == SVt_PVAV) {
1b6737cc 3680 const I32 arybase = PL_curcop->cop_arybase;
533c011a 3681 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
1b6737cc 3682 register SV **svp;
748a9306 3683 I32 max = -1;
924508f0 3684 for (svp = MARK + 1; svp <= SP; svp++) {
1b6737cc 3685 const I32 elem = SvIVx(*svp);
748a9306
LW		 3686 if (elem > max)
3687 max = elem;
3688 }
3689 if (max > AvMAX(av))
3690 av_extend(av, max);
3691 }
a0d0e21e 3692 while (++MARK <= SP) {
1b6737cc
AL		 3693 register SV **svp;
3694 I32 elem = SvIVx(*MARK);
a0d0e21e 3695
748a9306
LW		 3696 if (elem > 0)
3697 elem -= arybase;
a0d0e21e
LW		 3698 svp = av_fetch(av, elem, lval);
3699 if (lval) {
3280af22 3700 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 3701 DIE(aTHX_ PL_no_aelem, elem);
533c011a 3702 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 3703 save_aelem(av, elem, svp);
79072805 3704 }
3280af22 3705 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 3706 }
3707 }
748a9306 3708 if (GIMME != G_ARRAY) {
a0d0e21e 3709 MARK = ORIGMARK;
04ab2c87 3710 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e
LW		 3711 SP = MARK;
3712 }
79072805
LW		 3713 RETURN;
3714}
3715
3716/* Associative arrays. */
3717
3718PP(pp_each)
3719{
39644a26 3720 dSP;
1b6737cc 3721 HV * const hash = (HV*)POPs;
c07a80fd 3722 HE *entry;
f54cb97a 3723 const I32 gimme = GIMME_V;
8ec5e241 3724
c07a80fd 3725 PUTBACK;
c750a3ec 3726 /* might clobber stack_sp */
6d822dc4 3727 entry = hv_iternext(hash);
c07a80fd 3728 SPAGAIN;
79072805 3729
79072805
LW		 3730 EXTEND(SP, 2);
3731 if (entry) {
1b6737cc 3732 SV* const sv = hv_iterkeysv(entry);
574c8022 3733 PUSHs(sv); /* won't clobber stack_sp */
54310121 3734 if (gimme == G_ARRAY) {
59af0135 3735 SV *val;
c07a80fd 3736 PUTBACK;
c750a3ec 3737 /* might clobber stack_sp */
6d822dc4 3738 val = hv_iterval(hash, entry);
c07a80fd 3739 SPAGAIN;
59af0135 3740 PUSHs(val);
79072805 3741 }
79072805 3742 }
54310121 3743 else if (gimme == G_SCALAR)
79072805
LW		 3744 RETPUSHUNDEF;
3745
3746 RETURN;
3747}
3748
79072805
LW		 3749PP(pp_delete)
3750{
39644a26 3751 dSP;
f54cb97a
AL		 3752 const I32 gimme = GIMME_V;
3753 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5f05dabc 3754
533c011a 3755 if (PL_op->op_private & OPpSLICE) {
5f05dabc 3756 dMARK; dORIGMARK;
1b6737cc
AL		 3757 HV * const hv = (HV*)POPs;
3758 const U32 hvtype = SvTYPE(hv);
01020589
GS		 3759 if (hvtype == SVt_PVHV) { /* hash element */
3760 while (++MARK <= SP) {
1b6737cc 3761 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 3762 *MARK = sv ? sv : &PL_sv_undef;
3763 }
5f05dabc 3764 }
6d822dc4
MS		 3765 else if (hvtype == SVt_PVAV) { /* array element */
3766 if (PL_op->op_flags & OPf_SPECIAL) {
3767 while (++MARK <= SP) {
1b6737cc 3768 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
6d822dc4
MS		 3769 *MARK = sv ? sv : &PL_sv_undef;
3770 }
3771 }
01020589
GS		 3772 }
3773 else
3774 DIE(aTHX_ "Not a HASH reference");
54310121 3775 if (discard)
3776 SP = ORIGMARK;
3777 else if (gimme == G_SCALAR) {
5f05dabc 3778 MARK = ORIGMARK;
9111c9c0
DM		 3779 if (SP > MARK)
3780 *++MARK = *SP;
3781 else
3782 *++MARK = &PL_sv_undef;
5f05dabc 3783 SP = MARK;
3784 }
3785 }
3786 else {
3787 SV *keysv = POPs;
1b6737cc
AL		 3788 HV * const hv = (HV*)POPs;
3789 SV *sv;
97fcbf96
MB		 3790 if (SvTYPE(hv) == SVt_PVHV)
3791 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 3792 else if (SvTYPE(hv) == SVt_PVAV) {
3793 if (PL_op->op_flags & OPf_SPECIAL)
3794 sv = av_delete((AV*)hv, SvIV(keysv), discard);
af288a60
HS		 3795 else
3796 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 3797 }
97fcbf96 3798 else
cea2e8a9 3799 DIE(aTHX_ "Not a HASH reference");
5f05dabc 3800 if (!sv)
3280af22 3801 sv = &PL_sv_undef;
54310121 3802 if (!discard)
3803 PUSHs(sv);
79072805 3804 }
79072805
LW		 3805 RETURN;
3806}
3807
a0d0e21e 3808PP(pp_exists)
79072805 3809{
39644a26 3810 dSP;
afebc493
GS		 3811 SV *tmpsv;
3812 HV *hv;
3813
3814 if (PL_op->op_private & OPpEXISTS_SUB) {
3815 GV *gv;
afebc493 3816 SV *sv = POPs;
1b6737cc 3817 CV * const cv = sv_2cv(sv, &hv, &gv, FALSE);
afebc493
GS		 3818 if (cv)
3819 RETPUSHYES;
3820 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3821 RETPUSHYES;
3822 RETPUSHNO;
3823 }
3824 tmpsv = POPs;
3825 hv = (HV*)POPs;
c750a3ec 3826 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 3827 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 3828 RETPUSHYES;
ef54e1a4
JH		 3829 }
3830 else if (SvTYPE(hv) == SVt_PVAV) {
01020589
GS		 3831 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3832 if (av_exists((AV*)hv, SvIV(tmpsv)))
3833 RETPUSHYES;
3834 }
ef54e1a4
JH		 3835 }
3836 else {
cea2e8a9 3837 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 3838 }
a0d0e21e
LW		 3839 RETPUSHNO;
3840}
79072805 3841
a0d0e21e
LW		 3842PP(pp_hslice)
3843{
39644a26 3844 dSP; dMARK; dORIGMARK;
1b6737cc
AL		 3845 register HV * const hv = (HV*)POPs;
3846 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3847 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
eb85dfd3 3848 bool other_magic = FALSE;
79072805 3849
eb85dfd3
DM		 3850 if (localizing) {
3851 MAGIC *mg;
3852 HV *stash;
3853
3854 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3855 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3856 /* Try to preserve the existenceness of a tied hash
3857 * element by using EXISTS and DELETE if possible.
3858 * Fallback to FETCH and STORE otherwise */
3859 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3860 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3861 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3862 }
3863
6d822dc4 3864 while (++MARK <= SP) {
1b6737cc 3865 SV * const keysv = *MARK;
6d822dc4
MS		 3866 SV **svp;
3867 HE *he;
3868 bool preeminent = FALSE;
0ebe0038 3869
6d822dc4
MS		 3870 if (localizing) {
3871 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3872 hv_exists_ent(hv, keysv, 0);
3873 }
eb85dfd3 3874
6d822dc4
MS		 3875 he = hv_fetch_ent(hv, keysv, lval, 0);
3876 svp = he ? &HeVAL(he) : 0;
eb85dfd3 3877
6d822dc4
MS		 3878 if (lval) {
3879 if (!svp || *svp == &PL_sv_undef) {
ce5030a2 3880 DIE(aTHX_ PL_no_helem_sv, keysv);
6d822dc4
MS		 3881 }
3882 if (localizing) {
3883 if (preeminent)
3884 save_helem(hv, keysv, svp);
3885 else {
3886 STRLEN keylen;
5c144d81 3887 const char *key = SvPV_const(keysv, keylen);
6d822dc4 3888 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1f5346dc 3889 }
6d822dc4
MS		 3890 }
3891 }
3892 *MARK = svp ? *svp : &PL_sv_undef;
79072805 3893 }
a0d0e21e
LW		 3894 if (GIMME != G_ARRAY) {
3895 MARK = ORIGMARK;
04ab2c87 3896 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e 3897 SP = MARK;
79072805 3898 }
a0d0e21e
LW		 3899 RETURN;
3900}
3901
3902/* List operators. */
3903
3904PP(pp_list)
3905{
39644a26 3906 dSP; dMARK;
a0d0e21e
LW		 3907 if (GIMME != G_ARRAY) {
3908 if (++MARK <= SP)
3909 *MARK = *SP; /* unwanted list, return last item */
8990e307 3910 else
3280af22 3911 *MARK = &PL_sv_undef;
a0d0e21e 3912 SP = MARK;
79072805 3913 }
a0d0e21e 3914 RETURN;
79072805
LW		 3915}
3916
a0d0e21e 3917PP(pp_lslice)
79072805 3918{
39644a26 3919 dSP;
1b6737cc
AL		 3920 SV ** const lastrelem = PL_stack_sp;
3921 SV ** const lastlelem = PL_stack_base + POPMARK;
3922 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3923 register SV ** const firstrelem = lastlelem + 1;
3924 const I32 arybase = PL_curcop->cop_arybase;
3925 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3926
3927 register const I32 max = lastrelem - lastlelem;
a0d0e21e 3928 register SV **lelem;
a0d0e21e
LW		 3929
3930 if (GIMME != G_ARRAY) {
1b6737cc 3931 I32 ix = SvIVx(*lastlelem);
748a9306
LW		 3932 if (ix < 0)
3933 ix += max;
3934 else
3935 ix -= arybase;
a0d0e21e 3936 if (ix < 0 || ix >= max)
3280af22 3937 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 3938 else
3939 *firstlelem = firstrelem[ix];
3940 SP = firstlelem;
3941 RETURN;
3942 }
3943
3944 if (max == 0) {
3945 SP = firstlelem - 1;
3946 RETURN;
3947 }
3948
3949 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1b6737cc 3950 I32 ix = SvIVx(*lelem);
c73bf8e3 3951 if (ix < 0)
a0d0e21e 3952 ix += max;
b13b2135 3953 else
748a9306 3954 ix -= arybase;
c73bf8e3
HS		 3955 if (ix < 0 || ix >= max)
3956 *lelem = &PL_sv_undef;
3957 else {
3958 is_something_there = TRUE;
3959 if (!(*lelem = firstrelem[ix]))
3280af22 3960 *lelem = &PL_sv_undef;
748a9306 3961 }
79072805 3962 }
4633a7c4
LW		 3963 if (is_something_there)
3964 SP = lastlelem;
3965 else
3966 SP = firstlelem - 1;
79072805
LW		 3967 RETURN;
3968}
3969
a0d0e21e
LW		 3970PP(pp_anonlist)
3971{
39644a26 3972 dSP; dMARK; dORIGMARK;
1b6737cc
AL		 3973 const I32 items = SP - MARK;
3974 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
44a8e56a 3975 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3976 XPUSHs(av);
a0d0e21e
LW		 3977 RETURN;
3978}
3979
3980PP(pp_anonhash)
79072805 3981{
39644a26 3982 dSP; dMARK; dORIGMARK;
1b6737cc 3983 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
a0d0e21e
LW		 3984
3985 while (MARK < SP) {
1b6737cc
AL		 3986 SV * const key = *++MARK;
3987 SV * const val = NEWSV(46, 0);
a0d0e21e
LW		 3988 if (MARK < SP)
3989 sv_setsv(val, *++MARK);
e476b1b5 3990 else if (ckWARN(WARN_MISC))
9014280d 3991 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
f12c7020 3992 (void)hv_store_ent(hv,key,val,0);
79072805 3993 }
a0d0e21e
LW		 3994 SP = ORIGMARK;
3995 XPUSHs((SV*)hv);
79072805
LW		 3996 RETURN;
3997}
3998
a0d0e21e 3999PP(pp_splice)
79072805 4000{
27da23d5 4001 dVAR; dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 4002 register AV *ary = (AV*)*++MARK;
4003 register SV **src;
4004 register SV **dst;
4005 register I32 i;
4006 register I32 offset;
4007 register I32 length;
4008 I32 newlen;
4009 I32 after;
4010 I32 diff;
4011 SV **tmparyval = 0;
1b6737cc 4012 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
93965878 4013
1b6737cc 4014 if (mg) {
33c27489 4015 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 4016 PUSHMARK(MARK);
8ec5e241 4017 PUTBACK;
a60c0954 4018 ENTER;
864dbfa3 4019 call_method("SPLICE",GIMME_V);
a60c0954 4020 LEAVE;
93965878
NIS		 4021 SPAGAIN;
4022 RETURN;
4023 }
79072805 4024
a0d0e21e 4025 SP++;
79072805 4026
a0d0e21e 4027 if (++MARK < SP) {
84902520 4028 offset = i = SvIVx(*MARK);
a0d0e21e 4029 if (offset < 0)
93965878 4030 offset += AvFILLp(ary) + 1;
a0d0e21e 4031 else
3280af22 4032 offset -= PL_curcop->cop_arybase;
84902520 4033 if (offset < 0)
cea2e8a9 4034 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 4035 if (++MARK < SP) {
4036 length = SvIVx(*MARK++);
48cdf507
GA		 4037 if (length < 0) {
4038 length += AvFILLp(ary) - offset + 1;
4039 if (length < 0)
4040 length = 0;
4041 }
79072805
LW		 4042 }
4043 else
a0d0e21e 4044 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 4045 }
a0d0e21e
LW		 4046 else {
4047 offset = 0;
4048 length = AvMAX(ary) + 1;
4049 }
8cbc2e3b
JH		 4050 if (offset > AvFILLp(ary) + 1) {
4051 if (ckWARN(WARN_MISC))
9014280d 4052 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 4053 offset = AvFILLp(ary) + 1;
8cbc2e3b 4054 }
93965878 4055 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 4056 if (after < 0) { /* not that much array */
4057 length += after; /* offset+length now in array */
4058 after = 0;
4059 if (!AvALLOC(ary))
4060 av_extend(ary, 0);
4061 }
4062
4063 /* At this point, MARK .. SP-1 is our new LIST */
4064
4065 newlen = SP - MARK;
4066 diff = newlen - length;
13d7cbc1
GS		 4067 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4068 av_reify(ary);
a0d0e21e 4069
50528de0
WL		 4070 /* make new elements SVs now: avoid problems if they're from the array */
4071 for (dst = MARK, i = newlen; i; i--) {
1b6737cc 4072 SV * const h = *dst;
f2b990bf 4073 *dst++ = newSVsv(h);
50528de0
WL		 4074 }
4075
a0d0e21e
LW		 4076 if (diff < 0) { /* shrinking the area */
4077 if (newlen) {
a02a5408 4078 Newx(tmparyval, newlen, SV*); /* so remember insertion */
a0d0e21e 4079 Copy(MARK, tmparyval, newlen, SV*);
79072805 4080 }
a0d0e21e
LW		 4081
4082 MARK = ORIGMARK + 1;
4083 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4084 MEXTEND(MARK, length);
4085 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4086 if (AvREAL(ary)) {
bbce6d69 4087 EXTEND_MORTAL(length);
36477c24 4088 for (i = length, dst = MARK; i; i--) {
d689ffdd 4089 sv_2mortal(*dst); /* free them eventualy */
36477c24 4090 dst++;
4091 }
a0d0e21e
LW		 4092 }
4093 MARK += length - 1;
79072805 4094 }
a0d0e21e
LW		 4095 else {
4096 *MARK = AvARRAY(ary)[offset+length-1];
4097 if (AvREAL(ary)) {
d689ffdd 4098 sv_2mortal(*MARK);
a0d0e21e
LW		 4099 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4100 SvREFCNT_dec(*dst++); /* free them now */
79072805 4101 }
a0d0e21e 4102 }
93965878 4103 AvFILLp(ary) += diff;
a0d0e21e
LW		 4104
4105 /* pull up or down? */
4106
4107 if (offset < after) { /* easier to pull up */
4108 if (offset) { /* esp. if nothing to pull */
4109 src = &AvARRAY(ary)[offset-1];
4110 dst = src - diff; /* diff is negative */
4111 for (i = offset; i > 0; i--) /* can't trust Copy */
4112 *dst-- = *src--;
79072805 4113 }
a0d0e21e 4114 dst = AvARRAY(ary);
f880fe2f 4115 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
a0d0e21e
LW		 4116 AvMAX(ary) += diff;
4117 }
4118 else {
4119 if (after) { /* anything to pull down? */
4120 src = AvARRAY(ary) + offset + length;
4121 dst = src + diff; /* diff is negative */
4122 Move(src, dst, after, SV*);
79072805 4123 }
93965878 4124 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 4125 /* avoid later double free */
4126 }
4127 i = -diff;
4128 while (i)
3280af22 4129 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 4130
4131 if (newlen) {
50528de0 4132 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e
LW		 4133 Safefree(tmparyval);
4134 }
4135 }
4136 else { /* no, expanding (or same) */
4137 if (length) {
a02a5408 4138 Newx(tmparyval, length, SV*); /* so remember deletion */
a0d0e21e
LW		 4139 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4140 }
4141
4142 if (diff > 0) { /* expanding */
4143
4144 /* push up or down? */
4145
4146 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4147 if (offset) {
4148 src = AvARRAY(ary);
4149 dst = src - diff;
4150 Move(src, dst, offset, SV*);
79072805 4151 }
f880fe2f 4152 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
a0d0e21e 4153 AvMAX(ary) += diff;
93965878 4154 AvFILLp(ary) += diff;
79072805
LW		 4155 }
4156 else {
93965878
NIS		 4157 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4158 av_extend(ary, AvFILLp(ary) + diff);
4159 AvFILLp(ary) += diff;
a0d0e21e
LW		 4160
4161 if (after) {
93965878 4162 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 4163 src = dst - diff;
4164 for (i = after; i; i--) {
4165 *dst-- = *src--;
4166 }
79072805
LW		 4167 }
4168 }
a0d0e21e
LW		 4169 }
4170
50528de0
WL		 4171 if (newlen) {
4172 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e 4173 }
50528de0 4174
a0d0e21e
LW		 4175 MARK = ORIGMARK + 1;
4176 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4177 if (length) {
4178 Copy(tmparyval, MARK, length, SV*);
4179 if (AvREAL(ary)) {
bbce6d69 4180 EXTEND_MORTAL(length);
36477c24 4181 for (i = length, dst = MARK; i; i--) {
d689ffdd 4182 sv_2mortal(*dst); /* free them eventualy */
36477c24 4183 dst++;
4184 }
79072805 4185 }
a0d0e21e 4186 Safefree(tmparyval);
79072805 4187 }
a0d0e21e
LW		 4188 MARK += length - 1;
4189 }
4190 else if (length--) {
4191 *MARK = tmparyval[length];
4192 if (AvREAL(ary)) {
d689ffdd 4193 sv_2mortal(*MARK);
a0d0e21e
LW		 4194 while (length-- > 0)
4195 SvREFCNT_dec(tmparyval[length]);
79072805 4196 }
a0d0e21e 4197 Safefree(tmparyval);
79072805 4198 }
a0d0e21e 4199 else
3280af22 4200 *MARK = &PL_sv_undef;
79072805 4201 }
a0d0e21e 4202 SP = MARK;
79072805
LW		 4203 RETURN;
4204}
4205
a0d0e21e 4206PP(pp_push)
79072805 4207{
27da23d5 4208 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4209 register AV *ary = (AV*)*++MARK;
1b6737cc 4210 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
79072805 4211
1b6737cc 4212 if (mg) {
33c27489 4213 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS		 4214 PUSHMARK(MARK);
4215 PUTBACK;
a60c0954 4216 ENTER;
864dbfa3 4217 call_method("PUSH",G_SCALAR|G_DISCARD);
a60c0954 4218 LEAVE;
93965878 4219 SPAGAIN;
0a75904b
TP		 4220 SP = ORIGMARK;
4221 PUSHi( AvFILL(ary) + 1 );
93965878 4222 }
a60c0954 4223 else {
a60c0954 4224 for (++MARK; MARK <= SP; MARK++) {
1b6737cc 4225 SV * const sv = NEWSV(51, 0);
a60c0954
NIS		 4226 if (*MARK)
4227 sv_setsv(sv, *MARK);
0a75904b 4228 av_store(ary, AvFILLp(ary)+1, sv);
a60c0954 4229 }
0a75904b
TP		 4230 SP = ORIGMARK;
4231 PUSHi( AvFILLp(ary) + 1 );
79072805 4232 }
79072805
LW		 4233 RETURN;
4234}
4235
a0d0e21e 4236PP(pp_pop)
79072805 4237{
39644a26 4238 dSP;
1b6737cc
AL		 4239 AV * const av = (AV*)POPs;
4240 SV * const sv = av_pop(av);
d689ffdd 4241 if (AvREAL(av))
a0d0e21e
LW		 4242 (void)sv_2mortal(sv);
4243 PUSHs(sv);
79072805 4244 RETURN;
79072805
LW		 4245}
4246
a0d0e21e 4247PP(pp_shift)
79072805 4248{
39644a26 4249 dSP;
1b6737cc
AL		 4250 AV * const av = (AV*)POPs;
4251 SV * const sv = av_shift(av);
79072805 4252 EXTEND(SP, 1);
a0d0e21e 4253 if (!sv)
79072805 4254 RETPUSHUNDEF;
d689ffdd 4255 if (AvREAL(av))
a0d0e21e
LW		 4256 (void)sv_2mortal(sv);
4257 PUSHs(sv);
79072805 4258 RETURN;
79072805
LW		 4259}
4260
a0d0e21e 4261PP(pp_unshift)
79072805 4262{
27da23d5 4263 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4264 register AV *ary = (AV*)*++MARK;
1b6737cc 4265 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
93965878 4266
1b6737cc 4267 if (mg) {
33c27489 4268 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 4269 PUSHMARK(MARK);
93965878 4270 PUTBACK;
a60c0954 4271 ENTER;
864dbfa3 4272 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
a60c0954 4273 LEAVE;
93965878 4274 SPAGAIN;
93965878 4275 }
a60c0954 4276 else {
1b6737cc 4277 register I32 i = 0;
a60c0954
NIS		 4278 av_unshift(ary, SP - MARK);
4279 while (MARK < SP) {
1b6737cc 4280 SV * const sv = newSVsv(*++MARK);
a60c0954
NIS		 4281 (void)av_store(ary, i++, sv);
4282 }
79072805 4283 }
a0d0e21e
LW		 4284 SP = ORIGMARK;
4285 PUSHi( AvFILL(ary) + 1 );
79072805 4286 RETURN;
79072805
LW		 4287}
4288
a0d0e21e 4289PP(pp_reverse)
79072805 4290{
39644a26 4291 dSP; dMARK;
1b6737cc 4292 SV ** const oldsp = SP;
79072805 4293
a0d0e21e
LW		 4294 if (GIMME == G_ARRAY) {
4295 MARK++;
4296 while (MARK < SP) {
1b6737cc 4297 register SV * const tmp = *MARK;
a0d0e21e
LW		 4298 *MARK++ = *SP;
4299 *SP-- = tmp;
4300 }
dd58a1ab 4301 /* safe as long as stack cannot get extended in the above */
a0d0e21e 4302 SP = oldsp;
79072805
LW		 4303 }
4304 else {
a0d0e21e
LW		 4305 register char *up;
4306 register char *down;
4307 register I32 tmp;
4308 dTARGET;
4309 STRLEN len;
e1f795dc 4310 I32 padoff_du;
79072805 4311
7e2040f0 4312 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4313 if (SP - MARK > 1)
3280af22 4314 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 4315 else
e1f795dc
RGS		 4316 sv_setsv(TARG, (SP > MARK)
4317 ? *SP
29289021 4318 : (padoff_du = find_rundefsvoffset(),
e1f795dc
RGS		 4319 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4320 ? DEFSV : PAD_SVl(padoff_du)));
a0d0e21e
LW		 4321 up = SvPV_force(TARG, len);
4322 if (len > 1) {
7e2040f0 4323 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55 4324 U8* s = (U8*)SvPVX(TARG);
349d4f2f 4325 const U8* send = (U8*)(s + len);
a0ed51b3 4326 while (s < send) {
d742c382 4327 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 4328 s++;
4329 continue;
4330 }
4331 else {
9041c2e3 4332 if (!utf8_to_uvchr(s, 0))
a0dbb045 4333 break;
dfe13c55 4334 up = (char*)s;
a0ed51b3 4335 s += UTF8SKIP(s);
dfe13c55 4336 down = (char*)(s - 1);
a0dbb045 4337 /* reverse this character */
a0ed51b3
LW		 4338 while (down > up) {
4339 tmp = *up;
4340 *up++ = *down;
eb160463 4341 *down-- = (char)tmp;
a0ed51b3
LW		 4342 }
4343 }
4344 }
4345 up = SvPVX(TARG);
4346 }
a0d0e21e
LW		 4347 down = SvPVX(TARG) + len - 1;
4348 while (down > up) {
4349 tmp = *up;
4350 *up++ = *down;
eb160463 4351 *down-- = (char)tmp;
a0d0e21e 4352 }
3aa33fe5 4353 (void)SvPOK_only_UTF8(TARG);
79072805 4354 }
a0d0e21e
LW		 4355 SP = MARK + 1;
4356 SETTARG;
79072805 4357 }
a0d0e21e 4358 RETURN;
79072805
LW		 4359}
4360
a0d0e21e 4361PP(pp_split)
79072805 4362{
27da23d5 4363 dVAR; dSP; dTARG;
a0d0e21e 4364 AV *ary;
467f0320 4365 register IV limit = POPi; /* note, negative is forever */
1b6737cc 4366 SV * const sv = POPs;
a0d0e21e 4367 STRLEN len;
727b7506 4368 register const char *s = SvPV_const(sv, len);
1b6737cc 4369 const bool do_utf8 = DO_UTF8(sv);
727b7506 4370 const char *strend = s + len;
44a8e56a 4371 register PMOP *pm;
d9f97599 4372 register REGEXP *rx;
a0d0e21e 4373 register SV *dstr;
727b7506 4374 register const char *m;
a0d0e21e 4375 I32 iters = 0;
f54cb97a 4376 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
792b2c16 4377 I32 maxiters = slen + 10;
727b7506 4378 const char *orig;
1b6737cc 4379 const I32 origlimit = limit;
a0d0e21e
LW		 4380 I32 realarray = 0;
4381 I32 base;
f54cb97a
AL		 4382 const I32 gimme = GIMME_V;
4383 const I32 oldsave = PL_savestack_ix;
8ec5e241 4384 I32 make_mortal = 1;
7fba1cd6 4385 bool multiline = 0;
8ec5e241 4386 MAGIC *mg = (MAGIC *) NULL;
79072805 4387
44a8e56a 4388#ifdef DEBUGGING
4389 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4390#else
4391 pm = (PMOP*)POPs;
4392#endif
a0d0e21e 4393 if (!pm || !s)
2269b42e 4394 DIE(aTHX_ "panic: pp_split");
aaa362c4 4395 rx = PM_GETRE(pm);
bbce6d69 4396
4397 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4398 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4399
a30b2f1f 4400 RX_MATCH_UTF8_set(rx, do_utf8);
d9f424b2 4401
971a9dd3
GS		 4402 if (pm->op_pmreplroot) {
4403#ifdef USE_ITHREADS
dd2155a4 4404 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
971a9dd3 4405#else
a0d0e21e 4406 ary = GvAVn((GV*)pm->op_pmreplroot);
971a9dd3
GS		 4407#endif
4408 }
a0d0e21e 4409 else if (gimme != G_ARRAY)
3280af22 4410 ary = GvAVn(PL_defgv);
79072805 4411 else
a0d0e21e
LW		 4412 ary = Nullav;
4413 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4414 realarray = 1;
8ec5e241 4415 PUTBACK;
a0d0e21e
LW		 4416 av_extend(ary,0);
4417 av_clear(ary);
8ec5e241 4418 SPAGAIN;
14befaf4 4419 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
8ec5e241 4420 PUSHMARK(SP);
33c27489 4421 XPUSHs(SvTIED_obj((SV*)ary, mg));
8ec5e241
NIS		 4422 }
4423 else {
1c0b011c 4424 if (!AvREAL(ary)) {
1b6737cc 4425 I32 i;
1c0b011c 4426 AvREAL_on(ary);
abff13bb 4427 AvREIFY_off(ary);
1c0b011c 4428 for (i = AvFILLp(ary); i >= 0; i--)
3280af22 4429 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 4430 }
4431 /* temporarily switch stacks */
8b7059b1 4432 SAVESWITCHSTACK(PL_curstack, ary);
8ec5e241 4433 make_mortal = 0;
1c0b011c 4434 }
79072805 4435 }
3280af22 4436 base = SP - PL_stack_base;
a0d0e21e
LW		 4437 orig = s;
4438 if (pm->op_pmflags & PMf_SKIPWHITE) {
bbce6d69 4439 if (pm->op_pmflags & PMf_LOCALE) {
4440 while (isSPACE_LC(*s))
4441 s++;
4442 }
4443 else {
4444 while (isSPACE(*s))
4445 s++;
4446 }
a0d0e21e 4447 }
7fba1cd6
RD		 4448 if (pm->op_pmflags & PMf_MULTILINE) {
4449 multiline = 1;
c07a80fd 4450 }
4451
a0d0e21e
LW		 4452 if (!limit)
4453 limit = maxiters + 2;
4454 if (pm->op_pmflags & PMf_WHITE) {
4455 while (--limit) {
bbce6d69 4456 m = s;
4457 while (m < strend &&
4458 !((pm->op_pmflags & PMf_LOCALE)
4459 ? isSPACE_LC(*m) : isSPACE(*m)))
4460 ++m;
a0d0e21e
LW		 4461 if (m >= strend)
4462 break;
bbce6d69 4463
f2b990bf 4464 dstr = newSVpvn(s, m-s);
8ec5e241 4465 if (make_mortal)
a0d0e21e 4466 sv_2mortal(dstr);
792b2c16 4467 if (do_utf8)
28cb3359 4468 (void)SvUTF8_on(dstr);
a0d0e21e 4469 XPUSHs(dstr);
bbce6d69 4470
4471 s = m + 1;
4472 while (s < strend &&
4473 ((pm->op_pmflags & PMf_LOCALE)
4474 ? isSPACE_LC(*s) : isSPACE(*s)))
4475 ++s;
79072805
LW		 4476 }
4477 }
770526c1 4478 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
a0d0e21e 4479 while (--limit) {
a6e20a40
AL		 4480 for (m = s; m < strend && *m != '\n'; m++)
4481 ;
a0d0e21e
LW		 4482 m++;
4483 if (m >= strend)
4484 break;
f2b990bf 4485 dstr = newSVpvn(s, m-s);
8ec5e241 4486 if (make_mortal)
a0d0e21e 4487 sv_2mortal(dstr);
792b2c16 4488 if (do_utf8)
28cb3359 4489 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4490 XPUSHs(dstr);
4491 s = m;
4492 }
4493 }
699c3c34
JH		 4494 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4495 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
d9f97599
GS		 4496 && (rx->reganch & ROPT_CHECK_ALL)
4497 && !(rx->reganch & ROPT_ANCH)) {
1b6737cc
AL		 4498 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4499 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
cf93c79d 4500
ca5b42cb 4501 len = rx->minlen;
1aa99e6b 4502 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
1b6737cc 4503 const char c = *SvPV_nolen_const(csv);
a0d0e21e 4504 while (--limit) {
a6e20a40
AL		 4505 for (m = s; m < strend && *m != c; m++)
4506 ;
a0d0e21e
LW		 4507 if (m >= strend)
4508 break;
f2b990bf 4509 dstr = newSVpvn(s, m-s);
8ec5e241 4510 if (make_mortal)
a0d0e21e 4511 sv_2mortal(dstr);
792b2c16 4512 if (do_utf8)
28cb3359 4513 (void)SvUTF8_on(dstr);
a0d0e21e 4514 XPUSHs(dstr);
93f04dac
JH		 4515 /* The rx->minlen is in characters but we want to step
4516 * s ahead by bytes. */
1aa99e6b
IH		 4517 if (do_utf8)
4518 s = (char*)utf8_hop((U8*)m, len);
4519 else
4520 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 4521 }
4522 }
4523 else {
a0d0e21e 4524 while (s < strend && --limit &&
f722798b 4525 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
7fba1cd6 4526 csv, multiline ? FBMrf_MULTILINE : 0)) )
a0d0e21e 4527 {
f2b990bf 4528 dstr = newSVpvn(s, m-s);
8ec5e241 4529 if (make_mortal)
a0d0e21e 4530 sv_2mortal(dstr);
792b2c16 4531 if (do_utf8)
28cb3359 4532 (void)SvUTF8_on(dstr);
a0d0e21e 4533 XPUSHs(dstr);
93f04dac
JH		 4534 /* The rx->minlen is in characters but we want to step
4535 * s ahead by bytes. */
1aa99e6b
IH		 4536 if (do_utf8)
4537 s = (char*)utf8_hop((U8*)m, len);
4538 else
4539 s = m + len; /* Fake \n at the end */
a0d0e21e 4540 }
463ee0b2 4541 }
463ee0b2 4542 }
a0d0e21e 4543 else {
792b2c16 4544 maxiters += slen * rx->nparens;
080c2dec 4545 while (s < strend && --limit)
bbce6d69 4546 {
1b6737cc 4547 I32 rex_return;
080c2dec 4548 PUTBACK;
1b6737cc 4549 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
727b7506 4550 sv, NULL, 0);
080c2dec 4551 SPAGAIN;
1b6737cc 4552 if (rex_return == 0)
080c2dec 4553 break;
d9f97599 4554 TAINT_IF(RX_MATCH_TAINTED(rx));
cf93c79d 4555 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 4556 m = s;
4557 s = orig;
cf93c79d 4558 orig = rx->subbeg;
a0d0e21e
LW		 4559 s = orig + (m - s);
4560 strend = s + (strend - m);
4561 }
cf93c79d 4562 m = rx->startp[0] + orig;
f2b990bf 4563 dstr = newSVpvn(s, m-s);
8ec5e241 4564 if (make_mortal)
a0d0e21e 4565 sv_2mortal(dstr);
792b2c16 4566 if (do_utf8)
28cb3359 4567 (void)SvUTF8_on(dstr);
a0d0e21e 4568 XPUSHs(dstr);
d9f97599 4569 if (rx->nparens) {
1b6737cc 4570 I32 i;
eb160463 4571 for (i = 1; i <= (I32)rx->nparens; i++) {
cf93c79d
IZ		 4572 s = rx->startp[i] + orig;
4573 m = rx->endp[i] + orig;
6de67870
JP		 4574
4575 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4576 parens that didn't match -- they should be set to
4577 undef, not the empty string */
4578 if (m >= orig && s >= orig) {
f2b990bf 4579 dstr = newSVpvn(s, m-s);
748a9306
LW		 4580 }
4581 else
6de67870 4582 dstr = &PL_sv_undef; /* undef, not "" */
8ec5e241 4583 if (make_mortal)
a0d0e21e 4584 sv_2mortal(dstr);
792b2c16 4585 if (do_utf8)
28cb3359 4586 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4587 XPUSHs(dstr);
4588 }
4589 }
cf93c79d 4590 s = rx->endp[0] + orig;
a0d0e21e 4591 }
79072805 4592 }
8ec5e241 4593
3280af22 4594 iters = (SP - PL_stack_base) - base;
a0d0e21e 4595 if (iters > maxiters)
cea2e8a9 4596 DIE(aTHX_ "Split loop");
8ec5e241 4597
a0d0e21e
LW		 4598 /* keep field after final delim? */
4599 if (s < strend || (iters && origlimit)) {
1b6737cc 4600 const STRLEN l = strend - s;
f2b990bf 4601 dstr = newSVpvn(s, l);
8ec5e241 4602 if (make_mortal)
a0d0e21e 4603 sv_2mortal(dstr);
792b2c16 4604 if (do_utf8)
28cb3359 4605 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4606 XPUSHs(dstr);
4607 iters++;
79072805 4608 }
a0d0e21e 4609 else if (!origlimit) {
89900bd3
SR		 4610 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4611 if (TOPs && !make_mortal)
4612 sv_2mortal(TOPs);
4613 iters--;
e3a8873f 4614 *SP-- = &PL_sv_undef;
89900bd3 4615 }
a0d0e21e 4616 }
8ec5e241 4617
8b7059b1
DM		 4618 PUTBACK;
4619 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4620 SPAGAIN;
a0d0e21e 4621 if (realarray) {
8ec5e241 4622 if (!mg) {
1c0b011c
NIS		 4623 if (SvSMAGICAL(ary)) {
4624 PUTBACK;
4625 mg_set((SV*)ary);
4626 SPAGAIN;
4627 }
4628 if (gimme == G_ARRAY) {
4629 EXTEND(SP, iters);
4630 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4631 SP += iters;
4632 RETURN;
4633 }
8ec5e241 4634 }
1c0b011c 4635 else {
fb73857a 4636 PUTBACK;
8ec5e241 4637 ENTER;
864dbfa3 4638 call_method("PUSH",G_SCALAR|G_DISCARD);
8ec5e241 4639 LEAVE;
fb73857a 4640 SPAGAIN;
8ec5e241 4641 if (gimme == G_ARRAY) {
1b6737cc 4642 I32 i;
8ec5e241
NIS		 4643 /* EXTEND should not be needed - we just popped them */
4644 EXTEND(SP, iters);
4645 for (i=0; i < iters; i++) {
4646 SV **svp = av_fetch(ary, i, FALSE);
3280af22 4647 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 4648 }
1c0b011c
NIS		 4649 RETURN;
4650 }
a0d0e21e
LW		 4651 }
4652 }
4653 else {
4654 if (gimme == G_ARRAY)
4655 RETURN;
4656 }
7f18b612
YST		 4657
4658 GETTARGET;
4659 PUSHi(iters);
4660 RETURN;
79072805 4661}
85e6fe83 4662
c0329465
MB		 4663PP(pp_lock)
4664{
39644a26 4665 dSP;
c0329465 4666 dTOPss;
e55aaa0e 4667 SV *retsv = sv;
68795e93 4668 SvLOCK(sv);
e55aaa0e
MB		 4669 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4670 || SvTYPE(retsv) == SVt_PVCV) {
4671 retsv = refto(retsv);
4672 }
4673 SETs(retsv);
c0329465
MB		 4674 RETURN;
4675}
a863c7d1 4676
65bca31a
NC		 4677
4678PP(unimplemented_op)
4679{
4680 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4681 PL_op->op_type);
4682}
4683
e609e586
NC		 4684/*
4685 * Local variables:
4686 * c-indentation-style: bsd
4687 * c-basic-offset: 4
4688 * indent-tabs-mode: t
4689 * End:
4690 *
37442d52
RGS		 4691 * ex: set ts=8 sts=4 sw=4 noet:
4692 */
Unnamed repository; edit this file 'description' to name the repository.