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