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