Retract the mergesort code, way too incompatible licensing
[perl.git] / doop.c
1 /*    doop.c
2  *
3  *    Copyright (c) 1991-2000, 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  * "'So that was the job I felt I had to do when I started,' thought Sam."
12  */
13
14 #include "EXTERN.h"
15 #define PERL_IN_DOOP_C
16 #include "perl.h"
17
18 #ifndef PERL_MICRO
19 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
20 #include <signal.h>
21 #endif
22 #endif
23
24 #define HALF_UTF8_UPGRADE(start,end) \
25     STMT_START {                                \
26       if ((start)<(end)) {                      \
27         U8* NeWsTr;                             \
28         STRLEN LeN = (end) - (start);           \
29         NeWsTr = bytes_to_utf8(start, &LeN);    \
30         Safefree(start);                        \
31         (start) = NeWsTr;                       \
32         (end) = (start) + LeN;                  \
33       }                                         \
34     } STMT_END
35
36 STATIC I32
37 S_do_trans_simple(pTHX_ SV *sv)
38 {
39     dTHR;
40     U8 *s;
41     U8 *d;
42     U8 *send;
43     U8 *dstart;
44     I32 matches = 0;
45     I32 sutf = SvUTF8(sv);
46     STRLEN len;
47     short *tbl;
48     I32 ch;
49
50     tbl = (short*)cPVOP->op_pv;
51     if (!tbl)
52         Perl_croak(aTHX_ "panic: do_trans");
53
54     s = (U8*)SvPV(sv, len);
55     send = s + len;
56
57     /* First, take care of non-UTF8 input strings, because they're easy */
58     if (!sutf) {
59         while (s < send) {
60             if ((ch = tbl[*s]) >= 0) {
61                 matches++;
62                 *s++ = ch;
63             }
64             else
65                 s++;
66         }
67         SvSETMAGIC(sv);
68         return matches;
69     }
70
71     /* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
72     Newz(0, d, len*2+1, U8);
73     dstart = d;
74     while (s < send) {
75         I32 ulen;
76         short c;
77
78         ulen = 1;
79         /* Need to check this, otherwise 128..255 won't match */
80         c = utf8_to_uv(s, &ulen);
81         if (c < 0x100 && (ch = tbl[(short)c]) >= 0) {
82             matches++;
83             if (ch < 0x80) 
84                 *d++ = ch;
85             else         
86                 d = uv_to_utf8(d,ch);
87             s += ulen;
88         }
89         else { /* No match -> copy */
90             while (ulen--)
91                 *d++ = *s++;
92         }
93     }
94     *d = '\0';
95     sv_setpvn(sv, (const char*)dstart, d - dstart);
96     Safefree(dstart);
97     SvUTF8_on(sv);
98     SvSETMAGIC(sv);
99     return matches;
100 }
101
102 STATIC I32
103 S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */
104 {
105     dTHR;
106     U8 *s;
107     U8 *send;
108     I32 matches = 0;
109     I32 hasutf = SvUTF8(sv);
110     STRLEN len;
111     short *tbl;
112
113     tbl = (short*)cPVOP->op_pv;
114     if (!tbl)
115         Perl_croak(aTHX_ "panic: do_trans");
116
117     s = (U8*)SvPV(sv, len);
118     send = s + len;
119
120     while (s < send) {
121         if (hasutf && *s & 0x80)
122             s += UTF8SKIP(s);
123         else {
124             UV c;
125             I32 ulen;
126             ulen = 1;
127             if (hasutf)
128                 c = utf8_to_uv(s,&ulen);
129             else
130                 c = *s;
131             if (c < 0x100 && tbl[c] >= 0)
132                 matches++;
133             s += ulen;
134         }
135     }
136
137     return matches;
138 }
139
140 STATIC I32
141 S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
142 {
143     dTHR;
144     U8 *s;
145     U8 *send;
146     U8 *d;
147     I32 hasutf = SvUTF8(sv);
148     I32 matches = 0;
149     STRLEN len;
150     short *tbl;
151     I32 ch;
152
153     tbl = (short*)cPVOP->op_pv;
154     if (!tbl)
155         Perl_croak(aTHX_ "panic: do_trans");
156
157     s = (U8*)SvPV(sv, len);
158     send = s + len;
159
160     d = s;
161     if (PL_op->op_private & OPpTRANS_SQUASH) {
162         U8* p = send;
163
164         while (s < send) {
165             if (hasutf && *s & 0x80)
166                 s += UTF8SKIP(s);
167             else {
168                 if ((ch = tbl[*s]) >= 0) {
169                     *d = ch;
170                     matches++;
171                     if (p == d - 1 && *p == *d)
172                         matches--;
173                     else
174                         p = d++;
175                 }
176                 else if (ch == -1)      /* -1 is unmapped character */
177                     *d++ = *s;          /* -2 is delete character */
178                 s++;
179             }
180         }
181     }
182     else {
183         while (s < send) {
184             if (hasutf && *s & 0x80)
185                 s += UTF8SKIP(s);
186             else {
187                 if ((ch = tbl[*s]) >= 0) {
188                     *d = ch;
189                     matches++;
190                     d++;
191                 }
192                 else if (ch == -1)      /* -1 is unmapped character */
193                     *d++ = *s;          /* -2 is delete character */
194                 s++;
195             }
196         }
197     }
198     matches += send - d;                /* account for disappeared chars */
199     *d = '\0';
200     SvCUR_set(sv, d - (U8*)SvPVX(sv));
201     SvSETMAGIC(sv);
202
203     return matches;
204 }
205
206 STATIC I32
207 S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
208 {
209     dTHR;
210     U8 *s;
211     U8 *send;
212     U8 *d;
213     U8 *start;
214     U8 *dstart;
215     I32 matches = 0;
216     STRLEN len;
217
218     SV* rv = (SV*)cSVOP->op_sv;
219     HV* hv = (HV*)SvRV(rv);
220     SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
221     UV none = svp ? SvUV(*svp) : 0x7fffffff;
222     UV extra = none + 1;
223     UV final;
224     UV uv;
225     I32 isutf; 
226     I32 howmany;
227
228     isutf = SvUTF8(sv);
229     s = (U8*)SvPV(sv, len);
230     send = s + len;
231     start = s;
232
233     svp = hv_fetch(hv, "FINAL", 5, FALSE);
234     if (svp)
235         final = SvUV(*svp);
236
237     /* d needs to be bigger than s, in case e.g. upgrading is required */
238     Newz(0, d, len*2+1, U8);
239     dstart = d;
240     while (s < send) {
241         if ((uv = swash_fetch(rv, s)) < none) {
242             s += UTF8SKIP(s);
243             matches++;
244             if ((uv & 0x80) && !isutf++)
245                 HALF_UTF8_UPGRADE(dstart,d);
246             d = uv_to_utf8(d, uv);
247         }
248         else if (uv == none) {
249             int i;
250             i = UTF8SKIP(s);
251             if (i > 1 && !isutf++)
252                 HALF_UTF8_UPGRADE(dstart,d);
253             while(i--)
254                 *d++ = *s++;
255         }
256         else if (uv == extra) {
257             int i;
258             i = UTF8SKIP(s);
259             s += i;
260             matches++;
261             if (i > 1 && !isutf++) 
262                 HALF_UTF8_UPGRADE(dstart,d);
263             d = uv_to_utf8(d, final);
264         }
265         else
266             s += UTF8SKIP(s);
267     }
268     *d = '\0';
269     sv_setpvn(sv, (const char*)dstart, d - dstart);
270     SvSETMAGIC(sv);
271     if (isutf)
272         SvUTF8_on(sv);
273
274     return matches;
275 }
276
277 STATIC I32
278 S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */
279 {
280     dTHR;
281     U8 *s;
282     U8 *send;
283     I32 matches = 0;
284     STRLEN len;
285
286     SV* rv = (SV*)cSVOP->op_sv;
287     HV* hv = (HV*)SvRV(rv);
288     SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
289     UV none = svp ? SvUV(*svp) : 0x7fffffff;
290     UV uv;
291
292     s = (U8*)SvPV(sv, len);
293     if (!SvUTF8(sv))
294         s = bytes_to_utf8(s, &len);
295     send = s + len;
296
297     while (s < send) {
298         if ((uv = swash_fetch(rv, s)) < none)
299             matches++;
300         s += UTF8SKIP(s);
301     }
302
303     return matches;
304 }
305
306 STATIC I32
307 S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
308 {
309     dTHR;
310     U8 *s;
311     U8 *send;
312     U8 *d;
313     I32 matches = 0;
314     I32 squash   = PL_op->op_private & OPpTRANS_SQUASH;
315     I32 del      = PL_op->op_private & OPpTRANS_DELETE;
316     SV* rv = (SV*)cSVOP->op_sv;
317     HV* hv = (HV*)SvRV(rv);
318     SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
319     UV none = svp ? SvUV(*svp) : 0x7fffffff;
320     UV extra = none + 1;
321     UV final;
322     UV uv;
323     STRLEN len;
324     U8 *dst;
325     I32 isutf = SvUTF8(sv);
326
327     s = (U8*)SvPV(sv, len);
328     send = s + len;
329
330     svp = hv_fetch(hv, "FINAL", 5, FALSE);
331     if (svp)
332         final = SvUV(*svp);
333
334     Newz(0, d, len*2+1, U8);
335         dst = d;
336
337     if (squash) {
338         UV puv = 0xfeedface;
339         while (s < send) {
340             if (SvUTF8(sv)) 
341                 uv = swash_fetch(rv, s);
342             else {
343                 U8 tmpbuf[2];
344                 uv = *s++;
345                 if (uv < 0x80)
346                     tmpbuf[0] = uv;
347                 else {
348                     tmpbuf[0] = (( uv >>  6)         | 0xc0);
349                     tmpbuf[1] = (( uv        & 0x3f) | 0x80);
350                 }
351                 uv = swash_fetch(rv, tmpbuf);
352             }
353
354             if (uv < none) {
355                 matches++;
356                 if (uv != puv) {
357                     if ((uv & 0x80) && !isutf++) 
358                         HALF_UTF8_UPGRADE(dst,d);
359                     d = uv_to_utf8(d, uv);
360                     puv = uv;
361                 }
362                 s += UTF8SKIP(s);
363                 continue;
364             }
365             else if (uv == none) {      /* "none" is unmapped character */
366                 I32 ulen;
367                 *d++ = (U8)utf8_to_uv(s, &ulen);
368                 s += ulen;
369                 puv = 0xfeedface;
370                 continue;
371             }
372             else if (uv == extra && !del) {
373                 matches++;
374                 if (uv != puv) {
375                     d = uv_to_utf8(d, final);
376                     puv = final;
377                 }
378                 s += UTF8SKIP(s);
379                 continue;
380             }
381             matches++;                  /* "none+1" is delete character */
382             s += UTF8SKIP(s);
383         }
384     }
385     else {
386         while (s < send) {
387             if (SvUTF8(sv)) 
388                 uv = swash_fetch(rv, s);
389             else {
390                 U8 tmpbuf[2];
391                 uv = *s++;
392                 if (uv < 0x80)
393                     tmpbuf[0] = uv;
394                 else {
395                     tmpbuf[0] = (( uv >>  6)         | 0xc0);
396                     tmpbuf[1] = (( uv        & 0x3f) | 0x80);
397                 }
398                 uv = swash_fetch(rv, tmpbuf);
399             }
400             if (uv < none) {
401                 matches++;
402                 d = uv_to_utf8(d, uv);
403                 s += UTF8SKIP(s);
404                 continue;
405             }
406             else if (uv == none) {      /* "none" is unmapped character */
407                 I32 ulen;
408                 *d++ = (U8)utf8_to_uv(s, &ulen);
409                 s += ulen;
410                 continue;
411             }
412             else if (uv == extra && !del) {
413                 matches++;
414                 d = uv_to_utf8(d, final);
415                 s += UTF8SKIP(s);
416                 continue;
417             }
418             matches++;                  /* "none+1" is delete character */
419             s += UTF8SKIP(s);
420         }
421     }
422     if (dst)
423         sv_usepvn(sv, (char*)dst, d - dst);
424     else {
425         *d = '\0';
426         SvCUR_set(sv, d - (U8*)SvPVX(sv));
427     }
428     SvSETMAGIC(sv);
429
430     return matches;
431 }
432
433 I32
434 Perl_do_trans(pTHX_ SV *sv)
435 {
436     dTHR;
437     STRLEN len;
438     I32 hasutf = (PL_op->op_private & 
439                     (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
440
441     if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
442         Perl_croak(aTHX_ PL_no_modify);
443
444     (void)SvPV(sv, len);
445     if (!len)
446         return 0;
447     if (!SvPOKp(sv))
448         (void)SvPV_force(sv, len);
449     if (!(PL_op->op_private & OPpTRANS_IDENTICAL))
450         (void)SvPOK_only_UTF8(sv);
451
452     DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
453
454     switch (PL_op->op_private & ~hasutf & 63) {
455     case 0:
456         if (hasutf)
457             return do_trans_simple_utf8(sv);
458         else
459             return do_trans_simple(sv);
460
461     case OPpTRANS_IDENTICAL:
462         if (hasutf)
463             return do_trans_count_utf8(sv);
464         else
465             return do_trans_count(sv);
466
467     default:
468         if (hasutf)
469             return do_trans_complex_utf8(sv);
470         else
471             return do_trans_complex(sv);
472     }
473 }
474
475 void
476 Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp)
477 {
478     SV **oldmark = mark;
479     register I32 items = sp - mark;
480     register STRLEN len;
481     STRLEN delimlen;
482     register char *delim = SvPV(del, delimlen);
483     STRLEN tmplen;
484
485     mark++;
486     len = (items > 0 ? (delimlen * (items - 1) ) : 0);
487     (void)SvUPGRADE(sv, SVt_PV);
488     if (SvLEN(sv) < len + items) {      /* current length is way too short */
489         while (items-- > 0) {
490             if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) {
491                 SvPV(*mark, tmplen);
492                 len += tmplen;
493             }
494             mark++;
495         }
496         SvGROW(sv, len + 1);            /* so try to pre-extend */
497
498         mark = oldmark;
499         items = sp - mark;
500         ++mark;
501     }
502
503     if (items-- > 0) {
504         char *s;
505
506         sv_setpv(sv, "");
507         if (*mark)
508             sv_catsv(sv, *mark);
509         mark++;
510     }
511     else
512         sv_setpv(sv,"");
513     len = delimlen;
514     if (len) {
515         for (; items > 0; items--,mark++) {
516             sv_catpvn(sv,delim,len);
517             sv_catsv(sv,*mark);
518         }
519     }
520     else {
521         for (; items > 0; items--,mark++)
522             sv_catsv(sv,*mark);
523     }
524     SvSETMAGIC(sv);
525 }
526
527 void
528 Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
529 {
530     STRLEN patlen;
531     char *pat = SvPV(*sarg, patlen);
532     bool do_taint = FALSE;
533
534     sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
535     SvSETMAGIC(sv);
536     if (do_taint)
537         SvTAINTED_on(sv);
538 }
539
540 /* XXX SvUTF8 support missing! */
541 UV
542 Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
543 {
544     STRLEN srclen, len;
545     unsigned char *s = (unsigned char *) SvPV(sv, srclen);
546     UV retnum = 0;
547
548     if (offset < 0)
549         return retnum;
550     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ 
551         Perl_croak(aTHX_ "Illegal number of bits in vec");
552     offset *= size;     /* turn into bit offset */
553     len = (offset + size + 7) / 8;      /* required number of bytes */
554     if (len > srclen) {
555         if (size <= 8)
556             retnum = 0;
557         else {
558             offset >>= 3;       /* turn into byte offset */
559             if (size == 16) {
560                 if (offset >= srclen)
561                     retnum = 0;
562                 else
563                     retnum = (UV) s[offset] <<  8;
564             }
565             else if (size == 32) {
566                 if (offset >= srclen)
567                     retnum = 0;
568                 else if (offset + 1 >= srclen)
569                     retnum =
570                         ((UV) s[offset    ] << 24);
571                 else if (offset + 2 >= srclen)
572                     retnum =
573                         ((UV) s[offset    ] << 24) +
574                         ((UV) s[offset + 1] << 16);
575                 else
576                     retnum =
577                         ((UV) s[offset    ] << 24) +
578                         ((UV) s[offset + 1] << 16) +
579                         (     s[offset + 2] <<  8);
580             }
581 #ifdef UV_IS_QUAD
582             else if (size == 64) {
583                 dTHR;
584                 if (ckWARN(WARN_PORTABLE))
585                     Perl_warner(aTHX_ WARN_PORTABLE,
586                                 "Bit vector size > 32 non-portable");
587                 if (offset >= srclen)
588                     retnum = 0;
589                 else if (offset + 1 >= srclen)
590                     retnum =
591                         (UV) s[offset     ] << 56;
592                 else if (offset + 2 >= srclen)
593                     retnum =
594                         ((UV) s[offset    ] << 56) +
595                         ((UV) s[offset + 1] << 48);
596                 else if (offset + 3 >= srclen)
597                     retnum =
598                         ((UV) s[offset    ] << 56) +
599                         ((UV) s[offset + 1] << 48) +
600                         ((UV) s[offset + 2] << 40);
601                 else if (offset + 4 >= srclen)
602                     retnum =
603                         ((UV) s[offset    ] << 56) +
604                         ((UV) s[offset + 1] << 48) +
605                         ((UV) s[offset + 2] << 40) +
606                         ((UV) s[offset + 3] << 32);
607                 else if (offset + 5 >= srclen)
608                     retnum =
609                         ((UV) s[offset    ] << 56) +
610                         ((UV) s[offset + 1] << 48) +
611                         ((UV) s[offset + 2] << 40) +
612                         ((UV) s[offset + 3] << 32) +
613                         (     s[offset + 4] << 24);
614                 else if (offset + 6 >= srclen)
615                     retnum =
616                         ((UV) s[offset    ] << 56) +
617                         ((UV) s[offset + 1] << 48) +
618                         ((UV) s[offset + 2] << 40) +
619                         ((UV) s[offset + 3] << 32) +
620                         ((UV) s[offset + 4] << 24) +
621                         ((UV) s[offset + 5] << 16);
622                 else
623                     retnum = 
624                         ((UV) s[offset    ] << 56) +
625                         ((UV) s[offset + 1] << 48) +
626                         ((UV) s[offset + 2] << 40) +
627                         ((UV) s[offset + 3] << 32) +
628                         ((UV) s[offset + 4] << 24) +
629                         ((UV) s[offset + 5] << 16) +
630                         (     s[offset + 6] <<  8);
631             }
632 #endif
633         }
634     }
635     else if (size < 8)
636         retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
637     else {
638         offset >>= 3;   /* turn into byte offset */
639         if (size == 8)
640             retnum = s[offset];
641         else if (size == 16)
642             retnum =
643                 ((UV) s[offset] <<      8) +
644                       s[offset + 1];
645         else if (size == 32)
646             retnum =
647                 ((UV) s[offset    ] << 24) +
648                 ((UV) s[offset + 1] << 16) +
649                 (     s[offset + 2] <<  8) +
650                       s[offset + 3];
651 #ifdef UV_IS_QUAD
652         else if (size == 64) {
653             dTHR;
654             if (ckWARN(WARN_PORTABLE))
655                 Perl_warner(aTHX_ WARN_PORTABLE,
656                             "Bit vector size > 32 non-portable");
657             retnum =
658                 ((UV) s[offset    ] << 56) +
659                 ((UV) s[offset + 1] << 48) +
660                 ((UV) s[offset + 2] << 40) +
661                 ((UV) s[offset + 3] << 32) +
662                 ((UV) s[offset + 4] << 24) +
663                 ((UV) s[offset + 5] << 16) +
664                 (     s[offset + 6] <<  8) +
665                       s[offset + 7];
666         }
667 #endif
668     }
669
670     return retnum;
671 }
672
673 /* XXX SvUTF8 support missing! */
674 void
675 Perl_do_vecset(pTHX_ SV *sv)
676 {
677     SV *targ = LvTARG(sv);
678     register I32 offset;
679     register I32 size;
680     register unsigned char *s;
681     register UV lval;
682     I32 mask;
683     STRLEN targlen;
684     STRLEN len;
685
686     if (!targ)
687         return;
688     s = (unsigned char*)SvPV_force(targ, targlen);
689     (void)SvPOK_only(targ);
690     lval = SvUV(sv);
691     offset = LvTARGOFF(sv);
692     if (offset < 0)
693         Perl_croak(aTHX_ "Assigning to negative offset in vec");
694     size = LvTARGLEN(sv);
695     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ 
696         Perl_croak(aTHX_ "Illegal number of bits in vec");
697     
698     offset *= size;                     /* turn into bit offset */
699     len = (offset + size + 7) / 8;      /* required number of bytes */
700     if (len > targlen) {
701         s = (unsigned char*)SvGROW(targ, len + 1);
702         (void)memzero((char *)(s + targlen), len - targlen + 1);
703         SvCUR_set(targ, len);
704     }
705     
706     if (size < 8) {
707         mask = (1 << size) - 1;
708         size = offset & 7;
709         lval &= mask;
710         offset >>= 3;                   /* turn into byte offset */
711         s[offset] &= ~(mask << size);
712         s[offset] |= lval << size;
713     }
714     else {
715         offset >>= 3;                   /* turn into byte offset */
716         if (size == 8)
717             s[offset  ] = lval         & 0xff;
718         else if (size == 16) {
719             s[offset  ] = (lval >>  8) & 0xff;
720             s[offset+1] = lval         & 0xff;
721         }
722         else if (size == 32) {
723             s[offset  ] = (lval >> 24) & 0xff;
724             s[offset+1] = (lval >> 16) & 0xff;
725             s[offset+2] = (lval >>  8) & 0xff;
726             s[offset+3] =  lval        & 0xff;
727         }
728 #ifdef UV_IS_QUAD
729         else if (size == 64) {
730             dTHR;
731             if (ckWARN(WARN_PORTABLE))
732                 Perl_warner(aTHX_ WARN_PORTABLE,
733                             "Bit vector size > 32 non-portable");
734             s[offset  ] = (lval >> 56) & 0xff;
735             s[offset+1] = (lval >> 48) & 0xff;
736             s[offset+2] = (lval >> 40) & 0xff;
737             s[offset+3] = (lval >> 32) & 0xff;
738             s[offset+4] = (lval >> 24) & 0xff;
739             s[offset+5] = (lval >> 16) & 0xff;
740             s[offset+6] = (lval >>  8) & 0xff;
741             s[offset+7] =  lval        & 0xff;
742         }
743 #endif
744     }
745     SvSETMAGIC(targ);
746 }
747
748 void
749 Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
750 {
751     STRLEN len;
752     char *s;
753     dTHR;
754     
755     if (SvTYPE(sv) == SVt_PVAV) {
756         register I32 i;
757         I32 max;
758         AV* av = (AV*)sv;
759         max = AvFILL(av);
760         for (i = 0; i <= max; i++) {
761             sv = (SV*)av_fetch(av, i, FALSE);
762             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
763                 do_chop(astr, sv);
764         }
765         return;
766     }
767     else if (SvTYPE(sv) == SVt_PVHV) {
768         HV* hv = (HV*)sv;
769         HE* entry;
770         (void)hv_iterinit(hv);
771         /*SUPPRESS 560*/
772         while ((entry = hv_iternext(hv)))
773             do_chop(astr,hv_iterval(hv,entry));
774         return;
775     }
776     else if (SvREADONLY(sv))
777         Perl_croak(aTHX_ PL_no_modify);
778     s = SvPV(sv, len);
779     if (len && !SvPOK(sv))
780         s = SvPV_force(sv, len);
781     if (DO_UTF8(sv)) {
782         if (s && len) {
783             char *send = s + len;
784             char *start = s;
785             s = send - 1;
786             while ((*s & 0xc0) == 0x80)
787                 --s;
788             if (UTF8SKIP(s) != send - s && ckWARN_d(WARN_UTF8))
789                 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
790             sv_setpvn(astr, s, send - s);
791             *s = '\0';
792             SvCUR_set(sv, s - start);
793             SvNIOK_off(sv);
794             SvUTF8_on(astr);
795         }
796         else
797             sv_setpvn(astr, "", 0);
798     }
799     else if (s && len) {
800         s += --len;
801         sv_setpvn(astr, s, 1);
802         *s = '\0';
803         SvCUR_set(sv, len);
804         SvUTF8_off(sv);
805         SvNIOK_off(sv);
806     }
807     else
808         sv_setpvn(astr, "", 0);
809     SvSETMAGIC(sv);
810 }
811
812 I32
813 Perl_do_chomp(pTHX_ register SV *sv)
814 {
815     dTHR;
816     register I32 count;
817     STRLEN len;
818     char *s;
819
820     if (RsSNARF(PL_rs))
821         return 0;
822     if (RsRECORD(PL_rs))
823       return 0;
824     count = 0;
825     if (SvTYPE(sv) == SVt_PVAV) {
826         register I32 i;
827         I32 max;
828         AV* av = (AV*)sv;
829         max = AvFILL(av);
830         for (i = 0; i <= max; i++) {
831             sv = (SV*)av_fetch(av, i, FALSE);
832             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
833                 count += do_chomp(sv);
834         }
835         return count;
836     }
837     else if (SvTYPE(sv) == SVt_PVHV) {
838         HV* hv = (HV*)sv;
839         HE* entry;
840         (void)hv_iterinit(hv);
841         /*SUPPRESS 560*/
842         while ((entry = hv_iternext(hv)))
843             count += do_chomp(hv_iterval(hv,entry));
844         return count;
845     }
846     else if (SvREADONLY(sv))
847         Perl_croak(aTHX_ PL_no_modify);
848     s = SvPV(sv, len);
849     if (len && !SvPOKp(sv))
850         s = SvPV_force(sv, len);
851     if (s && len) {
852         s += --len;
853         if (RsPARA(PL_rs)) {
854             if (*s != '\n')
855                 goto nope;
856             ++count;
857             while (len && s[-1] == '\n') {
858                 --len;
859                 --s;
860                 ++count;
861             }
862         }
863         else {
864             STRLEN rslen;
865             char *rsptr = SvPV(PL_rs, rslen);
866             if (rslen == 1) {
867                 if (*s != *rsptr)
868                     goto nope;
869                 ++count;
870             }
871             else {
872                 if (len < rslen - 1)
873                     goto nope;
874                 len -= rslen - 1;
875                 s -= rslen - 1;
876                 if (memNE(s, rsptr, rslen))
877                     goto nope;
878                 count += rslen;
879             }
880         }
881         *s = '\0';
882         SvCUR_set(sv, len);
883         SvNIOK_off(sv);
884     }
885   nope:
886     SvSETMAGIC(sv);
887     return count;
888
889
890 void
891 Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
892 {
893     dTHR;       /* just for taint */
894 #ifdef LIBERAL
895     register long *dl;
896     register long *ll;
897     register long *rl;
898 #endif
899     register char *dc;
900     STRLEN leftlen;
901     STRLEN rightlen;
902     register char *lc;
903     register char *rc;
904     register I32 len;
905     I32 lensave;
906     char *lsave;
907     char *rsave;
908     bool left_utf = DO_UTF8(left);
909     bool right_utf = DO_UTF8(right);
910     I32 needlen;
911
912     if (left_utf && !right_utf)
913         sv_utf8_upgrade(right);
914     if (!left_utf && right_utf)
915         sv_utf8_upgrade(left);
916
917     if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
918         sv_setpvn(sv, "", 0);   /* avoid undef warning on |= and ^= */
919     lsave = lc = SvPV(left, leftlen);
920     rsave = rc = SvPV(right, rightlen);
921     len = leftlen < rightlen ? leftlen : rightlen;
922     lensave = len;
923     if ((left_utf || right_utf) && (sv == left || sv == right)) {
924         needlen = optype == OP_BIT_AND ? len : leftlen + rightlen;
925         Newz(801, dc, needlen + 1, char);
926     }
927     else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
928         STRLEN n_a;
929         dc = SvPV_force(sv, n_a);
930         if (SvCUR(sv) < len) {
931             dc = SvGROW(sv, len + 1);
932             (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
933         }
934         if (optype != OP_BIT_AND && (left_utf || right_utf))
935             dc = SvGROW(sv, leftlen + rightlen + 1);
936     }
937     else {
938         needlen = ((optype == OP_BIT_AND)
939                     ? len : (leftlen > rightlen ? leftlen : rightlen));
940         Newz(801, dc, needlen + 1, char);
941         (void)sv_usepvn(sv, dc, needlen);
942         dc = SvPVX(sv);         /* sv_usepvn() calls Renew() */
943     }
944     SvCUR_set(sv, len);
945     (void)SvPOK_only(sv);
946     if (left_utf || right_utf) {
947         UV duc, luc, ruc;
948         char *dcsave = dc;
949         STRLEN lulen = leftlen;
950         STRLEN rulen = rightlen;
951         I32 ulen;
952
953         switch (optype) {
954         case OP_BIT_AND:
955             while (lulen && rulen) {
956                 luc = utf8_to_uv((U8*)lc, &ulen);
957                 lc += ulen;
958                 lulen -= ulen;
959                 ruc = utf8_to_uv((U8*)rc, &ulen);
960                 rc += ulen;
961                 rulen -= ulen;
962                 duc = luc & ruc;
963                 dc = (char*)uv_to_utf8((U8*)dc, duc);
964             }
965             if (sv == left || sv == right)
966                 (void)sv_usepvn(sv, dcsave, needlen);
967             SvCUR_set(sv, dc - dcsave);
968             break;
969         case OP_BIT_XOR:
970             while (lulen && rulen) {
971                 luc = utf8_to_uv((U8*)lc, &ulen);
972                 lc += ulen;
973                 lulen -= ulen;
974                 ruc = utf8_to_uv((U8*)rc, &ulen);
975                 rc += ulen;
976                 rulen -= ulen;
977                 duc = luc ^ ruc;
978                 dc = (char*)uv_to_utf8((U8*)dc, duc);
979             }
980             goto mop_up_utf;
981         case OP_BIT_OR:
982             while (lulen && rulen) {
983                 luc = utf8_to_uv((U8*)lc, &ulen);
984                 lc += ulen;
985                 lulen -= ulen;
986                 ruc = utf8_to_uv((U8*)rc, &ulen);
987                 rc += ulen;
988                 rulen -= ulen;
989                 duc = luc | ruc;
990                 dc = (char*)uv_to_utf8((U8*)dc, duc);
991             }
992           mop_up_utf:
993             if (sv == left || sv == right)
994                 (void)sv_usepvn(sv, dcsave, needlen);
995             SvCUR_set(sv, dc - dcsave);
996             if (rulen)
997                 sv_catpvn(sv, rc, rulen);
998             else if (lulen)
999                 sv_catpvn(sv, lc, lulen);
1000             else
1001                 *SvEND(sv) = '\0';
1002             break;
1003         }
1004         SvUTF8_on(sv);
1005         goto finish;
1006     }
1007     else
1008 #ifdef LIBERAL
1009     if (len >= sizeof(long)*4 &&
1010         !((long)dc % sizeof(long)) &&
1011         !((long)lc % sizeof(long)) &&
1012         !((long)rc % sizeof(long)))     /* It's almost always aligned... */
1013     {
1014         I32 remainder = len % (sizeof(long)*4);
1015         len /= (sizeof(long)*4);
1016
1017         dl = (long*)dc;
1018         ll = (long*)lc;
1019         rl = (long*)rc;
1020
1021         switch (optype) {
1022         case OP_BIT_AND:
1023             while (len--) {
1024                 *dl++ = *ll++ & *rl++;
1025                 *dl++ = *ll++ & *rl++;
1026                 *dl++ = *ll++ & *rl++;
1027                 *dl++ = *ll++ & *rl++;
1028             }
1029             break;
1030         case OP_BIT_XOR:
1031             while (len--) {
1032                 *dl++ = *ll++ ^ *rl++;
1033                 *dl++ = *ll++ ^ *rl++;
1034                 *dl++ = *ll++ ^ *rl++;
1035                 *dl++ = *ll++ ^ *rl++;
1036             }
1037             break;
1038         case OP_BIT_OR:
1039             while (len--) {
1040                 *dl++ = *ll++ | *rl++;
1041                 *dl++ = *ll++ | *rl++;
1042                 *dl++ = *ll++ | *rl++;
1043                 *dl++ = *ll++ | *rl++;
1044             }
1045         }
1046
1047         dc = (char*)dl;
1048         lc = (char*)ll;
1049         rc = (char*)rl;
1050
1051         len = remainder;
1052     }
1053 #endif
1054     {
1055         switch (optype) {
1056         case OP_BIT_AND:
1057             while (len--)
1058                 *dc++ = *lc++ & *rc++;
1059             break;
1060         case OP_BIT_XOR:
1061             while (len--)
1062                 *dc++ = *lc++ ^ *rc++;
1063             goto mop_up;
1064         case OP_BIT_OR:
1065             while (len--)
1066                 *dc++ = *lc++ | *rc++;
1067           mop_up:
1068             len = lensave;
1069             if (rightlen > len)
1070                 sv_catpvn(sv, rsave + len, rightlen - len);
1071             else if (leftlen > len)
1072                 sv_catpvn(sv, lsave + len, leftlen - len);
1073             else
1074                 *SvEND(sv) = '\0';
1075             break;
1076         }
1077     }
1078 finish:
1079     SvTAINT(sv);
1080 }
1081
1082 OP *
1083 Perl_do_kv(pTHX)
1084 {
1085     djSP;
1086     HV *hv = (HV*)POPs;
1087     HV *keys;
1088     register HE *entry;
1089     SV *tmpstr;
1090     I32 gimme = GIMME_V;
1091     I32 dokeys =   (PL_op->op_type == OP_KEYS);
1092     I32 dovalues = (PL_op->op_type == OP_VALUES);
1093     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
1094     
1095     if (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV) 
1096         dokeys = dovalues = TRUE;
1097
1098     if (!hv) {
1099         if (PL_op->op_flags & OPf_MOD) {        /* lvalue */
1100             dTARGET;            /* make sure to clear its target here */
1101             if (SvTYPE(TARG) == SVt_PVLV)
1102                 LvTARG(TARG) = Nullsv;
1103             PUSHs(TARG);
1104         }
1105         RETURN;
1106     }
1107
1108     keys = realhv ? hv : avhv_keys((AV*)hv);
1109     (void)hv_iterinit(keys);    /* always reset iterator regardless */
1110
1111     if (gimme == G_VOID)
1112         RETURN;
1113
1114     if (gimme == G_SCALAR) {
1115         IV i;
1116         dTARGET;
1117
1118         if (PL_op->op_flags & OPf_MOD) {        /* lvalue */
1119             if (SvTYPE(TARG) < SVt_PVLV) {
1120                 sv_upgrade(TARG, SVt_PVLV);
1121                 sv_magic(TARG, Nullsv, 'k', Nullch, 0);
1122             }
1123             LvTYPE(TARG) = 'k';
1124             if (LvTARG(TARG) != (SV*)keys) {
1125                 if (LvTARG(TARG))
1126                     SvREFCNT_dec(LvTARG(TARG));
1127                 LvTARG(TARG) = SvREFCNT_inc(keys);
1128             }
1129             PUSHs(TARG);
1130             RETURN;
1131         }
1132
1133         if (! SvTIED_mg((SV*)keys, 'P'))
1134             i = HvKEYS(keys);
1135         else {
1136             i = 0;
1137             /*SUPPRESS 560*/
1138             while (hv_iternext(keys)) i++;
1139         }
1140         PUSHi( i );
1141         RETURN;
1142     }
1143
1144     EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
1145
1146     PUTBACK;    /* hv_iternext and hv_iterval might clobber stack_sp */
1147     while ((entry = hv_iternext(keys))) {
1148         SPAGAIN;
1149         if (dokeys)
1150             XPUSHs(hv_iterkeysv(entry));        /* won't clobber stack_sp */
1151         if (dovalues) {
1152             PUTBACK;
1153             tmpstr = realhv ?
1154                      hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry);
1155             DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
1156                             (unsigned long)HeHASH(entry),
1157                             HvMAX(keys)+1,
1158                             (unsigned long)(HeHASH(entry) & HvMAX(keys))));
1159             SPAGAIN;
1160             XPUSHs(tmpstr);
1161         }
1162         PUTBACK;
1163     }
1164     return NORMAL;
1165 }
1166