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