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