tweaks to enable PERL_OBJECT to build & test on win32
[p5sagit/p5-mst-13.2.git] / doop.c
CommitLineData
a0d0e21e 1/* doop.c
79072805 2 *
9607fc9c 3 * Copyright (c) 1991-1997, Larry Wall
79072805 4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
a0d0e21e 8 */
9
10/*
11 * "'So that was the job I felt I had to do when I started,' thought Sam."
79072805 12 */
13
14#include "EXTERN.h"
15#include "perl.h"
16
17#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
18#include <signal.h>
19#endif
20
942e002e 21#ifndef PERL_OBJECT
22static I32 do_trans_CC_simple _((SV *sv));
23static I32 do_trans_CC_count _((SV *sv));
24static I32 do_trans_CC_complex _((SV *sv));
25static I32 do_trans_UU_simple _((SV *sv));
26static I32 do_trans_UU_count _((SV *sv));
27static I32 do_trans_UU_complex _((SV *sv));
28static I32 do_trans_UC_simple _((SV *sv));
29static I32 do_trans_CU_simple _((SV *sv));
30static I32 do_trans_UC_trivial _((SV *sv));
31static I32 do_trans_CU_trivial _((SV *sv));
32#endif
33
34STATIC I32
4757a243 35do_trans_CC_simple(SV *sv)
79072805 36{
11343788 37 dTHR;
4757a243 38 U8 *s;
39 U8 *send;
40 I32 matches = 0;
463ee0b2 41 STRLEN len;
4757a243 42 short *tbl;
43 I32 ch;
79072805 44
4757a243 45 tbl = (short*)cPVOP->op_pv;
46 if (!tbl)
47 croak("panic: do_trans");
a0ed51b3 48
4757a243 49 s = (U8*)SvPV(sv, len);
50 send = s + len;
51
52 while (s < send) {
53 if ((ch = tbl[*s]) >= 0) {
54 matches++;
55 *s = ch;
79072805 56 }
4757a243 57 s++;
58 }
59 SvSETMAGIC(sv);
60
61 return matches;
62}
63
942e002e 64STATIC I32
4757a243 65do_trans_CC_count(SV *sv)
66{
67 dTHR;
68 U8 *s;
69 U8 *send;
70 I32 matches = 0;
71 STRLEN len;
72 short *tbl;
73
74 tbl = (short*)cPVOP->op_pv;
75 if (!tbl)
76 croak("panic: do_trans");
77
78 s = (U8*)SvPV(sv, len);
79 send = s + len;
80
81 while (s < send) {
82 if (tbl[*s] >= 0)
83 matches++;
84 s++;
85 }
86
87 return matches;
88}
89
942e002e 90STATIC I32
4757a243 91do_trans_CC_complex(SV *sv)
92{
93 dTHR;
94 U8 *s;
95 U8 *send;
96 U8 *d;
97 I32 matches = 0;
98 STRLEN len;
99 short *tbl;
100 I32 ch;
101
102 tbl = (short*)cPVOP->op_pv;
103 if (!tbl)
104 croak("panic: do_trans");
105
106 s = (U8*)SvPV(sv, len);
107 send = s + len;
108
109 d = s;
110 if (PL_op->op_private & OPpTRANS_SQUASH) {
111 U8* p = send;
112
113 while (s < send) {
114 if ((ch = tbl[*s]) >= 0) {
115 *d = ch;
116 matches++;
117 if (p == d - 1 && *p == *d)
118 matches--;
a0ed51b3 119 else
4757a243 120 p = d++;
a0ed51b3 121 }
4757a243 122 else if (ch == -1) /* -1 is unmapped character */
123 *d++ = *s; /* -2 is delete character */
124 s++;
a0ed51b3 125 }
4757a243 126 }
127 else {
128 while (s < send) {
129 if ((ch = tbl[*s]) >= 0) {
130 *d = ch;
131 matches++;
132 d++;
a0ed51b3 133 }
4757a243 134 else if (ch == -1) /* -1 is unmapped character */
135 *d++ = *s; /* -2 is delete character */
136 s++;
5d06d08e 137 }
4757a243 138 }
139 matches += send - d; /* account for disappeared chars */
140 *d = '\0';
141 SvCUR_set(sv, d - (U8*)SvPVX(sv));
142 SvSETMAGIC(sv);
143
144 return matches;
145}
146
942e002e 147STATIC I32
4757a243 148do_trans_UU_simple(SV *sv)
149{
150 dTHR;
151 U8 *s;
152 U8 *send;
153 U8 *d;
154 I32 matches = 0;
155 STRLEN len;
156
157 SV* rv = (SV*)cSVOP->op_sv;
158 HV* hv = (HV*)SvRV(rv);
159 SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
160 UV none = svp ? SvUV(*svp) : 0x7fffffff;
161 UV extra = none + 1;
162 UV final;
163 UV uv;
164
165 s = (U8*)SvPV(sv, len);
166 send = s + len;
167
168 svp = hv_fetch(hv, "FINAL", 5, FALSE);
169 if (svp)
170 final = SvUV(*svp);
171
172 d = s;
173 while (s < send) {
174 if ((uv = swash_fetch(rv, s)) < none) {
175 s += UTF8SKIP(s);
176 matches++;
177 d = uv_to_utf8(d, uv);
178 }
179 else if (uv == none) {
180 int i;
181 for (i = UTF8SKIP(s); i; i--)
182 *d++ = *s++;
183 }
184 else if (uv == extra) {
185 s += UTF8SKIP(s);
186 matches++;
187 d = uv_to_utf8(d, final);
188 }
189 else
190 s += UTF8SKIP(s);
191 }
192 *d = '\0';
193 SvCUR_set(sv, d - (U8*)SvPVX(sv));
194 SvSETMAGIC(sv);
195
196 return matches;
197}
198
942e002e 199STATIC I32
4757a243 200do_trans_UU_count(SV *sv)
201{
202 dTHR;
203 U8 *s;
204 U8 *send;
205 I32 matches = 0;
206 STRLEN len;
207
208 SV* rv = (SV*)cSVOP->op_sv;
209 HV* hv = (HV*)SvRV(rv);
210 SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
211 UV none = svp ? SvUV(*svp) : 0x7fffffff;
212 UV uv;
213
214 s = (U8*)SvPV(sv, len);
215 send = s + len;
216
217 while (s < send) {
218 if ((uv = swash_fetch(rv, s)) < none) {
219 s += UTF8SKIP(s);
220 matches++;
221 }
222 }
223
224 return matches;
225}
226
942e002e 227STATIC I32
4757a243 228do_trans_UC_simple(SV *sv)
229{
230 dTHR;
231 U8 *s;
232 U8 *send;
233 U8 *d;
234 I32 matches = 0;
235 STRLEN len;
236
237 SV* rv = (SV*)cSVOP->op_sv;
238 HV* hv = (HV*)SvRV(rv);
239 SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
240 UV none = svp ? SvUV(*svp) : 0x7fffffff;
241 UV extra = none + 1;
242 UV final;
243 UV uv;
244
245 s = (U8*)SvPV(sv, len);
246 send = s + len;
247
248 svp = hv_fetch(hv, "FINAL", 5, FALSE);
249 if (svp)
250 final = SvUV(*svp);
251
252 d = s;
253 while (s < send) {
254 if ((uv = swash_fetch(rv, s)) < none) {
255 s += UTF8SKIP(s);
256 matches++;
257 *d++ = (U8)uv;
258 }
259 else if (uv == none) {
260 I32 ulen;
261 uv = utf8_to_uv(s, &ulen);
262 s += ulen;
263 *d++ = (U8)uv;
264 }
265 else if (uv == extra) {
266 s += UTF8SKIP(s);
267 matches++;
268 *d++ = (U8)final;
269 }
270 else
271 s += UTF8SKIP(s);
272 }
273 *d = '\0';
274 SvCUR_set(sv, d - (U8*)SvPVX(sv));
275 SvSETMAGIC(sv);
276
277 return matches;
278}
279
942e002e 280STATIC I32
4757a243 281do_trans_CU_simple(SV *sv)
282{
283 dTHR;
284 U8 *s;
285 U8 *send;
286 U8 *d;
287 U8 *dst;
288 I32 matches = 0;
289 STRLEN len;
290
291 SV* rv = (SV*)cSVOP->op_sv;
292 HV* hv = (HV*)SvRV(rv);
293 SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
294 UV none = svp ? SvUV(*svp) : 0x7fffffff;
295 UV extra = none + 1;
296 UV final;
297 UV uv;
298 U8 tmpbuf[10];
299 I32 bits = 16;
300
301 s = (U8*)SvPV(sv, len);
302 send = s + len;
303
304 svp = hv_fetch(hv, "BITS", 4, FALSE);
305 if (svp)
306 bits = (I32)SvIV(*svp);
307
308 svp = hv_fetch(hv, "FINAL", 5, FALSE);
309 if (svp)
310 final = SvUV(*svp);
311
312 Newz(801, d, len * (bits >> 3) + 1, U8);
313 dst = d;
314
315 while (s < send) {
316 uv = *s++;
317 if (uv < 0x80)
318 tmpbuf[0] = uv;
319 else {
320 tmpbuf[0] = (( uv >> 6) | 0xc0);
321 tmpbuf[1] = (( uv & 0x3f) | 0x80);
a0ed51b3 322 }
4757a243 323
324 if ((uv = swash_fetch(rv, tmpbuf)) < none) {
325 matches++;
326 d = uv_to_utf8(d, uv);
327 }
328 else if (uv == none)
329 d = uv_to_utf8(d, s[-1]);
330 else if (uv == extra) {
331 matches++;
332 d = uv_to_utf8(d, final);
333 }
334 }
335 *d = '\0';
336 sv_usepvn_mg(sv, (char*)dst, d - dst);
337
338 return matches;
339}
340
341/* utf-8 to latin-1 */
342
942e002e 343STATIC I32
4757a243 344do_trans_UC_trivial(SV *sv)
345{
346 dTHR;
347 U8 *s;
348 U8 *send;
349 U8 *d;
350 STRLEN len;
351
352 s = (U8*)SvPV(sv, len);
353 send = s + len;
354
355 d = s;
356 while (s < send) {
357 if (*s < 0x80)
358 *d++ = *s++;
a0ed51b3 359 else {
4757a243 360 I32 ulen;
361 UV uv = utf8_to_uv(s, &ulen);
362 s += ulen;
363 *d++ = (U8)uv;
364 }
365 }
366 *d = '\0';
367 SvCUR_set(sv, d - (U8*)SvPVX(sv));
368 SvSETMAGIC(sv);
a0ed51b3 369
4757a243 370 return SvCUR(sv);
371}
a0ed51b3 372
4757a243 373/* latin-1 to utf-8 */
a0ed51b3 374
942e002e 375STATIC I32
4757a243 376do_trans_CU_trivial(SV *sv)
377{
378 dTHR;
379 U8 *s;
380 U8 *send;
381 U8 *d;
382 U8 *dst;
383 I32 matches;
384 STRLEN len;
a0ed51b3 385
4757a243 386 s = (U8*)SvPV(sv, len);
387 send = s + len;
388
389 Newz(801, d, len * 2 + 1, U8);
390 dst = d;
391
392 matches = send - s;
393
394 while (s < send) {
395 if (*s < 0x80)
396 *d++ = *s++;
397 else {
398 UV uv = *s++;
399 *d++ = (( uv >> 6) | 0xc0);
400 *d++ = (( uv & 0x3f) | 0x80);
401 }
402 }
403 *d = '\0';
404 sv_usepvn_mg(sv, (char*)dst, d - dst);
405
406 return matches;
407}
408
942e002e 409STATIC I32
4757a243 410do_trans_UU_complex(SV *sv)
411{
412 dTHR;
413 U8 *s;
414 U8 *send;
415 U8 *d;
416 I32 matches = 0;
417 I32 squash = PL_op->op_private & OPpTRANS_SQUASH;
418 I32 from_utf = PL_op->op_private & OPpTRANS_FROM_UTF;
419 I32 to_utf = PL_op->op_private & OPpTRANS_TO_UTF;
420 I32 del = PL_op->op_private & OPpTRANS_DELETE;
421 SV* rv = (SV*)cSVOP->op_sv;
422 HV* hv = (HV*)SvRV(rv);
423 SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
424 UV none = svp ? SvUV(*svp) : 0x7fffffff;
425 UV extra = none + 1;
426 UV final;
427 UV uv;
428 STRLEN len;
429 U8 *dst;
430
431 s = (U8*)SvPV(sv, len);
432 send = s + len;
433
434 svp = hv_fetch(hv, "FINAL", 5, FALSE);
435 if (svp)
436 final = SvUV(*svp);
437
438 if (PL_op->op_private & OPpTRANS_GROWS) {
439 I32 bits = 16;
440
441 svp = hv_fetch(hv, "BITS", 4, FALSE);
442 if (svp)
443 bits = (I32)SvIV(*svp);
444
445 Newz(801, d, len * (bits >> 3) + 1, U8);
446 dst = d;
447 }
448 else {
449 d = s;
450 dst = 0;
451 }
452
453 if (squash) {
454 UV puv = 0xfeedface;
455 while (s < send) {
456 if (from_utf) {
457 uv = swash_fetch(rv, s);
a0ed51b3 458 }
459 else {
4757a243 460 U8 tmpbuf[2];
461 uv = *s++;
462 if (uv < 0x80)
463 tmpbuf[0] = uv;
464 else {
465 tmpbuf[0] = (( uv >> 6) | 0xc0);
466 tmpbuf[1] = (( uv & 0x3f) | 0x80);
467 }
468 uv = swash_fetch(rv, tmpbuf);
469 }
470 if (uv < none) {
471 matches++;
472 if (uv != puv) {
473 if (uv >= 0x80 && to_utf)
474 d = uv_to_utf8(d, uv);
475 else
476 *d++ = (U8)uv;
477 puv = uv;
478 }
479 if (from_utf)
480 s += UTF8SKIP(s);
481 continue;
482 }
483 else if (uv == none) { /* "none" is unmapped character */
484 if (from_utf) {
485 if (*s < 0x80)
486 *d++ = *s++;
487 else if (to_utf) {
a0ed51b3 488 int i;
4757a243 489 for (i = UTF8SKIP(s); i; --i)
490 *d++ = *s++;
a0ed51b3 491 }
4757a243 492 else {
493 I32 ulen;
494 *d++ = (U8)utf8_to_uv(s, &ulen);
495 s += ulen;
a0ed51b3 496 }
a0ed51b3 497 }
4757a243 498 else { /* must be to_utf only */
499 d = uv_to_utf8(d, s[-1]);
500 }
501 puv = 0xfeedface;
502 continue;
a0ed51b3 503 }
4757a243 504 else if (uv == extra && !del) {
505 matches++;
506 if (uv != puv) {
507 if (final >= 0x80 && to_utf)
508 d = uv_to_utf8(d, final);
509 else
510 *d++ = (U8)final;
511 puv = final;
512 }
513 if (from_utf)
514 s += UTF8SKIP(s);
515 continue;
516 }
517 matches++; /* "none+1" is delete character */
518 if (from_utf)
519 s += UTF8SKIP(s);
a0ed51b3 520 }
79072805 521 }
522 else {
4757a243 523 while (s < send) {
524 if (from_utf) {
525 uv = swash_fetch(rv, s);
526 }
527 else {
528 U8 tmpbuf[2];
529 uv = *s++;
530 if (uv < 0x80)
531 tmpbuf[0] = uv;
532 else {
533 tmpbuf[0] = (( uv >> 6) | 0xc0);
534 tmpbuf[1] = (( uv & 0x3f) | 0x80);
a0ed51b3 535 }
4757a243 536 uv = swash_fetch(rv, tmpbuf);
a0ed51b3 537 }
4757a243 538 if (uv < none) {
539 matches++;
540 if (uv >= 0x80 && to_utf)
541 d = uv_to_utf8(d, uv);
542 else
543 *d++ = (U8)uv;
544 if (from_utf)
545 s += UTF8SKIP(s);
546 continue;
a0ed51b3 547 }
4757a243 548 else if (uv == none) { /* "none" is unmapped character */
549 if (from_utf) {
550 if (*s < 0x80)
551 *d++ = *s++;
552 else if (to_utf) {
553 int i;
554 for (i = UTF8SKIP(s); i; --i)
555 *d++ = *s++;
556 }
557 else {
558 I32 ulen;
559 *d++ = (U8)utf8_to_uv(s, &ulen);
560 s += ulen;
a0ed51b3 561 }
79072805 562 }
4757a243 563 else { /* must be to_utf only */
564 d = uv_to_utf8(d, s[-1]);
565 }
566 continue;
79072805 567 }
4757a243 568 else if (uv == extra && !del) {
569 matches++;
570 if (final >= 0x80 && to_utf)
571 d = uv_to_utf8(d, final);
572 else
573 *d++ = (U8)final;
574 if (from_utf)
575 s += UTF8SKIP(s);
576 continue;
577 }
578 matches++; /* "none+1" is delete character */
579 if (from_utf)
580 s += UTF8SKIP(s);
79072805 581 }
4757a243 582 }
583 if (dst)
584 sv_usepvn(sv, (char*)dst, d - dst);
585 else {
586 *d = '\0';
587 SvCUR_set(sv, d - (U8*)SvPVX(sv));
588 }
589 SvSETMAGIC(sv);
590
591 return matches;
592}
593
594I32
595do_trans(SV *sv)
596{
597 STRLEN len;
598
599 if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
600 croak(no_modify);
601
602 (void)SvPV(sv, len);
603 if (!len)
604 return 0;
605 if (!SvPOKp(sv))
606 (void)SvPV_force(sv, len);
607 (void)SvPOK_only(sv);
608
609 DEBUG_t( deb("2.TBL\n"));
610
611 switch (PL_op->op_private & 63) {
612 case 0:
613 return do_trans_CC_simple(sv);
614
615 case OPpTRANS_FROM_UTF:
616 return do_trans_UC_simple(sv);
617
618 case OPpTRANS_TO_UTF:
619 return do_trans_CU_simple(sv);
620
621 case OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF:
622 return do_trans_UU_simple(sv);
623
624 case OPpTRANS_IDENTICAL:
625 return do_trans_CC_count(sv);
626
627 case OPpTRANS_FROM_UTF|OPpTRANS_IDENTICAL:
628 return do_trans_UC_trivial(sv);
629
630 case OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL:
631 return do_trans_CU_trivial(sv);
632
633 case OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL:
634 return do_trans_UU_count(sv);
635
636 default:
637 if (PL_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
638 return do_trans_UU_complex(sv); /* could be UC or CU too */
639 else
640 return do_trans_CC_complex(sv);
79072805 641 }
79072805 642}
643
644void
8ac85365 645do_join(register SV *sv, SV *del, register SV **mark, register SV **sp)
79072805 646{
647 SV **oldmark = mark;
648 register I32 items = sp - mark;
79072805 649 register STRLEN len;
463ee0b2 650 STRLEN delimlen;
651 register char *delim = SvPV(del, delimlen);
652 STRLEN tmplen;
79072805 653
654 mark++;
655 len = (items > 0 ? (delimlen * (items - 1) ) : 0);
656 if (SvTYPE(sv) < SVt_PV)
657 sv_upgrade(sv, SVt_PV);
658 if (SvLEN(sv) < len + items) { /* current length is way too short */
659 while (items-- > 0) {
48c036b1 660 if (*mark && !SvGMAGICAL(*mark) && SvOK(*mark)) {
463ee0b2 661 SvPV(*mark, tmplen);
662 len += tmplen;
79072805 663 }
664 mark++;
665 }
666 SvGROW(sv, len + 1); /* so try to pre-extend */
667
668 mark = oldmark;
669 items = sp - mark;;
670 ++mark;
671 }
672
463ee0b2 673 if (items-- > 0) {
8990e307 674 char *s;
675
676 if (*mark) {
677 s = SvPV(*mark, tmplen);
678 sv_setpvn(sv, s, tmplen);
679 }
680 else
681 sv_setpv(sv, "");
463ee0b2 682 mark++;
683 }
79072805 684 else
685 sv_setpv(sv,"");
686 len = delimlen;
687 if (len) {
688 for (; items > 0; items--,mark++) {
689 sv_catpvn(sv,delim,len);
690 sv_catsv(sv,*mark);
691 }
692 }
693 else {
694 for (; items > 0; items--,mark++)
695 sv_catsv(sv,*mark);
696 }
697 SvSETMAGIC(sv);
698}
699
700void
8ac85365 701do_sprintf(SV *sv, I32 len, SV **sarg)
79072805 702{
46fc3d4c 703 STRLEN patlen;
704 char *pat = SvPV(*sarg, patlen);
705 bool do_taint = FALSE;
706
707 sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
79072805 708 SvSETMAGIC(sv);
46fc3d4c 709 if (do_taint)
710 SvTAINTED_on(sv);
79072805 711}
712
713void
8ac85365 714do_vecset(SV *sv)
79072805 715{
716 SV *targ = LvTARG(sv);
717 register I32 offset;
718 register I32 size;
8990e307 719 register unsigned char *s;
720 register unsigned long lval;
79072805 721 I32 mask;
a0d0e21e 722 STRLEN targlen;
723 STRLEN len;
79072805 724
8990e307 725 if (!targ)
726 return;
a0d0e21e 727 s = (unsigned char*)SvPV_force(targ, targlen);
8990e307 728 lval = U_L(SvNV(sv));
79072805 729 offset = LvTARGOFF(sv);
730 size = LvTARGLEN(sv);
a0d0e21e 731
732 len = (offset + size + 7) / 8;
733 if (len > targlen) {
734 s = (unsigned char*)SvGROW(targ, len + 1);
735 (void)memzero(s + targlen, len - targlen + 1);
736 SvCUR_set(targ, len);
737 }
738
79072805 739 if (size < 8) {
740 mask = (1 << size) - 1;
741 size = offset & 7;
742 lval &= mask;
743 offset >>= 3;
744 s[offset] &= ~(mask << size);
745 s[offset] |= lval << size;
746 }
747 else {
a0d0e21e 748 offset >>= 3;
79072805 749 if (size == 8)
750 s[offset] = lval & 255;
751 else if (size == 16) {
752 s[offset] = (lval >> 8) & 255;
753 s[offset+1] = lval & 255;
754 }
755 else if (size == 32) {
756 s[offset] = (lval >> 24) & 255;
757 s[offset+1] = (lval >> 16) & 255;
758 s[offset+2] = (lval >> 8) & 255;
759 s[offset+3] = lval & 255;
760 }
761 }
762}
763
764void
8ac85365 765do_chop(register SV *astr, register SV *sv)
79072805 766{
463ee0b2 767 STRLEN len;
a0d0e21e 768 char *s;
c485e607 769 dTHR;
a0d0e21e 770
79072805 771 if (SvTYPE(sv) == SVt_PVAV) {
a0d0e21e 772 register I32 i;
773 I32 max;
774 AV* av = (AV*)sv;
775 max = AvFILL(av);
776 for (i = 0; i <= max; i++) {
777 sv = (SV*)av_fetch(av, i, FALSE);
3280af22 778 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
a0d0e21e 779 do_chop(astr, sv);
780 }
781 return;
79072805 782 }
783 if (SvTYPE(sv) == SVt_PVHV) {
a0d0e21e 784 HV* hv = (HV*)sv;
785 HE* entry;
786 (void)hv_iterinit(hv);
787 /*SUPPRESS 560*/
788 while (entry = hv_iternext(hv))
789 do_chop(astr,hv_iterval(hv,entry));
790 return;
79072805 791 }
a0d0e21e 792 s = SvPV(sv, len);
748a9306 793 if (len && !SvPOK(sv))
a0d0e21e 794 s = SvPV_force(sv, len);
a0ed51b3 795 if (IN_UTF8) {
796 if (s && len) {
797 char *send = s + len;
798 char *start = s;
799 s = send - 1;
800 while ((*s & 0xc0) == 0x80)
801 --s;
802 if (UTF8SKIP(s) != send - s)
803 warn("Malformed UTF-8 character");
804 sv_setpvn(astr, s, send - s);
805 *s = '\0';
806 SvCUR_set(sv, s - start);
807 SvNIOK_off(sv);
808 }
809 else
810 sv_setpvn(astr, "", 0);
811 }
812 else
a0d0e21e 813 if (s && len) {
814 s += --len;
815 sv_setpvn(astr, s, 1);
816 *s = '\0';
817 SvCUR_set(sv, len);
818 SvNIOK_off(sv);
79072805 819 }
820 else
a0d0e21e 821 sv_setpvn(astr, "", 0);
822 SvSETMAGIC(sv);
823}
824
825I32
8ac85365 826do_chomp(register SV *sv)
a0d0e21e 827{
aeea060c 828 dTHR;
c07a80fd 829 register I32 count;
a0d0e21e 830 STRLEN len;
831 char *s;
c07a80fd 832
3280af22 833 if (RsSNARF(PL_rs))
c07a80fd 834 return 0;
835 count = 0;
a0d0e21e 836 if (SvTYPE(sv) == SVt_PVAV) {
837 register I32 i;
838 I32 max;
839 AV* av = (AV*)sv;
840 max = AvFILL(av);
841 for (i = 0; i <= max; i++) {
842 sv = (SV*)av_fetch(av, i, FALSE);
3280af22 843 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
a0d0e21e 844 count += do_chomp(sv);
845 }
846 return count;
847 }
848 if (SvTYPE(sv) == SVt_PVHV) {
849 HV* hv = (HV*)sv;
850 HE* entry;
851 (void)hv_iterinit(hv);
852 /*SUPPRESS 560*/
853 while (entry = hv_iternext(hv))
854 count += do_chomp(hv_iterval(hv,entry));
855 return count;
856 }
857 s = SvPV(sv, len);
858 if (len && !SvPOKp(sv))
859 s = SvPV_force(sv, len);
860 if (s && len) {
861 s += --len;
3280af22 862 if (RsPARA(PL_rs)) {
a0d0e21e 863 if (*s != '\n')
864 goto nope;
865 ++count;
866 while (len && s[-1] == '\n') {
867 --len;
868 --s;
869 ++count;
870 }
871 }
a0d0e21e 872 else {
c07a80fd 873 STRLEN rslen;
3280af22 874 char *rsptr = SvPV(PL_rs, rslen);
c07a80fd 875 if (rslen == 1) {
876 if (*s != *rsptr)
877 goto nope;
878 ++count;
879 }
880 else {
8c2cee6f 881 if (len < rslen - 1)
c07a80fd 882 goto nope;
883 len -= rslen - 1;
884 s -= rslen - 1;
36477c24 885 if (memNE(s, rsptr, rslen))
c07a80fd 886 goto nope;
887 count += rslen;
888 }
a0d0e21e 889 }
a0d0e21e 890 *s = '\0';
891 SvCUR_set(sv, len);
892 SvNIOK_off(sv);
893 }
894 nope:
895 SvSETMAGIC(sv);
896 return count;
897}
79072805 898
899void
8ac85365 900do_vop(I32 optype, SV *sv, SV *left, SV *right)
79072805 901{
aeea060c 902 dTHR; /* just for taint */
79072805 903#ifdef LIBERAL
904 register long *dl;
905 register long *ll;
906 register long *rl;
907#endif
908 register char *dc;
463ee0b2 909 STRLEN leftlen;
910 STRLEN rightlen;
7a4c00b4 911 register char *lc;
912 register char *rc;
79072805 913 register I32 len;
a0d0e21e 914 I32 lensave;
7a4c00b4 915 char *lsave;
916 char *rsave;
79072805 917
1fbd88dc 918 if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
919 sv_setpvn(sv, "", 0); /* avoid undef warning on |= and ^= */
7a4c00b4 920 lsave = lc = SvPV(left, leftlen);
921 rsave = rc = SvPV(right, rightlen);
93a17b20 922 len = leftlen < rightlen ? leftlen : rightlen;
a0d0e21e 923 lensave = len;
7a4c00b4 924 if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
3280af22 925 dc = SvPV_force(sv, PL_na);
ff68c719 926 if (SvCUR(sv) < len) {
927 dc = SvGROW(sv, len + 1);
928 (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
929 }
930 }
931 else {
932 I32 needlen = ((optype == OP_BIT_AND)
933 ? len : (leftlen > rightlen ? leftlen : rightlen));
934 Newz(801, dc, needlen + 1, char);
935 (void)sv_usepvn(sv, dc, needlen);
936 dc = SvPVX(sv); /* sv_usepvn() calls Renew() */
79072805 937 }
a0d0e21e 938 SvCUR_set(sv, len);
939 (void)SvPOK_only(sv);
79072805 940#ifdef LIBERAL
941 if (len >= sizeof(long)*4 &&
942 !((long)dc % sizeof(long)) &&
943 !((long)lc % sizeof(long)) &&
944 !((long)rc % sizeof(long))) /* It's almost always aligned... */
945 {
946 I32 remainder = len % (sizeof(long)*4);
947 len /= (sizeof(long)*4);
948
949 dl = (long*)dc;
950 ll = (long*)lc;
951 rl = (long*)rc;
952
953 switch (optype) {
954 case OP_BIT_AND:
955 while (len--) {
956 *dl++ = *ll++ & *rl++;
957 *dl++ = *ll++ & *rl++;
958 *dl++ = *ll++ & *rl++;
959 *dl++ = *ll++ & *rl++;
960 }
961 break;
a0d0e21e 962 case OP_BIT_XOR:
79072805 963 while (len--) {
964 *dl++ = *ll++ ^ *rl++;
965 *dl++ = *ll++ ^ *rl++;
966 *dl++ = *ll++ ^ *rl++;
967 *dl++ = *ll++ ^ *rl++;
968 }
969 break;
970 case OP_BIT_OR:
971 while (len--) {
972 *dl++ = *ll++ | *rl++;
973 *dl++ = *ll++ | *rl++;
974 *dl++ = *ll++ | *rl++;
975 *dl++ = *ll++ | *rl++;
976 }
977 }
978
979 dc = (char*)dl;
980 lc = (char*)ll;
981 rc = (char*)rl;
982
983 len = remainder;
984 }
985#endif
a0d0e21e 986 {
a0d0e21e 987 switch (optype) {
988 case OP_BIT_AND:
989 while (len--)
990 *dc++ = *lc++ & *rc++;
991 break;
992 case OP_BIT_XOR:
993 while (len--)
994 *dc++ = *lc++ ^ *rc++;
995 goto mop_up;
996 case OP_BIT_OR:
997 while (len--)
998 *dc++ = *lc++ | *rc++;
999 mop_up:
1000 len = lensave;
1001 if (rightlen > len)
1002 sv_catpvn(sv, rsave + len, rightlen - len);
1003 else if (leftlen > len)
1004 sv_catpvn(sv, lsave + len, leftlen - len);
4633a7c4 1005 else
1006 *SvEND(sv) = '\0';
a0d0e21e 1007 break;
1008 }
79072805 1009 }
fb73857a 1010 SvTAINT(sv);
79072805 1011}
463ee0b2 1012
1013OP *
8ac85365 1014do_kv(ARGSproto)
463ee0b2 1015{
4e35701f 1016 djSP;
463ee0b2 1017 HV *hv = (HV*)POPs;
800e9ae0 1018 HV *keys;
463ee0b2 1019 register HE *entry;
463ee0b2 1020 SV *tmpstr;
54310121 1021 I32 gimme = GIMME_V;
533c011a 1022 I32 dokeys = (PL_op->op_type == OP_KEYS);
1023 I32 dovalues = (PL_op->op_type == OP_VALUES);
c750a3ec 1024 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
1025
533c011a 1026 if (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV)
a0d0e21e 1027 dokeys = dovalues = TRUE;
463ee0b2 1028
85581909 1029 if (!hv) {
533c011a 1030 if (PL_op->op_flags & OPf_MOD) { /* lvalue */
85581909 1031 dTARGET; /* make sure to clear its target here */
1032 if (SvTYPE(TARG) == SVt_PVLV)
1033 LvTARG(TARG) = Nullsv;
1034 PUSHs(TARG);
1035 }
463ee0b2 1036 RETURN;
85581909 1037 }
748a9306 1038
800e9ae0 1039 keys = realhv ? hv : avhv_keys((AV*)hv);
1040 (void)hv_iterinit(keys); /* always reset iterator regardless */
748a9306 1041
54310121 1042 if (gimme == G_VOID)
aa689395 1043 RETURN;
1044
54310121 1045 if (gimme == G_SCALAR) {
6ee623d5 1046 IV i;
463ee0b2 1047 dTARGET;
1048
533c011a 1049 if (PL_op->op_flags & OPf_MOD) { /* lvalue */
85581909 1050 if (SvTYPE(TARG) < SVt_PVLV) {
1051 sv_upgrade(TARG, SVt_PVLV);
1052 sv_magic(TARG, Nullsv, 'k', Nullch, 0);
1053 }
1054 LvTYPE(TARG) = 'k';
800e9ae0 1055 if (LvTARG(TARG) != (SV*)keys) {
6ff81951 1056 if (LvTARG(TARG))
1057 SvREFCNT_dec(LvTARG(TARG));
800e9ae0 1058 LvTARG(TARG) = SvREFCNT_inc(keys);
6ff81951 1059 }
85581909 1060 PUSHs(TARG);
1061 RETURN;
1062 }
1063
800e9ae0 1064 if (!SvRMAGICAL(keys) || !mg_find((SV*)keys,'P'))
1065 i = HvKEYS(keys);
463ee0b2 1066 else {
1067 i = 0;
463ee0b2 1068 /*SUPPRESS 560*/
800e9ae0 1069 while (hv_iternext(keys)) i++;
463ee0b2 1070 }
1071 PUSHi( i );
1072 RETURN;
1073 }
1074
8ed4b672 1075 EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
463ee0b2 1076
463ee0b2 1077 PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
800e9ae0 1078 while (entry = hv_iternext(keys)) {
463ee0b2 1079 SPAGAIN;
8c2cee6f 1080 if (dokeys)
1081 XPUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
463ee0b2 1082 if (dovalues) {
463ee0b2 1083 PUTBACK;
b6429b1b 1084 tmpstr = realhv ?
1085 hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry);
46fc3d4c 1086 DEBUG_H(sv_setpvf(tmpstr, "%lu%%%d=%lu",
1087 (unsigned long)HeHASH(entry),
800e9ae0 1088 HvMAX(keys)+1,
1089 (unsigned long)(HeHASH(entry) & HvMAX(keys))));
463ee0b2 1090 SPAGAIN;
46fc3d4c 1091 XPUSHs(tmpstr);
463ee0b2 1092 }
1093 PUTBACK;
1094 }
1095 return NORMAL;
1096}
4e35701f 1097