This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
The danger of piping an mbox to patch is that it contains more than
[perl5.git] / doop.c
CommitLineData
a0d0e21e 1/* doop.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
b94e2f88 4 * 2000, 2001, 2002, 2004, 2005, 2006, by Larry Wall and others
79072805
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW
9 */
10
11/*
12 * "'So that was the job I felt I had to do when I started,' thought Sam."
79072805
LW
13 */
14
166f8a29
DM
15/* This file contains some common functions needed to carry out certain
16 * ops. For example both pp_schomp() and pp_chomp() - scalar and array
17 * chomp operations - call the function do_chomp() found in this file.
18 */
19
79072805 20#include "EXTERN.h"
864dbfa3 21#define PERL_IN_DOOP_C
79072805
LW
22#include "perl.h"
23
64ca3a65 24#ifndef PERL_MICRO
79072805
LW
25#include <signal.h>
26#endif
27
942e002e 28STATIC I32
b250498f 29S_do_trans_simple(pTHX_ SV *sv)
79072805 30{
97aff369 31 dVAR;
4757a243 32 U8 *s;
b250498f 33 U8 *d;
f54cb97a 34 const U8 *send;
b250498f 35 U8 *dstart;
4757a243 36 I32 matches = 0;
f54cb97a 37 const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
463ee0b2 38 STRLEN len;
79072805 39
c4420975 40 const short * const tbl = (short*)cPVOP->op_pv;
4757a243 41 if (!tbl)
7d85a32c 42 Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__);
a0ed51b3 43
4757a243
LW
44 s = (U8*)SvPV(sv, len);
45 send = s + len;
46
1e54db1a 47 /* First, take care of non-UTF-8 input strings, because they're easy */
1aa99e6b 48 if (!SvUTF8(sv)) {
01ec43d0 49 while (s < send) {
f54cb97a
AL
50 const I32 ch = tbl[*s];
51 if (ch >= 0) {
01ec43d0 52 matches++;
c4420975 53 *s = (U8)ch;
01ec43d0 54 }
c4420975 55 s++;
01ec43d0
GS
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 62 if (grows)
a02a5408 63 Newx(d, len*2+1, U8);
9b877dbb
IH
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 */
9f7f3913 72 const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT);
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{
97aff369 100 dVAR;
83003860
NC
101 const U8 *s;
102 const U8 *send;
4757a243
LW
103 I32 matches = 0;
104 STRLEN len;
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 117 }
fabdb6c0
AL
118 else {
119 const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
1aa99e6b 120 while (s < send) {
1aa99e6b 121 STRLEN ulen;
9f7f3913 122 const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT);
8973db79
JH
123 if (c < 0x100) {
124 if (tbl[c] >= 0)
125 matches++;
126 } else if (complement)
1aa99e6b
IH
127 matches++;
128 s += ulen;
129 }
fabdb6c0 130 }
4757a243
LW
131
132 return matches;
133}
134
942e002e 135STATIC I32
21304a3b 136S_do_trans_complex(pTHX_ SV *sv)
4757a243 137{
97aff369 138 dVAR;
4757a243
LW
139 U8 *s;
140 U8 *send;
141 U8 *d;
5e44153e 142 U8 *dstart;
1aa99e6b 143 I32 isutf8;
4757a243 144 I32 matches = 0;
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 */
fabdb6c0
AL
192 const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
193 const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
194 const I32 del = PL_op->op_private & OPpTRANS_DELETE;
195
9b877dbb 196 if (grows)
a02a5408 197 Newx(d, len*2+1, U8);
9b877dbb
IH
198 else
199 d = s;
1aa99e6b 200 dstart = d;
8973db79
JH
201 if (complement && !del)
202 rlen = tbl[0x100];
1aa99e6b 203
4aecb5b5
JH
204#ifdef MACOS_TRADITIONAL
205#define comp CoMP /* "comp" is a keyword in some compilers ... */
206#endif
207
1aa99e6b 208 if (PL_op->op_private & OPpTRANS_SQUASH) {
1aa99e6b
IH
209 UV pch = 0xfeedface;
210 while (s < send) {
211 STRLEN len;
9f7f3913
ST
212 const UV comp = utf8n_to_uvchr(s, send - s, &len,
213 UTF8_ALLOW_DEFAULT);
f54cb97a 214 I32 ch;
1aa99e6b 215
8973db79
JH
216 if (comp > 0xff) {
217 if (!complement) {
218 Copy(s, d, len, U8);
219 d += len;
220 }
221 else {
222 matches++;
223 if (!del) {
05d340b8
JH
224 ch = (rlen == 0) ? comp :
225 (comp - 0x100 < rlen) ?
8973db79 226 tbl[comp+1] : tbl[0x100+rlen];
eb160463 227 if ((UV)ch != pch) {
9041c2e3 228 d = uvchr_to_utf8(d, ch);
eb160463 229 pch = (UV)ch;
8973db79
JH
230 }
231 s += len;
232 continue;
233 }
234 }
9b877dbb 235 }
1aa99e6b
IH
236 else if ((ch = tbl[comp]) >= 0) {
237 matches++;
eb160463 238 if ((UV)ch != pch) {
9041c2e3 239 d = uvchr_to_utf8(d, ch);
eb160463 240 pch = (UV)ch;
1aa99e6b
IH
241 }
242 s += len;
243 continue;
244 }
9b877dbb
IH
245 else if (ch == -1) { /* -1 is unmapped character */
246 Copy(s, d, len, U8);
247 d += len;
248 }
1aa99e6b
IH
249 else if (ch == -2) /* -2 is delete character */
250 matches++;
251 s += len;
252 pch = 0xfeedface;
253 }
5d06d08e 254 }
1aa99e6b
IH
255 else {
256 while (s < send) {
257 STRLEN len;
9f7f3913
ST
258 const UV comp = utf8n_to_uvchr(s, send - s, &len,
259 UTF8_ALLOW_DEFAULT);
f54cb97a 260 I32 ch;
8973db79
JH
261 if (comp > 0xff) {
262 if (!complement) {
0376ff32 263 Move(s, d, len, U8);
8973db79
JH
264 d += len;
265 }
266 else {
267 matches++;
268 if (!del) {
9041c2e3
NIS
269 if (comp - 0x100 < rlen)
270 d = uvchr_to_utf8(d, tbl[comp+1]);
8973db79 271 else
9041c2e3 272 d = uvchr_to_utf8(d, tbl[0x100+rlen]);
8973db79
JH
273 }
274 }
9b877dbb 275 }
1aa99e6b 276 else if ((ch = tbl[comp]) >= 0) {
9041c2e3 277 d = uvchr_to_utf8(d, ch);
1aa99e6b
IH
278 matches++;
279 }
280 else if (ch == -1) { /* -1 is unmapped character */
9b877dbb
IH
281 Copy(s, d, len, U8);
282 d += len;
1aa99e6b
IH
283 }
284 else if (ch == -2) /* -2 is delete character */
285 matches++;
286 s += len;
287 }
288 }
9b877dbb
IH
289 if (grows) {
290 sv_setpvn(sv, (char*)dstart, d - dstart);
291 Safefree(dstart);
292 }
293 else {
294 *d = '\0';
295 SvCUR_set(sv, d - dstart);
296 }
1aa99e6b 297 SvUTF8_on(sv);
4757a243 298 }
5e44153e 299 SvSETMAGIC(sv);
4757a243
LW
300 return matches;
301}
302
942e002e 303STATIC I32
21304a3b 304S_do_trans_simple_utf8(pTHX_ SV *sv)
4757a243 305{
97aff369 306 dVAR;
4757a243
LW
307 U8 *s;
308 U8 *send;
309 U8 *d;
036b4402 310 U8 *start;
1aa99e6b 311 U8 *dstart, *dend;
4757a243 312 I32 matches = 0;
f54cb97a 313 const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
4757a243
LW
314 STRLEN len;
315
53c1dcc0
AL
316 SV* const rv = (SV*)cSVOP->op_sv;
317 HV* const hv = (HV*)SvRV(rv);
a4fc7abc 318 SV* const * svp = hv_fetchs(hv, "NONE", FALSE);
f54cb97a
AL
319 const UV none = svp ? SvUV(*svp) : 0x7fffffff;
320 const UV extra = none + 1;
b7953727 321 UV final = 0;
1aa99e6b
IH
322 I32 isutf8;
323 U8 hibit = 0;
4757a243
LW
324
325 s = (U8*)SvPV(sv, len);
1aa99e6b
IH
326 isutf8 = SvUTF8(sv);
327 if (!isutf8) {
c4420975
AL
328 const U8 *t = s;
329 const U8 * const e = s + len;
c4d5f83a 330 while (t < e) {
f54cb97a 331 const U8 ch = *t++;
fabdb6c0
AL
332 hibit = !NATIVE_IS_INVARIANT(ch);
333 if (hibit) {
334 s = bytes_to_utf8(s, &len);
1aa99e6b 335 break;
fabdb6c0 336 }
c4d5f83a 337 }
1aa99e6b 338 }
4757a243 339 send = s + len;
036b4402 340 start = s;
4757a243 341
a4fc7abc 342 svp = hv_fetchs(hv, "FINAL", FALSE);
4757a243
LW
343 if (svp)
344 final = SvUV(*svp);
345
9b877dbb
IH
346 if (grows) {
347 /* d needs to be bigger than s, in case e.g. upgrading is required */
a02a5408 348 Newx(d, len * 3 + UTF8_MAXBYTES, U8);
9b877dbb
IH
349 dend = d + len * 3;
350 dstart = d;
351 }
352 else {
353 dstart = d = s;
354 dend = d + len;
355 }
1aa99e6b 356
4757a243 357 while (s < send) {
0bcc34c2
AL
358 const UV uv = swash_fetch(rv, s, TRUE);
359 if (uv < none) {
4757a243
LW
360 s += UTF8SKIP(s);
361 matches++;
7d85a32c 362 d = uvuni_to_utf8(d, uv);
4757a243
LW
363 }
364 else if (uv == none) {
4373e329 365 const int i = UTF8SKIP(s);
0376ff32 366 Move(s, d, i, U8);
9b877dbb
IH
367 d += i;
368 s += i;
4757a243
LW
369 }
370 else if (uv == extra) {
4373e329 371 s += UTF8SKIP(s);
4757a243 372 matches++;
7d85a32c 373 d = uvuni_to_utf8(d, final);
4757a243
LW
374 }
375 else
376 s += UTF8SKIP(s);
1aa99e6b 377
9b877dbb 378 if (d > dend) {
4373e329
AL
379 const STRLEN clen = d - dstart;
380 const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
9b877dbb 381 if (!grows)
7d85a32c 382 Perl_croak(aTHX_ "panic: do_trans_simple_utf8 line %d",__LINE__);
89ebb4a3 383 Renew(dstart, nlen + UTF8_MAXBYTES, U8);
1aa99e6b
IH
384 d = dstart + clen;
385 dend = dstart + nlen;
386 }
4757a243 387 }
16ec844d 388 if (grows || hibit) {
9b877dbb
IH
389 sv_setpvn(sv, (char*)dstart, d - dstart);
390 Safefree(dstart);
16ec844d
IH
391 if (grows && hibit)
392 Safefree(start);
9b877dbb
IH
393 }
394 else {
395 *d = '\0';
396 SvCUR_set(sv, d - dstart);
397 }
4757a243 398 SvSETMAGIC(sv);
1aa99e6b 399 SvUTF8_on(sv);
4757a243
LW
400
401 return matches;
402}
403
942e002e 404STATIC I32
21304a3b 405S_do_trans_count_utf8(pTHX_ SV *sv)
4757a243 406{
97aff369 407 dVAR;
93524f2b 408 const U8 *s;
cbbf8932
AL
409 const U8 *start = NULL;
410 const U8 *send;
4757a243
LW
411 I32 matches = 0;
412 STRLEN len;
413
53c1dcc0
AL
414 SV* const rv = (SV*)cSVOP->op_sv;
415 HV* const hv = (HV*)SvRV(rv);
a4fc7abc 416 SV* const * const svp = hv_fetchs(hv, "NONE", FALSE);
f54cb97a
AL
417 const UV none = svp ? SvUV(*svp) : 0x7fffffff;
418 const UV extra = none + 1;
1aa99e6b 419 U8 hibit = 0;
4757a243 420
93524f2b 421 s = (const U8*)SvPV_const(sv, len);
1aa99e6b 422 if (!SvUTF8(sv)) {
4373e329 423 const U8 *t = s;
c4420975 424 const U8 * const e = s + len;
c4d5f83a 425 while (t < e) {
4373e329 426 const U8 ch = *t++;
fabdb6c0
AL
427 hibit = !NATIVE_IS_INVARIANT(ch);
428 if (hibit) {
429 start = s = bytes_to_utf8(s, &len);
1aa99e6b 430 break;
fabdb6c0 431 }
c4d5f83a 432 }
1aa99e6b 433 }
4757a243
LW
434 send = s + len;
435
436 while (s < send) {
c4420975
AL
437 const UV uv = swash_fetch(rv, s, TRUE);
438 if (uv < none || uv == extra)
4757a243 439 matches++;
834a4ddd 440 s += UTF8SKIP(s);
4757a243 441 }
1aa99e6b
IH
442 if (hibit)
443 Safefree(start);
4757a243
LW
444
445 return matches;
446}
447
942e002e 448STATIC I32
21304a3b 449S_do_trans_complex_utf8(pTHX_ SV *sv)
4757a243 450{
97aff369 451 dVAR;
1aa99e6b 452 U8 *start, *send;
4757a243
LW
453 U8 *d;
454 I32 matches = 0;
4373e329
AL
455 const I32 squash = PL_op->op_private & OPpTRANS_SQUASH;
456 const I32 del = PL_op->op_private & OPpTRANS_DELETE;
457 const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
53c1dcc0
AL
458 SV * const rv = (SV*)cSVOP->op_sv;
459 HV * const hv = (HV*)SvRV(rv);
a4fc7abc 460 SV * const *svp = hv_fetchs(hv, "NONE", FALSE);
f54cb97a
AL
461 const UV none = svp ? SvUV(*svp) : 0x7fffffff;
462 const UV extra = none + 1;
b7953727 463 UV final = 0;
45005bfb 464 bool havefinal = FALSE;
4757a243 465 STRLEN len;
1aa99e6b 466 U8 *dstart, *dend;
1aa99e6b 467 U8 hibit = 0;
4757a243 468
f54cb97a
AL
469 U8 *s = (U8*)SvPV(sv, len);
470 const I32 isutf8 = SvUTF8(sv);
1aa99e6b 471 if (!isutf8) {
53c1dcc0
AL
472 const U8 *t = s;
473 const U8 * const e = s + len;
c4d5f83a 474 while (t < e) {
f54cb97a 475 const U8 ch = *t++;
fabdb6c0
AL
476 hibit = !NATIVE_IS_INVARIANT(ch);
477 if (hibit) {
478 s = bytes_to_utf8(s, &len);
1aa99e6b 479 break;
fabdb6c0 480 }
c4d5f83a 481 }
1aa99e6b 482 }
4757a243 483 send = s + len;
1aa99e6b 484 start = s;
4757a243 485
a4fc7abc 486 svp = hv_fetchs(hv, "FINAL", FALSE);
45005bfb 487 if (svp) {
4757a243 488 final = SvUV(*svp);
45005bfb
JH
489 havefinal = TRUE;
490 }
4757a243 491
9b877dbb
IH
492 if (grows) {
493 /* d needs to be bigger than s, in case e.g. upgrading is required */
a02a5408 494 Newx(d, len * 3 + UTF8_MAXBYTES, U8);
9b877dbb
IH
495 dend = d + len * 3;
496 dstart = d;
497 }
498 else {
499 dstart = d = s;
500 dend = d + len;
501 }
4757a243
LW
502
503 if (squash) {
504 UV puv = 0xfeedface;
505 while (s < send) {
f54cb97a 506 UV uv = swash_fetch(rv, s, TRUE);
9041c2e3 507
9b877dbb 508 if (d > dend) {
4373e329
AL
509 const STRLEN clen = d - dstart;
510 const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
9b877dbb 511 if (!grows)
7d85a32c 512 Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
89ebb4a3 513 Renew(dstart, nlen + UTF8_MAXBYTES, U8);
1aa99e6b
IH
514 d = dstart + clen;
515 dend = dstart + nlen;
4757a243
LW
516 }
517 if (uv < none) {
518 matches++;
94472101 519 s += UTF8SKIP(s);
4757a243 520 if (uv != puv) {
7d85a32c 521 d = uvuni_to_utf8(d, uv);
4757a243
LW
522 puv = uv;
523 }
4757a243
LW
524 continue;
525 }
526 else if (uv == none) { /* "none" is unmapped character */
4373e329 527 const int i = UTF8SKIP(s);
0376ff32 528 Move(s, d, i, U8);
9b877dbb
IH
529 d += i;
530 s += i;
4757a243
LW
531 puv = 0xfeedface;
532 continue;
a0ed51b3 533 }
4757a243
LW
534 else if (uv == extra && !del) {
535 matches++;
45005bfb
JH
536 if (havefinal) {
537 s += UTF8SKIP(s);
538 if (puv != final) {
7d85a32c 539 d = uvuni_to_utf8(d, final);
45005bfb
JH
540 puv = final;
541 }
542 }
543 else {
544 STRLEN len;
9f7f3913 545 uv = utf8n_to_uvuni(s, send - s, &len, UTF8_ALLOW_DEFAULT);
45005bfb 546 if (uv != puv) {
0376ff32 547 Move(s, d, len, U8);
45005bfb
JH
548 d += len;
549 puv = uv;
550 }
551 s += len;
4757a243 552 }
4757a243
LW
553 continue;
554 }
01ec43d0
GS
555 matches++; /* "none+1" is delete character */
556 s += UTF8SKIP(s);
a0ed51b3 557 }
79072805
LW
558 }
559 else {
4757a243 560 while (s < send) {
f54cb97a 561 const UV uv = swash_fetch(rv, s, TRUE);
9b877dbb 562 if (d > dend) {
f54cb97a
AL
563 const STRLEN clen = d - dstart;
564 const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
9b877dbb 565 if (!grows)
7d85a32c 566 Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
89ebb4a3 567 Renew(dstart, nlen + UTF8_MAXBYTES, U8);
1aa99e6b
IH
568 d = dstart + clen;
569 dend = dstart + nlen;
a0ed51b3 570 }
4757a243
LW
571 if (uv < none) {
572 matches++;
01ec43d0 573 s += UTF8SKIP(s);
7d85a32c 574 d = uvuni_to_utf8(d, uv);
4757a243 575 continue;
a0ed51b3 576 }
4757a243 577 else if (uv == none) { /* "none" is unmapped character */
f54cb97a 578 const int i = UTF8SKIP(s);
0376ff32 579 Move(s, d, i, U8);
9b877dbb
IH
580 d += i;
581 s += i;
4757a243 582 continue;
79072805 583 }
4757a243
LW
584 else if (uv == extra && !del) {
585 matches++;
01ec43d0 586 s += UTF8SKIP(s);
7d85a32c 587 d = uvuni_to_utf8(d, final);
4757a243
LW
588 continue;
589 }
01ec43d0
GS
590 matches++; /* "none+1" is delete character */
591 s += UTF8SKIP(s);
79072805 592 }
4757a243 593 }
16ec844d 594 if (grows || hibit) {
9b877dbb
IH
595 sv_setpvn(sv, (char*)dstart, d - dstart);
596 Safefree(dstart);
16ec844d
IH
597 if (grows && hibit)
598 Safefree(start);
9b877dbb
IH
599 }
600 else {
601 *d = '\0';
602 SvCUR_set(sv, d - dstart);
603 }
1aa99e6b 604 SvUTF8_on(sv);
4757a243
LW
605 SvSETMAGIC(sv);
606
607 return matches;
608}
609
610I32
864dbfa3 611Perl_do_trans(pTHX_ SV *sv)
4757a243 612{
97aff369 613 dVAR;
4757a243 614 STRLEN len;
4373e329 615 const I32 hasutf = (PL_op->op_private &
036b4402 616 (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
4757a243 617
2233f375 618 if (SvREADONLY(sv)) {
765f542d
NC
619 if (SvIsCOW(sv))
620 sv_force_normal_flags(sv, 0);
2233f375
NC
621 if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
622 Perl_croak(aTHX_ PL_no_modify);
623 }
10516c54 624 (void)SvPV_const(sv, len);
4757a243
LW
625 if (!len)
626 return 0;
d59e14db
RGS
627 if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) {
628 if (!SvPOKp(sv))
629 (void)SvPV_force(sv, len);
2de7b02f 630 (void)SvPOK_only_UTF8(sv);
d59e14db 631 }
4757a243 632
cea2e8a9 633 DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
4757a243 634
a77e643a
RGS
635 switch (PL_op->op_private & ~hasutf & (
636 OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|
637 OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) {
4757a243 638 case 0:
01ec43d0
GS
639 if (hasutf)
640 return do_trans_simple_utf8(sv);
641 else
642 return do_trans_simple(sv);
4757a243
LW
643
644 case OPpTRANS_IDENTICAL:
05d340b8 645 case OPpTRANS_IDENTICAL|OPpTRANS_COMPLEMENT:
01ec43d0
GS
646 if (hasutf)
647 return do_trans_count_utf8(sv);
648 else
649 return do_trans_count(sv);
4757a243
LW
650
651 default:
01ec43d0 652 if (hasutf)
036b4402 653 return do_trans_complex_utf8(sv);
4757a243 654 else
036b4402 655 return do_trans_complex(sv);
79072805 656 }
79072805
LW
657}
658
659void
864dbfa3 660Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp)
79072805 661{
97aff369 662 dVAR;
53c1dcc0 663 SV ** const oldmark = mark;
79072805 664 register I32 items = sp - mark;
79072805 665 register STRLEN len;
463ee0b2 666 STRLEN delimlen;
79072805 667
5c144d81 668 (void) SvPV_const(del, delimlen); /* stringify and get the delimlen */
5ba99574 669 /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */
516a5887 670
79072805
LW
671 mark++;
672 len = (items > 0 ? (delimlen * (items - 1) ) : 0);
862a34c6 673 SvUPGRADE(sv, SVt_PV);
79072805
LW
674 if (SvLEN(sv) < len + items) { /* current length is way too short */
675 while (items-- > 0) {
1426bbf4 676 if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) {
f54cb97a 677 STRLEN tmplen;
5c144d81 678 SvPV_const(*mark, tmplen);
463ee0b2 679 len += tmplen;
79072805
LW
680 }
681 mark++;
682 }
683 SvGROW(sv, len + 1); /* so try to pre-extend */
684
685 mark = oldmark;
db7c17d7 686 items = sp - mark;
79072805
LW
687 ++mark;
688 }
689
fc0199cd 690 sv_setpvn(sv, "", 0);
e4803c42 691 /* sv_setpv retains old UTF8ness [perl #24846] */
fb622db0 692 SvUTF8_off(sv);
e4803c42 693
8d6d96c1
HS
694 if (PL_tainting && SvMAGICAL(sv))
695 SvTAINTED_off(sv);
696
463ee0b2 697 if (items-- > 0) {
92d29cee
JH
698 if (*mark)
699 sv_catsv(sv, *mark);
463ee0b2
LW
700 mark++;
701 }
8d6d96c1 702
c512ce4f 703 if (delimlen) {
79072805 704 for (; items > 0; items--,mark++) {
c512ce4f 705 sv_catsv(sv,del);
79072805
LW
706 sv_catsv(sv,*mark);
707 }
708 }
709 else {
710 for (; items > 0; items--,mark++)
711 sv_catsv(sv,*mark);
712 }
713 SvSETMAGIC(sv);
714}
715
716void
864dbfa3 717Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
79072805 718{
97aff369 719 dVAR;
46fc3d4c 720 STRLEN patlen;
53c1dcc0 721 const char * const pat = SvPV_const(*sarg, patlen);
46fc3d4c
PP
722 bool do_taint = FALSE;
723
5b781b5b 724 SvUTF8_off(sv);
2cf2cfc6
A
725 if (DO_UTF8(*sarg))
726 SvUTF8_on(sv);
4608196e 727 sv_vsetpvfn(sv, pat, patlen, NULL, sarg + 1, len - 1, &do_taint);
79072805 728 SvSETMAGIC(sv);
46fc3d4c
PP
729 if (do_taint)
730 SvTAINTED_on(sv);
79072805
LW
731}
732
33b45480 733/* currently converts input to bytes if possible, but doesn't sweat failure */
81e118e0
JH
734UV
735Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
736{
97aff369 737 dVAR;
81e118e0 738 STRLEN srclen, len;
10516c54 739 const unsigned char *s = (const unsigned char *) SvPV_const(sv, srclen);
81e118e0
JH
740 UV retnum = 0;
741
a50d7633 742 if (offset < 0)
81e118e0 743 return retnum;
8e84507e 744 if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
a50d7633 745 Perl_croak(aTHX_ "Illegal number of bits in vec");
246fae53 746
dcad2880 747 if (SvUTF8(sv))
33b45480 748 (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE);
246fae53 749
81e118e0
JH
750 offset *= size; /* turn into bit offset */
751 len = (offset + size + 7) / 8; /* required number of bytes */
752 if (len > srclen) {
753 if (size <= 8)
754 retnum = 0;
755 else {
756 offset >>= 3; /* turn into byte offset */
757 if (size == 16) {
eb160463 758 if ((STRLEN)offset >= srclen)
81e118e0
JH
759 retnum = 0;
760 else
628e1a40 761 retnum = (UV) s[offset] << 8;
81e118e0
JH
762 }
763 else if (size == 32) {
eb160463 764 if ((STRLEN)offset >= srclen)
81e118e0 765 retnum = 0;
eb160463 766 else if ((STRLEN)(offset + 1) >= srclen)
81e118e0
JH
767 retnum =
768 ((UV) s[offset ] << 24);
eb160463 769 else if ((STRLEN)(offset + 2) >= srclen)
81e118e0
JH
770 retnum =
771 ((UV) s[offset ] << 24) +
772 ((UV) s[offset + 1] << 16);
773 else
774 retnum =
775 ((UV) s[offset ] << 24) +
776 ((UV) s[offset + 1] << 16) +
777 ( s[offset + 2] << 8);
778 }
d7d93a81 779#ifdef UV_IS_QUAD
c5a0f51a 780 else if (size == 64) {
c5a0f51a 781 if (ckWARN(WARN_PORTABLE))
9014280d 782 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
c5a0f51a
JH
783 "Bit vector size > 32 non-portable");
784 if (offset >= srclen)
785 retnum = 0;
786 else if (offset + 1 >= srclen)
787 retnum =
788 (UV) s[offset ] << 56;
789 else if (offset + 2 >= srclen)
790 retnum =
791 ((UV) s[offset ] << 56) +
792 ((UV) s[offset + 1] << 48);
793 else if (offset + 3 >= srclen)
794 retnum =
795 ((UV) s[offset ] << 56) +
796 ((UV) s[offset + 1] << 48) +
797 ((UV) s[offset + 2] << 40);
798 else if (offset + 4 >= srclen)
799 retnum =
800 ((UV) s[offset ] << 56) +
801 ((UV) s[offset + 1] << 48) +
802 ((UV) s[offset + 2] << 40) +
803 ((UV) s[offset + 3] << 32);
804 else if (offset + 5 >= srclen)
805 retnum =
806 ((UV) s[offset ] << 56) +
807 ((UV) s[offset + 1] << 48) +
808 ((UV) s[offset + 2] << 40) +
809 ((UV) s[offset + 3] << 32) +
810 ( s[offset + 4] << 24);
811 else if (offset + 6 >= srclen)
812 retnum =
813 ((UV) s[offset ] << 56) +
814 ((UV) s[offset + 1] << 48) +
815 ((UV) s[offset + 2] << 40) +
816 ((UV) s[offset + 3] << 32) +
817 ((UV) s[offset + 4] << 24) +
818 ((UV) s[offset + 5] << 16);
819 else
8e84507e 820 retnum =
c5a0f51a
JH
821 ((UV) s[offset ] << 56) +
822 ((UV) s[offset + 1] << 48) +
823 ((UV) s[offset + 2] << 40) +
824 ((UV) s[offset + 3] << 32) +
825 ((UV) s[offset + 4] << 24) +
826 ((UV) s[offset + 5] << 16) +
628e1a40 827 ( s[offset + 6] << 8);
c5a0f51a
JH
828 }
829#endif
81e118e0
JH
830 }
831 }
832 else if (size < 8)
833 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
834 else {
835 offset >>= 3; /* turn into byte offset */
836 if (size == 8)
837 retnum = s[offset];
838 else if (size == 16)
839 retnum =
628e1a40 840 ((UV) s[offset] << 8) +
81e118e0
JH
841 s[offset + 1];
842 else if (size == 32)
843 retnum =
844 ((UV) s[offset ] << 24) +
845 ((UV) s[offset + 1] << 16) +
846 ( s[offset + 2] << 8) +
847 s[offset + 3];
d7d93a81 848#ifdef UV_IS_QUAD
c5a0f51a 849 else if (size == 64) {
c5a0f51a 850 if (ckWARN(WARN_PORTABLE))
9014280d 851 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
c5a0f51a
JH
852 "Bit vector size > 32 non-portable");
853 retnum =
854 ((UV) s[offset ] << 56) +
855 ((UV) s[offset + 1] << 48) +
856 ((UV) s[offset + 2] << 40) +
857 ((UV) s[offset + 3] << 32) +
858 ((UV) s[offset + 4] << 24) +
859 ((UV) s[offset + 5] << 16) +
628e1a40 860 ( s[offset + 6] << 8) +
c5a0f51a
JH
861 s[offset + 7];
862 }
863#endif
81e118e0
JH
864 }
865
866 return retnum;
867}
868
33b45480
SB
869/* currently converts input to bytes if possible but doesn't sweat failures,
870 * although it does ensure that the string it clobbers is not marked as
871 * utf8-valid any more
872 */
79072805 873void
864dbfa3 874Perl_do_vecset(pTHX_ SV *sv)
79072805 875{
97aff369 876 dVAR;
79072805
LW
877 register I32 offset;
878 register I32 size;
8990e307 879 register unsigned char *s;
81e118e0 880 register UV lval;
79072805 881 I32 mask;
a0d0e21e
LW
882 STRLEN targlen;
883 STRLEN len;
c4420975 884 SV * const targ = LvTARG(sv);
79072805 885
8990e307
LW
886 if (!targ)
887 return;
a0d0e21e 888 s = (unsigned char*)SvPV_force(targ, targlen);
246fae53 889 if (SvUTF8(targ)) {
33b45480
SB
890 /* This is handled by the SvPOK_only below...
891 if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
892 SvUTF8_off(targ);
893 */
894 (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
246fae53
MG
895 }
896
4ebbc975 897 (void)SvPOK_only(targ);
81e118e0 898 lval = SvUV(sv);
79072805 899 offset = LvTARGOFF(sv);
fe58ced6 900 if (offset < 0)
ed9aa3b7 901 Perl_croak(aTHX_ "Negative offset to vec in lvalue context");
79072805 902 size = LvTARGLEN(sv);
8e84507e 903 if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
a50d7633 904 Perl_croak(aTHX_ "Illegal number of bits in vec");
8e84507e 905
81e118e0
JH
906 offset *= size; /* turn into bit offset */
907 len = (offset + size + 7) / 8; /* required number of bytes */
a0d0e21e
LW
908 if (len > targlen) {
909 s = (unsigned char*)SvGROW(targ, len + 1);
12ae5dfc 910 (void)memzero((char *)(s + targlen), len - targlen + 1);
a0d0e21e
LW
911 SvCUR_set(targ, len);
912 }
8e84507e 913
79072805
LW
914 if (size < 8) {
915 mask = (1 << size) - 1;
916 size = offset & 7;
917 lval &= mask;
81e118e0 918 offset >>= 3; /* turn into byte offset */
79072805
LW
919 s[offset] &= ~(mask << size);
920 s[offset] |= lval << size;
921 }
922 else {
81e118e0 923 offset >>= 3; /* turn into byte offset */
79072805 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;
79072805 1181 register I32 len;
a0d0e21e 1182 I32 lensave;
e62f0680
NC
1183 const char *lsave;
1184 const char *rsave;
f54cb97a
AL
1185 const bool left_utf = DO_UTF8(left);
1186 const bool right_utf = DO_UTF8(right);
b7953727 1187 I32 needlen = 0;
2d78db9d 1188 bool needfree = FALSE;
0c57e439
GS
1189
1190 if (left_utf && !right_utf)
1191 sv_utf8_upgrade(right);
a1ca4561 1192 else if (!left_utf && right_utf)
0c57e439 1193 sv_utf8_upgrade(left);
79072805 1194
1fbd88dc
CS
1195 if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
1196 sv_setpvn(sv, "", 0); /* avoid undef warning on |= and ^= */
e62f0680
NC
1197 lsave = lc = SvPV_nomg_const(left, leftlen);
1198 rsave = rc = SvPV_nomg_const(right, rightlen);
93a17b20 1199 len = leftlen < rightlen ? leftlen : rightlen;
a0d0e21e 1200 lensave = len;
2d78db9d
JH
1201 SvCUR_set(sv, len);
1202 (void)SvPOK_only(sv);
c9b3c8d0
JH
1203 if ((left_utf || right_utf) && (sv == left || sv == right)) {
1204 needlen = optype == OP_BIT_AND ? len : leftlen + rightlen;
a02a5408 1205 Newxz(dc, needlen + 1, char);
2d78db9d 1206 needfree = TRUE;
c9b3c8d0
JH
1207 }
1208 else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
2596d9fe 1209 dc = SvPV_force_nomg_nolen(sv);
1a787b95 1210 if (SvLEN(sv) < (STRLEN)(len + 1)) {
eb160463 1211 dc = SvGROW(sv, (STRLEN)(len + 1));
ff68c719
PP
1212 (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
1213 }
c9b3c8d0
JH
1214 if (optype != OP_BIT_AND && (left_utf || right_utf))
1215 dc = SvGROW(sv, leftlen + rightlen + 1);
ff68c719
PP
1216 }
1217 else {
c9b3c8d0
JH
1218 needlen = ((optype == OP_BIT_AND)
1219 ? len : (leftlen > rightlen ? leftlen : rightlen));
a02a5408 1220 Newxz(dc, needlen + 1, char);
aa0a69cb 1221 sv_usepvn_flags(sv, dc, needlen, SV_HAS_TRAILING_NUL);
ff68c719 1222 dc = SvPVX(sv); /* sv_usepvn() calls Renew() */
79072805 1223 }
0c57e439
GS
1224 if (left_utf || right_utf) {
1225 UV duc, luc, ruc;
794a0d33
JH
1226 char *dcorig = dc;
1227 char *dcsave = NULL;
0c57e439
GS
1228 STRLEN lulen = leftlen;
1229 STRLEN rulen = rightlen;
ba210ebe 1230 STRLEN ulen;
0c57e439
GS
1231
1232 switch (optype) {
1233 case OP_BIT_AND:
1234 while (lulen && rulen) {
9041c2e3 1235 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
1236 lc += ulen;
1237 lulen -= ulen;
9041c2e3 1238 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
1239 rc += ulen;
1240 rulen -= ulen;
1241 duc = luc & ruc;
9041c2e3 1242 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
0c57e439 1243 }
2d78db9d
JH
1244 if (sv == left || sv == right) {
1245 (void)sv_usepvn(sv, dcorig, needlen); /* Uses Renew(). */
1246 needfree = FALSE; /* sv_usepvn() moved dcorig. */
1247 }
794a0d33 1248 SvCUR_set(sv, dc - dcorig);
0c57e439
GS
1249 break;
1250 case OP_BIT_XOR:
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
GS
1260 }
1261 goto mop_up_utf;
1262 case OP_BIT_OR:
1263 while (lulen && rulen) {
9041c2e3 1264 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
1265 lc += ulen;
1266 lulen -= ulen;
9041c2e3 1267 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
1268 rc += ulen;
1269 rulen -= ulen;
1270 duc = luc | ruc;
9041c2e3 1271 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
0c57e439 1272 }
2d78db9d 1273 goto mop_up_utf; /* For consistency. */
0c57e439 1274 mop_up_utf:
794a0d33
JH
1275 if (rulen)
1276 dcsave = savepvn(rc, rulen);
1277 else if (lulen)
1278 dcsave = savepvn(lc, lulen);
2d78db9d 1279 if (sv == left || sv == right) {
794a0d33 1280 (void)sv_usepvn(sv, dcorig, needlen); /* Uses Renew(). */
2d78db9d
JH
1281 needfree = FALSE; /* sv_usepvn() moved dcorig. */
1282 }
794a0d33 1283 SvCUR_set(sv, dc - dcorig);
0c57e439 1284 if (rulen)
794a0d33 1285 sv_catpvn(sv, dcsave, rulen);
0c57e439 1286 else if (lulen)
794a0d33 1287 sv_catpvn(sv, dcsave, lulen);
0c57e439
GS
1288 else
1289 *SvEND(sv) = '\0';
794a0d33 1290 Safefree(dcsave);
0c57e439
GS
1291 break;
1292 }
2d78db9d
JH
1293 if (needfree)
1294 Safefree(dcorig);
0c57e439
GS
1295 SvUTF8_on(sv);
1296 goto finish;
1297 }
1298 else
79072805
LW
1299#ifdef LIBERAL
1300 if (len >= sizeof(long)*4 &&
1301 !((long)dc % sizeof(long)) &&
1302 !((long)lc % sizeof(long)) &&
1303 !((long)rc % sizeof(long))) /* It's almost always aligned... */
1304 {
f54cb97a 1305 const I32 remainder = len % (sizeof(long)*4);
79072805
LW
1306 len /= (sizeof(long)*4);
1307
1308 dl = (long*)dc;
1309 ll = (long*)lc;
1310 rl = (long*)rc;
1311
1312 switch (optype) {
1313 case OP_BIT_AND:
1314 while (len--) {
1315 *dl++ = *ll++ & *rl++;
1316 *dl++ = *ll++ & *rl++;
1317 *dl++ = *ll++ & *rl++;
1318 *dl++ = *ll++ & *rl++;
1319 }
1320 break;
a0d0e21e 1321 case OP_BIT_XOR:
79072805
LW
1322 while (len--) {
1323 *dl++ = *ll++ ^ *rl++;
1324 *dl++ = *ll++ ^ *rl++;
1325 *dl++ = *ll++ ^ *rl++;
1326 *dl++ = *ll++ ^ *rl++;
1327 }
1328 break;
1329 case OP_BIT_OR:
1330 while (len--) {
1331 *dl++ = *ll++ | *rl++;
1332 *dl++ = *ll++ | *rl++;
1333 *dl++ = *ll++ | *rl++;
1334 *dl++ = *ll++ | *rl++;
1335 }
1336 }
1337
1338 dc = (char*)dl;
1339 lc = (char*)ll;
1340 rc = (char*)rl;
1341
1342 len = remainder;
1343 }
1344#endif
a0d0e21e 1345 {
a0d0e21e
LW
1346 switch (optype) {
1347 case OP_BIT_AND:
1348 while (len--)
1349 *dc++ = *lc++ & *rc++;
1a787b95 1350 *dc = '\0';
a0d0e21e
LW
1351 break;
1352 case OP_BIT_XOR:
1353 while (len--)
1354 *dc++ = *lc++ ^ *rc++;
1355 goto mop_up;
1356 case OP_BIT_OR:
1357 while (len--)
1358 *dc++ = *lc++ | *rc++;
1359 mop_up:
1360 len = lensave;
eb160463 1361 if (rightlen > (STRLEN)len)
a0d0e21e 1362 sv_catpvn(sv, rsave + len, rightlen - len);
eb160463 1363 else if (leftlen > (STRLEN)len)
a0d0e21e 1364 sv_catpvn(sv, lsave + len, leftlen - len);
4633a7c4
LW
1365 else
1366 *SvEND(sv) = '\0';
a0d0e21e
LW
1367 break;
1368 }
79072805 1369 }
0c57e439 1370finish:
fb73857a 1371 SvTAINT(sv);
79072805 1372}
463ee0b2
LW
1373
1374OP *
cea2e8a9 1375Perl_do_kv(pTHX)
463ee0b2 1376{
97aff369 1377 dVAR;
39644a26 1378 dSP;
c4420975 1379 HV * const hv = (HV*)POPs;
800e9ae0 1380 HV *keys;
463ee0b2 1381 register HE *entry;
f54cb97a
AL
1382 const I32 gimme = GIMME_V;
1383 const I32 dokv = (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV);
1384 const I32 dokeys = dokv || (PL_op->op_type == OP_KEYS);
1385 const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES);
463ee0b2 1386
85581909 1387 if (!hv) {
78f9721b 1388 if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
85581909
SB
1389 dTARGET; /* make sure to clear its target here */
1390 if (SvTYPE(TARG) == SVt_PVLV)
a0714e2c 1391 LvTARG(TARG) = NULL;
85581909
SB
1392 PUSHs(TARG);
1393 }
463ee0b2 1394 RETURN;
85581909 1395 }
748a9306 1396
6d822dc4 1397 keys = hv;
800e9ae0 1398 (void)hv_iterinit(keys); /* always reset iterator regardless */
748a9306 1399
54310121 1400 if (gimme == G_VOID)
aa689395
PP
1401 RETURN;
1402
54310121 1403 if (gimme == G_SCALAR) {
6ee623d5 1404 IV i;
463ee0b2
LW
1405 dTARGET;
1406
78f9721b 1407 if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
85581909
SB
1408 if (SvTYPE(TARG) < SVt_PVLV) {
1409 sv_upgrade(TARG, SVt_PVLV);
a0714e2c 1410 sv_magic(TARG, NULL, PERL_MAGIC_nkeys, NULL, 0);
85581909
SB
1411 }
1412 LvTYPE(TARG) = 'k';
800e9ae0 1413 if (LvTARG(TARG) != (SV*)keys) {
6ff81951
GS
1414 if (LvTARG(TARG))
1415 SvREFCNT_dec(LvTARG(TARG));
b37c2d43 1416 LvTARG(TARG) = SvREFCNT_inc_simple(keys);
6ff81951 1417 }
85581909
SB
1418 PUSHs(TARG);
1419 RETURN;
1420 }
1421
14befaf4 1422 if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied))
a98face1 1423 i = HvKEYS(keys);
463ee0b2
LW
1424 else {
1425 i = 0;
800e9ae0 1426 while (hv_iternext(keys)) i++;
463ee0b2
LW
1427 }
1428 PUSHi( i );
1429 RETURN;
1430 }
1431
8ed4b672 1432 EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
463ee0b2 1433
463ee0b2 1434 PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
155aba94 1435 while ((entry = hv_iternext(keys))) {
463ee0b2 1436 SPAGAIN;
574c8022 1437 if (dokeys) {
890ce7af 1438 SV* const sv = hv_iterkeysv(entry);
574c8022
JH
1439 XPUSHs(sv); /* won't clobber stack_sp */
1440 }
463ee0b2 1441 if (dovalues) {
f54cb97a 1442 SV *tmpstr;
463ee0b2 1443 PUTBACK;
6d822dc4 1444 tmpstr = hv_iterval(hv,entry);
cea2e8a9 1445 DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
46fc3d4c 1446 (unsigned long)HeHASH(entry),
cdd3ba14 1447 (int)HvMAX(keys)+1,
800e9ae0 1448 (unsigned long)(HeHASH(entry) & HvMAX(keys))));
463ee0b2 1449 SPAGAIN;
46fc3d4c 1450 XPUSHs(tmpstr);
463ee0b2
LW
1451 }
1452 PUTBACK;
1453 }
1454 return NORMAL;
1455}
4e35701f 1456
af3babe4
NC
1457/*
1458 * Local variables:
1459 * c-indentation-style: bsd
1460 * c-basic-offset: 4
1461 * indent-tabs-mode: t
1462 * End:
1463 *
37442d52
RGS
1464 * ex: set ts=8 sts=4 sw=4 noet:
1465 */