source: trunk/third/perl/doop.c @ 14545

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