This is my patch patch.1i for perl5.001.
[perl.git] / pp.c
1 /*    pp.c
2  *
3  *    Copyright (c) 1991-1994, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  */
9
10 /*
11  * "It's a big house this, and very peculiar.  Always a bit more to discover,
12  * and no knowing what you'll find around a corner.  And Elves, sir!" --Samwise
13  */
14
15 #include "EXTERN.h"
16 #include "perl.h"
17
18 static void doencodes _((SV *sv, char *s, I32 len));
19
20 /* variations on pp_null */
21
22 PP(pp_stub)
23 {
24     dSP;
25     if (GIMME != G_ARRAY) {
26         XPUSHs(&sv_undef);
27     }
28     RETURN;
29 }
30
31 PP(pp_scalar)
32 {
33     return NORMAL;
34 }
35
36 /* Pushy stuff. */
37
38 PP(pp_padav)
39 {
40     dSP; dTARGET;
41     if (op->op_private & OPpLVAL_INTRO)
42         SAVECLEARSV(curpad[op->op_targ]);
43     EXTEND(SP, 1);
44     if (op->op_flags & OPf_REF) {
45         PUSHs(TARG);
46         RETURN;
47     }
48     if (GIMME == G_ARRAY) {
49         I32 maxarg = AvFILL((AV*)TARG) + 1;
50         EXTEND(SP, maxarg);
51         Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
52         SP += maxarg;
53     }
54     else {
55         SV* sv = sv_newmortal();
56         I32 maxarg = AvFILL((AV*)TARG) + 1;
57         sv_setiv(sv, maxarg);
58         PUSHs(sv);
59     }
60     RETURN;
61 }
62
63 PP(pp_padhv)
64 {
65     dSP; dTARGET;
66     XPUSHs(TARG);
67     if (op->op_private & OPpLVAL_INTRO)
68         SAVECLEARSV(curpad[op->op_targ]);
69     if (op->op_flags & OPf_REF)
70         RETURN;
71     if (GIMME == G_ARRAY) { /* array wanted */
72         RETURNOP(do_kv(ARGS));
73     }
74     else {
75         SV* sv = sv_newmortal();
76         if (HvFILL((HV*)TARG)) {
77             sprintf(buf, "%d/%d", HvFILL((HV*)TARG), HvMAX((HV*)TARG)+1);
78             sv_setpv(sv, buf);
79         }
80         else
81             sv_setiv(sv, 0);
82         SETs(sv);
83         RETURN;
84     }
85 }
86
87 PP(pp_padany)
88 {
89     DIE("NOT IMPL LINE %d",__LINE__);
90 }
91
92 /* Translations. */
93
94 PP(pp_rv2gv)
95 {
96     dSP; dTOPss;
97     
98     if (SvROK(sv)) {
99       wasref:
100         sv = SvRV(sv);
101         if (SvTYPE(sv) != SVt_PVGV)
102             DIE("Not a GLOB reference");
103     }
104     else {
105         if (SvTYPE(sv) != SVt_PVGV) {
106             char *sym;
107
108             if (SvGMAGICAL(sv)) {
109                 mg_get(sv);
110                 if (SvROK(sv))
111                     goto wasref;
112             }
113             if (!SvOK(sv)) {
114                 if (op->op_flags & OPf_REF ||
115                     op->op_private & HINT_STRICT_REFS)
116                     DIE(no_usym, "a symbol");
117                 RETSETUNDEF;
118             }
119             sym = SvPV(sv, na);
120             if (op->op_private & HINT_STRICT_REFS)
121                 DIE(no_symref, sym, "a symbol");
122             sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
123         }
124     }
125     if (op->op_private & OPpLVAL_INTRO) {
126         GP *ogp = GvGP(sv);
127
128         SSCHECK(3);
129         SSPUSHPTR(sv);
130         SSPUSHPTR(ogp);
131         SSPUSHINT(SAVEt_GP);
132
133         if (op->op_flags & OPf_SPECIAL) {
134             GvGP(sv)->gp_refcnt++;              /* will soon be assigned */
135             GvFLAGS(sv) |= GVf_INTRO;
136         }
137         else {
138             GP *gp;
139             Newz(602,gp, 1, GP);
140             GvGP(sv) = gp;
141             GvREFCNT(sv) = 1;
142             GvSV(sv) = NEWSV(72,0);
143             GvLINE(sv) = curcop->cop_line;
144             GvEGV(sv) = sv;
145         }
146     }
147     SETs(sv);
148     RETURN;
149 }
150
151 PP(pp_sv2len)
152 {
153     dSP; dTARGET;
154     dPOPss;
155     PUSHi(sv_len(sv));
156     RETURN;
157 }
158
159 PP(pp_rv2sv)
160 {
161     dSP; dTOPss;
162
163     if (SvROK(sv)) {
164       wasref:
165         sv = SvRV(sv);
166         switch (SvTYPE(sv)) {
167         case SVt_PVAV:
168         case SVt_PVHV:
169         case SVt_PVCV:
170             DIE("Not a SCALAR reference");
171         }
172     }
173     else {
174         GV *gv = sv;
175         char *sym;
176
177         if (SvTYPE(gv) != SVt_PVGV) {
178             if (SvGMAGICAL(sv)) {
179                 mg_get(sv);
180                 if (SvROK(sv))
181                     goto wasref;
182             }
183             if (!SvOK(sv)) {
184                 if (op->op_flags & OPf_REF ||
185                     op->op_private & HINT_STRICT_REFS)
186                     DIE(no_usym, "a SCALAR");
187                 RETSETUNDEF;
188             }
189             sym = SvPV(sv, na);
190             if (op->op_private & HINT_STRICT_REFS)
191                 DIE(no_symref, sym, "a SCALAR");
192             gv = (SV*)gv_fetchpv(sym, TRUE, SVt_PV);
193         }
194         sv = GvSV(gv);
195     }
196     if (op->op_flags & OPf_MOD) {
197         if (op->op_private & OPpLVAL_INTRO)
198             sv = save_scalar((GV*)TOPs);
199         else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) {
200             if (SvGMAGICAL(sv))
201                 mg_get(sv);
202             if (!SvOK(sv)) {
203                 (void)SvUPGRADE(sv, SVt_RV);
204                 SvRV(sv) = (op->op_private & OPpDEREF_HV ?
205                             (SV*)newHV() : (SV*)newAV());
206                 SvROK_on(sv);
207                 SvSETMAGIC(sv);
208             }
209         }
210     }
211     SETs(sv);
212     RETURN;
213 }
214
215 PP(pp_av2arylen)
216 {
217     dSP;
218     AV *av = (AV*)TOPs;
219     SV *sv = AvARYLEN(av);
220     if (!sv) {
221         AvARYLEN(av) = sv = NEWSV(0,0);
222         sv_upgrade(sv, SVt_IV);
223         sv_magic(sv, (SV*)av, '#', Nullch, 0);
224     }
225     SETs(sv);
226     RETURN;
227 }
228
229 PP(pp_pos)
230 {
231     dSP; dTARGET; dPOPss;
232     
233     if (op->op_flags & OPf_MOD) {
234         LvTYPE(TARG) = '<';
235         LvTARG(TARG) = sv;
236         PUSHs(TARG);    /* no SvSETMAGIC */
237         RETURN;
238     }
239     else {
240         MAGIC* mg; 
241
242         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
243             mg = mg_find(sv, 'g');
244             if (mg && mg->mg_len >= 0) {
245                 PUSHi(mg->mg_len + curcop->cop_arybase);
246                 RETURN;
247             }
248         }
249         RETPUSHUNDEF;
250     }
251 }
252
253 PP(pp_rv2cv)
254 {
255     dSP;
256     GV *gv;
257     HV *stash;
258
259     /* We always try to add a non-existent subroutine in case of AUTOLOAD. */
260     CV *cv = sv_2cv(TOPs, &stash, &gv, TRUE);
261
262     SETs((SV*)cv);
263     RETURN;
264 }
265
266 PP(pp_anoncode)
267 {
268     dSP;
269     CV* cv = (CV*)cSVOP->op_sv;
270     EXTEND(SP,1);
271
272     if (SvFLAGS(cv) & SVpcv_CLONE) {
273         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
274     }
275
276     PUSHs((SV*)cv);
277     RETURN;
278 }
279
280 PP(pp_srefgen)
281 {
282     dSP; dTOPss;
283     SV* rv;
284     rv = sv_newmortal();
285     sv_upgrade(rv, SVt_RV);
286     if (SvPADTMP(sv))
287         sv = newSVsv(sv);
288     else {
289         SvTEMP_off(sv);
290         (void)SvREFCNT_inc(sv);
291     }
292     SvRV(rv) = sv;
293     SvROK_on(rv);
294     SETs(rv);
295     RETURN;
296
297
298 PP(pp_refgen)
299 {
300     dSP; dMARK;
301     SV* sv;
302     SV* rv;
303     if (GIMME != G_ARRAY) {
304         MARK[1] = *SP;
305         SP = MARK + 1;
306     }
307     while (MARK < SP) {
308         sv = *++MARK;
309         rv = sv_newmortal();
310         sv_upgrade(rv, SVt_RV);
311         if (SvPADTMP(sv))
312             sv = newSVsv(sv);
313         else {
314             SvTEMP_off(sv);
315             (void)SvREFCNT_inc(sv);
316         }
317         SvRV(rv) = sv;
318         SvROK_on(rv);
319         *MARK = rv;
320     }
321     RETURN;
322 }
323
324 PP(pp_ref)
325 {
326     dSP; dTARGET;
327     SV *sv;
328     char *pv;
329
330     sv = POPs;
331     if (!sv || !SvROK(sv))
332         RETPUSHUNDEF;
333
334     sv = SvRV(sv);
335     pv = sv_reftype(sv,TRUE);
336     PUSHp(pv, strlen(pv));
337     RETURN;
338 }
339
340 PP(pp_bless)
341 {
342     dSP;
343     HV *stash;
344
345     if (MAXARG == 1)
346         stash = curcop->cop_stash;
347     else
348         stash = gv_stashsv(POPs, TRUE);
349
350     (void)sv_bless(TOPs, stash);
351     RETURN;
352 }
353
354 /* Pattern matching */
355
356 PP(pp_study)
357 {
358     dSP; dTARGET;
359     register unsigned char *s;
360     register I32 pos;
361     register I32 ch;
362     register I32 *sfirst;
363     register I32 *snext;
364     I32 retval;
365     STRLEN len;
366
367     s = (unsigned char*)(SvPV(TARG, len));
368     pos = len;
369     if (lastscream)
370         SvSCREAM_off(lastscream);
371     lastscream = TARG;
372     if (pos <= 0) {
373         retval = 0;
374         goto ret;
375     }
376     if (pos > maxscream) {
377         if (maxscream < 0) {
378             maxscream = pos + 80;
379             New(301, screamfirst, 256, I32);
380             New(302, screamnext, maxscream, I32);
381         }
382         else {
383             maxscream = pos + pos / 4;
384             Renew(screamnext, maxscream, I32);
385         }
386     }
387
388     sfirst = screamfirst;
389     snext = screamnext;
390
391     if (!sfirst || !snext)
392         DIE("do_study: out of memory");
393
394     for (ch = 256; ch; --ch)
395         *sfirst++ = -1;
396     sfirst -= 256;
397
398     while (--pos >= 0) {
399         ch = s[pos];
400         if (sfirst[ch] >= 0)
401             snext[pos] = sfirst[ch] - pos;
402         else
403             snext[pos] = -pos;
404         sfirst[ch] = pos;
405
406         /* If there were any case insensitive searches, we must assume they
407          * all are.  This speeds up insensitive searches much more than
408          * it slows down sensitive ones.
409          */
410         if (sawi)
411             sfirst[fold[ch]] = pos;
412     }
413
414     SvSCREAM_on(TARG);
415     retval = 1;
416   ret:
417     XPUSHs(sv_2mortal(newSViv((I32)retval)));
418     RETURN;
419 }
420
421 PP(pp_trans)
422 {
423     dSP; dTARG;
424     SV *sv;
425
426     if (op->op_flags & OPf_STACKED)
427         sv = POPs;
428     else {
429         sv = GvSV(defgv);
430         EXTEND(SP,1);
431     }
432     TARG = sv_newmortal();
433     PUSHi(do_trans(sv, op));
434     RETURN;
435 }
436
437 /* Lvalue operators. */
438
439 PP(pp_schop)
440 {
441     dSP; dTARGET;
442     do_chop(TARG, TOPs);
443     SETTARG;
444     RETURN;
445 }
446
447 PP(pp_chop)
448 {
449     dSP; dMARK; dTARGET;
450     while (SP > MARK)
451         do_chop(TARG, POPs);
452     PUSHTARG;
453     RETURN;
454 }
455
456 PP(pp_schomp)
457 {
458     dSP; dTARGET;
459     SETi(do_chomp(TOPs));
460     RETURN;
461 }
462
463 PP(pp_chomp)
464 {
465     dSP; dMARK; dTARGET;
466     register I32 count = 0;
467     
468     while (SP > MARK)
469         count += do_chomp(POPs);
470     PUSHi(count);
471     RETURN;
472 }
473
474 PP(pp_defined)
475 {
476     dSP;
477     register SV* sv;
478
479     sv = POPs;
480     if (!sv || !SvANY(sv))
481         RETPUSHNO;
482     switch (SvTYPE(sv)) {
483     case SVt_PVAV:
484         if (AvMAX(sv) >= 0)
485             RETPUSHYES;
486         break;
487     case SVt_PVHV:
488         if (HvARRAY(sv))
489             RETPUSHYES;
490         break;
491     case SVt_PVCV:
492         if (CvROOT(sv) || CvXSUB(sv))
493             RETPUSHYES;
494         break;
495     default:
496         if (SvGMAGICAL(sv))
497             mg_get(sv);
498         if (SvOK(sv))
499             RETPUSHYES;
500     }
501     RETPUSHNO;
502 }
503
504 PP(pp_undef)
505 {
506     dSP;
507     SV *sv;
508
509     if (!op->op_private)
510         RETPUSHUNDEF;
511
512     sv = POPs;
513     if (!sv)
514         RETPUSHUNDEF;
515
516     if (SvTHINKFIRST(sv)) {
517         if (SvREADONLY(sv))
518             RETPUSHUNDEF;
519         if (SvROK(sv))
520             sv_unref(sv);
521     }
522
523     switch (SvTYPE(sv)) {
524     case SVt_NULL:
525         break;
526     case SVt_PVAV:
527         av_undef((AV*)sv);
528         break;
529     case SVt_PVHV:
530         hv_undef((HV*)sv);
531         break;
532     case SVt_PVCV:
533         cv_undef((CV*)sv);
534         sub_generation++;
535         break;
536     default:
537         if (sv != GvSV(defgv)) {
538             if (SvPOK(sv) && SvLEN(sv)) {
539                 (void)SvOOK_off(sv);
540                 Safefree(SvPVX(sv));
541                 SvPV_set(sv, Nullch);
542                 SvLEN_set(sv, 0);
543             }
544             (void)SvOK_off(sv);
545             SvSETMAGIC(sv);
546         }
547     }
548
549     RETPUSHUNDEF;
550 }
551
552 PP(pp_predec)
553 {
554     dSP;
555     if (SvIOK(TOPs)) {
556         --SvIVX(TOPs);
557         SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
558     }
559     else
560         sv_dec(TOPs);
561     SvSETMAGIC(TOPs);
562     return NORMAL;
563 }
564
565 PP(pp_postinc)
566 {
567     dSP; dTARGET;
568     sv_setsv(TARG, TOPs);
569     if (SvIOK(TOPs)) {
570         ++SvIVX(TOPs);
571         SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
572     }
573     else
574         sv_inc(TOPs);
575     SvSETMAGIC(TOPs);
576     if (!SvOK(TARG))
577         sv_setiv(TARG, 0);
578     SETs(TARG);
579     return NORMAL;
580 }
581
582 PP(pp_postdec)
583 {
584     dSP; dTARGET;
585     sv_setsv(TARG, TOPs);
586     if (SvIOK(TOPs)) {
587         --SvIVX(TOPs);
588         SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
589     }
590     else
591         sv_dec(TOPs);
592     SvSETMAGIC(TOPs);
593     SETs(TARG);
594     return NORMAL;
595 }
596
597 /* Ordinary operators. */
598
599 PP(pp_pow)
600 {
601     dSP; dATARGET; tryAMAGICbin(pow,opASSIGN); 
602     {
603       dPOPTOPnnrl;
604       SETn( pow( left, right) );
605       RETURN;
606     }
607 }
608
609 PP(pp_multiply)
610 {
611     dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); 
612     {
613       dPOPTOPnnrl;
614       SETn( left * right );
615       RETURN;
616     }
617 }
618
619 PP(pp_divide)
620 {
621     dSP; dATARGET; tryAMAGICbin(div,opASSIGN); 
622     {
623       dPOPnv;
624       if (value == 0.0)
625         DIE("Illegal division by zero");
626 #ifdef SLOPPYDIVIDE
627       /* insure that 20./5. == 4. */
628       {
629         double x;
630         I32    k;
631         x =  POPn;
632         if ((double)I_32(x)     == x &&
633             (double)I_32(value) == value &&
634             (k = I_32(x)/I_32(value))*I_32(value) == I_32(x)) {
635             value = k;
636         } else {
637             value = x/value;
638         }
639       }
640 #else
641       value = POPn / value;
642 #endif
643       PUSHn( value );
644       RETURN;
645     }
646 }
647
648 PP(pp_modulo)
649 {
650     dSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
651     {
652       register unsigned long tmpulong;
653       register long tmplong;
654       I32 value;
655
656       tmpulong = (unsigned long) POPn;
657       if (tmpulong == 0L)
658         DIE("Illegal modulus zero");
659       value = TOPn;
660       if (value >= 0.0)
661         value = (I32)(((unsigned long)value) % tmpulong);
662       else {
663         tmplong = (long)value;
664         value = (I32)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1;
665       }
666       SETi(value);
667       RETURN;
668     }
669 }
670
671 PP(pp_repeat)
672 {
673   dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
674   {
675     register I32 count = POPi;
676     if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
677         dMARK;
678         I32 items = SP - MARK;
679         I32 max;
680
681         max = items * count;
682         MEXTEND(MARK, max);
683         if (count > 1) {
684             while (SP > MARK) {
685                 if (*SP)
686                     SvTEMP_off((*SP));
687                 SP--;
688             }
689             MARK++;
690             repeatcpy((char*)(MARK + items), (char*)MARK,
691                 items * sizeof(SV*), count - 1);
692             SP += max;
693         }
694         else if (count <= 0)
695             SP -= items;
696     }
697     else {      /* Note: mark already snarfed by pp_list */
698         SV *tmpstr;
699         STRLEN len;
700
701         tmpstr = POPs;
702         if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
703             if (SvREADONLY(tmpstr) && curcop != &compiling)
704                 DIE("Can't x= to readonly value");
705             if (SvROK(tmpstr))
706                 sv_unref(tmpstr);
707         }
708         SvSetSV(TARG, tmpstr);
709         SvPV_force(TARG, len);
710         if (count >= 1) {
711             SvGROW(TARG, (count * len) + 1);
712             if (count > 1)
713                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
714             SvCUR(TARG) *= count;
715             *SvEND(TARG) = '\0';
716             (void)SvPOK_only(TARG);
717         }
718         else
719             sv_setsv(TARG, &sv_no);
720         PUSHTARG;
721     }
722     RETURN;
723   }
724 }
725
726 PP(pp_subtract)
727 {
728     dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); 
729     {
730       dPOPTOPnnrl;
731       SETn( left - right );
732       RETURN;
733     }
734 }
735
736 PP(pp_left_shift)
737 {
738     dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); 
739     {
740         dPOPTOPiirl;
741         SETi( left << right );
742         RETURN;
743     }
744 }
745
746 PP(pp_right_shift)
747 {
748     dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); 
749     {
750       dPOPTOPiirl;
751       SETi( left >> right );
752       RETURN;
753     }
754 }
755
756 PP(pp_lt)
757 {
758     dSP; tryAMAGICbinSET(lt,0); 
759     {
760       dPOPnv;
761       SETs((TOPn < value) ? &sv_yes : &sv_no);
762       RETURN;
763     }
764 }
765
766 PP(pp_gt)
767 {
768     dSP; tryAMAGICbinSET(gt,0); 
769     {
770       dPOPnv;
771       SETs((TOPn > value) ? &sv_yes : &sv_no);
772       RETURN;
773     }
774 }
775
776 PP(pp_le)
777 {
778     dSP; tryAMAGICbinSET(le,0); 
779     {
780       dPOPnv;
781       SETs((TOPn <= value) ? &sv_yes : &sv_no);
782       RETURN;
783     }
784 }
785
786 PP(pp_ge)
787 {
788     dSP; tryAMAGICbinSET(ge,0); 
789     {
790       dPOPnv;
791       SETs((TOPn >= value) ? &sv_yes : &sv_no);
792       RETURN;
793     }
794 }
795
796 PP(pp_ne)
797 {
798     dSP; tryAMAGICbinSET(ne,0); 
799     {
800       dPOPnv;
801       SETs((TOPn != value) ? &sv_yes : &sv_no);
802       RETURN;
803     }
804 }
805
806 PP(pp_ncmp)
807 {
808     dSP; dTARGET; tryAMAGICbin(ncmp,0); 
809     {
810       dPOPTOPnnrl;
811       I32 value;
812
813       if (left > right)
814         value = 1;
815       else if (left < right)
816         value = -1;
817       else
818         value = 0;
819       SETi(value);
820       RETURN;
821     }
822 }
823
824 PP(pp_slt)
825 {
826     dSP; tryAMAGICbinSET(slt,0); 
827     {
828       dPOPTOPssrl;
829       SETs( sv_cmp(left, right) < 0 ? &sv_yes : &sv_no );
830       RETURN;
831     }
832 }
833
834 PP(pp_sgt)
835 {
836     dSP; tryAMAGICbinSET(sgt,0); 
837     {
838       dPOPTOPssrl;
839       SETs( sv_cmp(left, right) > 0 ? &sv_yes : &sv_no );
840       RETURN;
841     }
842 }
843
844 PP(pp_sle)
845 {
846     dSP; tryAMAGICbinSET(sle,0); 
847     {
848       dPOPTOPssrl;
849       SETs( sv_cmp(left, right) <= 0 ? &sv_yes : &sv_no );
850       RETURN;
851     }
852 }
853
854 PP(pp_sge)
855 {
856     dSP; tryAMAGICbinSET(sge,0); 
857     {
858       dPOPTOPssrl;
859       SETs( sv_cmp(left, right) >= 0 ? &sv_yes : &sv_no );
860       RETURN;
861     }
862 }
863
864 PP(pp_sne)
865 {
866     dSP; tryAMAGICbinSET(sne,0); 
867     {
868       dPOPTOPssrl;
869       SETs( !sv_eq(left, right) ? &sv_yes : &sv_no );
870       RETURN;
871     }
872 }
873
874 PP(pp_scmp)
875 {
876     dSP; dTARGET;  tryAMAGICbin(scmp,0);
877     {
878       dPOPTOPssrl;
879       SETi( sv_cmp(left, right) );
880       RETURN;
881     }
882 }
883
884 PP(pp_bit_and) {
885     dSP; dATARGET; tryAMAGICbin(band,opASSIGN); 
886     {
887       dPOPTOPssrl;
888       if (SvNIOK(left) || SvNIOK(right)) {
889         unsigned long value = U_L(SvNV(left));
890         value = value & U_L(SvNV(right));
891         SETn((double)value);
892       }
893       else {
894         do_vop(op->op_type, TARG, left, right);
895         SETTARG;
896       }
897       RETURN;
898     }
899 }
900
901 PP(pp_bit_xor)
902 {
903     dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); 
904     {
905       dPOPTOPssrl;
906       if (SvNIOK(left) || SvNIOK(right)) {
907         unsigned long value = U_L(SvNV(left));
908         value = value ^ U_L(SvNV(right));
909         SETn((double)value);
910       }
911       else {
912         do_vop(op->op_type, TARG, left, right);
913         SETTARG;
914       }
915       RETURN;
916     }
917 }
918
919 PP(pp_bit_or)
920 {
921     dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); 
922     {
923       dPOPTOPssrl;
924       if (SvNIOK(left) || SvNIOK(right)) {
925         unsigned long value = U_L(SvNV(left));
926         value = value | U_L(SvNV(right));
927         SETn((double)value);
928       }
929       else {
930         do_vop(op->op_type, TARG, left, right);
931         SETTARG;
932       }
933       RETURN;
934     }
935 }
936
937 PP(pp_negate)
938 {
939     dSP; dTARGET; tryAMAGICun(neg);
940     {
941         dTOPss;
942         if (SvNIOK(sv))
943             SETn(-SvNV(sv));
944         else if (SvPOK(sv)) {
945             STRLEN len;
946             char *s = SvPV(sv, len);
947             if (isALPHA(*s) || *s == '_') {
948                 sv_setpvn(TARG, "-", 1);
949                 sv_catsv(TARG, sv);
950             }
951             else if (*s == '+' || *s == '-') {
952                 sv_setsv(TARG, sv);
953                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
954             }
955             else
956                 sv_setnv(TARG, -SvNV(sv));
957             SETTARG;
958         }
959     }
960     RETURN;
961 }
962
963 PP(pp_not)
964 {
965 #ifdef OVERLOAD
966     dSP; tryAMAGICunSET(not);
967 #endif /* OVERLOAD */
968     *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes;
969     return NORMAL;
970 }
971
972 PP(pp_complement)
973 {
974     dSP; dTARGET; tryAMAGICun(compl); 
975     {
976       dTOPss;
977       register I32 anum;
978
979       if (SvNIOK(sv)) {
980         IV iv = ~SvIV(sv);
981         if (iv < 0)
982             SETn( (double) ~U_L(SvNV(sv)) );
983         else
984             SETi( iv );
985       }
986       else {
987         register char *tmps;
988         register long *tmpl;
989         STRLEN len;
990
991         SvSetSV(TARG, sv);
992         tmps = SvPV_force(TARG, len);
993         anum = len;
994 #ifdef LIBERAL
995         for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
996             *tmps = ~*tmps;
997         tmpl = (long*)tmps;
998         for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
999             *tmpl = ~*tmpl;
1000         tmps = (char*)tmpl;
1001 #endif
1002         for ( ; anum > 0; anum--, tmps++)
1003             *tmps = ~*tmps;
1004
1005         SETs(TARG);
1006       }
1007       RETURN;
1008     }
1009 }
1010
1011 /* integer versions of some of the above */
1012
1013 PP(pp_i_multiply)
1014 {
1015     dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); 
1016     {
1017       dPOPTOPiirl;
1018       SETi( left * right );
1019       RETURN;
1020     }
1021 }
1022
1023 PP(pp_i_divide)
1024 {
1025     dSP; dATARGET; tryAMAGICbin(div,opASSIGN); 
1026     {
1027       dPOPiv;
1028       if (value == 0)
1029         DIE("Illegal division by zero");
1030       value = POPi / value;
1031       PUSHi( value );
1032       RETURN;
1033     }
1034 }
1035
1036 PP(pp_i_modulo)
1037 {
1038     dSP; dATARGET; tryAMAGICbin(mod,opASSIGN); 
1039     {
1040       dPOPTOPiirl;
1041       SETi( left % right );
1042       RETURN;
1043     }
1044 }
1045
1046 PP(pp_i_add)
1047 {
1048     dSP; dATARGET; tryAMAGICbin(add,opASSIGN); 
1049     {
1050       dPOPTOPiirl;
1051       SETi( left + right );
1052       RETURN;
1053     }
1054 }
1055
1056 PP(pp_i_subtract)
1057 {
1058     dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); 
1059     {
1060       dPOPTOPiirl;
1061       SETi( left - right );
1062       RETURN;
1063     }
1064 }
1065
1066 PP(pp_i_lt)
1067 {
1068     dSP; tryAMAGICbinSET(lt,0); 
1069     {
1070       dPOPTOPiirl;
1071       SETs((left < right) ? &sv_yes : &sv_no);
1072       RETURN;
1073     }
1074 }
1075
1076 PP(pp_i_gt)
1077 {
1078     dSP; tryAMAGICbinSET(gt,0); 
1079     {
1080       dPOPTOPiirl;
1081       SETs((left > right) ? &sv_yes : &sv_no);
1082       RETURN;
1083     }
1084 }
1085
1086 PP(pp_i_le)
1087 {
1088     dSP; tryAMAGICbinSET(le,0); 
1089     {
1090       dPOPTOPiirl;
1091       SETs((left <= right) ? &sv_yes : &sv_no);
1092       RETURN;
1093     }
1094 }
1095
1096 PP(pp_i_ge)
1097 {
1098     dSP; tryAMAGICbinSET(ge,0); 
1099     {
1100       dPOPTOPiirl;
1101       SETs((left >= right) ? &sv_yes : &sv_no);
1102       RETURN;
1103     }
1104 }
1105
1106 PP(pp_i_eq)
1107 {
1108     dSP; tryAMAGICbinSET(eq,0); 
1109     {
1110       dPOPTOPiirl;
1111       SETs((left == right) ? &sv_yes : &sv_no);
1112       RETURN;
1113     }
1114 }
1115
1116 PP(pp_i_ne)
1117 {
1118     dSP; tryAMAGICbinSET(ne,0); 
1119     {
1120       dPOPTOPiirl;
1121       SETs((left != right) ? &sv_yes : &sv_no);
1122       RETURN;
1123     }
1124 }
1125
1126 PP(pp_i_ncmp)
1127 {
1128     dSP; dTARGET; tryAMAGICbin(ncmp,0); 
1129     {
1130       dPOPTOPiirl;
1131       I32 value;
1132
1133       if (left > right)
1134         value = 1;
1135       else if (left < right)
1136         value = -1;
1137       else
1138         value = 0;
1139       SETi(value);
1140       RETURN;
1141     }
1142 }
1143
1144 PP(pp_i_negate)
1145 {
1146     dSP; dTARGET; tryAMAGICun(neg);
1147     SETi(-TOPi);
1148     RETURN;
1149 }
1150
1151 /* High falutin' math. */
1152
1153 PP(pp_atan2)
1154 {
1155     dSP; dTARGET; tryAMAGICbin(atan2,0); 
1156     {
1157       dPOPTOPnnrl;
1158       SETn(atan2(left, right));
1159       RETURN;
1160     }
1161 }
1162
1163 PP(pp_sin)
1164 {
1165     dSP; dTARGET; tryAMAGICun(sin);
1166     {
1167       double value;
1168       value = POPn;
1169       value = sin(value);
1170       XPUSHn(value);
1171       RETURN;
1172     }
1173 }
1174
1175 PP(pp_cos)
1176 {
1177     dSP; dTARGET; tryAMAGICun(cos);
1178     {
1179       double value;
1180       value = POPn;
1181       value = cos(value);
1182       XPUSHn(value);
1183       RETURN;
1184     }
1185 }
1186
1187 PP(pp_rand)
1188 {
1189     dSP; dTARGET;
1190     double value;
1191     if (MAXARG < 1)
1192         value = 1.0;
1193     else
1194         value = POPn;
1195     if (value == 0.0)
1196         value = 1.0;
1197 #if RANDBITS == 31
1198     value = rand() * value / 2147483648.0;
1199 #else
1200 #if RANDBITS == 16
1201     value = rand() * value / 65536.0;
1202 #else
1203 #if RANDBITS == 15
1204     value = rand() * value / 32768.0;
1205 #else
1206     value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
1207 #endif
1208 #endif
1209 #endif
1210     XPUSHn(value);
1211     RETURN;
1212 }
1213
1214 PP(pp_srand)
1215 {
1216     dSP;
1217     I32 anum;
1218     Time_t when;
1219
1220     if (MAXARG < 1) {
1221         (void)time(&when);
1222         anum = when;
1223     }
1224     else
1225         anum = POPi;
1226     (void)srand(anum);
1227     EXTEND(SP, 1);
1228     RETPUSHYES;
1229 }
1230
1231 PP(pp_exp)
1232 {
1233     dSP; dTARGET; tryAMAGICun(exp);
1234     {
1235       double value;
1236       value = POPn;
1237       value = exp(value);
1238       XPUSHn(value);
1239       RETURN;
1240     }
1241 }
1242
1243 PP(pp_log)
1244 {
1245     dSP; dTARGET; tryAMAGICun(log);
1246     {
1247       double value;
1248       value = POPn;
1249       if (value <= 0.0)
1250         DIE("Can't take log of %g", value);
1251       value = log(value);
1252       XPUSHn(value);
1253       RETURN;
1254     }
1255 }
1256
1257 PP(pp_sqrt)
1258 {
1259     dSP; dTARGET; tryAMAGICun(sqrt);
1260     {
1261       double value;
1262       value = POPn;
1263       if (value < 0.0)
1264         DIE("Can't take sqrt of %g", value);
1265       value = sqrt(value);
1266       XPUSHn(value);
1267       RETURN;
1268     }
1269 }
1270
1271 PP(pp_int)
1272 {
1273     dSP; dTARGET;
1274     double value;
1275     value = POPn;
1276     if (value >= 0.0)
1277         (void)modf(value, &value);
1278     else {
1279         (void)modf(-value, &value);
1280         value = -value;
1281     }
1282     XPUSHn(value);
1283     RETURN;
1284 }
1285
1286 PP(pp_abs)
1287 {
1288     dSP; dTARGET; tryAMAGICun(abs);
1289     {
1290       double value;
1291       value = POPn;
1292
1293       if (value < 0.0)
1294         value = -value;
1295
1296       XPUSHn(value);
1297       RETURN;
1298     }
1299 }
1300
1301 PP(pp_hex)
1302 {
1303     dSP; dTARGET;
1304     char *tmps;
1305     I32 argtype;
1306
1307     tmps = POPp;
1308     XPUSHi( scan_hex(tmps, 99, &argtype) );
1309     RETURN;
1310 }
1311
1312 PP(pp_oct)
1313 {
1314     dSP; dTARGET;
1315     I32 value;
1316     I32 argtype;
1317     char *tmps;
1318
1319     tmps = POPp;
1320     while (*tmps && (isSPACE(*tmps) || *tmps == '0'))
1321         tmps++;
1322     if (*tmps == 'x')
1323         value = (I32)scan_hex(++tmps, 99, &argtype);
1324     else
1325         value = (I32)scan_oct(tmps, 99, &argtype);
1326     XPUSHi(value);
1327     RETURN;
1328 }
1329
1330 /* String stuff. */
1331
1332 PP(pp_length)
1333 {
1334     dSP; dTARGET;
1335     SETi( sv_len(TOPs) );
1336     RETURN;
1337 }
1338
1339 PP(pp_substr)
1340 {
1341     dSP; dTARGET;
1342     SV *sv;
1343     I32 len;
1344     STRLEN curlen;
1345     I32 pos;
1346     I32 rem;
1347     I32 lvalue = op->op_flags & OPf_MOD;
1348     char *tmps;
1349     I32 arybase = curcop->cop_arybase;
1350
1351     if (MAXARG > 2)
1352         len = POPi;
1353     pos = POPi - arybase;
1354     sv = POPs;
1355     tmps = SvPV(sv, curlen);
1356     if (pos < 0)
1357         pos += curlen + arybase;
1358     if (pos < 0 || pos > curlen) {
1359         if (dowarn || lvalue)
1360             warn("substr outside of string");
1361         RETPUSHUNDEF;
1362     }
1363     else {
1364         if (MAXARG < 3)
1365             len = curlen;
1366         else if (len < 0) {
1367             len += curlen - pos;
1368             if (len < 0)
1369                 len = 0;
1370         }
1371         tmps += pos;
1372         rem = curlen - pos;     /* rem=how many bytes left*/
1373         if (rem > len)
1374             rem = len;
1375         sv_setpvn(TARG, tmps, rem);
1376         if (lvalue) {                   /* it's an lvalue! */
1377             (void)SvPOK_only(sv);
1378             if (SvTYPE(TARG) < SVt_PVLV) {
1379                 sv_upgrade(TARG, SVt_PVLV);
1380                 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1381             }
1382
1383             LvTYPE(TARG) = 's';
1384             LvTARG(TARG) = sv;
1385             LvTARGOFF(TARG) = pos;
1386             LvTARGLEN(TARG) = rem; 
1387         }
1388     }
1389     PUSHs(TARG);                /* avoid SvSETMAGIC here */
1390     RETURN;
1391 }
1392
1393 PP(pp_vec)
1394 {
1395     dSP; dTARGET;
1396     register I32 size = POPi;
1397     register I32 offset = POPi;
1398     register SV *src = POPs;
1399     I32 lvalue = op->op_flags & OPf_MOD;
1400     STRLEN srclen;
1401     unsigned char *s = (unsigned char*)SvPV(src, srclen);
1402     unsigned long retnum;
1403     I32 len;
1404
1405     offset *= size;             /* turn into bit offset */
1406     len = (offset + size + 7) / 8;
1407     if (offset < 0 || size < 1)
1408         retnum = 0;
1409     else {
1410         if (lvalue) {                      /* it's an lvalue! */
1411             if (SvTYPE(TARG) < SVt_PVLV) {
1412                 sv_upgrade(TARG, SVt_PVLV);
1413                 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1414             }
1415
1416             LvTYPE(TARG) = 'v';
1417             LvTARG(TARG) = src;
1418             LvTARGOFF(TARG) = offset; 
1419             LvTARGLEN(TARG) = size; 
1420         }
1421         if (len > srclen) {
1422             if (size <= 8)
1423                 retnum = 0;
1424             else {
1425                 offset >>= 3;
1426                 if (size == 16) {
1427                     if (offset >= srclen)
1428                         retnum = 0;
1429                     else
1430                         retnum = (unsigned long) s[offset] << 8;
1431                 }
1432                 else if (size == 32) {
1433                     if (offset >= srclen)
1434                         retnum = 0;
1435                     else if (offset + 1 >= srclen)
1436                         retnum = (unsigned long) s[offset] << 24;
1437                     else if (offset + 2 >= srclen)
1438                         retnum = ((unsigned long) s[offset] << 24) +
1439                             ((unsigned long) s[offset + 1] << 16);
1440                     else
1441                         retnum = ((unsigned long) s[offset] << 24) +
1442                             ((unsigned long) s[offset + 1] << 16) +
1443                             (s[offset + 2] << 8);
1444                 }
1445             }
1446         }
1447         else if (size < 8)
1448             retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1449         else {
1450             offset >>= 3;
1451             if (size == 8)
1452                 retnum = s[offset];
1453             else if (size == 16)
1454                 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1455             else if (size == 32)
1456                 retnum = ((unsigned long) s[offset] << 24) +
1457                         ((unsigned long) s[offset + 1] << 16) +
1458                         (s[offset + 2] << 8) + s[offset+3];
1459         }
1460     }
1461
1462     sv_setiv(TARG, (I32)retnum);
1463     PUSHs(TARG);
1464     RETURN;
1465 }
1466
1467 PP(pp_index)
1468 {
1469     dSP; dTARGET;
1470     SV *big;
1471     SV *little;
1472     I32 offset;
1473     I32 retval;
1474     char *tmps;
1475     char *tmps2;
1476     STRLEN biglen;
1477     I32 arybase = curcop->cop_arybase;
1478
1479     if (MAXARG < 3)
1480         offset = 0;
1481     else
1482         offset = POPi - arybase;
1483     little = POPs;
1484     big = POPs;
1485     tmps = SvPV(big, biglen);
1486     if (offset < 0)
1487         offset = 0;
1488     else if (offset > biglen)
1489         offset = biglen;
1490     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
1491       (unsigned char*)tmps + biglen, little)))
1492         retval = -1 + arybase;
1493     else
1494         retval = tmps2 - tmps + arybase;
1495     PUSHi(retval);
1496     RETURN;
1497 }
1498
1499 PP(pp_rindex)
1500 {
1501     dSP; dTARGET;
1502     SV *big;
1503     SV *little;
1504     STRLEN blen;
1505     STRLEN llen;
1506     SV *offstr;
1507     I32 offset;
1508     I32 retval;
1509     char *tmps;
1510     char *tmps2;
1511     I32 arybase = curcop->cop_arybase;
1512
1513     if (MAXARG >= 3)
1514         offstr = POPs;
1515     little = POPs;
1516     big = POPs;
1517     tmps2 = SvPV(little, llen);
1518     tmps = SvPV(big, blen);
1519     if (MAXARG < 3)
1520         offset = blen;
1521     else
1522         offset = SvIV(offstr) - arybase + llen;
1523     if (offset < 0)
1524         offset = 0;
1525     else if (offset > blen)
1526         offset = blen;
1527     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
1528                           tmps2, tmps2 + llen)))
1529         retval = -1 + arybase;
1530     else
1531         retval = tmps2 - tmps + arybase;
1532     PUSHi(retval);
1533     RETURN;
1534 }
1535
1536 PP(pp_sprintf)
1537 {
1538     dSP; dMARK; dORIGMARK; dTARGET;
1539     do_sprintf(TARG, SP-MARK, MARK+1);
1540     SP = ORIGMARK;
1541     PUSHTARG;
1542     RETURN;
1543 }
1544
1545 PP(pp_ord)
1546 {
1547     dSP; dTARGET;
1548     I32 value;
1549     char *tmps;
1550
1551 #ifndef I286
1552     tmps = POPp;
1553     value = (I32) (*tmps & 255);
1554 #else
1555     I32 anum;
1556     tmps = POPp;
1557     anum = (I32) *tmps;
1558     value = (I32) (anum & 255);
1559 #endif
1560     XPUSHi(value);
1561     RETURN;
1562 }
1563
1564 PP(pp_chr)
1565 {
1566     dSP; dTARGET;
1567     char *tmps;
1568
1569     (void)SvUPGRADE(TARG,SVt_PV);
1570     SvGROW(TARG,2);
1571     SvCUR_set(TARG, 1);
1572     tmps = SvPVX(TARG);
1573     *tmps++ = POPi;
1574     *tmps = '\0';
1575     (void)SvPOK_only(TARG);
1576     XPUSHs(TARG);
1577     RETURN;
1578 }
1579
1580 PP(pp_crypt)
1581 {
1582     dSP; dTARGET; dPOPTOPssrl;
1583 #ifdef HAS_CRYPT
1584     char *tmps = SvPV(left, na);
1585 #ifdef FCRYPT
1586     sv_setpv(TARG, fcrypt(tmps, SvPV(right, na)));
1587 #else
1588     sv_setpv(TARG, crypt(tmps, SvPV(right, na)));
1589 #endif
1590 #else
1591     DIE(
1592       "The crypt() function is unimplemented due to excessive paranoia.");
1593 #endif
1594     SETs(TARG);
1595     RETURN;
1596 }
1597
1598 PP(pp_ucfirst)
1599 {
1600     dSP;
1601     SV *sv = TOPs;
1602     register char *s;
1603
1604     if (!SvPADTMP(sv)) {
1605         dTARGET;
1606         sv_setsv(TARG, sv);
1607         sv = TARG;
1608         SETs(sv);
1609     }
1610     s = SvPV_force(sv, na);
1611     if (isLOWER(*s))
1612         *s = toUPPER(*s);
1613
1614     RETURN;
1615 }
1616
1617 PP(pp_lcfirst)
1618 {
1619     dSP;
1620     SV *sv = TOPs;
1621     register char *s;
1622
1623     if (!SvPADTMP(sv)) {
1624         dTARGET;
1625         sv_setsv(TARG, sv);
1626         sv = TARG;
1627         SETs(sv);
1628     }
1629     s = SvPV_force(sv, na);
1630     if (isUPPER(*s))
1631         *s = toLOWER(*s);
1632
1633     SETs(sv);
1634     RETURN;
1635 }
1636
1637 PP(pp_uc)
1638 {
1639     dSP;
1640     SV *sv = TOPs;
1641     register char *s;
1642     register char *send;
1643     STRLEN len;
1644
1645     if (!SvPADTMP(sv)) {
1646         dTARGET;
1647         sv_setsv(TARG, sv);
1648         sv = TARG;
1649         SETs(sv);
1650     }
1651     s = SvPV_force(sv, len);
1652     send = s + len;
1653     while (s < send) {
1654         if (isLOWER(*s))
1655             *s = toUPPER(*s);
1656         s++;
1657     }
1658     RETURN;
1659 }
1660
1661 PP(pp_lc)
1662 {
1663     dSP;
1664     SV *sv = TOPs;
1665     register char *s;
1666     register char *send;
1667     STRLEN len;
1668
1669     if (!SvPADTMP(sv)) {
1670         dTARGET;
1671         sv_setsv(TARG, sv);
1672         sv = TARG;
1673         SETs(sv);
1674     }
1675     s = SvPV_force(sv, len);
1676     send = s + len;
1677     while (s < send) {
1678         if (isUPPER(*s))
1679             *s = toLOWER(*s);
1680         s++;
1681     }
1682     RETURN;
1683 }
1684
1685 PP(pp_quotemeta)
1686 {
1687     dSP; dTARGET;
1688     SV *sv = TOPs;
1689     STRLEN len;
1690     register char *s = SvPV(sv,len);
1691     register char *d;
1692
1693     if (len) {
1694         (void)SvUPGRADE(TARG, SVt_PV);
1695         SvGROW(TARG, len * 2);
1696         d = SvPVX(TARG);
1697         while (len--) {
1698             if (!isALNUM(*s))
1699                 *d++ = '\\';
1700             *d++ = *s++;
1701         }
1702         *d = '\0';
1703         SvCUR_set(TARG, d - SvPVX(TARG));
1704         (void)SvPOK_only(TARG);
1705     }
1706     else
1707         sv_setpvn(TARG, s, len);
1708     SETs(TARG);
1709     RETURN;
1710 }
1711
1712 /* Arrays. */
1713
1714 PP(pp_aslice)
1715 {
1716     dSP; dMARK; dORIGMARK;
1717     register SV** svp;
1718     register AV* av = (AV*)POPs;
1719     register I32 lval = op->op_flags & OPf_MOD;
1720     I32 arybase = curcop->cop_arybase;
1721     I32 elem;
1722
1723     if (SvTYPE(av) == SVt_PVAV) {
1724         if (lval && op->op_private & OPpLVAL_INTRO) {
1725             I32 max = -1;
1726             for (svp = mark + 1; svp <= sp; svp++) {
1727                 elem = SvIVx(*svp);
1728                 if (elem > max)
1729                     max = elem;
1730             }
1731             if (max > AvMAX(av))
1732                 av_extend(av, max);
1733         }
1734         while (++MARK <= SP) {
1735             elem = SvIVx(*MARK);
1736
1737             if (elem > 0)
1738                 elem -= arybase;
1739             svp = av_fetch(av, elem, lval);
1740             if (lval) {
1741                 if (!svp || *svp == &sv_undef)
1742                     DIE(no_aelem, elem);
1743                 if (op->op_private & OPpLVAL_INTRO)
1744                     save_svref(svp);
1745             }
1746             *MARK = svp ? *svp : &sv_undef;
1747         }
1748     }
1749     if (GIMME != G_ARRAY) {
1750         MARK = ORIGMARK;
1751         *++MARK = *SP;
1752         SP = MARK;
1753     }
1754     RETURN;
1755 }
1756
1757 /* Associative arrays. */
1758
1759 PP(pp_each)
1760 {
1761     dSP; dTARGET;
1762     HV *hash = (HV*)POPs;
1763     HE *entry = hv_iternext(hash);
1764     I32 i;
1765     char *tmps;
1766
1767     EXTEND(SP, 2);
1768     if (entry) {
1769         tmps = hv_iterkey(entry, &i);
1770         if (!i)
1771             tmps = "";
1772         PUSHs(sv_2mortal(newSVpv(tmps, i)));
1773         if (GIMME == G_ARRAY) {
1774             sv_setsv(TARG, hv_iterval(hash, entry));
1775             PUSHs(TARG);
1776         }
1777     }
1778     else if (GIMME == G_SCALAR)
1779         RETPUSHUNDEF;
1780
1781     RETURN;
1782 }
1783
1784 PP(pp_values)
1785 {
1786     return do_kv(ARGS);
1787 }
1788
1789 PP(pp_keys)
1790 {
1791     return do_kv(ARGS);
1792 }
1793
1794 PP(pp_delete)
1795 {
1796     dSP;
1797     SV *sv;
1798     SV *tmpsv = POPs;
1799     HV *hv = (HV*)POPs;
1800     char *tmps;
1801     STRLEN len;
1802     if (SvTYPE(hv) != SVt_PVHV) {
1803         DIE("Not a HASH reference");
1804     }
1805     tmps = SvPV(tmpsv, len);
1806     sv = hv_delete(hv, tmps, len,
1807         op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0);
1808     if (!sv)
1809         RETPUSHUNDEF;
1810     PUSHs(sv);
1811     RETURN;
1812 }
1813
1814 PP(pp_exists)
1815 {
1816     dSP;
1817     SV *tmpsv = POPs;
1818     HV *hv = (HV*)POPs;
1819     char *tmps;
1820     STRLEN len;
1821     if (SvTYPE(hv) != SVt_PVHV) {
1822         DIE("Not a HASH reference");
1823     }
1824     tmps = SvPV(tmpsv, len);
1825     if (hv_exists(hv, tmps, len))
1826         RETPUSHYES;
1827     RETPUSHNO;
1828 }
1829
1830 PP(pp_hslice)
1831 {
1832     dSP; dMARK; dORIGMARK;
1833     register SV **svp;
1834     register HV *hv = (HV*)POPs;
1835     register I32 lval = op->op_flags & OPf_MOD;
1836
1837     if (SvTYPE(hv) == SVt_PVHV) {
1838         while (++MARK <= SP) {
1839             STRLEN keylen;
1840             char *key = SvPV(*MARK, keylen);
1841
1842             svp = hv_fetch(hv, key, keylen, lval);
1843             if (lval) {
1844                 if (!svp || *svp == &sv_undef)
1845                     DIE(no_helem, key);
1846                 if (op->op_private & OPpLVAL_INTRO)
1847                     save_svref(svp);
1848             }
1849             *MARK = svp ? *svp : &sv_undef;
1850         }
1851     }
1852     if (GIMME != G_ARRAY) {
1853         MARK = ORIGMARK;
1854         *++MARK = *SP;
1855         SP = MARK;
1856     }
1857     RETURN;
1858 }
1859
1860 /* List operators. */
1861
1862 PP(pp_list)
1863 {
1864     dSP; dMARK;
1865     if (GIMME != G_ARRAY) {
1866         if (++MARK <= SP)
1867             *MARK = *SP;                /* unwanted list, return last item */
1868         else
1869             *MARK = &sv_undef;
1870         SP = MARK;
1871     }
1872     RETURN;
1873 }
1874
1875 PP(pp_lslice)
1876 {
1877     dSP;
1878     SV **lastrelem = stack_sp;
1879     SV **lastlelem = stack_base + POPMARK;
1880     SV **firstlelem = stack_base + POPMARK + 1;
1881     register SV **firstrelem = lastlelem + 1;
1882     I32 arybase = curcop->cop_arybase;
1883
1884     register I32 max = lastrelem - lastlelem;
1885     register SV **lelem;
1886     register I32 ix;
1887
1888     if (GIMME != G_ARRAY) {
1889         ix = SvIVx(*lastlelem);
1890         if (ix < 0)
1891             ix += max;
1892         else
1893             ix -= arybase;
1894         if (ix < 0 || ix >= max)
1895             *firstlelem = &sv_undef;
1896         else
1897             *firstlelem = firstrelem[ix];
1898         SP = firstlelem;
1899         RETURN;
1900     }
1901
1902     if (max == 0) {
1903         SP = firstlelem - 1;
1904         RETURN;
1905     }
1906
1907     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1908         ix = SvIVx(*lelem);
1909         if (ix < 0) {
1910             ix += max;
1911             if (ix < 0)
1912                 *lelem = &sv_undef;
1913             else if (!(*lelem = firstrelem[ix]))
1914                 *lelem = &sv_undef;
1915         }
1916         else {
1917             ix -= arybase;
1918             if (ix >= max || !(*lelem = firstrelem[ix]))
1919                 *lelem = &sv_undef;
1920         }
1921     }
1922     SP = lastlelem;
1923     RETURN;
1924 }
1925
1926 PP(pp_anonlist)
1927 {
1928     dSP; dMARK;
1929     I32 items = SP - MARK;
1930     SP = MARK;
1931     XPUSHs((SV*)sv_2mortal((SV*)av_make(items, MARK+1)));
1932     RETURN;
1933 }
1934
1935 PP(pp_anonhash)
1936 {
1937     dSP; dMARK; dORIGMARK;
1938     STRLEN len;
1939     HV* hv = (HV*)sv_2mortal((SV*)newHV());
1940
1941     while (MARK < SP) {
1942         SV* key = *++MARK;
1943         char *tmps;
1944         SV *val = NEWSV(46, 0);
1945         if (MARK < SP)
1946             sv_setsv(val, *++MARK);
1947         else
1948             warn("Odd number of elements in hash list");
1949         tmps = SvPV(key,len);
1950         (void)hv_store(hv,tmps,len,val,0);
1951     }
1952     SP = ORIGMARK;
1953     XPUSHs((SV*)hv);
1954     RETURN;
1955 }
1956
1957 PP(pp_splice)
1958 {
1959     dSP; dMARK; dORIGMARK;
1960     register AV *ary = (AV*)*++MARK;
1961     register SV **src;
1962     register SV **dst;
1963     register I32 i;
1964     register I32 offset;
1965     register I32 length;
1966     I32 newlen;
1967     I32 after;
1968     I32 diff;
1969     SV **tmparyval = 0;
1970
1971     SP++;
1972
1973     if (++MARK < SP) {
1974         offset = SvIVx(*MARK);
1975         if (offset < 0)
1976             offset += AvFILL(ary) + 1;
1977         else
1978             offset -= curcop->cop_arybase;
1979         if (++MARK < SP) {
1980             length = SvIVx(*MARK++);
1981             if (length < 0)
1982                 length = 0;
1983         }
1984         else
1985             length = AvMAX(ary) + 1;            /* close enough to infinity */
1986     }
1987     else {
1988         offset = 0;
1989         length = AvMAX(ary) + 1;
1990     }
1991     if (offset < 0) {
1992         length += offset;
1993         offset = 0;
1994         if (length < 0)
1995             length = 0;
1996     }
1997     if (offset > AvFILL(ary) + 1)
1998         offset = AvFILL(ary) + 1;
1999     after = AvFILL(ary) + 1 - (offset + length);
2000     if (after < 0) {                            /* not that much array */
2001         length += after;                        /* offset+length now in array */
2002         after = 0;
2003         if (!AvALLOC(ary))
2004             av_extend(ary, 0);
2005     }
2006
2007     /* At this point, MARK .. SP-1 is our new LIST */
2008
2009     newlen = SP - MARK;
2010     diff = newlen - length;
2011
2012     if (diff < 0) {                             /* shrinking the area */
2013         if (newlen) {
2014             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
2015             Copy(MARK, tmparyval, newlen, SV*);
2016         }
2017
2018         MARK = ORIGMARK + 1;
2019         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2020             MEXTEND(MARK, length);
2021             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2022             if (AvREAL(ary)) {
2023                 for (i = length, dst = MARK; i; i--)
2024                     sv_2mortal(*dst++); /* free them eventualy */
2025             }
2026             MARK += length - 1;
2027         }
2028         else {
2029             *MARK = AvARRAY(ary)[offset+length-1];
2030             if (AvREAL(ary)) {
2031                 sv_2mortal(*MARK);
2032                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2033                     SvREFCNT_dec(*dst++);       /* free them now */
2034             }
2035         }
2036         AvFILL(ary) += diff;
2037
2038         /* pull up or down? */
2039
2040         if (offset < after) {                   /* easier to pull up */
2041             if (offset) {                       /* esp. if nothing to pull */
2042                 src = &AvARRAY(ary)[offset-1];
2043                 dst = src - diff;               /* diff is negative */
2044                 for (i = offset; i > 0; i--)    /* can't trust Copy */
2045                     *dst-- = *src--;
2046             }
2047             dst = AvARRAY(ary);
2048             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2049             AvMAX(ary) += diff;
2050         }
2051         else {
2052             if (after) {                        /* anything to pull down? */
2053                 src = AvARRAY(ary) + offset + length;
2054                 dst = src + diff;               /* diff is negative */
2055                 Move(src, dst, after, SV*);
2056             }
2057             dst = &AvARRAY(ary)[AvFILL(ary)+1];
2058                                                 /* avoid later double free */
2059         }
2060         i = -diff;
2061         while (i)
2062             dst[--i] = &sv_undef;
2063         
2064         if (newlen) {
2065             for (src = tmparyval, dst = AvARRAY(ary) + offset;
2066               newlen; newlen--) {
2067                 *dst = NEWSV(46, 0);
2068                 sv_setsv(*dst++, *src++);
2069             }
2070             Safefree(tmparyval);
2071         }
2072     }
2073     else {                                      /* no, expanding (or same) */
2074         if (length) {
2075             New(452, tmparyval, length, SV*);   /* so remember deletion */
2076             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2077         }
2078
2079         if (diff > 0) {                         /* expanding */
2080
2081             /* push up or down? */
2082
2083             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2084                 if (offset) {
2085                     src = AvARRAY(ary);
2086                     dst = src - diff;
2087                     Move(src, dst, offset, SV*);
2088                 }
2089                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2090                 AvMAX(ary) += diff;
2091                 AvFILL(ary) += diff;
2092             }
2093             else {
2094                 if (AvFILL(ary) + diff >= AvMAX(ary))   /* oh, well */
2095                     av_extend(ary, AvFILL(ary) + diff);
2096                 AvFILL(ary) += diff;
2097
2098                 if (after) {
2099                     dst = AvARRAY(ary) + AvFILL(ary);
2100                     src = dst - diff;
2101                     for (i = after; i; i--) {
2102                         *dst-- = *src--;
2103                     }
2104                 }
2105             }
2106         }
2107
2108         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2109             *dst = NEWSV(46, 0);
2110             sv_setsv(*dst++, *src++);
2111         }
2112         MARK = ORIGMARK + 1;
2113         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2114             if (length) {
2115                 Copy(tmparyval, MARK, length, SV*);
2116                 if (AvREAL(ary)) {
2117                     for (i = length, dst = MARK; i; i--)
2118                         sv_2mortal(*dst++);     /* free them eventualy */
2119                 }
2120                 Safefree(tmparyval);
2121             }
2122             MARK += length - 1;
2123         }
2124         else if (length--) {
2125             *MARK = tmparyval[length];
2126             if (AvREAL(ary)) {
2127                 sv_2mortal(*MARK);
2128                 while (length-- > 0)
2129                     SvREFCNT_dec(tmparyval[length]);
2130             }
2131             Safefree(tmparyval);
2132         }
2133         else
2134             *MARK = &sv_undef;
2135     }
2136     SP = MARK;
2137     RETURN;
2138 }
2139
2140 PP(pp_push)
2141 {
2142     dSP; dMARK; dORIGMARK; dTARGET;
2143     register AV *ary = (AV*)*++MARK;
2144     register SV *sv = &sv_undef;
2145
2146     for (++MARK; MARK <= SP; MARK++) {
2147         sv = NEWSV(51, 0);
2148         if (*MARK)
2149             sv_setsv(sv, *MARK);
2150         av_push(ary, sv);
2151     }
2152     SP = ORIGMARK;
2153     PUSHi( AvFILL(ary) + 1 );
2154     RETURN;
2155 }
2156
2157 PP(pp_pop)
2158 {
2159     dSP;
2160     AV *av = (AV*)POPs;
2161     SV *sv = av_pop(av);
2162     if (sv != &sv_undef && AvREAL(av))
2163         (void)sv_2mortal(sv);
2164     PUSHs(sv);
2165     RETURN;
2166 }
2167
2168 PP(pp_shift)
2169 {
2170     dSP;
2171     AV *av = (AV*)POPs;
2172     SV *sv = av_shift(av);
2173     EXTEND(SP, 1);
2174     if (!sv)
2175         RETPUSHUNDEF;
2176     if (sv != &sv_undef && AvREAL(av))
2177         (void)sv_2mortal(sv);
2178     PUSHs(sv);
2179     RETURN;
2180 }
2181
2182 PP(pp_unshift)
2183 {
2184     dSP; dMARK; dORIGMARK; dTARGET;
2185     register AV *ary = (AV*)*++MARK;
2186     register SV *sv;
2187     register I32 i = 0;
2188
2189     av_unshift(ary, SP - MARK);
2190     while (MARK < SP) {
2191         sv = NEWSV(27, 0);
2192         sv_setsv(sv, *++MARK);
2193         (void)av_store(ary, i++, sv);
2194     }
2195
2196     SP = ORIGMARK;
2197     PUSHi( AvFILL(ary) + 1 );
2198     RETURN;
2199 }
2200
2201 PP(pp_reverse)
2202 {
2203     dSP; dMARK;
2204     register SV *tmp;
2205     SV **oldsp = SP;
2206
2207     if (GIMME == G_ARRAY) {
2208         MARK++;
2209         while (MARK < SP) {
2210             tmp = *MARK;
2211             *MARK++ = *SP;
2212             *SP-- = tmp;
2213         }
2214         SP = oldsp;
2215     }
2216     else {
2217         register char *up;
2218         register char *down;
2219         register I32 tmp;
2220         dTARGET;
2221         STRLEN len;
2222
2223         if (SP - MARK > 1)
2224             do_join(TARG, &sv_no, MARK, SP);
2225         else
2226             sv_setsv(TARG, *SP);
2227         up = SvPV_force(TARG, len);
2228         if (len > 1) {
2229             down = SvPVX(TARG) + len - 1;
2230             while (down > up) {
2231                 tmp = *up;
2232                 *up++ = *down;
2233                 *down-- = tmp;
2234             }
2235             (void)SvPOK_only(TARG);
2236         }
2237         SP = MARK + 1;
2238         SETTARG;
2239     }
2240     RETURN;
2241 }
2242
2243 /* Explosives and implosives. */
2244
2245 PP(pp_unpack)
2246 {
2247     dSP;
2248     dPOPPOPssrl;
2249     SV *sv;
2250     STRLEN llen;
2251     STRLEN rlen;
2252     register char *pat = SvPV(left, llen);
2253     register char *s = SvPV(right, rlen);
2254     char *strend = s + rlen;
2255     char *strbeg = s;
2256     register char *patend = pat + llen;
2257     I32 datumtype;
2258     register I32 len;
2259     register I32 bits;
2260
2261     /* These must not be in registers: */
2262     I16 ashort;
2263     int aint;
2264     I32 along;
2265 #ifdef HAS_QUAD
2266     Quad_t aquad;
2267 #endif
2268     U16 aushort;
2269     unsigned int auint;
2270     U32 aulong;
2271 #ifdef HAS_QUAD
2272     unsigned Quad_t auquad;
2273 #endif
2274     char *aptr;
2275     float afloat;
2276     double adouble;
2277     I32 checksum = 0;
2278     register U32 culong;
2279     double cdouble;
2280     static char* bitcount = 0;
2281
2282     if (GIMME != G_ARRAY) {             /* arrange to do first one only */
2283         /*SUPPRESS 530*/
2284         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
2285         if (strchr("aAbBhHP", *patend) || *pat == '%') {
2286             patend++;
2287             while (isDIGIT(*patend) || *patend == '*')
2288                 patend++;
2289         }
2290         else
2291             patend++;
2292     }
2293     while (pat < patend) {
2294       reparse:
2295         datumtype = *pat++;
2296         if (pat >= patend)
2297             len = 1;
2298         else if (*pat == '*') {
2299             len = strend - strbeg;      /* long enough */
2300             pat++;
2301         }
2302         else if (isDIGIT(*pat)) {
2303             len = *pat++ - '0';
2304             while (isDIGIT(*pat))
2305                 len = (len * 10) + (*pat++ - '0');
2306         }
2307         else
2308             len = (datumtype != '@');
2309         switch(datumtype) {
2310         default:
2311             break;
2312         case '%':
2313             if (len == 1 && pat[-1] != '1')
2314                 len = 16;
2315             checksum = len;
2316             culong = 0;
2317             cdouble = 0;
2318             if (pat < patend)
2319                 goto reparse;
2320             break;
2321         case '@':
2322             if (len > strend - strbeg)
2323                 DIE("@ outside of string");
2324             s = strbeg + len;
2325             break;
2326         case 'X':
2327             if (len > s - strbeg)
2328                 DIE("X outside of string");
2329             s -= len;
2330             break;
2331         case 'x':
2332             if (len > strend - s)
2333                 DIE("x outside of string");
2334             s += len;
2335             break;
2336         case 'A':
2337         case 'a':
2338             if (len > strend - s)
2339                 len = strend - s;
2340             if (checksum)
2341                 goto uchar_checksum;
2342             sv = NEWSV(35, len);
2343             sv_setpvn(sv, s, len);
2344             s += len;
2345             if (datumtype == 'A') {
2346                 aptr = s;       /* borrow register */
2347                 s = SvPVX(sv) + len - 1;
2348                 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
2349                     s--;
2350                 *++s = '\0';
2351                 SvCUR_set(sv, s - SvPVX(sv));
2352                 s = aptr;       /* unborrow register */
2353             }
2354             XPUSHs(sv_2mortal(sv));
2355             break;
2356         case 'B':
2357         case 'b':
2358             if (pat[-1] == '*' || len > (strend - s) * 8)
2359                 len = (strend - s) * 8;
2360             if (checksum) {
2361                 if (!bitcount) {
2362                     Newz(601, bitcount, 256, char);
2363                     for (bits = 1; bits < 256; bits++) {
2364                         if (bits & 1)   bitcount[bits]++;
2365                         if (bits & 2)   bitcount[bits]++;
2366                         if (bits & 4)   bitcount[bits]++;
2367                         if (bits & 8)   bitcount[bits]++;
2368                         if (bits & 16)  bitcount[bits]++;
2369                         if (bits & 32)  bitcount[bits]++;
2370                         if (bits & 64)  bitcount[bits]++;
2371                         if (bits & 128) bitcount[bits]++;
2372                     }
2373                 }
2374                 while (len >= 8) {
2375                     culong += bitcount[*(unsigned char*)s++];
2376                     len -= 8;
2377                 }
2378                 if (len) {
2379                     bits = *s;
2380                     if (datumtype == 'b') {
2381                         while (len-- > 0) {
2382                             if (bits & 1) culong++;
2383                             bits >>= 1;
2384                         }
2385                     }
2386                     else {
2387                         while (len-- > 0) {
2388                             if (bits & 128) culong++;
2389                             bits <<= 1;
2390                         }
2391                     }
2392                 }
2393                 break;
2394             }
2395             sv = NEWSV(35, len + 1);
2396             SvCUR_set(sv, len);
2397             SvPOK_on(sv);
2398             aptr = pat;                 /* borrow register */
2399             pat = SvPVX(sv);
2400             if (datumtype == 'b') {
2401                 aint = len;
2402                 for (len = 0; len < aint; len++) {
2403                     if (len & 7)                /*SUPPRESS 595*/
2404                         bits >>= 1;
2405                     else
2406                         bits = *s++;
2407                     *pat++ = '0' + (bits & 1);
2408                 }
2409             }
2410             else {
2411                 aint = len;
2412                 for (len = 0; len < aint; len++) {
2413                     if (len & 7)
2414                         bits <<= 1;
2415                     else
2416                         bits = *s++;
2417                     *pat++ = '0' + ((bits & 128) != 0);
2418                 }
2419             }
2420             *pat = '\0';
2421             pat = aptr;                 /* unborrow register */
2422             XPUSHs(sv_2mortal(sv));
2423             break;
2424         case 'H':
2425         case 'h':
2426             if (pat[-1] == '*' || len > (strend - s) * 2)
2427                 len = (strend - s) * 2;
2428             sv = NEWSV(35, len + 1);
2429             SvCUR_set(sv, len);
2430             SvPOK_on(sv);
2431             aptr = pat;                 /* borrow register */
2432             pat = SvPVX(sv);
2433             if (datumtype == 'h') {
2434                 aint = len;
2435                 for (len = 0; len < aint; len++) {
2436                     if (len & 1)
2437                         bits >>= 4;
2438                     else
2439                         bits = *s++;
2440                     *pat++ = hexdigit[bits & 15];
2441                 }
2442             }
2443             else {
2444                 aint = len;
2445                 for (len = 0; len < aint; len++) {
2446                     if (len & 1)
2447                         bits <<= 4;
2448                     else
2449                         bits = *s++;
2450                     *pat++ = hexdigit[(bits >> 4) & 15];
2451                 }
2452             }
2453             *pat = '\0';
2454             pat = aptr;                 /* unborrow register */
2455             XPUSHs(sv_2mortal(sv));
2456             break;
2457         case 'c':
2458             if (len > strend - s)
2459                 len = strend - s;
2460             if (checksum) {
2461                 while (len-- > 0) {
2462                     aint = *s++;
2463                     if (aint >= 128)    /* fake up signed chars */
2464                         aint -= 256;
2465                     culong += aint;
2466                 }
2467             }
2468             else {
2469                 EXTEND(SP, len);
2470                 while (len-- > 0) {
2471                     aint = *s++;
2472                     if (aint >= 128)    /* fake up signed chars */
2473                         aint -= 256;
2474                     sv = NEWSV(36, 0);
2475                     sv_setiv(sv, (I32)aint);
2476                     PUSHs(sv_2mortal(sv));
2477                 }
2478             }
2479             break;
2480         case 'C':
2481             if (len > strend - s)
2482                 len = strend - s;
2483             if (checksum) {
2484               uchar_checksum:
2485                 while (len-- > 0) {
2486                     auint = *s++ & 255;
2487                     culong += auint;
2488                 }
2489             }
2490             else {
2491                 EXTEND(SP, len);
2492                 while (len-- > 0) {
2493                     auint = *s++ & 255;
2494                     sv = NEWSV(37, 0);
2495                     sv_setiv(sv, (I32)auint);
2496                     PUSHs(sv_2mortal(sv));
2497                 }
2498             }
2499             break;
2500         case 's':
2501             along = (strend - s) / sizeof(I16);
2502             if (len > along)
2503                 len = along;
2504             if (checksum) {
2505                 while (len-- > 0) {
2506                     Copy(s, &ashort, 1, I16);
2507                     s += sizeof(I16);
2508                     culong += ashort;
2509                 }
2510             }
2511             else {
2512                 EXTEND(SP, len);
2513                 while (len-- > 0) {
2514                     Copy(s, &ashort, 1, I16);
2515                     s += sizeof(I16);
2516                     sv = NEWSV(38, 0);
2517                     sv_setiv(sv, (I32)ashort);
2518                     PUSHs(sv_2mortal(sv));
2519                 }
2520             }
2521             break;
2522         case 'v':
2523         case 'n':
2524         case 'S':
2525             along = (strend - s) / sizeof(U16);
2526             if (len > along)
2527                 len = along;
2528             if (checksum) {
2529                 while (len-- > 0) {
2530                     Copy(s, &aushort, 1, U16);
2531                     s += sizeof(U16);
2532 #ifdef HAS_NTOHS
2533                     if (datumtype == 'n')
2534                         aushort = ntohs(aushort);
2535 #endif
2536 #ifdef HAS_VTOHS
2537                     if (datumtype == 'v')
2538                         aushort = vtohs(aushort);
2539 #endif
2540                     culong += aushort;
2541                 }
2542             }
2543             else {
2544                 EXTEND(SP, len);
2545                 while (len-- > 0) {
2546                     Copy(s, &aushort, 1, U16);
2547                     s += sizeof(U16);
2548                     sv = NEWSV(39, 0);
2549 #ifdef HAS_NTOHS
2550                     if (datumtype == 'n')
2551                         aushort = ntohs(aushort);
2552 #endif
2553 #ifdef HAS_VTOHS
2554                     if (datumtype == 'v')
2555                         aushort = vtohs(aushort);
2556 #endif
2557                     sv_setiv(sv, (I32)aushort);
2558                     PUSHs(sv_2mortal(sv));
2559                 }
2560             }
2561             break;
2562         case 'i':
2563             along = (strend - s) / sizeof(int);
2564             if (len > along)
2565                 len = along;
2566             if (checksum) {
2567                 while (len-- > 0) {
2568                     Copy(s, &aint, 1, int);
2569                     s += sizeof(int);
2570                     if (checksum > 32)
2571                         cdouble += (double)aint;
2572                     else
2573                         culong += aint;
2574                 }
2575             }
2576             else {
2577                 EXTEND(SP, len);
2578                 while (len-- > 0) {
2579                     Copy(s, &aint, 1, int);
2580                     s += sizeof(int);
2581                     sv = NEWSV(40, 0);
2582                     sv_setiv(sv, (I32)aint);
2583                     PUSHs(sv_2mortal(sv));
2584                 }
2585             }
2586             break;
2587         case 'I':
2588             along = (strend - s) / sizeof(unsigned int);
2589             if (len > along)
2590                 len = along;
2591             if (checksum) {
2592                 while (len-- > 0) {
2593                     Copy(s, &auint, 1, unsigned int);
2594                     s += sizeof(unsigned int);
2595                     if (checksum > 32)
2596                         cdouble += (double)auint;
2597                     else
2598                         culong += auint;
2599                 }
2600             }
2601             else {
2602                 EXTEND(SP, len);
2603                 while (len-- > 0) {
2604                     Copy(s, &auint, 1, unsigned int);
2605                     s += sizeof(unsigned int);
2606                     sv = NEWSV(41, 0);
2607                     sv_setiv(sv, (I32)auint);
2608                     PUSHs(sv_2mortal(sv));
2609                 }
2610             }
2611             break;
2612         case 'l':
2613             along = (strend - s) / sizeof(I32);
2614             if (len > along)
2615                 len = along;
2616             if (checksum) {
2617                 while (len-- > 0) {
2618                     Copy(s, &along, 1, I32);
2619                     s += sizeof(I32);
2620                     if (checksum > 32)
2621                         cdouble += (double)along;
2622                     else
2623                         culong += along;
2624                 }
2625             }
2626             else {
2627                 EXTEND(SP, len);
2628                 while (len-- > 0) {
2629                     Copy(s, &along, 1, I32);
2630                     s += sizeof(I32);
2631                     sv = NEWSV(42, 0);
2632                     sv_setiv(sv, (I32)along);
2633                     PUSHs(sv_2mortal(sv));
2634                 }
2635             }
2636             break;
2637         case 'V':
2638         case 'N':
2639         case 'L':
2640             along = (strend - s) / sizeof(U32);
2641             if (len > along)
2642                 len = along;
2643             if (checksum) {
2644                 while (len-- > 0) {
2645                     Copy(s, &aulong, 1, U32);
2646                     s += sizeof(U32);
2647 #ifdef HAS_NTOHL
2648                     if (datumtype == 'N')
2649                         aulong = ntohl(aulong);
2650 #endif
2651 #ifdef HAS_VTOHL
2652                     if (datumtype == 'V')
2653                         aulong = vtohl(aulong);
2654 #endif
2655                     if (checksum > 32)
2656                         cdouble += (double)aulong;
2657                     else
2658                         culong += aulong;
2659                 }
2660             }
2661             else {
2662                 EXTEND(SP, len);
2663                 while (len-- > 0) {
2664                     Copy(s, &aulong, 1, U32);
2665                     s += sizeof(U32);
2666                     sv = NEWSV(43, 0);
2667 #ifdef HAS_NTOHL
2668                     if (datumtype == 'N')
2669                         aulong = ntohl(aulong);
2670 #endif
2671 #ifdef HAS_VTOHL
2672                     if (datumtype == 'V')
2673                         aulong = vtohl(aulong);
2674 #endif
2675                     sv_setnv(sv, (double)aulong);
2676                     PUSHs(sv_2mortal(sv));
2677                 }
2678             }
2679             break;
2680         case 'p':
2681             along = (strend - s) / sizeof(char*);
2682             if (len > along)
2683                 len = along;
2684             EXTEND(SP, len);
2685             while (len-- > 0) {
2686                 if (sizeof(char*) > strend - s)
2687                     break;
2688                 else {
2689                     Copy(s, &aptr, 1, char*);
2690                     s += sizeof(char*);
2691                 }
2692                 sv = NEWSV(44, 0);
2693                 if (aptr)
2694                     sv_setpv(sv, aptr);
2695                 PUSHs(sv_2mortal(sv));
2696             }
2697             break;
2698         case 'P':
2699             EXTEND(SP, 1);
2700             if (sizeof(char*) > strend - s)
2701                 break;
2702             else {
2703                 Copy(s, &aptr, 1, char*);
2704                 s += sizeof(char*);
2705             }
2706             sv = NEWSV(44, 0);
2707             if (aptr)
2708                 sv_setpvn(sv, aptr, len);
2709             PUSHs(sv_2mortal(sv));
2710             break;
2711 #ifdef HAS_QUAD
2712         case 'q':
2713             EXTEND(SP, len);
2714             while (len-- > 0) {
2715                 if (s + sizeof(Quad_t) > strend)
2716                     aquad = 0;
2717                 else {
2718                     Copy(s, &aquad, 1, Quad_t);
2719                     s += sizeof(Quad_t);
2720                 }
2721                 sv = NEWSV(42, 0);
2722                 sv_setiv(sv, (IV)aquad);
2723                 PUSHs(sv_2mortal(sv));
2724             }
2725             break;
2726         case 'Q':
2727             EXTEND(SP, len);
2728             while (len-- > 0) {
2729                 if (s + sizeof(unsigned Quad_t) > strend)
2730                     auquad = 0;
2731                 else {
2732                     Copy(s, &auquad, 1, unsigned Quad_t);
2733                     s += sizeof(unsigned Quad_t);
2734                 }
2735                 sv = NEWSV(43, 0);
2736                 sv_setiv(sv, (IV)auquad);
2737                 PUSHs(sv_2mortal(sv));
2738             }
2739             break;
2740 #endif
2741         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
2742         case 'f':
2743         case 'F':
2744             along = (strend - s) / sizeof(float);
2745             if (len > along)
2746                 len = along;
2747             if (checksum) {
2748                 while (len-- > 0) {
2749                     Copy(s, &afloat, 1, float);
2750                     s += sizeof(float);
2751                     cdouble += afloat;
2752                 }
2753             }
2754             else {
2755                 EXTEND(SP, len);
2756                 while (len-- > 0) {
2757                     Copy(s, &afloat, 1, float);
2758                     s += sizeof(float);
2759                     sv = NEWSV(47, 0);
2760                     sv_setnv(sv, (double)afloat);
2761                     PUSHs(sv_2mortal(sv));
2762                 }
2763             }
2764             break;
2765         case 'd':
2766         case 'D':
2767             along = (strend - s) / sizeof(double);
2768             if (len > along)
2769                 len = along;
2770             if (checksum) {
2771                 while (len-- > 0) {
2772                     Copy(s, &adouble, 1, double);
2773                     s += sizeof(double);
2774                     cdouble += adouble;
2775                 }
2776             }
2777             else {
2778                 EXTEND(SP, len);
2779                 while (len-- > 0) {
2780                     Copy(s, &adouble, 1, double);
2781                     s += sizeof(double);
2782                     sv = NEWSV(48, 0);
2783                     sv_setnv(sv, (double)adouble);
2784                     PUSHs(sv_2mortal(sv));
2785                 }
2786             }
2787             break;
2788         case 'u':
2789             along = (strend - s) * 3 / 4;
2790             sv = NEWSV(42, along);
2791             while (s < strend && *s > ' ' && *s < 'a') {
2792                 I32 a, b, c, d;
2793                 char hunk[4];
2794
2795                 hunk[3] = '\0';
2796                 len = (*s++ - ' ') & 077;
2797                 while (len > 0) {
2798                     if (s < strend && *s >= ' ')
2799                         a = (*s++ - ' ') & 077;
2800                     else
2801                         a = 0;
2802                     if (s < strend && *s >= ' ')
2803                         b = (*s++ - ' ') & 077;
2804                     else
2805                         b = 0;
2806                     if (s < strend && *s >= ' ')
2807                         c = (*s++ - ' ') & 077;
2808                     else
2809                         c = 0;
2810                     if (s < strend && *s >= ' ')
2811                         d = (*s++ - ' ') & 077;
2812                     else
2813                         d = 0;
2814                     hunk[0] = a << 2 | b >> 4;
2815                     hunk[1] = b << 4 | c >> 2;
2816                     hunk[2] = c << 6 | d;
2817                     sv_catpvn(sv, hunk, len > 3 ? 3 : len);
2818                     len -= 3;
2819                 }
2820                 if (*s == '\n')
2821                     s++;
2822                 else if (s[1] == '\n')          /* possible checksum byte */
2823                     s += 2;
2824             }
2825             XPUSHs(sv_2mortal(sv));
2826             break;
2827         }
2828         if (checksum) {
2829             sv = NEWSV(42, 0);
2830             if (strchr("fFdD", datumtype) ||
2831               (checksum > 32 && strchr("iIlLN", datumtype)) ) {
2832                 double trouble;
2833
2834                 adouble = 1.0;
2835                 while (checksum >= 16) {
2836                     checksum -= 16;
2837                     adouble *= 65536.0;
2838                 }
2839                 while (checksum >= 4) {
2840                     checksum -= 4;
2841                     adouble *= 16.0;
2842                 }
2843                 while (checksum--)
2844                     adouble *= 2.0;
2845                 along = (1 << checksum) - 1;
2846                 while (cdouble < 0.0)
2847                     cdouble += adouble;
2848                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
2849                 sv_setnv(sv, cdouble);
2850             }
2851             else {
2852                 if (checksum < 32) {
2853                     along = (1 << checksum) - 1;
2854                     culong &= (U32)along;
2855                 }
2856                 sv_setnv(sv, (double)culong);
2857             }
2858             XPUSHs(sv_2mortal(sv));
2859             checksum = 0;
2860         }
2861     }
2862     RETURN;
2863 }
2864
2865 static void
2866 doencodes(sv, s, len)
2867 register SV *sv;
2868 register char *s;
2869 register I32 len;
2870 {
2871     char hunk[5];
2872
2873     *hunk = len + ' ';
2874     sv_catpvn(sv, hunk, 1);
2875     hunk[4] = '\0';
2876     while (len > 0) {
2877         hunk[0] = ' ' + (077 & (*s >> 2));
2878         hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
2879         hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
2880         hunk[3] = ' ' + (077 & (s[2] & 077));
2881         sv_catpvn(sv, hunk, 4);
2882         s += 3;
2883         len -= 3;
2884     }
2885     for (s = SvPVX(sv); *s; s++) {
2886         if (*s == ' ')
2887             *s = '`';
2888     }
2889     sv_catpvn(sv, "\n", 1);
2890 }
2891
2892 PP(pp_pack)
2893 {
2894     dSP; dMARK; dORIGMARK; dTARGET;
2895     register SV *cat = TARG;
2896     register I32 items;
2897     STRLEN fromlen;
2898     register char *pat = SvPVx(*++MARK, fromlen);
2899     register char *patend = pat + fromlen;
2900     register I32 len;
2901     I32 datumtype;
2902     SV *fromstr;
2903     /*SUPPRESS 442*/
2904     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
2905     static char *space10 = "          ";
2906
2907     /* These must not be in registers: */
2908     char achar;
2909     I16 ashort;
2910     int aint;
2911     unsigned int auint;
2912     I32 along;
2913     U32 aulong;
2914 #ifdef HAS_QUAD
2915     Quad_t aquad;
2916     unsigned Quad_t auquad;
2917 #endif
2918     char *aptr;
2919     float afloat;
2920     double adouble;
2921
2922     items = SP - MARK;
2923     MARK++;
2924     sv_setpvn(cat, "", 0);
2925     while (pat < patend) {
2926 #define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
2927         datumtype = *pat++;
2928         if (*pat == '*') {
2929             len = strchr("@Xxu", datumtype) ? 0 : items;
2930             pat++;
2931         }
2932         else if (isDIGIT(*pat)) {
2933             len = *pat++ - '0';
2934             while (isDIGIT(*pat))
2935                 len = (len * 10) + (*pat++ - '0');
2936         }
2937         else
2938             len = 1;
2939         switch(datumtype) {
2940         default:
2941             break;
2942         case '%':
2943             DIE("%% may only be used in unpack");
2944         case '@':
2945             len -= SvCUR(cat);
2946             if (len > 0)
2947                 goto grow;
2948             len = -len;
2949             if (len > 0)
2950                 goto shrink;
2951             break;
2952         case 'X':
2953           shrink:
2954             if (SvCUR(cat) < len)
2955                 DIE("X outside of string");
2956             SvCUR(cat) -= len;
2957             *SvEND(cat) = '\0';
2958             break;
2959         case 'x':
2960           grow:
2961             while (len >= 10) {
2962                 sv_catpvn(cat, null10, 10);
2963                 len -= 10;
2964             }
2965             sv_catpvn(cat, null10, len);
2966             break;
2967         case 'A':
2968         case 'a':
2969             fromstr = NEXTFROM;
2970             aptr = SvPV(fromstr, fromlen);
2971             if (pat[-1] == '*')
2972                 len = fromlen;
2973             if (fromlen > len)
2974                 sv_catpvn(cat, aptr, len);
2975             else {
2976                 sv_catpvn(cat, aptr, fromlen);
2977                 len -= fromlen;
2978                 if (datumtype == 'A') {
2979                     while (len >= 10) {
2980                         sv_catpvn(cat, space10, 10);
2981                         len -= 10;
2982                     }
2983                     sv_catpvn(cat, space10, len);
2984                 }
2985                 else {
2986                     while (len >= 10) {
2987                         sv_catpvn(cat, null10, 10);
2988                         len -= 10;
2989                     }
2990                     sv_catpvn(cat, null10, len);
2991                 }
2992             }
2993             break;
2994         case 'B':
2995         case 'b':
2996             {
2997                 char *savepat = pat;
2998                 I32 saveitems;
2999
3000                 fromstr = NEXTFROM;
3001                 saveitems = items;
3002                 aptr = SvPV(fromstr, fromlen);
3003                 if (pat[-1] == '*')
3004                     len = fromlen;
3005                 pat = aptr;
3006                 aint = SvCUR(cat);
3007                 SvCUR(cat) += (len+7)/8;
3008                 SvGROW(cat, SvCUR(cat) + 1);
3009                 aptr = SvPVX(cat) + aint;
3010                 if (len > fromlen)
3011                     len = fromlen;
3012                 aint = len;
3013                 items = 0;
3014                 if (datumtype == 'B') {
3015                     for (len = 0; len++ < aint;) {
3016                         items |= *pat++ & 1;
3017                         if (len & 7)
3018                             items <<= 1;
3019                         else {
3020                             *aptr++ = items & 0xff;
3021                             items = 0;
3022                         }
3023                     }
3024                 }
3025                 else {
3026                     for (len = 0; len++ < aint;) {
3027                         if (*pat++ & 1)
3028                             items |= 128;
3029                         if (len & 7)
3030                             items >>= 1;
3031                         else {
3032                             *aptr++ = items & 0xff;
3033                             items = 0;
3034                         }
3035                     }
3036                 }
3037                 if (aint & 7) {
3038                     if (datumtype == 'B')
3039                         items <<= 7 - (aint & 7);
3040                     else
3041                         items >>= 7 - (aint & 7);
3042                     *aptr++ = items & 0xff;
3043                 }
3044                 pat = SvPVX(cat) + SvCUR(cat);
3045                 while (aptr <= pat)
3046                     *aptr++ = '\0';
3047
3048                 pat = savepat;
3049                 items = saveitems;
3050             }
3051             break;
3052         case 'H':
3053         case 'h':
3054             {
3055                 char *savepat = pat;
3056                 I32 saveitems;
3057
3058                 fromstr = NEXTFROM;
3059                 saveitems = items;
3060                 aptr = SvPV(fromstr, fromlen);
3061                 if (pat[-1] == '*')
3062                     len = fromlen;
3063                 pat = aptr;
3064                 aint = SvCUR(cat);
3065                 SvCUR(cat) += (len+1)/2;
3066                 SvGROW(cat, SvCUR(cat) + 1);
3067                 aptr = SvPVX(cat) + aint;
3068                 if (len > fromlen)
3069                     len = fromlen;
3070                 aint = len;
3071                 items = 0;
3072                 if (datumtype == 'H') {
3073                     for (len = 0; len++ < aint;) {
3074                         if (isALPHA(*pat))
3075                             items |= ((*pat++ & 15) + 9) & 15;
3076                         else
3077                             items |= *pat++ & 15;
3078                         if (len & 1)
3079                             items <<= 4;
3080                         else {
3081                             *aptr++ = items & 0xff;
3082                             items = 0;
3083                         }
3084                     }
3085                 }
3086                 else {
3087                     for (len = 0; len++ < aint;) {
3088                         if (isALPHA(*pat))
3089                             items |= (((*pat++ & 15) + 9) & 15) << 4;
3090                         else
3091                             items |= (*pat++ & 15) << 4;
3092                         if (len & 1)
3093                             items >>= 4;
3094                         else {
3095                             *aptr++ = items & 0xff;
3096                             items = 0;
3097                         }
3098                     }
3099                 }
3100                 if (aint & 1)
3101                     *aptr++ = items & 0xff;
3102                 pat = SvPVX(cat) + SvCUR(cat);
3103                 while (aptr <= pat)
3104                     *aptr++ = '\0';
3105
3106                 pat = savepat;
3107                 items = saveitems;
3108             }
3109             break;
3110         case 'C':
3111         case 'c':
3112             while (len-- > 0) {
3113                 fromstr = NEXTFROM;
3114                 aint = SvIV(fromstr);
3115                 achar = aint;
3116                 sv_catpvn(cat, &achar, sizeof(char));
3117             }
3118             break;
3119         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
3120         case 'f':
3121         case 'F':
3122             while (len-- > 0) {
3123                 fromstr = NEXTFROM;
3124                 afloat = (float)SvNV(fromstr);
3125                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
3126             }
3127             break;
3128         case 'd':
3129         case 'D':
3130             while (len-- > 0) {
3131                 fromstr = NEXTFROM;
3132                 adouble = (double)SvNV(fromstr);
3133                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
3134             }
3135             break;
3136         case 'n':
3137             while (len-- > 0) {
3138                 fromstr = NEXTFROM;
3139                 ashort = (I16)SvIV(fromstr);
3140 #ifdef HAS_HTONS
3141                 ashort = htons(ashort);
3142 #endif
3143                 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
3144             }
3145             break;
3146         case 'v':
3147             while (len-- > 0) {
3148                 fromstr = NEXTFROM;
3149                 ashort = (I16)SvIV(fromstr);
3150 #ifdef HAS_HTOVS
3151                 ashort = htovs(ashort);
3152 #endif
3153                 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
3154             }
3155             break;
3156         case 'S':
3157         case 's':
3158             while (len-- > 0) {
3159                 fromstr = NEXTFROM;
3160                 ashort = (I16)SvIV(fromstr);
3161                 sv_catpvn(cat, (char*)&ashort, sizeof(I16));
3162             }
3163             break;
3164         case 'I':
3165             while (len-- > 0) {
3166                 fromstr = NEXTFROM;
3167                 auint = U_I(SvNV(fromstr));
3168                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
3169             }
3170             break;
3171         case 'i':
3172             while (len-- > 0) {
3173                 fromstr = NEXTFROM;
3174                 aint = SvIV(fromstr);
3175                 sv_catpvn(cat, (char*)&aint, sizeof(int));
3176             }
3177             break;
3178         case 'N':
3179             while (len-- > 0) {
3180                 fromstr = NEXTFROM;
3181                 aulong = U_L(SvNV(fromstr));
3182 #ifdef HAS_HTONL
3183                 aulong = htonl(aulong);
3184 #endif
3185                 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
3186             }
3187             break;
3188         case 'V':
3189             while (len-- > 0) {
3190                 fromstr = NEXTFROM;
3191                 aulong = U_L(SvNV(fromstr));
3192 #ifdef HAS_HTOVL
3193                 aulong = htovl(aulong);
3194 #endif
3195                 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
3196             }
3197             break;
3198         case 'L':
3199             while (len-- > 0) {
3200                 fromstr = NEXTFROM;
3201                 aulong = U_L(SvNV(fromstr));
3202                 sv_catpvn(cat, (char*)&aulong, sizeof(U32));
3203             }
3204             break;
3205         case 'l':
3206             while (len-- > 0) {
3207                 fromstr = NEXTFROM;
3208                 along = SvIV(fromstr);
3209                 sv_catpvn(cat, (char*)&along, sizeof(I32));
3210             }
3211             break;
3212 #ifdef HAS_QUAD
3213         case 'Q':
3214             while (len-- > 0) {
3215                 fromstr = NEXTFROM;
3216                 auquad = (unsigned Quad_t)SvIV(fromstr);
3217                 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
3218             }
3219             break;
3220         case 'q':
3221             while (len-- > 0) {
3222                 fromstr = NEXTFROM;
3223                 aquad = (Quad_t)SvIV(fromstr);
3224                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
3225             }
3226             break;
3227 #endif /* HAS_QUAD */
3228         case 'P':
3229             len = 1;            /* assume SV is correct length */
3230             /* FALL THROUGH */
3231         case 'p':
3232             while (len-- > 0) {
3233                 fromstr = NEXTFROM;
3234                 aptr = SvPV_force(fromstr, na); /* XXX Error if TEMP? */
3235                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
3236             }
3237             break;
3238         case 'u':
3239             fromstr = NEXTFROM;
3240             aptr = SvPV(fromstr, fromlen);
3241             SvGROW(cat, fromlen * 4 / 3);
3242             if (len <= 1)
3243                 len = 45;
3244             else
3245                 len = len / 3 * 3;
3246             while (fromlen > 0) {
3247                 I32 todo;
3248
3249                 if (fromlen > len)
3250                     todo = len;
3251                 else
3252                     todo = fromlen;
3253                 doencodes(cat, aptr, todo);
3254                 fromlen -= todo;
3255                 aptr += todo;
3256             }
3257             break;
3258         }
3259     }
3260     SvSETMAGIC(cat);
3261     SP = ORIGMARK;
3262     PUSHs(cat);
3263     RETURN;
3264 }
3265 #undef NEXTFROM
3266
3267 PP(pp_split)
3268 {
3269     dSP; dTARG;
3270     AV *ary;
3271     register I32 limit = POPi;                  /* note, negative is forever */
3272     SV *sv = POPs;
3273     STRLEN len;
3274     register char *s = SvPV(sv, len);
3275     char *strend = s + len;
3276     register PMOP *pm = (PMOP*)POPs;
3277     register SV *dstr;
3278     register char *m;
3279     I32 iters = 0;
3280     I32 maxiters = (strend - s) + 10;
3281     I32 i;
3282     char *orig;
3283     I32 origlimit = limit;
3284     I32 realarray = 0;
3285     I32 base;
3286     AV *oldstack = stack;
3287     register REGEXP *rx = pm->op_pmregexp;
3288     I32 gimme = GIMME;
3289
3290     if (!pm || !s)
3291         DIE("panic: do_split");
3292     if (pm->op_pmreplroot)
3293         ary = GvAVn((GV*)pm->op_pmreplroot);
3294     else if (gimme != G_ARRAY)
3295         ary = GvAVn(defgv);
3296     else
3297         ary = Nullav;
3298     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
3299         realarray = 1;
3300         if (!AvREAL(ary)) {
3301             AvREAL_on(ary);
3302             for (i = AvFILL(ary); i >= 0; i--)
3303                 AvARRAY(ary)[i] = &sv_undef;    /* don't free mere refs */
3304         }
3305         av_extend(ary,0);
3306         av_clear(ary);
3307         /* temporarily switch stacks */
3308         SWITCHSTACK(stack, ary);
3309     }
3310     base = SP - stack_base;
3311     orig = s;
3312     if (pm->op_pmflags & PMf_SKIPWHITE) {
3313         while (isSPACE(*s))
3314             s++;
3315     }
3316     if (!limit)
3317         limit = maxiters + 2;
3318     if (pm->op_pmflags & PMf_WHITE) {
3319         while (--limit) {
3320             /*SUPPRESS 530*/
3321             for (m = s; m < strend && !isSPACE(*m); m++) ;
3322             if (m >= strend)
3323                 break;
3324             dstr = NEWSV(30, m-s);
3325             sv_setpvn(dstr, s, m-s);
3326             if (!realarray)
3327                 sv_2mortal(dstr);
3328             XPUSHs(dstr);
3329             /*SUPPRESS 530*/
3330             for (s = m + 1; s < strend && isSPACE(*s); s++) ;
3331         }
3332     }
3333     else if (strEQ("^", rx->precomp)) {
3334         while (--limit) {
3335             /*SUPPRESS 530*/
3336             for (m = s; m < strend && *m != '\n'; m++) ;
3337             m++;
3338             if (m >= strend)
3339                 break;
3340             dstr = NEWSV(30, m-s);
3341             sv_setpvn(dstr, s, m-s);
3342             if (!realarray)
3343                 sv_2mortal(dstr);
3344             XPUSHs(dstr);
3345             s = m;
3346         }
3347     }
3348     else if (pm->op_pmshort) {
3349         i = SvCUR(pm->op_pmshort);
3350         if (i == 1) {
3351             I32 fold = (pm->op_pmflags & PMf_FOLD);
3352             i = *SvPVX(pm->op_pmshort);
3353             if (fold && isUPPER(i))
3354                 i = toLOWER(i);
3355             while (--limit) {
3356                 if (fold) {
3357                     for ( m = s;
3358                           m < strend && *m != i &&
3359                             (!isUPPER(*m) || toLOWER(*m) != i);
3360                           m++)                  /*SUPPRESS 530*/
3361                         ;
3362                 }
3363                 else                            /*SUPPRESS 530*/
3364                     for (m = s; m < strend && *m != i; m++) ;
3365                 if (m >= strend)
3366                     break;
3367                 dstr = NEWSV(30, m-s);
3368                 sv_setpvn(dstr, s, m-s);
3369                 if (!realarray)
3370                     sv_2mortal(dstr);
3371                 XPUSHs(dstr);
3372                 s = m + 1;
3373             }
3374         }
3375         else {
3376 #ifndef lint
3377             while (s < strend && --limit &&
3378               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
3379                     pm->op_pmshort)) )
3380 #endif
3381             {
3382                 dstr = NEWSV(31, m-s);
3383                 sv_setpvn(dstr, s, m-s);
3384                 if (!realarray)
3385                     sv_2mortal(dstr);
3386                 XPUSHs(dstr);
3387                 s = m + i;
3388             }
3389         }
3390     }
3391     else {
3392         maxiters += (strend - s) * rx->nparens;
3393         while (s < strend && --limit &&
3394             regexec(rx, s, strend, orig, 1, Nullsv, TRUE) ) {
3395             if (rx->subbase
3396               && rx->subbase != orig) {
3397                 m = s;
3398                 s = orig;
3399                 orig = rx->subbase;
3400                 s = orig + (m - s);
3401                 strend = s + (strend - m);
3402             }
3403             m = rx->startp[0];
3404             dstr = NEWSV(32, m-s);
3405             sv_setpvn(dstr, s, m-s);
3406             if (!realarray)
3407                 sv_2mortal(dstr);
3408             XPUSHs(dstr);
3409             if (rx->nparens) {
3410                 for (i = 1; i <= rx->nparens; i++) {
3411                     s = rx->startp[i];
3412                     m = rx->endp[i];
3413                     if (m && s) {
3414                         dstr = NEWSV(33, m-s);
3415                         sv_setpvn(dstr, s, m-s);
3416                     }
3417                     else
3418                         dstr = NEWSV(33, 0);
3419                     if (!realarray)
3420                         sv_2mortal(dstr);
3421                     XPUSHs(dstr);
3422                 }
3423             }
3424             s = rx->endp[0];
3425         }
3426     }
3427     iters = (SP - stack_base) - base;
3428     if (iters > maxiters)
3429         DIE("Split loop");
3430     
3431     /* keep field after final delim? */
3432     if (s < strend || (iters && origlimit)) {
3433         dstr = NEWSV(34, strend-s);
3434         sv_setpvn(dstr, s, strend-s);
3435         if (!realarray)
3436             sv_2mortal(dstr);
3437         XPUSHs(dstr);
3438         iters++;
3439     }
3440     else if (!origlimit) {
3441         while (iters > 0 && SvCUR(TOPs) == 0)
3442             iters--, SP--;
3443     }
3444     if (realarray) {
3445         SWITCHSTACK(ary, oldstack);
3446         if (gimme == G_ARRAY) {
3447             EXTEND(SP, iters);
3448             Copy(AvARRAY(ary), SP + 1, iters, SV*);
3449             SP += iters;
3450             RETURN;
3451         }
3452     }
3453     else {
3454         if (gimme == G_ARRAY)
3455             RETURN;
3456     }
3457     if (iters || !pm->op_pmreplroot) {
3458         GETTARGET;
3459         PUSHi(iters);
3460         RETURN;
3461     }
3462     RETPUSHUNDEF;
3463 }
3464