This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
The sv_catsv() fix, take two.
[perl5.git] / doop.c
CommitLineData
a0d0e21e 1/* doop.c
79072805 2 *
3818b22b 3 * Copyright (c) 1991-2000, Larry Wall
79072805
LW
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
a0d0e21e
LW
8 */
9
10/*
11 * "'So that was the job I felt I had to do when I started,' thought Sam."
79072805
LW
12 */
13
14#include "EXTERN.h"
864dbfa3 15#define PERL_IN_DOOP_C
79072805
LW
16#include "perl.h"
17
64ca3a65 18#ifndef PERL_MICRO
79072805
LW
19#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
20#include <signal.h>
21#endif
64ca3a65 22#endif
79072805 23
075321c3 24#define HALF_UTF8_UPGRADE(start,end) \
01ec43d0 25 STMT_START { \
96c7109f 26 if ((start)<(end)) { \
01ec43d0 27 U8* NeWsTr; \
48b1b78b 28 STRLEN LeN = (end) - (start); \
01ec43d0 29 NeWsTr = bytes_to_utf8(start, &LeN); \
075321c3
JH
30 Safefree(start); \
31 (start) = NeWsTr; \
32 (end) = (start) + LeN; \
96c7109f 33 } \
01ec43d0 34 } STMT_END
b250498f 35
942e002e 36STATIC I32
b250498f 37S_do_trans_simple(pTHX_ SV *sv)
79072805 38{
4757a243 39 U8 *s;
b250498f 40 U8 *d;
4757a243 41 U8 *send;
b250498f 42 U8 *dstart;
4757a243 43 I32 matches = 0;
b250498f 44 I32 sutf = SvUTF8(sv);
463ee0b2 45 STRLEN len;
4757a243
LW
46 short *tbl;
47 I32 ch;
79072805 48
4757a243
LW
49 tbl = (short*)cPVOP->op_pv;
50 if (!tbl)
2269b42e 51 Perl_croak(aTHX_ "panic: do_trans_simple");
a0ed51b3 52
4757a243
LW
53 s = (U8*)SvPV(sv, len);
54 send = s + len;
55
b250498f
GS
56 /* First, take care of non-UTF8 input strings, because they're easy */
57 if (!sutf) {
01ec43d0 58 while (s < send) {
036b4402 59 if ((ch = tbl[*s]) >= 0) {
01ec43d0
GS
60 matches++;
61 *s++ = ch;
62 }
63 else
64 s++;
65 }
66 SvSETMAGIC(sv);
b250498f
GS
67 return matches;
68 }
4757a243 69
b250498f
GS
70 /* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
71 Newz(0, d, len*2+1, U8);
72 dstart = d;
73 while (s < send) {
ba210ebe 74 STRLEN ulen;
b250498f
GS
75 short c;
76
77 ulen = 1;
78 /* Need to check this, otherwise 128..255 won't match */
dcad2880 79 c = utf8_to_uv(s, send - s, &ulen, 0);
b250498f
GS
80 if (c < 0x100 && (ch = tbl[(short)c]) >= 0) {
81 matches++;
ed646e6e 82 d = uv_to_utf8(d,ch);
b250498f 83 s += ulen;
01ec43d0
GS
84 }
85 else { /* No match -> copy */
b250498f
GS
86 while (ulen--)
87 *d++ = *s++;
88 }
89 }
01ec43d0 90 *d = '\0';
be3174d2 91 sv_setpvn(sv, (const char*)dstart, d - dstart);
fdbb8cbd 92 Safefree(dstart);
b250498f 93 SvUTF8_on(sv);
b250498f 94 SvSETMAGIC(sv);
4757a243
LW
95 return matches;
96}
97
942e002e 98STATIC I32
036b4402 99S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */
4757a243 100{
4757a243
LW
101 U8 *s;
102 U8 *send;
103 I32 matches = 0;
036b4402 104 I32 hasutf = SvUTF8(sv);
4757a243
LW
105 STRLEN len;
106 short *tbl;
107
108 tbl = (short*)cPVOP->op_pv;
109 if (!tbl)
2269b42e 110 Perl_croak(aTHX_ "panic: do_trans_count");
4757a243
LW
111
112 s = (U8*)SvPV(sv, len);
113 send = s + len;
114
115 while (s < send) {
036b4402 116 if (hasutf && *s & 0x80)
01ec43d0 117 s += UTF8SKIP(s);
036b4402 118 else {
b250498f 119 UV c;
ba210ebe 120 STRLEN ulen;
b250498f
GS
121 ulen = 1;
122 if (hasutf)
dcad2880 123 c = utf8_to_uv(s, send - s, &ulen, 0);
b250498f
GS
124 else
125 c = *s;
126 if (c < 0x100 && tbl[c] >= 0)
036b4402 127 matches++;
01ec43d0 128 s += ulen;
036b4402 129 }
4757a243
LW
130 }
131
132 return matches;
133}
134
942e002e 135STATIC I32
b250498f 136S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
4757a243 137{
4757a243
LW
138 U8 *s;
139 U8 *send;
140 U8 *d;
5e44153e 141 U8 *dstart;
036b4402 142 I32 hasutf = SvUTF8(sv);
4757a243
LW
143 I32 matches = 0;
144 STRLEN len;
145 short *tbl;
146 I32 ch;
147
148 tbl = (short*)cPVOP->op_pv;
149 if (!tbl)
2269b42e 150 Perl_croak(aTHX_ "panic: do_trans_complex");
4757a243
LW
151
152 s = (U8*)SvPV(sv, len);
153 send = s + len;
154
5e44153e
SC
155 Newz(0, d, len*2+1, U8);
156 dstart = d;
157
4757a243
LW
158 if (PL_op->op_private & OPpTRANS_SQUASH) {
159 U8* p = send;
160
161 while (s < send) {
036b4402 162 if (hasutf && *s & 0x80)
01ec43d0 163 s += UTF8SKIP(s);
036b4402
GS
164 else {
165 if ((ch = tbl[*s]) >= 0) {
166 *d = ch;
167 matches++;
5e44153e 168 if (p != d - 1 || *p != *d)
036b4402
GS
169 p = d++;
170 }
01ec43d0 171 else if (ch == -1) /* -1 is unmapped character */
036b4402
GS
172 *d++ = *s; /* -2 is delete character */
173 s++;
174 }
a0ed51b3 175 }
4757a243
LW
176 }
177 else {
178 while (s < send) {
5e44153e 179 UV comp;
036b4402 180 if (hasutf && *s & 0x80)
5e44153e
SC
181 comp = utf8_to_uv_simple(s, NULL);
182 else
183 comp = *s;
184
185 ch = tbl[comp];
186
187 if (ch == -1) { /* -1 is unmapped character */
188 ch = comp;
189 matches--;
190 }
191
ed646e6e
SC
192 if (ch >= 0)
193 d = uv_to_utf8(d, ch);
194
5e44153e
SC
195 matches++;
196
197 s += hasutf && *s & 0x80 ? UNISKIP(*s) : 1;
198
5d06d08e 199 }
4757a243 200 }
5e44153e 201
4757a243 202 *d = '\0';
4757a243 203
5e44153e
SC
204 sv_setpvn(sv, (const char*)dstart, d - dstart);
205 Safefree(dstart);
206 if (hasutf)
207 SvUTF8_on(sv);
208 SvSETMAGIC(sv);
4757a243 209 return matches;
5e44153e 210
4757a243
LW
211}
212
942e002e 213STATIC I32
036b4402 214S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
4757a243 215{
4757a243
LW
216 U8 *s;
217 U8 *send;
218 U8 *d;
036b4402
GS
219 U8 *start;
220 U8 *dstart;
4757a243
LW
221 I32 matches = 0;
222 STRLEN len;
223
224 SV* rv = (SV*)cSVOP->op_sv;
225 HV* hv = (HV*)SvRV(rv);
226 SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
227 UV none = svp ? SvUV(*svp) : 0x7fffffff;
228 UV extra = none + 1;
229 UV final;
230 UV uv;
8e84507e 231 I32 isutf;
036b4402 232 I32 howmany;
4757a243 233
036b4402 234 isutf = SvUTF8(sv);
4757a243
LW
235 s = (U8*)SvPV(sv, len);
236 send = s + len;
036b4402 237 start = s;
4757a243
LW
238
239 svp = hv_fetch(hv, "FINAL", 5, FALSE);
240 if (svp)
241 final = SvUV(*svp);
242
036b4402
GS
243 /* d needs to be bigger than s, in case e.g. upgrading is required */
244 Newz(0, d, len*2+1, U8);
245 dstart = d;
4757a243
LW
246 while (s < send) {
247 if ((uv = swash_fetch(rv, s)) < none) {
248 s += UTF8SKIP(s);
249 matches++;
01ec43d0 250 if ((uv & 0x80) && !isutf++)
075321c3 251 HALF_UTF8_UPGRADE(dstart,d);
4757a243
LW
252 d = uv_to_utf8(d, uv);
253 }
254 else if (uv == none) {
255 int i;
01ec43d0 256 i = UTF8SKIP(s);
b250498f 257 if (i > 1 && !isutf++)
075321c3 258 HALF_UTF8_UPGRADE(dstart,d);
036b4402 259 while(i--)
075321c3 260 *d++ = *s++;
4757a243
LW
261 }
262 else if (uv == extra) {
036b4402 263 int i;
01ec43d0 264 i = UTF8SKIP(s);
036b4402 265 s += i;
4757a243 266 matches++;
8e84507e 267 if (i > 1 && !isutf++)
075321c3 268 HALF_UTF8_UPGRADE(dstart,d);
4757a243
LW
269 d = uv_to_utf8(d, final);
270 }
271 else
272 s += UTF8SKIP(s);
273 }
274 *d = '\0';
be3174d2 275 sv_setpvn(sv, (const char*)dstart, d - dstart);
4757a243 276 SvSETMAGIC(sv);
036b4402
GS
277 if (isutf)
278 SvUTF8_on(sv);
4757a243
LW
279
280 return matches;
281}
282
942e002e 283STATIC I32
036b4402 284S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */
4757a243 285{
4757a243
LW
286 U8 *s;
287 U8 *send;
288 I32 matches = 0;
289 STRLEN len;
290
291 SV* rv = (SV*)cSVOP->op_sv;
292 HV* hv = (HV*)SvRV(rv);
293 SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
294 UV none = svp ? SvUV(*svp) : 0x7fffffff;
295 UV uv;
296
297 s = (U8*)SvPV(sv, len);
036b4402
GS
298 if (!SvUTF8(sv))
299 s = bytes_to_utf8(s, &len);
4757a243
LW
300 send = s + len;
301
302 while (s < send) {
834a4ddd 303 if ((uv = swash_fetch(rv, s)) < none)
4757a243 304 matches++;
834a4ddd 305 s += UTF8SKIP(s);
4757a243
LW
306 }
307
308 return matches;
309}
310
942e002e 311STATIC I32
036b4402 312S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
4757a243 313{
4757a243
LW
314 U8 *s;
315 U8 *send;
316 U8 *d;
317 I32 matches = 0;
318 I32 squash = PL_op->op_private & OPpTRANS_SQUASH;
4757a243
LW
319 I32 del = PL_op->op_private & OPpTRANS_DELETE;
320 SV* rv = (SV*)cSVOP->op_sv;
321 HV* hv = (HV*)SvRV(rv);
322 SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
323 UV none = svp ? SvUV(*svp) : 0x7fffffff;
324 UV extra = none + 1;
325 UV final;
326 UV uv;
327 STRLEN len;
328 U8 *dst;
b250498f 329 I32 isutf = SvUTF8(sv);
4757a243
LW
330
331 s = (U8*)SvPV(sv, len);
332 send = s + len;
333
334 svp = hv_fetch(hv, "FINAL", 5, FALSE);
335 if (svp)
336 final = SvUV(*svp);
337
b250498f 338 Newz(0, d, len*2+1, U8);
4757a243 339 dst = d;
4757a243
LW
340
341 if (squash) {
342 UV puv = 0xfeedface;
343 while (s < send) {
8e84507e 344 if (SvUTF8(sv))
4757a243 345 uv = swash_fetch(rv, s);
a0ed51b3 346 else {
4757a243
LW
347 U8 tmpbuf[2];
348 uv = *s++;
349 if (uv < 0x80)
350 tmpbuf[0] = uv;
351 else {
352 tmpbuf[0] = (( uv >> 6) | 0xc0);
353 tmpbuf[1] = (( uv & 0x3f) | 0x80);
354 }
355 uv = swash_fetch(rv, tmpbuf);
356 }
b250498f 357
4757a243
LW
358 if (uv < none) {
359 matches++;
360 if (uv != puv) {
8e84507e 361 if ((uv & 0x80) && !isutf++)
075321c3 362 HALF_UTF8_UPGRADE(dst,d);
01ec43d0 363 d = uv_to_utf8(d, uv);
4757a243
LW
364 puv = uv;
365 }
075321c3 366 s += UTF8SKIP(s);
4757a243
LW
367 continue;
368 }
369 else if (uv == none) { /* "none" is unmapped character */
ba210ebe 370 STRLEN ulen;
dcad2880 371 *d++ = (U8)utf8_to_uv(s, send - s, &ulen, 0);
01ec43d0 372 s += ulen;
4757a243
LW
373 puv = 0xfeedface;
374 continue;
a0ed51b3 375 }
4757a243
LW
376 else if (uv == extra && !del) {
377 matches++;
378 if (uv != puv) {
01ec43d0 379 d = uv_to_utf8(d, final);
4757a243
LW
380 puv = final;
381 }
01ec43d0 382 s += UTF8SKIP(s);
4757a243
LW
383 continue;
384 }
01ec43d0
GS
385 matches++; /* "none+1" is delete character */
386 s += UTF8SKIP(s);
a0ed51b3 387 }
79072805
LW
388 }
389 else {
4757a243 390 while (s < send) {
8e84507e 391 if (SvUTF8(sv))
4757a243 392 uv = swash_fetch(rv, s);
4757a243
LW
393 else {
394 U8 tmpbuf[2];
395 uv = *s++;
396 if (uv < 0x80)
397 tmpbuf[0] = uv;
398 else {
399 tmpbuf[0] = (( uv >> 6) | 0xc0);
400 tmpbuf[1] = (( uv & 0x3f) | 0x80);
a0ed51b3 401 }
4757a243 402 uv = swash_fetch(rv, tmpbuf);
a0ed51b3 403 }
4757a243
LW
404 if (uv < none) {
405 matches++;
01ec43d0
GS
406 d = uv_to_utf8(d, uv);
407 s += UTF8SKIP(s);
4757a243 408 continue;
a0ed51b3 409 }
4757a243 410 else if (uv == none) { /* "none" is unmapped character */
ba210ebe 411 STRLEN ulen;
dcad2880 412 *d++ = (U8)utf8_to_uv(s, send - s, &ulen, 0);
01ec43d0 413 s += ulen;
4757a243 414 continue;
79072805 415 }
4757a243
LW
416 else if (uv == extra && !del) {
417 matches++;
01ec43d0
GS
418 d = uv_to_utf8(d, final);
419 s += UTF8SKIP(s);
4757a243
LW
420 continue;
421 }
01ec43d0
GS
422 matches++; /* "none+1" is delete character */
423 s += UTF8SKIP(s);
79072805 424 }
4757a243
LW
425 }
426 if (dst)
427 sv_usepvn(sv, (char*)dst, d - dst);
428 else {
429 *d = '\0';
430 SvCUR_set(sv, d - (U8*)SvPVX(sv));
431 }
432 SvSETMAGIC(sv);
433
434 return matches;
435}
436
437I32
864dbfa3 438Perl_do_trans(pTHX_ SV *sv)
4757a243
LW
439{
440 STRLEN len;
8e84507e 441 I32 hasutf = (PL_op->op_private &
036b4402 442 (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
4757a243
LW
443
444 if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
cea2e8a9 445 Perl_croak(aTHX_ PL_no_modify);
4757a243
LW
446
447 (void)SvPV(sv, len);
448 if (!len)
449 return 0;
450 if (!SvPOKp(sv))
451 (void)SvPV_force(sv, len);
2de7b02f
GS
452 if (!(PL_op->op_private & OPpTRANS_IDENTICAL))
453 (void)SvPOK_only_UTF8(sv);
4757a243 454
cea2e8a9 455 DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
4757a243 456
036b4402 457 switch (PL_op->op_private & ~hasutf & 63) {
4757a243 458 case 0:
01ec43d0
GS
459 if (hasutf)
460 return do_trans_simple_utf8(sv);
461 else
462 return do_trans_simple(sv);
4757a243
LW
463
464 case OPpTRANS_IDENTICAL:
01ec43d0
GS
465 if (hasutf)
466 return do_trans_count_utf8(sv);
467 else
468 return do_trans_count(sv);
4757a243
LW
469
470 default:
01ec43d0 471 if (hasutf)
036b4402 472 return do_trans_complex_utf8(sv);
4757a243 473 else
036b4402 474 return do_trans_complex(sv);
79072805 475 }
79072805
LW
476}
477
478void
864dbfa3 479Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp)
79072805
LW
480{
481 SV **oldmark = mark;
482 register I32 items = sp - mark;
79072805 483 register STRLEN len;
463ee0b2
LW
484 STRLEN delimlen;
485 register char *delim = SvPV(del, delimlen);
486 STRLEN tmplen;
79072805
LW
487
488 mark++;
489 len = (items > 0 ? (delimlen * (items - 1) ) : 0);
07f14f54 490 (void)SvUPGRADE(sv, SVt_PV);
79072805
LW
491 if (SvLEN(sv) < len + items) { /* current length is way too short */
492 while (items-- > 0) {
1426bbf4 493 if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) {
463ee0b2
LW
494 SvPV(*mark, tmplen);
495 len += tmplen;
79072805
LW
496 }
497 mark++;
498 }
499 SvGROW(sv, len + 1); /* so try to pre-extend */
500
501 mark = oldmark;
db7c17d7 502 items = sp - mark;
79072805
LW
503 ++mark;
504 }
505
463ee0b2 506 if (items-- > 0) {
92d29cee
JH
507 sv_setpv(sv, "");
508 if (*mark)
509 sv_catsv(sv, *mark);
463ee0b2
LW
510 mark++;
511 }
79072805
LW
512 else
513 sv_setpv(sv,"");
c512ce4f 514 if (delimlen) {
79072805 515 for (; items > 0; items--,mark++) {
c512ce4f 516 sv_catsv(sv,del);
79072805
LW
517 sv_catsv(sv,*mark);
518 }
519 }
520 else {
521 for (; items > 0; items--,mark++)
522 sv_catsv(sv,*mark);
523 }
524 SvSETMAGIC(sv);
525}
526
527void
864dbfa3 528Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
79072805 529{
46fc3d4c
PP
530 STRLEN patlen;
531 char *pat = SvPV(*sarg, patlen);
532 bool do_taint = FALSE;
533
534 sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
79072805 535 SvSETMAGIC(sv);
46fc3d4c
PP
536 if (do_taint)
537 SvTAINTED_on(sv);
79072805
LW
538}
539
33b45480 540/* currently converts input to bytes if possible, but doesn't sweat failure */
81e118e0
JH
541UV
542Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
543{
544 STRLEN srclen, len;
545 unsigned char *s = (unsigned char *) SvPV(sv, srclen);
546 UV retnum = 0;
547
a50d7633 548 if (offset < 0)
81e118e0 549 return retnum;
8e84507e 550 if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
a50d7633 551 Perl_croak(aTHX_ "Illegal number of bits in vec");
246fae53 552
dcad2880 553 if (SvUTF8(sv))
33b45480 554 (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE);
246fae53 555
81e118e0
JH
556 offset *= size; /* turn into bit offset */
557 len = (offset + size + 7) / 8; /* required number of bytes */
558 if (len > srclen) {
559 if (size <= 8)
560 retnum = 0;
561 else {
562 offset >>= 3; /* turn into byte offset */
563 if (size == 16) {
564 if (offset >= srclen)
565 retnum = 0;
566 else
628e1a40 567 retnum = (UV) s[offset] << 8;
81e118e0
JH
568 }
569 else if (size == 32) {
570 if (offset >= srclen)
571 retnum = 0;
572 else if (offset + 1 >= srclen)
573 retnum =
574 ((UV) s[offset ] << 24);
575 else if (offset + 2 >= srclen)
576 retnum =
577 ((UV) s[offset ] << 24) +
578 ((UV) s[offset + 1] << 16);
579 else
580 retnum =
581 ((UV) s[offset ] << 24) +
582 ((UV) s[offset + 1] << 16) +
583 ( s[offset + 2] << 8);
584 }
d7d93a81 585#ifdef UV_IS_QUAD
c5a0f51a 586 else if (size == 64) {
c5a0f51a
JH
587 if (ckWARN(WARN_PORTABLE))
588 Perl_warner(aTHX_ WARN_PORTABLE,
589 "Bit vector size > 32 non-portable");
590 if (offset >= srclen)
591 retnum = 0;
592 else if (offset + 1 >= srclen)
593 retnum =
594 (UV) s[offset ] << 56;
595 else if (offset + 2 >= srclen)
596 retnum =
597 ((UV) s[offset ] << 56) +
598 ((UV) s[offset + 1] << 48);
599 else if (offset + 3 >= srclen)
600 retnum =
601 ((UV) s[offset ] << 56) +
602 ((UV) s[offset + 1] << 48) +
603 ((UV) s[offset + 2] << 40);
604 else if (offset + 4 >= srclen)
605 retnum =
606 ((UV) s[offset ] << 56) +
607 ((UV) s[offset + 1] << 48) +
608 ((UV) s[offset + 2] << 40) +
609 ((UV) s[offset + 3] << 32);
610 else if (offset + 5 >= srclen)
611 retnum =
612 ((UV) s[offset ] << 56) +
613 ((UV) s[offset + 1] << 48) +
614 ((UV) s[offset + 2] << 40) +
615 ((UV) s[offset + 3] << 32) +
616 ( s[offset + 4] << 24);
617 else if (offset + 6 >= srclen)
618 retnum =
619 ((UV) s[offset ] << 56) +
620 ((UV) s[offset + 1] << 48) +
621 ((UV) s[offset + 2] << 40) +
622 ((UV) s[offset + 3] << 32) +
623 ((UV) s[offset + 4] << 24) +
624 ((UV) s[offset + 5] << 16);
625 else
8e84507e 626 retnum =
c5a0f51a
JH
627 ((UV) s[offset ] << 56) +
628 ((UV) s[offset + 1] << 48) +
629 ((UV) s[offset + 2] << 40) +
630 ((UV) s[offset + 3] << 32) +
631 ((UV) s[offset + 4] << 24) +
632 ((UV) s[offset + 5] << 16) +
628e1a40 633 ( s[offset + 6] << 8);
c5a0f51a
JH
634 }
635#endif
81e118e0
JH
636 }
637 }
638 else if (size < 8)
639 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
640 else {
641 offset >>= 3; /* turn into byte offset */
642 if (size == 8)
643 retnum = s[offset];
644 else if (size == 16)
645 retnum =
628e1a40 646 ((UV) s[offset] << 8) +
81e118e0
JH
647 s[offset + 1];
648 else if (size == 32)
649 retnum =
650 ((UV) s[offset ] << 24) +
651 ((UV) s[offset + 1] << 16) +
652 ( s[offset + 2] << 8) +
653 s[offset + 3];
d7d93a81 654#ifdef UV_IS_QUAD
c5a0f51a 655 else if (size == 64) {
c5a0f51a
JH
656 if (ckWARN(WARN_PORTABLE))
657 Perl_warner(aTHX_ WARN_PORTABLE,
658 "Bit vector size > 32 non-portable");
659 retnum =
660 ((UV) s[offset ] << 56) +
661 ((UV) s[offset + 1] << 48) +
662 ((UV) s[offset + 2] << 40) +
663 ((UV) s[offset + 3] << 32) +
664 ((UV) s[offset + 4] << 24) +
665 ((UV) s[offset + 5] << 16) +
628e1a40 666 ( s[offset + 6] << 8) +
c5a0f51a
JH
667 s[offset + 7];
668 }
669#endif
81e118e0
JH
670 }
671
672 return retnum;
673}
674
33b45480
SB
675/* currently converts input to bytes if possible but doesn't sweat failures,
676 * although it does ensure that the string it clobbers is not marked as
677 * utf8-valid any more
678 */
79072805 679void
864dbfa3 680Perl_do_vecset(pTHX_ SV *sv)
79072805
LW
681{
682 SV *targ = LvTARG(sv);
683 register I32 offset;
684 register I32 size;
8990e307 685 register unsigned char *s;
81e118e0 686 register UV lval;
79072805 687 I32 mask;
a0d0e21e
LW
688 STRLEN targlen;
689 STRLEN len;
79072805 690
8990e307
LW
691 if (!targ)
692 return;
a0d0e21e 693 s = (unsigned char*)SvPV_force(targ, targlen);
246fae53 694 if (SvUTF8(targ)) {
33b45480
SB
695 /* This is handled by the SvPOK_only below...
696 if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
697 SvUTF8_off(targ);
698 */
699 (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
246fae53
MG
700 }
701
4ebbc975 702 (void)SvPOK_only(targ);
81e118e0 703 lval = SvUV(sv);
79072805 704 offset = LvTARGOFF(sv);
fe58ced6
MG
705 if (offset < 0)
706 Perl_croak(aTHX_ "Assigning to negative offset in vec");
79072805 707 size = LvTARGLEN(sv);
8e84507e 708 if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
a50d7633 709 Perl_croak(aTHX_ "Illegal number of bits in vec");
8e84507e 710
81e118e0
JH
711 offset *= size; /* turn into bit offset */
712 len = (offset + size + 7) / 8; /* required number of bytes */
a0d0e21e
LW
713 if (len > targlen) {
714 s = (unsigned char*)SvGROW(targ, len + 1);
12ae5dfc 715 (void)memzero((char *)(s + targlen), len - targlen + 1);
a0d0e21e
LW
716 SvCUR_set(targ, len);
717 }
8e84507e 718
79072805
LW
719 if (size < 8) {
720 mask = (1 << size) - 1;
721 size = offset & 7;
722 lval &= mask;
81e118e0 723 offset >>= 3; /* turn into byte offset */
79072805
LW
724 s[offset] &= ~(mask << size);
725 s[offset] |= lval << size;
726 }
727 else {
81e118e0 728 offset >>= 3; /* turn into byte offset */
79072805 729 if (size == 8)
c5a0f51a 730 s[offset ] = lval & 0xff;
79072805 731 else if (size == 16) {
c5a0f51a
JH
732 s[offset ] = (lval >> 8) & 0xff;
733 s[offset+1] = lval & 0xff;
79072805
LW
734 }
735 else if (size == 32) {
c5a0f51a
JH
736 s[offset ] = (lval >> 24) & 0xff;
737 s[offset+1] = (lval >> 16) & 0xff;
738 s[offset+2] = (lval >> 8) & 0xff;
739 s[offset+3] = lval & 0xff;
740 }
d7d93a81 741#ifdef UV_IS_QUAD
c5a0f51a 742 else if (size == 64) {
c5a0f51a
JH
743 if (ckWARN(WARN_PORTABLE))
744 Perl_warner(aTHX_ WARN_PORTABLE,
745 "Bit vector size > 32 non-portable");
746 s[offset ] = (lval >> 56) & 0xff;
747 s[offset+1] = (lval >> 48) & 0xff;
748 s[offset+2] = (lval >> 40) & 0xff;
749 s[offset+3] = (lval >> 32) & 0xff;
750 s[offset+4] = (lval >> 24) & 0xff;
751 s[offset+5] = (lval >> 16) & 0xff;
752 s[offset+6] = (lval >> 8) & 0xff;
753 s[offset+7] = lval & 0xff;
79072805 754 }
dc1e3f56 755#endif
79072805 756 }
7bb043c3 757 SvSETMAGIC(targ);
79072805
LW
758}
759
760void
864dbfa3 761Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
79072805 762{
463ee0b2 763 STRLEN len;
a0d0e21e 764 char *s;
8e84507e 765
79072805 766 if (SvTYPE(sv) == SVt_PVAV) {
a0d0e21e
LW
767 register I32 i;
768 I32 max;
769 AV* av = (AV*)sv;
770 max = AvFILL(av);
771 for (i = 0; i <= max; i++) {
772 sv = (SV*)av_fetch(av, i, FALSE);
3280af22 773 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
a0d0e21e
LW
774 do_chop(astr, sv);
775 }
776 return;
79072805 777 }
aa854799 778 else if (SvTYPE(sv) == SVt_PVHV) {
a0d0e21e
LW
779 HV* hv = (HV*)sv;
780 HE* entry;
781 (void)hv_iterinit(hv);
782 /*SUPPRESS 560*/
155aba94 783 while ((entry = hv_iternext(hv)))
a0d0e21e
LW
784 do_chop(astr,hv_iterval(hv,entry));
785 return;
79072805 786 }
aa854799 787 else if (SvREADONLY(sv))
cea2e8a9 788 Perl_croak(aTHX_ PL_no_modify);
a0d0e21e 789 s = SvPV(sv, len);
748a9306 790 if (len && !SvPOK(sv))
a0d0e21e 791 s = SvPV_force(sv, len);
7e2040f0 792 if (DO_UTF8(sv)) {
a0ed51b3
LW
793 if (s && len) {
794 char *send = s + len;
795 char *start = s;
796 s = send - 1;
797 while ((*s & 0xc0) == 0x80)
798 --s;
0453d815
PM
799 if (UTF8SKIP(s) != send - s && ckWARN_d(WARN_UTF8))
800 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
a0ed51b3
LW
801 sv_setpvn(astr, s, send - s);
802 *s = '\0';
803 SvCUR_set(sv, s - start);
804 SvNIOK_off(sv);
7e2040f0 805 SvUTF8_on(astr);
a0ed51b3
LW
806 }
807 else
808 sv_setpvn(astr, "", 0);
809 }
7e2040f0 810 else if (s && len) {
a0d0e21e
LW
811 s += --len;
812 sv_setpvn(astr, s, 1);
813 *s = '\0';
814 SvCUR_set(sv, len);
2c19a612 815 SvUTF8_off(sv);
a0d0e21e 816 SvNIOK_off(sv);
79072805
LW
817 }
818 else
a0d0e21e
LW
819 sv_setpvn(astr, "", 0);
820 SvSETMAGIC(sv);
7e2040f0 821}
a0d0e21e
LW
822
823I32
864dbfa3 824Perl_do_chomp(pTHX_ register SV *sv)
a0d0e21e 825{
c07a80fd 826 register I32 count;
a0d0e21e
LW
827 STRLEN len;
828 char *s;
c07a80fd 829
3280af22 830 if (RsSNARF(PL_rs))
c07a80fd 831 return 0;
4c5a6083
GS
832 if (RsRECORD(PL_rs))
833 return 0;
c07a80fd 834 count = 0;
a0d0e21e
LW
835 if (SvTYPE(sv) == SVt_PVAV) {
836 register I32 i;
837 I32 max;
838 AV* av = (AV*)sv;
839 max = AvFILL(av);
840 for (i = 0; i <= max; i++) {
841 sv = (SV*)av_fetch(av, i, FALSE);
3280af22 842 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
a0d0e21e
LW
843 count += do_chomp(sv);
844 }
845 return count;
846 }
aa854799 847 else if (SvTYPE(sv) == SVt_PVHV) {
a0d0e21e
LW
848 HV* hv = (HV*)sv;
849 HE* entry;
850 (void)hv_iterinit(hv);
851 /*SUPPRESS 560*/
155aba94 852 while ((entry = hv_iternext(hv)))
a0d0e21e
LW
853 count += do_chomp(hv_iterval(hv,entry));
854 return count;
855 }
aa854799 856 else if (SvREADONLY(sv))
cea2e8a9 857 Perl_croak(aTHX_ PL_no_modify);
a0d0e21e
LW
858 s = SvPV(sv, len);
859 if (len && !SvPOKp(sv))
860 s = SvPV_force(sv, len);
861 if (s && len) {
862 s += --len;
3280af22 863 if (RsPARA(PL_rs)) {
a0d0e21e
LW
864 if (*s != '\n')
865 goto nope;
866 ++count;
867 while (len && s[-1] == '\n') {
868 --len;
869 --s;
870 ++count;
871 }
872 }
a0d0e21e 873 else {
c07a80fd 874 STRLEN rslen;
3280af22 875 char *rsptr = SvPV(PL_rs, rslen);
c07a80fd
PP
876 if (rslen == 1) {
877 if (*s != *rsptr)
878 goto nope;
879 ++count;
880 }
881 else {
8c2cee6f 882 if (len < rslen - 1)
c07a80fd
PP
883 goto nope;
884 len -= rslen - 1;
885 s -= rslen - 1;
36477c24 886 if (memNE(s, rsptr, rslen))
c07a80fd
PP
887 goto nope;
888 count += rslen;
889 }
a0d0e21e 890 }
a0d0e21e
LW
891 *s = '\0';
892 SvCUR_set(sv, len);
893 SvNIOK_off(sv);
894 }
895 nope:
896 SvSETMAGIC(sv);
897 return count;
8e84507e 898}
79072805
LW
899
900void
864dbfa3 901Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
79072805
LW
902{
903#ifdef LIBERAL
904 register long *dl;
905 register long *ll;
906 register long *rl;
907#endif
908 register char *dc;
463ee0b2
LW
909 STRLEN leftlen;
910 STRLEN rightlen;
7a4c00b4
PP
911 register char *lc;
912 register char *rc;
79072805 913 register I32 len;
a0d0e21e 914 I32 lensave;
7a4c00b4
PP
915 char *lsave;
916 char *rsave;
0c57e439
GS
917 bool left_utf = DO_UTF8(left);
918 bool right_utf = DO_UTF8(right);
c9b3c8d0 919 I32 needlen;
0c57e439
GS
920
921 if (left_utf && !right_utf)
922 sv_utf8_upgrade(right);
a1ca4561 923 else if (!left_utf && right_utf)
0c57e439 924 sv_utf8_upgrade(left);
79072805 925
1fbd88dc
CS
926 if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
927 sv_setpvn(sv, "", 0); /* avoid undef warning on |= and ^= */
7a4c00b4
PP
928 lsave = lc = SvPV(left, leftlen);
929 rsave = rc = SvPV(right, rightlen);
93a17b20 930 len = leftlen < rightlen ? leftlen : rightlen;
a0d0e21e 931 lensave = len;
c9b3c8d0
JH
932 if ((left_utf || right_utf) && (sv == left || sv == right)) {
933 needlen = optype == OP_BIT_AND ? len : leftlen + rightlen;
934 Newz(801, dc, needlen + 1, char);
935 }
936 else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
2d8e6c8d
GS
937 STRLEN n_a;
938 dc = SvPV_force(sv, n_a);
ff68c719
PP
939 if (SvCUR(sv) < len) {
940 dc = SvGROW(sv, len + 1);
941 (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
942 }
c9b3c8d0
JH
943 if (optype != OP_BIT_AND && (left_utf || right_utf))
944 dc = SvGROW(sv, leftlen + rightlen + 1);
ff68c719
PP
945 }
946 else {
c9b3c8d0
JH
947 needlen = ((optype == OP_BIT_AND)
948 ? len : (leftlen > rightlen ? leftlen : rightlen));
ff68c719
PP
949 Newz(801, dc, needlen + 1, char);
950 (void)sv_usepvn(sv, dc, needlen);
951 dc = SvPVX(sv); /* sv_usepvn() calls Renew() */
79072805 952 }
a0d0e21e
LW
953 SvCUR_set(sv, len);
954 (void)SvPOK_only(sv);
0c57e439
GS
955 if (left_utf || right_utf) {
956 UV duc, luc, ruc;
c9b3c8d0 957 char *dcsave = dc;
0c57e439
GS
958 STRLEN lulen = leftlen;
959 STRLEN rulen = rightlen;
ba210ebe 960 STRLEN ulen;
0c57e439
GS
961
962 switch (optype) {
963 case OP_BIT_AND:
964 while (lulen && rulen) {
cc366d4b 965 luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
966 lc += ulen;
967 lulen -= ulen;
cc366d4b 968 ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
969 rc += ulen;
970 rulen -= ulen;
971 duc = luc & ruc;
972 dc = (char*)uv_to_utf8((U8*)dc, duc);
973 }
c9b3c8d0
JH
974 if (sv == left || sv == right)
975 (void)sv_usepvn(sv, dcsave, needlen);
976 SvCUR_set(sv, dc - dcsave);
0c57e439
GS
977 break;
978 case OP_BIT_XOR:
979 while (lulen && rulen) {
cc366d4b 980 luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
981 lc += ulen;
982 lulen -= ulen;
cc366d4b 983 ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
984 rc += ulen;
985 rulen -= ulen;
986 duc = luc ^ ruc;
987 dc = (char*)uv_to_utf8((U8*)dc, duc);
988 }
989 goto mop_up_utf;
990 case OP_BIT_OR:
991 while (lulen && rulen) {
cc366d4b 992 luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
993 lc += ulen;
994 lulen -= ulen;
cc366d4b 995 ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
0c57e439
GS
996 rc += ulen;
997 rulen -= ulen;
998 duc = luc | ruc;
999 dc = (char*)uv_to_utf8((U8*)dc, duc);
1000 }
1001 mop_up_utf:
c9b3c8d0
JH
1002 if (sv == left || sv == right)
1003 (void)sv_usepvn(sv, dcsave, needlen);
1004 SvCUR_set(sv, dc - dcsave);
0c57e439
GS
1005 if (rulen)
1006 sv_catpvn(sv, rc, rulen);
1007 else if (lulen)
1008 sv_catpvn(sv, lc, lulen);
1009 else
1010 *SvEND(sv) = '\0';
1011 break;
1012 }
1013 SvUTF8_on(sv);
1014 goto finish;
1015 }
1016 else
79072805
LW
1017#ifdef LIBERAL
1018 if (len >= sizeof(long)*4 &&
1019 !((long)dc % sizeof(long)) &&
1020 !((long)lc % sizeof(long)) &&
1021 !((long)rc % sizeof(long))) /* It's almost always aligned... */
1022 {
1023 I32 remainder = len % (sizeof(long)*4);
1024 len /= (sizeof(long)*4);
1025
1026 dl = (long*)dc;
1027 ll = (long*)lc;
1028 rl = (long*)rc;
1029
1030 switch (optype) {
1031 case OP_BIT_AND:
1032 while (len--) {
1033 *dl++ = *ll++ & *rl++;
1034 *dl++ = *ll++ & *rl++;
1035 *dl++ = *ll++ & *rl++;
1036 *dl++ = *ll++ & *rl++;
1037 }
1038 break;
a0d0e21e 1039 case OP_BIT_XOR:
79072805
LW
1040 while (len--) {
1041 *dl++ = *ll++ ^ *rl++;
1042 *dl++ = *ll++ ^ *rl++;
1043 *dl++ = *ll++ ^ *rl++;
1044 *dl++ = *ll++ ^ *rl++;
1045 }
1046 break;
1047 case OP_BIT_OR:
1048 while (len--) {
1049 *dl++ = *ll++ | *rl++;
1050 *dl++ = *ll++ | *rl++;
1051 *dl++ = *ll++ | *rl++;
1052 *dl++ = *ll++ | *rl++;
1053 }
1054 }
1055
1056 dc = (char*)dl;
1057 lc = (char*)ll;
1058 rc = (char*)rl;
1059
1060 len = remainder;
1061 }
1062#endif
a0d0e21e 1063 {
a0d0e21e
LW
1064 switch (optype) {
1065 case OP_BIT_AND:
1066 while (len--)
1067 *dc++ = *lc++ & *rc++;
1068 break;
1069 case OP_BIT_XOR:
1070 while (len--)
1071 *dc++ = *lc++ ^ *rc++;
1072 goto mop_up;
1073 case OP_BIT_OR:
1074 while (len--)
1075 *dc++ = *lc++ | *rc++;
1076 mop_up:
1077 len = lensave;
1078 if (rightlen > len)
1079 sv_catpvn(sv, rsave + len, rightlen - len);
1080 else if (leftlen > len)
1081 sv_catpvn(sv, lsave + len, leftlen - len);
4633a7c4
LW
1082 else
1083 *SvEND(sv) = '\0';
a0d0e21e
LW
1084 break;
1085 }
79072805 1086 }
0c57e439 1087finish:
fb73857a 1088 SvTAINT(sv);
79072805 1089}
463ee0b2
LW
1090
1091OP *
cea2e8a9 1092Perl_do_kv(pTHX)
463ee0b2 1093{
4e35701f 1094 djSP;
463ee0b2 1095 HV *hv = (HV*)POPs;
800e9ae0 1096 HV *keys;
463ee0b2 1097 register HE *entry;
463ee0b2 1098 SV *tmpstr;
54310121 1099 I32 gimme = GIMME_V;
533c011a
NIS
1100 I32 dokeys = (PL_op->op_type == OP_KEYS);
1101 I32 dovalues = (PL_op->op_type == OP_VALUES);
c750a3ec 1102 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
8e84507e
NIS
1103
1104 if (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV)
a0d0e21e 1105 dokeys = dovalues = TRUE;
463ee0b2 1106
85581909 1107 if (!hv) {
533c011a 1108 if (PL_op->op_flags & OPf_MOD) { /* lvalue */
85581909
SB
1109 dTARGET; /* make sure to clear its target here */
1110 if (SvTYPE(TARG) == SVt_PVLV)
1111 LvTARG(TARG) = Nullsv;
1112 PUSHs(TARG);
1113 }
463ee0b2 1114 RETURN;
85581909 1115 }
748a9306 1116
800e9ae0
JP
1117 keys = realhv ? hv : avhv_keys((AV*)hv);
1118 (void)hv_iterinit(keys); /* always reset iterator regardless */
748a9306 1119
54310121 1120 if (gimme == G_VOID)
aa689395
PP
1121 RETURN;
1122
54310121 1123 if (gimme == G_SCALAR) {
6ee623d5 1124 IV i;
463ee0b2
LW
1125 dTARGET;
1126
533c011a 1127 if (PL_op->op_flags & OPf_MOD) { /* lvalue */
85581909
SB
1128 if (SvTYPE(TARG) < SVt_PVLV) {
1129 sv_upgrade(TARG, SVt_PVLV);
1130 sv_magic(TARG, Nullsv, 'k', Nullch, 0);
1131 }
1132 LvTYPE(TARG) = 'k';
800e9ae0 1133 if (LvTARG(TARG) != (SV*)keys) {
6ff81951
GS
1134 if (LvTARG(TARG))
1135 SvREFCNT_dec(LvTARG(TARG));
800e9ae0 1136 LvTARG(TARG) = SvREFCNT_inc(keys);
6ff81951 1137 }
85581909
SB
1138 PUSHs(TARG);
1139 RETURN;
1140 }
1141
33c27489 1142 if (! SvTIED_mg((SV*)keys, 'P'))
800e9ae0 1143 i = HvKEYS(keys);
463ee0b2
LW
1144 else {
1145 i = 0;
463ee0b2 1146 /*SUPPRESS 560*/
800e9ae0 1147 while (hv_iternext(keys)) i++;
463ee0b2
LW
1148 }
1149 PUSHi( i );
1150 RETURN;
1151 }
1152
8ed4b672 1153 EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
463ee0b2 1154
463ee0b2 1155 PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
155aba94 1156 while ((entry = hv_iternext(keys))) {
463ee0b2 1157 SPAGAIN;
6bfc225d 1158 if (dokeys)
8c2cee6f 1159 XPUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
463ee0b2 1160 if (dovalues) {
463ee0b2 1161 PUTBACK;
b6429b1b
GS
1162 tmpstr = realhv ?
1163 hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry);
cea2e8a9 1164 DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
46fc3d4c 1165 (unsigned long)HeHASH(entry),
800e9ae0
JP
1166 HvMAX(keys)+1,
1167 (unsigned long)(HeHASH(entry) & HvMAX(keys))));
463ee0b2 1168 SPAGAIN;
46fc3d4c 1169 XPUSHs(tmpstr);
463ee0b2
LW
1170 }
1171 PUTBACK;
1172 }
1173 return NORMAL;
1174}
4e35701f 1175