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