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