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