This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
trivia in perlthrtut.pod
[perl5.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
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) {
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
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
b9ac451d 651Perl_do_join(pTHX_ register SV *sv, SV *delim, 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
b9ac451d 659 (void) SvPV_const(delim, 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++) {
b9ac451d 696 sv_catsv(sv,delim);
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;
bbb8a7e0 729 STRLEN srclen, len, uoffset, bitoffs = 0;
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
bbb8a7e0
MHM
741 if (size < 8) {
742 bitoffs = ((offset%8)*size)%8;
743 uoffset = offset/(8/size);
744 }
745 else if (size > 8)
746 uoffset = offset*(size/8);
747 else
748 uoffset = offset;
749
750 len = uoffset + (bitoffs + size + 7)/8; /* required number of bytes */
81e118e0
JH
751 if (len > srclen) {
752 if (size <= 8)
753 retnum = 0;
754 else {
81e118e0 755 if (size == 16) {
bb7a0f54 756 if (uoffset >= srclen)
81e118e0
JH
757 retnum = 0;
758 else
bb7a0f54 759 retnum = (UV) s[uoffset] << 8;
81e118e0
JH
760 }
761 else if (size == 32) {
bb7a0f54 762 if (uoffset >= srclen)
81e118e0 763 retnum = 0;
bb7a0f54 764 else if (uoffset + 1 >= srclen)
81e118e0 765 retnum =
bb7a0f54
MHM
766 ((UV) s[uoffset ] << 24);
767 else if (uoffset + 2 >= srclen)
81e118e0 768 retnum =
bb7a0f54
MHM
769 ((UV) s[uoffset ] << 24) +
770 ((UV) s[uoffset + 1] << 16);
81e118e0
JH
771 else
772 retnum =
bb7a0f54
MHM
773 ((UV) s[uoffset ] << 24) +
774 ((UV) s[uoffset + 1] << 16) +
775 ( s[uoffset + 2] << 8);
81e118e0 776 }
d7d93a81 777#ifdef UV_IS_QUAD
c5a0f51a 778 else if (size == 64) {
c5a0f51a 779 if (ckWARN(WARN_PORTABLE))
9014280d 780 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
c5a0f51a 781 "Bit vector size > 32 non-portable");
bb7a0f54 782 if (uoffset >= srclen)
c5a0f51a 783 retnum = 0;
bb7a0f54 784 else if (uoffset + 1 >= srclen)
c5a0f51a 785 retnum =
bb7a0f54
MHM
786 (UV) s[uoffset ] << 56;
787 else if (uoffset + 2 >= srclen)
c5a0f51a 788 retnum =
bb7a0f54
MHM
789 ((UV) s[uoffset ] << 56) +
790 ((UV) s[uoffset + 1] << 48);
791 else if (uoffset + 3 >= srclen)
c5a0f51a 792 retnum =
bb7a0f54
MHM
793 ((UV) s[uoffset ] << 56) +
794 ((UV) s[uoffset + 1] << 48) +
795 ((UV) s[uoffset + 2] << 40);
796 else if (uoffset + 4 >= srclen)
c5a0f51a 797 retnum =
bb7a0f54
MHM
798 ((UV) s[uoffset ] << 56) +
799 ((UV) s[uoffset + 1] << 48) +
800 ((UV) s[uoffset + 2] << 40) +
801 ((UV) s[uoffset + 3] << 32);
802 else if (uoffset + 5 >= srclen)
c5a0f51a 803 retnum =
bb7a0f54
MHM
804 ((UV) s[uoffset ] << 56) +
805 ((UV) s[uoffset + 1] << 48) +
806 ((UV) s[uoffset + 2] << 40) +
807 ((UV) s[uoffset + 3] << 32) +
808 ( s[uoffset + 4] << 24);
809 else if (uoffset + 6 >= srclen)
c5a0f51a 810 retnum =
bb7a0f54
MHM
811 ((UV) s[uoffset ] << 56) +
812 ((UV) s[uoffset + 1] << 48) +
813 ((UV) s[uoffset + 2] << 40) +
814 ((UV) s[uoffset + 3] << 32) +
815 ((UV) s[uoffset + 4] << 24) +
816 ((UV) s[uoffset + 5] << 16);
c5a0f51a 817 else
8e84507e 818 retnum =
bb7a0f54
MHM
819 ((UV) s[uoffset ] << 56) +
820 ((UV) s[uoffset + 1] << 48) +
821 ((UV) s[uoffset + 2] << 40) +
822 ((UV) s[uoffset + 3] << 32) +
823 ((UV) s[uoffset + 4] << 24) +
824 ((UV) s[uoffset + 5] << 16) +
825 ( s[uoffset + 6] << 8);
c5a0f51a
JH
826 }
827#endif
81e118e0
JH
828 }
829 }
830 else if (size < 8)
bbb8a7e0 831 retnum = (s[uoffset] >> bitoffs) & ((1 << size) - 1);
81e118e0 832 else {
81e118e0 833 if (size == 8)
bb7a0f54 834 retnum = s[uoffset];
81e118e0
JH
835 else if (size == 16)
836 retnum =
bb7a0f54
MHM
837 ((UV) s[uoffset] << 8) +
838 s[uoffset + 1];
81e118e0
JH
839 else if (size == 32)
840 retnum =
bb7a0f54
MHM
841 ((UV) s[uoffset ] << 24) +
842 ((UV) s[uoffset + 1] << 16) +
843 ( s[uoffset + 2] << 8) +
844 s[uoffset + 3];
d7d93a81 845#ifdef UV_IS_QUAD
c5a0f51a 846 else if (size == 64) {
c5a0f51a 847 if (ckWARN(WARN_PORTABLE))
9014280d 848 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
c5a0f51a
JH
849 "Bit vector size > 32 non-portable");
850 retnum =
bb7a0f54
MHM
851 ((UV) s[uoffset ] << 56) +
852 ((UV) s[uoffset + 1] << 48) +
853 ((UV) s[uoffset + 2] << 40) +
854 ((UV) s[uoffset + 3] << 32) +
855 ((UV) s[uoffset + 4] << 24) +
856 ((UV) s[uoffset + 5] << 16) +
857 ( s[uoffset + 6] << 8) +
858 s[uoffset + 7];
c5a0f51a
JH
859 }
860#endif
81e118e0
JH
861 }
862
863 return retnum;
864}
865
33b45480
SB
866/* currently converts input to bytes if possible but doesn't sweat failures,
867 * although it does ensure that the string it clobbers is not marked as
868 * utf8-valid any more
869 */
79072805 870void
864dbfa3 871Perl_do_vecset(pTHX_ SV *sv)
79072805 872{
97aff369 873 dVAR;
bbb8a7e0 874 register I32 offset, bitoffs = 0;
79072805 875 register I32 size;
8990e307 876 register unsigned char *s;
81e118e0 877 register UV lval;
79072805 878 I32 mask;
a0d0e21e
LW
879 STRLEN targlen;
880 STRLEN len;
c4420975 881 SV * const targ = LvTARG(sv);
79072805 882
8990e307
LW
883 if (!targ)
884 return;
a0d0e21e 885 s = (unsigned char*)SvPV_force(targ, targlen);
246fae53 886 if (SvUTF8(targ)) {
33b45480
SB
887 /* This is handled by the SvPOK_only below...
888 if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
889 SvUTF8_off(targ);
890 */
891 (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
246fae53
MG
892 }
893
4ebbc975 894 (void)SvPOK_only(targ);
81e118e0 895 lval = SvUV(sv);
79072805 896 offset = LvTARGOFF(sv);
fe58ced6 897 if (offset < 0)
ed9aa3b7 898 Perl_croak(aTHX_ "Negative offset to vec in lvalue context");
79072805 899 size = LvTARGLEN(sv);
8e84507e 900 if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
a50d7633 901 Perl_croak(aTHX_ "Illegal number of bits in vec");
8e84507e 902
bbb8a7e0
MHM
903 if (size < 8) {
904 bitoffs = ((offset%8)*size)%8;
905 offset /= 8/size;
906 }
907 else if (size > 8)
908 offset *= size/8;
909
910 len = offset + (bitoffs + size + 7)/8; /* required number of bytes */
a0d0e21e
LW
911 if (len > targlen) {
912 s = (unsigned char*)SvGROW(targ, len + 1);
12ae5dfc 913 (void)memzero((char *)(s + targlen), len - targlen + 1);
a0d0e21e
LW
914 SvCUR_set(targ, len);
915 }
8e84507e 916
79072805
LW
917 if (size < 8) {
918 mask = (1 << size) - 1;
79072805 919 lval &= mask;
bbb8a7e0
MHM
920 s[offset] &= ~(mask << bitoffs);
921 s[offset] |= lval << bitoffs;
79072805
LW
922 }
923 else {
924 if (size == 8)
eb160463 925 s[offset ] = (U8)( lval & 0xff);
79072805 926 else if (size == 16) {
eb160463
GS
927 s[offset ] = (U8)((lval >> 8) & 0xff);
928 s[offset+1] = (U8)( lval & 0xff);
79072805
LW
929 }
930 else if (size == 32) {
eb160463
GS
931 s[offset ] = (U8)((lval >> 24) & 0xff);
932 s[offset+1] = (U8)((lval >> 16) & 0xff);
933 s[offset+2] = (U8)((lval >> 8) & 0xff);
934 s[offset+3] = (U8)( lval & 0xff);
c5a0f51a 935 }
d7d93a81 936#ifdef UV_IS_QUAD
c5a0f51a 937 else if (size == 64) {
c5a0f51a 938 if (ckWARN(WARN_PORTABLE))
9014280d 939 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
c5a0f51a 940 "Bit vector size > 32 non-portable");
eb160463
GS
941 s[offset ] = (U8)((lval >> 56) & 0xff);
942 s[offset+1] = (U8)((lval >> 48) & 0xff);
943 s[offset+2] = (U8)((lval >> 40) & 0xff);
944 s[offset+3] = (U8)((lval >> 32) & 0xff);
945 s[offset+4] = (U8)((lval >> 24) & 0xff);
946 s[offset+5] = (U8)((lval >> 16) & 0xff);
947 s[offset+6] = (U8)((lval >> 8) & 0xff);
948 s[offset+7] = (U8)( lval & 0xff);
79072805 949 }
dc1e3f56 950#endif
79072805 951 }
7bb043c3 952 SvSETMAGIC(targ);
79072805
LW
953}
954
955void
864dbfa3 956Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
79072805 957{
97aff369 958 dVAR;
463ee0b2 959 STRLEN len;
a0d0e21e 960 char *s;
8e84507e 961
79072805 962 if (SvTYPE(sv) == SVt_PVAV) {
a0d0e21e 963 register I32 i;
c4420975 964 AV* const av = (AV*)sv;
f54cb97a
AL
965 const I32 max = AvFILL(av);
966
967 for (i = 0; i <= max; i++) {
a0d0e21e 968 sv = (SV*)av_fetch(av, i, FALSE);
3280af22 969 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
a0d0e21e
LW
970 do_chop(astr, sv);
971 }
972 return;
79072805 973 }
aa854799 974 else if (SvTYPE(sv) == SVt_PVHV) {
c4420975 975 HV* const hv = (HV*)sv;
a0d0e21e
LW
976 HE* entry;
977 (void)hv_iterinit(hv);
155aba94 978 while ((entry = hv_iternext(hv)))
a0d0e21e
LW
979 do_chop(astr,hv_iterval(hv,entry));
980 return;
79072805 981 }
991e6d41
NC
982 else if (SvREADONLY(sv)) {
983 if (SvFAKE(sv)) {
984 /* SV is copy-on-write */
985 sv_force_normal_flags(sv, 0);
986 }
987 if (SvREADONLY(sv))
988 Perl_croak(aTHX_ PL_no_modify);
989 }
565a3db3
RGS
990
991 if (PL_encoding && !SvUTF8(sv)) {
992 /* like in do_chomp(), utf8-ize the sv as a side-effect
993 * if we're using encoding. */
994 sv_recode_to_utf8(sv, PL_encoding);
995 }
996
a0d0e21e 997 s = SvPV(sv, len);
748a9306 998 if (len && !SvPOK(sv))
a0d0e21e 999 s = SvPV_force(sv, len);
7e2040f0 1000 if (DO_UTF8(sv)) {
a0ed51b3 1001 if (s && len) {
c4420975 1002 char * const send = s + len;
0bcc34c2 1003 char * const start = s;
a0ed51b3 1004 s = send - 1;
a0dbb045
JH
1005 while (s > start && UTF8_IS_CONTINUATION(*s))
1006 s--;
ace7757b 1007 if (is_utf8_string((U8*)s, send - s)) {
a0dbb045
JH
1008 sv_setpvn(astr, s, send - s);
1009 *s = '\0';
1010 SvCUR_set(sv, s - start);
1011 SvNIOK_off(sv);
1012 SvUTF8_on(astr);
1013 }
a0ed51b3
LW
1014 }
1015 else
1016 sv_setpvn(astr, "", 0);
1017 }
7e2040f0 1018 else if (s && len) {
a0d0e21e
LW
1019 s += --len;
1020 sv_setpvn(astr, s, 1);
1021 *s = '\0';
1022 SvCUR_set(sv, len);
2c19a612 1023 SvUTF8_off(sv);
a0d0e21e 1024 SvNIOK_off(sv);
79072805
LW
1025 }
1026 else
a0d0e21e
LW
1027 sv_setpvn(astr, "", 0);
1028 SvSETMAGIC(sv);
7e2040f0 1029}
a0d0e21e
LW
1030
1031I32
864dbfa3 1032Perl_do_chomp(pTHX_ register SV *sv)
a0d0e21e 1033{
97aff369 1034 dVAR;
c07a80fd 1035 register I32 count;
a0d0e21e
LW
1036 STRLEN len;
1037 char *s;
c4c87a06 1038 char *temp_buffer = NULL;
a0714e2c 1039 SV* svrecode = NULL;
c07a80fd 1040
3280af22 1041 if (RsSNARF(PL_rs))
c07a80fd 1042 return 0;
4c5a6083
GS
1043 if (RsRECORD(PL_rs))
1044 return 0;
c07a80fd 1045 count = 0;
a0d0e21e
LW
1046 if (SvTYPE(sv) == SVt_PVAV) {
1047 register I32 i;
890ce7af 1048 AV* const av = (AV*)sv;
f54cb97a
AL
1049 const I32 max = AvFILL(av);
1050
1051 for (i = 0; i <= max; i++) {
a0d0e21e 1052 sv = (SV*)av_fetch(av, i, FALSE);
3280af22 1053 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
a0d0e21e
LW
1054 count += do_chomp(sv);
1055 }
1056 return count;
1057 }
aa854799 1058 else if (SvTYPE(sv) == SVt_PVHV) {
890ce7af 1059 HV* const hv = (HV*)sv;
a0d0e21e
LW
1060 HE* entry;
1061 (void)hv_iterinit(hv);
155aba94 1062 while ((entry = hv_iternext(hv)))
a0d0e21e
LW
1063 count += do_chomp(hv_iterval(hv,entry));
1064 return count;
1065 }
991e6d41
NC
1066 else if (SvREADONLY(sv)) {
1067 if (SvFAKE(sv)) {
1068 /* SV is copy-on-write */
1069 sv_force_normal_flags(sv, 0);
1070 }
1071 if (SvREADONLY(sv))
1072 Perl_croak(aTHX_ PL_no_modify);
1073 }
a6aa349d
ST
1074
1075 if (PL_encoding) {
1076 if (!SvUTF8(sv)) {
1077 /* XXX, here sv is utf8-ized as a side-effect!
1078 If encoding.pm is used properly, almost string-generating
1079 operations, including literal strings, chr(), input data, etc.
1080 should have been utf8-ized already, right?
1081 */
1082 sv_recode_to_utf8(sv, PL_encoding);
1083 }
1084 }
1085
a0d0e21e 1086 s = SvPV(sv, len);
a0d0e21e
LW
1087 if (s && len) {
1088 s += --len;
3280af22 1089 if (RsPARA(PL_rs)) {
a0d0e21e
LW
1090 if (*s != '\n')
1091 goto nope;
1092 ++count;
1093 while (len && s[-1] == '\n') {
1094 --len;
1095 --s;
1096 ++count;
1097 }
1098 }
a0d0e21e 1099 else {
a6aa349d 1100 STRLEN rslen, rs_charlen;
93524f2b 1101 const char *rsptr = SvPV_const(PL_rs, rslen);
a6aa349d
ST
1102
1103 rs_charlen = SvUTF8(PL_rs)
1104 ? sv_len_utf8(PL_rs)
1105 : rslen;
1106
c4c87a06
NC
1107 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
1108 /* Assumption is that rs is shorter than the scalar. */
1109 if (SvUTF8(PL_rs)) {
1110 /* RS is utf8, scalar is 8 bit. */
1111 bool is_utf8 = TRUE;
1112 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
1113 &rslen, &is_utf8);
1114 if (is_utf8) {
1115 /* Cannot downgrade, therefore cannot possibly match
1116 */
1117 assert (temp_buffer == rsptr);
1118 temp_buffer = NULL;
1119 goto nope;
1120 }
1121 rsptr = temp_buffer;
a6aa349d
ST
1122 }
1123 else if (PL_encoding) {
1124 /* RS is 8 bit, encoding.pm is used.
1125 * Do not recode PL_rs as a side-effect. */
1126 svrecode = newSVpvn(rsptr, rslen);
1127 sv_recode_to_utf8(svrecode, PL_encoding);
93524f2b 1128 rsptr = SvPV_const(svrecode, rslen);
a6aa349d
ST
1129 rs_charlen = sv_len_utf8(svrecode);
1130 }
1131 else {
c4c87a06
NC
1132 /* RS is 8 bit, scalar is utf8. */
1133 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
1134 rsptr = temp_buffer;
1135 }
1136 }
c07a80fd
PP
1137 if (rslen == 1) {
1138 if (*s != *rsptr)
1139 goto nope;
1140 ++count;
1141 }
1142 else {
8c2cee6f 1143 if (len < rslen - 1)
c07a80fd
PP
1144 goto nope;
1145 len -= rslen - 1;
1146 s -= rslen - 1;
36477c24 1147 if (memNE(s, rsptr, rslen))
c07a80fd 1148 goto nope;
a6aa349d 1149 count += rs_charlen;
c07a80fd 1150 }
a0d0e21e 1151 }
8b6b16e7 1152 s = SvPV_force_nolen(sv);
a0d0e21e 1153 SvCUR_set(sv, len);
9b33ce3b 1154 *SvEND(sv) = '\0';
a0d0e21e 1155 SvNIOK_off(sv);
9b33ce3b 1156 SvSETMAGIC(sv);
a0d0e21e
LW
1157 }
1158 nope:
a6aa349d
ST
1159
1160 if (svrecode)
1161 SvREFCNT_dec(svrecode);
1162
c4c87a06 1163 Safefree(temp_buffer);
a0d0e21e 1164 return count;
8e84507e 1165}
79072805
LW
1166
1167void
864dbfa3 1168Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
79072805 1169{
97aff369 1170 dVAR;
79072805
LW
1171#ifdef LIBERAL
1172 register long *dl;
1173 register long *ll;
1174 register long *rl;
1175#endif
1176 register char *dc;
463ee0b2
LW
1177 STRLEN leftlen;
1178 STRLEN rightlen;
e62f0680
NC
1179 register const char *lc;
1180 register const char *rc;
bb7a0f54
MHM
1181 register STRLEN len;
1182 STRLEN lensave;
e62f0680
NC
1183 const char *lsave;
1184 const char *rsave;
12abf4f0
NC
1185 bool left_utf;
1186 bool right_utf;
bb7a0f54 1187 STRLEN needlen = 0;
0c57e439 1188
79072805 1189
1fbd88dc
CS
1190 if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
1191 sv_setpvn(sv, "", 0); /* avoid undef warning on |= and ^= */
e62f0680
NC
1192 lsave = lc = SvPV_nomg_const(left, leftlen);
1193 rsave = rc = SvPV_nomg_const(right, rightlen);
12abf4f0
NC
1194
1195 /* This need to come after SvPV to ensure that string overloading has
1196 fired off. */
1197
1198 left_utf = DO_UTF8(left);
1199 right_utf = DO_UTF8(right);
1200
1201 if (left_utf && !right_utf) {
1202 /* Avoid triggering overloading again by using temporaries.
1203 Maybe there should be a variant of sv_utf8_upgrade that takes pvn
1204 */
1205 right = sv_2mortal(newSVpvn(rsave, rightlen));
1206 sv_utf8_upgrade(right);
1207 rsave = rc = SvPV_nomg_const(right, rightlen);
1208 right_utf = TRUE;
1209 }
1210 else if (!left_utf && right_utf) {
1211 left = sv_2mortal(newSVpvn(lsave, leftlen));
1212 sv_utf8_upgrade(left);
1213 lsave = lc = SvPV_nomg_const(left, leftlen);
1214 left_utf = TRUE;
1215 }
1216
93a17b20 1217 len = leftlen < rightlen ? leftlen : rightlen;
a0d0e21e 1218 lensave = len;
9fdd7463
JH
1219 SvCUR_set(sv, len);
1220 (void)SvPOK_only(sv);
c9b3c8d0
JH
1221 if ((left_utf || right_utf) && (sv == left || sv == right)) {
1222 needlen = optype == OP_BIT_AND ? len : leftlen + rightlen;
a02a5408 1223 Newxz(dc, needlen + 1, char);
c9b3c8d0
JH
1224 }
1225 else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
2596d9fe 1226 dc = SvPV_force_nomg_nolen(sv);
bb7a0f54
MHM
1227 if (SvLEN(sv) < len + 1) {
1228 dc = SvGROW(sv, len + 1);
ff68c719
PP
1229 (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
1230 }
c9b3c8d0
JH
1231 if (optype != OP_BIT_AND && (left_utf || right_utf))
1232 dc = SvGROW(sv, leftlen + rightlen + 1);
ff68c719
PP
1233 }
1234 else {
bb7a0f54
MHM
1235 needlen = optype == OP_BIT_AND
1236 ? len : (leftlen > rightlen ? leftlen : rightlen);
a02a5408 1237 Newxz(dc, needlen + 1, char);
aa0a69cb 1238 sv_usepvn_flags(sv, dc, needlen, SV_HAS_TRAILING_NUL);
ff68c719 1239 dc = SvPVX(sv); /* sv_usepvn() calls Renew() */
79072805 1240 }
0c57e439
GS
1241 if (left_utf || right_utf) {
1242 UV duc, luc, ruc;
794a0d33
JH
1243 char *dcorig = dc;
1244 char *dcsave = NULL;
0c57e439
GS
1245 STRLEN lulen = leftlen;
1246 STRLEN rulen = rightlen;
ba210ebe 1247 STRLEN ulen;
0c57e439
GS
1248
1249 switch (optype) {
1250 case OP_BIT_AND:
1251 while (lulen && rulen) {
9041c2e3 1252 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
1253 lc += ulen;
1254 lulen -= ulen;
9041c2e3 1255 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
1256 rc += ulen;
1257 rulen -= ulen;
1258 duc = luc & ruc;
9041c2e3 1259 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
0c57e439 1260 }
3ce4c532
NC
1261 if (sv == left || sv == right)
1262 (void)sv_usepvn(sv, dcorig, needlen);
794a0d33 1263 SvCUR_set(sv, dc - dcorig);
0c57e439
GS
1264 break;
1265 case OP_BIT_XOR:
1266 while (lulen && rulen) {
9041c2e3 1267 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
1268 lc += ulen;
1269 lulen -= ulen;
9041c2e3 1270 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
1271 rc += ulen;
1272 rulen -= ulen;
1273 duc = luc ^ ruc;
9041c2e3 1274 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
0c57e439
GS
1275 }
1276 goto mop_up_utf;
1277 case OP_BIT_OR:
1278 while (lulen && rulen) {
9041c2e3 1279 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
1280 lc += ulen;
1281 lulen -= ulen;
9041c2e3 1282 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
1283 rc += ulen;
1284 rulen -= ulen;
1285 duc = luc | ruc;
9041c2e3 1286 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
0c57e439
GS
1287 }
1288 mop_up_utf:
794a0d33
JH
1289 if (rulen)
1290 dcsave = savepvn(rc, rulen);
1291 else if (lulen)
1292 dcsave = savepvn(lc, lulen);
3ce4c532 1293 if (sv == left || sv == right)
794a0d33
JH
1294 (void)sv_usepvn(sv, dcorig, needlen); /* Uses Renew(). */
1295 SvCUR_set(sv, dc - dcorig);
0c57e439 1296 if (rulen)
794a0d33 1297 sv_catpvn(sv, dcsave, rulen);
0c57e439 1298 else if (lulen)
794a0d33 1299 sv_catpvn(sv, dcsave, lulen);
0c57e439
GS
1300 else
1301 *SvEND(sv) = '\0';
794a0d33 1302 Safefree(dcsave);
0c57e439 1303 break;
41547412
NC
1304 default:
1305 if (sv == left || sv == right)
1306 Safefree(dcorig);
c395bd6c
AL
1307 Perl_croak(aTHX_ "panic: do_vop called for op %u (%s)",
1308 (unsigned)optype, PL_op_name[optype]);
0c57e439
GS
1309 }
1310 SvUTF8_on(sv);
1311 goto finish;
1312 }
1313 else
79072805
LW
1314#ifdef LIBERAL
1315 if (len >= sizeof(long)*4 &&
bb7a0f54
MHM
1316 !((unsigned long)dc % sizeof(long)) &&
1317 !((unsigned long)lc % sizeof(long)) &&
1318 !((unsigned long)rc % sizeof(long))) /* It's almost always aligned... */
79072805 1319 {
bb7a0f54 1320 const STRLEN remainder = len % (sizeof(long)*4);
79072805
LW
1321 len /= (sizeof(long)*4);
1322
1323 dl = (long*)dc;
1324 ll = (long*)lc;
1325 rl = (long*)rc;
1326
1327 switch (optype) {
1328 case OP_BIT_AND:
1329 while (len--) {
1330 *dl++ = *ll++ & *rl++;
1331 *dl++ = *ll++ & *rl++;
1332 *dl++ = *ll++ & *rl++;
1333 *dl++ = *ll++ & *rl++;
1334 }
1335 break;
a0d0e21e 1336 case OP_BIT_XOR:
79072805
LW
1337 while (len--) {
1338 *dl++ = *ll++ ^ *rl++;
1339 *dl++ = *ll++ ^ *rl++;
1340 *dl++ = *ll++ ^ *rl++;
1341 *dl++ = *ll++ ^ *rl++;
1342 }
1343 break;
1344 case OP_BIT_OR:
1345 while (len--) {
1346 *dl++ = *ll++ | *rl++;
1347 *dl++ = *ll++ | *rl++;
1348 *dl++ = *ll++ | *rl++;
1349 *dl++ = *ll++ | *rl++;
1350 }
1351 }
1352
1353 dc = (char*)dl;
1354 lc = (char*)ll;
1355 rc = (char*)rl;
1356
1357 len = remainder;
1358 }
1359#endif
a0d0e21e 1360 {
a0d0e21e
LW
1361 switch (optype) {
1362 case OP_BIT_AND:
1363 while (len--)
1364 *dc++ = *lc++ & *rc++;
1a787b95 1365 *dc = '\0';
a0d0e21e
LW
1366 break;
1367 case OP_BIT_XOR:
1368 while (len--)
1369 *dc++ = *lc++ ^ *rc++;
1370 goto mop_up;
1371 case OP_BIT_OR:
1372 while (len--)
1373 *dc++ = *lc++ | *rc++;
1374 mop_up:
1375 len = lensave;
bb7a0f54 1376 if (rightlen > len)
a0d0e21e 1377 sv_catpvn(sv, rsave + len, rightlen - len);
eb160463 1378 else if (leftlen > (STRLEN)len)
a0d0e21e 1379 sv_catpvn(sv, lsave + len, leftlen - len);
4633a7c4
LW
1380 else
1381 *SvEND(sv) = '\0';
a0d0e21e
LW
1382 break;
1383 }
79072805 1384 }
0c57e439 1385finish:
fb73857a 1386 SvTAINT(sv);
79072805 1387}
463ee0b2
LW
1388
1389OP *
cea2e8a9 1390Perl_do_kv(pTHX)
463ee0b2 1391{
97aff369 1392 dVAR;
39644a26 1393 dSP;
c4420975 1394 HV * const hv = (HV*)POPs;
800e9ae0 1395 HV *keys;
463ee0b2 1396 register HE *entry;
f54cb97a
AL
1397 const I32 gimme = GIMME_V;
1398 const I32 dokv = (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV);
1399 const I32 dokeys = dokv || (PL_op->op_type == OP_KEYS);
1400 const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES);
463ee0b2 1401
85581909 1402 if (!hv) {
78f9721b 1403 if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
85581909
SB
1404 dTARGET; /* make sure to clear its target here */
1405 if (SvTYPE(TARG) == SVt_PVLV)
a0714e2c 1406 LvTARG(TARG) = NULL;
85581909
SB
1407 PUSHs(TARG);
1408 }
463ee0b2 1409 RETURN;
85581909 1410 }
748a9306 1411
6d822dc4 1412 keys = hv;
800e9ae0 1413 (void)hv_iterinit(keys); /* always reset iterator regardless */
748a9306 1414
54310121 1415 if (gimme == G_VOID)
aa689395
PP
1416 RETURN;
1417
54310121 1418 if (gimme == G_SCALAR) {
6ee623d5 1419 IV i;
463ee0b2
LW
1420 dTARGET;
1421
78f9721b 1422 if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
85581909
SB
1423 if (SvTYPE(TARG) < SVt_PVLV) {
1424 sv_upgrade(TARG, SVt_PVLV);
a0714e2c 1425 sv_magic(TARG, NULL, PERL_MAGIC_nkeys, NULL, 0);
85581909
SB
1426 }
1427 LvTYPE(TARG) = 'k';
800e9ae0 1428 if (LvTARG(TARG) != (SV*)keys) {
6ff81951
GS
1429 if (LvTARG(TARG))
1430 SvREFCNT_dec(LvTARG(TARG));
b37c2d43 1431 LvTARG(TARG) = SvREFCNT_inc_simple(keys);
6ff81951 1432 }
85581909
SB
1433 PUSHs(TARG);
1434 RETURN;
1435 }
1436
44a2ac75 1437 if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied) )
81714fb9 1438 {
a98face1 1439 i = HvKEYS(keys);
81714fb9 1440 }
463ee0b2
LW
1441 else {
1442 i = 0;
800e9ae0 1443 while (hv_iternext(keys)) i++;
463ee0b2
LW
1444 }
1445 PUSHi( i );
1446 RETURN;
1447 }
1448
8ed4b672 1449 EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
463ee0b2 1450
463ee0b2 1451 PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
155aba94 1452 while ((entry = hv_iternext(keys))) {
463ee0b2 1453 SPAGAIN;
574c8022 1454 if (dokeys) {
890ce7af 1455 SV* const sv = hv_iterkeysv(entry);
574c8022
JH
1456 XPUSHs(sv); /* won't clobber stack_sp */
1457 }
463ee0b2 1458 if (dovalues) {
f54cb97a 1459 SV *tmpstr;
463ee0b2 1460 PUTBACK;
6d822dc4 1461 tmpstr = hv_iterval(hv,entry);
cea2e8a9 1462 DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
46fc3d4c 1463 (unsigned long)HeHASH(entry),
cdd3ba14 1464 (int)HvMAX(keys)+1,
800e9ae0 1465 (unsigned long)(HeHASH(entry) & HvMAX(keys))));
463ee0b2 1466 SPAGAIN;
46fc3d4c 1467 XPUSHs(tmpstr);
463ee0b2
LW
1468 }
1469 PUTBACK;
1470 }
1471 return NORMAL;
1472}
4e35701f 1473
af3babe4
NC
1474/*
1475 * Local variables:
1476 * c-indentation-style: bsd
1477 * c-basic-offset: 4
1478 * indent-tabs-mode: t
1479 * End:
1480 *
37442d52
RGS
1481 * ex: set ts=8 sts=4 sw=4 noet:
1482 */