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