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