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