1 /* doop.c
2 *
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2004, by Larry Wall and others
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11 /*
12 * "'So that was the job I felt I had to do when I started,' thought Sam."
13 */
14
15 #include "EXTERN.h"
16 #define PERL_IN_DOOP_C
17 #include "perl.h"
18
19 #ifndef PERL_MICRO
20 #include <signal.h>
21 #endif
22
23 STATIC I32
S_do_trans_simple(pTHX_ SV * sv)24 S_do_trans_simple(pTHX_ SV *sv)
25 {
26 U8 *s;
27 U8 *d;
28 U8 *send;
29 U8 *dstart;
30 I32 matches = 0;
31 I32 grows = PL_op->op_private & OPpTRANS_GROWS;
32 STRLEN len;
33 short *tbl;
34 I32 ch;
35
36 tbl = (short*)cPVOP->op_pv;
37 if (!tbl)
38 Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__);
39
40 s = (U8*)SvPV(sv, len);
41 send = s + len;
42
43 /* First, take care of non-UTF-8 input strings, because they're easy */
44 if (!SvUTF8(sv)) {
45 while (s < send) {
46 if ((ch = tbl[*s]) >= 0) {
47 matches++;
48 *s++ = (U8)ch;
49 }
50 else
51 s++;
52 }
53 SvSETMAGIC(sv);
54 return matches;
55 }
56
57 /* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
58 if (grows)
59 New(0, d, len*2+1, U8);
60 else
61 d = s;
62 dstart = d;
63 while (s < send) {
64 STRLEN ulen;
65 UV c;
66
67 /* Need to check this, otherwise 128..255 won't match */
68 c = utf8n_to_uvchr(s, send - s, &ulen, 0);
69 if (c < 0x100 && (ch = tbl[c]) >= 0) {
70 matches++;
71 d = uvchr_to_utf8(d, ch);
72 s += ulen;
73 }
74 else { /* No match -> copy */
75 Move(s, d, ulen, U8);
76 d += ulen;
77 s += ulen;
78 }
79 }
80 if (grows) {
81 sv_setpvn(sv, (char*)dstart, d - dstart);
82 Safefree(dstart);
83 }
84 else {
85 *d = '\0';
86 SvCUR_set(sv, d - dstart);
87 }
88 SvUTF8_on(sv);
89 SvSETMAGIC(sv);
90 return matches;
91 }
92
93 STATIC I32
S_do_trans_count(pTHX_ SV * sv)94 S_do_trans_count(pTHX_ SV *sv)
95 {
96 U8 *s;
97 U8 *send;
98 I32 matches = 0;
99 STRLEN len;
100 short *tbl;
101 I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
102
103 tbl = (short*)cPVOP->op_pv;
104 if (!tbl)
105 Perl_croak(aTHX_ "panic: do_trans_count line %d",__LINE__);
106
107 s = (U8*)SvPV(sv, len);
108 send = s + len;
109
110 if (!SvUTF8(sv))
111 while (s < send) {
112 if (tbl[*s++] >= 0)
113 matches++;
114 }
115 else
116 while (s < send) {
117 UV c;
118 STRLEN ulen;
119 c = utf8n_to_uvchr(s, send - s, &ulen, 0);
120 if (c < 0x100) {
121 if (tbl[c] >= 0)
122 matches++;
123 } else if (complement)
124 matches++;
125 s += ulen;
126 }
127
128 return matches;
129 }
130
131 STATIC I32
S_do_trans_complex(pTHX_ SV * sv)132 S_do_trans_complex(pTHX_ SV *sv)
133 {
134 U8 *s;
135 U8 *send;
136 U8 *d;
137 U8 *dstart;
138 I32 isutf8;
139 I32 matches = 0;
140 I32 grows = PL_op->op_private & OPpTRANS_GROWS;
141 I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
142 I32 del = PL_op->op_private & OPpTRANS_DELETE;
143 STRLEN len, rlen = 0;
144 short *tbl;
145 I32 ch;
146
147 tbl = (short*)cPVOP->op_pv;
148 if (!tbl)
149 Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__);
150
151 s = (U8*)SvPV(sv, len);
152 isutf8 = SvUTF8(sv);
153 send = s + len;
154
155 if (!isutf8) {
156 dstart = d = s;
157 if (PL_op->op_private & OPpTRANS_SQUASH) {
158 U8* p = send;
159 while (s < send) {
160 if ((ch = tbl[*s]) >= 0) {
161 *d = (U8)ch;
162 matches++;
163 if (p != d - 1 || *p != *d)
164 p = d++;
165 }
166 else if (ch == -1) /* -1 is unmapped character */
167 *d++ = *s;
168 else if (ch == -2) /* -2 is delete character */
169 matches++;
170 s++;
171 }
172 }
173 else {
174 while (s < send) {
175 if ((ch = tbl[*s]) >= 0) {
176 matches++;
177 *d++ = (U8)ch;
178 }
179 else if (ch == -1) /* -1 is unmapped character */
180 *d++ = *s;
181 else if (ch == -2) /* -2 is delete character */
182 matches++;
183 s++;
184 }
185 }
186 *d = '\0';
187 SvCUR_set(sv, d - dstart);
188 }
189 else { /* isutf8 */
190 if (grows)
191 New(0, d, len*2+1, U8);
192 else
193 d = s;
194 dstart = d;
195 if (complement && !del)
196 rlen = tbl[0x100];
197
198 #ifdef MACOS_TRADITIONAL
199 #define comp CoMP /* "comp" is a keyword in some compilers ... */
200 #endif
201
202 if (PL_op->op_private & OPpTRANS_SQUASH) {
203 UV pch = 0xfeedface;
204 while (s < send) {
205 STRLEN len;
206 UV comp = utf8_to_uvchr(s, &len);
207
208 if (comp > 0xff) {
209 if (!complement) {
210 Copy(s, d, len, U8);
211 d += len;
212 }
213 else {
214 matches++;
215 if (!del) {
216 ch = (rlen == 0) ? comp :
217 (comp - 0x100 < rlen) ?
218 tbl[comp+1] : tbl[0x100+rlen];
219 if ((UV)ch != pch) {
220 d = uvchr_to_utf8(d, ch);
221 pch = (UV)ch;
222 }
223 s += len;
224 continue;
225 }
226 }
227 }
228 else if ((ch = tbl[comp]) >= 0) {
229 matches++;
230 if ((UV)ch != pch) {
231 d = uvchr_to_utf8(d, ch);
232 pch = (UV)ch;
233 }
234 s += len;
235 continue;
236 }
237 else if (ch == -1) { /* -1 is unmapped character */
238 Copy(s, d, len, U8);
239 d += len;
240 }
241 else if (ch == -2) /* -2 is delete character */
242 matches++;
243 s += len;
244 pch = 0xfeedface;
245 }
246 }
247 else {
248 while (s < send) {
249 STRLEN len;
250 UV comp = utf8_to_uvchr(s, &len);
251 if (comp > 0xff) {
252 if (!complement) {
253 Move(s, d, len, U8);
254 d += len;
255 }
256 else {
257 matches++;
258 if (!del) {
259 if (comp - 0x100 < rlen)
260 d = uvchr_to_utf8(d, tbl[comp+1]);
261 else
262 d = uvchr_to_utf8(d, tbl[0x100+rlen]);
263 }
264 }
265 }
266 else if ((ch = tbl[comp]) >= 0) {
267 d = uvchr_to_utf8(d, ch);
268 matches++;
269 }
270 else if (ch == -1) { /* -1 is unmapped character */
271 Copy(s, d, len, U8);
272 d += len;
273 }
274 else if (ch == -2) /* -2 is delete character */
275 matches++;
276 s += len;
277 }
278 }
279 if (grows) {
280 sv_setpvn(sv, (char*)dstart, d - dstart);
281 Safefree(dstart);
282 }
283 else {
284 *d = '\0';
285 SvCUR_set(sv, d - dstart);
286 }
287 SvUTF8_on(sv);
288 }
289 SvSETMAGIC(sv);
290 return matches;
291 }
292
293 STATIC I32
S_do_trans_simple_utf8(pTHX_ SV * sv)294 S_do_trans_simple_utf8(pTHX_ SV *sv)
295 {
296 U8 *s;
297 U8 *send;
298 U8 *d;
299 U8 *start;
300 U8 *dstart, *dend;
301 I32 matches = 0;
302 I32 grows = PL_op->op_private & OPpTRANS_GROWS;
303 STRLEN len;
304
305 SV* rv = (SV*)cSVOP->op_sv;
306 HV* hv = (HV*)SvRV(rv);
307 SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
308 UV none = svp ? SvUV(*svp) : 0x7fffffff;
309 UV extra = none + 1;
310 UV final = 0;
311 UV uv;
312 I32 isutf8;
313 U8 hibit = 0;
314
315 s = (U8*)SvPV(sv, len);
316 isutf8 = SvUTF8(sv);
317 if (!isutf8) {
318 U8 *t = s, *e = s + len;
319 while (t < e) {
320 U8 ch = *t++;
321 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
322 break;
323 }
324 if (hibit)
325 s = bytes_to_utf8(s, &len);
326 }
327 send = s + len;
328 start = s;
329
330 svp = hv_fetch(hv, "FINAL", 5, FALSE);
331 if (svp)
332 final = SvUV(*svp);
333
334 if (grows) {
335 /* d needs to be bigger than s, in case e.g. upgrading is required */
336 New(0, d, len*3+UTF8_MAXLEN, U8);
337 dend = d + len * 3;
338 dstart = d;
339 }
340 else {
341 dstart = d = s;
342 dend = d + len;
343 }
344
345 while (s < send) {
346 if ((uv = swash_fetch(rv, s, TRUE)) < none) {
347 s += UTF8SKIP(s);
348 matches++;
349 d = uvuni_to_utf8(d, uv);
350 }
351 else if (uv == none) {
352 int i = UTF8SKIP(s);
353 Move(s, d, i, U8);
354 d += i;
355 s += i;
356 }
357 else if (uv == extra) {
358 int i = UTF8SKIP(s);
359 s += i;
360 matches++;
361 d = uvuni_to_utf8(d, final);
362 }
363 else
364 s += UTF8SKIP(s);
365
366 if (d > dend) {
367 STRLEN clen = d - dstart;
368 STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
369 if (!grows)
370 Perl_croak(aTHX_ "panic: do_trans_simple_utf8 line %d",__LINE__);
371 Renew(dstart, nlen+UTF8_MAXLEN, U8);
372 d = dstart + clen;
373 dend = dstart + nlen;
374 }
375 }
376 if (grows || hibit) {
377 sv_setpvn(sv, (char*)dstart, d - dstart);
378 Safefree(dstart);
379 if (grows && hibit)
380 Safefree(start);
381 }
382 else {
383 *d = '\0';
384 SvCUR_set(sv, d - dstart);
385 }
386 SvSETMAGIC(sv);
387 SvUTF8_on(sv);
388
389 return matches;
390 }
391
392 STATIC I32
S_do_trans_count_utf8(pTHX_ SV * sv)393 S_do_trans_count_utf8(pTHX_ SV *sv)
394 {
395 U8 *s;
396 U8 *start = 0, *send;
397 I32 matches = 0;
398 STRLEN len;
399
400 SV* rv = (SV*)cSVOP->op_sv;
401 HV* hv = (HV*)SvRV(rv);
402 SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
403 UV none = svp ? SvUV(*svp) : 0x7fffffff;
404 UV extra = none + 1;
405 UV uv;
406 U8 hibit = 0;
407
408 s = (U8*)SvPV(sv, len);
409 if (!SvUTF8(sv)) {
410 U8 *t = s, *e = s + len;
411 while (t < e) {
412 U8 ch = *t++;
413 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
414 break;
415 }
416 if (hibit)
417 start = s = bytes_to_utf8(s, &len);
418 }
419 send = s + len;
420
421 while (s < send) {
422 if ((uv = swash_fetch(rv, s, TRUE)) < none || uv == extra)
423 matches++;
424 s += UTF8SKIP(s);
425 }
426 if (hibit)
427 Safefree(start);
428
429 return matches;
430 }
431
432 STATIC I32
S_do_trans_complex_utf8(pTHX_ SV * sv)433 S_do_trans_complex_utf8(pTHX_ SV *sv)
434 {
435 U8 *s;
436 U8 *start, *send;
437 U8 *d;
438 I32 matches = 0;
439 I32 squash = PL_op->op_private & OPpTRANS_SQUASH;
440 I32 del = PL_op->op_private & OPpTRANS_DELETE;
441 I32 grows = PL_op->op_private & OPpTRANS_GROWS;
442 SV* rv = (SV*)cSVOP->op_sv;
443 HV* hv = (HV*)SvRV(rv);
444 SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
445 UV none = svp ? SvUV(*svp) : 0x7fffffff;
446 UV extra = none + 1;
447 UV final = 0;
448 bool havefinal = FALSE;
449 UV uv;
450 STRLEN len;
451 U8 *dstart, *dend;
452 I32 isutf8;
453 U8 hibit = 0;
454
455 s = (U8*)SvPV(sv, len);
456 isutf8 = SvUTF8(sv);
457 if (!isutf8) {
458 U8 *t = s, *e = s + len;
459 while (t < e) {
460 U8 ch = *t++;
461 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
462 break;
463 }
464 if (hibit)
465 s = bytes_to_utf8(s, &len);
466 }
467 send = s + len;
468 start = s;
469
470 svp = hv_fetch(hv, "FINAL", 5, FALSE);
471 if (svp) {
472 final = SvUV(*svp);
473 havefinal = TRUE;
474 }
475
476 if (grows) {
477 /* d needs to be bigger than s, in case e.g. upgrading is required */
478 New(0, d, len*3+UTF8_MAXLEN, U8);
479 dend = d + len * 3;
480 dstart = d;
481 }
482 else {
483 dstart = d = s;
484 dend = d + len;
485 }
486
487 if (squash) {
488 UV puv = 0xfeedface;
489 while (s < send) {
490 uv = swash_fetch(rv, s, TRUE);
491
492 if (d > dend) {
493 STRLEN clen = d - dstart;
494 STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
495 if (!grows)
496 Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
497 Renew(dstart, nlen+UTF8_MAXLEN, U8);
498 d = dstart + clen;
499 dend = dstart + nlen;
500 }
501 if (uv < none) {
502 matches++;
503 s += UTF8SKIP(s);
504 if (uv != puv) {
505 d = uvuni_to_utf8(d, uv);
506 puv = uv;
507 }
508 continue;
509 }
510 else if (uv == none) { /* "none" is unmapped character */
511 int i = UTF8SKIP(s);
512 Move(s, d, i, U8);
513 d += i;
514 s += i;
515 puv = 0xfeedface;
516 continue;
517 }
518 else if (uv == extra && !del) {
519 matches++;
520 if (havefinal) {
521 s += UTF8SKIP(s);
522 if (puv != final) {
523 d = uvuni_to_utf8(d, final);
524 puv = final;
525 }
526 }
527 else {
528 STRLEN len;
529 uv = utf8_to_uvuni(s, &len);
530 if (uv != puv) {
531 Move(s, d, len, U8);
532 d += len;
533 puv = uv;
534 }
535 s += len;
536 }
537 continue;
538 }
539 matches++; /* "none+1" is delete character */
540 s += UTF8SKIP(s);
541 }
542 }
543 else {
544 while (s < send) {
545 uv = swash_fetch(rv, s, TRUE);
546 if (d > dend) {
547 STRLEN clen = d - dstart;
548 STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
549 if (!grows)
550 Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
551 Renew(dstart, nlen+UTF8_MAXLEN, U8);
552 d = dstart + clen;
553 dend = dstart + nlen;
554 }
555 if (uv < none) {
556 matches++;
557 s += UTF8SKIP(s);
558 d = uvuni_to_utf8(d, uv);
559 continue;
560 }
561 else if (uv == none) { /* "none" is unmapped character */
562 int i = UTF8SKIP(s);
563 Move(s, d, i, U8);
564 d += i;
565 s += i;
566 continue;
567 }
568 else if (uv == extra && !del) {
569 matches++;
570 s += UTF8SKIP(s);
571 d = uvuni_to_utf8(d, final);
572 continue;
573 }
574 matches++; /* "none+1" is delete character */
575 s += UTF8SKIP(s);
576 }
577 }
578 if (grows || hibit) {
579 sv_setpvn(sv, (char*)dstart, d - dstart);
580 Safefree(dstart);
581 if (grows && hibit)
582 Safefree(start);
583 }
584 else {
585 *d = '\0';
586 SvCUR_set(sv, d - dstart);
587 }
588 SvUTF8_on(sv);
589 SvSETMAGIC(sv);
590
591 return matches;
592 }
593
594 I32
Perl_do_trans(pTHX_ SV * sv)595 Perl_do_trans(pTHX_ SV *sv)
596 {
597 STRLEN len;
598 I32 hasutf = (PL_op->op_private &
599 (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
600
601 if (SvREADONLY(sv)) {
602 if (SvFAKE(sv))
603 sv_force_normal(sv);
604 if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
605 Perl_croak(aTHX_ PL_no_modify);
606 }
607 (void)SvPV(sv, len);
608 if (!len)
609 return 0;
610 if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) {
611 if (!SvPOKp(sv))
612 (void)SvPV_force(sv, len);
613 (void)SvPOK_only_UTF8(sv);
614 }
615
616 DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
617
618 switch (PL_op->op_private & ~hasutf & (
619 OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|
620 OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) {
621 case 0:
622 if (hasutf)
623 return do_trans_simple_utf8(sv);
624 else
625 return do_trans_simple(sv);
626
627 case OPpTRANS_IDENTICAL:
628 case OPpTRANS_IDENTICAL|OPpTRANS_COMPLEMENT:
629 if (hasutf)
630 return do_trans_count_utf8(sv);
631 else
632 return do_trans_count(sv);
633
634 default:
635 if (hasutf)
636 return do_trans_complex_utf8(sv);
637 else
638 return do_trans_complex(sv);
639 }
640 }
641
642 void
Perl_do_join(pTHX_ register SV * sv,SV * del,register SV ** mark,register SV ** sp)643 Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp)
644 {
645 SV **oldmark = mark;
646 register I32 items = sp - mark;
647 register STRLEN len;
648 STRLEN delimlen;
649 STRLEN tmplen;
650
651 (void) SvPV(del, delimlen); /* stringify and get the delimlen */
652 /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */
653
654 mark++;
655 len = (items > 0 ? (delimlen * (items - 1) ) : 0);
656 (void)SvUPGRADE(sv, SVt_PV);
657 if (SvLEN(sv) < len + items) { /* current length is way too short */
658 while (items-- > 0) {
659 if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) {
660 SvPV(*mark, tmplen);
661 len += tmplen;
662 }
663 mark++;
664 }
665 SvGROW(sv, len + 1); /* so try to pre-extend */
666
667 mark = oldmark;
668 items = sp - mark;
669 ++mark;
670 }
671
672 sv_setpvn(sv, "", 0);
673 /* sv_setpv retains old UTF8ness [perl #24846] */
674 if (SvUTF8(sv))
675 SvUTF8_off(sv);
676
677 if (PL_tainting && SvMAGICAL(sv))
678 SvTAINTED_off(sv);
679
680 if (items-- > 0) {
681 if (*mark)
682 sv_catsv(sv, *mark);
683 mark++;
684 }
685
686 if (delimlen) {
687 for (; items > 0; items--,mark++) {
688 sv_catsv(sv,del);
689 sv_catsv(sv,*mark);
690 }
691 }
692 else {
693 for (; items > 0; items--,mark++)
694 sv_catsv(sv,*mark);
695 }
696 SvSETMAGIC(sv);
697 }
698
699 void
Perl_do_sprintf(pTHX_ SV * sv,I32 len,SV ** sarg)700 Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
701 {
702 STRLEN patlen;
703 char *pat = SvPV(*sarg, patlen);
704 bool do_taint = FALSE;
705
706 SvUTF8_off(sv);
707 if (DO_UTF8(*sarg))
708 SvUTF8_on(sv);
709 sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
710 SvSETMAGIC(sv);
711 if (do_taint)
712 SvTAINTED_on(sv);
713 }
714
715 /* currently converts input to bytes if possible, but doesn't sweat failure */
716 UV
Perl_do_vecget(pTHX_ SV * sv,I32 offset,I32 size)717 Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
718 {
719 STRLEN srclen, len;
720 unsigned char *s = (unsigned char *) SvPV(sv, srclen);
721 UV retnum = 0;
722
723 if (offset < 0)
724 return retnum;
725 if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
726 Perl_croak(aTHX_ "Illegal number of bits in vec");
727
728 if (SvUTF8(sv))
729 (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE);
730
731 offset *= size; /* turn into bit offset */
732 len = (offset + size + 7) / 8; /* required number of bytes */
733 if (len > srclen) {
734 if (size <= 8)
735 retnum = 0;
736 else {
737 offset >>= 3; /* turn into byte offset */
738 if (size == 16) {
739 if ((STRLEN)offset >= srclen)
740 retnum = 0;
741 else
742 retnum = (UV) s[offset] << 8;
743 }
744 else if (size == 32) {
745 if ((STRLEN)offset >= srclen)
746 retnum = 0;
747 else if ((STRLEN)(offset + 1) >= srclen)
748 retnum =
749 ((UV) s[offset ] << 24);
750 else if ((STRLEN)(offset + 2) >= srclen)
751 retnum =
752 ((UV) s[offset ] << 24) +
753 ((UV) s[offset + 1] << 16);
754 else
755 retnum =
756 ((UV) s[offset ] << 24) +
757 ((UV) s[offset + 1] << 16) +
758 ( s[offset + 2] << 8);
759 }
760 #ifdef UV_IS_QUAD
761 else if (size == 64) {
762 if (ckWARN(WARN_PORTABLE))
763 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
764 "Bit vector size > 32 non-portable");
765 if (offset >= srclen)
766 retnum = 0;
767 else if (offset + 1 >= srclen)
768 retnum =
769 (UV) s[offset ] << 56;
770 else if (offset + 2 >= srclen)
771 retnum =
772 ((UV) s[offset ] << 56) +
773 ((UV) s[offset + 1] << 48);
774 else if (offset + 3 >= srclen)
775 retnum =
776 ((UV) s[offset ] << 56) +
777 ((UV) s[offset + 1] << 48) +
778 ((UV) s[offset + 2] << 40);
779 else if (offset + 4 >= srclen)
780 retnum =
781 ((UV) s[offset ] << 56) +
782 ((UV) s[offset + 1] << 48) +
783 ((UV) s[offset + 2] << 40) +
784 ((UV) s[offset + 3] << 32);
785 else if (offset + 5 >= srclen)
786 retnum =
787 ((UV) s[offset ] << 56) +
788 ((UV) s[offset + 1] << 48) +
789 ((UV) s[offset + 2] << 40) +
790 ((UV) s[offset + 3] << 32) +
791 ( s[offset + 4] << 24);
792 else if (offset + 6 >= srclen)
793 retnum =
794 ((UV) s[offset ] << 56) +
795 ((UV) s[offset + 1] << 48) +
796 ((UV) s[offset + 2] << 40) +
797 ((UV) s[offset + 3] << 32) +
798 ((UV) s[offset + 4] << 24) +
799 ((UV) s[offset + 5] << 16);
800 else
801 retnum =
802 ((UV) s[offset ] << 56) +
803 ((UV) s[offset + 1] << 48) +
804 ((UV) s[offset + 2] << 40) +
805 ((UV) s[offset + 3] << 32) +
806 ((UV) s[offset + 4] << 24) +
807 ((UV) s[offset + 5] << 16) +
808 ( s[offset + 6] << 8);
809 }
810 #endif
811 }
812 }
813 else if (size < 8)
814 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
815 else {
816 offset >>= 3; /* turn into byte offset */
817 if (size == 8)
818 retnum = s[offset];
819 else if (size == 16)
820 retnum =
821 ((UV) s[offset] << 8) +
822 s[offset + 1];
823 else if (size == 32)
824 retnum =
825 ((UV) s[offset ] << 24) +
826 ((UV) s[offset + 1] << 16) +
827 ( s[offset + 2] << 8) +
828 s[offset + 3];
829 #ifdef UV_IS_QUAD
830 else if (size == 64) {
831 if (ckWARN(WARN_PORTABLE))
832 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
833 "Bit vector size > 32 non-portable");
834 retnum =
835 ((UV) s[offset ] << 56) +
836 ((UV) s[offset + 1] << 48) +
837 ((UV) s[offset + 2] << 40) +
838 ((UV) s[offset + 3] << 32) +
839 ((UV) s[offset + 4] << 24) +
840 ((UV) s[offset + 5] << 16) +
841 ( s[offset + 6] << 8) +
842 s[offset + 7];
843 }
844 #endif
845 }
846
847 return retnum;
848 }
849
850 /* currently converts input to bytes if possible but doesn't sweat failures,
851 * although it does ensure that the string it clobbers is not marked as
852 * utf8-valid any more
853 */
854 void
Perl_do_vecset(pTHX_ SV * sv)855 Perl_do_vecset(pTHX_ SV *sv)
856 {
857 SV *targ = LvTARG(sv);
858 register I32 offset;
859 register I32 size;
860 register unsigned char *s;
861 register UV lval;
862 I32 mask;
863 STRLEN targlen;
864 STRLEN len;
865
866 if (!targ)
867 return;
868 s = (unsigned char*)SvPV_force(targ, targlen);
869 if (SvUTF8(targ)) {
870 /* This is handled by the SvPOK_only below...
871 if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
872 SvUTF8_off(targ);
873 */
874 (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
875 }
876
877 (void)SvPOK_only(targ);
878 lval = SvUV(sv);
879 offset = LvTARGOFF(sv);
880 if (offset < 0)
881 Perl_croak(aTHX_ "Negative offset to vec in lvalue context");
882 size = LvTARGLEN(sv);
883 if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
884 Perl_croak(aTHX_ "Illegal number of bits in vec");
885
886 offset *= size; /* turn into bit offset */
887 len = (offset + size + 7) / 8; /* required number of bytes */
888 if (len > targlen) {
889 s = (unsigned char*)SvGROW(targ, len + 1);
890 (void)memzero((char *)(s + targlen), len - targlen + 1);
891 SvCUR_set(targ, len);
892 }
893
894 if (size < 8) {
895 mask = (1 << size) - 1;
896 size = offset & 7;
897 lval &= mask;
898 offset >>= 3; /* turn into byte offset */
899 s[offset] &= ~(mask << size);
900 s[offset] |= lval << size;
901 }
902 else {
903 offset >>= 3; /* turn into byte offset */
904 if (size == 8)
905 s[offset ] = (U8)( lval & 0xff);
906 else if (size == 16) {
907 s[offset ] = (U8)((lval >> 8) & 0xff);
908 s[offset+1] = (U8)( lval & 0xff);
909 }
910 else if (size == 32) {
911 s[offset ] = (U8)((lval >> 24) & 0xff);
912 s[offset+1] = (U8)((lval >> 16) & 0xff);
913 s[offset+2] = (U8)((lval >> 8) & 0xff);
914 s[offset+3] = (U8)( lval & 0xff);
915 }
916 #ifdef UV_IS_QUAD
917 else if (size == 64) {
918 if (ckWARN(WARN_PORTABLE))
919 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
920 "Bit vector size > 32 non-portable");
921 s[offset ] = (U8)((lval >> 56) & 0xff);
922 s[offset+1] = (U8)((lval >> 48) & 0xff);
923 s[offset+2] = (U8)((lval >> 40) & 0xff);
924 s[offset+3] = (U8)((lval >> 32) & 0xff);
925 s[offset+4] = (U8)((lval >> 24) & 0xff);
926 s[offset+5] = (U8)((lval >> 16) & 0xff);
927 s[offset+6] = (U8)((lval >> 8) & 0xff);
928 s[offset+7] = (U8)( lval & 0xff);
929 }
930 #endif
931 }
932 SvSETMAGIC(targ);
933 }
934
935 void
Perl_do_chop(pTHX_ register SV * astr,register SV * sv)936 Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
937 {
938 STRLEN len;
939 char *s;
940
941 if (SvTYPE(sv) == SVt_PVAV) {
942 register I32 i;
943 I32 max;
944 AV* av = (AV*)sv;
945 max = AvFILL(av);
946 for (i = 0; i <= max; i++) {
947 sv = (SV*)av_fetch(av, i, FALSE);
948 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
949 do_chop(astr, sv);
950 }
951 return;
952 }
953 else if (SvTYPE(sv) == SVt_PVHV) {
954 HV* hv = (HV*)sv;
955 HE* entry;
956 (void)hv_iterinit(hv);
957 /*SUPPRESS 560*/
958 while ((entry = hv_iternext(hv)))
959 do_chop(astr,hv_iterval(hv,entry));
960 return;
961 }
962 else if (SvREADONLY(sv)) {
963 if (SvFAKE(sv)) {
964 /* SV is copy-on-write */
965 sv_force_normal_flags(sv, 0);
966 }
967 if (SvREADONLY(sv))
968 Perl_croak(aTHX_ PL_no_modify);
969 }
970 s = SvPV(sv, len);
971 if (len && !SvPOK(sv))
972 s = SvPV_force(sv, len);
973 if (DO_UTF8(sv)) {
974 if (s && len) {
975 char *send = s + len;
976 char *start = s;
977 s = send - 1;
978 while (s > start && UTF8_IS_CONTINUATION(*s))
979 s--;
980 if (utf8_to_uvchr((U8*)s, 0)) {
981 sv_setpvn(astr, s, send - s);
982 *s = '\0';
983 SvCUR_set(sv, s - start);
984 SvNIOK_off(sv);
985 SvUTF8_on(astr);
986 }
987 }
988 else
989 sv_setpvn(astr, "", 0);
990 }
991 else if (s && len) {
992 s += --len;
993 sv_setpvn(astr, s, 1);
994 *s = '\0';
995 SvCUR_set(sv, len);
996 SvUTF8_off(sv);
997 SvNIOK_off(sv);
998 }
999 else
1000 sv_setpvn(astr, "", 0);
1001 SvSETMAGIC(sv);
1002 }
1003
1004 I32
Perl_do_chomp(pTHX_ register SV * sv)1005 Perl_do_chomp(pTHX_ register SV *sv)
1006 {
1007 register I32 count;
1008 STRLEN len;
1009 STRLEN n_a;
1010 char *s;
1011 char *temp_buffer = NULL;
1012 SV* svrecode = Nullsv;
1013
1014 if (RsSNARF(PL_rs))
1015 return 0;
1016 if (RsRECORD(PL_rs))
1017 return 0;
1018 count = 0;
1019 if (SvTYPE(sv) == SVt_PVAV) {
1020 register I32 i;
1021 I32 max;
1022 AV* av = (AV*)sv;
1023 max = AvFILL(av);
1024 for (i = 0; i <= max; i++) {
1025 sv = (SV*)av_fetch(av, i, FALSE);
1026 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
1027 count += do_chomp(sv);
1028 }
1029 return count;
1030 }
1031 else if (SvTYPE(sv) == SVt_PVHV) {
1032 HV* hv = (HV*)sv;
1033 HE* entry;
1034 (void)hv_iterinit(hv);
1035 /*SUPPRESS 560*/
1036 while ((entry = hv_iternext(hv)))
1037 count += do_chomp(hv_iterval(hv,entry));
1038 return count;
1039 }
1040 else if (SvREADONLY(sv)) {
1041 if (SvFAKE(sv)) {
1042 /* SV is copy-on-write */
1043 sv_force_normal_flags(sv, 0);
1044 }
1045 if (SvREADONLY(sv))
1046 Perl_croak(aTHX_ PL_no_modify);
1047 }
1048
1049 if (PL_encoding) {
1050 if (!SvUTF8(sv)) {
1051 /* XXX, here sv is utf8-ized as a side-effect!
1052 If encoding.pm is used properly, almost string-generating
1053 operations, including literal strings, chr(), input data, etc.
1054 should have been utf8-ized already, right?
1055 */
1056 sv_recode_to_utf8(sv, PL_encoding);
1057 }
1058 }
1059
1060 s = SvPV(sv, len);
1061 if (s && len) {
1062 s += --len;
1063 if (RsPARA(PL_rs)) {
1064 if (*s != '\n')
1065 goto nope;
1066 ++count;
1067 while (len && s[-1] == '\n') {
1068 --len;
1069 --s;
1070 ++count;
1071 }
1072 }
1073 else {
1074 STRLEN rslen, rs_charlen;
1075 char *rsptr = SvPV(PL_rs, rslen);
1076
1077 rs_charlen = SvUTF8(PL_rs)
1078 ? sv_len_utf8(PL_rs)
1079 : rslen;
1080
1081 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
1082 /* Assumption is that rs is shorter than the scalar. */
1083 if (SvUTF8(PL_rs)) {
1084 /* RS is utf8, scalar is 8 bit. */
1085 bool is_utf8 = TRUE;
1086 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
1087 &rslen, &is_utf8);
1088 if (is_utf8) {
1089 /* Cannot downgrade, therefore cannot possibly match
1090 */
1091 assert (temp_buffer == rsptr);
1092 temp_buffer = NULL;
1093 goto nope;
1094 }
1095 rsptr = temp_buffer;
1096 }
1097 else if (PL_encoding) {
1098 /* RS is 8 bit, encoding.pm is used.
1099 * Do not recode PL_rs as a side-effect. */
1100 svrecode = newSVpvn(rsptr, rslen);
1101 sv_recode_to_utf8(svrecode, PL_encoding);
1102 rsptr = SvPV(svrecode, rslen);
1103 rs_charlen = sv_len_utf8(svrecode);
1104 }
1105 else {
1106 /* RS is 8 bit, scalar is utf8. */
1107 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
1108 rsptr = temp_buffer;
1109 }
1110 }
1111 if (rslen == 1) {
1112 if (*s != *rsptr)
1113 goto nope;
1114 ++count;
1115 }
1116 else {
1117 if (len < rslen - 1)
1118 goto nope;
1119 len -= rslen - 1;
1120 s -= rslen - 1;
1121 if (memNE(s, rsptr, rslen))
1122 goto nope;
1123 count += rs_charlen;
1124 }
1125 }
1126 s = SvPV_force(sv, n_a);
1127 SvCUR_set(sv, len);
1128 *SvEND(sv) = '\0';
1129 SvNIOK_off(sv);
1130 SvSETMAGIC(sv);
1131 }
1132 nope:
1133
1134 if (svrecode)
1135 SvREFCNT_dec(svrecode);
1136
1137 Safefree(temp_buffer);
1138 return count;
1139 }
1140
1141 void
Perl_do_vop(pTHX_ I32 optype,SV * sv,SV * left,SV * right)1142 Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
1143 {
1144 #ifdef LIBERAL
1145 register long *dl;
1146 register long *ll;
1147 register long *rl;
1148 #endif
1149 register char *dc;
1150 STRLEN leftlen;
1151 STRLEN rightlen;
1152 register char *lc;
1153 register char *rc;
1154 register I32 len;
1155 I32 lensave;
1156 char *lsave;
1157 char *rsave;
1158 bool left_utf = DO_UTF8(left);
1159 bool right_utf = DO_UTF8(right);
1160 I32 needlen = 0;
1161
1162 if (left_utf && !right_utf)
1163 sv_utf8_upgrade(right);
1164 else if (!left_utf && right_utf)
1165 sv_utf8_upgrade(left);
1166
1167 if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
1168 sv_setpvn(sv, "", 0); /* avoid undef warning on |= and ^= */
1169 lsave = lc = SvPV(left, leftlen);
1170 rsave = rc = SvPV(right, rightlen);
1171 len = leftlen < rightlen ? leftlen : rightlen;
1172 lensave = len;
1173 if ((left_utf || right_utf) && (sv == left || sv == right)) {
1174 needlen = optype == OP_BIT_AND ? len : leftlen + rightlen;
1175 Newz(801, dc, needlen + 1, char);
1176 }
1177 else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
1178 STRLEN n_a;
1179 dc = SvPV_force(sv, n_a);
1180 if (SvCUR(sv) < (STRLEN)len) {
1181 dc = SvGROW(sv, (STRLEN)(len + 1));
1182 (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
1183 }
1184 if (optype != OP_BIT_AND && (left_utf || right_utf))
1185 dc = SvGROW(sv, leftlen + rightlen + 1);
1186 }
1187 else {
1188 needlen = ((optype == OP_BIT_AND)
1189 ? len : (leftlen > rightlen ? leftlen : rightlen));
1190 Newz(801, dc, needlen + 1, char);
1191 (void)sv_usepvn(sv, dc, needlen);
1192 dc = SvPVX(sv); /* sv_usepvn() calls Renew() */
1193 }
1194 SvCUR_set(sv, len);
1195 (void)SvPOK_only(sv);
1196 if (left_utf || right_utf) {
1197 UV duc, luc, ruc;
1198 char *dcsave = dc;
1199 STRLEN lulen = leftlen;
1200 STRLEN rulen = rightlen;
1201 STRLEN ulen;
1202
1203 switch (optype) {
1204 case OP_BIT_AND:
1205 while (lulen && rulen) {
1206 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1207 lc += ulen;
1208 lulen -= ulen;
1209 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1210 rc += ulen;
1211 rulen -= ulen;
1212 duc = luc & ruc;
1213 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1214 }
1215 if (sv == left || sv == right)
1216 (void)sv_usepvn(sv, dcsave, needlen);
1217 SvCUR_set(sv, dc - dcsave);
1218 break;
1219 case OP_BIT_XOR:
1220 while (lulen && rulen) {
1221 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1222 lc += ulen;
1223 lulen -= ulen;
1224 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1225 rc += ulen;
1226 rulen -= ulen;
1227 duc = luc ^ ruc;
1228 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1229 }
1230 goto mop_up_utf;
1231 case OP_BIT_OR:
1232 while (lulen && rulen) {
1233 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1234 lc += ulen;
1235 lulen -= ulen;
1236 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1237 rc += ulen;
1238 rulen -= ulen;
1239 duc = luc | ruc;
1240 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1241 }
1242 mop_up_utf:
1243 if (sv == left || sv == right)
1244 (void)sv_usepvn(sv, dcsave, needlen);
1245 SvCUR_set(sv, dc - dcsave);
1246 if (rulen)
1247 sv_catpvn(sv, rc, rulen);
1248 else if (lulen)
1249 sv_catpvn(sv, lc, lulen);
1250 else
1251 *SvEND(sv) = '\0';
1252 break;
1253 }
1254 SvUTF8_on(sv);
1255 goto finish;
1256 }
1257 else
1258 #ifdef LIBERAL
1259 if (len >= sizeof(long)*4 &&
1260 !((long)dc % sizeof(long)) &&
1261 !((long)lc % sizeof(long)) &&
1262 !((long)rc % sizeof(long))) /* It's almost always aligned... */
1263 {
1264 I32 remainder = len % (sizeof(long)*4);
1265 len /= (sizeof(long)*4);
1266
1267 dl = (long*)dc;
1268 ll = (long*)lc;
1269 rl = (long*)rc;
1270
1271 switch (optype) {
1272 case OP_BIT_AND:
1273 while (len--) {
1274 *dl++ = *ll++ & *rl++;
1275 *dl++ = *ll++ & *rl++;
1276 *dl++ = *ll++ & *rl++;
1277 *dl++ = *ll++ & *rl++;
1278 }
1279 break;
1280 case OP_BIT_XOR:
1281 while (len--) {
1282 *dl++ = *ll++ ^ *rl++;
1283 *dl++ = *ll++ ^ *rl++;
1284 *dl++ = *ll++ ^ *rl++;
1285 *dl++ = *ll++ ^ *rl++;
1286 }
1287 break;
1288 case OP_BIT_OR:
1289 while (len--) {
1290 *dl++ = *ll++ | *rl++;
1291 *dl++ = *ll++ | *rl++;
1292 *dl++ = *ll++ | *rl++;
1293 *dl++ = *ll++ | *rl++;
1294 }
1295 }
1296
1297 dc = (char*)dl;
1298 lc = (char*)ll;
1299 rc = (char*)rl;
1300
1301 len = remainder;
1302 }
1303 #endif
1304 {
1305 switch (optype) {
1306 case OP_BIT_AND:
1307 while (len--)
1308 *dc++ = *lc++ & *rc++;
1309 break;
1310 case OP_BIT_XOR:
1311 while (len--)
1312 *dc++ = *lc++ ^ *rc++;
1313 goto mop_up;
1314 case OP_BIT_OR:
1315 while (len--)
1316 *dc++ = *lc++ | *rc++;
1317 mop_up:
1318 len = lensave;
1319 if (rightlen > (STRLEN)len)
1320 sv_catpvn(sv, rsave + len, rightlen - len);
1321 else if (leftlen > (STRLEN)len)
1322 sv_catpvn(sv, lsave + len, leftlen - len);
1323 else
1324 *SvEND(sv) = '\0';
1325 break;
1326 }
1327 }
1328 finish:
1329 SvTAINT(sv);
1330 }
1331
1332 OP *
Perl_do_kv(pTHX)1333 Perl_do_kv(pTHX)
1334 {
1335 dSP;
1336 HV *hv = (HV*)POPs;
1337 HV *keys;
1338 register HE *entry;
1339 SV *tmpstr;
1340 I32 gimme = GIMME_V;
1341 I32 dokeys = (PL_op->op_type == OP_KEYS);
1342 I32 dovalues = (PL_op->op_type == OP_VALUES);
1343 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
1344
1345 if (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV)
1346 dokeys = dovalues = TRUE;
1347
1348 if (!hv) {
1349 if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
1350 dTARGET; /* make sure to clear its target here */
1351 if (SvTYPE(TARG) == SVt_PVLV)
1352 LvTARG(TARG) = Nullsv;
1353 PUSHs(TARG);
1354 }
1355 RETURN;
1356 }
1357
1358 keys = realhv ? hv : avhv_keys((AV*)hv);
1359 (void)hv_iterinit(keys); /* always reset iterator regardless */
1360
1361 if (gimme == G_VOID)
1362 RETURN;
1363
1364 if (gimme == G_SCALAR) {
1365 IV i;
1366 dTARGET;
1367
1368 if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
1369 if (SvTYPE(TARG) < SVt_PVLV) {
1370 sv_upgrade(TARG, SVt_PVLV);
1371 sv_magic(TARG, Nullsv, PERL_MAGIC_nkeys, Nullch, 0);
1372 }
1373 LvTYPE(TARG) = 'k';
1374 if (LvTARG(TARG) != (SV*)keys) {
1375 if (LvTARG(TARG))
1376 SvREFCNT_dec(LvTARG(TARG));
1377 LvTARG(TARG) = SvREFCNT_inc(keys);
1378 }
1379 PUSHs(TARG);
1380 RETURN;
1381 }
1382
1383 if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied))
1384 i = HvKEYS(keys);
1385 else {
1386 i = 0;
1387 /*SUPPRESS 560*/
1388 while (hv_iternext(keys)) i++;
1389 }
1390 PUSHi( i );
1391 RETURN;
1392 }
1393
1394 EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
1395
1396 PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
1397 while ((entry = hv_iternext(keys))) {
1398 SPAGAIN;
1399 if (dokeys) {
1400 SV* sv = hv_iterkeysv(entry);
1401 XPUSHs(sv); /* won't clobber stack_sp */
1402 }
1403 if (dovalues) {
1404 PUTBACK;
1405 tmpstr = realhv ?
1406 hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry);
1407 DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
1408 (unsigned long)HeHASH(entry),
1409 HvMAX(keys)+1,
1410 (unsigned long)(HeHASH(entry) & HvMAX(keys))));
1411 SPAGAIN;
1412 XPUSHs(tmpstr);
1413 }
1414 PUTBACK;
1415 }
1416 return NORMAL;
1417 }
1418
1419