This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
1d761d53768a3e7dbe890e9a2de9452e703220ad
[perl5.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_sprintf() and pp_prtf() call the function
19  * do_sprintf() found in this file.
20  */
21
22 #include "EXTERN.h"
23 #define PERL_IN_DOOP_C
24 #include "perl.h"
25 #include "invlist_inline.h"
26
27 #ifndef PERL_MICRO
28 #include <signal.h>
29 #endif
30
31
32 /* Helper function for do_trans().
33  * Handles cases where the search and replacement charlists aren't UTF-8,
34  * aren't identical, and neither the /d nor /s flag is present.
35  *
36  * sv may or may not be utf8.  Note that no code point above 255 can possibly
37  * be in the to-translate set
38  */
39
40 STATIC Size_t
41 S_do_trans_simple(pTHX_ SV * const sv, const OPtrans_map * const tbl)
42 {
43     Size_t matches = 0;
44     STRLEN len;
45     U8 *s = (U8*)SvPV_nomg(sv,len);
46     U8 * const send = s+len;
47
48     PERL_ARGS_ASSERT_DO_TRANS_SIMPLE;
49     DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: entering do_trans_simple:"
50                                           " input sv:\n",
51                                           __FILE__, __LINE__));
52     DEBUG_y(sv_dump(sv));
53
54     /* First, take care of non-UTF-8 input strings, because they're easy */
55     if (!SvUTF8(sv)) {
56         while (s < send) {
57             const short ch = tbl->map[*s];
58             if (ch >= 0) {
59                 matches++;
60                 *s = (U8)ch;
61             }
62             s++;
63         }
64         SvSETMAGIC(sv);
65     }
66     else {
67         const bool grows = cBOOL(PL_op->op_private & OPpTRANS_GROWS);
68         U8 *d;
69         U8 *dstart;
70
71         /* Allow for worst-case expansion: Each input byte can become 2.  For a
72          * given input character, this happens when it occupies a single byte
73          * under UTF-8, but is to be translated to something that occupies two:
74          * $_="a".chr(400); tr/a/\xFE/, FE needs encoding. */
75         if (grows)
76             Newx(d, len*2+1, U8);
77         else
78             d = s;
79         dstart = d;
80         while (s < send) {
81             STRLEN ulen;
82             short ch;
83
84             /* Need to check this, otherwise 128..255 won't match */
85             const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT);
86             if (c < 0x100 && (ch = tbl->map[c]) >= 0) {
87                 matches++;
88                 d = uvchr_to_utf8(d, (UV)ch);
89                 s += ulen;
90             }
91             else { /* No match -> copy */
92                 Move(s, d, ulen, U8);
93                 d += ulen;
94                 s += ulen;
95             }
96         }
97         if (grows) {
98             sv_setpvn(sv, (char*)dstart, d - dstart);
99             Safefree(dstart);
100         }
101         else {
102             *d = '\0';
103             SvCUR_set(sv, d - dstart);
104         }
105         SvUTF8_on(sv);
106         SvSETMAGIC(sv);
107     }
108     DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: returning %" IVdf "\n",
109                                           __FILE__, __LINE__, matches));
110     DEBUG_y(sv_dump(sv));
111     return matches;
112 }
113
114
115 /* Helper function for do_trans().
116  * Handles cases where the search and replacement charlists are identical and
117  * non-utf8: so the string isn't modified, and only a count of modifiable
118  * chars is needed.
119  *
120  * Note that it doesn't handle /d or /s, since these modify the string even if
121  * the replacement list is empty.
122  *
123  * sv may or may not be utf8.  Note that no code point above 255 can possibly
124  * be in the to-translate set
125  */
126
127 STATIC Size_t
128 S_do_trans_count(pTHX_ SV * const sv, const OPtrans_map * const tbl)
129 {
130     STRLEN len;
131     const U8 *s = (const U8*)SvPV_nomg_const(sv, len);
132     const U8 * const send = s + len;
133     Size_t matches = 0;
134
135     PERL_ARGS_ASSERT_DO_TRANS_COUNT;
136
137     DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: entering do_trans_count:"
138                                           " input sv:\n",
139                                           __FILE__, __LINE__));
140     DEBUG_y(sv_dump(sv));
141
142     if (!SvUTF8(sv)) {
143         while (s < send) {
144             if (tbl->map[*s++] >= 0)
145                 matches++;
146         }
147     }
148     else {
149         const bool complement = cBOOL(PL_op->op_private & OPpTRANS_COMPLEMENT);
150         while (s < send) {
151             STRLEN ulen;
152             const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT);
153             if (c < 0x100) {
154                 if (tbl->map[c] >= 0)
155                     matches++;
156             } else if (complement)
157                 matches++;
158             s += ulen;
159         }
160     }
161
162     DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: count returning %" IVdf "\n",
163                                           __FILE__, __LINE__, matches));
164     return matches;
165 }
166
167
168 /* Helper function for do_trans().
169  * Handles cases where the search and replacement charlists aren't identical
170  * and both are non-utf8, and one or both of /d, /s is specified.
171  *
172  * sv may or may not be utf8.  Note that no code point above 255 can possibly
173  * be in the to-translate set
174  */
175
176 STATIC Size_t
177 S_do_trans_complex(pTHX_ SV * const sv, const OPtrans_map * const tbl)
178 {
179     STRLEN len;
180     U8 *s = (U8*)SvPV_nomg(sv, len);
181     U8 * const send = s+len;
182     Size_t matches = 0;
183     const bool complement = cBOOL(PL_op->op_private & OPpTRANS_COMPLEMENT);
184
185     PERL_ARGS_ASSERT_DO_TRANS_COMPLEX;
186
187     DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: entering do_trans_complex:"
188                                           " input sv:\n",
189                                           __FILE__, __LINE__));
190     DEBUG_y(sv_dump(sv));
191
192     if (!SvUTF8(sv)) {
193         U8 *d = s;
194         U8 * const dstart = d;
195
196         if (PL_op->op_private & OPpTRANS_SQUASH) {
197
198             /* What the mapping of the previous character was to.  If the new
199              * character has the same mapping, it is squashed from the output
200              * (but still is included in the count) */
201             short previous_map = (short) TR_OOB;
202
203             while (s < send) {
204                 const short this_map = tbl->map[*s];
205                 if (this_map >= 0) {
206                     matches++;
207                     if (this_map != previous_map) {
208                         *d++ = (U8)this_map;
209                         previous_map = this_map;
210                     }
211                 }
212                 else {
213                     if (this_map == (short) TR_UNMAPPED)
214                         *d++ = *s;
215                     else {
216                         assert(this_map == (short) TR_DELETE);
217                         matches++;
218                     }
219                     previous_map = (short) TR_OOB;
220                 }
221
222                 s++;
223             }
224         }
225         else {  /* Not to squash */
226             while (s < send) {
227                 const short this_map = tbl->map[*s];
228                 if (this_map >= 0) {
229                     matches++;
230                     *d++ = (U8)this_map;
231                 }
232                 else if (this_map == (short) TR_UNMAPPED)
233                     *d++ = *s;
234                 else if (this_map == (short) TR_DELETE)
235                     matches++;
236                 s++;
237             }
238         }
239         *d = '\0';
240         SvCUR_set(sv, d - dstart);
241     }
242     else { /* is utf8 */
243         const bool squash = cBOOL(PL_op->op_private & OPpTRANS_SQUASH);
244         const bool grows  = cBOOL(PL_op->op_private & OPpTRANS_GROWS);
245         U8 *d;
246         U8 *dstart;
247         Size_t size = tbl->size;
248
249         /* What the mapping of the previous character was to.  If the new
250          * character has the same mapping, it is squashed from the output (but
251          * still is included in the count) */
252         UV pch = TR_OOB;
253
254         if (grows)
255             /* Allow for worst-case expansion: Each input byte can become 2.
256              * For a given input character, this happens when it occupies a
257              * single byte under UTF-8, but is to be translated to something
258              * that occupies two: */
259             Newx(d, len*2+1, U8);
260         else
261             d = s;
262         dstart = d;
263
264         while (s < send) {
265             STRLEN len;
266             const UV comp = utf8n_to_uvchr(s, send - s, &len,
267                                            UTF8_ALLOW_DEFAULT);
268             UV     ch;
269             short sch;
270
271             sch = (comp < size)
272                   ? tbl->map[comp]
273                   : (! complement)
274                     ? (short) TR_UNMAPPED
275                     : tbl->map[size];
276
277             if (sch >= 0) {
278                 ch = (UV)sch;
279               replace:
280                 matches++;
281                 if (LIKELY(!squash || ch != pch)) {
282                     d = uvchr_to_utf8(d, ch);
283                     pch = ch;
284                 }
285                 s += len;
286                 continue;
287             }
288             else if (sch == (short) TR_UNMAPPED) {
289                 Move(s, d, len, U8);
290                 d += len;
291             }
292             else if (sch == (short) TR_DELETE)
293                 matches++;
294             else {
295                 assert(sch == (short) TR_R_EMPTY);  /* empty replacement */
296                 ch = comp;
297                 goto replace;
298             }
299
300             s += len;
301             pch = TR_OOB;
302         }
303
304         if (grows) {
305             sv_setpvn(sv, (char*)dstart, d - dstart);
306             Safefree(dstart);
307         }
308         else {
309             *d = '\0';
310             SvCUR_set(sv, d - dstart);
311         }
312         SvUTF8_on(sv);
313     }
314     SvSETMAGIC(sv);
315     DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: returning %" IVdf "\n",
316                                           __FILE__, __LINE__, matches));
317     DEBUG_y(sv_dump(sv));
318     return matches;
319 }
320
321
322 /* Helper function for do_trans().
323  * Handles cases where an inversion map implementation is to be used and the
324  * search and replacement charlists are identical: so the string isn't
325  * modified, and only a count of modifiable chars is needed.
326  *
327  * Note that it doesn't handle /d nor /s, since these modify the string
328  * even if the replacement charlist is empty.
329  *
330  * sv may or may not be utf8.
331  */
332
333 STATIC Size_t
334 S_do_trans_count_invmap(pTHX_ SV * const sv, AV * const invmap)
335 {
336     U8 *s;
337     U8 *send;
338     Size_t matches = 0;
339     STRLEN len;
340     SV** const from_invlist_ptr = av_fetch(invmap, 0, TRUE);
341     SV** const to_invmap_ptr = av_fetch(invmap, 1, TRUE);
342     SV* from_invlist = *from_invlist_ptr;
343     SV* to_invmap_sv = *to_invmap_ptr;
344     UV* map = (UV *) SvPVX(to_invmap_sv);
345
346     PERL_ARGS_ASSERT_DO_TRANS_COUNT_INVMAP;
347
348     DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:"
349                                           "entering do_trans_count_invmap:"
350                                           " input sv:\n",
351                                           __FILE__, __LINE__));
352     DEBUG_y(sv_dump(sv));
353     DEBUG_y(PerlIO_printf(Perl_debug_log, "mapping:\n"));
354     DEBUG_y(invmap_dump(from_invlist, (UV *) SvPVX(to_invmap_sv)));
355
356     s = (U8*)SvPV_nomg(sv, len);
357
358     send = s + len;
359
360     while (s < send) {
361         UV from;
362         SSize_t i;
363         STRLEN s_len;
364
365         /* Get the code point of the next character in the string */
366         if (! SvUTF8(sv) || UTF8_IS_INVARIANT(*s)) {
367             from = *s;
368             s_len = 1;
369         }
370         else {
371             from = utf8_to_uvchr_buf(s, send, &s_len);
372             if (from == 0 && *s != '\0') {
373                 _force_out_malformed_utf8_message(s, send, 0, /*die*/TRUE);
374             }
375         }
376
377         /* Look the code point up in the data structure for this tr/// to get
378          * what it maps to */
379         i = _invlist_search(from_invlist, from);
380         assert(i >= 0);
381
382         if (map[i] != (UV) TR_UNLISTED) {
383             matches++;
384         }
385
386         s += s_len;
387     }
388
389     DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: returning %" IVdf "\n",
390                                           __FILE__, __LINE__, matches));
391     return matches;
392 }
393
394 /* Helper function for do_trans().
395  * Handles cases where an inversion map implementation is to be used and the
396  * search and replacement charlists are either not identical or flags are
397  * present.
398  *
399  * sv may or may not be utf8.
400  */
401
402 STATIC Size_t
403 S_do_trans_invmap(pTHX_ SV * const sv, AV * const invmap)
404 {
405     U8 *s;
406     U8 *send;
407     U8 *d;
408     U8 *s0;
409     U8 *d0;
410     Size_t matches = 0;
411     STRLEN len;
412     SV** const from_invlist_ptr = av_fetch(invmap, 0, TRUE);
413     SV** const to_invmap_ptr = av_fetch(invmap, 1, TRUE);
414     SV** const to_expansion_ptr = av_fetch(invmap, 2, TRUE);
415     NV max_expansion = SvNV(*to_expansion_ptr);
416     SV* from_invlist = *from_invlist_ptr;
417     SV* to_invmap_sv = *to_invmap_ptr;
418     UV* map = (UV *) SvPVX(to_invmap_sv);
419     UV previous_map = TR_OOB;
420     const bool squash         = cBOOL(PL_op->op_private & OPpTRANS_SQUASH);
421     const bool delete_unfound = cBOOL(PL_op->op_private & OPpTRANS_DELETE);
422     bool inplace = ! cBOOL(PL_op->op_private & OPpTRANS_GROWS);
423     const UV* from_array = invlist_array(from_invlist);
424     UV final_map = TR_OOB;
425     bool out_is_utf8 = cBOOL(SvUTF8(sv));
426     STRLEN s_len;
427
428     PERL_ARGS_ASSERT_DO_TRANS_INVMAP;
429
430     /* A third element in the array indicates that the replacement list was
431      * shorter than the search list, and this element contains the value to use
432      * for the items that don't correspond */
433     if (av_top_index(invmap) >= 3) {
434         SV** const final_map_ptr = av_fetch(invmap, 3, TRUE);
435         SV*  const final_map_sv = *final_map_ptr;
436         final_map = SvUV(final_map_sv);
437     }
438
439     /* If there is something in the transliteration that could force the input
440      * to be changed to UTF-8, we don't know if we can do it in place, so
441      * assume cannot */
442     if (! out_is_utf8 && (PL_op->op_private & OPpTRANS_CAN_FORCE_UTF8)) {
443         inplace = FALSE;
444         if (max_expansion < 2) {
445             max_expansion = 2;
446         }
447     }
448
449     s = (U8*)SvPV_nomg(sv, len);
450     DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: entering do_trans_invmap:"
451                                           " input sv:\n",
452                                           __FILE__, __LINE__));
453     DEBUG_y(sv_dump(sv));
454     DEBUG_y(PerlIO_printf(Perl_debug_log, "mapping:\n"));
455     DEBUG_y(invmap_dump(from_invlist, map));
456
457     send = s + len;
458     s0 = s;
459
460     /* We know by now if there are some possible input strings whose
461      * transliterations are longer than the input.  If none can, we just edit
462      * in place. */
463     if (inplace) {
464         d0 = d = s;
465     }
466     else {
467         /* Here, we can't edit in place.  We have no idea how much, if any,
468          * this particular input string will grow.  However, the compilation
469          * calculated the maximum expansion possible.  Use that to allocale
470          * based on the worst case scenario. */
471         Newx(d, (STRLEN) (len * max_expansion + 1 + 1), U8);
472         d0 = d;
473     }
474
475   restart:
476
477     /* Do the actual transliteration */
478     while (s < send) {
479         UV from;
480         UV to;
481         SSize_t i;
482         STRLEN s_len;
483
484         /* Get the code point of the next character in the string */
485         if (! SvUTF8(sv) || UTF8_IS_INVARIANT(*s)) {
486             from = *s;
487             s_len = 1;
488         }
489         else {
490             from = utf8_to_uvchr_buf(s, send, &s_len);
491             if (from == 0 && *s != '\0') {
492                 _force_out_malformed_utf8_message(s, send, 0, /*die*/TRUE);
493             }
494         }
495
496         /* Look the code point up in the data structure for this tr/// to get
497          * what it maps to */
498         i = _invlist_search(from_invlist, from);
499         assert(i >= 0);
500
501         to = map[i];
502
503         if (to == (UV) TR_UNLISTED) { /* Just copy the unreplaced character */
504             if (UVCHR_IS_INVARIANT(from) || ! out_is_utf8) {
505                 *d++ = (U8) from;
506             }
507             else if (SvUTF8(sv)) {
508                 Move(s, d, s_len, U8);
509                 d += s_len;
510             }
511             else {  /* Convert to UTF-8 */
512                 append_utf8_from_native_byte(*s, &d);
513             }
514
515             previous_map = to;
516             s += s_len;
517             continue;
518         }
519
520         /* Everything else is counted as a match */
521         matches++;
522
523         if (to == (UV) TR_SPECIAL_HANDLING) {
524             if (delete_unfound) {
525                 previous_map = to;
526                 s += s_len;
527                 continue;
528             }
529
530             /* Use the final character in the replacement list */
531             to = final_map;
532         }
533         else { /* Here the input code point is to be remapped.  The actual
534                   value is offset from the base of this entry */
535             to += from - from_array[i];
536         }
537
538         /* If copying all occurrences, or this is the first occurrence, copy it
539          * to the output */
540         if (! squash || to != previous_map) {
541             if (out_is_utf8) {
542                 d = uvchr_to_utf8(d, to);
543             }
544             else {
545                 if (to >= 256) {    /* If need to convert to UTF-8, restart */
546                     out_is_utf8 = TRUE;
547                     s = s0;
548                     d = d0;
549                     matches = 0;
550                     goto restart;
551                 }
552                 *d++ = (U8) to;
553             }
554         }
555
556         previous_map = to;
557         s += s_len;
558     }
559
560     s_len = 0;
561     s += s_len;
562     if (! inplace) {
563         sv_setpvn(sv, (char*)d0, d - d0);
564         Safefree(d0);
565     }
566     else {
567         *d = '\0';
568         SvCUR_set(sv, d - d0);
569     }
570
571     if (! SvUTF8(sv) && out_is_utf8) {
572         SvUTF8_on(sv);
573     }
574     SvSETMAGIC(sv);
575
576     DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: returning %" IVdf "\n",
577                                           __FILE__, __LINE__, matches));
578     DEBUG_y(sv_dump(sv));
579     return matches;
580 }
581
582 /* Execute a tr//. sv is the value to be translated, while PL_op
583  * should be an OP_TRANS or OP_TRANSR op, whose op_pv field contains a
584  * translation table or whose op_sv field contains an inversion map.
585  *
586  * Returns a count of number of characters translated
587  */
588
589 Size_t
590 Perl_do_trans(pTHX_ SV *sv)
591 {
592     STRLEN len;
593     const U8 flags = PL_op->op_private;
594     bool use_utf8_fcns = cBOOL(flags & OPpTRANS_USE_SVOP);
595     bool identical     = cBOOL(flags & OPpTRANS_IDENTICAL);
596
597     PERL_ARGS_ASSERT_DO_TRANS;
598
599     if (SvREADONLY(sv) && ! identical) {
600         Perl_croak_no_modify();
601     }
602     (void)SvPV_const(sv, len);
603     if (!len)
604         return 0;
605     if (! identical) {
606         if (!SvPOKp(sv) || SvTHINKFIRST(sv))
607             (void)SvPV_force_nomg(sv, len);
608         (void)SvPOK_only_UTF8(sv);
609     }
610
611     if (use_utf8_fcns) {
612         SV* const map =
613 #ifdef USE_ITHREADS
614                         PAD_SVl(cPADOP->op_padix);
615 #else
616                         MUTABLE_SV(cSVOP->op_sv);
617 #endif
618
619         if (identical) {
620             return do_trans_count_invmap(sv, (AV *) map);
621         }
622         else {
623             return do_trans_invmap(sv, (AV *) map);
624         }
625     }
626     else {
627         const OPtrans_map * const map = (OPtrans_map*)cPVOP->op_pv;
628
629         if (identical) {
630             return do_trans_count(sv, map);
631         }
632         else if (flags & (OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) {
633             return do_trans_complex(sv, map);
634         }
635         else
636             return do_trans_simple(sv, map);
637     }
638 }
639
640 void
641 Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp)
642 {
643     SV ** const oldmark = mark;
644     I32 items = sp - mark;
645     STRLEN len;
646     STRLEN delimlen;
647     const char * const delims = SvPV_const(delim, delimlen);
648
649     PERL_ARGS_ASSERT_DO_JOIN;
650
651     mark++;
652     len = (items > 0 ? (delimlen * (items - 1) ) : 0);
653     SvUPGRADE(sv, SVt_PV);
654     if (SvLEN(sv) < len + items) {      /* current length is way too short */
655         while (items-- > 0) {
656             if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) {
657                 STRLEN tmplen;
658                 SvPV_const(*mark, tmplen);
659                 len += tmplen;
660             }
661             mark++;
662         }
663         SvGROW(sv, len + 1);            /* so try to pre-extend */
664
665         mark = oldmark;
666         items = sp - mark;
667         ++mark;
668     }
669
670     SvPVCLEAR(sv);
671     /* sv_setpv retains old UTF8ness [perl #24846] */
672     SvUTF8_off(sv);
673
674     if (TAINTING_get && SvMAGICAL(sv))
675         SvTAINTED_off(sv);
676
677     if (items-- > 0) {
678         if (*mark)
679             sv_catsv(sv, *mark);
680         mark++;
681     }
682
683     if (delimlen) {
684         const U32 delimflag = DO_UTF8(delim) ? SV_CATUTF8 : SV_CATBYTES;
685         for (; items > 0; items--,mark++) {
686             STRLEN len;
687             const char *s;
688             sv_catpvn_flags(sv,delims,delimlen,delimflag);
689             s = SvPV_const(*mark,len);
690             sv_catpvn_flags(sv,s,len,
691                             DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES);
692         }
693     }
694     else {
695         for (; items > 0; items--,mark++)
696         {
697             STRLEN len;
698             const char *s = SvPV_const(*mark,len);
699             sv_catpvn_flags(sv,s,len,
700                             DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES);
701         }
702     }
703     SvSETMAGIC(sv);
704 }
705
706 void
707 Perl_do_sprintf(pTHX_ SV *sv, SSize_t len, SV **sarg)
708 {
709     STRLEN patlen;
710     const char * const pat = SvPV_const(*sarg, patlen);
711     bool do_taint = FALSE;
712
713     PERL_ARGS_ASSERT_DO_SPRINTF;
714     assert(len >= 1);
715
716     if (SvTAINTED(*sarg))
717         TAINT_PROPER(
718                 (PL_op && PL_op->op_type < OP_max)
719                     ? (PL_op->op_type == OP_PRTF)
720                         ? "printf"
721                         : PL_op_name[PL_op->op_type]
722                     : "(unknown)"
723         );
724     SvUTF8_off(sv);
725     if (DO_UTF8(*sarg))
726         SvUTF8_on(sv);
727     sv_vsetpvfn(sv, pat, patlen, NULL, sarg + 1, (Size_t)(len - 1), &do_taint);
728     SvSETMAGIC(sv);
729     if (do_taint)
730         SvTAINTED_on(sv);
731 }
732
733 /* currently converts input to bytes if possible, but doesn't sweat failure */
734 UV
735 Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size)
736 {
737     STRLEN srclen, len, avail, uoffset, bitoffs = 0;
738     const I32 svpv_flags = ((PL_op->op_flags & OPf_MOD || LVRET)
739                                           ? SV_UNDEF_RETURNS_NULL : 0);
740     unsigned char *s = (unsigned char *)
741                             SvPV_flags(sv, srclen, (svpv_flags|SV_GMAGIC));
742     UV retnum = 0;
743
744     if (!s) {
745       s = (unsigned char *)"";
746     }
747
748     PERL_ARGS_ASSERT_DO_VECGET;
749
750     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
751         Perl_croak(aTHX_ "Illegal number of bits in vec");
752
753     if (SvUTF8(sv)) {
754         if (Perl_sv_utf8_downgrade_flags(aTHX_ sv, TRUE, 0)) {
755             /* PVX may have changed */
756             s = (unsigned char *) SvPV_flags(sv, srclen, svpv_flags);
757         }
758         else {
759                 Perl_croak(aTHX_ "Use of strings with code points over 0xFF as arguments to vec is forbidden");
760         }
761     }
762
763     if (size < 8) {
764         bitoffs = ((offset%8)*size)%8;
765         uoffset = offset/(8/size);
766     }
767     else if (size > 8) {
768         int n = size/8;
769         if (offset > Size_t_MAX / n - 1) /* would overflow */
770             return 0;
771         uoffset = offset*n;
772     }
773     else
774         uoffset = offset;
775
776     if (uoffset >= srclen)
777         return 0;
778
779     len   = (bitoffs + size + 7)/8; /* required number of bytes */
780     avail = srclen - uoffset;       /* available number of bytes */
781
782     /* Does the byte range overlap the end of the string? If so,
783      * handle specially. */
784     if (avail < len) {
785         if (size <= 8)
786             retnum = 0;
787         else {
788             if (size == 16) {
789                 assert(avail == 1);
790                 retnum = (UV) s[uoffset] <<  8;
791             }
792             else if (size == 32) {
793                 assert(avail >= 1 && avail <= 3);
794                 if (avail == 1)
795                     retnum =
796                         ((UV) s[uoffset    ] << 24);
797                 else if (avail == 2)
798                     retnum =
799                         ((UV) s[uoffset    ] << 24) +
800                         ((UV) s[uoffset + 1] << 16);
801                 else
802                     retnum =
803                         ((UV) s[uoffset    ] << 24) +
804                         ((UV) s[uoffset + 1] << 16) +
805                         (     s[uoffset + 2] <<  8);
806             }
807 #ifdef UV_IS_QUAD
808             else if (size == 64) {
809                 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
810                                "Bit vector size > 32 non-portable");
811                 assert(avail >= 1 && avail <= 7);
812                 if (avail == 1)
813                     retnum =
814                         (UV) s[uoffset     ] << 56;
815                 else if (avail == 2)
816                     retnum =
817                         ((UV) s[uoffset    ] << 56) +
818                         ((UV) s[uoffset + 1] << 48);
819                 else if (avail == 3)
820                     retnum =
821                         ((UV) s[uoffset    ] << 56) +
822                         ((UV) s[uoffset + 1] << 48) +
823                         ((UV) s[uoffset + 2] << 40);
824                 else if (avail == 4)
825                     retnum =
826                         ((UV) s[uoffset    ] << 56) +
827                         ((UV) s[uoffset + 1] << 48) +
828                         ((UV) s[uoffset + 2] << 40) +
829                         ((UV) s[uoffset + 3] << 32);
830                 else if (avail == 5)
831                     retnum =
832                         ((UV) s[uoffset    ] << 56) +
833                         ((UV) s[uoffset + 1] << 48) +
834                         ((UV) s[uoffset + 2] << 40) +
835                         ((UV) s[uoffset + 3] << 32) +
836                         ((UV) s[uoffset + 4] << 24);
837                 else if (avail == 6)
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                         ((UV) s[uoffset + 4] << 24) +
844                         ((UV) s[uoffset + 5] << 16);
845                 else
846                     retnum =
847                         ((UV) s[uoffset    ] << 56) +
848                         ((UV) s[uoffset + 1] << 48) +
849                         ((UV) s[uoffset + 2] << 40) +
850                         ((UV) s[uoffset + 3] << 32) +
851                         ((UV) s[uoffset + 4] << 24) +
852                         ((UV) s[uoffset + 5] << 16) +
853                         ((UV) s[uoffset + 6] <<  8);
854             }
855 #endif
856         }
857     }
858     else if (size < 8)
859         retnum = (s[uoffset] >> bitoffs) & ((1 << size) - 1);
860     else {
861         if (size == 8)
862             retnum = s[uoffset];
863         else if (size == 16)
864             retnum =
865                 ((UV) s[uoffset] <<      8) +
866                       s[uoffset + 1];
867         else if (size == 32)
868             retnum =
869                 ((UV) s[uoffset    ] << 24) +
870                 ((UV) s[uoffset + 1] << 16) +
871                 (     s[uoffset + 2] <<  8) +
872                       s[uoffset + 3];
873 #ifdef UV_IS_QUAD
874         else if (size == 64) {
875             Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
876                            "Bit vector size > 32 non-portable");
877             retnum =
878                 ((UV) s[uoffset    ] << 56) +
879                 ((UV) s[uoffset + 1] << 48) +
880                 ((UV) s[uoffset + 2] << 40) +
881                 ((UV) s[uoffset + 3] << 32) +
882                 ((UV) s[uoffset + 4] << 24) +
883                 ((UV) s[uoffset + 5] << 16) +
884                 (     s[uoffset + 6] <<  8) +
885                       s[uoffset + 7];
886         }
887 #endif
888     }
889
890     return retnum;
891 }
892
893 /* currently converts input to bytes if possible but doesn't sweat failures,
894  * although it does ensure that the string it clobbers is not marked as
895  * utf8-valid any more
896  */
897 void
898 Perl_do_vecset(pTHX_ SV *sv)
899 {
900     STRLEN offset, bitoffs = 0;
901     int size;
902     unsigned char *s;
903     UV lval;
904     I32 mask;
905     STRLEN targlen;
906     STRLEN len;
907     SV * const targ = LvTARG(sv);
908     char errflags = LvFLAGS(sv);
909
910     PERL_ARGS_ASSERT_DO_VECSET;
911
912     /* some out-of-range errors have been deferred if/until the LV is
913      * actually written to: f(vec($s,-1,8)) is not always fatal */
914     if (errflags) {
915         assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
916         if (errflags & LVf_NEG_OFF)
917             Perl_croak_nocontext("Negative offset to vec in lvalue context");
918         Perl_croak_nocontext("Out of memory!");
919     }
920
921     if (!targ)
922         return;
923     s = (unsigned char*)SvPV_force_flags(targ, targlen,
924                                          SV_GMAGIC | SV_UNDEF_RETURNS_NULL);
925     if (SvUTF8(targ)) {
926         /* This is handled by the SvPOK_only below...
927         if (!Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0))
928             SvUTF8_off(targ);
929          */
930         (void) Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0);
931     }
932
933     (void)SvPOK_only(targ);
934     lval = SvUV(sv);
935     offset = LvTARGOFF(sv);
936     size = LvTARGLEN(sv);
937
938     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
939         Perl_croak(aTHX_ "Illegal number of bits in vec");
940
941     if (size < 8) {
942         bitoffs = ((offset%8)*size)%8;
943         offset /= 8/size;
944     }
945     else if (size > 8) {
946         int n = size/8;
947         if (offset > Size_t_MAX / n - 1) /* would overflow */
948             Perl_croak_nocontext("Out of memory!");
949         offset *= n;
950     }
951
952     len = (bitoffs + size + 7)/8;       /* required number of bytes */
953     if (targlen < offset || targlen - offset < len) {
954         STRLEN newlen = offset > Size_t_MAX - len - 1 ? /* avoid overflow */
955                                         Size_t_MAX : offset + len + 1;
956         s = (unsigned char*)SvGROW(targ, newlen);
957         (void)memzero((char *)(s + targlen), newlen - targlen);
958         SvCUR_set(targ, newlen - 1);
959     }
960
961     if (size < 8) {
962         mask = (1 << size) - 1;
963         lval &= mask;
964         s[offset] &= ~(mask << bitoffs);
965         s[offset] |= lval << bitoffs;
966     }
967     else {
968         if (size == 8)
969             s[offset  ] = (U8)( lval        & 0xff);
970         else if (size == 16) {
971             s[offset  ] = (U8)((lval >>  8) & 0xff);
972             s[offset+1] = (U8)( lval        & 0xff);
973         }
974         else if (size == 32) {
975             s[offset  ] = (U8)((lval >> 24) & 0xff);
976             s[offset+1] = (U8)((lval >> 16) & 0xff);
977             s[offset+2] = (U8)((lval >>  8) & 0xff);
978             s[offset+3] = (U8)( lval        & 0xff);
979         }
980 #ifdef UV_IS_QUAD
981         else if (size == 64) {
982             Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
983                            "Bit vector size > 32 non-portable");
984             s[offset  ] = (U8)((lval >> 56) & 0xff);
985             s[offset+1] = (U8)((lval >> 48) & 0xff);
986             s[offset+2] = (U8)((lval >> 40) & 0xff);
987             s[offset+3] = (U8)((lval >> 32) & 0xff);
988             s[offset+4] = (U8)((lval >> 24) & 0xff);
989             s[offset+5] = (U8)((lval >> 16) & 0xff);
990             s[offset+6] = (U8)((lval >>  8) & 0xff);
991             s[offset+7] = (U8)( lval        & 0xff);
992         }
993 #endif
994     }
995     SvSETMAGIC(targ);
996 }
997
998 void
999 Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
1000 {
1001     long *dl;
1002     long *ll;
1003     long *rl;
1004     char *dc;
1005     STRLEN leftlen;
1006     STRLEN rightlen;
1007     const char *lc;
1008     const char *rc;
1009     STRLEN len = 0;
1010     STRLEN lensave;
1011     const char *lsave;
1012     const char *rsave;
1013     STRLEN needlen = 0;
1014     bool result_needs_to_be_utf8 = FALSE;
1015     bool left_utf8 = FALSE;
1016     bool right_utf8 = FALSE;
1017     U8 * left_non_downgraded = NULL;
1018     U8 * right_non_downgraded = NULL;
1019     Size_t left_non_downgraded_len = 0;
1020     Size_t right_non_downgraded_len = 0;
1021     char * non_downgraded = NULL;
1022     Size_t non_downgraded_len = 0;
1023
1024     PERL_ARGS_ASSERT_DO_VOP;
1025
1026     if (sv != left || (optype != OP_BIT_AND && !SvOK(sv)))
1027         SvPVCLEAR(sv);        /* avoid undef warning on |= and ^= */
1028     if (sv == left) {
1029         lc = SvPV_force_nomg(left, leftlen);
1030     }
1031     else {
1032         lc = SvPV_nomg_const(left, leftlen);
1033         SvPV_force_nomg_nolen(sv);
1034     }
1035     rc = SvPV_nomg_const(right, rightlen);
1036
1037     /* This needs to come after SvPV to ensure that string overloading has
1038        fired off.  */
1039
1040     /* Create downgraded temporaries of any UTF-8 encoded operands */
1041     if (DO_UTF8(left)) {
1042         const U8 * save_lc = (U8 *) lc;
1043
1044         left_utf8 = TRUE;
1045         result_needs_to_be_utf8 = TRUE;
1046
1047         left_non_downgraded_len = leftlen;
1048         lc = (char *) bytes_from_utf8_loc((const U8 *) lc, &leftlen,
1049                                           &left_utf8,
1050                                           (const U8 **) &left_non_downgraded);
1051         /* Calculate the number of trailing unconvertible bytes.  This quantity
1052          * is the original length minus the length of the converted portion. */
1053         left_non_downgraded_len -= left_non_downgraded - save_lc;
1054         SAVEFREEPV(lc);
1055     }
1056     if (DO_UTF8(right)) {
1057         const U8 * save_rc = (U8 *) rc;
1058
1059         right_utf8 = TRUE;
1060         result_needs_to_be_utf8 = TRUE;
1061
1062         right_non_downgraded_len = rightlen;
1063         rc = (char *) bytes_from_utf8_loc((const U8 *) rc, &rightlen,
1064                                           &right_utf8,
1065                                           (const U8 **) &right_non_downgraded);
1066         right_non_downgraded_len -= right_non_downgraded - save_rc;
1067         SAVEFREEPV(rc);
1068     }
1069
1070     /* We set 'len' to the length that the operation actually operates on.  The
1071      * dangling part of the longer operand doesn't actually participate in the
1072      * operation.  What happens is that we pretend that the shorter operand has
1073      * been extended to the right by enough imaginary zeros to match the length
1074      * of the longer one.  But we know in advance the result of the operation
1075      * on zeros without having to do it.  In the case of '&', the result is
1076      * zero, and the dangling portion is simply discarded.  For '|' and '^', the
1077      * result is the same as the other operand, so the dangling part is just
1078      * appended to the final result, unchanged.  As of perl-5.32, we no longer
1079      * accept above-FF code points in the dangling portion.
1080      */
1081     if (left_utf8 || right_utf8) {
1082         Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[optype]);
1083     }
1084     else {  /* Neither is UTF-8 */
1085         len = MIN(leftlen, rightlen);
1086     }
1087
1088     lensave = len;
1089     lsave = lc;
1090     rsave = rc;
1091
1092     SvCUR_set(sv, len);
1093     (void)SvPOK_only(sv);
1094     if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
1095         dc = SvPV_force_nomg_nolen(sv);
1096         if (SvLEN(sv) < len + 1) {
1097             dc = SvGROW(sv, len + 1);
1098             (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
1099         }
1100     }
1101     else {
1102         needlen = optype == OP_BIT_AND
1103                     ? len : (leftlen > rightlen ? leftlen : rightlen);
1104         Newxz(dc, needlen + 1, char);
1105         sv_usepvn_flags(sv, dc, needlen, SV_HAS_TRAILING_NUL);
1106         dc = SvPVX(sv);         /* sv_usepvn() calls Renew() */
1107     }
1108
1109     if (len >= sizeof(long)*4 &&
1110         !(PTR2nat(dc) % sizeof(long)) &&
1111         !(PTR2nat(lc) % sizeof(long)) &&
1112         !(PTR2nat(rc) % sizeof(long)))  /* It's almost always aligned... */
1113     {
1114         const STRLEN remainder = len % (sizeof(long)*4);
1115         len /= (sizeof(long)*4);
1116
1117         dl = (long*)dc;
1118         ll = (long*)lc;
1119         rl = (long*)rc;
1120
1121         switch (optype) {
1122         case OP_BIT_AND:
1123             while (len--) {
1124                 *dl++ = *ll++ & *rl++;
1125                 *dl++ = *ll++ & *rl++;
1126                 *dl++ = *ll++ & *rl++;
1127                 *dl++ = *ll++ & *rl++;
1128             }
1129             break;
1130         case OP_BIT_XOR:
1131             while (len--) {
1132                 *dl++ = *ll++ ^ *rl++;
1133                 *dl++ = *ll++ ^ *rl++;
1134                 *dl++ = *ll++ ^ *rl++;
1135                 *dl++ = *ll++ ^ *rl++;
1136             }
1137             break;
1138         case OP_BIT_OR:
1139             while (len--) {
1140                 *dl++ = *ll++ | *rl++;
1141                 *dl++ = *ll++ | *rl++;
1142                 *dl++ = *ll++ | *rl++;
1143                 *dl++ = *ll++ | *rl++;
1144             }
1145         }
1146
1147         dc = (char*)dl;
1148         lc = (char*)ll;
1149         rc = (char*)rl;
1150
1151         len = remainder;
1152     }
1153
1154     switch (optype) {
1155     case OP_BIT_AND:
1156         while (len--)
1157             *dc++ = *lc++ & *rc++;
1158         *dc = '\0';
1159         break;
1160     case OP_BIT_XOR:
1161         while (len--)
1162             *dc++ = *lc++ ^ *rc++;
1163         goto mop_up;
1164     case OP_BIT_OR:
1165         while (len--)
1166             *dc++ = *lc++ | *rc++;
1167       mop_up:
1168         len = lensave;
1169         if (rightlen > len) {
1170             if (dc == rc)
1171                 SvCUR_set(sv, rightlen);
1172             else
1173                 sv_catpvn_nomg(sv, rsave + len, rightlen - len);
1174         }
1175         else if (leftlen > len) {
1176             if (dc == lc)
1177                 SvCUR_set(sv, leftlen);
1178             else
1179                 sv_catpvn_nomg(sv, lsave + len, leftlen - len);
1180         }
1181         *SvEND(sv) = '\0';
1182
1183         /* If there is trailing stuff that couldn't be converted from UTF-8, it
1184          * is appended as-is for the ^ and | operators.  This preserves
1185          * backwards compatibility */
1186         if (right_non_downgraded) {
1187             non_downgraded = (char *) right_non_downgraded;
1188             non_downgraded_len = right_non_downgraded_len;
1189         }
1190         else if (left_non_downgraded) {
1191             non_downgraded = (char *) left_non_downgraded;
1192             non_downgraded_len = left_non_downgraded_len;
1193         }
1194
1195         break;
1196     }
1197
1198     if (result_needs_to_be_utf8) {
1199         sv_utf8_upgrade_nomg(sv);
1200
1201         /* Append any trailing UTF-8 as-is. */
1202         if (non_downgraded) {
1203             sv_catpvn_nomg(sv, non_downgraded, non_downgraded_len);
1204         }
1205     }
1206
1207     SvTAINT(sv);
1208 }
1209
1210
1211 /* Perl_do_kv() may be:
1212  *  * called directly as the pp function for pp_keys() and pp_values();
1213  *  * It may also be called directly when the op is OP_AVHVSWITCH, to
1214  *       implement CORE::keys(), CORE::values().
1215  *
1216  * In all cases it expects an HV on the stack and returns a list of keys,
1217  * values, or key-value pairs, depending on PL_op.
1218  */
1219
1220 OP *
1221 Perl_do_kv(pTHX)
1222 {
1223     dSP;
1224     HV * const keys = MUTABLE_HV(POPs);
1225     const U8 gimme = GIMME_V;
1226
1227     const I32 dokeys   =     (PL_op->op_type == OP_KEYS)
1228                           || (    PL_op->op_type == OP_AVHVSWITCH
1229                               && (PL_op->op_private & OPpAVHVSWITCH_MASK)
1230                                     + OP_EACH == OP_KEYS);
1231
1232     const I32 dovalues =     (PL_op->op_type == OP_VALUES)
1233                           || (    PL_op->op_type == OP_AVHVSWITCH
1234                               && (PL_op->op_private & OPpAVHVSWITCH_MASK)
1235                                      + OP_EACH == OP_VALUES);
1236
1237     assert(   PL_op->op_type == OP_KEYS
1238            || PL_op->op_type == OP_VALUES
1239            || PL_op->op_type == OP_AVHVSWITCH);
1240
1241     assert(!(    PL_op->op_type == OP_VALUES
1242              && (PL_op->op_private & OPpMAYBE_LVSUB)));
1243
1244     (void)hv_iterinit(keys);    /* always reset iterator regardless */
1245
1246     if (gimme == G_VOID)
1247         RETURN;
1248
1249     if (gimme == G_SCALAR) {
1250         if (PL_op->op_flags & OPf_MOD || LVRET) {       /* lvalue */
1251             SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
1252             sv_magic(ret, NULL, PERL_MAGIC_nkeys, NULL, 0);
1253             LvTYPE(ret) = 'k';
1254             LvTARG(ret) = SvREFCNT_inc_simple(keys);
1255             PUSHs(ret);
1256         }
1257         else {
1258             IV i;
1259             dTARGET;
1260
1261             /* note that in 'scalar(keys %h)' the OP_KEYS is usually
1262              * optimised away and the action is performed directly by the
1263              * padhv or rv2hv op. We now only get here via OP_AVHVSWITCH
1264              * and \&CORE::keys
1265              */
1266             if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) ) {
1267                 i = HvUSEDKEYS(keys);
1268             }
1269             else {
1270                 i = 0;
1271                 while (hv_iternext(keys)) i++;
1272             }
1273             PUSHi( i );
1274         }
1275         RETURN;
1276     }
1277
1278     if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
1279         const I32 flags = is_lvalue_sub();
1280         if (flags && !(flags & OPpENTERSUB_INARGS))
1281             /* diag_listed_as: Can't modify %s in %s */
1282             Perl_croak(aTHX_ "Can't modify keys in list assignment");
1283     }
1284
1285     PUTBACK;
1286     hv_pushkv(keys, (dokeys | (dovalues << 1)));
1287     return NORMAL;
1288 }
1289
1290 /*
1291  * ex: set ts=8 sts=4 sw=4 et:
1292  */