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