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