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