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