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