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