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