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