3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2004, 2005, 2006, by Larry Wall and others
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.
12 * "'So that was the job I felt I had to do when I started,' thought Sam."
15 /* This file contains some common functions needed to carry out certain
16 * ops. For example both pp_schomp() and pp_chomp() - scalar and array
17 * chomp operations - call the function do_chomp() found in this file.
21 #define PERL_IN_DOOP_C
29 S_do_trans_simple(pTHX_ SV * const sv)
33 U8 *s = (U8*)SvPV(sv,len);
34 U8 * const send = s+len;
36 const short * const tbl = (short*)cPVOP->op_pv;
38 Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__);
40 /* First, take care of non-UTF-8 input strings, because they're easy */
43 const I32 ch = tbl[*s];
53 const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
57 /* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
67 /* Need to check this, otherwise 128..255 won't match */
68 const UV c = utf8n_to_uvchr(s, send - s, &ulen, 0);
69 if (c < 0x100 && (ch = tbl[c]) >= 0) {
71 d = uvchr_to_utf8(d, ch);
74 else { /* No match -> copy */
81 sv_setpvn(sv, (char*)dstart, d - dstart);
86 SvCUR_set(sv, d - dstart);
95 S_do_trans_count(pTHX_ SV * const sv)
98 const U8 *s = (const U8*)SvPV_const(sv, len);
99 const U8 * const send = s + len;
102 const short * const tbl = (short*)cPVOP->op_pv;
104 Perl_croak(aTHX_ "panic: do_trans_count line %d",__LINE__);
113 const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
116 const UV c = utf8n_to_uvchr((U8 *)s, send - s, &ulen, 0);
120 } else if (complement)
130 S_do_trans_complex(pTHX_ SV * const sv)
133 U8 *s = (U8*)SvPV(sv, len);
134 U8 * const send = s+len;
137 const short * const tbl = (short*)cPVOP->op_pv;
139 Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__);
143 U8 * const dstart = d;
145 if (PL_op->op_private & OPpTRANS_SQUASH) {
148 const I32 ch = tbl[*s];
152 if (p != d - 1 || *p != *d)
155 else if (ch == -1) /* -1 is unmapped character */
157 else if (ch == -2) /* -2 is delete character */
164 const I32 ch = tbl[*s];
169 else if (ch == -1) /* -1 is unmapped character */
171 else if (ch == -2) /* -2 is delete character */
177 SvCUR_set(sv, d - dstart);
180 const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
181 const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
182 const I32 del = PL_op->op_private & OPpTRANS_DELETE;
188 Newx(d, len*2+1, U8);
192 if (complement && !del)
195 #ifdef MACOS_TRADITIONAL
196 #define comp CoMP /* "comp" is a keyword in some compilers ... */
199 if (PL_op->op_private & OPpTRANS_SQUASH) {
203 const UV comp = utf8_to_uvchr(s, &len);
214 ch = (rlen == 0) ? (I32)comp :
215 (comp - 0x100 < rlen) ?
216 tbl[comp+1] : tbl[0x100+rlen];
218 d = uvchr_to_utf8(d, ch);
226 else if ((ch = tbl[comp]) >= 0) {
229 d = uvchr_to_utf8(d, ch);
235 else if (ch == -1) { /* -1 is unmapped character */
239 else if (ch == -2) /* -2 is delete character */
248 const UV comp = utf8_to_uvchr(s, &len);
258 if (comp - 0x100 < rlen)
259 d = uvchr_to_utf8(d, tbl[comp+1]);
261 d = uvchr_to_utf8(d, tbl[0x100+rlen]);
265 else if ((ch = tbl[comp]) >= 0) {
266 d = uvchr_to_utf8(d, ch);
269 else if (ch == -1) { /* -1 is unmapped character */
273 else if (ch == -2) /* -2 is delete character */
279 sv_setpvn(sv, (char*)dstart, d - dstart);
284 SvCUR_set(sv, d - dstart);
293 S_do_trans_simple_utf8(pTHX_ SV * const sv)
301 const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
304 SV* const rv = (SV*)cSVOP->op_sv;
305 HV* const hv = (HV*)SvRV(rv);
306 SV* const * svp = hv_fetchs(hv, "NONE", FALSE);
307 const UV none = svp ? SvUV(*svp) : 0x7fffffff;
308 const UV extra = none + 1;
312 s = (U8*)SvPV(sv, len);
315 const U8 * const e = s + len;
318 hibit = !NATIVE_IS_INVARIANT(ch);
320 s = bytes_to_utf8(s, &len);
328 svp = hv_fetchs(hv, "FINAL", FALSE);
333 /* d needs to be bigger than s, in case e.g. upgrading is required */
334 Newx(d, len * 3 + UTF8_MAXBYTES, U8);
344 const UV uv = swash_fetch(rv, s, TRUE);
348 d = uvuni_to_utf8(d, uv);
350 else if (uv == none) {
351 const int i = UTF8SKIP(s);
356 else if (uv == extra) {
359 d = uvuni_to_utf8(d, final);
365 const STRLEN clen = d - dstart;
366 const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
368 Perl_croak(aTHX_ "panic: do_trans_simple_utf8 line %d",__LINE__);
369 Renew(dstart, nlen + UTF8_MAXBYTES, U8);
371 dend = dstart + nlen;
374 if (grows || hibit) {
375 sv_setpvn(sv, (char*)dstart, d - dstart);
382 SvCUR_set(sv, d - dstart);
391 S_do_trans_count_utf8(pTHX_ SV * const sv)
394 const U8 *start = NULL;
399 SV* const rv = (SV*)cSVOP->op_sv;
400 HV* const hv = (HV*)SvRV(rv);
401 SV* const * const svp = hv_fetchs(hv, "NONE", FALSE);
402 const UV none = svp ? SvUV(*svp) : 0x7fffffff;
403 const UV extra = none + 1;
406 s = (const U8*)SvPV_const(sv, len);
409 const U8 * const e = s + len;
412 hibit = !NATIVE_IS_INVARIANT(ch);
414 start = s = bytes_to_utf8((U8 *)s, &len);
422 const UV uv = swash_fetch(rv, (U8 *)s, TRUE);
423 if (uv < none || uv == extra)
434 S_do_trans_complex_utf8(pTHX_ SV * const sv)
439 const I32 squash = PL_op->op_private & OPpTRANS_SQUASH;
440 const I32 del = PL_op->op_private & OPpTRANS_DELETE;
441 const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
442 SV * const rv = (SV*)cSVOP->op_sv;
443 HV * const hv = (HV*)SvRV(rv);
444 SV * const *svp = hv_fetchs(hv, "NONE", FALSE);
445 const UV none = svp ? SvUV(*svp) : 0x7fffffff;
446 const UV extra = none + 1;
448 bool havefinal = FALSE;
453 U8 *s = (U8*)SvPV(sv, len);
456 const U8 * const e = s + len;
459 hibit = !NATIVE_IS_INVARIANT(ch);
461 s = bytes_to_utf8(s, &len);
469 svp = hv_fetchs(hv, "FINAL", FALSE);
476 /* d needs to be bigger than s, in case e.g. upgrading is required */
477 Newx(d, len * 3 + UTF8_MAXBYTES, U8);
489 UV uv = swash_fetch(rv, s, TRUE);
492 const STRLEN clen = d - dstart;
493 const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
495 Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
496 Renew(dstart, nlen + UTF8_MAXBYTES, U8);
498 dend = dstart + nlen;
504 d = uvuni_to_utf8(d, uv);
509 else if (uv == none) { /* "none" is unmapped character */
510 const int i = UTF8SKIP(s);
517 else if (uv == extra && !del) {
522 d = uvuni_to_utf8(d, final);
528 uv = utf8_to_uvuni(s, &len);
538 matches++; /* "none+1" is delete character */
544 const UV uv = swash_fetch(rv, s, TRUE);
546 const STRLEN clen = d - dstart;
547 const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
549 Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
550 Renew(dstart, nlen + UTF8_MAXBYTES, U8);
552 dend = dstart + nlen;
557 d = uvuni_to_utf8(d, uv);
560 else if (uv == none) { /* "none" is unmapped character */
561 const int i = UTF8SKIP(s);
567 else if (uv == extra && !del) {
570 d = uvuni_to_utf8(d, final);
573 matches++; /* "none+1" is delete character */
577 if (grows || hibit) {
578 sv_setpvn(sv, (char*)dstart, d - dstart);
585 SvCUR_set(sv, d - dstart);
594 Perl_do_trans(pTHX_ SV *sv)
597 const I32 hasutf = (PL_op->op_private &
598 (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
600 if (SvREADONLY(sv)) {
603 if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
604 Perl_croak(aTHX_ PL_no_modify);
606 (void)SvPV_const(sv, len);
609 if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) {
611 (void)SvPV_force(sv, len);
612 (void)SvPOK_only_UTF8(sv);
615 DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
617 switch (PL_op->op_private & ~hasutf & (
618 OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|
619 OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) {
622 return do_trans_simple_utf8(sv);
624 return do_trans_simple(sv);
626 case OPpTRANS_IDENTICAL:
627 case OPpTRANS_IDENTICAL|OPpTRANS_COMPLEMENT:
629 return do_trans_count_utf8(sv);
631 return do_trans_count(sv);
635 return do_trans_complex_utf8(sv);
637 return do_trans_complex(sv);
642 Perl_do_join(pTHX_ register SV *sv, SV *delim, register SV **mark, register SV **sp)
644 SV ** const oldmark = mark;
645 register I32 items = sp - mark;
649 (void) SvPV_const(delim, delimlen); /* stringify and get the delimlen */
650 /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */
653 len = (items > 0 ? (delimlen * (items - 1) ) : 0);
654 (void)SvUPGRADE(sv, SVt_PV);
655 if (SvLEN(sv) < len + items) { /* current length is way too short */
656 while (items-- > 0) {
657 if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) {
659 SvPV_const(*mark, tmplen);
664 SvGROW(sv, len + 1); /* so try to pre-extend */
671 sv_setpvn(sv, "", 0);
672 /* sv_setpv retains old UTF8ness [perl #24846] */
675 if (PL_tainting && SvMAGICAL(sv))
685 for (; items > 0; items--,mark++) {
691 for (; items > 0; items--,mark++)
698 Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
701 const char * const pat = SvPV_const(*sarg, patlen);
702 bool do_taint = FALSE;
707 sv_vsetpvfn(sv, pat, patlen, NULL, sarg + 1, len - 1, &do_taint);
713 /* currently converts input to bytes if possible, but doesn't sweat failure */
715 Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
717 STRLEN srclen, len, uoffset, bitoffs = 0;
718 const unsigned char *s = (const unsigned char *) SvPV_const(sv, srclen);
723 if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
724 Perl_croak(aTHX_ "Illegal number of bits in vec");
727 (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE);
730 bitoffs = ((offset%8)*size)%8;
731 uoffset = offset/(8/size);
734 uoffset = offset*(size/8);
738 len = uoffset + (bitoffs + size + 7)/8; /* required number of bytes */
744 if (uoffset >= srclen)
747 retnum = (UV) s[uoffset] << 8;
749 else if (size == 32) {
750 if (uoffset >= srclen)
752 else if (uoffset + 1 >= srclen)
754 ((UV) s[uoffset ] << 24);
755 else if (uoffset + 2 >= srclen)
757 ((UV) s[uoffset ] << 24) +
758 ((UV) s[uoffset + 1] << 16);
761 ((UV) s[uoffset ] << 24) +
762 ((UV) s[uoffset + 1] << 16) +
763 ( s[uoffset + 2] << 8);
766 else if (size == 64) {
767 if (ckWARN(WARN_PORTABLE))
768 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
769 "Bit vector size > 32 non-portable");
770 if (uoffset >= srclen)
772 else if (uoffset + 1 >= srclen)
774 (UV) s[uoffset ] << 56;
775 else if (uoffset + 2 >= srclen)
777 ((UV) s[uoffset ] << 56) +
778 ((UV) s[uoffset + 1] << 48);
779 else if (uoffset + 3 >= srclen)
781 ((UV) s[uoffset ] << 56) +
782 ((UV) s[uoffset + 1] << 48) +
783 ((UV) s[uoffset + 2] << 40);
784 else if (uoffset + 4 >= srclen)
786 ((UV) s[uoffset ] << 56) +
787 ((UV) s[uoffset + 1] << 48) +
788 ((UV) s[uoffset + 2] << 40) +
789 ((UV) s[uoffset + 3] << 32);
790 else if (uoffset + 5 >= srclen)
792 ((UV) s[uoffset ] << 56) +
793 ((UV) s[uoffset + 1] << 48) +
794 ((UV) s[uoffset + 2] << 40) +
795 ((UV) s[uoffset + 3] << 32) +
796 ( s[uoffset + 4] << 24);
797 else if (uoffset + 6 >= srclen)
799 ((UV) s[uoffset ] << 56) +
800 ((UV) s[uoffset + 1] << 48) +
801 ((UV) s[uoffset + 2] << 40) +
802 ((UV) s[uoffset + 3] << 32) +
803 ((UV) s[uoffset + 4] << 24) +
804 ((UV) s[uoffset + 5] << 16);
807 ((UV) s[uoffset ] << 56) +
808 ((UV) s[uoffset + 1] << 48) +
809 ((UV) s[uoffset + 2] << 40) +
810 ((UV) s[uoffset + 3] << 32) +
811 ((UV) s[uoffset + 4] << 24) +
812 ((UV) s[uoffset + 5] << 16) +
813 ( s[uoffset + 6] << 8);
819 retnum = (s[uoffset] >> bitoffs) & ((1 << size) - 1);
825 ((UV) s[uoffset] << 8) +
829 ((UV) s[uoffset ] << 24) +
830 ((UV) s[uoffset + 1] << 16) +
831 ( s[uoffset + 2] << 8) +
834 else if (size == 64) {
835 if (ckWARN(WARN_PORTABLE))
836 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
837 "Bit vector size > 32 non-portable");
839 ((UV) s[uoffset ] << 56) +
840 ((UV) s[uoffset + 1] << 48) +
841 ((UV) s[uoffset + 2] << 40) +
842 ((UV) s[uoffset + 3] << 32) +
843 ((UV) s[uoffset + 4] << 24) +
844 ((UV) s[uoffset + 5] << 16) +
845 ( s[uoffset + 6] << 8) +
854 /* currently converts input to bytes if possible but doesn't sweat failures,
855 * although it does ensure that the string it clobbers is not marked as
856 * utf8-valid any more
859 Perl_do_vecset(pTHX_ SV *sv)
861 register I32 offset, bitoffs = 0;
863 register unsigned char *s;
868 SV * const targ = LvTARG(sv);
872 s = (unsigned char*)SvPV_force(targ, targlen);
874 /* This is handled by the SvPOK_only below...
875 if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
878 (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
881 (void)SvPOK_only(targ);
883 offset = LvTARGOFF(sv);
885 Perl_croak(aTHX_ "Negative offset to vec in lvalue context");
886 size = LvTARGLEN(sv);
887 if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
888 Perl_croak(aTHX_ "Illegal number of bits in vec");
891 bitoffs = ((offset%8)*size)%8;
897 len = offset + (bitoffs + size + 7)/8; /* required number of bytes */
899 s = (unsigned char*)SvGROW(targ, len + 1);
900 (void)memzero((char *)(s + targlen), len - targlen + 1);
901 SvCUR_set(targ, len);
905 mask = (1 << size) - 1;
907 s[offset] &= ~(mask << bitoffs);
908 s[offset] |= lval << bitoffs;
912 s[offset ] = (U8)( lval & 0xff);
913 else if (size == 16) {
914 s[offset ] = (U8)((lval >> 8) & 0xff);
915 s[offset+1] = (U8)( lval & 0xff);
917 else if (size == 32) {
918 s[offset ] = (U8)((lval >> 24) & 0xff);
919 s[offset+1] = (U8)((lval >> 16) & 0xff);
920 s[offset+2] = (U8)((lval >> 8) & 0xff);
921 s[offset+3] = (U8)( lval & 0xff);
924 else if (size == 64) {
925 if (ckWARN(WARN_PORTABLE))
926 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
927 "Bit vector size > 32 non-portable");
928 s[offset ] = (U8)((lval >> 56) & 0xff);
929 s[offset+1] = (U8)((lval >> 48) & 0xff);
930 s[offset+2] = (U8)((lval >> 40) & 0xff);
931 s[offset+3] = (U8)((lval >> 32) & 0xff);
932 s[offset+4] = (U8)((lval >> 24) & 0xff);
933 s[offset+5] = (U8)((lval >> 16) & 0xff);
934 s[offset+6] = (U8)((lval >> 8) & 0xff);
935 s[offset+7] = (U8)( lval & 0xff);
943 Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
948 if (SvTYPE(sv) == SVt_PVAV) {
950 AV* const av = (AV*)sv;
951 const I32 max = AvFILL(av);
953 for (i = 0; i <= max; i++) {
954 sv = (SV*)av_fetch(av, i, FALSE);
955 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
960 else if (SvTYPE(sv) == SVt_PVHV) {
961 HV* const hv = (HV*)sv;
963 (void)hv_iterinit(hv);
964 while ((entry = hv_iternext(hv)))
965 do_chop(astr,hv_iterval(hv,entry));
968 else if (SvREADONLY(sv)) {
970 /* SV is copy-on-write */
971 sv_force_normal_flags(sv, 0);
974 Perl_croak(aTHX_ PL_no_modify);
977 if (PL_encoding && !SvUTF8(sv)) {
978 /* like in do_chomp(), utf8-ize the sv as a side-effect
979 * if we're using encoding. */
980 sv_recode_to_utf8(sv, PL_encoding);
984 if (len && !SvPOK(sv))
985 s = SvPV_force(sv, len);
988 char * const send = s + len;
989 char * const start = s;
991 while (s > start && UTF8_IS_CONTINUATION(*s))
993 if (is_utf8_string((U8*)s, send - s)) {
994 sv_setpvn(astr, s, send - s);
996 SvCUR_set(sv, s - start);
1002 sv_setpvn(astr, "", 0);
1004 else if (s && len) {
1006 sv_setpvn(astr, s, 1);
1013 sv_setpvn(astr, "", 0);
1018 Perl_do_chomp(pTHX_ register SV *sv)
1023 char *temp_buffer = NULL;
1024 SV* svrecode = NULL;
1028 if (RsRECORD(PL_rs))
1031 if (SvTYPE(sv) == SVt_PVAV) {
1033 AV* const av = (AV*)sv;
1034 const I32 max = AvFILL(av);
1036 for (i = 0; i <= max; i++) {
1037 sv = (SV*)av_fetch(av, i, FALSE);
1038 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
1039 count += do_chomp(sv);
1043 else if (SvTYPE(sv) == SVt_PVHV) {
1044 HV* const hv = (HV*)sv;
1046 (void)hv_iterinit(hv);
1047 while ((entry = hv_iternext(hv)))
1048 count += do_chomp(hv_iterval(hv,entry));
1051 else if (SvREADONLY(sv)) {
1053 /* SV is copy-on-write */
1054 sv_force_normal_flags(sv, 0);
1057 Perl_croak(aTHX_ PL_no_modify);
1062 /* XXX, here sv is utf8-ized as a side-effect!
1063 If encoding.pm is used properly, almost string-generating
1064 operations, including literal strings, chr(), input data, etc.
1065 should have been utf8-ized already, right?
1067 sv_recode_to_utf8(sv, PL_encoding);
1074 if (RsPARA(PL_rs)) {
1078 while (len && s[-1] == '\n') {
1085 STRLEN rslen, rs_charlen;
1086 const char *rsptr = SvPV_const(PL_rs, rslen);
1088 rs_charlen = SvUTF8(PL_rs)
1089 ? sv_len_utf8(PL_rs)
1092 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
1093 /* Assumption is that rs is shorter than the scalar. */
1094 if (SvUTF8(PL_rs)) {
1095 /* RS is utf8, scalar is 8 bit. */
1096 bool is_utf8 = TRUE;
1097 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
1100 /* Cannot downgrade, therefore cannot possibly match
1102 assert (temp_buffer == rsptr);
1106 rsptr = temp_buffer;
1108 else if (PL_encoding) {
1109 /* RS is 8 bit, encoding.pm is used.
1110 * Do not recode PL_rs as a side-effect. */
1111 svrecode = newSVpvn(rsptr, rslen);
1112 sv_recode_to_utf8(svrecode, PL_encoding);
1113 rsptr = SvPV_const(svrecode, rslen);
1114 rs_charlen = sv_len_utf8(svrecode);
1117 /* RS is 8 bit, scalar is utf8. */
1118 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
1119 rsptr = temp_buffer;
1128 if (len < rslen - 1)
1132 if (memNE(s, rsptr, rslen))
1134 count += rs_charlen;
1137 s = SvPV_force_nolen(sv);
1146 SvREFCNT_dec(svrecode);
1148 Safefree(temp_buffer);
1153 Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
1163 register const char *lc;
1164 register const char *rc;
1165 register STRLEN len;
1174 if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
1175 sv_setpvn(sv, "", 0); /* avoid undef warning on |= and ^= */
1176 lsave = lc = SvPV_nomg_const(left, leftlen);
1177 rsave = rc = SvPV_nomg_const(right, rightlen);
1179 /* This need to come after SvPV to ensure that string overloading has
1182 left_utf = DO_UTF8(left);
1183 right_utf = DO_UTF8(right);
1185 if (left_utf && !right_utf) {
1186 /* Avoid triggering overloading again by using temporaries.
1187 Maybe there should be a variant of sv_utf8_upgrade that takes pvn
1189 right = sv_2mortal(newSVpvn(rsave, rightlen));
1190 sv_utf8_upgrade(right);
1191 rsave = rc = SvPV_nomg_const(right, rightlen);
1194 else if (!left_utf && right_utf) {
1195 left = sv_2mortal(newSVpvn(lsave, leftlen));
1196 sv_utf8_upgrade(left);
1197 lsave = lc = SvPV_nomg_const(left, leftlen);
1201 len = leftlen < rightlen ? leftlen : rightlen;
1204 (void)SvPOK_only(sv);
1205 if ((left_utf || right_utf) && (sv == left || sv == right)) {
1206 needlen = optype == OP_BIT_AND ? len : leftlen + rightlen;
1207 Newxz(dc, needlen + 1, char);
1209 else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
1210 dc = SvPV_force_nomg_nolen(sv);
1211 if (SvLEN(sv) < len + 1) {
1212 dc = SvGROW(sv, len + 1);
1213 (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
1215 if (optype != OP_BIT_AND && (left_utf || right_utf))
1216 dc = SvGROW(sv, leftlen + rightlen + 1);
1219 needlen = optype == OP_BIT_AND
1220 ? len : (leftlen > rightlen ? leftlen : rightlen);
1221 Newxz(dc, needlen + 1, char);
1222 sv_usepvn_flags(sv, dc, needlen, SV_HAS_TRAILING_NUL);
1223 dc = SvPVX(sv); /* sv_usepvn() calls Renew() */
1225 if (left_utf || right_utf) {
1228 char *dcsave = NULL;
1229 STRLEN lulen = leftlen;
1230 STRLEN rulen = rightlen;
1235 while (lulen && rulen) {
1236 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1239 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1243 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1245 if (sv == left || sv == right)
1246 (void)sv_usepvn(sv, dcorig, needlen);
1247 SvCUR_set(sv, dc - dcorig);
1250 while (lulen && rulen) {
1251 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1254 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1258 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1262 while (lulen && rulen) {
1263 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1266 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1270 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1274 dcsave = savepvn(rc, rulen);
1276 dcsave = savepvn(lc, lulen);
1277 if (sv == left || sv == right)
1278 (void)sv_usepvn(sv, dcorig, needlen); /* Uses Renew(). */
1279 SvCUR_set(sv, dc - dcorig);
1281 sv_catpvn(sv, dcsave, rulen);
1283 sv_catpvn(sv, dcsave, lulen);
1289 if (sv == left || sv == right)
1291 Perl_croak(aTHX_ "panic: do_vop called for op %u (%s)",
1292 (unsigned)optype, PL_op_name[optype]);
1299 if (len >= sizeof(long)*4 &&
1300 !((unsigned long)dc % sizeof(long)) &&
1301 !((unsigned long)lc % sizeof(long)) &&
1302 !((unsigned long)rc % sizeof(long))) /* It's almost always aligned... */
1304 const STRLEN remainder = len % (sizeof(long)*4);
1305 len /= (sizeof(long)*4);
1314 *dl++ = *ll++ & *rl++;
1315 *dl++ = *ll++ & *rl++;
1316 *dl++ = *ll++ & *rl++;
1317 *dl++ = *ll++ & *rl++;
1322 *dl++ = *ll++ ^ *rl++;
1323 *dl++ = *ll++ ^ *rl++;
1324 *dl++ = *ll++ ^ *rl++;
1325 *dl++ = *ll++ ^ *rl++;
1330 *dl++ = *ll++ | *rl++;
1331 *dl++ = *ll++ | *rl++;
1332 *dl++ = *ll++ | *rl++;
1333 *dl++ = *ll++ | *rl++;
1348 *dc++ = *lc++ & *rc++;
1353 *dc++ = *lc++ ^ *rc++;
1357 *dc++ = *lc++ | *rc++;
1361 sv_catpvn(sv, rsave + len, rightlen - len);
1362 else if (leftlen > (STRLEN)len)
1363 sv_catpvn(sv, lsave + len, leftlen - len);
1377 HV * const hv = (HV*)POPs;
1380 const I32 gimme = GIMME_V;
1381 const I32 dokv = (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV);
1382 const I32 dokeys = dokv || (PL_op->op_type == OP_KEYS);
1383 const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES);
1384 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
1387 if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
1388 dTARGET; /* make sure to clear its target here */
1389 if (SvTYPE(TARG) == SVt_PVLV)
1390 LvTARG(TARG) = NULL;
1396 keys = realhv ? hv : avhv_keys((AV*)hv);
1397 (void)hv_iterinit(keys); /* always reset iterator regardless */
1399 if (gimme == G_VOID)
1402 if (gimme == G_SCALAR) {
1406 if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */
1407 if (SvTYPE(TARG) < SVt_PVLV) {
1408 sv_upgrade(TARG, SVt_PVLV);
1409 sv_magic(TARG, NULL, PERL_MAGIC_nkeys, NULL, 0);
1412 if (LvTARG(TARG) != (SV*)keys) {
1414 SvREFCNT_dec(LvTARG(TARG));
1415 LvTARG(TARG) = SvREFCNT_inc_simple(keys);
1421 if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied))
1425 while (hv_iternext(keys)) i++;
1431 EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
1433 PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
1434 while ((entry = hv_iternext(keys))) {
1437 SV* const sv = hv_iterkeysv(entry);
1438 XPUSHs(sv); /* won't clobber stack_sp */
1444 hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry);
1445 DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
1446 (unsigned long)HeHASH(entry),
1448 (unsigned long)(HeHASH(entry) & HvMAX(keys))));
1459 * c-indentation-style: bsd
1461 * indent-tabs-mode: t
1464 * ex: set ts=8 sts=4 sw=4 noet: