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