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