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