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