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