8bff60aa0a1a3ebdcb9507e9ec25de65d4ebba35
[perl.git] / doop.c
1 /*    doop.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2004, 2005, 2006, 2007, by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * "'So that was the job I felt I had to do when I started,' thought Sam."
13  */
14
15 /* This file contains some common functions needed to carry out certain
16  * ops. For example both pp_schomp() and pp_chomp() - scalar and array
17  * chomp operations - call the function do_chomp() found in this file.
18  */
19
20 #include "EXTERN.h"
21 #define PERL_IN_DOOP_C
22 #include "perl.h"
23
24 #ifndef PERL_MICRO
25 #include <signal.h>
26 #endif
27
28 STATIC I32
29 S_do_trans_simple(pTHX_ SV * const sv)
30 {
31     dVAR;
32     I32 matches = 0;
33     STRLEN len;
34     U8 *s = (U8*)SvPV(sv,len);
35     U8 * const send = s+len;
36     const short * const tbl = (short*)cPVOP->op_pv;
37
38     PERL_ARGS_ASSERT_DO_TRANS_SIMPLE;
39
40     if (!tbl)
41         Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__);
42
43     /* First, take care of non-UTF-8 input strings, because they're easy */
44     if (!SvUTF8(sv)) {
45         while (s < send) {
46             const I32 ch = tbl[*s];
47             if (ch >= 0) {
48                 matches++;
49                 *s = (U8)ch;
50             }
51             s++;
52         }
53         SvSETMAGIC(sv);
54     }
55     else {
56         const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
57         U8 *d;
58         U8 *dstart;
59
60         /* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
61         if (grows)
62             Newx(d, len*2+1, U8);
63         else
64             d = s;
65         dstart = d;
66         while (s < send) {
67             STRLEN ulen;
68             I32 ch;
69
70             /* Need to check this, otherwise 128..255 won't match */
71             const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT);
72             if (c < 0x100 && (ch = tbl[c]) >= 0) {
73                 matches++;
74                 d = uvchr_to_utf8(d, ch);
75                 s += ulen;
76             }
77             else { /* No match -> copy */
78                 Move(s, d, ulen, U8);
79                 d += ulen;
80                 s += ulen;
81             }
82         }
83         if (grows) {
84             sv_setpvn(sv, (char*)dstart, d - dstart);
85             Safefree(dstart);
86         }
87         else {
88             *d = '\0';
89             SvCUR_set(sv, d - dstart);
90         }
91         SvUTF8_on(sv);
92         SvSETMAGIC(sv);
93     }
94     return matches;
95 }
96
97 STATIC I32
98 S_do_trans_count(pTHX_ SV * const sv)
99 {
100     dVAR;
101     STRLEN len;
102     const U8 *s = (const U8*)SvPV_const(sv, len);
103     const U8 * const send = s + len;
104     I32 matches = 0;
105     const short * const tbl = (short*)cPVOP->op_pv;
106
107     PERL_ARGS_ASSERT_DO_TRANS_COUNT;
108
109     if (!tbl)
110         Perl_croak(aTHX_ "panic: do_trans_count line %d",__LINE__);
111
112     if (!SvUTF8(sv)) {
113         while (s < send) {
114             if (tbl[*s++] >= 0)
115                 matches++;
116         }
117     }
118     else {
119         const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
120         while (s < send) {
121             STRLEN ulen;
122             const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT);
123             if (c < 0x100) {
124                 if (tbl[c] >= 0)
125                     matches++;
126             } else if (complement)
127                 matches++;
128             s += ulen;
129         }
130     }
131
132     return matches;
133 }
134
135 STATIC I32
136 S_do_trans_complex(pTHX_ SV * const sv)
137 {
138     dVAR;
139     STRLEN len;
140     U8 *s = (U8*)SvPV(sv, len);
141     U8 * const send = s+len;
142     I32 matches = 0;
143     const short * const tbl = (short*)cPVOP->op_pv;
144
145     PERL_ARGS_ASSERT_DO_TRANS_COMPLEX;
146
147     if (!tbl)
148         Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__);
149
150     if (!SvUTF8(sv)) {
151         U8 *d = s;
152         U8 * const dstart = d;
153
154         if (PL_op->op_private & OPpTRANS_SQUASH) {
155             const U8* p = send;
156             while (s < send) {
157                 const I32 ch = tbl[*s];
158                 if (ch >= 0) {
159                     *d = (U8)ch;
160                     matches++;
161                     if (p != d - 1 || *p != *d)
162                         p = d++;
163                 }
164                 else if (ch == -1)      /* -1 is unmapped character */
165                     *d++ = *s;  
166                 else if (ch == -2)      /* -2 is delete character */
167                     matches++;
168                 s++;
169             }
170         }
171         else {
172             while (s < send) {
173                 const I32 ch = tbl[*s];
174                 if (ch >= 0) {
175                     matches++;
176                     *d++ = (U8)ch;
177                 }
178                 else if (ch == -1)      /* -1 is unmapped character */
179                     *d++ = *s;
180                 else if (ch == -2)      /* -2 is delete character */
181                     matches++;
182                 s++;
183             }
184         }
185         *d = '\0';
186         SvCUR_set(sv, d - dstart);
187     }
188     else { /* is utf8 */
189         const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
190         const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
191         const I32 del = PL_op->op_private & OPpTRANS_DELETE;
192         U8 *d;
193         U8 *dstart;
194         STRLEN rlen = 0;
195
196         if (grows)
197             Newx(d, len*2+1, U8);
198         else
199             d = s;
200         dstart = d;
201         if (complement && !del)
202             rlen = tbl[0x100];
203
204 #ifdef MACOS_TRADITIONAL
205 #define comp CoMP   /* "comp" is a keyword in some compilers ... */
206 #endif
207
208         if (PL_op->op_private & OPpTRANS_SQUASH) {
209             UV pch = 0xfeedface;
210             while (s < send) {
211                 STRLEN len;
212                 const UV comp = utf8n_to_uvchr(s, send - s, &len,
213                                                UTF8_ALLOW_DEFAULT);
214                 I32 ch;
215
216                 if (comp > 0xff) {
217                     if (!complement) {
218                         Move(s, d, len, U8);
219                         d += len;
220                     }
221                     else {
222                         matches++;
223                         if (!del) {
224                             ch = (rlen == 0) ? (I32)comp :
225                                 (comp - 0x100 < rlen) ?
226                                 tbl[comp+1] : tbl[0x100+rlen];
227                             if ((UV)ch != pch) {
228                                 d = uvchr_to_utf8(d, ch);
229                                 pch = (UV)ch;
230                             }
231                             s += len;
232                             continue;
233                         }
234                     }
235                 }
236                 else if ((ch = tbl[comp]) >= 0) {
237                     matches++;
238                     if ((UV)ch != pch) {
239                         d = uvchr_to_utf8(d, ch);
240                         pch = (UV)ch;
241                     }
242                     s += len;
243                     continue;
244                 }
245                 else if (ch == -1) {    /* -1 is unmapped character */
246                     Move(s, d, len, U8);
247                     d += len;
248                 }
249                 else if (ch == -2)      /* -2 is delete character */
250                     matches++;
251                 s += len;
252                 pch = 0xfeedface;
253             }
254         }
255         else {
256             while (s < send) {
257                 STRLEN len;
258                 const UV comp = utf8n_to_uvchr(s, send - s, &len,
259                                                UTF8_ALLOW_DEFAULT);
260                 I32 ch;
261                 if (comp > 0xff) {
262                     if (!complement) {
263                         Move(s, d, len, U8);
264                         d += len;
265                     }
266                     else {
267                         matches++;
268                         if (!del) {
269                             if (comp - 0x100 < rlen)
270                                 d = uvchr_to_utf8(d, tbl[comp+1]);
271                             else
272                                 d = uvchr_to_utf8(d, tbl[0x100+rlen]);
273                         }
274                     }
275                 }
276                 else if ((ch = tbl[comp]) >= 0) {
277                     d = uvchr_to_utf8(d, ch);
278                     matches++;
279                 }
280                 else if (ch == -1) {    /* -1 is unmapped character */
281                     Move(s, d, len, U8);
282                     d += len;
283                 }
284                 else if (ch == -2)      /* -2 is delete character */
285                     matches++;
286                 s += len;
287             }
288         }
289         if (grows) {
290             sv_setpvn(sv, (char*)dstart, d - dstart);
291             Safefree(dstart);
292         }
293         else {
294             *d = '\0';
295             SvCUR_set(sv, d - dstart);
296         }
297         SvUTF8_on(sv);
298     }
299     SvSETMAGIC(sv);
300     return matches;
301 }
302
303 STATIC I32
304 S_do_trans_simple_utf8(pTHX_ SV * const sv)
305 {
306     dVAR;
307     U8 *s;
308     U8 *send;
309     U8 *d;
310     U8 *start;
311     U8 *dstart, *dend;
312     I32 matches = 0;
313     const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
314     STRLEN len;
315     SV* const  rv =
316 #ifdef USE_ITHREADS
317                     PAD_SVl(cPADOP->op_padix);
318 #else
319                     (SV*)cSVOP->op_sv;
320 #endif
321     HV* const  hv = (HV*)SvRV(rv);
322     SV* const * svp = hv_fetchs(hv, "NONE", FALSE);
323     const UV none = svp ? SvUV(*svp) : 0x7fffffff;
324     const UV extra = none + 1;
325     UV final = 0;
326     U8 hibit = 0;
327
328     PERL_ARGS_ASSERT_DO_TRANS_SIMPLE_UTF8;
329
330     s = (U8*)SvPV(sv, len);
331     if (!SvUTF8(sv)) {
332         const U8 *t = s;
333         const U8 * const e = s + len;
334         while (t < e) {
335             const U8 ch = *t++;
336             hibit = !NATIVE_IS_INVARIANT(ch);
337             if (hibit) {
338                 s = bytes_to_utf8(s, &len);
339                 break;
340             }
341         }
342     }
343     send = s + len;
344     start = s;
345
346     svp = hv_fetchs(hv, "FINAL", FALSE);
347     if (svp)
348         final = SvUV(*svp);
349
350     if (grows) {
351         /* d needs to be bigger than s, in case e.g. upgrading is required */
352         Newx(d, len * 3 + UTF8_MAXBYTES, U8);
353         dend = d + len * 3;
354         dstart = d;
355     }
356     else {
357         dstart = d = s;
358         dend = d + len;
359     }
360
361     while (s < send) {
362         const UV uv = swash_fetch(rv, s, TRUE);
363         if (uv < none) {
364             s += UTF8SKIP(s);
365             matches++;
366             d = uvuni_to_utf8(d, uv);
367         }
368         else if (uv == none) {
369             const int i = UTF8SKIP(s);
370             Move(s, d, i, U8);
371             d += i;
372             s += i;
373         }
374         else if (uv == extra) {
375             s += UTF8SKIP(s);
376             matches++;
377             d = uvuni_to_utf8(d, final);
378         }
379         else
380             s += UTF8SKIP(s);
381
382         if (d > dend) {
383             const STRLEN clen = d - dstart;
384             const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
385             if (!grows)
386                 Perl_croak(aTHX_ "panic: do_trans_simple_utf8 line %d",__LINE__);
387             Renew(dstart, nlen + UTF8_MAXBYTES, U8);
388             d = dstart + clen;
389             dend = dstart + nlen;
390         }
391     }
392     if (grows || hibit) {
393         sv_setpvn(sv, (char*)dstart, d - dstart);
394         Safefree(dstart);
395         if (grows && hibit)
396             Safefree(start);
397     }
398     else {
399         *d = '\0';
400         SvCUR_set(sv, d - dstart);
401     }
402     SvSETMAGIC(sv);
403     SvUTF8_on(sv);
404
405     return matches;
406 }
407
408 STATIC I32
409 S_do_trans_count_utf8(pTHX_ SV * const sv)
410 {
411     dVAR;
412     const U8 *s;
413     const U8 *start = NULL;
414     const U8 *send;
415     I32 matches = 0;
416     STRLEN len;
417     SV* const  rv =
418 #ifdef USE_ITHREADS
419                     PAD_SVl(cPADOP->op_padix);
420 #else
421                     (SV*)cSVOP->op_sv;
422 #endif
423     HV* const hv = (HV*)SvRV(rv);
424     SV* const * const svp = hv_fetchs(hv, "NONE", FALSE);
425     const UV none = svp ? SvUV(*svp) : 0x7fffffff;
426     const UV extra = none + 1;
427     U8 hibit = 0;
428
429     PERL_ARGS_ASSERT_DO_TRANS_COUNT_UTF8;
430
431     s = (const U8*)SvPV_const(sv, len);
432     if (!SvUTF8(sv)) {
433         const U8 *t = s;
434         const U8 * const e = s + len;
435         while (t < e) {
436             const U8 ch = *t++;
437             hibit = !NATIVE_IS_INVARIANT(ch);
438             if (hibit) {
439                 start = s = bytes_to_utf8(s, &len);
440                 break;
441             }
442         }
443     }
444     send = s + len;
445
446     while (s < send) {
447         const UV uv = swash_fetch(rv, s, TRUE);
448         if (uv < none || uv == extra)
449             matches++;
450         s += UTF8SKIP(s);
451     }
452     if (hibit)
453         Safefree(start);
454
455     return matches;
456 }
457
458 STATIC I32
459 S_do_trans_complex_utf8(pTHX_ SV * const sv)
460 {
461     dVAR;
462     U8 *start, *send;
463     U8 *d;
464     I32 matches = 0;
465     const I32 squash   = PL_op->op_private & OPpTRANS_SQUASH;
466     const I32 del      = PL_op->op_private & OPpTRANS_DELETE;
467     const I32 grows    = PL_op->op_private & OPpTRANS_GROWS;
468     SV* const  rv =
469 #ifdef USE_ITHREADS
470                     PAD_SVl(cPADOP->op_padix);
471 #else
472                     (SV*)cSVOP->op_sv;
473 #endif
474     HV * const hv = (HV*)SvRV(rv);
475     SV * const *svp = hv_fetchs(hv, "NONE", FALSE);
476     const UV none = svp ? SvUV(*svp) : 0x7fffffff;
477     const UV extra = none + 1;
478     UV final = 0;
479     bool havefinal = FALSE;
480     STRLEN len;
481     U8 *dstart, *dend;
482     U8 hibit = 0;
483     U8 *s = (U8*)SvPV(sv, len);
484
485     PERL_ARGS_ASSERT_DO_TRANS_COMPLEX_UTF8;
486
487     if (!SvUTF8(sv)) {
488         const U8 *t = s;
489         const U8 * const e = s + len;
490         while (t < e) {
491             const U8 ch = *t++;
492             hibit = !NATIVE_IS_INVARIANT(ch);
493             if (hibit) {
494                 s = bytes_to_utf8(s, &len);
495                 break;
496             }
497         }
498     }
499     send = s + len;
500     start = s;
501
502     svp = hv_fetchs(hv, "FINAL", FALSE);
503     if (svp) {
504         final = SvUV(*svp);
505         havefinal = TRUE;
506     }
507
508     if (grows) {
509         /* d needs to be bigger than s, in case e.g. upgrading is required */
510         Newx(d, len * 3 + UTF8_MAXBYTES, U8);
511         dend = d + len * 3;
512         dstart = d;
513     }
514     else {
515         dstart = d = s;
516         dend = d + len;
517     }
518
519     if (squash) {
520         UV puv = 0xfeedface;
521         while (s < send) {
522             UV uv = swash_fetch(rv, s, TRUE);
523         
524             if (d > dend) {
525                 const STRLEN clen = d - dstart;
526                 const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
527                 if (!grows)
528                     Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
529                 Renew(dstart, nlen + UTF8_MAXBYTES, U8);
530                 d = dstart + clen;
531                 dend = dstart + nlen;
532             }
533             if (uv < none) {
534                 matches++;
535                 s += UTF8SKIP(s);
536                 if (uv != puv) {
537                     d = uvuni_to_utf8(d, uv);
538                     puv = uv;
539                 }
540                 continue;
541             }
542             else if (uv == none) {      /* "none" is unmapped character */
543                 const int i = UTF8SKIP(s);
544                 Move(s, d, i, U8);
545                 d += i;
546                 s += i;
547                 puv = 0xfeedface;
548                 continue;
549             }
550             else if (uv == extra && !del) {
551                 matches++;
552                 if (havefinal) {
553                     s += UTF8SKIP(s);
554                     if (puv != final) {
555                         d = uvuni_to_utf8(d, final);
556                         puv = final;
557                     }
558                 }
559                 else {
560                     STRLEN len;
561                     uv = utf8n_to_uvuni(s, send - s, &len, UTF8_ALLOW_DEFAULT);
562                     if (uv != puv) {
563                         Move(s, d, len, U8);
564                         d += len;
565                         puv = uv;
566                     }
567                     s += len;
568                 }
569                 continue;
570             }
571             matches++;                  /* "none+1" is delete character */
572             s += UTF8SKIP(s);
573         }
574     }
575     else {
576         while (s < send) {
577             const UV uv = swash_fetch(rv, s, TRUE);
578             if (d > dend) {
579                 const STRLEN clen = d - dstart;
580                 const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
581                 if (!grows)
582                     Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
583                 Renew(dstart, nlen + UTF8_MAXBYTES, U8);
584                 d = dstart + clen;
585                 dend = dstart + nlen;
586             }
587             if (uv < none) {
588                 matches++;
589                 s += UTF8SKIP(s);
590                 d = uvuni_to_utf8(d, uv);
591                 continue;
592             }
593             else if (uv == none) {      /* "none" is unmapped character */
594                 const int i = UTF8SKIP(s);
595                 Move(s, d, i, U8);
596                 d += i;
597                 s += i;
598                 continue;
599             }
600             else if (uv == extra && !del) {
601                 matches++;
602                 s += UTF8SKIP(s);
603                 d = uvuni_to_utf8(d, final);
604                 continue;
605             }
606             matches++;                  /* "none+1" is delete character */
607             s += UTF8SKIP(s);
608         }
609     }
610     if (grows || hibit) {
611         sv_setpvn(sv, (char*)dstart, d - dstart);
612         Safefree(dstart);
613         if (grows && hibit)
614             Safefree(start);
615     }
616     else {
617         *d = '\0';
618         SvCUR_set(sv, d - dstart);
619     }
620     SvUTF8_on(sv);
621     SvSETMAGIC(sv);
622
623     return matches;
624 }
625
626 I32
627 Perl_do_trans(pTHX_ SV *sv)
628 {
629     dVAR;
630     STRLEN len;
631     const I32 hasutf = (PL_op->op_private &
632                     (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
633
634     PERL_ARGS_ASSERT_DO_TRANS;
635
636     if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) {
637         if (SvIsCOW(sv))
638             sv_force_normal_flags(sv, 0);
639         if (SvREADONLY(sv))
640             Perl_croak(aTHX_ PL_no_modify);
641     }
642     (void)SvPV_const(sv, len);
643     if (!len)
644         return 0;
645     if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) {
646         if (!SvPOKp(sv))
647             (void)SvPV_force(sv, len);
648         (void)SvPOK_only_UTF8(sv);
649     }
650
651     DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
652
653     switch (PL_op->op_private & ~hasutf & (
654                 OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|
655                 OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) {
656     case 0:
657         if (hasutf)
658             return do_trans_simple_utf8(sv);
659         else
660             return do_trans_simple(sv);
661
662     case OPpTRANS_IDENTICAL:
663     case OPpTRANS_IDENTICAL|OPpTRANS_COMPLEMENT:
664         if (hasutf)
665             return do_trans_count_utf8(sv);
666         else
667             return do_trans_count(sv);
668
669     default:
670         if (hasutf)
671             return do_trans_complex_utf8(sv);
672         else
673             return do_trans_complex(sv);
674     }
675 }
676
677 void
678 Perl_do_join(pTHX_ register SV *sv, SV *delim, register SV **mark, register SV **sp)
679 {
680     dVAR;
681     SV ** const oldmark = mark;
682     register I32 items = sp - mark;
683     register STRLEN len;
684     STRLEN delimlen;
685
686     PERL_ARGS_ASSERT_DO_JOIN;
687
688     (void) SvPV_const(delim, delimlen); /* stringify and get the delimlen */
689     /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */
690
691     mark++;
692     len = (items > 0 ? (delimlen * (items - 1) ) : 0);
693     SvUPGRADE(sv, SVt_PV);
694     if (SvLEN(sv) < len + items) {      /* current length is way too short */
695         while (items-- > 0) {
696             if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) {
697                 STRLEN tmplen;
698                 SvPV_const(*mark, tmplen);
699                 len += tmplen;
700             }
701             mark++;
702         }
703         SvGROW(sv, len + 1);            /* so try to pre-extend */
704
705         mark = oldmark;
706         items = sp - mark;
707         ++mark;
708     }
709
710     sv_setpvn(sv, "", 0);
711     /* sv_setpv retains old UTF8ness [perl #24846] */
712     SvUTF8_off(sv);
713
714     if (PL_tainting && SvMAGICAL(sv))
715         SvTAINTED_off(sv);
716
717     if (items-- > 0) {
718         if (*mark)
719             sv_catsv(sv, *mark);
720         mark++;
721     }
722
723     if (delimlen) {
724         for (; items > 0; items--,mark++) {
725             sv_catsv(sv,delim);
726             sv_catsv(sv,*mark);
727         }
728     }
729     else {
730         for (; items > 0; items--,mark++)
731             sv_catsv(sv,*mark);
732     }
733     SvSETMAGIC(sv);
734 }
735
736 void
737 Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
738 {
739     dVAR;
740     STRLEN patlen;
741     const char * const pat = SvPV_const(*sarg, patlen);
742     bool do_taint = FALSE;
743
744     PERL_ARGS_ASSERT_DO_SPRINTF;
745
746     SvUTF8_off(sv);
747     if (DO_UTF8(*sarg))
748         SvUTF8_on(sv);
749     sv_vsetpvfn(sv, pat, patlen, NULL, sarg + 1, len - 1, &do_taint);
750     SvSETMAGIC(sv);
751     if (do_taint)
752         SvTAINTED_on(sv);
753 }
754
755 /* currently converts input to bytes if possible, but doesn't sweat failure */
756 UV
757 Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
758 {
759     dVAR;
760     STRLEN srclen, len, uoffset, bitoffs = 0;
761     const unsigned char *s = (const unsigned char *) SvPV_const(sv, srclen);
762     UV retnum = 0;
763
764     PERL_ARGS_ASSERT_DO_VECGET;
765
766     if (offset < 0)
767         return 0;
768     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
769         Perl_croak(aTHX_ "Illegal number of bits in vec");
770
771     if (SvUTF8(sv))
772         (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE);
773
774     if (size < 8) {
775         bitoffs = ((offset%8)*size)%8;
776         uoffset = offset/(8/size);
777     }
778     else if (size > 8)
779         uoffset = offset*(size/8);
780     else
781         uoffset = offset;
782
783     len = uoffset + (bitoffs + size + 7)/8;     /* required number of bytes */
784     if (len > srclen) {
785         if (size <= 8)
786             retnum = 0;
787         else {
788             if (size == 16) {
789                 if (uoffset >= srclen)
790                     retnum = 0;
791                 else
792                     retnum = (UV) s[uoffset] <<  8;
793             }
794             else if (size == 32) {
795                 if (uoffset >= srclen)
796                     retnum = 0;
797                 else if (uoffset + 1 >= srclen)
798                     retnum =
799                         ((UV) s[uoffset    ] << 24);
800                 else if (uoffset + 2 >= srclen)
801                     retnum =
802                         ((UV) s[uoffset    ] << 24) +
803                         ((UV) s[uoffset + 1] << 16);
804                 else
805                     retnum =
806                         ((UV) s[uoffset    ] << 24) +
807                         ((UV) s[uoffset + 1] << 16) +
808                         (     s[uoffset + 2] <<  8);
809             }
810 #ifdef UV_IS_QUAD
811             else if (size == 64) {
812                 if (ckWARN(WARN_PORTABLE))
813                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
814                                 "Bit vector size > 32 non-portable");
815                 if (uoffset >= srclen)
816                     retnum = 0;
817                 else if (uoffset + 1 >= srclen)
818                     retnum =
819                         (UV) s[uoffset     ] << 56;
820                 else if (uoffset + 2 >= srclen)
821                     retnum =
822                         ((UV) s[uoffset    ] << 56) +
823                         ((UV) s[uoffset + 1] << 48);
824                 else if (uoffset + 3 >= srclen)
825                     retnum =
826                         ((UV) s[uoffset    ] << 56) +
827                         ((UV) s[uoffset + 1] << 48) +
828                         ((UV) s[uoffset + 2] << 40);
829                 else if (uoffset + 4 >= srclen)
830                     retnum =
831                         ((UV) s[uoffset    ] << 56) +
832                         ((UV) s[uoffset + 1] << 48) +
833                         ((UV) s[uoffset + 2] << 40) +
834                         ((UV) s[uoffset + 3] << 32);
835                 else if (uoffset + 5 >= srclen)
836                     retnum =
837                         ((UV) s[uoffset    ] << 56) +
838                         ((UV) s[uoffset + 1] << 48) +
839                         ((UV) s[uoffset + 2] << 40) +
840                         ((UV) s[uoffset + 3] << 32) +
841                         (     s[uoffset + 4] << 24);
842                 else if (uoffset + 6 >= srclen)
843                     retnum =
844                         ((UV) s[uoffset    ] << 56) +
845                         ((UV) s[uoffset + 1] << 48) +
846                         ((UV) s[uoffset + 2] << 40) +
847                         ((UV) s[uoffset + 3] << 32) +
848                         ((UV) s[uoffset + 4] << 24) +
849                         ((UV) s[uoffset + 5] << 16);
850                 else
851                     retnum =
852                         ((UV) s[uoffset    ] << 56) +
853                         ((UV) s[uoffset + 1] << 48) +
854                         ((UV) s[uoffset + 2] << 40) +
855                         ((UV) s[uoffset + 3] << 32) +
856                         ((UV) s[uoffset + 4] << 24) +
857                         ((UV) s[uoffset + 5] << 16) +
858                         (     s[uoffset + 6] <<  8);
859             }
860 #endif
861         }
862     }
863     else if (size < 8)
864         retnum = (s[uoffset] >> bitoffs) & ((1 << size) - 1);
865     else {
866         if (size == 8)
867             retnum = s[uoffset];
868         else if (size == 16)
869             retnum =
870                 ((UV) s[uoffset] <<      8) +
871                       s[uoffset + 1];
872         else if (size == 32)
873             retnum =
874                 ((UV) s[uoffset    ] << 24) +
875                 ((UV) s[uoffset + 1] << 16) +
876                 (     s[uoffset + 2] <<  8) +
877                       s[uoffset + 3];
878 #ifdef UV_IS_QUAD
879         else if (size == 64) {
880             if (ckWARN(WARN_PORTABLE))
881                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
882                             "Bit vector size > 32 non-portable");
883             retnum =
884                 ((UV) s[uoffset    ] << 56) +
885                 ((UV) s[uoffset + 1] << 48) +
886                 ((UV) s[uoffset + 2] << 40) +
887                 ((UV) s[uoffset + 3] << 32) +
888                 ((UV) s[uoffset + 4] << 24) +
889                 ((UV) s[uoffset + 5] << 16) +
890                 (     s[uoffset + 6] <<  8) +
891                       s[uoffset + 7];
892         }
893 #endif
894     }
895
896     return retnum;
897 }
898
899 /* currently converts input to bytes if possible but doesn't sweat failures,
900  * although it does ensure that the string it clobbers is not marked as
901  * utf8-valid any more
902  */
903 void
904 Perl_do_vecset(pTHX_ SV *sv)
905 {
906     dVAR;
907     register I32 offset, bitoffs = 0;
908     register I32 size;
909     register unsigned char *s;
910     register UV lval;
911     I32 mask;
912     STRLEN targlen;
913     STRLEN len;
914     SV * const targ = LvTARG(sv);
915
916     PERL_ARGS_ASSERT_DO_VECSET;
917
918     if (!targ)
919         return;
920     s = (unsigned char*)SvPV_force(targ, targlen);
921     if (SvUTF8(targ)) {
922         /* This is handled by the SvPOK_only below...
923         if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
924             SvUTF8_off(targ);
925          */
926         (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
927     }
928
929     (void)SvPOK_only(targ);
930     lval = SvUV(sv);
931     offset = LvTARGOFF(sv);
932     if (offset < 0)
933         Perl_croak(aTHX_ "Negative offset to vec in lvalue context");
934     size = LvTARGLEN(sv);
935     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
936         Perl_croak(aTHX_ "Illegal number of bits in vec");
937
938     if (size < 8) {
939         bitoffs = ((offset%8)*size)%8;
940         offset /= 8/size;
941     }
942     else if (size > 8)
943         offset *= size/8;
944
945     len = offset + (bitoffs + size + 7)/8;      /* required number of bytes */
946     if (len > targlen) {
947         s = (unsigned char*)SvGROW(targ, len + 1);
948         (void)memzero((char *)(s + targlen), len - targlen + 1);
949         SvCUR_set(targ, len);
950     }
951
952     if (size < 8) {
953         mask = (1 << size) - 1;
954         lval &= mask;
955         s[offset] &= ~(mask << bitoffs);
956         s[offset] |= lval << bitoffs;
957     }
958     else {
959         if (size == 8)
960             s[offset  ] = (U8)( lval        & 0xff);
961         else if (size == 16) {
962             s[offset  ] = (U8)((lval >>  8) & 0xff);
963             s[offset+1] = (U8)( lval        & 0xff);
964         }
965         else if (size == 32) {
966             s[offset  ] = (U8)((lval >> 24) & 0xff);
967             s[offset+1] = (U8)((lval >> 16) & 0xff);
968             s[offset+2] = (U8)((lval >>  8) & 0xff);
969             s[offset+3] = (U8)( lval        & 0xff);
970         }
971 #ifdef UV_IS_QUAD
972         else if (size == 64) {
973             if (ckWARN(WARN_PORTABLE))
974                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
975                             "Bit vector size > 32 non-portable");
976             s[offset  ] = (U8)((lval >> 56) & 0xff);
977             s[offset+1] = (U8)((lval >> 48) & 0xff);
978             s[offset+2] = (U8)((lval >> 40) & 0xff);
979             s[offset+3] = (U8)((lval >> 32) & 0xff);
980             s[offset+4] = (U8)((lval >> 24) & 0xff);
981             s[offset+5] = (U8)((lval >> 16) & 0xff);
982             s[offset+6] = (U8)((lval >>  8) & 0xff);
983             s[offset+7] = (U8)( lval        & 0xff);
984         }
985 #endif
986     }
987     SvSETMAGIC(targ);
988 }
989
990 void
991 Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
992 {
993     dVAR;
994     STRLEN len;
995     char *s;
996
997     PERL_ARGS_ASSERT_DO_CHOP;
998
999     if (SvTYPE(sv) == SVt_PVAV) {
1000         register I32 i;
1001         AV* const av = (AV*)sv;
1002         const I32 max = AvFILL(av);
1003
1004         for (i = 0; i <= max; i++) {
1005             sv = (SV*)av_fetch(av, i, FALSE);
1006             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
1007                 do_chop(astr, sv);
1008         }
1009         return;
1010     }
1011     else if (SvTYPE(sv) == SVt_PVHV) {
1012         HV* const hv = (HV*)sv;
1013         HE* entry;
1014         (void)hv_iterinit(hv);
1015         while ((entry = hv_iternext(hv)))
1016             do_chop(astr,hv_iterval(hv,entry));
1017         return;
1018     }
1019     else if (SvREADONLY(sv)) {
1020         if (SvFAKE(sv)) {
1021             /* SV is copy-on-write */
1022             sv_force_normal_flags(sv, 0);
1023         }
1024         if (SvREADONLY(sv))
1025             Perl_croak(aTHX_ PL_no_modify);
1026     }
1027
1028     if (PL_encoding && !SvUTF8(sv)) {
1029         /* like in do_chomp(), utf8-ize the sv as a side-effect
1030          * if we're using encoding. */
1031         sv_recode_to_utf8(sv, PL_encoding);
1032     }
1033
1034     s = SvPV(sv, len);
1035     if (len && !SvPOK(sv))
1036         s = SvPV_force_nomg(sv, len);
1037     if (DO_UTF8(sv)) {
1038         if (s && len) {
1039             char * const send = s + len;
1040             char * const start = s;
1041             s = send - 1;
1042             while (s > start && UTF8_IS_CONTINUATION(*s))
1043                 s--;
1044             if (is_utf8_string((U8*)s, send - s)) {
1045                 sv_setpvn(astr, s, send - s);
1046                 *s = '\0';
1047                 SvCUR_set(sv, s - start);
1048                 SvNIOK_off(sv);
1049                 SvUTF8_on(astr);
1050             }
1051         }
1052         else
1053             sv_setpvn(astr, "", 0);
1054     }
1055     else if (s && len) {
1056         s += --len;
1057         sv_setpvn(astr, s, 1);
1058         *s = '\0';
1059         SvCUR_set(sv, len);
1060         SvUTF8_off(sv);
1061         SvNIOK_off(sv);
1062     }
1063     else
1064         sv_setpvn(astr, "", 0);
1065     SvSETMAGIC(sv);
1066 }
1067
1068 I32
1069 Perl_do_chomp(pTHX_ register SV *sv)
1070 {
1071     dVAR;
1072     register I32 count;
1073     STRLEN len;
1074     char *s;
1075     char *temp_buffer = NULL;
1076     SV* svrecode = NULL;
1077
1078     PERL_ARGS_ASSERT_DO_CHOMP;
1079
1080     if (RsSNARF(PL_rs))
1081         return 0;
1082     if (RsRECORD(PL_rs))
1083       return 0;
1084     count = 0;
1085     if (SvTYPE(sv) == SVt_PVAV) {
1086         register I32 i;
1087         AV* const av = (AV*)sv;
1088         const I32 max = AvFILL(av);
1089
1090         for (i = 0; i <= max; i++) {
1091             sv = (SV*)av_fetch(av, i, FALSE);
1092             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
1093                 count += do_chomp(sv);
1094         }
1095         return count;
1096     }
1097     else if (SvTYPE(sv) == SVt_PVHV) {
1098         HV* const hv = (HV*)sv;
1099         HE* entry;
1100         (void)hv_iterinit(hv);
1101         while ((entry = hv_iternext(hv)))
1102             count += do_chomp(hv_iterval(hv,entry));
1103         return count;
1104     }
1105     else if (SvREADONLY(sv)) {
1106         if (SvFAKE(sv)) {
1107             /* SV is copy-on-write */
1108             sv_force_normal_flags(sv, 0);
1109         }
1110         if (SvREADONLY(sv))
1111             Perl_croak(aTHX_ PL_no_modify);
1112     }
1113
1114     if (PL_encoding) {
1115         if (!SvUTF8(sv)) {
1116         /* XXX, here sv is utf8-ized as a side-effect!
1117            If encoding.pm is used properly, almost string-generating
1118            operations, including literal strings, chr(), input data, etc.
1119            should have been utf8-ized already, right?
1120         */
1121             sv_recode_to_utf8(sv, PL_encoding);
1122         }
1123     }
1124
1125     s = SvPV(sv, len);
1126     if (s && len) {
1127         s += --len;
1128         if (RsPARA(PL_rs)) {
1129             if (*s != '\n')
1130                 goto nope;
1131             ++count;
1132             while (len && s[-1] == '\n') {
1133                 --len;
1134                 --s;
1135                 ++count;
1136             }
1137         }
1138         else {
1139             STRLEN rslen, rs_charlen;
1140             const char *rsptr = SvPV_const(PL_rs, rslen);
1141
1142             rs_charlen = SvUTF8(PL_rs)
1143                 ? sv_len_utf8(PL_rs)
1144                 : rslen;
1145
1146             if (SvUTF8(PL_rs) != SvUTF8(sv)) {
1147                 /* Assumption is that rs is shorter than the scalar.  */
1148                 if (SvUTF8(PL_rs)) {
1149                     /* RS is utf8, scalar is 8 bit.  */
1150                     bool is_utf8 = TRUE;
1151                     temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
1152                                                          &rslen, &is_utf8);
1153                     if (is_utf8) {
1154                         /* Cannot downgrade, therefore cannot possibly match
1155                          */
1156                         assert (temp_buffer == rsptr);
1157                         temp_buffer = NULL;
1158                         goto nope;
1159                     }
1160                     rsptr = temp_buffer;
1161                 }
1162                 else if (PL_encoding) {
1163                     /* RS is 8 bit, encoding.pm is used.
1164                      * Do not recode PL_rs as a side-effect. */
1165                    svrecode = newSVpvn(rsptr, rslen);
1166                    sv_recode_to_utf8(svrecode, PL_encoding);
1167                    rsptr = SvPV_const(svrecode, rslen);
1168                    rs_charlen = sv_len_utf8(svrecode);
1169                 }
1170                 else {
1171                     /* RS is 8 bit, scalar is utf8.  */
1172                     temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
1173                     rsptr = temp_buffer;
1174                 }
1175             }
1176             if (rslen == 1) {
1177                 if (*s != *rsptr)
1178                     goto nope;
1179                 ++count;
1180             }
1181             else {
1182                 if (len < rslen - 1)
1183                     goto nope;
1184                 len -= rslen - 1;
1185                 s -= rslen - 1;
1186                 if (memNE(s, rsptr, rslen))
1187                     goto nope;
1188                 count += rs_charlen;
1189             }
1190         }
1191         s = SvPV_force_nolen(sv);
1192         SvCUR_set(sv, len);
1193         *SvEND(sv) = '\0';
1194         SvNIOK_off(sv);
1195         SvSETMAGIC(sv);
1196     }
1197   nope:
1198
1199     if (svrecode)
1200          SvREFCNT_dec(svrecode);
1201
1202     Safefree(temp_buffer);
1203     return count;
1204 }
1205
1206 void
1207 Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
1208 {
1209     dVAR;
1210 #ifdef LIBERAL
1211     register long *dl;
1212     register long *ll;
1213     register long *rl;
1214 #endif
1215     register char *dc;
1216     STRLEN leftlen;
1217     STRLEN rightlen;
1218     register const char *lc;
1219     register const char *rc;
1220     register STRLEN len;
1221     STRLEN lensave;
1222     const char *lsave;
1223     const char *rsave;
1224     bool left_utf;
1225     bool right_utf;
1226     STRLEN needlen = 0;
1227
1228     PERL_ARGS_ASSERT_DO_VOP;
1229
1230     if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
1231         sv_setpvn(sv, "", 0);   /* avoid undef warning on |= and ^= */
1232     lsave = lc = SvPV_nomg_const(left, leftlen);
1233     rsave = rc = SvPV_nomg_const(right, rightlen);
1234
1235     /* This need to come after SvPV to ensure that string overloading has
1236        fired off.  */
1237
1238     left_utf = DO_UTF8(left);
1239     right_utf = DO_UTF8(right);
1240
1241     if (left_utf && !right_utf) {
1242         /* Avoid triggering overloading again by using temporaries.
1243            Maybe there should be a variant of sv_utf8_upgrade that takes pvn
1244         */
1245         right = newSVpvn_flags(rsave, rightlen, SVs_TEMP);
1246         sv_utf8_upgrade(right);
1247         rsave = rc = SvPV_nomg_const(right, rightlen);
1248         right_utf = TRUE;
1249     }
1250     else if (!left_utf && right_utf) {
1251         left = newSVpvn_flags(lsave, leftlen, SVs_TEMP);
1252         sv_utf8_upgrade(left);
1253         lsave = lc = SvPV_nomg_const(left, leftlen);
1254         left_utf = TRUE;
1255     }
1256
1257     len = leftlen < rightlen ? leftlen : rightlen;
1258     lensave = len;
1259     SvCUR_set(sv, len);
1260     (void)SvPOK_only(sv);
1261     if ((left_utf || right_utf) && (sv == left || sv == right)) {
1262         needlen = optype == OP_BIT_AND ? len : leftlen + rightlen;
1263         Newxz(dc, needlen + 1, char);
1264     }
1265     else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
1266         dc = SvPV_force_nomg_nolen(sv);
1267         if (SvLEN(sv) < len + 1) {
1268             dc = SvGROW(sv, len + 1);
1269             (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
1270         }
1271         if (optype != OP_BIT_AND && (left_utf || right_utf))
1272             dc = SvGROW(sv, leftlen + rightlen + 1);
1273     }
1274     else {
1275         needlen = optype == OP_BIT_AND
1276                     ? len : (leftlen > rightlen ? leftlen : rightlen);
1277         Newxz(dc, needlen + 1, char);
1278         sv_usepvn_flags(sv, dc, needlen, SV_HAS_TRAILING_NUL);
1279         dc = SvPVX(sv);         /* sv_usepvn() calls Renew() */
1280     }
1281     if (left_utf || right_utf) {
1282         UV duc, luc, ruc;
1283         char *dcorig = dc;
1284         char *dcsave = NULL;
1285         STRLEN lulen = leftlen;
1286         STRLEN rulen = rightlen;
1287         STRLEN ulen;
1288
1289         switch (optype) {
1290         case OP_BIT_AND:
1291             while (lulen && rulen) {
1292                 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1293                 lc += ulen;
1294                 lulen -= ulen;
1295                 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1296                 rc += ulen;
1297                 rulen -= ulen;
1298                 duc = luc & ruc;
1299                 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1300             }
1301             if (sv == left || sv == right)
1302                 (void)sv_usepvn(sv, dcorig, needlen);
1303             SvCUR_set(sv, dc - dcorig);
1304             break;
1305         case OP_BIT_XOR:
1306             while (lulen && rulen) {
1307                 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1308                 lc += ulen;
1309                 lulen -= ulen;
1310                 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1311                 rc += ulen;
1312                 rulen -= ulen;
1313                 duc = luc ^ ruc;
1314                 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1315             }
1316             goto mop_up_utf;
1317         case OP_BIT_OR:
1318             while (lulen && rulen) {
1319                 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1320                 lc += ulen;
1321                 lulen -= ulen;
1322                 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1323                 rc += ulen;
1324                 rulen -= ulen;
1325                 duc = luc | ruc;
1326                 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1327             }
1328           mop_up_utf:
1329             if (rulen)
1330                 dcsave = savepvn(rc, rulen);
1331             else if (lulen)
1332                 dcsave = savepvn(lc, lulen);
1333             if (sv == left || sv == right)
1334                 (void)sv_usepvn(sv, dcorig, needlen); /* Uses Renew(). */
1335             SvCUR_set(sv, dc - dcorig);
1336             if (rulen)
1337                 sv_catpvn(sv, dcsave, rulen);
1338             else if (lulen)
1339                 sv_catpvn(sv, dcsave, lulen);
1340             else
1341                 *SvEND(sv) = '\0';
1342             Safefree(dcsave);
1343             break;
1344         default:
1345             if (sv == left || sv == right)
1346                 Safefree(dcorig);
1347             Perl_croak(aTHX_ "panic: do_vop called for op %u (%s)",
1348                         (unsigned)optype, PL_op_name[optype]);
1349         }
1350         SvUTF8_on(sv);
1351         goto finish;
1352     }
1353     else
1354 #ifdef LIBERAL
1355     if (len >= sizeof(long)*4 &&
1356         !((unsigned long)dc % sizeof(long)) &&
1357         !((unsigned long)lc % sizeof(long)) &&
1358         !((unsigned long)rc % sizeof(long)))    /* It's almost always aligned... */
1359     {
1360         const STRLEN remainder = len % (sizeof(long)*4);
1361         len /= (sizeof(long)*4);
1362
1363         dl = (long*)dc;
1364         ll = (long*)lc;
1365         rl = (long*)rc;
1366
1367         switch (optype) {
1368         case OP_BIT_AND:
1369             while (len--) {
1370                 *dl++ = *ll++ & *rl++;
1371                 *dl++ = *ll++ & *rl++;
1372                 *dl++ = *ll++ & *rl++;
1373                 *dl++ = *ll++ & *rl++;
1374             }
1375             break;
1376         case OP_BIT_XOR:
1377             while (len--) {
1378                 *dl++ = *ll++ ^ *rl++;
1379                 *dl++ = *ll++ ^ *rl++;
1380                 *dl++ = *ll++ ^ *rl++;
1381                 *dl++ = *ll++ ^ *rl++;
1382             }
1383             break;
1384         case OP_BIT_OR:
1385             while (len--) {
1386                 *dl++ = *ll++ | *rl++;
1387                 *dl++ = *ll++ | *rl++;
1388                 *dl++ = *ll++ | *rl++;
1389                 *dl++ = *ll++ | *rl++;
1390             }
1391         }
1392
1393         dc = (char*)dl;
1394         lc = (char*)ll;
1395         rc = (char*)rl;
1396
1397         len = remainder;
1398     }
1399 #endif
1400     {
1401         switch (optype) {
1402         case OP_BIT_AND:
1403             while (len--)
1404                 *dc++ = *lc++ & *rc++;
1405             *dc = '\0';
1406             break;
1407         case OP_BIT_XOR:
1408             while (len--)
1409                 *dc++ = *lc++ ^ *rc++;
1410             goto mop_up;
1411         case OP_BIT_OR:
1412             while (len--)
1413                 *dc++ = *lc++ | *rc++;
1414           mop_up:
1415             len = lensave;
1416             if (rightlen > len)
1417                 sv_catpvn(sv, rsave + len, rightlen - len);
1418             else if (leftlen > (STRLEN)len)
1419                 sv_catpvn(sv, lsave + len, leftlen - len);
1420             else
1421                 *SvEND(sv) = '\0';
1422             break;
1423         }
1424     }
1425 finish:
1426     SvTAINT(sv);
1427 }
1428
1429 OP *
1430 Perl_do_kv(pTHX)
1431 {
1432     dVAR;
1433     dSP;
1434     HV * const hv = (HV*)POPs;
1435     HV *keys;
1436     register HE *entry;
1437     const I32 gimme = GIMME_V;
1438     const I32 dokv =     (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV);
1439     const I32 dokeys =   dokv || (PL_op->op_type == OP_KEYS);
1440     const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES);
1441
1442     if (!hv) {
1443         if (PL_op->op_flags & OPf_MOD || LVRET) {       /* lvalue */
1444             dTARGET;            /* make sure to clear its target here */
1445             if (SvTYPE(TARG) == SVt_PVLV)
1446                 LvTARG(TARG) = NULL;
1447             PUSHs(TARG);
1448         }
1449         RETURN;
1450     }
1451
1452     keys = hv;
1453     (void)hv_iterinit(keys);    /* always reset iterator regardless */
1454
1455     if (gimme == G_VOID)
1456         RETURN;
1457
1458     if (gimme == G_SCALAR) {
1459         IV i;
1460         dTARGET;
1461
1462         if (PL_op->op_flags & OPf_MOD || LVRET) {       /* lvalue */
1463             if (SvTYPE(TARG) < SVt_PVLV) {
1464                 sv_upgrade(TARG, SVt_PVLV);
1465                 sv_magic(TARG, NULL, PERL_MAGIC_nkeys, NULL, 0);
1466             }
1467             LvTYPE(TARG) = 'k';
1468             if (LvTARG(TARG) != (SV*)keys) {
1469                 if (LvTARG(TARG))
1470                     SvREFCNT_dec(LvTARG(TARG));
1471                 LvTARG(TARG) = SvREFCNT_inc_simple(keys);
1472             }
1473             PUSHs(TARG);
1474             RETURN;
1475         }
1476
1477         if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied) )
1478         {
1479             i = HvKEYS(keys);
1480         }
1481         else {
1482             i = 0;
1483             while (hv_iternext(keys)) i++;
1484         }
1485         PUSHi( i );
1486         RETURN;
1487     }
1488
1489     EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
1490
1491     PUTBACK;    /* hv_iternext and hv_iterval might clobber stack_sp */
1492     while ((entry = hv_iternext(keys))) {
1493         SPAGAIN;
1494         if (dokeys) {
1495             SV* const sv = hv_iterkeysv(entry);
1496             XPUSHs(sv); /* won't clobber stack_sp */
1497         }
1498         if (dovalues) {
1499             SV *tmpstr;
1500             PUTBACK;
1501             tmpstr = hv_iterval(hv,entry);
1502             DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
1503                             (unsigned long)HeHASH(entry),
1504                             (int)HvMAX(keys)+1,
1505                             (unsigned long)(HeHASH(entry) & HvMAX(keys))));
1506             SPAGAIN;
1507             XPUSHs(tmpstr);
1508         }
1509         PUTBACK;
1510     }
1511     return NORMAL;
1512 }
1513
1514 /*
1515  * Local variables:
1516  * c-indentation-style: bsd
1517  * c-basic-offset: 4
1518  * indent-tabs-mode: t
1519  * End:
1520  *
1521  * ex: set ts=8 sts=4 sw=4 noet:
1522  */