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